From eebc79853176d1c69bac0a141518bb1a6a018d83 Mon Sep 17 00:00:00 2001 From: Daniel Wortmann Date: Wed, 26 Jul 2017 15:07:37 +0200 Subject: [PATCH] Added new wannier routines from JPH --- wannier/abcof_small.F | 340 +++++++ wannier/uhu/d2fdz2.F | 47 + wannier/uhu/d2fdz2cmplx.F | 63 ++ wannier/uhu/dujdr.F | 63 ++ wannier/uhu/wann_uHu.F | 1460 ++++++++++++++++++++++++++++ wannier/uhu/wann_uHu_commat.f | 429 ++++++++ wannier/uhu/wann_uHu_commat_save.f | 353 +++++++ wannier/uhu/wann_uHu_dmi.F | 1431 +++++++++++++++++++++++++++ wannier/uhu/wann_uHu_int.F | 152 +++ wannier/uhu/wann_uHu_int2.F | 53 + wannier/uhu/wann_uHu_od_vac.F | 561 +++++++++++ wannier/uhu/wann_uHu_radintsra.F | 107 ++ wannier/uhu/wann_uHu_radintsra2.F | 86 ++ wannier/uhu/wann_uHu_radintsra3.F | 70 ++ wannier/uhu/wann_uHu_radintsra4.F | 70 ++ wannier/uhu/wann_uHu_radintsra5.F | 120 +++ wannier/uhu/wann_uHu_soc.F | 456 +++++++++ wannier/uhu/wann_uHu_soc_tlo.F | 517 ++++++++++ wannier/uhu/wann_uHu_sph.F | 234 +++++ wannier/uhu/wann_uHu_symcheck.F | 71 ++ wannier/uhu/wann_uHu_tlmplm.F | 779 +++++++++++++++ wannier/uhu/wann_uHu_tlmplm2.F | 715 ++++++++++++++ wannier/uhu/wann_uHu_tlo.F | 832 ++++++++++++++++ wannier/uhu/wann_uHu_util.F | 54 + wannier/uhu/wann_uHu_vac.F | 657 +++++++++++++ wannier/uhu/wann_write_uHu.F | 151 +++ wannier/wann_1dvacabcof.F | 151 +++ wannier/wann_get_qpts.f | 72 ++ wannier/wann_gwf_anglmom.f | 82 ++ wannier/wann_gwf_auxbrav.F | 43 + wannier/wann_gwf_auxovlp.F | 37 + wannier/wann_gwf_commat.f | 460 +++++++++ wannier/wann_gwf_commat2.f | 360 +++++++ wannier/wann_gwf_commat_old.f | 251 +++++ wannier/wann_gwf_tools.f | 166 ++++ wannier/wann_gwf_write_mmnk.F | 59 ++ wannier/wann_maxbnd.F | 79 ++ wannier/wann_mmkb_int2.F | 104 ++ wannier/wann_mmkb_od_vac2.F | 331 +++++++ wannier/wann_mmkb_sph2.F | 247 +++++ wannier/wann_nocoplot.F | 308 ++++++ wannier/wann_orbmag.F | 925 ++++++++++++++++++ wannier/wann_postproc_setup4.f | 157 +++ wannier/wann_postproc_setup5.f | 157 +++ wannier/wann_write_mmnk2.F | 107 ++ 45 files changed, 13967 insertions(+) create mode 100644 wannier/abcof_small.F create mode 100644 wannier/uhu/d2fdz2.F create mode 100644 wannier/uhu/d2fdz2cmplx.F create mode 100644 wannier/uhu/dujdr.F create mode 100644 wannier/uhu/wann_uHu.F create mode 100644 wannier/uhu/wann_uHu_commat.f create mode 100644 wannier/uhu/wann_uHu_commat_save.f create mode 100644 wannier/uhu/wann_uHu_dmi.F create mode 100644 wannier/uhu/wann_uHu_int.F create mode 100644 wannier/uhu/wann_uHu_int2.F create mode 100644 wannier/uhu/wann_uHu_od_vac.F create mode 100644 wannier/uhu/wann_uHu_radintsra.F create mode 100644 wannier/uhu/wann_uHu_radintsra2.F create mode 100644 wannier/uhu/wann_uHu_radintsra3.F create mode 100644 wannier/uhu/wann_uHu_radintsra4.F create mode 100644 wannier/uhu/wann_uHu_radintsra5.F create mode 100644 wannier/uhu/wann_uHu_soc.F create mode 100644 wannier/uhu/wann_uHu_soc_tlo.F create mode 100644 wannier/uhu/wann_uHu_sph.F create mode 100644 wannier/uhu/wann_uHu_symcheck.F create mode 100644 wannier/uhu/wann_uHu_tlmplm.F create mode 100644 wannier/uhu/wann_uHu_tlmplm2.F create mode 100644 wannier/uhu/wann_uHu_tlo.F create mode 100644 wannier/uhu/wann_uHu_util.F create mode 100644 wannier/uhu/wann_uHu_vac.F create mode 100644 wannier/uhu/wann_write_uHu.F create mode 100644 wannier/wann_1dvacabcof.F create mode 100644 wannier/wann_get_qpts.f create mode 100644 wannier/wann_gwf_anglmom.f create mode 100644 wannier/wann_gwf_auxbrav.F create mode 100644 wannier/wann_gwf_auxovlp.F create mode 100644 wannier/wann_gwf_commat.f create mode 100644 wannier/wann_gwf_commat2.f create mode 100644 wannier/wann_gwf_commat_old.f create mode 100644 wannier/wann_gwf_tools.f create mode 100644 wannier/wann_gwf_write_mmnk.F create mode 100644 wannier/wann_maxbnd.F create mode 100644 wannier/wann_mmkb_int2.F create mode 100644 wannier/wann_mmkb_od_vac2.F create mode 100644 wannier/wann_mmkb_sph2.F create mode 100644 wannier/wann_nocoplot.F create mode 100644 wannier/wann_orbmag.F create mode 100644 wannier/wann_postproc_setup4.f create mode 100644 wannier/wann_postproc_setup5.f create mode 100644 wannier/wann_write_mmnk2.F diff --git a/wannier/abcof_small.F b/wannier/abcof_small.F new file mode 100644 index 00000000..2abb62da --- /dev/null +++ b/wannier/abcof_small.F @@ -0,0 +1,340 @@ + MODULE m_abcof_small + CONTAINS + SUBROUTINE abcof_small( + > lmaxd,ntypd,neigd,nobd,natd,nop,nvd,jspd, + > lmd,nbasfcn,llod,nlod,nlotot,invtab, + > ntype,mrot,ngopr,taual,neq,lmax,rmt,omtil, + > bmat,bbmat,bkpt,k1,k2,k3,nv,nmat,ne,z, + > us,dus,uds,duds,ddn,invsat,invsatnr, + > ulos,uulon,dulon,dulos,llo,nlo,l_dulo,lapw_l, + > l_noco,l_ss,jspin,alph,beta,qss,kveclo,odi,ods, + < acof,bcof,ccof,nig) +c ************************************************************ +c subroutine constructs the a,b coefficients of the linearized +c m.t. wavefunctions for each band and atom. c.l. fu +c ************************************************************ +#include "cpp_double.h" + + USE m_cotra, ONLY : cotra3 + USE m_constants, ONLY : pimach + USE m_dotir, ONLY : dotirp + USE m_setabc1locdn + USE m_sphbes + USE m_dsphbs + USE m_abclocdn + USE m_ylm + USE m_od_types, ONLY : od_inp, od_sym + + IMPLICIT NONE +C .. +C .. Scalar Arguments .. + INTEGER, INTENT (IN) :: lmaxd,ntypd,neigd,nobd,natd,nop,nvd,jspd + INTEGER, INTENT (IN) :: ne,ntype,nmat,nbasfcn,llod,nlod,lmd + REAL, INTENT (IN) :: omtil + INTEGER, INTENT (IN) :: jspin,nlotot,nig + LOGICAL, INTENT (IN) :: l_noco,l_ss +C .. +C .. Array Arguments .. + INTEGER, INTENT (IN) :: mrot(3,3,nop),ngopr(natd),lmax(ntypd) + INTEGER, INTENT (IN) :: k1(nvd,jspd),k2(nvd,jspd),k3(nvd,jspd) + INTEGER, INTENT (IN) :: nv(jspd),lapw_l(ntypd),invtab(nop) + INTEGER, INTENT (IN) :: neq(ntypd),invsat(natd),invsatnr(natd) + INTEGER, INTENT (IN) :: nlo(ntypd),llo(nlod,ntypd),kveclo(nlotot) + REAL, INTENT (IN) :: bmat(3,3),bbmat(3,3),bkpt(3) + REAL, INTENT (IN) :: taual(3,natd),rmt(ntypd) + REAL, INTENT (IN) :: dus(0:lmaxd,ntypd),duds(0:lmaxd,ntypd) + REAL, INTENT (IN) :: us(0:lmaxd,ntypd), uds(0:lmaxd,ntypd) + REAL, INTENT (IN) :: ulos(nlod,ntypd),uulon(nlod,ntypd) + REAL, INTENT (IN) :: dulon(nlod,ntypd),dulos(nlod,ntypd) + REAL, INTENT (IN) :: ddn(0:lmaxd,ntypd) + REAL, INTENT (IN) :: alph(ntypd),beta(ntypd),qss(3) +#if ( !defined(CPP_INVERSION) || defined(CPP_SOC) ) + COMPLEX, INTENT (IN) :: z(nbasfcn,neigd) +#else + REAL, INTENT (IN) :: z(nbasfcn,neigd) +#endif + LOGICAL, INTENT (IN) :: l_dulo(nlod,ntypd) + COMPLEX, INTENT (OUT):: acof(nobd,0:lmd,natd) + COMPLEX, INTENT (OUT):: bcof(nobd,0:lmd,natd) + COMPLEX, INTENT (OUT):: ccof(-llod:llod,nobd,nlod,natd) +c-odim + TYPE (od_inp), INTENT (IN) :: odi + TYPE (od_sym), INTENT (IN) :: ods +c+odim +C .. +C .. Local Scalars .. + COMPLEX phase,cexp,c_0,c_1,c_2,ci + REAL const,df,r1,s,tmk,wronk,tpi,qss1,qss2,qss3 + INTEGER i,j,k,l,ll1,lm,m,n,nap,natom,nn,iatom,jatom,lmp + INTEGER inv_f,ie,ilo,kspin,iintsp,nintsp,nvmax,lo,inap +C .. +C .. Local Arrays .. + INTEGER kvec(2*(2*llod+1),nlod,natd) + INTEGER nbasf0(nlod,natd),nkvec(nlod,natd) + REAL dfj(0:lmaxd),fj(0:lmaxd),fk(3),fkp(3),fkr(3) + REAL alo1(nlod,ntypd),blo1(nlod,ntypd),clo1(nlod,ntypd) + COMPLEX ylm( (lmaxd+1)**2 ) + COMPLEX ccchi(2,2) + LOGICAL enough(natd),apw(0:lmaxd,ntypd) +#if ( !defined(CPP_INVERSION) || defined(CPP_SOC) ) + COMPLEX, ALLOCATABLE :: work(:) +#else + REAL, ALLOCATABLE :: work(:) +#endif +C .. +C .. Intrinsic Functions .. + INTRINSIC cmplx,conjg,exp,sqrt +C .. + ci = cmplx(0.0,1.0) + tpi = 2 * pimach() + const = 2 * tpi/sqrt(omtil) +c + acof(:,:,:) = cmplx(0.0,0.0) + bcof(:,:,:) = cmplx(0.0,0.0) + ALLOCATE ( work(nobd) ) +C .. +c+APW_LO + DO n = 1, ntype + DO l = 0,lmax(n) + apw(l,n) = .false. + DO lo = 1,nlo(n) + IF (l_dulo(lo,n)) apw(l,n) = .true. + ENDDO +#ifdef CPP_APW + IF (lapw_l(n).GE.l) apw(l,n) = .false. +#endif + ENDDO + DO lo = 1,nlo(n) + IF (l_dulo(lo,n)) apw(llo(lo,n),n) = .true. + ENDDO + ENDDO +c+APW_LO +c + nintsp = 1 + IF (l_ss) nintsp = 2 +c---> loop over the interstitial spin + DO iintsp = 1,nintsp + nvmax = nv(jspin) + IF (l_ss) nvmax = nv(iintsp) +c + CALL setabc1locdn( + > ntypd,natd,nlod,llod,nobd,lmaxd,nvmax, + > nmat,ne,ntype,neq,l_noco,iintsp, + > nlo,llo,l_dulo,invsat,invsatnr,ddn, + > us,dus,uds,duds,dulos,ulos,dulon,uulon, + > nlotot,kveclo, + < enough,nkvec,kvec,nbasf0,ccof, + < alo1,blo1,clo1) +c + IF (iintsp .EQ. 1) THEN + qss1= - qss(1)/2 + qss2= - qss(2)/2 + qss3= - qss(3)/2 + ELSE + qss1= + qss(1)/2 + qss2= + qss(2)/2 + qss3= + qss(3)/2 + ENDIF + + k = nig + +c---> loop over atom types + natom = 0 + DO n = 1,ntype +c ----> loop over equivalent atoms + DO nn = 1,neq(n) + natom = natom + 1 + IF ((invsat(natom).EQ.0) .OR. (invsat(natom).EQ.1)) THEN +c---> loop over lapws + !DO k = 1,nvmax + IF (.NOT.l_noco) THEN + DO i = 1,ne + work(i) = z(k,i) + ENDDO + ENDIF + + IF (l_noco) THEN +c---> generate the complex conjgates of the spinors (chi) + ccchi(1,1) = conjg( exp(-ci*alph(n)/2)*cos(beta(n)/2)) + ccchi(1,2) = conjg(-exp(-ci*alph(n)/2)*sin(beta(n)/2)) + ccchi(2,1) = conjg( exp( ci*alph(n)/2)*sin(beta(n)/2)) + ccchi(2,2) = conjg( exp( ci*alph(n)/2)*cos(beta(n)/2)) + IF (l_ss) THEN +c---> the coefficients of the spin-down basis functions are +c---> stored in the second half of the eigenvector + kspin = (iintsp-1)*(nv(1)+nlotot) + DO i = 1,ne + work(i) = ccchi(iintsp,jspin)*z(kspin+k,i) + ENDDO + ELSE +c---> perform sum over the two interstitial spin directions +c---> and take into account the spin boundary conditions +c---> (jspin counts the local spin directions inside each MT) + kspin = nv(1)+nlotot + DO i = 1,ne + work(i) = ccchi(1,jspin)*z(k,i) + + + ccchi(2,jspin)*z(kspin+k,i) + ENDDO + ENDIF + ENDIF ! (l_noco) + IF (l_ss) THEN + fk(1) = bkpt(1) + k1(k,iintsp) + qss1 + fk(2) = bkpt(2) + k2(k,iintsp) + qss2 + fk(3) = bkpt(3) + k3(k,iintsp) + qss3 + ELSE + fk(1) = bkpt(1) + k1(k,jspin) + qss1 + fk(2) = bkpt(2) + k2(k,jspin) + qss2 + fk(3) = bkpt(3) + k3(k,jspin) + qss3 + ENDIF ! (l_ss) + s = dotirp(fk,fk,bbmat) + s = sqrt(s) + r1 = rmt(n)*s + CALL sphbes( + > lmax(n),r1, + < fj) + CALL dsphbs( + > lmax(n),r1,fj, + < dfj) +c ----> construct a and b coefficients + DO l = 0,lmax(n) + df = s*dfj(l) + wronk = uds(l,n)*dus(l,n) - us(l,n)*duds(l,n) + IF (apw(l,n)) THEN + fj(l) = 1.0*const * fj(l)/us(l,n) + dfj(l) = 0.0d0 + ELSE + dfj(l) = const* (dus(l,n)*fj(l)-df*us(l,n))/wronk + fj(l) = const* (df*uds(l,n)-fj(l)*duds(l,n))/wronk + ENDIF + ENDDO ! loop over l + tmk = tpi* (fk(1)*taual(1,natom)+ + + fk(2)*taual(2,natom)+ + + fk(3)*taual(3,natom)) + phase = cmplx(cos(tmk),sin(tmk)) + IF (odi%d1) THEN + inap = ods%ngopr(natom) + ELSE + nap = ngopr(natom) + inap = invtab(nap) + END IF + DO j = 1,3 + fkr(j) = 0. + DO i = 1,3 + IF (odi%d1) THEN + fkr(j) = fkr(j) + fk(i)*ods%mrot(i,j,inap) + ELSE + fkr(j) = fkr(j) + fk(i)*mrot(i,j,inap) + END IF + ENDDO + ENDDO + CALL cotra3(fkr,fkp,bmat) +c ----> generate spherical harmonics + CALL ylm4( + > lmax(n),fkp, + < ylm) +c ----> loop over l + DO l = 0,lmax(n) + ll1 = l* (l+1) +c ----> loop over m + DO m = -l,l + lm = ll1 + m + c_0 = conjg(ylm(lm+1))*phase + c_1 = c_0 * fj(l) + c_2 = c_0 * dfj(l) +c ----> loop over bands + DO i = 1,ne + acof(i,lm,natom) = acof(i,lm,natom) + + + c_1 * work(i) + ENDDO + DO i = 1,ne + bcof(i,lm,natom) = bcof(i,lm,natom) + + + c_2 * work(i) + ENDDO +#if ( defined(CPP_SOC) && defined(CPP_INVERSION) ) + IF (invsat(natom).EQ.1) THEN + jatom = invsatnr(natom) + lmp = ll1 - m + inv_f = (-1)**(l-m) + c_1 = conjg(c_1) * inv_f + c_2 = conjg(c_2) * inv_f + CALL CPP_BLAS_caxpy(ne,c_1,work,1, + X acof(1,lmp,jatom),1) + CALL CPP_BLAS_caxpy(ne,c_2,work,1, + X bcof(1,lmp,jatom),1) + ENDIF +#endif + ENDDO ! loop over m + ENDDO ! loop over l + IF (.NOT.enough(natom)) THEN + write(*,*)'.not.enough(natom)' + CALL abclocdn( + > nobd,natd,nlod,llod,lmaxd,neigd,ntypd, + > lmd,nbasfcn,nlo,llo,invsat,invsatnr, + > l_noco,ccchi(1,jspin),kspin,l_ss,iintsp, + > const,rmt(n),phase,ylm,n,natom,k,s,nvmax, + > ne,z,nbasf0,alo1,blo1,clo1,kvec(1,1,natom), + < nkvec,enough,acof,bcof,ccof) + ENDIF + !ENDDO ! loop over LAPWs + ENDIF ! invsatom == ( 0 v 1 ) + ENDDO ! loop over equivalent atoms + ENDDO ! loop over atom types + ENDDO ! loop over interstitial spin + +#if ( defined(CPP_SOC) && defined(CPP_INVERSION) ) +! +! -p,n (l+m) p,n * +! Usually, we exploit that A = (-1) (A ) if p and -p are the positions +! l,m l,-m +! of two atoms related by inversion symmetry and the coefficients are considered to +! be in the local frame of the representative atom. This is possible, if z is real. +! After SOC, however, the eigenvectors z are complex and this is no longer possible +! so the z has to enter, not z*. This is done within the k-loop. +! -p,n m p,n * +! When called from hsohelp, we need A = (-1) (A ) because we don't have to +! l,m l,-m l +! rotate, but in the sums in hsoham only products A* A enter and the (-1) cancels. +! lm lm +#else + iatom = 0 + DO n = 1,ntype + DO nn = 1,neq(n) + iatom = iatom + 1 + IF (invsat(iatom).EQ.1) THEN + jatom = invsatnr(iatom) + cexp = exp(tpi*ci*dot_product(taual(:,jatom) + + + taual(:,iatom),(/bkpt(1),bkpt(2),bkpt(3)/))) + DO ilo = 1,nlo(n) + l = llo(ilo,n) + DO m = -l,l + inv_f = (-1.0)**(m+l) + DO ie = 1,ne + ccof(m,ie,ilo,jatom) = inv_f * cexp * + + conjg( ccof(-m,ie,ilo,iatom)) + ENDDO + ENDDO + ENDDO + DO l = 0,lmax(n) + ll1 = l* (l+1) + DO m =-l,l + lm = ll1 + m + lmp = ll1 - m + inv_f = (-1.0)**(m+l) + DO ie = 1,ne + acof(ie,lm,jatom) = inv_f * cexp * + * conjg(acof(ie,lmp,iatom)) + ENDDO + DO ie = 1,ne + bcof(ie,lm,jatom) = inv_f * cexp * + * conjg(bcof(ie,lmp,iatom)) + ENDDO + ENDDO + ENDDO + ENDIF + ENDDO + ENDDO +#endif + DEALLOCATE ( work ) +c + END SUBROUTINE abcof_small + END MODULE m_abcof_small diff --git a/wannier/uhu/d2fdz2.F b/wannier/uhu/d2fdz2.F new file mode 100644 index 00000000..680ad5c4 --- /dev/null +++ b/wannier/uhu/d2fdz2.F @@ -0,0 +1,47 @@ + MODULE m_d2fdz2 + CONTAINS + + SUBROUTINE d2fdz2(jmtd,jri,rmsh,dx,f,fac,d2f) + + IMPLICIT NONE + + REAL difcub + EXTERNAL difcub + + REAL, INTENT(INOUT) :: d2f(jmtd) + REAL, INTENT(IN) :: fac(jmtd) + REAL, INTENT(IN) :: f(jmtd) + REAL, INTENT(IN) :: rmsh(jmtd) + REAL, INTENT(IN) :: dx + + INTEGER, INTENT(IN) :: jri + INTEGER, INTENT(IN) :: jmtd + + REAL, ALLOCATABLE :: fr(:),dfr(:) + INTEGER :: i + + allocate( dfr(jri),fr(jri) ) + DO i=1,jri + fr(i) = f(i)*fac(i) + ENDDO + + dfr(1) = difcub( rmsh(1),fr(1),rmsh(1) ) + DO i = 2, jri-2 + dfr(i) = difcub( rmsh(i-1),fr(i-1),rmsh(i) ) + ENDDO + dfr(jri-1) = difcub( rmsh(jri-3),fr(jri-3),rmsh(jri-1) ) + dfr(jri) = difcub( rmsh(jri-3),fr(jri-3),rmsh(jri) ) + + + d2f(1) = difcub( rmsh(1),dfr(1),rmsh(1) ) + DO i = 2, jri-2 + d2f(i) = difcub( rmsh(i-1),dfr(i-1),rmsh(i) ) + ENDDO + d2f(jri-1) = difcub( rmsh(jri-3),dfr(jri-3),rmsh(jri-1) ) + d2f(jri) = difcub( rmsh(jri-3),dfr(jri-3),rmsh(jri) ) + + + deallocate( dfr,fr ) + + END SUBROUTINE d2fdz2 + END MODULE m_d2fdz2 diff --git a/wannier/uhu/d2fdz2cmplx.F b/wannier/uhu/d2fdz2cmplx.F new file mode 100644 index 00000000..e6422194 --- /dev/null +++ b/wannier/uhu/d2fdz2cmplx.F @@ -0,0 +1,63 @@ + MODULE m_d2fdz2cmplx + CONTAINS + + SUBROUTINE d2fdz2cmplx(jmtd,jri,rmsh,dx,f,fac,d2f) + + IMPLICIT NONE + + REAL difcub + EXTERNAL difcub + + COMPLEX, INTENT(INOUT) :: d2f(jmtd) + COMPLEX, INTENT(IN) :: fac(jmtd) + + REAL, INTENT(IN) :: f(jmtd) + REAL, INTENT(IN) :: rmsh(jmtd) + REAL, INTENT(IN) :: dx + + INTEGER, INTENT(IN) :: jri + INTEGER, INTENT(IN) :: jmtd + + REAL, ALLOCATABLE :: fr(:),fi(:),dfr(:),dfi(:) + INTEGER :: i + + allocate( dfr(jri),dfi(jri),fr(jri),fi(jri) ) + DO i=1,jri + fr(i) = f(i)*real(fac(i)) + fi(i) = f(i)*aimag(fac(i)) + ENDDO + + dfr(1) = difcub( rmsh(1),fr(1),rmsh(1) ) + dfi(1) = difcub( rmsh(1),fi(1),rmsh(1) ) + DO i = 2, jri-2 + dfr(i) = difcub( rmsh(i-1),fr(i-1),rmsh(i) ) + dfi(i) = difcub( rmsh(i-1),fi(i-1),rmsh(i) ) + ENDDO + dfr(jri-1) = difcub( rmsh(jri-3),fr(jri-3),rmsh(jri-1) ) + dfi(jri-1) = difcub( rmsh(jri-3),fi(jri-3),rmsh(jri-1) ) + dfr(jri) = difcub( rmsh(jri-3),fr(jri-3),rmsh(jri) ) + dfi(jri) = difcub( rmsh(jri-3),fi(jri-3),rmsh(jri) ) + + + d2f(1) = cmplx( difcub( rmsh(1),dfr(1),rmsh(1) ), + > difcub( rmsh(1),dfi(1),rmsh(1) ) ) + DO i = 2, jri-2 + d2f(i) = cmplx( difcub( rmsh(i-1),dfr(i-1),rmsh(i) ), + > difcub( rmsh(i-1),dfi(i-1),rmsh(i) ) ) + ENDDO + d2f(jri-1) = cmplx( difcub( rmsh(jri-3),dfr(jri-3),rmsh(jri-1) ), + > difcub( rmsh(jri-3),dfi(jri-3),rmsh(jri-1) ) ) + d2f(jri) = cmplx( difcub( rmsh(jri-3),dfr(jri-3),rmsh(jri) ), + > difcub( rmsh(jri-3),dfi(jri-3),rmsh(jri) ) ) + + deallocate( dfr,dfi,fr,fi ) + +c d2f = cmplx(0.,0.) +c d2f(1) = (f(3)-2*f(2)+f(1))/dx/dx +c do i=2,jri-1 +c d2f(i) = (f(i+1)-2*f(i)+f(i-1))/dx/dx +c enddo +c d2f(jri) = (f(jri-2)-2*f(jri-1)+f(jri))/dx/dx + + END SUBROUTINE d2fdz2cmplx + END MODULE m_d2fdz2cmplx diff --git a/wannier/uhu/dujdr.F b/wannier/uhu/dujdr.F new file mode 100644 index 00000000..44fbd2ec --- /dev/null +++ b/wannier/uhu/dujdr.F @@ -0,0 +1,63 @@ + MODULE m_dujdr + CONTAINS + + SUBROUTINE dujdr(jmtd,jri,rmsh,dx,ub,j2,b,l,lmaxd,dub) + + USE m_constants + IMPLICIT NONE + + REAL difcub + EXTERNAL difcub + + REAL, INTENT(IN) :: rmsh(jmtd),dx + REAL, INTENT(IN) :: ub(jmtd,2) ! u(b2) + REAL, INTENT(IN) :: j2(0:lmaxd,jmtd) ! j_l(b2*r) + REAL, INTENT(IN) :: b ! b2 + INTEGER, INTENT(IN) :: jri,jmtd,lmaxd + INTEGER, INTENT(IN) :: l ! l of sph. Bessel j2 + + REAL, INTENT(OUT) :: dub(jmtd,2) + REAL :: xi,t(jri,2) + INTEGER :: i,j + + ! derivatives d/dr for large and small component of q + DO i=1,jri + t(i,:) = ub(i,:) / rmsh(i) * j2(l,i) + ENDDO + + DO j = 1, 2 + ! derivative at 1st point + dub(1,j) = difcub( rmsh(1),t(1,j),rmsh(1) ) + + ! derivative at 2nd...(jri-2)th point + DO i = 2, jri-2 + dub(i,j) = difcub( rmsh(i-1),t(i-1,j),rmsh(i) ) + ENDDO + + ! derivative at last two points + dub(jri-1,j) = difcub( rmsh(jri-3),t(jri-3,j),rmsh(jri-1) ) + dub(jri,j) = difcub( rmsh(jri-3),t(jri-3,j),rmsh(jri) ) + ENDDO + + DO i=1,jri + dub(i,:) = dub(i,:)*rmsh(i) + ENDDO + + ! complete d/dr (ub*j2) = ub'j2 + ub j2' with sph. Bessel func. j + ! rule: j'_{l}(ar) = a*j_{l-1}(ar) - (l+1)/r*j_{l}(ar) +c IF(l.ne.0) THEN +c DO i=1,jri +c xi = rmsh(i) +c dub(i,:) = dub(i,:) * j2(l,i) * xi +c > + ub(i,:) *( j2(l-1,i)*b - (l+1)/xi*j2(l,i) ) +c ENDDO +c ELSE +c DO i=1,jri +c xi = rmsh(i) +c dub(i,:) = dub(i,:) * j2(l,i) * xi +c > - ub(i,:) * j2(1,i) * b +c ENDDO +c ENDIF + + END SUBROUTINE dujdr + END MODULE m_dujdr diff --git a/wannier/uhu/wann_uHu.F b/wannier/uhu/wann_uHu.F new file mode 100644 index 00000000..76e200bc --- /dev/null +++ b/wannier/uhu/wann_uHu.F @@ -0,0 +1,1460 @@ +c*******************************************c +c Set up uHu matrix necessary for c +c Wannier-based calc. of orbital moment c +c*******************************************c +c keyword is 'matrixuhu' in wann_inp c +c*******************************************c +c uHu = < u_{k+b1} | H_{k} | u_{k+b2} > c +c c +c Contributions to Hamiltonian: c +c (i) interstitial c +c (ii) muffin tin (a) spherical c +c (b) non-sph. c +c (c) SOC c +c (iii) vacuum c +c*******************************************c +c J.-P. Hanke, Dec. 2015 c +c*******************************************c + MODULE m_wann_uHu + USE m_fleurenv + CONTAINS + SUBROUTINE wann_uHu( + > 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,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,zrfs,ig2,area,tau,zatom,nq2,kv2,nop2, + > volint,symor,pos,ef,irecl,l_soc, + > memd,lnonsph,clnu,lmplmd,mlh,nmem,llh,lo1l, + > theta,phi,soc_opt, + > l_ms,l_sgwf,l_socgwf,aux_latt_const, + > param_file,param_vec,nparampts,param_alpha,l_dim) + + 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, only : cdn_read0, cdn_read + use m_od_types, only : od_inp, od_sym + use m_loddop + use m_constants, only : pimach + use m_wann_projmethod + use m_wann_abinv + use m_wann_kptsrotate + use m_wann_read_inp + use m_matmul,only : matmul3,matmul3r + use m_wann_maxbnd + use m_wann_uHu_tlmplm + use m_wann_uHu_sph + use m_wann_uHu_int + use m_wann_uHu_soc + use m_wann_uHu_vac + use m_wann_uHu_od_vac + use m_wann_uHu_util + use m_wann_uHu_commat + use m_wann_write_uHu + + IMPLICIT NONE +#include "cpp_double.h" +#ifdef CPP_MPI + include 'mpif.h' + integer ierr(3) + integer cpu_index + integer stt(MPI_STATUS_SIZE) +#endif +c ..scalar arguments.. + character(len=20),intent(in) :: param_file + type (od_inp), intent (in) :: odi + type (od_sym), intent (in) :: ods + logical, intent (in) :: invs,invs2,film,slice,symor,zrfs + logical, intent (in) :: l_noco,l_ss,l_soc + logical, intent (in) :: l_ms,l_sgwf,l_socgwf + integer, intent (in) :: lmaxd,ntypd,neigd,nkptd,kk,nnne + integer, intent (in) :: natd,nop,nvd,jspd,nbasfcn,nq2,nop2 + integer, intent (in) :: llod,nlod,ntype,nwdd,n3d,n2d + integer, intent (in) :: nmzxyd,nmzd,jmtd,nlhd,nq3,nvac + integer, intent (in) :: ntypsd,jspins,k1d,k2d,k3d + integer, intent (in) :: irank,isize,nv2d,nmzxy,nmz + integer, intent (in) :: irecl,memd,lmplmd,nparampts + real, intent (in) :: omtil,e1s,e2s,delz,area,z1,volint + real, intent (in) :: ef,theta,phi,aux_latt_const + +c ..array arguments.. + logical, intent (in) :: l_dulo(nlod,ntypd) + logical, intent (in) :: soc_opt(ntype+2),l_dim(3) + integer, intent (in) :: ig(-k1d:k1d,-k2d:k2d,-k3d:k3d) + integer, intent (in) :: nlh(ntypsd),jri(ntypd),ntypsy(natd) + integer, intent (in) :: nlo(ntypd),llo(nlod,ntypd),lapw_l(ntypd) + integer, intent (in) :: invtab(nop),mrot(3,3,nop),ngopr(natd) + integer, intent (in) :: neq(ntypd),lmax(ntypd) + integer, intent (in) :: invsat(natd),invsatnr(natd),nkpt(nwdd) + integer, intent (in) :: ulo_der(nlod,ntypd),ig2(n3d),kv2(2,n2d) + integer, intent (in) :: mlh(memd,0:nlhd,ntypsd) + integer, intent (in) :: nmem(0:nlhd,ntypsd) + integer, intent (in) :: llh(0:nlhd,ntypsd),lnonsph(ntypd) + integer, intent (in) :: lo1l(0:llod,ntypd) + real, intent (in) :: rgphs(-k1d:k1d,-k2d:k2d,-k3d:k3d) + real, intent (in) :: taual(3,natd),rmt(ntypd),dx(ntypd) + real, intent (in) :: amat(3,3),bmat(3,3),bbmat(3,3) + real, intent (in) :: rmsh(jmtd,ntypd),tau(3,nop),zatom(ntype) + real, intent (inout) :: alph(ntypd),beta(ntypd),qss(3) + real, intent (in) :: pos(3,natd),sk2(n2d),phi2(n2d) + real, intent (in) :: param_vec(3,nparampts) + real, intent (in) :: param_alpha(ntypd,nparampts) + complex, intent (in) :: ustep(n3d) + complex, intent (in) :: clnu(memd,0:nlhd,ntypsd) + +c ..allocatable arrays.. + integer, allocatable :: kveclo(:) , nv(:) + integer, allocatable :: kveclo_b(:) , nv_b(:) + integer, allocatable :: kveclo_b2(:), nv_b2(:) + integer, allocatable :: k1(:,:) , k2(:,:) , k3(:,:) + integer, allocatable :: k1_b(:,:) , k2_b(:,:) , k3_b(:,:) + integer, allocatable :: k1_b2(:,:), k2_b2(:,:), k3_b2(:,:) + integer, allocatable :: irreduc(:),mapkoper(:) + integer, allocatable :: irreduc_q(:),mapqoper(:) + integer, allocatable :: shiftkpt(:,:),pair_to_do(:,:) + integer, allocatable :: shiftqpt(:,:),pair_to_do_q(:,:) + integer, allocatable :: maptopair(:,:,:) + integer, allocatable :: maptopair_q(:,:,:) + integer, allocatable :: counts(:),displs(:) + integer, allocatable :: gb(:,:,:),bpt(:,:) + integer, allocatable :: gb_q(:,:,:),bpt_q(:,:) + real, allocatable :: we(:),we_b(:),we_b2(:) + real, allocatable :: eigg(:) + real, allocatable :: vr(:,:,:),vz(:,:,:),vrf(:,:,:,:) + real, allocatable :: flo(:,:,:,:,:) + real, allocatable :: ff(:,:,:,:,:),gg(:,:,:,:,:) + real, allocatable :: us(:,:,:),uds(:,:,:),ulos(:,:,:) + real, allocatable :: dus(:,:,:),duds(:,:,:),dulos(:,:,:) + real, allocatable :: ddn(:,:,:),uulon(:,:,:),dulon(:,:,:) + real, allocatable :: uloulopn(:,:,:,:) + real, allocatable :: kdiff(:,:),qdiff(:,:),zero_qdiff(:,:) + complex, allocatable :: vpw(:,:),vzxy(:,:,:,:) + complex, allocatable :: uHu(:,:,:,:,:) +c complex, allocatable :: uHuold(:,:) + complex, allocatable :: acof_b(:,:,:),acof_b2(:,:,:) + complex, allocatable :: bcof_b(:,:,:),bcof_b2(:,:,:) + complex, allocatable :: ccof_b(:,:,:,:),ccof_b2(:,:,:,:) + complex, allocatable :: tdd(:,:,:,:,:),tdu(:,:,:,:,:) + complex, allocatable :: tud(:,:,:,:,:),tuu(:,:,:,:,:) + complex, allocatable :: tdulo(:,:,:,:,:,:),tuulo(:,:,:,:,:,:) + complex, allocatable :: tulod(:,:,:,:,:,:),tulou(:,:,:,:,:,:) + complex, allocatable :: tuloulo(:,:,:,:,:,:,:) + complex, allocatable :: tdd_soc(:,:,:,:),tdu_soc(:,:,:,:) + complex, allocatable :: tud_soc(:,:,:,:),tuu_soc(:,:,:,:) + complex, allocatable :: tdulo_soc(:,:,:,:,:) + complex, allocatable :: tuulo_soc(:,:,:,:,:) + complex, allocatable :: tulod_soc(:,:,:,:,:) + complex, allocatable :: tulou_soc(:,:,:,:,:) + complex, allocatable :: tuloulo_soc(:,:,:,:,:,:) +#if ( !defined(CPP_INVERSION) || defined(CPP_SOC) ) + complex, allocatable :: z(:,:),zz(:,:) + complex, allocatable :: z_b(:,:) + complex, allocatable :: z_b2(:,:) +#else + real, allocatable :: z(:,:),zz(:,:) + real, allocatable :: z_b(:,:) + real, allocatable :: z_b2(:,:) +#endif + +c ..local arrays.. + character(len=2) :: spin012(0:2) + data spin012/' ', '.1', '.2'/ + character(len=3) :: spin12(2) + data spin12/'WF1' , 'WF2'/ + character(len=8) :: name(10) + integer :: n_bands(0:neigd),ngopr1(natd) + real :: bkpt(3),bkpt_b(3),bkpt_b2(3),bkrot(3) + real :: eig(neigd),eig_b(neigd),eig_b2(neigd) + real :: uuilon(nlod,ntypd),duilon(nlod,ntypd) + real :: ulouilopn(nlod,nlod,ntypd) + real :: ello(nlod,ntypd,max(2,jspd)),evac(2,max(2,jspd)) + real :: epar(0:lmaxd,ntypd,max(2,jspd)),evdu(2,max(jspd,2)) + real :: qpt_i(3),qptb_i(3) + real :: alph_i(ntypd),alphb_i(ntypd) + real :: beta_i(ntypd),betab_i(ntypd) + real :: cp_time(9) + +c ..local scalars.. + character(len=6) :: filename + character(len=8) :: dop,iop + character(len=12) fending + character(len=30) fstart + type(t_wann) :: wann + logical :: l_p0,l_bkpts,l_proj,l_file + logical :: l_bqpts,l_gwf,l_exist,l_nocosoc,l_symcheck + logical :: l_skip_sph,l_skip_non,l_skip_soc + logical :: l_skip_int,l_skip_vac,l_skip_loc + integer :: lmd,nlotot,n,iter,ikpt,ikpt_b,ikpt_b2,iqpt,iqpt_b + integer :: addnoco,addnoco2,funbas,loplod,igvm2 + integer :: nn,nkpts,i,j,l,i_rec,m,nwf,nwfp + integer :: jsp_start,jsp_end,nrec,nrec_b,nrec1 + integer :: nodeu,noded,n_size,na,n_rank,nbnd,numbands + integer :: i1,i2,i3,in,lda + integer :: nmat,nmat_b,nmat_b2,nmat_qb + integer :: nbands,nbands_b,nbands_b2,nbands_qb + integer :: nslibd,nslibd_b,nslibd_b2,nslibd_qb + integer :: noccbd,noccbd_b,noccbd_b2,noccbd_qb + integer :: kptibz,kptibz_b,kptibz_b2 + integer :: qptibz, qptibz_b + integer :: oper,oper_b,oper_b2,oper_q, oper_qb + integer :: nwfs,nntot,nntot_q,fullnkpts,fullnqpts + integer :: kpt,qpt,j1,j2,j3,k,ikpt_help,iqpt_help + integer :: wannierspin,jspin,jspin_b,jspin2 + integer :: jspin3,jspin4_b,jspin4,jspin5,tspin,tspin2 + integer :: n_start,n_end,mlotot,mlolotot,err + integer :: mlot_d,mlolot_d,ilo,dir,length + integer :: npotmatfile,ig3,maxvac,irec,imz,ivac,ipot + integer :: funit_start,band_help,sign2 + integer :: doublespin,doublespin_max,nrec5 + integer :: aoff,d1,d10,d100 + real :: tpi,wronk,wk,wk_b,wk_b2 + real :: t0,t00,t1,t_tlmplm,t_init + real :: t_int,t_sph,t_vac,t_abcof,t_eig,t_total + real :: efermi,htr2ev + real :: theta_i, thetab_i, phi_i, phib_i + complex :: nsfactor,nsfactor_b,nsfactor_b2 + complex :: ci + + +c ..initializations.. + call cpu_time(t00) + + ci = cmplx(0.,1.) + t_init = 0. + t_tlmplm = 0. + t_eig = 0. + t_abcof = 0. + t_int = 0. + t_sph = 0. + t_vac = 0. + t_total = 0. + htr2ev = 27.2 + nntot_q = 1 + fullnqpts = 1 + funit_start = 5000 + + aoff = iachar('1')-1 + d1 = mod(irank,10) + IF (irank < 100) THEN + d10 = int( (irank + 0.5)/10 ) + fstart = 'eig'//achar(d10+aoff)//achar(d1+aoff) + ELSE + d10 = mod((irank-d1)/10,10) + d100 = (irank-10*d10-d1)/100 + IF ( d100.GE.10 ) d100 = d100 + iachar('7') + fstart = + + 'eig'//achar(d100+aoff)//achar(d10+aoff)//achar(d1+aoff) + ENDIF + + + ngopr1(:)=1 + + l_p0 = .false. + if (irank.eq.0) l_p0 = .true. + l_nocosoc = l_noco.or.l_soc + + tpi = 2* pimach() + lmd = lmaxd*(lmaxd+2) + +!!! should be changed in case the windows are really used + nkpts = maxval(nkpt(:)) + + ! do we have to construct GWF ? + l_gwf = .false. + l_gwf = l_sgwf.or.l_socgwf + + +c-----read the input file to determine what to do + call wann_read_inp( + > l_p0, + < wann) + + if(wann%l_byenergy.and.wann%l_byindex) CALL fleur_err + + ("byenergy.and.byindex",calledby ="wannier") + if(wann%l_byenergy.and.wann%l_bynumber) CALL fleur_err + + ("byenergy.and.bynumber",calledby ="wannier") + if(wann%l_bynumber.and.wann%l_byindex) CALL fleur_err + + ("bynumber.and.byindex",calledby ="wannier") + if(.not.(wann%l_bynumber.or.wann%l_byindex.or.wann%l_byenergy)) + & CALL fleur_err("no rule to sort bands",calledby ="wannier") + + + efermi=ef + if(.not.wann%l_fermi)efermi=0.0 + +#ifdef CPP_MPI + call MPI_BARRIER(MPI_COMM_WORLD,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 fleur_err + + ("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 fleur_err("bpt.gt.fullnkpts" + + ,calledby ="wannier") + enddo + enddo + close (202) + allocate(kdiff(3,nntot)) + +c********************************************************** +ccccccccccccccc read in the bqpts file ccccccccccccccccc +c********************************************************** + if (l_gwf.or.l_ms) then ! for Omega functional minimization + l_bqpts = .false. + inquire (file='bqpts',exist=l_bqpts) + if (.not.l_bqpts) CALL fleur_err("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 fleur_err("iqpt.ne.iqpt_help" + + ,calledby ="wannier") + if (bpt_q(nn,iqpt)>fullnqpts) + & CALL fleur_err("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(l_sgwf) gb_q = 2*gb_q + if(l_socgwf) gb_q = 2*gb_q + + if(wann%l_finishgwf) goto 9110 +c******************************************************** +c find symmetry-related elements in mmkb +c******************************************************** + allocate(maptopair(3,fullnkpts,nntot)) + allocate(pair_to_do(fullnkpts,nntot)) + call wann_mmnk_symm( + > fullnkpts,nntot,bpt,gb,wann%l_bzsym, + > irreduc,mapkoper,l_p0,film,nop,invtab,mrot,odi%d1, + > tau, + < pair_to_do,maptopair,kdiff,.false.,param_file) + + ! do the same for q-points to construct GWFs + if(l_gwf)then + allocate(maptopair_q(3,fullnqpts,nntot_q)) + allocate(pair_to_do_q(fullnqpts,nntot_q)) + call wann_mmnk_symm( + > fullnqpts,nntot_q,bpt_q,gb_q,wann%l_bzsym, + > irreduc_q,mapqoper,l_p0,.false.,1,invtab(1),mrot(:,:,1), + > .false.,tau, + < pair_to_do_q,maptopair_q,qdiff,.true.,param_file) + endif + + +c********************************************************* +cccccccccccccccc initialize the potential cccccccccccc +c********************************************************* + + if(.not. l_noco) then + allocate ( vpw(n3d,jspd),vzxy(nmzxyd,odi%n2d-1,2,jspd) ) + else + allocate ( vpw(n3d,4),vzxy(nmzxyd,odi%n2d-1,2,4) ) + endif + + allocate ( vz(nmzd,2,4) ) + allocate ( vrf(jmtd,0:nlhd,ntypd,jspd) ) + allocate ( vr(jmtd,ntypd,jspd) ) + + open (8,file='pottot',form='unformatted',status='old') + rewind (8) + + call loddop( + > jspd,n3d,odi%n2d,nmzxyd,nmzd,jmtd,nlhd,ntypd, + > jspins,nq3,odi%nq2,nvac,ntype,invs,invs2,film, + > nlh,jri,ntypsd,ntypsy,8,natd,neq, + < iop,dop,iter,vrf,vpw,vz,vzxy,name) + + close (8) + + do jspin = 1,jspins + do n = 1, ntype + do j = 1,jri(n) + vr(j,n,jspin) = vrf(j,0,n,jspin) + enddo + enddo + enddo + + if(.not. film) deallocate(vz,vzxy) + + if(l_noco)then + npotmatfile=25 + + OPEN (npotmatfile,FILE='potmat',FORM='unformatted', + + STATUS='old') +c---> load the interstitial potential + if(l_p0 .and. nq3.ne.n3d) then + write(*,*)'WARNING for reading potmat: nq3.ne.n3d' + endif + vpw = cmplx(0.0, 0.0) + READ (npotmatfile) (vpw(ig3,1),ig3=1,n3d) + READ (npotmatfile) (vpw(ig3,2),ig3=1,n3d) + READ (npotmatfile) (vpw(ig3,3),ig3=1,n3d) + vpw(:,4) = conjg(vpw(:,3)) + if(film) then + maxvac=2 + if(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. (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,nmzd),ipot=1,4) + +c---> load the warping part of the potential + if(.not.odi%d1)then + DO ipot = 1,3 + READ (npotmatfile)((vzxy(imz,igvm2,ivac,ipot), + + imz=1,nmzxy),igvm2=1,nq2-1) + ENDDO + else + DO ipot = 1,3 + READ (npotmatfile)((vzxy(imz,igvm2,ivac,ipot), + + imz=1,nmzxy),igvm2=1,odi%n2d-1) + ENDDO + endif + vzxy(:,:,:,4) = conjg(vzxy(:,:,:,3)) + enddo + endif + CLOSE (npotmatfile) + endif + + + if(film .and. l_p0) write(*,*)'nvac',nvac + +cccccccccccccccc end of the potential part ccccccccccc + wannierspin=jspd + if(l_soc) wannierspin=2 + + allocate(flo(ntypd,jmtd,2,nlod,2)) + allocate ( ff(ntypd,jmtd,2,0:lmaxd,2) ) + allocate ( gg(ntypd,jmtd,2,0:lmaxd,2) ) + allocate ( us(0:lmaxd,ntypd,2) ) + allocate ( uds(0:lmaxd,ntypd,2) ) + allocate ( dus(0:lmaxd,ntypd,2) ) + allocate ( duds(0:lmaxd,ntypd,2) ) + allocate ( ddn(0:lmaxd,ntypd,2) ) + allocate ( ulos(nlod,ntypd,2) ) + allocate ( dulos(nlod,ntypd,2) ) + allocate ( uulon(nlod,ntypd,2) ) + allocate ( dulon(nlod,ntypd,2) ) + allocate ( uloulopn(nlod,nlod,ntypd,2) ) + + allocate ( kveclo(nlotot),nv(wannierspin) ) + allocate ( kveclo_b(nlotot),nv_b(wannierspin) ) + allocate ( kveclo_b2(nlotot),nv_b2(wannierspin) ) + allocate ( k1(nvd,wannierspin),k2(nvd,wannierspin), + & k3(nvd,wannierspin) ) + allocate ( k1_b(nvd,wannierspin),k2_b(nvd,wannierspin), + & k3_b(nvd,wannierspin) ) + allocate ( k1_b2(nvd,wannierspin),k2_b2(nvd,wannierspin), + & k3_b2(nvd,wannierspin) ) + + if(l_nocosoc) then + doublespin_max=4 + else + doublespin_max=wannierspin + endif + +c if(l_soc.and.(jspins.eq.1)) doublespin_max=wannierspin + + l_skip_int = .false.; l_skip_soc = .false.; l_skip_vac = .false. + l_skip_sph = .false.; l_skip_non = .false.; l_skip_loc = .false. + inquire(file='debug_uHu',exist=l_exist) + if(l_exist) then + open(888,file='debug_uHu') + read(888,*)l_skip_int + read(888,*)l_skip_sph + read(888,*)l_skip_non + read(888,*)l_skip_soc + read(888,*)l_skip_loc + read(888,*)l_skip_vac + read(888,*)doublespin_max + close(888) + if(l_p0) then + write(*,*)'skip INT :',l_skip_int + write(*,*)'skip SPH :',l_skip_sph + write(*,*)'skip NON :',l_skip_non + write(*,*)'skip SOC :',l_skip_soc + write(*,*)'skip LOC :',l_skip_loc + write(*,*)'skip VAC :',l_skip_vac + write(*,*)'doublespin_max:',doublespin_max + endif + endif + + tspin = doublespin_max + if(fullnqpts.eq.1) tspin=1 + if(l_p0) write(*,*)'tspin',tspin + allocate( tdd(0:lmd,0:lmd,ntypd,nntot*nntot,tspin) ) + allocate( tdu(0:lmd,0:lmd,ntypd,nntot*nntot,tspin) ) + allocate( tud(0:lmd,0:lmd,ntypd,nntot*nntot,tspin) ) + allocate( tuu(0:lmd,0:lmd,ntypd,nntot*nntot,tspin) ) + allocate( tdulo(0:lmd,nlod,-llod:llod,ntypd,nntot*nntot,tspin) ) + allocate( tuulo(0:lmd,nlod,-llod:llod,ntypd,nntot*nntot,tspin) ) + allocate( tulou(0:lmd,nlod,-llod:llod,ntypd,nntot*nntot,tspin) ) + allocate( tulod(0:lmd,nlod,-llod:llod,ntypd,nntot*nntot,tspin) ) + allocate( tuloulo(nlod,-llod:llod,nlod,-llod:llod, + > ntypd,nntot*nntot,tspin) ) + allocate( tdd_soc(0:lmd,0:lmd,ntypd,nntot*nntot) ) + allocate( tdu_soc(0:lmd,0:lmd,ntypd,nntot*nntot) ) + allocate( tud_soc(0:lmd,0:lmd,ntypd,nntot*nntot) ) + allocate( tuu_soc(0:lmd,0:lmd,ntypd,nntot*nntot) ) + allocate( tdulo_soc(0:lmd,nlod,-llod:llod,ntypd,nntot*nntot) ) + allocate( tuulo_soc(0:lmd,nlod,-llod:llod,ntypd,nntot*nntot) ) + allocate( tulou_soc(0:lmd,nlod,-llod:llod,ntypd,nntot*nntot) ) + allocate( tulod_soc(0:lmd,nlod,-llod:llod,ntypd,nntot*nntot) ) + allocate( tuloulo_soc(nlod,-llod:llod,nlod,-llod:llod, + > ntypd,nntot*nntot) ) + + tuu = cmplx(0.,0.); tdu = cmplx(0.,0.) + tud = cmplx(0.,0.); tdd = cmplx(0.,0.) + tuulo = cmplx(0.,0.); tdulo = cmplx(0.,0.) + tulou = cmplx(0.,0.); tulod = cmplx(0.,0.) + tuloulo = cmplx(0.,0.) + tuu_soc = cmplx(0.,0.); tdu_soc = cmplx(0.,0.) + tud_soc = cmplx(0.,0.); tdd_soc = cmplx(0.,0.) + tuulo_soc = cmplx(0.,0.); tdulo_soc = cmplx(0.,0.) + tulou_soc = cmplx(0.,0.); tulod_soc = cmplx(0.,0.) + tuloulo_soc = cmplx(0.,0.) + + call cpu_time(t1) + t_init = t1-t00 + +c*****************************************************************c +c START Q LOOP c +c*****************************************************************c + do 314 iqpt = 1,fullnqpts ! loop by q-points starts + + 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 = qss + alph_i = alph + beta_i = beta + theta_i = theta + phi_i = phi + if(l_sgwf.or.l_ms) then + qpt_i(:) = param_vec(:,qptibz) + alph_i(:) = param_alpha(:,qptibz) + elseif(l_socgwf) then + if(l_dim(2)) phi_i = tpi*param_vec(2,qptibz) + if(l_dim(3)) theta_i = tpi*param_vec(3,qptibz) + endif + + if(l_p0) then + write(*,*)'qpt_i',qpt_i + do n=1,ntype + write(*,*)'n=',n,alph_i(n),beta_i(n) + enddo + write(*,*)'theta_i=',theta_i + write(*,*)'phi_i=',phi_i + endif + + IF (l_gwf) THEN + do iqpt_b=1,nntot_q + WRITE(fending,'("_",i4.4)')bpt_q(iqpt_b,iqpt) + OPEN(funit_start+iqpt_b,file=trim(fstart)//fending, + > access='direct', + > form='unformatted',recl=irecl,status='old') + enddo + WRITE(fending,'("_",i4.4)')qptibz + OPEN(66,file=trim(fstart)//fending,access='direct', + > form='unformatted',recl=irecl,status='old') + ELSEIF(l_ms) THEN + WRITE(fending,'("_",i4.4)')qptibz + OPEN(66,file=trim(fstart)//fending,access='direct', + > form='unformatted',recl=irecl,status='old') + ELSE + fending='' + ENDIF ! l_gwf.or.l_ms + nrec=0 + nrec_b=0 + +c**************************************************** +c cycle by spins starts! +c**************************************************** + do 110 doublespin=1,doublespin_max ! cycle by spins + if(l_p0) write(*,*)'spin loop:',doublespin + +c jspin=mod(doublespin+1,2)+1 +c jspin_b=jspin +c if(doublespin.eq.3) jspin_b=2 +c if(doublespin.eq.4) jspin_b=1 + jspin_b=mod(doublespin+1,2)+1 + jspin=jspin_b + if(doublespin.eq.3) jspin=2 + if(doublespin.eq.4) jspin=1 + + tspin2 = doublespin + if(fullnqpts.eq.1) tspin2 = 1 + + nrec_b = nrec + + if(.not.l_noco) then + nrec = (jspin-1)*nkpts + nrec_b = (jspin_b-1)*nkpts + endif + +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 fleur_err("no proj/proj.1/proj.2",calledby ="wannier") + endif + + + jspin2=jspin + if(l_soc .and. jspins.eq.1)jspin2=1 + jsp_start = jspin ; jsp_end = jspin + +cccccccccccc read in the eigenvalues and vectors cccccc + do jspin5=1,wannierspin!1,2 + jsp_start=jspin5; jsp_end=jspin5 + nrec5=0 + if(.not.l_noco) nrec5 = (jspin5-1)*nkpts + call cdn_read0( + > lmaxd,ntypd,nlod,neigd,jspd,!wannierspin, + > irank,isize,jspin5,jsp_start,jsp_end, + > l_noco,nrec5,66, !nrec + < ello,evac,epar,bkpt,wk,n_bands,nrec1,n_size) + enddo + +c.. now we want to define the maximum number of the bands by all kpts + nbnd = 0 + i_rec = 0 ; n_rank = 0 + + if(l_p0)then + call wann_maxbnd( + > lmaxd,ntypd,nlod,neigd,nvd,wannierspin, + > isize,jspin,nbasfcn,nlotot, + > l_ss,l_noco,nrec,fullnkpts,irecl, + > wann%l_bzsym,wann%l_byindex,wann%l_bynumber, + > wann%l_byenergy, + > irreduc,odi,wann%band_min(jspin), + > wann%band_max(jspin), + > numbands,e1s,e2s,efermi,nkpts, + < nbnd,l_gwf,iqpt) + 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,isize-1 + call MPI_SEND(nbnd,1,MPI_INTEGER,cpu_index,1,MPI_COMM_WORLD,ierr) + enddo + else + call MPI_RECV(nbnd,1,MPI_INTEGER,0,1,MPI_COMM_WORLD,stt,ierr) + endif +#endif + +c################################################################## + if(.not.allocated(uHu)) then + allocate(uHu(nbnd,nbnd,nntot,nntot,counts(irank))) +c allocate(uHuold(nbnd,nbnd)) + uHu = cmplx(0.,0.) +c uHuold = cmplx(0.,0.) + endif + + + +! set up T-matrix for spherical and non-spherical part +! only once since it is k- and q-independent ! + if(iqpt.eq.1) then + if(l_p0) write(*,*)'tspin2=',tspin2 + tuu(:,:,:,:,tspin2) = cmplx(0.,0.) + tdu(:,:,:,:,tspin2) = cmplx(0.,0.) + tud(:,:,:,:,tspin2) = cmplx(0.,0.) + tdd(:,:,:,:,tspin2) = cmplx(0.,0.) + tuulo(:,:,:,:,:,tspin2) = cmplx(0.,0.) + tdulo(:,:,:,:,:,tspin2) = cmplx(0.,0.) + tulou(:,:,:,:,:,tspin2) = cmplx(0.,0.) + tulod(:,:,:,:,:,tspin2) = cmplx(0.,0.) + tuloulo(:,:,:,:,:,:,tspin2) = cmplx(0.,0.) + + do jspin4=1,2 + jspin3=jspin4 + if(jspins.eq.1) jspin3=1 + na = 1 + do 40 n = 1,ntype + do 30 l = 0,lmax(n) +c...compute the l-dependent, k-independent radial MT- basis functions + call radfun( + > l,epar(l,n,jspin3),vr(1,n,jspin3),jri(n),rmsh(1,n), + > dx(n),jmtd, + < ff(n,:,:,l,jspin4),gg(n,:,:,l,jspin4), + > us(l,n,jspin4), + < dus(l,n,jspin4),uds(l,n,jspin4),duds(l,n,jspin4), + < ddn(l,n,jspin4),nodeu,noded,wronk) + 30 continue +c...and the local orbital radial functions + do ilo = 1, nlo(n) + call radflo( + > ntypd,nlod,jspd,jmtd,lmaxd,n,jspin, !jspin not important + > ello(1,1,jspin3),vr(1,n,jspin3), + > jri(n),rmsh(1,n),dx(n),ff(n,1:,1:,0:,jspin4), + > gg(n,1:,1:,0:,jspin4),llo,nlo,l_dulo(1,n), + > irank,ulo_der, + < ulos(1,1,jspin4),dulos(1,1,jspin4),uulon(1,1,jspin4), + > dulon(1,1,jspin4), + < uloulopn(1,1,1,jspin4),uuilon,duilon,ulouilopn, + > flo(n,:,:,:,jspin4)) + enddo +c na = na + neq(n) + 40 continue + enddo!jspin3 + + + if(jspin.eq.jspin_b) then + if(l_p0) write(*,*)'wann_uHu_tlmplm' + jspin3=jspin + if(jspins.eq.1) jspin3=1 + call cpu_time(t0) + call wann_uHu_tlmplm( + > memd,nlhd,ntypsd,ntypd,jmtd,lmaxd,jspd,ntype,dx, + > rmsh,jri,lmax,ntypsy,natd,lnonsph,lmd,lmplmd,clnu, + > mlh,nmem,llh,nlh,neq,irank,mlotot,mlolotot, + > vrf(:,:,:,jspin3),nlod,llod,loplod,ello(1,1,jspin3), + > llo,nlo,lo1l,l_dulo,ulo_der,ff(:,:,:,:,jspin), + > gg(:,:,:,:,jspin),flo(:,:,:,:,jspin), + > ff(:,:,:,:,jspin_b),gg(:,:,:,:,jspin_b), + > flo(:,:,:,:,jspin_b),kdiff,kdiff,nntot,nntot,bmat,bbmat, + > vr(1,1,jspin3),epar(0,1,jspin3),invsat, + > l_skip_sph,l_skip_non,l_skip_loc, + < tuu(:,:,:,:,tspin2),tud(:,:,:,:,tspin2), + > tdu(:,:,:,:,tspin2),tdd(:,:,:,:,tspin2), + > tuulo(:,:,:,:,:,tspin2),tulou(:,:,:,:,:,tspin2), + > tdulo(:,:,:,:,:,tspin2),tulod(:,:,:,:,:,tspin2), + > tuloulo(:,:,:,:,:,:,tspin2)) + call cpu_time(t1) + t_tlmplm = t_tlmplm + t1-t0 + endif + + endif!iqpt.eq.1 + + +! compute SOC-contribution for each theta_i ! + if(l_soc.and. (.not.l_skip_soc)) then + if(l_p0) write(*,*)'wann_uHu_soc' + tuu_soc = cmplx(0.,0.); tdu_soc = cmplx(0.,0.) + tud_soc = cmplx(0.,0.); tdd_soc = cmplx(0.,0.) + tuulo_soc = cmplx(0.,0.); tdulo_soc = cmplx(0.,0.) + tulou_soc = cmplx(0.,0.); tulod_soc = cmplx(0.,0.) + tuloulo_soc = cmplx(0.,0.) + call cpu_time(t0) + call wann_uHu_soc( + > ntypd,jmtd,lmaxd,jspd, + > ntype,dx,rmsh,jri,lmax,natd, + > lmd,lmplmd,neq,irank, + > nlod,llod,loplod,ello,llo,nlo,lo1l,l_dulo,ulo_der, + > ff(:,:,:,:,jspin),gg(:,:,:,:,jspin),flo(:,:,:,:,jspin), + > ff(:,:,:,:,jspin_b),gg(:,:,:,:,jspin_b),flo(:,:,:,:,jspin_b), + > kdiff,kdiff,nntot,nntot,bmat,bbmat, + > vr,epar,jspin,jspin_b,jspins, + > .true.,theta_i,phi_i,alph_i,beta_i,l_noco,l_skip_loc, + < tuu_soc,tud_soc, + > tdu_soc,tdd_soc, + > tuulo_soc,tulou_soc, + > tdulo_soc,tulod_soc, + > tuloulo_soc) + call cpu_time(t1) + t_tlmplm = t_tlmplm + t1-t0 + endif!l_soc + + + i_rec = 0 ; n_rank = 0 + +c**************************************************************** +c.. loop by kpoints starts! each may be a separate task +c**************************************************************** + if(l_p0) write(*,*)'start k-loop' + do 10 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) + + if(kpt_on_node(ikpt,isize,counts,displs).eq.irank) then +c write(*,*)irank,ikpt + i_rec = i_rec + 1 +c if (mod(i_rec-1,isize).eq.irank) then + + allocate ( zz(nbasfcn,neigd),eigg(neigd) ) + + n_start=1 + n_end=neigd + + call cpu_time(t0) + ! get current bkpt vector +#if(!defined(CPP_HDF) && defined(CPP_MPI)) + call wann_read_eig( + > lmaxd,ntypd,nlod,neigd,nvd,wannierspin, + > irank,isize,kptibz,jspin,nbasfcn,nlotot, + > l_ss,l_noco,nrec,irecl, + < nmat,nv,ello,evdu,epar,kveclo, + < k1,k2,k3,bkpt,wk,nbands, + < eigg,zz,cp_time,66,l_gwf,iqpt) +#else + call cdn_read( + > lmaxd,ntypd,nlod,neigd,nvd,jspd,!wannierspin, + > irank,isize,kptibz,jspin,nbasfcn,nlotot, + > l_ss,l_noco,nrec,kptibz,66, + > neigd,n_start,n_end, + < nmat,nv,ello,evdu,epar,kveclo, + < k1,k2,k3,bkpt,wk,nbands, + < eigg,zz,cp_time) +#endif + call cpu_time(t1) + t_eig = t_eig + t1 - t0 + + allocate ( z_b(nbasfcn,neigd), we_b(neigd) ) + allocate ( z_b2(nbasfcn,neigd), we_b2(neigd) ) + + !!! the cycle by the nearest neighbors (nntot) for each kpoint + + do 15 ikpt_b = 1,nntot + kptibz_b=bpt(ikpt_b,ikpt) + + if(wann%l_bzsym) oper_b=mapkoper(kptibz_b) + if (wann%l_bzsym) kptibz_b=irreduc(kptibz_b) + + n_start=1 + n_end=neigd + + eigg = 0. + call cpu_time(t0) +#if(!defined(CPP_HDF) && defined(CPP_MPI)) + call wann_read_eig( + > lmaxd,ntypd,nlod,neigd,nvd,wannierspin, + > irank,isize,kptibz_b,jspin,nbasfcn,nlotot, + > l_ss,l_noco,nrec,irecl, + < nmat_b,nv_b,ello,evdu,epar,kveclo_b, + < k1_b,k2_b,k3_b,bkpt_b,wk_b,nbands_b, + < eigg,zz,cp_time,66,l_gwf,iqpt) +#else + call cdn_read( + > lmaxd,ntypd,nlod,neigd,nvd,jspd,!wannierspin, + > irank,isize,kptibz_b,jspin,nbasfcn,nlotot, + > l_ss,l_noco,nrec,kptibz_b,66, + > neigd,n_start,n_end, + < nmat_b,nv_b,ello,evdu,epar,kveclo_b, + < k1_b,k2_b,k3_b,bkpt_b,wk_b,nbands_b, + < eigg,zz,cp_time) + +#endif + nslibd_b = 0 + +#if ( !defined(CPP_INVERSION) || defined(CPP_SOC) ) + z_b(:,:) = cmplx(0.,0.) +#else + z_b(:,:) = 0. +#endif + eig_b(:) = 0. + + do i = 1,nbands_b + if((eigg(i).ge.e1s.and.nslibd_b.lt.numbands + & .and.wann%l_bynumber) + &.or.(eigg(i).ge.e1s.and.eigg(i).le.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(l_noco)then + funbas = nv_b(1) + nlotot + funbas = funbas+nv_b(2) + nlotot + else + funbas = nv_b(jspin) + nlotot + endif + do j = 1,funbas + z_b(j,nslibd_b) = zz(j,i) + enddo + endif + enddo + +c*********************************************************** +c Rotate the wavefunction of next neighbor. +c*********************************************************** + if (wann%l_bzsym .and. (oper_b.ne.1) ) then + call wann_kptsrotate( + > natd,nlod,llod, + > ntypd,nlo,llo,invsat, + > l_noco,l_soc, + > ntype,neq,nlotot, + > kveclo_b,jspin, + > oper_b,nop,mrot,nvd, + > nv_b, + > shiftkpt(:,bpt(ikpt_b,ikpt)), + > tau, + x bkpt_b,k1_b(:,:), + x k2_b(:,:),k3_b(:,:), + x z_b,nsfactor_b) + else + nsfactor_b=cmplx(1.0,0.0) + endif + noccbd_b = nslibd_b + call cpu_time(t1) + t_eig = t_eig + t1 - t0 + + addnoco = 0 + if(l_noco.and.jspin.eq.2) addnoco=nv_b(1)+nlotot + + ! set up a(k+b1),b(k+b1),c(k+b1) + allocate( acof_b(noccbd_b,0:lmd,natd), + > bcof_b(noccbd_b,0:lmd,natd), + > ccof_b(-llod:llod,noccbd_b,nlod,natd) ) + + call cpu_time(t0) + call abcof( + > lmaxd,ntypd,neigd,noccbd_b,natd,nop,nvd,wannierspin, + > lmd,nbasfcn,llod,nlod,nlotot,invtab, + > ntype,mrot,ngopr1,taual,neq,lmax,rmt,omtil, + > bmat,bbmat,bkpt_b, + > k1_b,k2_b,k3_b,nv_b,nmat_b,noccbd_b,z_b, + > us(0,1,jspin),dus(0,1,jspin),uds(0,1,jspin), + > duds(0,1,jspin),ddn(0,1,jspin),invsat,invsatnr, + > ulos(1,1,jspin),uulon(1,1,jspin),dulon(1,1,jspin), + > dulos(1,1,jspin),llo,nlo,l_dulo,lapw_l, + > l_noco,l_ss,jspin,alph_i,beta_i,qpt_i, + > kveclo_b,odi,ods, + < acof_b(1,0,1),bcof_b(1,0,1), + < ccof_b(-llod,1,1,1)) + + call wann_abinv( + > ntypd,natd,noccbd_b,lmaxd,lmd,llod,nlod,ntype,neq, + > noccbd_b,lmax,nlo,llo,invsat,invsatnr,bkpt_b,taual, + X acof_b,bcof_b,ccof_b) + call cpu_time(t1) + t_abcof = t_abcof + t1 - t0 + + do 25 ikpt_b2 = 1,nntot!ikpt_b!nntot + + kptibz_b2=bpt(ikpt_b2,ikpt) + if(wann%l_bzsym) oper_b2=mapkoper(kptibz_b2) + if (wann%l_bzsym) kptibz_b2=irreduc(kptibz_b2) + + n_start=1 + n_end=neigd + + eigg = 0. + call cpu_time(t0) +#if(!defined(CPP_HDF) && defined(CPP_MPI)) + call wann_read_eig( + > lmaxd,ntypd,nlod,neigd,nvd,wannierspin, + > irank,isize,kptibz_b2,jspin_b,nbasfcn,nlotot, + > l_ss,l_noco,nrec_b,irecl, + < nmat_b2,nv_b2,ello,evdu,epar,kveclo_b2, + < k1_b2,k2_b2,k3_b2,bkpt_b2,wk_b2,nbands_b2, + < eigg,zz,cp_time,66,l_gwf,iqpt) +#else + call cdn_read( + > lmaxd,ntypd,nlod,neigd,nvd,jspd,!wannierspin, + > irank,isize,kptibz_b2,jspin_b,nbasfcn,nlotot, + > l_ss,l_noco,nrec_b,kptibz_b2,66, + > neigd,n_start,n_end, + < nmat_b2,nv_b2,ello,evdu,epar,kveclo_b2, + < k1_b2,k2_b2,k3_b2,bkpt_b2,wk_b2,nbands_b2, + < eigg,zz,cp_time) + +#endif + nslibd_b2 = 0 + +#if ( !defined(CPP_INVERSION) || defined(CPP_SOC) ) + z_b2(:,:) = cmplx(0.,0.) +#else + z_b2(:,:) = 0. +#endif + eig_b2(:) = 0. + + do i = 1,nbands_b2 + if((eigg(i).ge.e1s.and.nslibd_b2.lt.numbands + & .and.wann%l_bynumber) + &.or.(eigg(i).ge.e1s.and.eigg(i).le.e2s.and.wann%l_byenergy) + &.or.(i.ge.wann%band_min(jspin_b) + & .and. + & (i.le.wann%band_max(jspin_b)) + & .and. + & wann%l_byindex))then + nslibd_b2 = nslibd_b2 + 1 + eig_b2(nslibd_b2) = eigg(i) + we_b2(nslibd_b2) = we_b2(i) + if(l_noco)then + funbas = nv_b2(1) + nlotot + funbas = funbas+nv_b2(2) + nlotot + else + funbas = nv_b2(jspin_b) + nlotot + endif + do j = 1,funbas + z_b2(j,nslibd_b2) = zz(j,i) + enddo + endif + enddo + +c*********************************************************** +c Rotate the wavefunction of next neighbor. +c*********************************************************** + if (wann%l_bzsym .and. (oper_b2.ne.1) ) then + call wann_kptsrotate( + > natd,nlod,llod, + > ntypd,nlo,llo,invsat, + > l_noco,l_soc, + > ntype,neq,nlotot, + > kveclo_b2,jspin_b, + > oper_b2,nop,mrot,nvd, + > nv_b2, + > shiftkpt(:,bpt(ikpt_b2,ikpt)), + > tau, + x bkpt_b2,k1_b2(:,:), + x k2_b2(:,:),k3_b2(:,:), + x z_b2,nsfactor_b2) + else + nsfactor_b2=cmplx(1.0,0.0) + endif + noccbd_b2 = nslibd_b2 + call cpu_time(t1) + t_eig = t_eig + t1 - t0 + + addnoco2 = 0 + if(l_noco.and.jspin_b.eq.2) addnoco2=nv_b2(1)+nlotot + + ! set up a(k+b2),b(k+b2),c(k+b2) + allocate( acof_b2(noccbd_b2,0:lmd,natd), + > bcof_b2(noccbd_b2,0:lmd,natd), + > ccof_b2(-llod:llod,noccbd_b2,nlod,natd) ) + + call cpu_time(t0) + call abcof( + > lmaxd,ntypd,neigd,noccbd_b2,natd,nop,nvd,wannierspin, + > lmd,nbasfcn,llod,nlod,nlotot,invtab, + > ntype,mrot,ngopr1,taual,neq,lmax,rmt,omtil, + > bmat,bbmat,bkpt_b2, + > k1_b2,k2_b2,k3_b2,nv_b2,nmat_b2,noccbd_b2,z_b2, + > us(0,1,jspin_b),dus(0,1,jspin_b),uds(0,1,jspin_b), + > duds(0,1,jspin_b),ddn(0,1,jspin_b),invsat,invsatnr, + > ulos(1,1,jspin_b),uulon(1,1,jspin_b),dulon(1,1,jspin_b), + > dulos(1,1,jspin_b),llo,nlo,l_dulo,lapw_l, + > l_noco,l_ss,jspin_b,alph_i,beta_i,qpt_i, + > kveclo_b2,odi,ods, + < acof_b2(1,0,1),bcof_b2(1,0,1), + < ccof_b2(-llod,1,1,1)) + + call wann_abinv( + > ntypd,natd,noccbd_b2,lmaxd,lmd,llod,nlod,ntype,neq, + > noccbd_b2,lmax,nlo,llo,invsat,invsatnr,bkpt_b2,taual, + X acof_b2,bcof_b2,ccof_b2) + call cpu_time(t1) + t_abcof = t_abcof + t1 - t0 + + +c**************************************c +c calculate uHu matrix due to: c +c (i) interstitial c +c (ii) muffin tins c +c (iii) vacuum c +c**************************************c +c if(ANY(gb(3:3,ikpt_b,ikpt).ne.0) .or. +c > ANY(gb(3:3,ikpt_b2,ikpt).ne.0)) then +c write(*,*)ikpt,ikpt_b,ikpt_b2 +c write(*,*)gb(:,ikpt_b,ikpt) +c write(*,*)gb(:,ikpt_b2,ikpt) +c uHu(:,:,ikpt_b2,ikpt_b,i_rec) = cmplx(0.,0.) +c goto 848 +c endif + + ! MT (SPH, NON) + if(.not.(l_skip_sph.and.l_skip_non)) then + call cpu_time(t0) + call wann_uHu_sph( + > cmplx(1.,0.),nbnd,llod,nslibd_b,nslibd_b2,nlod,natd,ntypd, + > lmd,jmtd,taual,nop,lmax,ntype,neq,nlo,llo, + > acof_b,bcof_b,ccof_b,bkpt_b2, + > acof_b2,bcof_b2,ccof_b2,bkpt_b,bkpt, + > gb(:,ikpt_b,ikpt),gb(:,ikpt_b2,ikpt), + < tuu(:,:,:,:,tspin2),tud(:,:,:,:,tspin2), + > tdu(:,:,:,:,tspin2),tdd(:,:,:,:,tspin2), + > tuulo(:,:,:,:,:,tspin2),tulou(:,:,:,:,:,tspin2), + > tdulo(:,:,:,:,:,tspin2),tulod(:,:,:,:,:,tspin2), + > tuloulo(:,:,:,:,:,:,tspin2), + > kdiff,kdiff,nntot,nntot, + > uHu(:,:,ikpt_b2,ikpt_b,i_rec)) + call cpu_time(t1) + t_sph = t_sph + t1 - t0 + endif +c if(ikpt.eq.1) then +c write(*,*)'SPH,NON',ikpt_b2,ikpt_b +c write(*,*)uHu(1,3,ikpt_b2,ikpt_b,i_rec) +c write(*,*)uHu(3,1,ikpt_b2,ikpt_b,i_rec) +c uHuold(:,:) = uHu(:,:,ikpt_b2,ikpt_b,i_rec) +c endif + + ! MT (SOC) + if(l_soc.and.(.not.l_skip_soc)) then + call cpu_time(t0) + call wann_uHu_sph( + > cmplx(1.,0.),nbnd,llod,nslibd_b,nslibd_b2,nlod,natd,ntypd, + > lmd,jmtd,taual,nop,lmax,ntype,neq,nlo,llo, + > acof_b,bcof_b,ccof_b,bkpt_b2, + > acof_b2,bcof_b2,ccof_b2,bkpt_b,bkpt, + > gb(:,ikpt_b,ikpt),gb(:,ikpt_b2,ikpt), + < tuu_soc,tud_soc, + > tdu_soc,tdd_soc, + > tuulo_soc,tulou_soc, + > tdulo_soc,tulod_soc, + > tuloulo_soc, + > kdiff,kdiff,nntot,nntot, + > uHu(:,:,ikpt_b2,ikpt_b,i_rec)) + call cpu_time(t1) + t_sph = t_sph + t1 - t0 +c if(ikpt.eq.1) then +c write(*,*)'SOC',ikpt_b2,ikpt_b +c write(*,*)uHu(1,3,ikpt_b2,ikpt_b,i_rec)-uHuold(1,3) +c write(*,*)uHu(3,1,ikpt_b2,ikpt_b,i_rec)-uHuold(3,1) +c uHuold(:,:) = uHu(:,:,ikpt_b2,ikpt_b,i_rec) +c endif + endif + + + ! In collinear calculation, the potential in interstital and + ! vacuum region is always diagonal with respect to the spin + IF( l_noco .OR. ((.NOT. l_noco) .AND. (doublespin.LT.3)) ) THEN + + jspin3 = doublespin + if(jspins.eq.1) jspin3=1 + + jspin4 = jspin + jspin4_b=jspin_b + if(jspins.eq.1) then + jspin4=1 + jspin4_b=1 + endif + + sign2 = 1 + if(doublespin.EQ.4) sign2=-1 + + ! INT + if(.not.l_skip_int) then + call cpu_time(t0) + call wann_uHu_int(cmplx(1.,0.),nvd,k1d,k2d,k3d,n3d, + > nv_b(jspin),nv_b2(jspin_b),nbnd,neigd, + > nslibd_b,nslibd_b2,nbasfcn,addnoco,addnoco2, + > k1_b(:,jspin), k2_b(:,jspin), k3_b(:,jspin), + > gb(:,ikpt_b,ikpt), + > k1_b2(:,jspin_b),k2_b2(:,jspin_b),k3_b2(:,jspin_b), + > gb(:,ikpt_b2,ikpt), + > bkpt,bbmat,vpw(:,jspin3),z_b,z_b2,rgphs, + > ustep,ig,jspin.eq.jspin_b,sign2, + > uHu(:,:,ikpt_b2,ikpt_b,i_rec)) + call cpu_time(t1) + t_int = t_int + t1 - t0 + endif +c if(ikpt.eq.1) then +c write(*,*)'INT',ikpt_b2,ikpt_b +c write(*,*)uHu(1,3,ikpt_b2,ikpt_b,i_rec)-uHuold(1,3) +c write(*,*)uHu(3,1,ikpt_b2,ikpt_b,i_rec)-uHuold(3,1) +c uHuold(:,:) = uHu(:,:,ikpt_b2,ikpt_b,i_rec) +c endif + + + ! VAC + if ((.not.l_skip_vac) .and. film .and. (.not.odi%d1)) then + + call cpu_time(t0) + call wann_uHu_vac( + > cmplx(1.,0.),l_noco,l_soc,zrfs,jspins,nlotot,qpt_i, + > nbnd,z1,nmzxyd,nmzd,n2d,nv2d,k1d,k2d,k3d,n3d,nvac,ig, + > rgphs,nmzxy,nmz,delz,ig2,nq2,kv2,area,bmat,bbmat, + > evac(:,jspin4),evac(:,jspin4_b),bkpt_b,bkpt_b2, + > vzxy(:,:,:,jspin3),vz,nslibd_b,nslibd_b2, + > jspin,jspin_b,doublespin,k1_b,k2_b,k3_b, + > k1_b2,k2_b2,k3_b2,wannierspin,nvd,nbasfcn,neigd, + > z_b,z_b2,nv_b,nv_b2,omtil,gb(:,ikpt_b,ikpt), + > gb(:,ikpt_b2,ikpt),sign2, + > uHu(:,:,ikpt_b2,ikpt_b,i_rec)) + call cpu_time(t1) + t_vac = t_vac + t1 - t0 + + elseif ((.not.l_skip_vac) .and. odi%d1) then + + call cpu_time(t0) + call wann_uHu_od_vac( + > cmplx(1.,0.),l_noco,l_soc,jspins,nlotot,nbnd,z1, + > nmzxyd,nmzd,nv2d,k1d,k2d,k3d,n2d,n3d,ig,nmzxy,nmz, + > delz,ig2,bbmat,evac(1,jspin4),evac(1,jspin4_b),bkpt_b, + > bkpt_b2,odi,vzxy(:,:,:,jspin3),vz,nslibd_b,nslibd_b2, + > jspin,jspin_b,doublespin,k1_b,k2_b,k3_b,k1_b2,k2_b2, + > k3_b2,wannierspin,nvd,area,nbasfcn,neigd,z_b,z_b2, + > nv_b,nv_b2,sk2,phi2,omtil,gb(:,ikpt_b,ikpt), + > gb(:,ikpt_b2,ikpt),qpt_i,sign2, + > uHu(:,:,ikpt_b2,ikpt_b,i_rec)) + call cpu_time(t1) + t_vac = t_vac + t1 - t0 + + endif +c if(ikpt.eq.1) then +c write(*,*)'VAC',ikpt_b2,ikpt_b +c write(*,*)uHu(1,3,ikpt_b2,ikpt_b,i_rec)-uHuold(1,3) +c write(*,*)uHu(3,1,ikpt_b2,ikpt_b,i_rec)-uHuold(3,1) +c uHuold(:,:) = uHu(:,:,ikpt_b2,ikpt_b,i_rec) +c endif + ELSE + IF(ikpt.EQ.1 .AND. ikpt_b.EQ.1 .AND. ikpt_b2.EQ.1) THEN + if(l_p0) write(*,*)'skip INT and VAC' + ENDIF + ENDIF + + +848 continue + + deallocate (acof_b2,bcof_b2,ccof_b2) +25 continue ! end of loop by the nearest k-neighbors + + deallocate (acof_b,bcof_b,ccof_b) +15 continue ! end of loop by the nearest k-neighbors + deallocate ( z_b,we_b ) + deallocate ( z_b2,we_b2 ) + deallocate ( zz,eigg ) + + endif ! loop by processors + +10 continue ! end of cycle by the k-points + +#ifdef CPP_MPI + call MPI_BARRIER(MPI_COMM_WORLD,ierr) +#endif + 5 continue + + l_symcheck = (.not.l_nocosoc).or.(doublespin.eq.doublespin_max) + jspin4=jspin + if(l_nocosoc) jspin4=1 + if(l_p0) write(*,*)'write uHu file' + uHu = uHu * htr2ev + call wann_write_uHu(jspin4,l_p0,fullnkpts,nntot,nntot,wann, + > nbnd,bpt,gb,isize,irank,fending,'',uHu, + > counts(irank),counts,displs,isize, + > wann%l_unformatted,.true.,l_symcheck) + uHu = uHu / htr2ev + if(.not.l_nocosoc) deallocate(uHu) + + if(.not.l_noco)nrec=nrec+nkpts + +110 continue ! end of cycle by spins + +#ifdef CPP_MPI + call MPI_BARRIER(MPI_COMM_WORLD,ierr) +#endif + + ! close eig files + IF (l_gwf) THEN + CLOSE(66) + DO iqpt_b=1,nntot_q + CLOSE(funit_start+iqpt_b) + ENDDO + ENDIF + + +c if(l_p0) write(*,*)'write uHu file' +c uHu = htr2ev * uHu +c call wann_write_uHu(1,l_p0,fullnkpts,nntot,nntot,wann, +c > nbnd,bpt,gb,isize,irank,fending,'',uHu, +c > counts(irank),counts,displs,isize, +c > wann%l_unformatted,.true.) + if(allocated(uHu)) deallocate(uHu) +c if(allocated(uHuold)) deallocate(uHuold) + +314 continue ! iqpt, q-points +c************************************************c +c END Q LOOP c +c************************************************c + + + deallocate ( kveclo,nv,k1,k2,k3 ) + deallocate(flo) + deallocate ( ff,gg,us,dus,duds,uds,ddn) + deallocate ( ulos,dulos,uulon,dulon,uloulopn ) + if (allocated(nv_b))deallocate(kveclo_b,nv_b,k1_b,k2_b,k3_b) + if (allocated(nv_b2))deallocate(kveclo_b2,nv_b2,k1_b2,k2_b2,k3_b2) + if (wann%l_bzsym)deallocate(irreduc,mapkoper,shiftkpt) + if (wann%l_bzsym.AND.l_gwf)deallocate(irreduc_q,mapqoper,shiftqpt) + if (allocated(pair_to_do)) deallocate(pair_to_do,maptopair) + 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) + if(allocated(vpw)) deallocate(vpw) + if(allocated(vzxy)) deallocate(vzxy) + if(allocated(vz)) deallocate(vz) + deallocate(vrf,vr) + deallocate(tdd,tdu,tud,tuu) + deallocate(tdulo,tuulo) + deallocate(tulou,tulod) + deallocate(tuloulo) + deallocate(tdd_soc,tdu_soc,tud_soc,tuu_soc) + deallocate(tdulo_soc,tuulo_soc) + deallocate(tulou_soc,tulod_soc) + deallocate(tuloulo_soc) + deallocate(counts,displs) + +9110 continue + + if(l_sgwf .or. l_socgwf) gb_q = gb_q/2 + + if(l_p0.and.l_gwf) then + call wann_uHu_commat( + > fullnkpts,nntot,bpt,fullnqpts,nntot_q,bpt_q, + > gb,gb_q,aux_latt_const,wann%l_unformatted,l_dim, + > nparampts,param_vec/2.0) + endif + + if(allocated(gb)) deallocate(gb,bpt) + if(allocated(gb_q)) deallocate(gb_q,bpt_q) + +#ifdef CPP_MPI + call MPI_BARRIER(MPI_COMM_WORLD,ierr) +#endif + call cpu_time(t1) + t_total = t1-t00 + if(l_p0) then + write(*,900)'t_init =',t_init + write(*,900)'t_tlmplm=',t_tlmplm + write(*,900)'t_eig =',t_eig + write(*,900)'t_abcof =',t_abcof + write(*,900)'t_int =',t_int + write(*,900)'t_sph =',t_sph + write(*,900)'t_vac =',t_vac + write(*,900)'t_total =',t_total + endif + +900 FORMAT(a,f14.4) + + END SUBROUTINE wann_uHu + + + END MODULE m_wann_uHu + + diff --git a/wannier/uhu/wann_uHu_commat.f b/wannier/uhu/wann_uHu_commat.f new file mode 100644 index 00000000..aa84bc28 --- /dev/null +++ b/wannier/uhu/wann_uHu_commat.f @@ -0,0 +1,429 @@ + module m_wann_uHu_commat + USE m_fleurenv + implicit none + contains + + subroutine wann_uHu_commat(nkpts,nntot,bpt,nqpts,nntot_q, + > bpt_q,gb,gb_q,latt_const_q, + > l_unformatted,l_dim,nparampts, + > param_vec) + use m_wann_gwf_tools + use m_wann_gwf_auxovlp + use m_constants, only : pimach + + implicit none + + ! input parameters + logical,intent(in) :: l_unformatted,l_dim(3) + integer,intent(in) :: nkpts,nntot,nqpts,nntot_q,nparampts + integer,intent(in) :: bpt(nntot,nkpts),bpt_q(nntot_q,nqpts) + integer,intent(in) :: gb(3,nntot,nkpts),gb_q(3,nntot_q,nqpts) + real, intent(in) :: latt_const_q,param_vec(3,nparampts) + + ! allocatable arrays + logical,allocatable :: l_fm(:),l_fm2(:) + integer,allocatable :: gb_kq(:,:,:) + integer,allocatable :: bpt_kq(:,:) + integer,allocatable :: g1(:,:,:),g2(:,:) + integer,allocatable :: b1(:,:),b2(:) + complex,allocatable :: tmp_a(:,:,:),tmp_m(:,:,:,:) + complex,allocatable :: uHukk(:,:,:,:,:) + complex,allocatable :: uHukq(:,:,:,:,:) + complex,allocatable :: mkk(:,:,:,:) + complex,allocatable :: mkq(:,:,:,:) + complex,allocatable :: uHu(:,:,:) + character(len=20),allocatable :: fuHu(:),fuHu2(:) + + ! further variables + integer :: nbnd,nwfs,kb,qb,kb2,qb2,nn_kq,kqb,kqb2,arr_len,shift(3) + integer :: i,j,ikqpt,ikqpt_b,nk,nq,nk2,nq2,g(3) + integer :: nbnd_arti,nqpts_arti,nntot_arti,nnkq_len,nnkq_ind + integer :: nkqpts,nntot_kq,nn,nn2,ikqpt_help,testnn + integer :: dump,nn_arti,nkp,k,b,q,nwf,n,is,ie,countkq,countqk + real :: mmn_r,mmn_i,tau,tpi,a_arti,b_arti,eig + complex :: ovaux + logical :: l_exist,l_miss,l_fe,l_fa,l_proj + character(len=20) :: fq + character(len=32) :: fmt,fmt2 + + write(*,*)'create uHu for HDWF case...' + + call get_dimension(l_dim,arr_len) + call get_shift(l_dim,shift) + + write(*,*)'dimension:',arr_len + write(*,*)'x?,y?,z? :',l_dim(1:3) + if(arr_len.le.3) call fleur_err("dimension<4", + > calledby='wann_gwf_commat') + + nkqpts=nkpts*nqpts + tpi = 2.0*pimach() + a_arti = latt_const_q + b_arti = 0.98*latt_const_q + tau = tpi/real(nqpts)/a_arti + ovaux = 2.0*tpi*tpi*sin(tau*b_arti/2.0) + ovaux = ovaux/(tpi*tpi-tau*tau*b_arti*b_arti) + ovaux = ovaux/(tau*b_arti) + write(*,*)'ov(0)=',ovaux + + allocate(fuHu(nqpts),fuHu2(nqpts),l_fm(nqpts),l_fm2(nqpts)) + +! are all necessary files present? + l_miss=.false. + do q=1,nqpts + write(fq,'(i4.4)')q + fuHu(q) = 'WF1_'//trim(fq)//'.uHu' ! kk-overlaps + fuHu2(q)= 'WF1_'//trim(fq)//'.uHu_kq' ! kq-overlaps + + inquire(file=fuHu(q) ,exist=l_fm(q) ) + inquire(file=fuHu2(q),exist=l_fm2(q)) + + if(.not.l_fm(q) ) write(*,*)'missing: ',fuHu(q) + if(.not.l_fm2(q)) write(*,*)'missing: ',fuHu2(q) + if(.not.(l_fm(q).or.l_fm2(q))) l_miss=.true. + enddo + inquire(file='bkqpts',exist=l_exist) + if(.not.l_exist) write(*,*)'missing: bkqpts' + inquire(file='proj',exist=l_proj) + if(.not.l_proj) write(*,*)'missing: proj' + if(l_miss.or.(.not.l_exist).or.(.not.l_proj)) + > call fleur_err("missing file(s) for HDWFs") + +! get number of bands and wfs from proj + open(405,file='proj',status='old') + read(405,*)nwfs,nbnd + close(405) + write(*,*)'nbnd=',nbnd + write(*,*)'nwfs=',nwfs + + +c*****************************c +c COMPOSITE .MMN FILE c +c*****************************c + + write(fmt,'(a,i1,a)')'(2i6,3x,',arr_len,'i4)' + write(fmt2,'(a,i1,a)')'(i7,i7,3x,',arr_len,'i4)' + + open (202,file='bkqpts',form='formatted',status='old') + rewind (202) + read (202,'(i4)') nntot_kq + write (*,*) 'nntot_kq=',nntot_kq + allocate ( gb_kq(arr_len,nntot_kq,nkqpts), + & bpt_kq(nntot_kq,nkqpts)) + do ikqpt=1,nkqpts + do nn=1,nntot_kq + read (202,fmt) + & ikqpt_help,bpt_kq(nn,ikqpt),(gb_kq(i,nn,ikqpt),i=1,arr_len) + enddo + enddo + close (202) + + if(l_unformatted) then + nnkq_len = (nntot_kq+1)*nntot_kq/2 + allocate(uHukk(nbnd,nbnd,nntot,nntot,nkpts)) + allocate(uHukq(nbnd,nbnd,nntot_q,nntot,nkpts)) + allocate(g1(3,nntot,nkpts)) + allocate(b1(nntot,nkpts)) +c allocate(uHu(nbnd,nbnd,nntot_kq,nntot_kq))!,nkqpts)) + allocate(uHu(nbnd,nbnd,nnkq_len)) + + open(307,file='WF1_gwf.uHu',form='unformatted') + write(307)nbnd,nkqpts,nntot_kq,nnkq_len + write(307)bpt_kq,gb_kq + + !open(853,file='debug_commat') + + countkq=0 + countqk=0 + + do q=1,nqpts + is = get_index_kq(1,q,nkpts) + ie = get_index_kq(nkpts,q,nkpts) + + if(l_fm(q)) then + open(405,file=fuHu(q),form='unformatted') + read(405)b,k,nn + read(405)b1,g1 + read(405)uHukk + close(405,status='delete') + else + uHukk=cmplx(0.,0.) + write(*,*)'k-k overlaps set to zero for q=',q + endif + + if(l_fm2(q)) then + open(405,file=fuHu2(q),form='unformatted') + read(405)b,k,nn + read(405)b1,g1 + read(405)uHukq + close(405,status='delete') + else + uHukq=cmplx(0.,0.) + write(*,*)'k-q overlaps set to zero for q=',q + endif + +c mmnq = mmnq*conjg(mmn_arti) + + do k=1,nkpts + uHu = cmplx(0.,0.) + ikqpt=get_index_kq(k,q,nkpts) + nnkq_ind=0 + do nn=1,nntot_kq + kqb = bpt_kq(nn,ikqpt) + kb=get_index_k(kqb,nkpts) + qb=get_index_q(kqb,nkpts) + + nk=get_index_nn_k(bpt(:,k),nntot,kb, + > gb_kq(:,nn,ikqpt), + > gb(1:3,1:nntot,k),arr_len) + nq=get_index_nn_q(bpt_q(:,q),nntot_q,qb, + > gb_kq(:,nn,ikqpt), + > gb_q(1:3,1:nntot_q,q), + > arr_len,shift,l_dim) + + do nn2=1,nn!nntot_kq + nnkq_ind = nnkq_ind+1 + kqb2= bpt_kq(nn2,ikqpt) + kb2=get_index_k(kqb2,nkpts) + qb2=get_index_q(kqb2,nkpts) + + nk2=get_index_nn_k(bpt(:,k),nntot,kb2, + > gb_kq(:,nn2,ikqpt), + > gb(1:3,1:nntot,k),arr_len) + nq2=get_index_nn_q(bpt_q(:,q),nntot_q,qb2, + > gb_kq(:,nn2,ikqpt), + > gb_q(1:3,1:nntot_q,q), + > arr_len,shift,l_dim) + testnn = nk/abs(nk)+nk2/abs(nk2)+nq/abs(nq)+nq2/abs(nq2) + if(testnn.ne.0) stop 'testnn.ne.0' +c write(*,*)'kq',ikqpt,nn,nn2 +c write(*,*)'k ',k,nk,nk2 +c write(*,*)'q ',q,nq,nq2 + + !write(853,'(a,1x,5(5i))')'kq,nkq',ikqpt,kqb,kqb2,nn,nn2 + !write(853,'(a,1x,5(5i))')'k,nk',k,kb,kb2,nk,nk2 + !write(853,'(a,1x,5(5i))')'q,nq',q,qb,qb2,nq,nq2 + !write(853,*)'nnkq_ind',nnkq_ind,nnkq_len + +c CALL wann_gwf_auxovlp(param_vec(:,qb),param_vec(:,qb2), +c > latt_const_q,ovaux) +c if(ovaux.ne.1.0) write(*,*)'ovaux',ovaux + + if((nq.lt.0) .and. (nq2.lt.0)) then ! kk + uHu(:,:,nnkq_ind)=uHukk(:,:,nk2,nk,k)!*ovaux +c write(*,'(a,5i8)')'' + !write(853,*)'' + elseif((nk.lt.0) .and. (nk2.lt.0)) then ! qq + uHu(:,:,nnkq_ind)=cmplx(0.,0.) +c write(*,'(a,5i8)')'' + !write(853,*)'' + else + if((nk.lt.0) .and. (nk2.ge.0) .and. + > (nq.ge.0) .and. (nq2.lt.0) ) then + uHu(:,:,nnkq_ind) + > = transpose(conjg(uHukq(:,:,nq,nk2,k))) + > *conjg(ovaux) + !write(853,*)'' +c write(*,'(a,8i8)')'' +c write(*,*)nn,nn2 +c write(*,*)'',q,bpt_q(nq,q),k,bpt(nk2,k) + if(q.eq.bpt_q(nq,q)) stop 'q.eq.bpt_q' + countqk=countqk+1 + elseif((nk.ge.0) .and. (nk2.lt.0) .and. + > (nq.lt.0) .and. (nq2.ge.0) ) then + uHu(:,:,nnkq_ind) + > = uHukq(:,:,nq2,nk,k) * ovaux + !write(853,*)'' +c write(*,'(a,8i8)')'' +c write(*,*)nn,nn2 +c write(*,*)'',k,bpt(nk,k),q,bpt_q(nq2,q) + if(q.eq.bpt_q(nq2,q)) stop 'q.eq.bpt_q' + countkq=countkq+1 + else + call fleur_err("problem k,q neighbors", + > calledby="wann_uHu_commat") + endif + endif + enddo + + enddo!nn + write(307)ikqpt,uHu + enddo!k + enddo!q + deallocate(b1,g1,uHukk,uHukq) + + !close(853) + close(307) + deallocate(uHu) + + write(*,*)'countkq',countkq + write(*,*)'countqk',countqk + + else + allocate(mkk(nbnd,nbnd,nntot,nntot)) + allocate(mkq(nbnd,nbnd,nntot_q,nntot)) + open(307,file='WF1_gwf.uHu') + write(307,*)'uHu for HDWFs' + write(307,'(i5,i7,i5)')nbnd,nkqpts,nntot_kq + + do q=1,nqpts + + if(l_fm(q)) then + open(405,file=fuHu(q)) + read(405,*)!title + read(405,*)b,k,nn + endif + if(l_fm2(q)) then + open(505,file=fuHu2(q)) + read(505,*)!title + read(505,*)b,k,nn + endif + + do k=1,nkpts + ikqpt=get_index_kq(k,q,nkpts) + + mkk = cmplx(0.,0.) + if(l_fm(q)) then + do nn=1,nntot + do nn2=1,nntot + read(405,*)nkp,b,i!g(1:3) + do i=1,nbnd + do j=1,nbnd + read(405,*)mmn_r,mmn_i + mkk(j,i,nn2,nn)=cmplx(mmn_r,mmn_i) + enddo + enddo + enddo + enddo + endif + + mkq = cmplx(0.,0.) + if(l_fm2(q)) then + do nn=1,nntot + do nn2=1,nntot_q + read(505,*)nkp,b,i!g(1:3) + do i=1,nbnd + do j=1,nbnd + read(505,*)mmn_r,mmn_i + mkq(j,i,nn2,nn)=cmplx(mmn_r,mmn_i) + enddo + enddo + enddo + enddo + mkq = mkq*ovaux + endif + + do nn=1,nntot_kq ! write composite overlaps + kqb = bpt_kq(nn,ikqpt) + kb=get_index_k(kqb,nkpts) + qb=get_index_q(kqb,nkpts) + + do nn2=1,nntot_kq + kqb2 = bpt_kq(nn2,ikqpt) + kb2=get_index_k(kqb2,nkpts) + qb2=get_index_q(kqb2,nkpts) + + write(307,'(3i7)')ikqpt,kqb,kqb2!gb_kq(1:arr_len,nn,ikqpt) + if((q.eq.qb).and.(q.eq.qb2)) then ! k-overlap + !write(307,*)'' + nk=get_index_nn_k(bpt(:,k),nntot,kb, + > gb_kq(:,nn,ikqpt), + > gb(1:3,1:nntot,k),arr_len) + nk2=get_index_nn_k(bpt(:,k),nntot,kb2, + > gb_kq(:,nn2,ikqpt), + > gb(1:3,1:nntot,k),arr_len) + do i=1,nbnd + do j=1,nbnd + write(307,'(2f24.18)') + > real(mkk(j,i,nk2,nk)),aimag(mkk(j,i,nk2,nk)) + enddo + enddo + elseif((k.eq.kb).and.(k.eq.kb2)) then ! q-overlap + +c write(*,*)'',qb,qb2 + + nq=get_index_nn_q(bpt_q(:,q),nntot_q,qb, + > gb_kq(:,nn,ikqpt), + > gb_q(1:3,1:nntot_q,q), + > arr_len,shift,l_dim) + nq2=get_index_nn_q(bpt_q(:,q),nntot_q,qb2, + > gb_kq(:,nn2,ikqpt), + > gb_q(1:3,1:nntot_q,q), + > arr_len,shift,l_dim) + +c CALL wann_gwf_auxovlp( param_vec(:,qb)+gb_q(:,nq,q), +c > param_vec(:,qb2)+gb_q(:,nq2,q),latt_const_q,ovaux) + + do i=1,nbnd + do j=1,nbnd + write(307,'(2f24.18)') 0.0,0.0 +c > real(mq(j,i,nq)),aimag(mq(j,i,nq)) + enddo + enddo + + else + + if((k.eq.kb).and.(k.ne.kb2).and. + > (q.ne.qb).and.(q.eq.qb2)) then +c write(*,*)'',qb,qb2 + nk2=get_index_nn_k(bpt(:,k),nntot,kb2, + > gb_kq(:,nn2,ikqpt), + > gb(1:3,1:nntot,k),arr_len) + nq=get_index_nn_q(bpt_q(:,q),nntot_q,qb, + > gb_kq(:,nn,ikqpt), + > gb_q(1:3,1:nntot_q,q), + > arr_len,shift,l_dim) + +c CALL wann_gwf_auxovlp( param_vec(:,qb)+gb_q(:,nq,q), +c > param_vec(:,qb2),latt_const_q,ovaux) + + do i=1,nbnd + do j=1,nbnd + write(307,'(2f24.18)') + > real(mkq(i,j,nq,nk2)),-aimag(mkq(i,j,nq,nk2)) + enddo + enddo + + elseif((k.ne.kb).and.(k.eq.kb2).and. + > (q.eq.qb).and.(q.ne.qb2)) then +c write(*,*)'',qb,qb2 + nk=get_index_nn_k(bpt(:,k),nntot,kb, + > gb_kq(:,nn,ikqpt), + > gb(1:3,1:nntot,k),arr_len) + nq2=get_index_nn_q(bpt_q(:,q),nntot_q,qb2, + > gb_kq(:,nn2,ikqpt), + > gb_q(1:3,1:nntot_q,q), + > arr_len,shift,l_dim) + +c CALL wann_gwf_auxovlp( param_vec(:,qb), +c > param_vec(:,qb2)+gb_q(:,nq2,q),latt_const_q,ovaux) + + do i=1,nbnd + do j=1,nbnd + write(307,'(2f24.18)') + > real(mkq(j,i,nq2,nk)),aimag(mkq(j,i,nq2,nk)) + enddo + enddo + + else + call fleur_err("problem k,q neighbors", + > calledby="wann_uHu_commat") + endif + endif + enddo + + enddo!nn + enddo!k + close(405) + close(505) + enddo!q + close(307) + deallocate(mkk,mkq) + endif!l_unformatted + + deallocate(gb_kq,bpt_kq) + deallocate(fuHu,l_fm) + deallocate(fuHu2,l_fm2) + + end subroutine wann_uHu_commat + end module m_wann_uHu_commat diff --git a/wannier/uhu/wann_uHu_commat_save.f b/wannier/uhu/wann_uHu_commat_save.f new file mode 100644 index 00000000..4902b215 --- /dev/null +++ b/wannier/uhu/wann_uHu_commat_save.f @@ -0,0 +1,353 @@ + module m_wann_uHu_commat + USE m_fleurenv + implicit none + contains + + subroutine wann_uHu_commat(nkpts,nntot,bpt,nqpts,nntot_q, + > bpt_q,gb,gb_q,latt_const_q, + > l_unformatted,l_dim,nparampts, + > param_vec) + use m_wann_gwf_tools + use m_wann_gwf_auxovlp + use m_constants, only : pimach + + implicit none + + ! input parameters + logical,intent(in) :: l_unformatted,l_dim(3) + integer,intent(in) :: nkpts,nntot,nqpts,nntot_q,nparampts + integer,intent(in) :: bpt(nntot,nkpts),bpt_q(nntot_q,nqpts) + integer,intent(in) :: gb(3,nntot,nkpts),gb_q(3,nntot_q,nqpts) + real, intent(in) :: latt_const_q,param_vec(3,nparampts) + + ! allocatable arrays + integer,allocatable :: gb_kq(:,:,:) + integer,allocatable :: bpt_kq(:,:) + integer,allocatable :: g1(:,:,:),g2(:,:) + integer,allocatable :: b1(:,:),b2(:) + complex,allocatable :: tmp_a(:,:,:),tmp_m(:,:,:,:) + complex,allocatable :: uHuk(:,:,:,:,:) + complex,allocatable :: mk(:,:,:,:) + complex,allocatable :: uHu(:,:,:,:,:) + character(len=20),allocatable :: fuHu(:),fuHu2(:) + + ! further variables + integer :: nbnd,nwfs,kb,qb,kb2,qb2,nn_kq,kqb,kqb2,arr_len,shift(3) + integer :: i,j,ikqpt,ikqpt_b,nk,nq,nk2,nq2,g(3) + integer :: nbnd_arti,nqpts_arti,nntot_arti + integer :: nkqpts,nntot_kq,nn,nn2,ikqpt_help + integer :: dump,nn_arti,nkp,k,b,q,nwf,n,is,ie + real :: mmn_r,mmn_i,tau,tpi,a_arti,b_arti,eig + complex :: ovaux + logical :: l_exist,l_miss,l_fe,l_fa,l_fm,l_fm2,l_proj + character(len=20) :: fq + character(len=32) :: fmt,fmt2 + + write(*,*)'create uHu for HDWF case...' + + call get_dimension(l_dim,arr_len) + call get_shift(l_dim,shift) + + write(*,*)'dimension:',arr_len + write(*,*)'x?,y?,z? :',l_dim(1:3) + if(arr_len.le.3) call fleur_err("dimension<4", + > calledby='wann_gwf_commat') + + nkqpts=nkpts*nqpts + tpi = 2.0*pimach() + l_fm = .true. + l_fm2 = .true. + l_exist= .true. + +! are all necessary files present? + allocate(fuHu(nqpts),fuHu2(nqpts)) + l_miss=.false. + do q=1,nqpts + write(fq,'(i4.4)')q + fuHu(q) = 'WF1_'//trim(fq)//'.uHu' ! k-overlaps + fuHu2(q)= 'param_'//trim(fq)//'.uHu' ! q-overlaps + + inquire(file=fuHu(q) ,exist=l_fm ) + l_fm2 = .true. + !inquire(file=fuHu2(q),exist=l_fm2) + + if(.not.l_fm ) write(*,*)'missing: ',fuHu(q) + if(.not.l_fm2) write(*,*)'missing: ',fuHu2(q) + if(.not.(l_fm.and.l_fm2))l_miss=.true. + enddo + inquire(file='bkqpts',exist=l_exist) + if(.not.l_exist) write(*,*)'missing: bkqpts' + inquire(file='proj',exist=l_proj) + if(.not.l_proj) write(*,*)'missing: proj' + if(l_miss.or.(.not.l_exist).or.(.not.l_proj)) + > call fleur_err("missing file(s) for HDWFs") + +! get number of bands and wfs from proj + open(405,file='proj',status='old') + read(405,*)nwfs,nbnd + close(405) + write(*,*)'nbnd=',nbnd + write(*,*)'nwfs=',nwfs + + +c*****************************c +c COMPOSITE .MMN FILE c +c*****************************c + + write(fmt,'(a,i1,a)')'(2i6,3x,',arr_len,'i4)' + write(fmt2,'(a,i1,a)')'(i7,i7,3x,',arr_len,'i4)' + + open (202,file='bkqpts',form='formatted',status='old') + rewind (202) + read (202,'(i4)') nntot_kq + write (*,*) 'nntot_kq=',nntot_kq + allocate ( gb_kq(arr_len,nntot_kq,nkqpts), + & bpt_kq(nntot_kq,nkqpts)) + do ikqpt=1,nkqpts + do nn=1,nntot_kq + read (202,fmt) + & ikqpt_help,bpt_kq(nn,ikqpt),(gb_kq(i,nn,ikqpt),i=1,arr_len) + enddo + enddo + close (202) + + if(l_unformatted) then + allocate(uHuk(nbnd,nbnd,nntot,nntot,nkpts)) + allocate(g1(3,nntot,nkpts),g2(3,nntot_q)) + allocate(b1(nntot,nkpts),b2(nntot_q)) + allocate(uHu(nbnd,nbnd,nntot_kq,nntot_kq,nkqpts)) + + do q=1,nqpts + is = get_index_kq(1,q,nkpts) + ie = get_index_kq(nkpts,q,nkpts) + + open(405,file=fuHu(q),form='unformatted') + read(405)b,k,nn + read(405)b1,g1 + read(405)uHuk + close(405) +c open(405,file=fuHu2(q),form='unformatted') +c read(405)b,k,nn +c read(405)b2,g2 +c read(405)mmnq +c close(405) +c mmnq = mmnq*conjg(mmn_arti) + + do k=1,nkpts + ikqpt=get_index_kq(k,q,nkpts) + do nn=1,nntot_kq + kqb = bpt_kq(nn,ikqpt) + kb=get_index_k(kqb,nkpts) + qb=get_index_q(kqb,nkpts) + + do nn2=1,nntot_kq + kqb2= bpt_kq(nn2,ikqpt) + kb2=get_index_k(kqb2,nkpts) + qb2=get_index_q(kqb2,nkpts) + + CALL wann_gwf_auxovlp(param_vec(:,qb),param_vec(:,qb2), + > latt_const_q,ovaux) + if(ovaux.ne.1.0) write(*,*)'ovaux',ovaux + + if((q.eq.qb) .and. (q.eq.qb2)) then ! k neighbors + nk=get_index_nn_k(bpt(:,k),nntot,kb, + > gb_kq(:,nn,ikqpt), + > gb(1:3,1:nntot,k),arr_len) + nk2=get_index_nn_k(bpt(:,k),nntot,kb2, + > gb_kq(:,nn2,ikqpt), + > gb(1:3,1:nntot,k),arr_len) + uHu(:,:,nn2,nn,ikqpt)=uHuk(:,:,nk2,nk,k)*ovaux +c write(*,'(a,5i8)')'',k,kb,kb2,nk,nk2 + elseif((k.eq.kb) .and. (k.eq.kb2)) then ! q neighbors + nq=get_index_nn_q(bpt_q(:,q),nntot_q,qb, + > gb_kq(:,nn,ikqpt), + > gb_q(1:3,1:nntot_q,q), + > arr_len,shift,l_dim) + nq2=get_index_nn_q(bpt_q(:,q),nntot_q,qb2, + > gb_kq(:,nn2,ikqpt), + > gb_q(1:3,1:nntot_q,q), + > arr_len,shift,l_dim) + uHu(:,:,nn2,nn,ikqpt)=cmplx(0.,0.) +c write(*,'(a,5i8)')'',q,qb,qb2,nq,nq2 + else ! otherwise problem + if((k.eq.kb).and.(k.ne.kb2).and. + > (q.ne.qb).and.(q.eq.qb2)) then + nk2=get_index_nn_k(bpt(:,k),nntot,kb2, + > gb_kq(:,nn2,ikqpt), + > gb(1:3,1:nntot,k),arr_len) + nq=get_index_nn_q(bpt_q(:,q),nntot_q,qb, + > gb_kq(:,nn,ikqpt), + > gb_q(1:3,1:nntot_q,q), + > arr_len,shift,l_dim) + uHu(:,:,nn2,nn,ikqpt)=cmplx(0.,0.) +c write(*,'(a,8i8)')'',q,k,qb,qb2,kb,kb2,nq,nk2 + elseif((k.ne.kb).and.(k.eq.kb2).and. + > (q.eq.qb).and.(q.ne.qb2)) then + nk=get_index_nn_k(bpt(:,k),nntot,kb, + > gb_kq(:,nn,ikqpt), + > gb(1:3,1:nntot,k),arr_len) + nq2=get_index_nn_q(bpt_q(:,q),nntot_q,qb2, + > gb_kq(:,nn2,ikqpt), + > gb_q(1:3,1:nntot_q,q), + > arr_len,shift,l_dim) + uHu(:,:,nn2,nn,ikqpt)=cmplx(0.,0.) +c write(*,'(a,8i8)')'',q,k,qb,qb2,kb,kb2,nk,nq2 + else + call fleur_err("problem k,q neighbors", + > calledby="wann_uHu_commat") + endif + endif + enddo + + enddo!nn + enddo!k + enddo!q + deallocate(b1,b2,g1,g2,uHuk) + + open(307,file='WF1_gwf.uHu',form='unformatted') + write(307)nbnd,nkqpts,nntot_kq + write(307)bpt_kq,gb_kq + write(307)uHu + close(307) + deallocate(uHu) + else + allocate(mk(nbnd,nbnd,nntot,nntot)) + open(307,file='WF1_gwf.uHu') + write(307,*)'uHu for HDWFs' + write(307,'(i5,i7,i5)')nbnd,nkqpts,nntot_kq + + do q=1,nqpts + open(405,file=fuHu(q)) + read(405,*)!title + read(405,*)b,k,nn + do k=1,1!nkpts + ikqpt=get_index_kq(k,q,nkpts) + + mk = cmplx(0.,0.) + do nn=1,nntot ! read k-overlaps + kb = bpt(nn,k) + do nn2=1,nntot + kb2= bpt(nn2,k) + read(405,*)nkp,b,i!g(1:3) + do i=1,nbnd + do j=1,nbnd + read(405,*)mmn_r,mmn_i + mk(j,i,nn2,nn)=cmplx(mmn_r,mmn_i) + enddo + enddo + enddo + enddo + + do nn=1,nntot_kq ! write composite overlaps + kqb = bpt_kq(nn,ikqpt) + kb=get_index_k(kqb,nkpts) + qb=get_index_q(kqb,nkpts) + + do nn2=1,nntot_kq + kqb2 = bpt_kq(nn2,ikqpt) + kb2=get_index_k(kqb2,nkpts) + qb2=get_index_q(kqb2,nkpts) + + write(307,'(3i7)')ikqpt,kqb,kqb2!gb_kq(1:arr_len,nn,ikqpt) + if((q.eq.qb).and.(q.eq.qb2)) then ! k-overlap + !write(307,*)'' + nk=get_index_nn_k(bpt(:,k),nntot,kb, + > gb_kq(:,nn,ikqpt), + > gb(1:3,1:nntot,k),arr_len) + nk2=get_index_nn_k(bpt(:,k),nntot,kb2, + > gb_kq(:,nn2,ikqpt), + > gb(1:3,1:nntot,k),arr_len) + do i=1,nbnd + do j=1,nbnd + write(307,'(2f24.18)') + > real(mk(j,i,nk2,nk)),aimag(mk(j,i,nk2,nk)) + enddo + enddo + elseif((k.eq.kb).and.(k.eq.kb2)) then ! q-overlap + +c write(*,*)'',qb,qb2 + + nq=get_index_nn_q(bpt_q(:,q),nntot_q,qb, + > gb_kq(:,nn,ikqpt), + > gb_q(1:3,1:nntot_q,q), + > arr_len,shift,l_dim) + nq2=get_index_nn_q(bpt_q(:,q),nntot_q,qb2, + > gb_kq(:,nn2,ikqpt), + > gb_q(1:3,1:nntot_q,q), + > arr_len,shift,l_dim) + +c CALL wann_gwf_auxovlp( param_vec(:,qb)+gb_q(:,nq,q), +c > param_vec(:,qb2)+gb_q(:,nq2,q),latt_const_q,ovaux) + + do i=1,nbnd + do j=1,nbnd + write(307,'(2f24.18)') 0.0,0.0 +c > real(mq(j,i,nq)),aimag(mq(j,i,nq)) + enddo + enddo + + else + + if((k.eq.kb).and.(k.ne.kb2).and. + > (q.ne.qb).and.(q.eq.qb2)) then +c write(*,*)'',qb,qb2 + nk2=get_index_nn_k(bpt(:,k),nntot,kb2, + > gb_kq(:,nn2,ikqpt), + > gb(1:3,1:nntot,k),arr_len) + nq=get_index_nn_q(bpt_q(:,q),nntot_q,qb, + > gb_kq(:,nn,ikqpt), + > gb_q(1:3,1:nntot_q,q), + > arr_len,shift,l_dim) + +c CALL wann_gwf_auxovlp( param_vec(:,qb)+gb_q(:,nq,q), +c > param_vec(:,qb2),latt_const_q,ovaux) + + do i=1,nbnd + do j=1,nbnd + write(307,'(2f24.18)') 0.0,0.0 +c > real(mq(j,i,nq)),aimag(mq(j,i,nq)) + enddo + enddo + + elseif((k.ne.kb).and.(k.eq.kb2).and. + > (q.eq.qb).and.(q.ne.qb2)) then +c write(*,*)'',qb,qb2 + nk=get_index_nn_k(bpt(:,k),nntot,kb, + > gb_kq(:,nn,ikqpt), + > gb(1:3,1:nntot,k),arr_len) + nq2=get_index_nn_q(bpt_q(:,q),nntot_q,qb2, + > gb_kq(:,nn2,ikqpt), + > gb_q(1:3,1:nntot_q,q), + > arr_len,shift,l_dim) + +c CALL wann_gwf_auxovlp( param_vec(:,qb), +c > param_vec(:,qb2)+gb_q(:,nq2,q),latt_const_q,ovaux) + + do i=1,nbnd + do j=1,nbnd + write(307,'(2f24.18)') 0.0,0.0 +c > real(mq(j,i,nq)),aimag(mq(j,i,nq)) + enddo + enddo + + else + call fleur_err("problem k,q neighbors", + > calledby="wann_uHu_commat") + endif + endif + enddo + + enddo!nn + enddo!k + close(405) + enddo!q + close(307) + deallocate(mk) + endif!l_unformatted + + deallocate(gb_kq,bpt_kq) + deallocate(fuHu) + deallocate(fuHu2) + + end subroutine wann_uHu_commat + end module m_wann_uHu_commat diff --git a/wannier/uhu/wann_uHu_dmi.F b/wannier/uhu/wann_uHu_dmi.F new file mode 100644 index 00000000..4220e45c --- /dev/null +++ b/wannier/uhu/wann_uHu_dmi.F @@ -0,0 +1,1431 @@ +c*******************************************c +c Set up uHu matrix necessary for c +c Wannier-based calc. of DMI c +c*******************************************c +c keyword is 'matrixuhu-dmi' in wann_inp c +c*******************************************c +c < u_{k+b1} | H_{k} | u_{\theta+b2} > c +c c +c Contributions to Hamiltonian: c +c (i) interstitial c +c (ii) muffin tin (a) spherical c +c (b) non-sph. c +c (c) SOC c +c (iii) vacuum c +c*******************************************c +c J.-P. Hanke, Feb. 2016 c +c*******************************************c + MODULE m_wann_uHu_dmi + USE m_fleurenv + CONTAINS + SUBROUTINE wann_uHu_dmi( + > 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,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,zrfs,ig2,area,tau,zatom,nq2,kv2,nop2, + > volint,symor,pos,ef,irecl,l_soc, + > memd,lnonsph,clnu,lmplmd,mlh,nmem,llh,lo1l, + > theta,phi,soc_opt, + > l_ms,l_sgwf,l_socgwf,aux_latt_const, + > param_file,param_vec,nparampts,param_alpha,l_dim,l_nochi) + + 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, only : cdn_read0, cdn_read + use m_od_types, only : od_inp, od_sym + use m_loddop + use m_constants, only : pimach + use m_wann_projmethod + use m_wann_abinv + use m_wann_kptsrotate + use m_wann_read_inp + use m_matmul,only : matmul3,matmul3r + use m_wann_maxbnd + use m_wann_uHu_tlmplm2 + use m_wann_uHu_sph + use m_wann_uHu_int + use m_wann_uHu_soc + use m_wann_uHu_vac + use m_wann_uHu_od_vac + use m_wann_uHu_util + use m_wann_uHu_commat + use m_wann_write_uHu + + IMPLICIT NONE +#include "cpp_double.h" +#ifdef CPP_MPI + include 'mpif.h' + integer ierr(3) + integer cpu_index + integer stt(MPI_STATUS_SIZE) +#endif +c ..scalar arguments.. + character(len=20),intent(in) :: param_file + type (od_inp), intent (in) :: odi + type (od_sym), intent (in) :: ods + logical, intent (in) :: invs,invs2,film,slice,symor,zrfs + logical, intent (in) :: l_noco,l_ss,l_soc,l_nochi + logical, intent (in) :: l_ms,l_sgwf,l_socgwf + integer, intent (in) :: lmaxd,ntypd,neigd,nkptd,kk,nnne + integer, intent (in) :: natd,nop,nvd,jspd,nbasfcn,nq2,nop2 + integer, intent (in) :: llod,nlod,ntype,nwdd,n3d,n2d + integer, intent (in) :: nmzxyd,nmzd,jmtd,nlhd,nq3,nvac + integer, intent (in) :: ntypsd,jspins,k1d,k2d,k3d + integer, intent (in) :: irank,isize,nv2d,nmzxy,nmz + integer, intent (in) :: irecl,memd,lmplmd,nparampts + real, intent (in) :: omtil,e1s,e2s,delz,area,z1,volint + real, intent (in) :: ef,theta,phi,aux_latt_const + +c ..array arguments.. + logical, intent (in) :: l_dulo(nlod,ntypd) + logical, intent (in) :: soc_opt(ntype+2),l_dim(3) + integer, intent (in) :: ig(-k1d:k1d,-k2d:k2d,-k3d:k3d) + integer, intent (in) :: nlh(ntypsd),jri(ntypd),ntypsy(natd) + integer, intent (in) :: nlo(ntypd),llo(nlod,ntypd),lapw_l(ntypd) + integer, intent (in) :: invtab(nop),mrot(3,3,nop),ngopr(natd) + integer, intent (in) :: neq(ntypd),lmax(ntypd) + integer, intent (in) :: invsat(natd),invsatnr(natd),nkpt(nwdd) + integer, intent (in) :: ulo_der(nlod,ntypd),ig2(n3d),kv2(2,n2d) + integer, intent (in) :: mlh(memd,0:nlhd,ntypsd) + integer, intent (in) :: nmem(0:nlhd,ntypsd) + integer, intent (in) :: llh(0:nlhd,ntypsd),lnonsph(ntypd) + integer, intent (in) :: lo1l(0:llod,ntypd) + real, intent (in) :: rgphs(-k1d:k1d,-k2d:k2d,-k3d:k3d) + real, intent (in) :: taual(3,natd),rmt(ntypd),dx(ntypd) + real, intent (in) :: amat(3,3),bmat(3,3),bbmat(3,3) + real, intent (in) :: rmsh(jmtd,ntypd),tau(3,nop),zatom(ntype) + real, intent (inout) :: alph(ntypd),beta(ntypd),qss(3) + real, intent (in) :: pos(3,natd),sk2(n2d),phi2(n2d) + real, intent (in) :: param_vec(3,nparampts) + real, intent (in) :: param_alpha(ntypd,nparampts) + complex, intent (in) :: ustep(n3d) + complex, intent (in) :: clnu(memd,0:nlhd,ntypsd) + +c ..allocatable arrays.. + integer, allocatable :: kveclo(:) , nv(:) + integer, allocatable :: kveclo_b(:) , nv_b(:) + integer, allocatable :: kveclo_b2(:), nv_b2(:) + integer, allocatable :: k1(:,:) , k2(:,:) , k3(:,:) + integer, allocatable :: k1_b(:,:) , k2_b(:,:) , k3_b(:,:) + integer, allocatable :: k1_b2(:,:), k2_b2(:,:), k3_b2(:,:) + integer, allocatable :: irreduc(:),mapkoper(:) + integer, allocatable :: irreduc_q(:),mapqoper(:) + integer, allocatable :: shiftkpt(:,:),pair_to_do(:,:) + integer, allocatable :: shiftqpt(:,:),pair_to_do_q(:,:) + integer, allocatable :: maptopair(:,:,:) + integer, allocatable :: maptopair_q(:,:,:) + integer, allocatable :: counts(:),displs(:) + integer, allocatable :: gb(:,:,:),bpt(:,:) + integer, allocatable :: gb_q(:,:,:),bpt_q(:,:) + real, allocatable :: we(:),we_b(:),we_b2(:) + real, allocatable :: eigg(:) + real, allocatable :: vr(:,:,:),vz(:,:,:),vrf(:,:,:,:) + real, allocatable :: flo(:,:,:,:,:) + real, allocatable :: ff(:,:,:,:,:),gg(:,:,:,:,:) + real, allocatable :: us(:,:,:),uds(:,:,:),ulos(:,:,:) + real, allocatable :: dus(:,:,:),duds(:,:,:),dulos(:,:,:) + real, allocatable :: ddn(:,:,:),uulon(:,:,:),dulon(:,:,:) + real, allocatable :: uloulopn(:,:,:,:) + real, allocatable :: kdiff(:,:),qdiff(:,:),zero_qdiff(:,:) + real, allocatable :: kdiff2(:,:) + complex, allocatable :: vpw(:,:),vzxy(:,:,:,:) + complex, allocatable :: uHu(:,:,:,:,:) + complex, allocatable :: acof_b(:,:,:),acof_b2(:,:,:) + complex, allocatable :: bcof_b(:,:,:),bcof_b2(:,:,:) + complex, allocatable :: ccof_b(:,:,:,:),ccof_b2(:,:,:,:) + complex, allocatable :: tdd(:,:,:,:,:),tdu(:,:,:,:,:) + complex, allocatable :: tud(:,:,:,:,:),tuu(:,:,:,:,:) + complex, allocatable :: tdd_soc(:,:,:,:,:),tdu_soc(:,:,:,:,:) + complex, allocatable :: tud_soc(:,:,:,:,:),tuu_soc(:,:,:,:,:) + complex, allocatable :: tdulo(:,:,:,:,:,:),tuulo(:,:,:,:,:,:) + complex, allocatable :: tulod(:,:,:,:,:,:),tulou(:,:,:,:,:,:) + complex, allocatable :: tuloulo(:,:,:,:,:,:,:) + complex, allocatable :: tdulo_soc(:,:,:,:,:,:), + > tuulo_soc(:,:,:,:,:,:) + complex, allocatable :: tulod_soc(:,:,:,:,:,:), + > tulou_soc(:,:,:,:,:,:) + complex, allocatable :: tuloulo_soc(:,:,:,:,:,:,:) +#if ( !defined(CPP_INVERSION) || defined(CPP_SOC) ) + complex, allocatable :: z(:,:),zz(:,:) + complex, allocatable :: z_b(:,:) + complex, allocatable :: z_b2(:,:) +#else + real, allocatable :: z(:,:),zz(:,:) + real, allocatable :: z_b(:,:) + real, allocatable :: z_b2(:,:) +#endif + +c ..local arrays.. + character(len=2) :: spin012(0:2) + data spin012/' ', '.1', '.2'/ + character(len=3) :: spin12(2) + data spin12/'WF1' , 'WF2'/ + character(len=8) :: name(10) + integer :: n_bands(0:neigd),ngopr1(natd) + real :: bkpt(3),bkpt_b(3),bkpt_b2(3),bkrot(3) + real :: eig(neigd),eig_b(neigd),eig_b2(neigd) + real :: uuilon(nlod,ntypd),duilon(nlod,ntypd) + real :: ulouilopn(nlod,nlod,ntypd) + real :: ello(nlod,ntypd,max(2,jspd)),evac(2,max(2,jspd)) + real :: epar(0:lmaxd,ntypd,max(2,jspd)),evdu(2,max(jspd,2)) + real :: qpt_i(3),qptb_i(3) + real :: alph_i(ntypd),alphb_i(ntypd) + real :: beta_i(ntypd),betab_i(ntypd) + real :: cp_time(9) + +c ..local scalars.. + character(len=6) :: filename + character(len=8) :: dop,iop + character(len=12) fending + character(len=30) fstart + type(t_wann) :: wann + logical :: l_p0,l_bkpts,l_proj,l_file + logical :: l_bqpts,l_gwf,l_exist + logical :: l_skip_sph,l_skip_non,l_skip_soc + logical :: l_skip_int,l_skip_vac,l_skip_loc + integer :: lmd,nlotot,n,iter,ikpt,ikpt_b,ikpt_b2,iqpt,iqpt_b + integer :: addnoco,addnoco2,funbas,loplod,igvm2 + integer :: nn,nkpts,i,j,l,i_rec,m,nwf,nwfp + integer :: jsp_start,jsp_end,nrec,nrec_b,nrec1 + integer :: nodeu,noded,n_size,na,n_rank,nbnd,numbands + integer :: i1,i2,i3,in,lda + integer :: nmat,nmat_b,nmat_b2,nmat_qb + integer :: nbands,nbands_b,nbands_b2,nbands_qb + integer :: nslibd,nslibd_b,nslibd_b2,nslibd_qb + integer :: noccbd,noccbd_b,noccbd_b2,noccbd_qb + integer :: kptibz,kptibz_b,kptibz_b2 + integer :: qptibz, qptibz_b + integer :: oper,oper_b,oper_b2,oper_q, oper_qb + integer :: nwfs,nntot,nntot2,nntot_q,fullnkpts,fullnqpts + integer :: kpt,qpt,j1,j2,j3,k,ikpt_help,iqpt_help + integer :: wannierspin,jspin,jspin_b,jspin2 + integer :: jspin3,jspin4,jspin5,tspin,tspin2 + integer :: n_start,n_end,mlotot,mlolotot,err + integer :: mlot_d,mlolot_d,ilo,dir,length + integer :: npotmatfile,ig3,maxvac,irec,imz,ivac,ipot + integer :: funit_start,band_help,sign2 + integer :: doublespin,doublespin_max,doublespin_start,nrec5 + integer :: aoff,d1,d10,d100 + real :: tpi,wronk,wk,wk_b,wk_b2 + real :: t0,t00,t1,t_tlmplm,t_init + real :: t_int,t_sph,t_vac,t_abcof,t_eig,t_total + real :: efermi,htr2ev + real :: theta_i, thetab_i, phi_i, phib_i,dth,dph + complex :: nsfactor,nsfactor_b,nsfactor_b2 + complex :: ci,chi,chi2 + + if(.not.l_socgwf) stop 'wann_uHu_dmi only with l_socgwf=T' + if(l_sgwf) stop 'wann_uHu_dmi only with l_sgwf=F' + if(l_noco) stop 'noco and dmi not implemented' + + if(irank.eq.0) write(*,*)'Wannier-based DMI interpolation' +c stop 'temporary_stop' + +c ..initializations.. + call cpu_time(t00) + + ci = cmplx(0.,1.) + t_init = 0.; t_tlmplm = 0.; t_eig = 0. + t_abcof = 0.; t_int = 0.; t_sph = 0. + t_vac = 0.; t_total = 0. + htr2ev = 27.2 + nntot_q = 1 + fullnqpts = 1 + funit_start = 5000 + + aoff = iachar('1')-1 + d1 = mod(irank,10) + IF (irank < 100) THEN + d10 = int( (irank + 0.5)/10 ) + fstart = 'eig'//achar(d10+aoff)//achar(d1+aoff) + ELSE + d10 = mod((irank-d1)/10,10) + d100 = (irank-10*d10-d1)/100 + IF ( d100.GE.10 ) d100 = d100 + iachar('7') + fstart = + + 'eig'//achar(d100+aoff)//achar(d10+aoff)//achar(d1+aoff) + ENDIF + + + ngopr1(:)=1 + + l_p0 = .false. + if (irank.eq.0) l_p0 = .true. + + tpi = 2* pimach() + lmd = lmaxd*(lmaxd+2) + +!!! should be changed in case the windows are really used + nkpts = maxval(nkpt(:)) + + ! do we have to construct GWF ? + l_gwf = .false. + l_gwf = l_sgwf.or.l_socgwf + + +c-----read the input file to determine what to do + call wann_read_inp( + > l_p0, + < wann) + + if(wann%l_byenergy.and.wann%l_byindex) CALL fleur_err + + ("byenergy.and.byindex",calledby ="wannier") + if(wann%l_byenergy.and.wann%l_bynumber) CALL fleur_err + + ("byenergy.and.bynumber",calledby ="wannier") + if(wann%l_bynumber.and.wann%l_byindex) CALL fleur_err + + ("bynumber.and.byindex",calledby ="wannier") + if(.not.(wann%l_bynumber.or.wann%l_byindex.or.wann%l_byenergy)) + & CALL fleur_err("no rule to sort bands",calledby ="wannier") + + + efermi=ef + if(.not.wann%l_fermi)efermi=0.0 + +#ifdef CPP_MPI + call MPI_BARRIER(MPI_COMM_WORLD,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 fleur_err + + ("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 fleur_err("bpt.gt.fullnkpts" + + ,calledby ="wannier") + enddo + enddo + close (202) + allocate(kdiff(3,nntot)) + +c********************************************************** +ccccccccccccccc read in the bqpts file ccccccccccccccccc +c********************************************************** + if (l_gwf.or.l_ms) then ! for Omega functional minimization + l_bqpts = .false. + inquire (file='bqpts',exist=l_bqpts) + if (.not.l_bqpts) CALL fleur_err("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 fleur_err("iqpt.ne.iqpt_help" + + ,calledby ="wannier") + if (bpt_q(nn,iqpt)>fullnqpts) + & CALL fleur_err("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(l_sgwf) gb_q = 2*gb_q + if(l_socgwf) gb_q = 2*gb_q + + if(wann%l_finishgwf) goto 9110 +c******************************************************** +c find symmetry-related elements in mmkb +c******************************************************** + allocate(maptopair(3,fullnkpts,nntot)) + allocate(pair_to_do(fullnkpts,nntot)) + call wann_mmnk_symm( + > fullnkpts,nntot,bpt,gb,wann%l_bzsym, + > irreduc,mapkoper,l_p0,film,nop,invtab,mrot,odi%d1, + > tau, + < pair_to_do,maptopair,kdiff,.false.,param_file) + + ! do the same for q-points to construct GWFs + if(l_gwf)then + allocate(maptopair_q(3,fullnqpts,nntot_q)) + allocate(pair_to_do_q(fullnqpts,nntot_q)) + call wann_mmnk_symm( + > fullnqpts,nntot_q,bpt_q,gb_q,wann%l_bzsym, + > irreduc_q,mapqoper,l_p0,.false.,1,invtab(1),mrot(:,:,1), + > .false.,tau, + < pair_to_do_q,maptopair_q,qdiff,.true.,param_file) + endif + + + nntot2 = 1 + allocate(kdiff2(3,nntot2)) + kdiff2 = 0.0 + +c********************************************************* +cccccccccccccccc initialize the potential cccccccccccc +c********************************************************* + + if(.not. l_noco) then + allocate ( vpw(n3d,jspd),vzxy(nmzxyd,odi%n2d-1,2,jspd) ) + else + allocate ( vpw(n3d,4),vzxy(nmzxyd,odi%n2d-1,2,4) ) + endif + + allocate ( vz(nmzd,2,4) ) + allocate ( vrf(jmtd,0:nlhd,ntypd,jspd) ) + allocate ( vr(jmtd,ntypd,jspd) ) + + open (8,file='pottot',form='unformatted',status='old') + rewind (8) + + call loddop( + > jspd,n3d,odi%n2d,nmzxyd,nmzd,jmtd,nlhd,ntypd, + > jspins,nq3,odi%nq2,nvac,ntype,invs,invs2,film, + > nlh,jri,ntypsd,ntypsy,8,natd,neq, + < iop,dop,iter,vrf,vpw,vz,vzxy,name) + + close (8) + + do jspin = 1,jspins + do n = 1, ntype + do j = 1,jri(n) + vr(j,n,jspin) = vrf(j,0,n,jspin) + enddo + enddo + enddo + + if(.not. film) deallocate(vz,vzxy) + + if(l_noco)then + npotmatfile=25 + + OPEN (npotmatfile,FILE='potmat',FORM='unformatted', + + STATUS='old') +c---> load the interstitial potential + READ (npotmatfile) (vpw(ig3,1),ig3=1,n3d) + READ (npotmatfile) (vpw(ig3,2),ig3=1,n3d) + READ (npotmatfile) (vpw(ig3,3),ig3=1,n3d) + vpw(:,4) = conjg(vpw(:,3)) + if(film) then + maxvac=2 + if(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. (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,nmzd),ipot=1,4) + +c---> load the warping part of the potential + if(.not.odi%d1)then + DO ipot = 1,3 + READ (npotmatfile)((vzxy(imz,igvm2,ivac,ipot), + + imz=1,nmzxy),igvm2=1,nq2-1) + ENDDO + else + DO ipot = 1,3 + READ (npotmatfile)((vzxy(imz,igvm2,ivac,ipot), + + imz=1,nmzxy),igvm2=1,odi%n2d-1) + ENDDO + endif + vzxy(:,:,:,4) = conjg(vzxy(:,:,:,3)) + enddo + endif + CLOSE (npotmatfile) + endif + + + if(film .and. l_p0) write(*,*)'nvac',nvac + +cccccccccccccccc end of the potential part ccccccccccc + wannierspin=jspd + if(l_soc) wannierspin=2 + + allocate ( flo(ntypd,jmtd,2,nlod,2) ) + allocate ( ff(ntypd,jmtd,2,0:lmaxd,2) ) + allocate ( gg(ntypd,jmtd,2,0:lmaxd,2) ) + allocate ( us(0:lmaxd,ntypd,2) ) + allocate ( uds(0:lmaxd,ntypd,2) ) + allocate ( dus(0:lmaxd,ntypd,2) ) + allocate ( duds(0:lmaxd,ntypd,2) ) + allocate ( ddn(0:lmaxd,ntypd,2) ) + allocate ( ulos(nlod,ntypd,2) ) + allocate ( dulos(nlod,ntypd,2) ) + allocate ( uulon(nlod,ntypd,2) ) + allocate ( dulon(nlod,ntypd,2) ) + allocate ( uloulopn(nlod,nlod,ntypd,2) ) + + allocate ( kveclo(nlotot),nv(wannierspin) ) + allocate ( kveclo_b(nlotot),nv_b(wannierspin) ) + allocate ( kveclo_b2(nlotot),nv_b2(wannierspin) ) + allocate ( k1(nvd,wannierspin),k2(nvd,wannierspin), + & k3(nvd,wannierspin) ) + allocate ( k1_b(nvd,wannierspin),k2_b(nvd,wannierspin), + & k3_b(nvd,wannierspin) ) + allocate ( k1_b2(nvd,wannierspin),k2_b2(nvd,wannierspin), + & k3_b2(nvd,wannierspin) ) + + doublespin_start=1 + if(l_noco.or.l_soc) then + doublespin_max=4 + else + doublespin_max=wannierspin + endif + + l_skip_int = .false.; l_skip_soc = .false.; l_skip_vac = .false. + l_skip_sph = .false.; l_skip_non = .false.; l_skip_loc = .false. + inquire(file='debug_uHu',exist=l_exist) + if(l_exist) then + open(888,file='debug_uHu') + read(888,*)l_skip_int + read(888,*)l_skip_sph + read(888,*)l_skip_non + read(888,*)l_skip_soc + read(888,*)l_skip_loc + read(888,*)l_skip_vac + read(888,*)doublespin_max + read(888,*)doublespin_start + close(888) + if(l_p0) then + write(*,*)'skip INT :',l_skip_int + write(*,*)'skip SPH :',l_skip_sph + write(*,*)'skip NON :',l_skip_non + write(*,*)'skip SOC :',l_skip_soc + write(*,*)'skip LOC :',l_skip_loc + write(*,*)'skip VAC :',l_skip_vac + write(*,*)'doublespin_max:',doublespin_max + endif + endif + + allocate( tdd(0:lmd,0:lmd,ntypd,nntot*nntot2,4) ) + allocate( tdu(0:lmd,0:lmd,ntypd,nntot*nntot2,4) ) + allocate( tud(0:lmd,0:lmd,ntypd,nntot*nntot2,4) ) + allocate( tuu(0:lmd,0:lmd,ntypd,nntot*nntot2,4) ) + allocate( tdd_soc(0:lmd,0:lmd,ntypd,nntot*nntot2,2) ) + allocate( tdu_soc(0:lmd,0:lmd,ntypd,nntot*nntot2,2) ) + allocate( tud_soc(0:lmd,0:lmd,ntypd,nntot*nntot2,2) ) + allocate( tuu_soc(0:lmd,0:lmd,ntypd,nntot*nntot2,2) ) + allocate( tdulo(0:lmd,nlod,-llod:llod,ntypd,nntot*nntot2,4) ) + allocate( tuulo(0:lmd,nlod,-llod:llod,ntypd,nntot*nntot2,4) ) + allocate( tulou(0:lmd,nlod,-llod:llod,ntypd,nntot*nntot2,4) ) + allocate( tulod(0:lmd,nlod,-llod:llod,ntypd,nntot*nntot2,4) ) + allocate( tuloulo(nlod,-llod:llod,nlod,-llod:llod, + > ntypd,nntot*nntot2,4) ) + allocate( tdulo_soc(0:lmd,nlod,-llod:llod,ntypd,nntot*nntot2,2) ) + allocate( tuulo_soc(0:lmd,nlod,-llod:llod,ntypd,nntot*nntot2,2) ) + allocate( tulou_soc(0:lmd,nlod,-llod:llod,ntypd,nntot*nntot2,2) ) + allocate( tulod_soc(0:lmd,nlod,-llod:llod,ntypd,nntot*nntot2,2) ) + allocate( tuloulo_soc(nlod,-llod:llod,nlod,-llod:llod, + > ntypd,nntot*nntot2,2) ) + + tuu = cmplx(0.,0.); tdu = cmplx(0.,0.) + tud = cmplx(0.,0.); tdd = cmplx(0.,0.) + tuu_soc = cmplx(0.,0.); tdu_soc = cmplx(0.,0.) + tud_soc = cmplx(0.,0.); tdd_soc = cmplx(0.,0.) + tuulo = cmplx(0.,0.); tdulo = cmplx(0.,0.) + tulou = cmplx(0.,0.); tulod = cmplx(0.,0.) + tuloulo = cmplx(0.,0.) + tuulo_soc = cmplx(0.,0.); tdulo_soc = cmplx(0.,0.) + tulou_soc = cmplx(0.,0.); tulod_soc = cmplx(0.,0.) + tuloulo_soc = cmplx(0.,0.) + + + call cpu_time(t1) + t_init = t1-t00 + +c*****************************************************************c +c START Q LOOP c +c*****************************************************************c + do 314 iqpt = 1,fullnqpts ! loop by q-points starts + + 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 = qss + alph_i = alph + beta_i = beta + theta_i = theta + phi_i = phi + if(l_sgwf.or.l_ms) then + qpt_i(:) = param_vec(:,qptibz) + alph_i(:) = param_alpha(:,qptibz) + elseif(l_socgwf) then + if(l_dim(2)) phi_i = tpi*param_vec(2,qptibz) + if(l_dim(3)) theta_i = tpi*param_vec(3,qptibz) + endif + + IF (l_gwf) THEN + do iqpt_b=1,nntot_q + WRITE(fending,'("_",i4.4)')bpt_q(iqpt_b,iqpt) + OPEN(funit_start+iqpt_b,file=trim(fstart)//fending, + > access='direct', + > form='unformatted',recl=irecl,status='old') + enddo + WRITE(fending,'("_",i4.4)')qptibz + OPEN(66,file=trim(fstart)//fending,access='direct', + > form='unformatted',recl=irecl,status='old') + ELSEIF(l_ms) THEN + WRITE(fending,'("_",i4.4)')qptibz + OPEN(66,file=trim(fstart)//fending,access='direct', + > form='unformatted',recl=irecl,status='old') + ELSE + fending='' + ENDIF ! l_gwf.or.l_ms + nrec=0 + nrec_b=0 + +c**************************************************** +c cycle by spins starts! +c**************************************************** + do 110 doublespin=doublespin_start,doublespin_max ! cycle by spins + if(l_p0) write(*,*)'spin loop:',doublespin + +c jspin=mod(doublespin+1,2)+1 +c jspin_b=jspin +c if(doublespin.eq.3) jspin_b=2 +c if(doublespin.eq.4) jspin_b=1 + jspin_b=mod(doublespin+1,2)+1 + jspin=jspin_b + if(doublespin.eq.3) jspin=2 + if(doublespin.eq.4) jspin=1 + + nrec_b = nrec + + if(.not.l_noco) then + nrec = (jspin-1)*nkpts + nrec_b = (jspin_b-1)*nkpts + endif + +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 fleur_err("no proj/proj.1/proj.2",calledby ="wannier") + endif + + + jspin2=jspin + if(l_soc .and. jspins.eq.1)jspin2=1 + jsp_start = jspin ; jsp_end = jspin + +cccccccccccc read in the eigenvalues and vectors cccccc + do jspin5=1,2 + jsp_start=jspin5; jsp_end=jspin5 + nrec5=0 + if(.not.l_noco) nrec5 = (jspin5-1)*nkpts + call cdn_read0( + > lmaxd,ntypd,nlod,neigd,jspd,!wannierspin, + > irank,isize,jspin5,jsp_start,jsp_end, + > l_noco,nrec5,66, !nrec + < ello,evac,epar,bkpt,wk,n_bands,nrec1,n_size) + enddo + +c.. now we want to define the maximum number of the bands by all kpts + nbnd = 0 + i_rec = 0 ; n_rank = 0 + + if(l_p0)then + call wann_maxbnd( + > lmaxd,ntypd,nlod,neigd,nvd,wannierspin, + > isize,jspin,nbasfcn,nlotot, + > l_ss,l_noco,nrec,fullnkpts,irecl, + > wann%l_bzsym,wann%l_byindex,wann%l_bynumber, + > wann%l_byenergy, + > irreduc,odi,wann%band_min(jspin), + > wann%band_max(jspin), + > numbands,e1s,e2s,efermi,nkpts, + < nbnd,l_gwf,iqpt) + write(*,*)'iqpt=',iqpt,'nbnd=',nbnd + 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,isize-1 + call MPI_SEND(nbnd,1,MPI_INTEGER,cpu_index,1,MPI_COMM_WORLD,ierr) + enddo + else + call MPI_RECV(nbnd,1,MPI_INTEGER,0,1,MPI_COMM_WORLD,stt,ierr) + endif +#endif + +c################################################################## + if(.not.allocated(uHu)) then + allocate(uHu(nbnd,nbnd,nntot_q,nntot,counts(irank))) + uHu = cmplx(0.,0.) + endif + + + + if(iqpt.eq.1) then + + do jspin4=1,2 + jspin3=jspin4 + if(jspins.eq.1) jspin3=1 + na = 1 + do 40 n = 1,ntype + do 30 l = 0,lmax(n) +c...compute the l-dependent, k-independent radial MT- basis functions + call radfun( + > l,epar(l,n,jspin3),vr(1,n,jspin3),jri(n),rmsh(1,n), + > dx(n),jmtd, + < ff(n,:,:,l,jspin4),gg(n,:,:,l,jspin4), + > us(l,n,jspin4), + < dus(l,n,jspin4),uds(l,n,jspin4),duds(l,n,jspin4), + < ddn(l,n,jspin4),nodeu,noded,wronk) + 30 continue +c...and the local orbital radial functions + do ilo = 1, nlo(n) + call radflo( + > ntypd,nlod,jspd,jmtd,lmaxd,n,jspin, !jspin not important + > ello(1,1,jspin3),vr(1,n,jspin3), + > jri(n),rmsh(1,n),dx(n),ff(n,1:,1:,0:,jspin4), + > gg(n,1:,1:,0:,jspin4),llo,nlo,l_dulo(1,n), + > irank,ulo_der, + < ulos(1,1,jspin4),dulos(1,1,jspin4),uulon(1,1,jspin4), + > dulon(1,1,jspin4), + < uloulopn(1,1,1,jspin4),uuilon,duilon,ulouilopn, + > flo(n,:,:,:,jspin4)) + enddo +c na = na + neq(n) + 40 continue + enddo!jspin3 + + + if(l_p0) write(*,'(4(a,i1),a)')'< ',jspin,' | H_MT(',jspin,',', + > jspin,') | ',jspin_b,' >' + jspin3=jspin + if(jspins.eq.1) jspin3=1 + call cpu_time(t0) + call wann_uHu_tlmplm2( + > memd,nlhd,ntypsd,ntypd,jmtd,lmaxd,jspd,ntype,dx, + > rmsh,jri,lmax,ntypsy,natd,lnonsph,lmd,lmplmd,clnu, + > mlh,nmem,llh,nlh,neq,irank,mlotot,mlolotot, + > vrf(:,:,:,jspin3),nlod,llod,loplod,ello(1,1,jspin3), + > llo,nlo,lo1l,l_dulo,ulo_der,ff(:,:,:,:,jspin), + > gg(:,:,:,:,jspin),flo(:,:,:,:,jspin), + > ff(:,:,:,:,jspin_b),gg(:,:,:,:,jspin_b), + > flo(:,:,:,:,jspin_b),kdiff,kdiff2,nntot,nntot2,bmat,bbmat, + > vr(1,1,jspin3),epar(0,1,1),invsat,jspin,jspin_b, + > l_skip_sph,l_skip_non,l_skip_loc, + < tuu(:,:,:,:,doublespin),tud(:,:,:,:,doublespin), + > tdu(:,:,:,:,doublespin),tdd(:,:,:,:,doublespin), + > tuulo(:,:,:,:,:,doublespin),tulou(:,:,:,:,:,doublespin), + > tdulo(:,:,:,:,:,doublespin),tulod(:,:,:,:,:,doublespin), + > tuloulo(:,:,:,:,:,:,doublespin)) + call cpu_time(t1) + t_tlmplm = t_tlmplm + t1-t0 + + endif!iqpt.eq.1 + + if(l_soc.and. (.not.l_skip_soc)) then + + tuu_soc = cmplx(0.,0.); tdu_soc = cmplx(0.,0.) + tdd_soc = cmplx(0.,0.); tud_soc = cmplx(0.,0.) + tuulo_soc = cmplx(0.,0.); tdulo_soc = cmplx(0.,0.) + tulou_soc = cmplx(0.,0.); tulod_soc = cmplx(0.,0.) + tuloulo_soc = cmplx(0.,0.) + + do tspin=1,2 + jspin5=jspin + if(tspin.eq.2) then + if(jspin.eq.1) jspin5=2 + if(jspin.eq.2) jspin5=1 + endif + if(l_p0) write(*,'(4(a,i1),a,f9.6)') + > '< ',jspin,' | H_SO(',jspin,',',jspin5,') | ', + > jspin_b,' > for theta=',theta_i + call cpu_time(t0) + call wann_uHu_soc( + > ntypd,jmtd,lmaxd,jspd, + > ntype,dx,rmsh,jri,lmax,natd, + > lmd,lmplmd,neq,irank, + > nlod,llod,loplod,ello,llo,nlo,lo1l,l_dulo,ulo_der, + > ff(:,:,:,:,jspin),gg(:,:,:,:,jspin),flo(:,:,:,:,jspin), + > ff(:,:,:,:,jspin_b),gg(:,:,:,:,jspin_b),flo(:,:,:,:,jspin_b), + > kdiff,kdiff2,nntot,nntot2,bmat,bbmat, + > vr,epar,jspin,jspin5,jspins, + > .true.,theta_i,phi_i,alph_i,beta_i,l_noco,l_skip_loc, + < tuu_soc(:,:,:,:,tspin),tud_soc(:,:,:,:,tspin), + > tdu_soc(:,:,:,:,tspin),tdd_soc(:,:,:,:,tspin), + > tuulo_soc(:,:,:,:,:,tspin),tulou_soc(:,:,:,:,:,tspin), + > tdulo_soc(:,:,:,:,:,tspin),tulod_soc(:,:,:,:,:,tspin), + > tuloulo_soc(:,:,:,:,:,:,tspin)) + call cpu_time(t1) + t_tlmplm = t_tlmplm + t1-t0 + enddo!tspin + endif!l_soc + + !endif!iqpt.eq.1 + + i_rec = 0 ; n_rank = 0 + +c**************************************************************** +c.. loop by kpoints starts! each may be a separate task +c**************************************************************** + if(l_p0) write(*,*)'start k-loop' + do 10 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) + + if(kpt_on_node(ikpt,isize,counts,displs).eq.irank) then + i_rec = i_rec + 1 +c if (mod(i_rec-1,isize).eq.irank) then + + allocate ( zz(nbasfcn,neigd),eigg(neigd) ) + + n_start=1 + n_end=neigd + + call cpu_time(t0) + ! get current bkpt vector +#if(!defined(CPP_HDF) && defined(CPP_MPI)) + call wann_read_eig( + > lmaxd,ntypd,nlod,neigd,nvd,wannierspin, + > irank,isize,kptibz,jspin,nbasfcn,nlotot, + > l_ss,l_noco,nrec,irecl, + < nmat,nv,ello,evdu,epar,kveclo, + < k1,k2,k3,bkpt,wk,nbands, + < eigg,zz,cp_time,66,l_gwf,iqpt) +#else + call cdn_read( + > lmaxd,ntypd,nlod,neigd,nvd,jspd,!wannierspin, + > irank,isize,kptibz,jspin,nbasfcn,nlotot, + > l_ss,l_noco,nrec,kptibz,66, + > neigd,n_start,n_end, + < nmat,nv,ello,evdu,epar,kveclo, + < k1,k2,k3,bkpt,wk,nbands, + < eigg,zz,cp_time) +#endif + call cpu_time(t1) + t_eig = t_eig + t1 - t0 + + allocate ( z_b(nbasfcn,neigd), we_b(neigd) ) + allocate ( z_b2(nbasfcn,neigd), we_b2(neigd) ) + + !!! the cycle by the nearest neighbors (nntot) for each kpoint + + do 15 ikpt_b = 1,nntot + kptibz_b=bpt(ikpt_b,ikpt) + + if(wann%l_bzsym) oper_b=mapkoper(kptibz_b) + if (wann%l_bzsym) kptibz_b=irreduc(kptibz_b) + + n_start=1 + n_end=neigd + + eigg = 0. + call cpu_time(t0) +#if(!defined(CPP_HDF) && defined(CPP_MPI)) + call wann_read_eig( + > lmaxd,ntypd,nlod,neigd,nvd,wannierspin, + > irank,isize,kptibz_b,jspin,nbasfcn,nlotot, + > l_ss,l_noco,nrec,irecl, + < nmat_b,nv_b,ello,evdu,epar,kveclo_b, + < k1_b,k2_b,k3_b,bkpt_b,wk_b,nbands_b, + < eigg,zz,cp_time,66,l_gwf,iqpt) +#else + call cdn_read( + > lmaxd,ntypd,nlod,neigd,nvd,jspd,!wannierspin, + > irank,isize,kptibz_b,jspin,nbasfcn,nlotot, + > l_ss,l_noco,nrec,kptibz_b,66, + > neigd,n_start,n_end, + < nmat_b,nv_b,ello,evdu,epar,kveclo_b, + < k1_b,k2_b,k3_b,bkpt_b,wk_b,nbands_b, + < eigg,zz,cp_time) + +#endif + nslibd_b = 0 + +#if ( !defined(CPP_INVERSION) || defined(CPP_SOC) ) + z_b(:,:) = cmplx(0.,0.) +#else + z_b(:,:) = 0. +#endif + eig_b(:) = 0. + + do i = 1,nbands_b + if((eigg(i).ge.e1s.and.nslibd_b.lt.numbands + & .and.wann%l_bynumber) + &.or.(eigg(i).ge.e1s.and.eigg(i).le.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(l_noco)then + funbas = nv_b(1) + nlotot + funbas = funbas+nv_b(2) + nlotot + else + funbas = nv_b(jspin) + nlotot + endif + do j = 1,funbas + z_b(j,nslibd_b) = zz(j,i) + enddo + endif + enddo + +c*********************************************************** +c Rotate the wavefunction of next neighbor. +c*********************************************************** + if (wann%l_bzsym .and. (oper_b.ne.1) ) then + call wann_kptsrotate( + > natd,nlod,llod, + > ntypd,nlo,llo,invsat, + > l_noco,l_soc, + > ntype,neq,nlotot, + > kveclo_b,jspin, + > oper_b,nop,mrot,nvd, + > nv_b, + > shiftkpt(:,bpt(ikpt_b,ikpt)), + > tau, + x bkpt_b,k1_b(:,:), + x k2_b(:,:),k3_b(:,:), + x z_b,nsfactor_b) + else + nsfactor_b=cmplx(1.0,0.0) + endif + noccbd_b = nslibd_b + call cpu_time(t1) + t_eig = t_eig + t1 - t0 + + addnoco = 0 + if(l_noco.and.jspin.eq.2) addnoco=nv_b(1)+nlotot + + ! set up a(k+b1),b(k+b1),c(k+b1) + allocate( acof_b(noccbd_b,0:lmd,natd), + > bcof_b(noccbd_b,0:lmd,natd), + > ccof_b(-llod:llod,noccbd_b,nlod,natd) ) + + call cpu_time(t0) + call abcof( + > lmaxd,ntypd,neigd,noccbd_b,natd,nop,nvd,wannierspin, + > lmd,nbasfcn,llod,nlod,nlotot,invtab, + > ntype,mrot,ngopr1,taual,neq,lmax,rmt,omtil, + > bmat,bbmat,bkpt_b, + > k1_b,k2_b,k3_b,nv_b,nmat_b,noccbd_b,z_b, + > us(0,1,jspin),dus(0,1,jspin),uds(0,1,jspin), + > duds(0,1,jspin),ddn(0,1,jspin),invsat,invsatnr, + > ulos(1,1,jspin),uulon(1,1,jspin),dulon(1,1,jspin), + > dulos(1,1,jspin),llo,nlo,l_dulo,lapw_l, + > l_noco,l_ss,jspin,alph_i,beta_i,qpt_i, + > kveclo_b,odi,ods, + < acof_b(1,0,1),bcof_b(1,0,1), + < ccof_b(-llod,1,1,1)) + + call wann_abinv( + > ntypd,natd,noccbd_b,lmaxd,lmd,llod,nlod,ntype,neq, + > noccbd_b,lmax,nlo,llo,invsat,invsatnr,bkpt_b,taual, + X acof_b,bcof_b,ccof_b) + call cpu_time(t1) + t_abcof = t_abcof + t1 - t0 + + do 25 iqpt_b = 1,nntot_q + + 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 = qss + alphb_i = alph + betab_i = beta + thetab_i = theta + phib_i = phi + if(l_dim(2)) phib_i = tpi*param_vec(2,qptibz_b) + if(l_dim(3)) thetab_i = tpi*param_vec(3,qptibz_b) + + n_start=1 + n_end=neigd + + eigg = 0. + call cpu_time(t0) +#if(!defined(CPP_HDF) && defined(CPP_MPI)) + !if(l_p0) write(*,*)'wann_read_eig for qptibz_b=',qptibz_b + call wann_read_eig( + > lmaxd,ntypd,nlod,neigd,nvd,wannierspin, + > irank,isize,kptibz,jspin_b,nbasfcn,nlotot, + > l_ss,l_noco,nrec_b,irecl, + < nmat_b2,nv_b2,ello,evdu,epar,kveclo_b2, + < k1_b2,k2_b2,k3_b2,bkpt_b2,wk_b2,nbands_b2, + < eigg,zz,cp_time,funit_start+iqpt_b,l_gwf,qptibz_b) +#else + call cdn_read( + > lmaxd,ntypd,nlod,neigd,nvd,jspd,!wannierspin, + > irank,isize,kptibz,jspin_b,nbasfcn,nlotot, + > l_ss,l_noco,nrec_b,kptibz,funit_start+iqpt_b, + > neigd,n_start,n_end, + < nmat_b2,nv_b2,ello,evdu,epar,kveclo_b2, + < k1_b2,k2_b2,k3_b2,bkpt_b2,wk_b2,nbands_b2, + < eigg,zz,cp_time) + +#endif + nslibd_b2 = 0 + + IF(ANY(bkpt_b2.ne.bkpt)) stop 'bkpt_b2.ne.bkpt' + +#if ( !defined(CPP_INVERSION) || defined(CPP_SOC) ) + z_b2(:,:) = cmplx(0.,0.) +#else + z_b2(:,:) = 0. +#endif + eig_b2(:) = 0. + + do i = 1,nbands_b2 + if((eigg(i).ge.e1s.and.nslibd_b2.lt.numbands + & .and.wann%l_bynumber) + &.or.(eigg(i).ge.e1s.and.eigg(i).le.e2s.and.wann%l_byenergy) + &.or.(i.ge.wann%band_min(jspin_b) + & .and. + & (i.le.wann%band_max(jspin_b)) + & .and. + & wann%l_byindex))then + nslibd_b2 = nslibd_b2 + 1 + eig_b2(nslibd_b2) = eigg(i) + we_b2(nslibd_b2) = we_b2(i) + if(l_noco)then + funbas = nv_b2(1) + nlotot + funbas = funbas+nv_b2(2) + nlotot + else + funbas = nv_b2(jspin_b) + nlotot + endif + do j = 1,funbas + z_b2(j,nslibd_b2) = zz(j,i) + enddo + endif + enddo + +c*********************************************************** +c Rotate the wavefunction of next neighbor. +c*********************************************************** + nsfactor_b2=cmplx(1.0,0.0) + noccbd_b2 = nslibd_b2 + + call cpu_time(t1) + t_eig = t_eig + t1 - t0 + + addnoco2 = 0 + if(l_noco.and.jspin_b.eq.2) addnoco2=nv_b2(1)+nlotot + + ! set up a(k+b2),b(k+b2),c(k+b2) + allocate( acof_b2(noccbd_b2,0:lmd,natd), + > bcof_b2(noccbd_b2,0:lmd,natd), + > ccof_b2(-llod:llod,noccbd_b2,nlod,natd) ) + + call cpu_time(t0) + call abcof( + > lmaxd,ntypd,neigd,noccbd_b2,natd,nop,nvd,wannierspin, + > lmd,nbasfcn,llod,nlod,nlotot,invtab, + > ntype,mrot,ngopr1,taual,neq,lmax,rmt,omtil, + > bmat,bbmat,bkpt_b2, + > k1_b2,k2_b2,k3_b2,nv_b2,nmat_b2,noccbd_b2,z_b2, + > us(0,1,jspin_b),dus(0,1,jspin_b),uds(0,1,jspin_b), + > duds(0,1,jspin_b),ddn(0,1,jspin_b),invsat,invsatnr, + > ulos(1,1,jspin_b),uulon(1,1,jspin_b),dulon(1,1,jspin_b), + > dulos(1,1,jspin_b),llo,nlo,l_dulo,lapw_l, + > l_noco,l_ss,jspin_b,alphb_i,betab_i,qptb_i, + > kveclo_b2,odi,ods, + < acof_b2(1,0,1),bcof_b2(1,0,1), + < ccof_b2(-llod,1,1,1)) + + call wann_abinv( + > ntypd,natd,noccbd_b2,lmaxd,lmd,llod,nlod,ntype,neq, + > noccbd_b2,lmax,nlo,llo,invsat,invsatnr,bkpt_b2,taual, + X acof_b2,bcof_b2,ccof_b2) + call cpu_time(t1) + t_abcof = t_abcof + t1 - t0 + + +c**************************************c +c calculate uHu matrix due to: c +c (i) interstitial c +c (ii) muffin tins c +c (iii) vacuum c +c**************************************c + + ! transformation from (thetab_i,phib_i)-frame + ! to global frame to (theta_i,phi_i)-frame + dth = (thetab_i - theta_i)/2.0 + dph = (phib_i - phi_i)/2.0 + if(l_nochi) then + dth = 0.0 + dph = 0.0 + endif + + if(l_p0 .and. dph.ne.0.0) then + write(*,*)'WARNING: include dph in chi trafo!' + endif + + if( (jspin.eq.1) .and. (jspin_b.eq.1) ) then ! (S,S') = uu + chi = cos(dth) !* cmplx(cos(dph),-sin(dph)) + chi2= sin(dth) !* cmplx(cos(dph), sin(dph)) + elseif( (jspin.eq.2) .and. (jspin_b.eq.2) ) then ! (S,S') = dd + chi = cos(dth) !* cmplx(cos(dph), sin(dph)) + chi2= -sin(dth) !* cmplx(cos(dph),-sin(dph)) + elseif( (jspin.eq.2) .and. (jspin_b.eq.1) ) then ! (S,S') = du + chi = sin(dth) !* cmplx(cos(dph), sin(dph)) + chi2= cos(dth) !* cmplx(cos(dph),-sin(dph)) + elseif( (jspin.eq.1) .and. (jspin_b.eq.2) ) then ! (S,S') = ud + chi = -sin(dth) !* cmplx(cos(dph),-sin(dph)) + chi2= cos(dth) !* cmplx(cos(dph), sin(dph)) + else + stop 'problem setting up chi: jspin,jspin_b' + endif + chi = conjg(chi) + chi2= conjg(chi2) + + !if(irank.eq.0) write(*,*)theta_i,thetab_i,chi,chi2 + + ! MT (SPH, NON) + if(.not.(l_skip_sph.and.l_skip_non)) then + ! matrix elements < S | H_{SS} | S' > x chi + call cpu_time(t0) + call wann_uHu_sph( + > chi,nbnd,llod,nslibd_b,nslibd_b2,nlod,natd,ntypd, + > lmd,jmtd,taual,nop,lmax,ntype,neq,nlo,llo, + > acof_b,bcof_b,ccof_b,bkpt_b2, + > acof_b2,bcof_b2,ccof_b2,bkpt_b,bkpt, + > gb(:,ikpt_b,ikpt),(/0,0,0/), + < tuu(:,:,:,:,doublespin), + > tud(:,:,:,:,doublespin), + > tdu(:,:,:,:,doublespin), + > tdd(:,:,:,:,doublespin), + > tuulo(:,:,:,:,:,doublespin),tulou(:,:,:,:,:,doublespin), + > tdulo(:,:,:,:,:,doublespin),tulod(:,:,:,:,:,doublespin), + > tuloulo(:,:,:,:,:,:,doublespin), + > kdiff,kdiff2,nntot,nntot2, + > uHu(:,:,iqpt_b,ikpt_b,i_rec)) + call cpu_time(t1) + t_sph = t_sph + t1 - t0 + endif + + ! MT (SOC) + if(.not.l_skip_soc) then + ! matrix elements < S | H_{SS} | S' > x chi + call cpu_time(t0) + call wann_uHu_sph( + > chi,nbnd,llod,nslibd_b,nslibd_b2,nlod,natd,ntypd, + > lmd,jmtd,taual,nop,lmax,ntype,neq,nlo,llo, + > acof_b,bcof_b,ccof_b,bkpt_b2, + > acof_b2,bcof_b2,ccof_b2,bkpt_b,bkpt, + > gb(:,ikpt_b,ikpt),(/0,0,0/), + < tuu_soc(:,:,:,:,1), + > tud_soc(:,:,:,:,1), + > tdu_soc(:,:,:,:,1), + > tdd_soc(:,:,:,:,1), + > tuulo_soc(:,:,:,:,:,1),tulou_soc(:,:,:,:,:,1), + > tdulo_soc(:,:,:,:,:,1),tulod_soc(:,:,:,:,:,1), + > tuloulo_soc(:,:,:,:,:,:,1), + > kdiff,kdiff2,nntot,nntot2, + > uHu(:,:,iqpt_b,ikpt_b,i_rec)) + call cpu_time(t1) + t_sph = t_sph + t1 - t0 + + ! matrix elements < S | H_{SS''} | S' > x chi2 , S''=/=S + call cpu_time(t0) + call wann_uHu_sph( + > chi2,nbnd,llod,nslibd_b,nslibd_b2,nlod,natd,ntypd, + > lmd,jmtd,taual,nop,lmax,ntype,neq,nlo,llo, + > acof_b,bcof_b,ccof_b,bkpt_b2, + > acof_b2,bcof_b2,ccof_b2,bkpt_b,bkpt, + > gb(:,ikpt_b,ikpt),(/0,0,0/), + < tuu_soc(:,:,:,:,2), + > tud_soc(:,:,:,:,2), + > tdu_soc(:,:,:,:,2), + > tdd_soc(:,:,:,:,2), + > tuulo_soc(:,:,:,:,:,2),tulou_soc(:,:,:,:,:,2), + > tdulo_soc(:,:,:,:,:,2),tulod_soc(:,:,:,:,:,2), + > tuloulo_soc(:,:,:,:,:,:,2), + > kdiff,kdiff2,nntot,nntot2, + > uHu(:,:,iqpt_b,ikpt_b,i_rec)) + call cpu_time(t1) + t_sph = t_sph + t1 - t0 + endif + + + jspin3 = jspin !doublespin + if(jspins.eq.1) jspin3=1 + + sign2 = 1 + + ! INT + if(.not.l_skip_int) then + ! matrix elements < S | H_{SS} | S' > x chi + call cpu_time(t0) + call wann_uHu_int(chi,nvd,k1d,k2d,k3d,n3d, + > nv_b(jspin),nv_b2(jspin_b),nbnd,neigd, + > nslibd_b,nslibd_b2,nbasfcn,addnoco,addnoco2, + > k1_b(:,jspin), k2_b(:,jspin), k3_b(:,jspin), + > gb(:,ikpt_b,ikpt), + > k1_b2(:,jspin_b),k2_b2(:,jspin_b),k3_b2(:,jspin_b), + > (/0,0,0/),bkpt,bbmat, + > vpw(:,jspin3),z_b,z_b2,rgphs, + > ustep,ig,.true.,sign2, + > uHu(:,:,iqpt_b,ikpt_b,i_rec)) + call cpu_time(t1) + t_int = t_int + t1 - t0 + endif + + ! VAC + if ((.not.l_skip_vac) .and. film .and. (.not.odi%d1)) then + ! matrix elements < S | H_{SS} | S' > x chi + call cpu_time(t0) + call wann_uHu_vac( + > chi,l_noco,l_soc,zrfs,jspins,nlotot,qpt_i,nbnd,z1, + > nmzxyd,nmzd,n2d,nv2d,k1d,k2d,k3d,n3d,nvac,ig, + > rgphs,nmzxy,nmz,delz,ig2,nq2,kv2,area,bmat,bbmat, + > evac(:,jspin),evac(:,jspin_b),bkpt_b,bkpt_b2, + > vzxy(:,:,:,jspin3),vz,nslibd_b,nslibd_b2, + > jspin,jspin_b,jspin,k1_b,k2_b,k3_b, + > k1_b2,k2_b2,k3_b2,wannierspin,nvd,nbasfcn,neigd, + > z_b,z_b2,nv_b,nv_b2,omtil,gb(:,ikpt_b,ikpt), + > (/0,0,0/),sign2, + > uHu(:,:,iqpt_b,ikpt_b,i_rec)) + call cpu_time(t1) + t_vac = t_vac + t1 - t0 + + elseif ((.not.l_skip_vac) .and. odi%d1) then + + call cpu_time(t0) + call wann_uHu_od_vac( + > chi,l_noco,l_soc,jspins,nlotot,nbnd,z1,nmzxyd,nmzd, + > nv2d,k1d,k2d,k3d,n2d,n3d,ig,nmzxy,nmz,delz,ig2, + > bbmat,evac(1,jspin),evac(1,jspin_b),bkpt_b,bkpt_b2, + > odi,vzxy(:,:,:,jspin3),vz,nslibd_b,nslibd_b2,jspin, + > jspin_b,jspin,k1_b,k2_b,k3_b,k1_b2,k2_b2,k3_b2, + > wannierspin,nvd,area,nbasfcn,neigd,z_b,z_b2,nv_b, + > nv_b2,sk2,phi2,omtil,gb(:,ikpt_b,ikpt), + > (/0,0,0/),qpt_i,sign2, + > uHu(:,:,iqpt_b,ikpt_b,i_rec)) + call cpu_time(t1) + t_vac = t_vac + t1 - t0 + + endif + + deallocate (acof_b2,bcof_b2,ccof_b2) +25 continue ! end of loop by the nearest k-neighbors + + deallocate (acof_b,bcof_b,ccof_b) +15 continue ! end of loop by the nearest k-neighbors + deallocate ( z_b,we_b ) + deallocate ( z_b2,we_b2 ) + deallocate ( zz,eigg ) + + endif ! loop by processors + +10 continue ! end of cycle by the k-points + +#ifdef CPP_MPI + call MPI_BARRIER(MPI_COMM_WORLD,ierr) +#endif + 5 continue + + if(.not.l_noco)nrec=nrec+nkpts + +110 continue ! end of cycle by spins + +#ifdef CPP_MPI + call MPI_BARRIER(MPI_COMM_WORLD,ierr) +#endif + + ! close eig files + IF (l_gwf) THEN + CLOSE(66) + DO iqpt_b=1,nntot_q + CLOSE(funit_start+iqpt_b) + ENDDO + ENDIF + + if(l_p0) write(*,*)'write uHu file' + uHu = htr2ev * uHu + call wann_write_uHu(1,l_p0,fullnkpts,nntot,nntot_q,wann, + > nbnd,bpt,gb,isize,irank,fending,'_kq',uHu, + > counts(irank),counts,displs,isize, + > wann%l_unformatted,.false.,.false.) + if(allocated(uHu)) deallocate(uHu) + +314 continue ! iqpt, q-points +c************************************************c +c END Q LOOP c +c************************************************c + + + deallocate ( kveclo,nv,k1,k2,k3 ) + deallocate ( ff,gg,us,dus,duds,uds,ddn) + deallocate ( flo ) + deallocate ( ulos,dulos,uulon,dulon,uloulopn ) + if (allocated(nv_b))deallocate(kveclo_b,nv_b,k1_b,k2_b,k3_b) + if (allocated(nv_b2))deallocate(kveclo_b2,nv_b2,k1_b2,k2_b2,k3_b2) + if (wann%l_bzsym)deallocate(irreduc,mapkoper,shiftkpt) + if (wann%l_bzsym.AND.l_gwf)deallocate(irreduc_q,mapqoper,shiftqpt) + if (allocated(pair_to_do)) deallocate(pair_to_do,maptopair) + if (allocated(pair_to_do_q)) deallocate(pair_to_do_q,maptopair_q) + if (allocated(kdiff)) deallocate ( kdiff ) + if (allocated(kdiff2)) deallocate ( kdiff2 ) + if (allocated(qdiff)) deallocate(qdiff,zero_qdiff) + if(allocated(vpw)) deallocate(vpw) + if(allocated(vzxy)) deallocate(vzxy) + if(allocated(vz)) deallocate(vz) + deallocate(vrf,vr) + deallocate(tdd,tdu,tud,tuu) + deallocate(tdd_soc,tdu_soc,tud_soc,tuu_soc) + deallocate(tdulo,tuulo) + deallocate(tulou,tulod) + deallocate(tuloulo) + deallocate(tdulo_soc,tuulo_soc) + deallocate(tulou_soc,tulod_soc) + deallocate(tuloulo_soc) + deallocate(counts,displs) + +9110 continue + + if(l_sgwf .or. l_socgwf) gb_q = gb_q/2 + + if(l_p0.and.l_gwf) then + call wann_uHu_commat( + > fullnkpts,nntot,bpt,fullnqpts,nntot_q,bpt_q, + > gb,gb_q,aux_latt_const,wann%l_unformatted,l_dim, + > nparampts,param_vec/2.0) + endif + + if(allocated(gb)) deallocate(gb,bpt) + if(allocated(gb_q)) deallocate(gb_q,bpt_q) + +#ifdef CPP_MPI + call MPI_BARRIER(MPI_COMM_WORLD,ierr) +#endif + call cpu_time(t1) + t_total = t1-t00 + if(l_p0) then + write(*,900)'t_init =',t_init + write(*,900)'t_tlmplm=',t_tlmplm + write(*,900)'t_eig =',t_eig + write(*,900)'t_abcof =',t_abcof + write(*,900)'t_int =',t_int + write(*,900)'t_sph =',t_sph + write(*,900)'t_vac =',t_vac + write(*,900)'t_total =',t_total + endif + +900 FORMAT(a,f14.4) + + END SUBROUTINE wann_uHu_dmi + + + END MODULE m_wann_uHu_dmi + + diff --git a/wannier/uhu/wann_uHu_int.F b/wannier/uhu/wann_uHu_int.F new file mode 100644 index 00000000..b1c1424a --- /dev/null +++ b/wannier/uhu/wann_uHu_int.F @@ -0,0 +1,152 @@ +c*****************************************c +c Interstitial contribution to uHu c +c < u_{k+b1} | H_{k}^{int} | u_{k+b2} > c +c*****************************************c +c k1_b, k2_b, k3_b : G-vectors at k+b1 c +c k1_b2, k2_b2, k3_b2: G-vectors at k+b2 c +c c +c gb : reciprocal latt. vector taking c +c k+b1 back to first Brillouin zone c +c gb2: reciprocal latt. vector taking c +c k+b2 back to first Brillouin zone c +c c +c z_b : eigenvectors at k+b1 c +c z_b2: eigenvectors at k+b2 c +c*****************************************c +c J.-P. Hanke, Dec. 2015 c +c*****************************************c + module m_wann_uHu_int + contains + subroutine wann_uHu_int( + > chi,nvd,k1d,k2d,k3d, + > n3d,nv_b,nv_b2,nbnd,neigd, + > nslibd_b,nslibd_b2,nbasfcn, + > addnoco,addnoco2, + > k1_b ,k2_b ,k3_b, gb, + > k1_b2,k2_b2,k3_b2,gb2, + > bkpt,bbmat,vpw,z_b,z_b2, + > rgphs,ustep,ig,l_kin,sign,uHu) +#include "cpp_double.h" + use m_dotir, ONLY : dotirp + implicit none + +c ..arguments.. + logical, intent(in) :: l_kin + integer, intent(in) :: gb(3),gb2(3) + integer, intent(in) :: k1d,k2d,k3d + integer, intent(in) :: nvd,n3d,nv_b,nv_b2,nbnd,neigd + integer, intent(in) :: nslibd_b,nslibd_b2,nbasfcn + integer, intent(in) :: addnoco,addnoco2,sign + integer, intent(in) :: k1_b(nvd) ,k2_b(nvd) ,k3_b(nvd) + integer, intent(in) :: k1_b2(nvd),k2_b2(nvd),k3_b2(nvd) + integer, intent(in) :: ig(-k1d:k1d,-k2d:k2d,-k3d:k3d) + real, intent(in) :: rgphs(-k1d:k1d,-k2d:k2d,-k3d:k3d) + real, intent(in) :: bkpt(3),bbmat(3,3) + complex, intent(in) :: ustep(n3d),vpw(n3d) + complex, intent(in) :: chi +#if ( !defined(CPP_INVERSION) || defined(CPP_SOC) ) + complex, intent(in) :: z_b(nbasfcn,neigd),z_b2(nbasfcn,neigd) +#else + real, intent(in) :: z_b(nbasfcn,neigd),z_b2(nbasfcn,neigd) +#endif + complex, intent(inout) :: uHu(nbnd,nbnd) + +c ..local variables.. +#if (!defined(CPP_INVERSION)||defined(CPP_SOC)) + complex,allocatable :: vstep(:,:) + complex,allocatable :: mat(:,:) + complex :: th +#else + real,allocatable :: vstep(:,:) + real,allocatable :: mat(:,:) + real,allocatable :: uHu_tmp(:,:) + real :: th +#endif + real,allocatable :: rk_b(:),rk_b2(:) + real :: phase,phase2,ekk,s(3) + integer :: i,j,j1,j2,j3,i1,i2,i3,in,ind + + allocate( vstep(nv_b2,nv_b) ) + allocate( mat(nv_b,nslibd_b2) ) + allocate( rk_b (nv_b) ) + allocate( rk_b2(nv_b2) ) +#if (!defined(CPP_INVERSION)||defined(CPP_SOC)) +#else + allocate( uHu_tmp(nslibd_b,nslibd_b2) ) +#endif + + ! set up |k+G-G(k+b1)|^2 + do i=1,nv_b + s(1) = bkpt(1) + k1_b(i) - gb(1) + s(2) = bkpt(2) + k2_b(i) - gb(2) + s(3) = bkpt(3) + k3_b(i) - gb(3) + rk_b(i) = dotirp(s,s,bbmat) + enddo + + ! set up |k+G'-G(k+b2)|^2 + do i=1,nv_b2 + s(1) = bkpt(1) + k1_b2(i) - gb2(1) + s(2) = bkpt(2) + k2_b2(i) - gb2(2) + s(3) = bkpt(3) + k3_b2(i) - gb2(3) + rk_b2(i) = dotirp(s,s,bbmat) + enddo + + ! construct vstep(g,g') ~ V(g-g') + ! + Theta(g-g')*[rk_b+rk_b2] + vstep(:,:) = 0.0 + do i=1,nv_b + j1 = -k1_b(i) + gb(1) - gb2(1) + j2 = -k2_b(i) + gb(2) - gb2(2) + j3 = -k3_b(i) + gb(3) - gb2(3) + do j=1,nv_b2 + i1 = j1 + k1_b2(j) + i2 = j2 + k2_b2(j) + i3 = j3 + k3_b2(j) + in = ig(sign*i1,sign*i2,sign*i3) + if(in.eq.0) cycle + phase = rgphs(i1,i2,i3) ! TODO: sign also here? + phase2= rgphs(sign*i1,sign*i2,sign*i3) + if(phase.ne.phase2) then + stop 'rgphs in wann_uHu_int' + endif + + ekk = rk_b(i) + rk_b2(j) +#if ( !defined(CPP_INVERSION) || defined(CPP_SOC) ) + th = phase*conjg(vpw(in)) + if(l_kin) th = th + phase*0.25*ekk*conjg(ustep(in)) +#else + th = phase*real(vpw(in)) + if(l_kin) th = th + phase*0.25*ekk*real(ustep(in)) +#endif + vstep(j,i) = th + enddo + enddo + + ! complex conjugate of (z(k+b1,g))^* vstep(g,g') z(k+b2,g') +#if (!defined(CPP_INVERSION) || defined(CPP_SOC)) + call CPP_BLAS_cgemm('T','N',nv_b,nslibd_b2,nv_b2,cmplx(1.0), + > vstep,nv_b2,z_b2(1+addnoco2,1),nbasfcn, + > cmplx(0.0),mat,nv_b) + mat = conjg(mat) + call CPP_BLAS_cgemm('T','N',nslibd_b,nslibd_b2,nv_b, + > chi,z_b(1+addnoco,1),nbasfcn, + > mat,nv_b,cmplx(1.0),uHu,nbnd) +#else + call CPP_BLAS_sgemm('T','N',nv_b,nslibd_b2,nv_b2,real(1.0), + > vstep,nv_b2,z_b2(1+addnoco2,1),nbasfcn, + > real(0.0),mat,nv_b) + call CPP_BLAS_sgemm('T','N',nslibd_b,nslibd_b2,nv_b, + > real(1.0),z_b(1+addnoco,1),nbasfcn, + > mat,nv_b,real(0.0),uHu_tmp,nslibd_b) + uHu(1:nslibd_b,1:nslibd_b2) = uHu(1:nslibd_b,1:nslibd_b2) + > + uHu_tmp(1:nslibd_b,1:nslibd_b2)*chi +#endif + + deallocate( vstep, mat ) + deallocate( rk_b, rk_b2 ) +#if (!defined(CPP_INVERSION) || defined(CPP_SOC)) +#else + deallocate( uHu_tmp ) +#endif + end subroutine + end module m_wann_uHu_int diff --git a/wannier/uhu/wann_uHu_int2.F b/wannier/uhu/wann_uHu_int2.F new file mode 100644 index 00000000..e0ca6d9d --- /dev/null +++ b/wannier/uhu/wann_uHu_int2.F @@ -0,0 +1,53 @@ + module m_wann_uHu_int2 + contains + subroutine wann_uHu_int2( + > nvd,k1d,k2d,k3d, + > n3d,k1,k2,k3, + > nv, + > k1_b,k2_b,k3_b, + > nv_b, + > rgphs,ustep,ig,gb,uHu) +#include "cpp_double.h" + implicit none + integer, intent(in) :: nvd,n3d,k1(nvd),k2(nvd),k3(nvd) + integer, intent(in) :: nv + integer, intent(in) :: nv_b,k1_b(nvd),k2_b(nvd),k3_b(nvd) + integer, intent(in) :: k1d,k2d,k3d + real, intent(in) :: rgphs(-k1d:k1d,-k2d:k2d,-k3d:k3d) + complex, intent(in) :: ustep(n3d) + integer, intent(in) :: ig(-k1d:k1d,-k2d:k2d,-k3d:k3d) + integer, intent(in) :: gb(3) + complex, intent(inout) :: uHu(nvd,nvd)!(nv,nv_b) + +#if (!defined(CPP_INVERSION)||defined(CPP_SOC)) + complex :: stepf(nv_b,nv) + complex phasust +#else + real :: stepf(nv_b,nv) + real phasust +#endif + integer i,j1,j2,j3,i1,i2,i3,j,in,m,n + real phase + + stepf(:,:)=0.0 + do i =1,nv + do j = 1,nv_b +c--> determine index and phase factor + i1 = k1_b(j) - k1(i) - gb(1) + i2 = k2_b(j) - k2(i) - gb(2) + i3 = k3_b(j) - k3(i) - gb(3) + in = ig(i1,i2,i3) + if (in.eq.0) cycle + phase = rgphs(i1,i2,i3) +#if ( !defined(CPP_INVERSION) || defined(CPP_SOC) ) + phasust=conjg(phase*ustep(in)) +#else + phasust=phase*real(ustep(in)) +#endif + stepf(j,i)=phasust + enddo + enddo + uHu(1:nv,1:nv_b) = uHu(1:nv,1:nv_b) + conjg(transpose(stepf)) + + end subroutine + end module m_wann_uHu_int2 diff --git a/wannier/uhu/wann_uHu_od_vac.F b/wannier/uhu/wann_uHu_od_vac.F new file mode 100644 index 00000000..33df8479 --- /dev/null +++ b/wannier/uhu/wann_uHu_od_vac.F @@ -0,0 +1,561 @@ +c***************************************c +c Vacuum contribution to uHu matrix c +c in one-dimensional FLAPW mode c +c***************************************c +c < u_{k+b1} | H_{k} | u_{k+b2} > c +c***************************************c +c J.-P. Hanke, Dec. 2015 c +c***************************************c + MODULE m_wann_uHu_od_vac + CONTAINS + SUBROUTINE wann_uHu_od_vac( + > chi,l_noco,l_soc,jspins,nlotot, + > nbnd,z1,nmzxyd,nmzd,nv2d,k1d,k2d,k3d,n2d,n3d, + > ig,nmzxy,nmz,delz,ig2, + > bbmat,evac,evac_b,bkpt,bkpt_b,odi,vxy,vz, + > nslibd,nslibd_b,jspin,jspin_b,ico, + > k1,k2,k3,k1_b,k2_b,k3_b, + > jspd,nvd,area,nbasfcn,neigd, + > z,z_b,nv,nv_b,sk2,phi2,omtil,gb,gb2,qss,sign2, + < uHu) + use m_constants, only : pimach + use m_od_types, only : od_inp + use m_od_abvac + use m_cylbes + use m_dcylbs + use m_intgr, only : intgz0 + use m_d2fdz2 + use m_dotir + + implicit none +c .. scalar Arguments.. + logical, intent (in) :: l_noco,l_soc + integer, intent (in) :: jspins,nlotot,ico + integer, intent (in) :: nmzxyd,nmzd,nv2d,k1d,k2d,k3d,n3d + integer, intent (in) :: nmzxy,nmz,n2d,nbnd + integer, intent (in) :: nslibd,nslibd_b + integer, intent (in) :: jspin,jspin_b,jspd,nvd + integer, intent (in) :: nbasfcn,neigd + real, intent (in) :: delz,z1,evac,area,omtil,evac_b + complex, intent (in) :: chi + type (od_inp), intent (in) :: odi + + +c ..array arguments.. + real, intent (in) :: bkpt(:),bkpt_b(:),qss(:) !bkpt(3),bkpt_b(3),qss(3) + real, intent (in) :: sk2(:),phi2(:) !sk2(n2d),phi2(n2d) + integer, intent (in) :: ig(-k1d:,-k2d:,-k3d:) !ig(-k1d:k1d,-k2d:k2d,-k3d:k3d) + integer, intent (in) :: ig2(:),nv(:),nv_b(:) !ig2(n3d),nv(jspd),nv_b(jspd) + integer, intent (in) :: gb(3),gb2(3) + real, intent (in) :: vz(nmzd,2,4),bbmat(3,3) + integer, intent (in) :: k1(:,:),k2(:,:),k3(:,:) !k1(nvd,jspd),k2(nvd,jspd),k3(nvd,jspd) + integer, intent (in) :: k1_b(:,:),k2_b(:,:),k3_b(:,:) !k1_b(nvd,jspd),k2_b(nvd,jspd),k3_b(nvd,jspd) + complex, intent (inout) :: uHu(:,:) !uHu(nbnd,nbnd) + +#if ( !defined(CPP_INVERSION) || defined(CPP_SOC) ) + complex, intent (in):: z(:,:),z_b(:,:) !z(nbasfcn,neigd),z_b(nbasfcn,neigd) +#else + real, intent (in):: z(:,:),z_b(:,:) !z(nbasfcn,neigd),z_b(nbasfcn,neigd) +#endif + complex, intent (in):: vxy(nmzxyd,odi%n2d-1,2) + + +c ..basis wavefunctions in the vacuum + real, allocatable :: udz(:,:) + real, allocatable :: uz(:,:) + real, allocatable :: dudz(:,:) + real, allocatable :: duz(:,:) + real, allocatable :: u(:,:,:) + real, allocatable :: ud(:,:,:) + real, allocatable :: ddnv(:,:) + + real, allocatable :: udz_b(:,:) + real, allocatable :: uz_b(:,:) + real, allocatable :: dudz_b(:,:) + real, allocatable :: duz_b(:,:) + real, allocatable :: u_b(:,:,:) + real, allocatable :: ud_b(:,:,:) + real, allocatable :: ddnv_b(:,:) + +c ..local scalars.. + logical tail + real wronk,wronk1,arg,zks,tpi,zz,rk,rk_b + real zks0,zks0_b,arg_b,fac1,xv,yv,s(3) + integer i,m,l,j,k,irec3,irec2,n,nv2,mp,ispin,np0,ind1,ind3 + integer nv2_b,np1,lp,addnoco,addnoco2,i3,j3 + integer sign,ivac,m1,m2,jspin2,jspin2_b,jspin2H,sign2 + complex tuu,tud,tdu,tdd + complex avac,bvac,ic,phasfc + complex, allocatable :: acof(:,:,:),bcof(:,:,:) + integer, allocatable :: kvac3(:),map1(:) + complex, allocatable :: acof_b(:,:,:),bcof_b(:,:,:) + integer, allocatable :: kvac3_b(:),map1_b(:) + real, allocatable :: bess(:),dbss(:) + real, allocatable :: gbess(:,:),gbess_b(:,:),besss(:) + real, allocatable :: zmsh(:),xx(:),xximag(:),v1(:) + real, allocatable :: gdu(:),gdud(:),gdu_b(:),gdud_b(:) + REAL qssbti(3,2) + +c ..intrinsic functions.. + intrinsic aimag,cmplx,conjg,real,sqrt + + addnoco=0 + addnoco2=0 + if(l_noco.and.(jspin.eq.2))then + addnoco = nv(1) + nlotot + endif + if(l_noco.and.(jspin_b.eq.2))then + addnoco2 = nv_b(1) + nlotot + endif + + allocate ( udz(nv2d,-odi%mb:odi%mb),uz(nv2d,-odi%mb:odi%mb), + + dudz(nv2d,-odi%mb:odi%mb), + + duz(nv2d,-odi%mb:odi%mb),u(nmzd,nv2d,-odi%mb:odi%mb), + + ud(nmzd,nv2d,-odi%mb:odi%mb),ddnv(nv2d,-odi%mb:odi%mb), + + udz_b(nv2d,-odi%mb:odi%mb),uz_b(nv2d,-odi%mb:odi%mb), + + dudz_b(nv2d,-odi%mb:odi%mb), + + duz_b(nv2d,-odi%mb:odi%mb), + + u_b(nmzd,nv2d,-odi%mb:odi%mb), + + ud_b(nmzd,nv2d,-odi%mb:odi%mb), + + ddnv_b(nv2d,-odi%mb:odi%mb), + + bess(-odi%mb:odi%mb),dbss(-odi%mb:odi%mb), + + besss(-odi%M:odi%M),gbess(-odi%M:odi%M,nmzd), + + gbess_b(-odi%M:odi%M,nmzd), + + acof(nv2d,-odi%mb:odi%mb,nslibd), + + bcof(nv2d,-odi%mb:odi%mb,nslibd), + + acof_b(nv2d,-odi%mb:odi%mb,nslibd_b), + + bcof_b(nv2d,-odi%mb:odi%mb,nslibd_b), + + kvac3(nv2d),map1(nvd), + + kvac3_b(nv2d),map1_b(nvd), + + zmsh(nmz),xx(nmz),xximag(nmz),v1(nmzd), + + gdu(nmzd),gdud(nmzd),gdu_b(nmzd),gdud_b(nmzd) ) + + tpi = 2 * pimach() ; ic = cmplx(0.,1.) + + tail = .true. + np0 = nmzxy + 1 + np1 = nmz + 1 + ivac = 1 + + jspin2 = jspin + jspin2_b = jspin_b + jspin2H = ico + if(l_soc.and.jspins.eq.1) then + jspin2 = 1 + jspin2_b = 1 + jspin2H = 1 + endif + + sign = 1.0 + IF (ico.EQ.4) sign=-1.0 ! for c.c. of vz + + + acof(:,:,:) = cmplx(0.,0.) ; bcof(:,:,:) = cmplx(0.,0.) + acof_b(:,:,:) = cmplx(0.,0.) ; bcof_b(:,:,:) = cmplx(0.,0.) + + nv2 = 0 ; nv2_b = 0 + + do 20 k = 1,nv(jspin) + do 10 j = 1,nv2 + if (k3(k,jspin).eq.kvac3(j)) then + map1(k) = j + goto 20 + endif + 10 continue + nv2 = nv2 + 1 + if (nv2.gt.nv2d) stop 'nv2d' + kvac3(nv2) = k3(k,jspin) + map1(k) = nv2 + 20 continue + + do 21 k = 1,nv_b(jspin_b) + do 11 j = 1,nv2_b + if (k3_b(k,jspin_b).eq.kvac3_b(j)) then + map1_b(k) = j + goto 21 + endif + 11 continue + nv2_b = nv2_b + 1 + if (nv2_b.gt.nv2d) stop 'nv2d' + kvac3_b(nv2_b) = k3_b(k,jspin_b) + map1_b(k) = nv2_b + 21 continue + + wronk = 2.0 + +c...for the k-point + + qssbti(1,1) = - qss(1)/2. + qssbti(2,1) = - qss(2)/2. + qssbti(1,2) = + qss(1)/2. + qssbti(2,2) = + qss(2)/2. + qssbti(3,1) = - qss(3)/2. + qssbti(3,2) = + qss(3)/2. + DO ispin = 1,1 ! jspins + CALL od_abvac( + > z1,nmzxyd,nmzd,nv2d,k1d,k2d,k3d,n2d,n3d, + > ig,odi%ig,tpi,qssbti(3,jspin), + > nmzxy,nmz,delz,ig2,odi%n2d, + > bbmat,wronk,evac,bkpt,odi%M,odi%mb, + > vz(1,ivac,jspin2),kvac3,nv2, + < uz(1,-odi%mb),duz(1,-odi%mb),u(1,1,-odi%mb),udz(1,-odi%mb), + < dudz(1,-odi%mb),ddnv(1,-odi%mb),ud(1,1,-odi%mb)) + ENDDO + + do k = 1,nv(jspin) + l = map1(k) + irec3 = ig(k1(k,jspin),k2(k,jspin),k3(k,jspin)) + if (irec3.ne.0) then + irec2 = ig2(irec3) + zks = sk2(irec2)*z1 + arg = phi2(irec2) + call cylbes(odi%mb,zks,bess) + call dcylbs(odi%mb,zks,bess,dbss) + do m = -odi%mb,odi%mb + wronk1 = uz(l,m)*dudz(l,m) - + - udz(l,m)*duz(l,m) + avac = exp(-cmplx(0.0,m*arg))*(ic**m)* + * cmplx(dudz(l,m)*bess(m) - + + udz(l,m)*sk2(irec2)*dbss(m),0.0)/ + / ((wronk1)*sqrt(omtil)) + bvac = exp(-cmplx(0.0,m*arg))*(ic**m)* + * cmplx(-duz(l,m)*bess(m) + + - uz(l,m)*sk2(irec2)*dbss(m),0.0)/ + / ((wronk1)*sqrt(omtil)) + do n = 1,nslibd + acof(l,m,n) = acof(l,m,n) + + + z(k+addnoco,n)*avac +c + conjg(z(k,n))*avac + bcof(l,m,n) = bcof(l,m,n) + + + z(k+addnoco,n)*bvac +c + conjg(z(k,n))*bvac + enddo + enddo ! -mb:mb + endif + enddo + +c...for the b-point + + DO ispin = 1,1 ! jspins + call od_abvac( + > z1,nmzxyd,nmzd,nv2d,k1d,k2d,k3d,n2d,n3d, + > ig,odi%ig,tpi,qssbti(3,jspin_b), + > nmzxy,nmz,delz,ig2,odi%n2d, + > bbmat,wronk,evac_b,bkpt_b,odi%M,odi%mb, + > vz(1,ivac,jspin2_b),kvac3_b,nv2_b, + < uz_b(1,-odi%mb),duz_b(1,-odi%mb),u_b(1,1,-odi%mb), + < udz_b(1,-odi%mb), + < dudz_b(1,-odi%mb),ddnv_b(1,-odi%mb),ud_b(1,1,-odi%mb)) + ENDDO + + do k = 1,nv_b(jspin_b) + l = map1_b(k) + irec3 = ig(k1_b(k,jspin_b),k2_b(k,jspin_b),k3_b(k,jspin_b)) + if (irec3.ne.0) then + irec2 = ig2(irec3) + zks = sk2(irec2)*z1 + arg = phi2(irec2) + call cylbes(odi%mb,zks,bess) + call dcylbs(odi%mb,zks,bess,dbss) + do m = -odi%mb,odi%mb + wronk1 = uz_b(l,m)*dudz_b(l,m) - + - udz_b(l,m)*duz_b(l,m) + avac = exp(-cmplx(0.0,m*arg))*(ic**m)* + * cmplx(dudz_b(l,m)*bess(m) - + + udz_b(l,m)*sk2(irec2)*dbss(m),0.0)/ + / ((wronk1)*sqrt(omtil)) + bvac = exp(-cmplx(0.0,m*arg))*(ic**m)* + & cmplx(-duz_b(l,m)*bess(m) + + - uz_b(l,m)*sk2(irec2)*dbss(m),0.0)/ + / ((wronk1)*sqrt(omtil)) + do n = 1,nslibd_b + acof_b(l,m,n) = acof_b(l,m,n) + + + z_b(k+addnoco2,n)*avac +c + conjg(z(k,n))*avac + bcof_b(l,m,n) = bcof_b(l,m,n) + + + z_b(k+addnoco2,n)*bvac +c + conjg(z(k,n))*bvac + enddo + enddo ! -mb:mb + endif + enddo ! k = 1,nv + +c now actually computing the uHu matrix + + irec3 = ig(gb(1),gb(2),gb(3)) + if (irec3.eq.0) stop 'Gb is not in the list of Gs' + irec2 = ig2(irec3) + zks0 = sk2(irec2) + arg = phi2(irec2) + + irec3 = ig(gb2(1),gb2(2),gb2(3)) + if (irec3.eq.0) stop 'Gb2 is not in the list of Gs' + irec2 = ig2(irec3) + zks0_b = sk2(irec2) + arg_b = phi2(irec2) + + gbess(:,:) = 0. + gbess_b(:,:) = 0. + do i = 1,nmz + ! set up mesh + zmsh(i) = z1 + (i-1)*delz + zz = sqrt(zmsh(i)) + + ! transformation u --> v = sqrt(z)*u + ! thus we can use simplified 'pseudopotential' + ! and skip r in integration dx dy = r dr dphi + u(i,:,:) = zz*u(i,:,:) + ud(i,:,:) = zz*ud(i,:,:) + u_b(i,:,:) = zz*u_b(i,:,:) + ud_b(i,:,:) = zz*ud_b(i,:,:) + + ! cyl. Bessel at G(k+b1) + zks = zks0*zmsh(i) + besss(:) = 0. + call cylbes(odi%M,zks,besss) + do m = -odi%M,odi%M + gbess(m,i) = besss(m) + enddo + + ! cyl. Bessel at G(k+b2) + zks = zks0_b*zmsh(i) + besss(:) = 0. + call cylbes(odi%M,zks,besss) + do m = -odi%M,odi%M + gbess_b(m,i) = besss(m) + enddo + enddo + + + ! calculate uHu matrix elements + do l = 1,nv2 + + j3 = kvac3(l) - gb(3) + + do lp = 1,nv2_b + + i3 = j3 - kvac3_b(lp) + gb2(3) + + ind3 = ig(0,0,sign2*i3) + IF (ind3.EQ.0) CYCLE + + DO m = -odi%mb, odi%mb + DO mp = -odi%mb, odi%mb + IF ((mp.EQ.m) .OR. ((iabs(m ).LE.odi%m_cyl) .AND. + > (iabs(mp).LE.odi%m_cyl))) THEN + + DO m1 = -odi%mb, odi%mb + DO m2 = -odi%mb, odi%mb + + ind1 = odi%ig(sign2*i3,m-m1-mp+m2) ! TODO: sign also for m-part? + if(sign2.ne.1) stop 'sign2, check m-part, wann_uHu_od_vac' + + IF(ind1.EQ.0) CYCLE + + ind1 = ind1 - 1 + IF(ind1.NE.0) THEN ! warping components Gz=/=0, m=/=0 + ! need integral with vxy and cyl. Bessel + ! tuu + DO i=1,nmzxy + fac1 = u (i,l ,m )*gbess (m1,i) + > *u_b(i,lp,mp)*gbess_b(m2,i) + xx (np0-i) = fac1*real (vxy(i,ind1,ivac)) + xximag(np0-i) = fac1*aimag(vxy(i,ind1,ivac)) + ENDDO + call intgz0(xx,delz,nmzxy,xv,tail) + call intgz0(xximag,delz,nmzxy,yv,tail) + tuu = cmplx(xv,-yv) + + ! tud + DO i=1,nmzxy + fac1 = u (i,l ,m )*gbess (m1,i) + > *ud_b(i,lp,mp)*gbess_b(m2,i) + xx (np0-i) = fac1*real (vxy(i,ind1,ivac)) + xximag(np0-i) = fac1*aimag(vxy(i,ind1,ivac)) + ENDDO + call intgz0(xx,delz,nmzxy,xv,tail) + call intgz0(xximag,delz,nmzxy,yv,tail) + tud = cmplx(xv,-yv) + + ! tdu + DO i=1,nmzxy + fac1 = ud (i,l ,m )*gbess (m1,i) + > *u_b(i,lp,mp)*gbess_b(m2,i) + xx (np0-i) = fac1*real (vxy(i,ind1,ivac)) + xximag(np0-i) = fac1*aimag(vxy(i,ind1,ivac)) + ENDDO + call intgz0(xx,delz,nmzxy,xv,tail) + call intgz0(xximag,delz,nmzxy,yv,tail) + tdu = cmplx(xv,-yv) + + ! tdd + DO i=1,nmzxy + fac1 = ud (i,l ,m )*gbess (m1,i) + > *ud_b(i,lp,mp)*gbess_b(m2,i) + xx (np0-i) = fac1*real (vxy(i,ind1,ivac)) + xximag(np0-i) = fac1*aimag(vxy(i,ind1,ivac)) + ENDDO + call intgz0(xx,delz,nmzxy,xv,tail) + call intgz0(xximag,delz,nmzxy,yv,tail) + tdd = cmplx(xv,-yv) + + ELSE ! non-warping components Gz==0, m==0 + ! need integral with XXXXXX + + IF ((ico.EQ.1) .OR. (ico.EQ.2)) THEN ! spin-diagonal + + ! determine second derivative of (u*gbess) etc. + CALL d2fdz2(nmzd,nmz,zmsh,delz, + > u(:,l,m),gbess(m1,:),gdu) + CALL d2fdz2(nmzd,nmz,zmsh,delz, + > ud(:,l,m),gbess(m1,:),gdud) + CALL d2fdz2(nmzd,nmz,zmsh,delz, + > u_b(:,lp,mp),gbess_b(m2,:),gdu_b) + CALL d2fdz2(nmzd,nmz,zmsh,delz, + > ud_b(:,lp,mp),gbess_b(m2,:),gdud_b) + + ! determine |G+k+b1|^2 and |G'+k+b2|^2 + s(1) = 0.0 + s(2) = 0.0 + s(3) = bkpt(3) + kvac3(l) + qssbti(3,jspin)!-gb(3) + rk = dotirp(s,s,bbmat) + + s(1) = 0.0 + s(2) = 0.0 + s(3) = bkpt_b(3) + kvac3_b(lp) + qssbti(3,jspin_b)!-gb2(3) + rk_b = dotirp(s,s,bbmat) + + ! construct symmetrized 'pseudopotential' + ! TODO: valid to simply symmetrize? + DO i=1,nmzd + v1(i) = vz(i,ivac,jspin2H) + > + (m*m+mp*mp)/(4.*zmsh(i)*zmsh(i)) + > - 1./(8.*zmsh(i)*zmsh(i)) + ENDDO + + ! tuu + DO i=1,nmz + fac1 = u (i,l ,m )*gbess (m1,i) + > *u_b(i,lp,mp)*gbess_b(m2,i) + xx(np1-i) = fac1*( 0.25*(rk+rk_b) + v1(i) ) + > -0.25*( gdu (i)*u_b(i,lp,mp)*gbess_b(m2,i) + > +gdu_b(i)*u (i,l ,m )*gbess (m1,i) ) + ENDDO + call intgz0(xx,delz,nmz,xv,tail) + tuu = cmplx(xv,0.0) + + ! tud + DO i=1,nmz + fac1 = u (i,l ,m )*gbess (m1,i) + > *ud_b(i,lp,mp)*gbess_b(m2,i) + xx(np1-i) = fac1*( 0.25*(rk+rk_b) + v1(i) ) + > -0.25*( gdu (i)*ud_b(i,lp,mp)*gbess_b(m2,i) + > +gdud_b(i)*u (i,l ,m )*gbess (m1,i) ) + ENDDO + call intgz0(xx,delz,nmz,xv,tail) + tud = cmplx(xv,0.0) + + ! tdu + DO i=1,nmz + fac1 = ud (i,l ,m )*gbess (m1,i) + > *u_b(i,lp,mp)*gbess_b(m2,i) + xx(np1-i) = fac1*( 0.25*(rk+rk_b) + v1(i) ) + > -0.25*( gdud (i)*u_b(i,lp,mp)*gbess_b(m2,i) + > +gdu_b(i)*ud (i,l ,m )*gbess (m1,i) ) + ENDDO + call intgz0(xx,delz,nmz,xv,tail) + tdu = cmplx(xv,0.0) + + ! tdd + DO i=1,nmz + fac1 = ud (i,l ,m )*gbess (m1,i) + > *ud_b(i,lp,mp)*gbess_b(m2,i) + xx(np1-i) = fac1*( 0.25*(rk+rk_b) + v1(i) ) + > -0.25*( gdud (i)*ud_b(i,lp,mp)*gbess_b(m2,i) + > +gdud_b(i)*ud (i,l ,m )*gbess (m1,i) ) + ENDDO + call intgz0(xx,delz,nmz,xv,tail) + tdd = cmplx(xv,0.0) + + ELSE ! spin-off-diagonal + + ! tuu + DO i=1,nmz + fac1 = u (i,l ,m )*gbess (m1,i) + > *u_b(i,lp,mp)*gbess_b(m2,i) + xx (np1-i) = fac1*vz(i,ivac,3) + xximag(np1-i) = fac1*vz(i,ivac,4)*sign + ENDDO + call intgz0(xx,delz,nmz,xv,tail) + call intgz0(xximag,delz,nmz,yv,tail) + tuu = cmplx(xv,-yv) + + ! tud + DO i=1,nmz + fac1 = u (i,l ,m )*gbess (m1,i) + > *ud_b(i,lp,mp)*gbess_b(m2,i) + xx (np1-i) = fac1*vz(i,ivac,3) + xximag(np1-i) = fac1*vz(i,ivac,4)*sign + ENDDO + call intgz0(xx,delz,nmz,xv,tail) + call intgz0(xximag,delz,nmz,yv,tail) + tud = cmplx(xv,-yv) + + ! tdu + DO i=1,nmz + fac1 = ud (i,l ,m )*gbess (m1,i) + > *u_b(i,lp,mp)*gbess_b(m2,i) + xx (np1-i) = fac1*vz(i,ivac,3) + xximag(np1-i) = fac1*vz(i,ivac,4)*sign + ENDDO + call intgz0(xx,delz,nmz,xv,tail) + call intgz0(xximag,delz,nmz,yv,tail) + tdu = cmplx(xv,-yv) + + ! tdd + DO i=1,nmz + fac1 = ud (i,l ,m )*gbess (m1,i) + > *ud_b(i,lp,mp)*gbess_b(m2,i) + xx (np1-i) = fac1*vz(i,ivac,3) + xximag(np1-i) = fac1*vz(i,ivac,4)*sign + ENDDO + call intgz0(xx,delz,nmz,xv,tail) + call intgz0(xximag,delz,nmz,yv,tail) + tdd = cmplx(xv,-yv) + + ENDIF ! ((ico.EQ.1) .OR. (ico.EQ.2)) + + ENDIF ! (ind1.NE.0) + + ! determine phase factor + phasfc = chi*exp(-cmplx(0.0,m2*arg_b-m1*arg)) + + ! contraction of integrals with a,b coefficients + ! yields contribution to uHu matrix + do i = 1,nslibd + do j = 1,nslibd_b + uHu(i,j) = uHu(i,j) + phasfc*area*( + * acof(l,m,i)*conjg(acof_b(lp,mp,j))*tuu + + + acof(l,m,i)*conjg(bcof_b(lp,mp,j))*tud + + + bcof(l,m,i)*conjg(acof_b(lp,mp,j))*tdu + + + bcof(l,m,i)*conjg(bcof_b(lp,mp,j))*tdd ) + enddo + enddo + + ENDDO ! m2 + ENDDO ! m1 + ENDIF ! noncyl. contributions + ENDDO ! mp + ENDDO ! m + + enddo ! lp + enddo ! l + + deallocate ( udz,uz,dudz,duz,u,ud,ddnv,bess,dbss,acof,bcof ) + deallocate ( udz_b,uz_b,dudz_b,duz_b,u_b,ud_b,ddnv_b,gbess,besss ) + deallocate ( acof_b,bcof_b,gbess_b ) + deallocate ( zmsh,xx,xximag,v1 ) + deallocate ( gdu, gdud, gdu_b, gdud_b ) + + END SUBROUTINE wann_uHu_od_vac + END MODULE m_wann_uHu_od_vac diff --git a/wannier/uhu/wann_uHu_radintsra.F b/wannier/uhu/wann_uHu_radintsra.F new file mode 100644 index 00000000..0edee171 --- /dev/null +++ b/wannier/uhu/wann_uHu_radintsra.F @@ -0,0 +1,107 @@ + MODULE m_wann_uHu_radintsra + CONTAINS + SUBROUTINE wann_uHu_radintsra(jmtd,jri,rmsh,dx, + > epar,vr,f,g,l,expect) + + USE m_intgr, ONLY : intgr3 + USE m_constants + IMPLICIT NONE + + REAL difcub + EXTERNAL difcub + + REAL, INTENT(IN) :: f(jmtd,2),g(jmtd,2) + REAL, INTENT(IN) :: vr(jmtd) + REAL, INTENT(IN) :: epar + REAL, INTENT(IN) :: rmsh(jmtd) + REAL, INTENT(IN) :: dx + REAL, INTENT(IN) :: expect + INTEGER, INTENT(IN) :: jri + INTEGER, INTENT(IN) :: jmtd + INTEGER, INTENT(IN) :: l + + REAL, ALLOCATABLE :: x(:),dg(:,:),t(:,:),vv(:) + REAL :: t11,t22,t12,t21,total,norm + REAL :: mm,c,c2,cin2,cin + REAL :: ll,xi,sfp + INTEGER :: i,j + + c = c_light(1.) + c2 = c*c + cin = 1./c + cin2 = cin*cin + ll = l*(l+1) + sfp = sqrt(4.0*pimach()) + + allocate( x(jri), dg(jri,2), t(jri,2), vv(jri) ) + + ! derivatives d/dr g for large and small component + DO i=1,jri + t(i,:) = g(i,:)/rmsh(i) + ENDDO + + DO j = 1, 2 + ! derivative at 1st point + dg(1,j) = difcub( rmsh(1),t(1,j),rmsh(1) ) + + ! derivative at 2nd...(jri-2)th point + DO i = 2, jri-2 + dg(i,j) = difcub( rmsh(i-1),t(i-1,j),rmsh(i) ) + ENDDO + + ! derivative at last two points + dg(jri-1,j) = difcub( rmsh(jri-3),t(jri-3,j),rmsh(jri-1) ) + dg(jri,j) = difcub( rmsh(jri-3),t(jri-3,j),rmsh(jri) ) + ENDDO + + DO i=1,jri + xi = rmsh(i) + dg(i,:) = dg(i,:) * xi + vv(i) = vr(i) / xi !* sfp + ENDDO + + ! check normalization + DO i = 1, jri + x(i) = f(i,1)*g(i,1)+f(i,2)*g(i,2) + ENDDO + call intgr3(x,rmsh,dx,jri,norm) + write(*,*)'norm:',norm + + + ! compute matrix elements of semi-relativistic + ! Hamiltonian [Eq.(3.54) in PhD thesis of P.Kurz] + DO i = 1, jri + mm = 1. + 0.5 * cin2 * ( epar - vv(i) ) + x(i) = f(i,1) * g(i,1) + > * ( 0.5 / mm * ll / rmsh(i) / rmsh(i) + vv(i) ) + ENDDO + call intgr3(x,rmsh,dx,jri,t11) ! large-H-large + + DO i = 1, jri + x(i) = f(i,2) * g(i,2) * ( -2. * c2 + vv(i) ) + ENDDO + call intgr3(x,rmsh,dx,jri,t22) ! small-H-small + + DO i = 1, jri + x(i) = f(i,1) * ( 2. * g(i,2) / rmsh(i) + dg(i,2) ) + ENDDO + x = -c * x + call intgr3(x,rmsh,dx,jri,t12) ! large-H-small + + DO i = 1, jri + x(i) = f(i,2) * dg(i,1) + ENDDO + x = c * x + call intgr3(x,rmsh,dx,jri,t21) ! small-H-large + + total = t11 + t22 + t12 + t21 + write(*,'(a,f16.12)')'expect:',expect + write(*,'(a,f16.12)')'integr:',total + if(abs(expect).gt.1e-12) then + write(*,'(a,f7.3,a)')'differ:',abs(expect-total)/expect*100.,' %' + endif + + deallocate( x, dg, t, vv ) + + END SUBROUTINE wann_uHu_radintsra + END MODULE m_wann_uHu_radintsra diff --git a/wannier/uhu/wann_uHu_radintsra2.F b/wannier/uhu/wann_uHu_radintsra2.F new file mode 100644 index 00000000..be11b7ac --- /dev/null +++ b/wannier/uhu/wann_uHu_radintsra2.F @@ -0,0 +1,86 @@ + MODULE m_wann_uHu_radintsra2 + CONTAINS + + ! < p | H(l) | q > + SUBROUTINE wann_uHu_radintsra2(jmtd,jri,rmsh,dx, + > e,vr, + > p,q,l, + > integral) + + USE m_intgr, ONLY : intgr3 + USE m_constants + IMPLICIT NONE + + REAL difcub + EXTERNAL difcub + + REAL, INTENT(IN) :: p(jmtd,2) + REAL, INTENT(IN) :: q(jmtd,2) + REAL, INTENT(IN) :: vr(jmtd) + REAL, INTENT(IN) :: e + REAL, INTENT(IN) :: rmsh(jmtd) + REAL, INTENT(IN) :: dx + INTEGER, INTENT(IN) :: jri + INTEGER, INTENT(IN) :: jmtd + INTEGER, INTENT(IN) :: l + REAL, INTENT(OUT) :: integral + + REAL, ALLOCATABLE :: x(:),dq(:,:),t(:,:) + REAL :: c,c2,cin2,cin + REAL :: ll,xi,vv,mm,sfp + INTEGER :: i,j + + c = c_light(1.) + c2 = c*c + cin = 1./c + cin2 = cin*cin + ll = l*(l+1) + sfp = sqrt(4.0*pimach()) + + allocate( x(jri), dq(jri,2), t(jri,2) ) + + DO i=1,jri + t(i,:) = q(i,:) / rmsh(i) + ENDDO + + ! derivatives d/dr for large and small component + DO j = 1, 2 + ! derivative at 1st point + dq(1,j) = difcub( rmsh(1),t(1,j),rmsh(1) ) + + ! derivative at 2nd...(jri-2)th point + DO i = 2, jri-2 + dq(i,j) = difcub( rmsh(i-1),t(i-1,j),rmsh(i) ) + ENDDO + + ! derivative at last two points + dq(jri-1,j) = difcub( rmsh(jri-3),t(jri-3,j),rmsh(jri-1) ) + dq(jri,j) = difcub( rmsh(jri-3),t(jri-3,j),rmsh(jri) ) + ENDDO + + DO i=1,jri + dq(i,:) = dq(i,:)*rmsh(i) + ENDDO + + ! compute matrix elements of semi-relativistic + ! Hamiltonian [Eq.(3.54) in PhD thesis of P.Kurz] + DO i = 1, jri + xi = rmsh(i) + vv = vr(i) / xi !* sfp + mm = 1. + 0.5 * cin2 * ( e - vv ) + x(i) = + > ! large-H-large + > p(i,1) * q(i,1) * ( 0.5 / mm * ll / xi / xi + vv ) + > ! small-H-small + > + p(i,2) * q(i,2) * ( -2. * c2 + vv ) + > ! large-H-small (not symmetrized) + > - c * p(i,1) * (2. * q(i,2) / xi + dq(i,2) ) + > ! small-H-large (not symmetrized) + > + c * p(i,2) * dq(i,1) + ENDDO + call intgr3(x,rmsh,dx,jri,integral) + + deallocate( x, dq, t ) + + END SUBROUTINE wann_uHu_radintsra2 + END MODULE m_wann_uHu_radintsra2 diff --git a/wannier/uhu/wann_uHu_radintsra3.F b/wannier/uhu/wann_uHu_radintsra3.F new file mode 100644 index 00000000..cd067e9b --- /dev/null +++ b/wannier/uhu/wann_uHu_radintsra3.F @@ -0,0 +1,70 @@ +c*************************************************c +c compute radial integrals of sph. Hamiltonian c +c in scalar relativistic approximation between c +c products of radial function u and spherical c +c Bessel functions c +c c +c integral = < uj1 | H_sra(lzb) | uj2 > c +c*************************************************c +c J.-P. Hanke, Dec. 2015 c +c*************************************************c + MODULE m_wann_uHu_radintsra3 + CONTAINS + + SUBROUTINE wann_uHu_radintsra3(jmtd,jri,rmsh,dx,e,vr, + > uj1,uj2,duj2,lmaxd,lzb, + > integral) + + USE m_intgr, ONLY : intgr3 + USE m_constants + IMPLICIT NONE + + REAL difcub + EXTERNAL difcub + + REAL, INTENT(OUT) :: integral + REAL, INTENT(IN) :: vr(jmtd),rmsh(jmtd),dx,e + REAL, INTENT(IN) :: uj1(jmtd,2) ! u(b1)*j + REAL, INTENT(IN) :: uj2(jmtd,2) ! u(b2)*j + REAL, INTENT(IN) :: duj2(jmtd,2) ! d/dr (u(b2)j) + INTEGER, INTENT(IN) :: jri,jmtd,lmaxd + INTEGER, INTENT(IN) :: lzb ! l of zentrifugal barrier + + REAL, ALLOCATABLE :: x(:) + REAL :: c,c2,cin2,cin + REAL :: ll,xi,vv,mm + REAL :: sfp + INTEGER :: i,j + + c = c_light(1.) + c2 = c*c + cin = 1./c + cin2 = cin*cin + ll = lzb*(lzb+1) + sfp = sqrt(4.0*pimach()) + + allocate( x(jri) ) + + ! compute matrix elements of semi-relativistic + ! Hamiltonian [Eq.(3.54) in PhD thesis of P.Kurz] + DO i = 1, jri + xi = rmsh(i) + vv = vr(i) / xi !* sfp ! no need to correct for Y_00 + mm = 1. + 0.5 * cin2 * ( e - vv ) + x(i) = + > ! large-H-large + > uj1(i,1) * uj2(i,1) * ( 0.5 / mm * ll / xi / xi + vv ) + > ! small-H-small + > + uj1(i,2) * uj2(i,2) * ( -2. * c2 + vv ) + > ! large-H-small (not symmetrized) + > - c * uj1(i,1) * ( 2. * uj2(i,2) / xi + duj2(i,2) ) + > ! small-H-large (not symmetrized) + > + c * uj1(i,2) * duj2(i,1) + ENDDO + call intgr3(x,rmsh,dx,jri,integral) + !integral = integral / sfp + + deallocate( x ) + + END SUBROUTINE wann_uHu_radintsra3 + END MODULE m_wann_uHu_radintsra3 diff --git a/wannier/uhu/wann_uHu_radintsra4.F b/wannier/uhu/wann_uHu_radintsra4.F new file mode 100644 index 00000000..b679e429 --- /dev/null +++ b/wannier/uhu/wann_uHu_radintsra4.F @@ -0,0 +1,70 @@ +c*************************************************c +c compute radial integrals of sph. Hamiltonian c +c in scalar relativistic approximation between c +c products of radial function u and spherical c +c Bessel functions c +c c +c integral = < uj1 | H_sra(lzb) | uj2 > c +c*************************************************c +c J.-P. Hanke, Dec. 2015 c +c*************************************************c + MODULE m_wann_uHu_radintsra4 + CONTAINS + + SUBROUTINE wann_uHu_radintsra4(jmtd,jri,rmsh,dx,e,vr,vm, + > uj1,uj2,duj2,lmaxd,lzb, + > integral) + + USE m_intgr, ONLY : intgr3 + USE m_constants + IMPLICIT NONE + + REAL difcub + EXTERNAL difcub + + REAL, INTENT(OUT) :: integral + REAL, INTENT(IN) :: vr(jmtd),vm(jmtd),rmsh(jmtd),dx,e + REAL, INTENT(IN) :: uj1(jmtd,2) ! u(b1)*j + REAL, INTENT(IN) :: uj2(jmtd,2) ! u(b2)*j + REAL, INTENT(IN) :: duj2(jmtd,2) ! d/dr (u(b2)j) + INTEGER, INTENT(IN) :: jri,jmtd,lmaxd + INTEGER, INTENT(IN) :: lzb ! l of zentrifugal barrier + + REAL, ALLOCATABLE :: x(:) + REAL :: c,c2,cin2,cin + REAL :: ll,xi,vv,mm,vv2 + REAL :: sfp + INTEGER :: i,j + + c = c_light(1.) + c2 = c*c + cin = 1./c + cin2 = cin*cin + ll = lzb*(lzb+1) + sfp = sqrt(4.0*pimach()) + + allocate( x(jri) ) + + ! compute matrix elements of semi-relativistic + ! Hamiltonian [Eq.(3.54) in PhD thesis of P.Kurz] + DO i = 1, jri + xi = rmsh(i) + vv = vr(i) / xi !* sfp + vv2= vm(i) / xi !* sfp + mm = 1. + 0.5 * cin2 * ( e - vv2 ) + x(i) = + > ! large-H-large + > uj1(i,1) * uj2(i,1) * ( 0.5 / mm * ll / xi / xi + vv ) + > ! small-H-small + > + uj1(i,2) * uj2(i,2) * ( -2. * c2 + vv ) + > ! large-H-small (not symmetrized) + > - c * uj1(i,1) * (2. * uj2(i,2) / xi + duj2(i,2) ) + > ! small-H-large (not symmetrized) + > + c * uj1(i,2) * duj2(i,1) + ENDDO + call intgr3(x,rmsh,dx,jri,integral) + + deallocate( x ) + + END SUBROUTINE wann_uHu_radintsra4 + END MODULE m_wann_uHu_radintsra4 diff --git a/wannier/uhu/wann_uHu_radintsra5.F b/wannier/uhu/wann_uHu_radintsra5.F new file mode 100644 index 00000000..23c83fe9 --- /dev/null +++ b/wannier/uhu/wann_uHu_radintsra5.F @@ -0,0 +1,120 @@ +c*************************************************c +c compute radial integrals of sph. Hamiltonian c +c in scalar relativistic approximation between c +c products of radial function u and spherical c +c Bessel functions c +c c +c integral = < uj1 | H_sra(lzb) | uj2 > c +c*************************************************c +c J.-P. Hanke, Dec. 2015 c +c*************************************************c + MODULE m_wann_uHu_radintsra5 + CONTAINS + + SUBROUTINE wann_uHu_radintsra5(jmtd,jri,rmsh,dx,e,vr, + > uj1,uj2,duj1,duj2,lmaxd,lzb, + > integral,irank) + + USE m_intgr, ONLY : intgr3 + USE m_constants + IMPLICIT NONE + + REAL difcub + EXTERNAL difcub + + REAL, INTENT(OUT) :: integral + REAL, INTENT(IN) :: vr(jmtd),rmsh(jmtd),dx,e + REAL, INTENT(IN) :: uj1(jmtd,2) ! u(b1)*j + REAL, INTENT(IN) :: uj2(jmtd,2) ! u(b2)*j + REAL, INTENT(IN) :: duj1(jmtd,2) ! d/dr (u(b1)j) + REAL, INTENT(IN) :: duj2(jmtd,2) ! d/dr (u(b2)j) + INTEGER, INTENT(IN) :: jri,jmtd,lmaxd,irank + INTEGER, INTENT(IN) :: lzb ! l of zentrifugal barrier + + REAL, ALLOCATABLE :: x(:) + REAL :: c,c2,cin2,cin + REAL :: ll,xi,vv,mm + REAL :: sfp,facr,facl + REAL, ALLOCATABLE :: xx(:,:),intt(:) + INTEGER :: i,j,symopt + + c = c_light(1.) + c2 = c*c + cin = 1./c + cin2 = cin*cin + ll = lzb*(lzb+1) + sfp = sqrt(4.0*pimach()) + symopt=0 + + if(symopt.eq.0) then ! symmetrize + facr = 0.5 + facl = 0.5 + elseif(symopt.lt.0)then ! apply H to left + facr = 0.0 + facl = 1.0 + else ! apply H to right + facr = 1.0 + facl = 0.0 + endif + + allocate( x(jri) ) + allocate( xx(jri,8),intt(8) ) + + ! compute matrix elements of semi-relativistic + ! Hamiltonian [Eq.(3.54) in PhD thesis of P.Kurz] + DO i = 1, jri + xi = rmsh(i) + vv = vr(i) / xi !* sfp ! no need to correct for Y_00 + mm = 1. + 0.5 * cin2 * ( e - vv ) + x(i) = + > ! large-H-large + > uj1(i,1) * uj2(i,1) * ( 0.5 / mm * ll / xi / xi + vv ) + > ! small-H-small + > + uj1(i,2) * uj2(i,2) * ( -2. * c2 + vv ) +c ! NEW VERSION BELOW +c > - c / xi * ( uj1(i,1)*uj2(i,2) + uj1(i,2)*uj2(i,1) ) +c > + c / 2. * ( uj1(i,2)*duj2(i,1) + duj1(i,2)*uj2(i,1) ) +c > - c / 2. * ( uj1(i,1)*duj2(i,2) + duj1(i,1)*uj2(i,2) ) + ! OLD VERSION BELOW + > ! large-H-small (symmetrized) + > - facr * c * uj1(i,1) * ( 2. * uj2(i,2) / xi + duj2(i,2) ) + > - facl * c * uj2(i,1) * ( 2. * uj1(i,2) / xi + duj1(i,2) ) + > ! small-H-large (symmetrized) + > + facr * c * uj1(i,2) * duj2(i,1) + > + facl * c * uj2(i,2) * duj1(i,1) + +c xx(i,:) = 0.0 +c +c xx(i,1)=uj1(i,1) * uj2(i,1) * ( 0.5 / mm * ll / xi / xi ) +c xx(i,2)=uj1(i,1) * uj2(i,1) * ( vv ) +c +c xx(i,3)=uj1(i,2) * uj2(i,2) * ( -2. * c2 ) +c xx(i,4)=uj1(i,2) * uj2(i,2) * ( vv ) +c +c xx(i,5)=-uj1(i,1) * c * ( 2.*uj2(i,2)/xi ) +c xx(i,6)=-uj1(i,1) * c * ( duj2(i,2) ) +c +c xx(i,7)= c * uj1(i,2) * duj2(i,1) +c +c x(i) = xx(i,1)+xx(i,2)+xx(i,3)+xx(i,4) +c > +xx(i,5)+xx(i,6)+xx(i,7)+xx(i,8) + + ENDDO + call intgr3(x,rmsh,dx,jri,integral) +c do i=1,8 +c call intgr3(xx(:,i),rmsh,dx,jri,intt(i)) +c enddo + !integral = integral / sfp + +c if(irank.eq.0 .and. abs(integral).gt.1e-10) then +c do i=1,8 +c write(*,'(a,i1,a,f8.2)')'int',i,':',intt(i)/integral*100. +c enddo +c write(*,*)'integral:',integral +c endif + + deallocate( x ) + deallocate( xx,intt ) + + END SUBROUTINE wann_uHu_radintsra5 + END MODULE m_wann_uHu_radintsra5 diff --git a/wannier/uhu/wann_uHu_soc.F b/wannier/uhu/wann_uHu_soc.F new file mode 100644 index 00000000..d1880396 --- /dev/null +++ b/wannier/uhu/wann_uHu_soc.F @@ -0,0 +1,456 @@ +c*****************************************c +c Spin-orbit coupling cont. to uHu c +c < u_{k+b1} | V_{k}^{soc} | u_{k+b2} > c +c*****************************************c +c Routine to set up T(lm,lmp) for all c +c pairs (b1,b2) and every atom n c +c*****************************************c +c J.-P. Hanke, Dec. 2015 c +c*****************************************c + MODULE m_wann_uHu_soc + CONTAINS + SUBROUTINE wann_uHu_soc( + > ntypd,jmtd,lmaxd,jspd,ntype,dx,rmsh,jri,lmax, + > natd,lmd,lmplmd,neq,irank,nlod,llod,loplod, + > ello,llo,nlo,lo1l,l_dulo,ulo_der,f,g,flo,f_b, + > g_b,flo_b,kdiff,kdiff2,nntot,nntot2, + > bmat,bbmat,vr,epar,jspin, + > jspin_b,jspins,l_spav,theta,phi,alph,beta, + > l_noco,l_skip_loc, + < tuu,tud,tdu,tdd,tuulo,tulou,tdulo,tulod,tuloulo) + + USE m_intgr, ONLY : intgr0 + USE m_sphbes + USE m_dotir + USE m_ylm + USE m_cotra + USE m_gaunt, ONLY: gaunt1 + USE m_sointg + USE m_constants, ONLY : c_light + USE m_wann_uHu_soc_tlo + + IMPLICIT NONE + REAL :: sgml + COMPLEX :: anglso + EXTERNAL sgml,anglso +C .. Intrinsic Functions .. + INTRINSIC abs,cmplx,max,mod +C .. +C .. Scalar Arguments .. + LOGICAL, INTENT (IN) :: l_noco,l_skip_loc + INTEGER, INTENT (IN) :: ntypd,jmtd,lmaxd,jspd,jspins + INTEGER, INTENT (IN) :: lmd,lmplmd,ntype,irank,jspin,jspin_b + INTEGER, INTENT (IN) :: nlod,llod,loplod,natd + INTEGER, INTENT (IN) :: nntot,nntot2 + REAL, INTENT (IN) :: theta,phi +C .. +C .. Array Arguments .. + COMPLEX, INTENT (INOUT):: + > tdd(0:lmd,0:lmd,ntypd,nntot*nntot2), + > tdu(0:lmd,0:lmd,ntypd,nntot*nntot2), + > tud(0:lmd,0:lmd,ntypd,nntot*nntot2), + > tuu(0:lmd,0:lmd,ntypd,nntot*nntot2) + COMPLEX, INTENT (INOUT):: + > tdulo(0:lmd,nlod,-llod:llod,ntypd,nntot*nntot2), + > tuulo(0:lmd,nlod,-llod:llod,ntypd,nntot*nntot2), + > tulou(0:lmd,nlod,-llod:llod,ntypd,nntot*nntot2), + > tulod(0:lmd,nlod,-llod:llod,ntypd,nntot*nntot2), + > tuloulo(nlod,-llod:llod,nlod,-llod:llod,ntypd,nntot*nntot2) + INTEGER, INTENT (IN) :: llo(nlod,ntypd),nlo(ntypd) + INTEGER, INTENT (IN) :: lo1l(0:llod,ntypd),neq(ntypd) + INTEGER, INTENT (IN) :: jri(ntypd),lmax(ntypd) + INTEGER, INTENT (IN) :: ulo_der(nlod,ntypd) + REAL, INTENT (IN) :: alph(ntypd),beta(ntypd) + REAL, INTENT (IN) :: dx(ntypd),rmsh(jmtd,ntypd) + REAL, INTENT (IN) :: ello(nlod,ntypd,max(jspd,2)) + REAL, INTENT (IN) :: epar(0:lmaxd,ntypd,max(jspd,2)) + REAL, INTENT (IN) :: vr(jmtd,ntypd,jspd) + REAL, INTENT (IN) :: f (ntypd,jmtd,2,0:lmaxd), + > g (ntypd,jmtd,2,0:lmaxd), + > f_b(ntypd,jmtd,2,0:lmaxd), + > g_b(ntypd,jmtd,2,0:lmaxd), + > flo (ntypd,jmtd,2,nlod), + > flo_b(ntypd,jmtd,2,nlod) + REAL, INTENT (IN) :: bmat(3,3),bbmat(3,3) + REAL, INTENT (IN) :: kdiff (3,nntot) + REAL, INTENT (IN) :: kdiff2(3,nntot2) + LOGICAL, INTENT (IN) :: l_dulo(nlod,ntypd),l_spav +C .. +C .. Local Scalars .. + REAL gs,rk1,rk2,socscreen_fac + REAL gc1,gc2,c,e,r0 + REAL t0,t1,t11,t22,t33,t44,t55,t66 + COMPLEX cil,ci,cci,cciljj1,ciljj2,fac1,fac2,fac3,dump1,dump2 + INTEGER i,l,l2,lh,lm,lmp,lp + INTEGER lp1,lpl,m,mp,mu,n,nh,noded,nodeu,nrec,na,ne + INTEGER ljj1,ljj2,mjj1,mjj2 + INTEGER ltil1,mtil1,mtil2 + INTEGER mlo, mlolo, iu, indexx + INTEGER lmini,lmini2, lmaxi,lmaxi2,lmx,lmx2 + INTEGER ll,llp,lljj1,lljj2,lmjj1,lmjj2 + INTEGER lltil1,lmtil1,lmtil2,sp1,sp2 + INTEGER mmin,mmax,lwn, ikpt_b,ikpt_b2 + LOGICAL l_socscreen +C .. +C .. Local Arrays .. + REAL, ALLOCATABLE :: dvd(:,:,:,:,:),dvu(:,:,:,:,:) + REAL, ALLOCATABLE :: uvd(:,:,:,:,:),uvu(:,:,:,:,:) + REAL, ALLOCATABLE :: p(:,:,:),p_b(:,:,:),q(:,:,:),q_b(:,:,:) + REAL, ALLOCATABLE :: x(:) + REAL, ALLOCATABLE :: jlpp(:),jj1(:,:),jj2(:,:) + REAL, ALLOCATABLE :: v0(:),vso(:,:) + REAL :: bpt(3),bpt2(3),bkrot(3) + COMPLEX, ALLOCATABLE :: yl1(:),yl2(:) + COMPLEX, ALLOCATABLE :: angso(:,:,:) + INTEGER :: ispjsp(2) + DATA ispjsp/1,-1/ + +#if (defined(CPP_MPI) && !defined(CPP_T90)) + INCLUDE 'mpif.h' + INTEGER ierr(3) +#endif + + t11 = 0.; t22 = 0.; t33 = 0.; t44 = 0.; t55 = 0.; t66 = 0. + ci = cmplx(0.0, 1.0) + cci = cmplx(0.0,-1.0) + c = c_light(1.0) + sp1 = ispjsp(jspin) + sp2 = ispjsp(jspin_b) + + l_socscreen = .false. ; socscreen_fac = 1.0 + INQUIRE(file='socscreen',exist=l_socscreen) + IF(l_socscreen) THEN + OPEN(757,file='socscreen') + READ(757,*)socscreen_fac + CLOSE(757) + IF(irank.eq.0) write(*,*)'socscreen with factor',socscreen_fac + ENDIF + + allocate( dvd(0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd) ) + allocate( dvu(0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd) ) + allocate( uvd(0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd) ) + allocate( uvu(0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd) ) + allocate( p(jmtd,0:lmaxd,0:lmaxd), p_b(jmtd,0:lmaxd,0:lmaxd) ) + allocate( q(jmtd,0:lmaxd,0:lmaxd), q_b(jmtd,0:lmaxd,0:lmaxd) ) + allocate( x(jmtd) ) + allocate( jlpp(0:lmaxd), jj1(0:lmaxd,jmtd), jj2(0:lmaxd,jmtd) ) + allocate( v0(jmtd), vso(jmtd,2) ) + allocate( angso(0:lmd,0:lmd,ntypd) ) + allocate( yl1((lmaxd+1)**2), yl2((lmaxd+1)**2) ) + + call cpu_time(t0) + angso = cmplx(0.,0.) +c*******************************************c +c set up < l m sp1 | sigma L | l mp sp2 > c +c*******************************************c + DO n=1,ntype + DO l=1,lmaxd ! TODO: exclude s-states? + ll=l*(l+1) + DO m=-l,l + lm = ll+m + DO mp=-l,l + lmp = ll+mp + if(l_noco) then + angso(lm,lmp,n) = anglso(beta(n),alph(n),l,m,sp1,l,mp,sp2) + else + angso(lm,lmp,n) = anglso(theta,phi,l,m,sp1,l,mp,sp2) + endif + ENDDO + ENDDO + ENDDO + ENDDO + call cpu_time(t1) + t11 = t11 + t1-t0 + +c***************************************c +c begin 1st neighbor loop: c +c***************************************c + do ikpt_b2=1,nntot2 + indexx = ikpt_b2 + (ikpt_b-1)*nntot2 + + bpt2 = kdiff2(:,ikpt_b2) + rk2= sqrt(dotirp(bpt2,bpt2,bbmat)) + + ! loop over atoms + DO 210 n = 1,ntype + lwn = lmax(n) + r0 = rmsh(1,n) + + ! set up spherical Bessel functions + ! jj1(l,b1*r) and jj2(l,b2*r) + call cpu_time(t0) + do i=1,jri(n) + gs = rk1*rmsh(i,n) + call sphbes(lwn,gs,jlpp) + jj1(:,i) = jlpp(:) + + gs = rk2*rmsh(i,n) + call sphbes(lwn,gs,jlpp) + jj2(:,i) = jlpp(:) + enddo + call cpu_time(t1) + t22 = t22 + t1-t0 + + ! set up spherical harmonics + ! yl1(lm) for b1 and yl2(lm) for b2 + yl1 = cmplx(0.,0.) + call cotra3(bpt,bkrot,bmat) + call ylm4(lwn,bkrot,yl1) + + yl2 = cmplx(0.,0.) + call cotra3(bpt2,bkrot,bmat) + call ylm4(lwn,bkrot,yl2) + call cpu_time(t0) + t33 = t33 + t0-t1 + + ! set up products of radial functions and sph. Bessel + DO ljj1 = 0, lwn + DO l = 0, lwn + DO i=1,jri(n) + p(i,l,ljj1) = f(n,i,1,l)*jj1(ljj1,i) + q(i,l,ljj1) = g(n,i,1,l)*jj1(ljj1,i) + p_b(i,l,ljj1) = f_b(n,i,1,l)*jj2(ljj1,i) + q_b(i,l,ljj1) = g_b(n,i,1,l)*jj2(ljj1,i) + ENDDO + ENDDO + ENDDO + +c****************************************************c +c compute radial integrals c +c c +c****************************************************c + uvu = 0.0; uvd = 0.0; dvu = 0.0; dvd = 0.0 + DO lp = 0, lwn + DO l = 0, lwn + + ! construct vso + v0 = 0. + IF (jspins.EQ.1) THEN + v0(1:jri(n)) = vr(1:jri(n),n,1) + e = ( epar(l,n,1) + epar(lp,n,1) )/2. + ELSE + DO i = 1,jri(n) + v0(i) = (vr(i,n,1)+vr(i,n,jspins))/2. + END DO + e = ( epar(l,n,1)+epar(l,n,jspins) + > +epar(lp,n,1)+epar(lp,n,jspins) )/4. + END IF + + CALL sointg( + > e,vr(:,n,:),v0,r0,dx(n),jri(n),jmtd,c,jspins, + < vso) + + ! spin-averaging + if(l_spav)then + DO i= 1,jmtd + vso(i,1)= (vso(i,1)+vso(i,2))/2. + vso(i,2)= vso(i,1) + ENDDO + endif + + if(l_socscreen) vso(:,:) = vso(:,:)*socscreen_fac + + ! calculate radial integrals + DO ljj1 = 0, lwn + lmini = abs(lp-ljj1) + lmaxi = lp+ljj1 + lmx = min(lmaxi,lwn) + DO ljj2 = 0, lwn + DO lh = lmini, lmx + lmini2= abs(lh-ljj2) + lmaxi2= lh+ljj2 + if((lmini2.gt.l) .or. (lmaxi2.lt.l).or. + > (mod(lmaxi+lh,2).eq.1).or. + > (mod(lmaxi2+l,2).eq.1) ) CYCLE + + DO i=1,jri(n) + x(i) = p(i,lp,ljj1)*p_b(i,l,ljj2)*vso(i,jspin) + ENDDO + call intgr0(x(1:jri(n)),r0,dx(n),jri(n), + > uvu(lh,l,lp,ljj2,ljj1)) + + DO i=1,jri(n) + x(i) = q(i,lp,ljj1)*p_b(i,l,ljj2)*vso(i,jspin) + ENDDO + call intgr0(x(1:jri(n)),r0,dx(n),jri(n), + > dvu(lh,l,lp,ljj2,ljj1)) + + DO i=1,jri(n) + x(i) = p(i,lp,ljj1)*q_b(i,l,ljj2)*vso(i,jspin) + ENDDO + call intgr0(x(1:jri(n)),r0,dx(n),jri(n), + > uvd(lh,l,lp,ljj2,ljj1)) + + DO i=1,jri(n) + x(i) = q(i,lp,ljj1)*q_b(i,l,ljj2)*vso(i,jspin) + ENDDO + call intgr0(x(1:jri(n)),r0,dx(n),jri(n), + > dvd(lh,l,lp,ljj2,ljj1)) + ENDDO + ENDDO + ENDDO + ENDDO!l + ENDDO!lp + call cpu_time(t1) + t44 = t44 +t1-t0 + +c***************** SOC CONTRIBUTION **********************c +c compute product of the two Gaunt coefficients c +c with the radial integrals (+prefactors) c +c*********************************************************c +c We deal with two Gaunt coefficients: c +c G1 = G( (ltil1, mtil1), (ljj1, mjj1), (lp, mp) ) c +c G2 = G( (l , m) , (ljj2, mjj2), (ltil1, mtil2) ) c +c*********************************************************c +c use Gaunt conditions to reduce number of operations. c +c coefficient G(L1,L2,L3) only nonzero if c +c a) l1 + l2 + l3 = even c +c b) |l2-l3| <= l1 <= l2+l3 c +c c) m1 = m2 + m3 c +c*********************************************************c + DO ljj1=0,lwn + lljj1 = ljj1 * (ljj1 + 1) + cciljj1 = cci**ljj1 + DO mjj1 = -ljj1,ljj1 + lmjj1 = lljj1 + mjj1 + fac1 = cciljj1 * conjg(yl1(lmjj1+1)) + IF(fac1.eq.0.0) CYCLE + + DO lp=0,lwn + llp = lp*(lp+1) + lmini = abs(lp-ljj1) + lmaxi = lp+ljj1 + lmx = min(lmaxi,lwn) + DO mp=-lp,lp + lmp = llp+mp + mtil1=mjj1+mp + IF(abs(mtil1).GT.lmx) CYCLE + + DO ltil1=lmini,lmx + ! Gaunt conditions (G1): + if((mod(lmaxi+ltil1,2).eq.1).or. + > (abs(mtil1).gt.ltil1)) cycle + + lltil1 = ltil1*(ltil1+1) + lmtil1 = lltil1+mtil1 + mmin = max(-ltil1,mtil1-1) + mmax = min( ltil1,mtil1+1) + + gc1 = gaunt1(ltil1, ljj1, lp, + > mtil1, mjj1, mp, lmaxd) + fac2 = fac1 * gc1 * (ci**lp) + + DO ljj2=0,lwn + lljj2 = ljj2 * (ljj2 + 1) + ciljj2 = ci**ljj2 + lmini2 = abs(ltil1-ljj2) + lmaxi2 = ltil1+ljj2 + lmx2 = min(lmaxi2,lwn) + DO mjj2 = -ljj2,ljj2 + lmjj2 = lljj2 + mjj2 + fac3 = fac2 * ciljj2 * conjg(yl2(lmjj2+1)) + IF(fac3.eq.0.0) CYCLE + + DO mtil2=mmin,mmax ! mtil1-1 <= mtil2 <= mtil1+1 + lmtil2 = lltil1+mtil2 + m=mjj2+mtil2 + IF(abs(m).GT.lmx2) cycle + + DO l=lmini2,lmx2 + ! Gaunt conditions (G2): + if((mod(lmaxi2+l,2).eq.1).or. + > (abs(m).gt.l)) cycle + ll = l*(l+1) + lm = ll+m + + gc2 = gaunt1( l, ljj2, ltil1, + > m, mjj2, mtil2, lmaxd) + + ! set up prefactor + cil = fac3 * (cci**l) * gc2 * conjg(angso(lmtil1,lmtil2,n)) + + ! compute T-coefficients + tuu(lm, lmp, n, indexx) + > = tuu(lm, lmp, n, indexx) + > + cil * uvu(ltil1, l, lp, ljj2, ljj1) + + tdd(lm, lmp, n, indexx) + > = tdd(lm, lmp, n, indexx) + > + cil * dvd(ltil1, l, lp, ljj2, ljj1) + + tud(lm, lmp, n, indexx) + > = tud(lm, lmp, n, indexx) + > + cil * uvd(ltil1, l, lp, ljj2, ljj1) + + tdu(lm, lmp, n, indexx) + > = tdu(lm, lmp, n, indexx) + > + cil * dvu(ltil1, l, lp, ljj2, ljj1) + ENDDO!ljj2 + ENDDO!m + ENDDO!l + ENDDO!mtil2 + ENDDO!ljj1 + ENDDO!mp + ENDDO!lp + ENDDO!mtil1 + ENDDO!ltil1 + call cpu_time(t0) + t55 = t55 + t0-t1 + +c************** LOCAL ORBITAL CONTRIBUTION ***************c +c determine contributions to T-matrix due to loc. orb. c +c*********************************************************c + IF((nlo(n).GE.1).AND.(.NOT.l_skip_loc)) THEN + + call wann_uHu_soc_tlo( + > ntypd,jmtd,lmaxd,jspd,ntype,dx,rmsh,jri,lmax, + > natd,lmd,irank,nlod,llod,loplod,ello,llo,nlo, + > lo1l,l_dulo,ulo_der,flo,flo_b,kdiff,kdiff2, + > nntot,nntot2, + > vr,epar,jspin,jspin_b,jspins,l_spav,theta,phi, + > yl1,yl2,jj1,jj2,p,p_b,q,q_b,n,angso(0,0,n), + > l_socscreen,socscreen_fac, + > tuulo(0,1,-llod,n,indexx), + > tdulo(0,1,-llod,n,indexx), + > tulou(0,1,-llod,n,indexx), + > tulod(0,1,-llod,n,indexx), + > tuloulo(1,-llod,1,-llod,n,indexx)) + + call cpu_time(t1) + t66 = t66 + t1-t0 + ENDIF + + 210 ENDDO !loop over atoms + + enddo !ikpt_b2 + enddo !ikpt_b + +#if (defined(CPP_MPI) && !defined(CPP_T90)) + CALL MPI_BARRIER(MPI_COMM_WORLD,ierr) +#endif + + deallocate( dvd, dvu, uvd, uvu ) + deallocate( p, p_b, q, q_b ) + deallocate( x ) + deallocate( jlpp, jj1, jj2 ) + deallocate( yl1, yl2 ) + deallocate( v0, vso, angso ) + + if(irank.eq.0) then + write(*,*)'t_angso =',t11 + write(*,*)'t_sphbes=',t22 + write(*,*)'t_ylm =',t33 + write(*,*)'t_radint=',t44 + write(*,*)'t_gaunt =',t55 + write(*,*)'t_locorb=',t66 + endif + + END SUBROUTINE wann_uHu_soc + END MODULE m_wann_uHu_soc diff --git a/wannier/uhu/wann_uHu_soc_tlo.F b/wannier/uhu/wann_uHu_soc_tlo.F new file mode 100644 index 00000000..142f8a41 --- /dev/null +++ b/wannier/uhu/wann_uHu_soc_tlo.F @@ -0,0 +1,517 @@ +c*****************************************c +c Spin-orbit coupling cont. to uHu c +c < u_{k+b1} | V_{k}^{soc} | u_{k+b2} > c +c*****************************************c +c Routine to set up T(lm,lmp) for all c +c pairs (b1,b2) and every atom n c +c due to local orbitals c +c*****************************************c +c J.-P. Hanke, Dec. 2015 c +c*****************************************c + MODULE m_wann_uHu_soc_tlo + CONTAINS + SUBROUTINE wann_uHu_soc_tlo( + > ntypd,jmtd,lmaxd,jspd, + > ntype,dx,rmsh,jri,lmax,natd, + > lmd,irank,nlod,llod, + > loplod,ello,llo,nlo,lo1l,l_dulo,ulo_der, + > flo,flo_b,kdiff,kdiff2,nntot,nntot2, + > vr,epar,jspin,jspin_b,jspins,l_spav,theta,phi, + > yl1,yl2,jj1,jj2,p,p_b,q,q_b,ntyp,angso, + > l_socscreen,socscreen_fac, + < tuulo,tdulo,tulou,tulod,tuloulo) + + USE m_intgr, ONLY : intgr0 + USE m_sphbes + USE m_dotir + USE m_ylm + USE m_cotra + USE m_gaunt, ONLY: gaunt1 + USE m_sointg + USE m_constants, ONLY : c_light + + + IMPLICIT NONE +C .. Intrinsic Functions .. + INTRINSIC abs,cmplx,max,mod +C .. +C .. Scalar Arguments .. + INTEGER, INTENT (IN) :: ntypd,jmtd,lmaxd,jspd,jspins + INTEGER, INTENT (IN) :: lmd,ntype,irank,jspin,jspin_b + INTEGER, INTENT (IN) :: nlod,llod,loplod,natd + INTEGER, INTENT (IN) :: nntot,nntot2,ntyp + REAL, INTENT (IN) :: theta,phi,socscreen_fac + LOGICAL, INTENT (IN) :: l_socscreen +C .. +C .. Array Arguments .. + COMPLEX, INTENT (INOUT):: + > tdulo(0:lmd,nlod,-llod:llod), + > tuulo(0:lmd,nlod,-llod:llod), + > tulou(0:lmd,nlod,-llod:llod), + > tulod(0:lmd,nlod,-llod:llod), + > tuloulo(nlod,-llod:llod,nlod,-llod:llod) + COMPLEX, INTENT (IN) :: angso(0:lmaxd,0:lmaxd) + COMPLEX, INTENT (IN) :: yl1((lmaxd+1)**2),yl2((lmaxd+1)**2) + INTEGER, INTENT (IN) :: llo(nlod,ntypd),nlo(ntypd) + INTEGER, INTENT (IN) :: lo1l(0:llod,ntypd) + INTEGER, INTENT (IN) :: jri(ntypd),lmax(ntypd) + INTEGER, INTENT (IN) :: ulo_der(nlod,ntypd) + REAL, INTENT (IN) :: dx(ntypd),rmsh(jmtd,ntypd) + REAL, INTENT (IN) :: ello(nlod,ntypd,max(jspd,2)) + REAL, INTENT (IN) :: epar(0:lmaxd,ntypd,max(jspd,2)) + REAL, INTENT (IN) :: vr(jmtd,ntypd,jspd) + REAL, INTENT (IN) :: flo (ntypd,jmtd,2,nlod), + > flo_b(ntypd,jmtd,2,nlod) + REAL, INTENT (IN) :: p(jmtd,0:lmaxd,0:lmaxd), + > q(jmtd,0:lmaxd,0:lmaxd), + > p_b(jmtd,0:lmaxd,0:lmaxd), + > q_b(jmtd,0:lmaxd,0:lmaxd) + REAL, INTENT (IN) :: kdiff (3,nntot) + REAL, INTENT (IN) :: kdiff2(3,nntot2) + REAL, INTENT (IN) :: jj1(0:lmaxd,jmtd),jj2(0:lmaxd,jmtd) + LOGICAL, INTENT (IN) :: l_dulo(nlod,ntypd),l_spav +C .. +C .. Local Scalars .. + REAL gc1,gc2,c,e,r0 + COMPLEX cil,ci + INTEGER i,l,l2,lh,lm,lmp,lp,lo,lop + INTEGER lp1,lpl,m,mp,mu + INTEGER ljj1,ljj2,mjj1,mjj2 + INTEGER ltil1,mtil1,mtil2 + INTEGER lmini,lmini2, lmaxi,lmaxi2 + INTEGER ll,llp,lljj1,lljj2,lmjj1,lmjj2 + INTEGER lltil1,lmtil1,lmtil2,sp1,sp2 + INTEGER mmin,mmax,lwn, ikpt_b,ikpt_b2 +C .. +C .. Local Arrays .. + REAL, ALLOCATABLE :: dvulo(:,:,:,:,:),ulovd(:,:,:,:,:) + REAL, ALLOCATABLE :: uvulo(:,:,:,:,:),ulovu(:,:,:,:,:) + REAL, ALLOCATABLE :: ulovulo(:,:,:,:,:) + REAL, ALLOCATABLE :: plo(:,:,:),plo_b(:,:,:) + REAL, ALLOCATABLE :: x(:) + REAL, ALLOCATABLE :: v0(:),vso(:,:) + INTEGER :: ispjsp(2) + DATA ispjsp/1,-1/ + +#if (defined(CPP_MPI) && !defined(CPP_T90)) + INCLUDE 'mpif.h' + INTEGER ierr(3) +#endif + + ci = cmplx(0.0,1.0) + c = c_light(1.0) + sp1 = ispjsp(jspin) + sp2 = ispjsp(jspin_b) + + allocate( ulovulo(0:lmaxd,0:lmaxd,0:lmaxd,nlod,nlod) ) + allocate( ulovu(0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd,nlod) ) + allocate( ulovd(0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd,nlod) ) + allocate( uvulo(0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd,nlod) ) + allocate( dvulo(0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd,nlod) ) + allocate( x(jmtd) ) + allocate( v0(jmtd), vso(jmtd,2) ) + allocate( plo(jmtd,0:lmaxd,nlod), plo_b(jmtd,0:lmaxd,nlod) ) + + lwn = lmax(ntyp) + r0 = rmsh(1,ntyp) + + DO lo = 1, nlo(ntyp) + DO ljj1 = 0, lwn + DO i=1,jri(ntyp) + plo(i,ljj1,lo) = flo(ntyp,i,1,lo)*jj1(ljj1,i) + plo_b(i,ljj1,lo) = flo_b(ntyp,i,1,lo)*jj2(ljj1,i) + ENDDO + ENDDO + ENDDO + +c****************************************************c +c compute radial integrals c +c c +c****************************************************c + +! lo-lo + DO lop = 1, nlo(ntyp) + lp = llo(lop,ntyp) + DO lo = 1, nlo(ntyp) + l = llo(lop,ntyp) + + ! construct vso + v0 = 0. + IF (jspins.EQ.1) THEN + v0(1:jri(ntyp)) = vr(1:jri(ntyp),ntyp,1) + e = ( ello(lo,ntyp,1) + ello(lop,ntyp,1) )/2. + ELSE + DO i = 1,jri(ntyp) + v0(i) = (vr(i,ntyp,1)+vr(i,ntyp,jspins))/2. + END DO + e = ( ello(lo,ntyp,1) + ello(lo,ntyp,jspins) + > +ello(lop,ntyp,1) + ello(lop,ntyp,jspins) )/4. + END IF + + CALL sointg( + > e,vr(:,ntyp,:),v0,r0,dx(ntyp),jri(ntyp),jmtd,c,jspins, + < vso) + + ! spin-averaging + if(l_spav)then + DO i= 1,jmtd + vso(i,1)= (vso(i,1)+vso(i,2))/2. + vso(i,2)= vso(i,1) + ENDDO + endif + + if(l_socscreen) vso(:,:) = vso(:,:)*socscreen_fac + + ! calculate radial integrals + DO ljj1 = 0, lwn + DO ljj2 = 0, lwn + DO lh=0,lwn + lmini = abs(lp-ljj1) + lmini2= abs(lh-ljj2) + lmaxi = lp+ljj1 + lmaxi2= lh+ljj2 + if((lmini.gt.lh) .or. (lmaxi.lt.lh).or. + > (lmini2.gt.l) .or. (lmaxi2.lt.l).or. + > (mod(lp+lh+ljj1,2).ne.0).or. + > (mod( l+lh+ljj2,2).ne.0) ) then + + ulovulo(lh,ljj2,ljj1,lo,lop) = 0. + + else + + DO i=1,jri(ntyp) + x(i) = plo(i,ljj1,lop)*plo_b(i,ljj2,lo)*vso(i,jspin) + ENDDO + call intgr0(x(1:jri(ntyp)),r0,dx(ntyp),jri(ntyp), + > ulovulo(lh,ljj2,ljj1,lo,lop)) + + endif + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO!lh + +! apw-lo + DO lop = 1, nlo(ntyp) + lp = llo(lop,ntyp) + DO l = 0, lwn + + ! construct vso + v0 = 0. + IF (jspins.EQ.1) THEN + v0(1:jri(ntyp)) = vr(1:jri(ntyp),ntyp,1) + e = ( epar(l,ntyp,1) + ello(lop,ntyp,1) )/2. + ELSE + DO i = 1,jri(ntyp) + v0(i) = (vr(i,ntyp,1)+vr(i,ntyp,jspins))/2. + END DO + e = ( epar(l,ntyp,1) + epar(l,ntyp,jspins) + > +ello(lop,ntyp,1) + ello(lop,ntyp,jspins) )/4. + END IF + + CALL sointg( + > e,vr(:,ntyp,:),v0,r0,dx(ntyp),jri(ntyp),jmtd,c,jspins, + < vso) + + ! spin-averaging + if(l_spav)then + DO i= 1,jmtd + vso(i,1)= (vso(i,1)+vso(i,2))/2. + vso(i,2)= vso(i,1) + ENDDO + endif + + ! calculate radial integrals + DO ljj1 = 0, lwn + DO ljj2 = 0, lwn + DO lh=0,lwn + lmini = abs(lp-ljj1) + lmini2= abs(lh-ljj2) + lmaxi = lp+ljj1 + lmaxi2= lh+ljj2 + if((lmini.gt.lh) .or. (lmaxi.lt.lh).or. + > (lmini2.gt.l) .or. (lmaxi2.lt.l).or. + > (mod(lp+lh+ljj1,2).ne.0).or. + > (mod( l+lh+ljj2,2).ne.0) ) then + + ulovu(lh,l,ljj2,ljj1,lop) = 0. + ulovd(lh,l,ljj2,ljj1,lop) = 0. + + else + + DO i=1,jri(ntyp) + x(i) = plo(i,ljj1,lop)*p_b(i,l,ljj2)*vso(i,jspin) + ENDDO + call intgr0(x(1:jri(ntyp)),r0,dx(ntyp),jri(ntyp), + > ulovu(lh,l,ljj2,ljj1,lop)) + DO i=1,jri(ntyp) + x(i) = plo(i,ljj1,lop)*q_b(i,l,ljj2)*vso(i,jspin) + ENDDO + call intgr0(x(1:jri(ntyp)),r0,dx(ntyp),jri(ntyp), + > ulovd(lh,l,ljj2,ljj1,lop)) + + endif + + lmini = abs(l-ljj1) + lmini2= abs(lh-ljj2) + lmaxi = l+ljj1 + lmaxi2= lh+ljj2 + if((lmini.gt.lh) .or. (lmaxi.lt.lh).or. + > (lmini2.gt.lp) .or. (lmaxi2.lt.lp).or. + > (mod( l+lh+ljj1,2).ne.0).or. + > (mod(lp+lh+ljj2,2).ne.0) ) then + + uvulo(lh,l,ljj2,ljj1,lop) = 0. + dvulo(lh,l,ljj2,ljj1,lop) = 0. + + else + + DO i=1,jri(ntyp) + x(i) = p(i,l,ljj1)*plo_b(i,ljj2,lop)*vso(i,jspin) + ENDDO + call intgr0(x(1:jri(ntyp)),r0,dx(ntyp),jri(ntyp), + > uvulo(lh,l,ljj2,ljj1,lop)) + DO i=1,jri(ntyp) + x(i) = q(i,l,ljj1)*plo_b(i,ljj2,lop)*vso(i,jspin) + ENDDO + call intgr0(x(1:jri(ntyp)),r0,dx(ntyp),jri(ntyp), + > dvulo(lh,l,ljj2,ljj1,lop)) + + endif + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO!lh + +c***************** SOC CONTRIBUTION **********************c +c compute product of the two Gaunt coefficients c +c with the radial integrals (+prefactors) c +c*********************************************************c +c We deal with two Gaunt coefficients: c +c G1 = G( (ltil1, mtil1), (ljj1, mjj1), (lp, mp) ) c +c G2 = G( (l , m) , (ljj2, mjj2), (ltil1, mtil2) ) c +c*********************************************************c +c use Gaunt conditions to reduce number of operations. c +c coefficient G(L1,L2,L3) only nonzero if c +c a) l1 + l2 + l3 = even c +c b) |l2-l3| <= l1 <= l2+l3 c +c c) m1 = m2 + m3 c +c*********************************************************c + +! lo-lo + DO lop=1,nlo(ntyp) + lp = llo(lop,ntyp) + DO mp=-lp,lp + DO ltil1=0,lwn + lltil1 = ltil1*(ltil1+1) + DO mtil1=-ltil1,ltil1 + lmtil1 = lltil1+mtil1 + mmin = max(-ltil1,mtil1-1) + mmax = min( ltil1,mtil1+1) + mjj1=mtil1-mp + DO ljj1=0,lwn + lljj1 = ljj1 * (ljj1 + 1) + lmjj1 = lljj1 + mjj1 + lmini = abs(lp-ljj1) + lmaxi = lp+ljj1 + ! Gaunt conditions (G1): + if((lmini.gt.ltil1).or.(lmaxi.lt.ltil1).or. + > (mod(lp+ltil1+ljj1,2).ne.0).or. + > (abs(mjj1).gt.ljj1)) cycle + + gc1 = gaunt1(ltil1, ljj1, lp, + > mtil1, mjj1, mp, lmaxd) + + DO lo=1,nlo(ntyp) + l = llo(lo,ntyp) + DO m=-l,l + DO mtil2=mmin,mmax ! mtil1-1 <= mtil2 <= mtil1+1 + lmtil2 = lltil1+mtil2 + mjj2=m-mtil2 + DO ljj2=0,lwn + lljj2 = ljj2 * (ljj2 + 1) + lmjj2 = lljj2 + mjj2 + lmini2 = abs(ltil1-ljj2) + lmaxi2 = ltil1+ljj2 + ! Gaunt conditions (G2): + if((lmini2.gt.l).or.(lmaxi2.lt.l).or. + > (mod(l+ltil1+ljj2,2).ne.0).or. + > (abs(mjj2).gt.ljj2)) cycle + + gc2 = gaunt1( l, ljj2, ltil1, + > m, mjj2, mtil2, lmaxd) + + ! set up prefactor + cil = ( ci ** (lp - l + ljj1 + ljj2) ) + + *( (-1.0) ** ljj1 ) + + * gc1 * gc2 + + * conjg( yl1(lmjj1 + 1) ) + + * conjg( yl2(lmjj2 + 1) ) + + * conjg( angso(lmtil1,lmtil2) ) + + ! compute T-coefficients + tuloulo(lo, m, lop, mp) = tuloulo(lo, m, lop, mp) + > + cil * ulovulo(ltil1, ljj2, ljj1, lo, lop) + + ENDDO!ljj2 + ENDDO!m + ENDDO!l + ENDDO!mtil2 + ENDDO!ljj1 + ENDDO!mp + ENDDO!lp + ENDDO!mtil1 + ENDDO!ltil1 + +! apw-lo + DO lop=1,nlo(ntyp) + lp = llo(lop,ntyp) + DO mp=-lp,lp + DO ltil1=0,lwn + lltil1 = ltil1*(ltil1+1) + DO mtil1=-ltil1,ltil1 + lmtil1 = lltil1+mtil1 + mmin = max(-ltil1,mtil1-1) + mmax = min( ltil1,mtil1+1) + mjj1=mtil1-mp + DO ljj1=0,lwn + lljj1 = ljj1 * (ljj1 + 1) + lmjj1 = lljj1 + mjj1 + lmini = abs(lp-ljj1) + lmaxi = lp+ljj1 + ! Gaunt conditions (G1): + if((lmini.gt.ltil1).or.(lmaxi.lt.ltil1).or. + > (mod(lp+ltil1+ljj1,2).ne.0).or. + > (abs(mjj1).gt.ljj1)) cycle + + gc1 = gaunt1(ltil1, ljj1, lp, + > mtil1, mjj1, mp, lmaxd) + + DO mtil2=mmin,mmax ! mtil1-1 <= mtil2 <= mtil1+1 + lmtil2 = lltil1+mtil2 + DO l=0,lwn + ll = l*(l+1) + DO m=-l,l + lm = ll+m + mjj2=m-mtil2 + DO ljj2=0,lwn + lljj2 = ljj2 * (ljj2 + 1) + lmjj2 = lljj2 + mjj2 + lmini2 = abs(ltil1-ljj2) + lmaxi2 = ltil1+ljj2 + ! Gaunt conditions (G2): + if((lmini2.gt.l).or.(lmaxi2.lt.l).or. + > (mod(l+ltil1+ljj2,2).ne.0).or. + > (abs(mjj2).gt.ljj2)) cycle + + gc2 = gaunt1( l, ljj2, ltil1, + > m, mjj2, mtil2, lmaxd) + + ! set up prefactor + cil = ( ci ** (lp - l + ljj1 + ljj2) ) + + *( (-1.0) ** ljj1 ) + + * gc1 * gc2 + + * conjg( yl1(lmjj1 + 1) ) + + * conjg( yl2(lmjj2 + 1) ) + + * conjg( angso(lmtil1,lmtil2) ) + + ! compute T-coefficients + tulou(lm, lop, mp) = tulou(lm, lop, mp) + > + cil * ulovu(ltil1, l, ljj2, ljj1, lop) + + tulod(lm, lop, mp) = tulod(lm, lop, mp) + > + cil * ulovd(ltil1, l, ljj2, ljj1, lop) + + ENDDO!ljj2 + ENDDO!m + ENDDO!l + ENDDO!mtil2 + ENDDO!ljj1 + ENDDO!mp + ENDDO!lp + ENDDO!mtil1 + ENDDO!ltil1 + + + DO l=0,lwn + ll = l*(l+1) + DO m=-l,l + lm = ll+m + DO ltil1=0,lwn + lltil1 = ltil1*(ltil1+1) + DO mtil1=-ltil1,ltil1 + lmtil1 = lltil1+mtil1 + mmin = max(-ltil1,mtil1-1) + mmax = min( ltil1,mtil1+1) + mjj1=mtil1-m + DO ljj1=0,lwn + lljj1 = ljj1 * (ljj1 + 1) + lmjj1 = lljj1 + mjj1 + lmini = abs(l-ljj1) + lmaxi = l+ljj1 + ! Gaunt conditions (G1): + if((lmini.gt.ltil1).or.(lmaxi.lt.ltil1).or. + > (mod(l+ltil1+ljj1,2).ne.0).or. + > (abs(mjj1).gt.ljj1)) cycle + + gc1 = gaunt1(ltil1, ljj1, l, + > mtil1, mjj1, m, lmaxd) + + DO mtil2=mmin,mmax ! mtil1-1 <= mtil2 <= mtil1+1 + lmtil2 = lltil1+mtil2 + DO lop=1,nlo(ntyp) + lp = llo(lop,ntyp) + DO mp=-lp,lp + mjj2=mp-mtil2 + DO ljj2=0,lwn + lljj2 = ljj2 * (ljj2 + 1) + lmjj2 = lljj2 + mjj2 + lmini2 = abs(ltil1-ljj2) + lmaxi2 = ltil1+ljj2 + ! Gaunt conditions (G2): + if((lmini2.gt.lp).or.(lmaxi2.lt.lp).or. + > (mod(lp+ltil1+ljj2,2).ne.0).or. + > (abs(mjj2).gt.ljj2)) cycle + + gc2 = gaunt1( lp, ljj2, ltil1, + > mp, mjj2, mtil2, lmaxd) + + ! set up prefactor + cil = ( ci ** (l - lp + ljj1 + ljj2) ) + + *( (-1.0) ** ljj1 ) + + * gc1 * gc2 + + * conjg( yl1(lmjj1 + 1) ) + + * conjg( yl2(lmjj2 + 1) ) + + * conjg( angso(lmtil1,lmtil2) ) + + ! compute T-coefficients + tuulo(lm, lop, mp) = tuulo(lm, lop, mp) + > + cil * uvulo(ltil1, l, ljj2, ljj1, lop) + + tdulo(lm, lop, mp) = tdulo(lm, lop, mp) + > + cil * dvulo(ltil1, l, ljj2, ljj1, lop) + + ENDDO!ljj2 + ENDDO!m + ENDDO!l + ENDDO!mtil2 + ENDDO!ljj1 + ENDDO!mp + ENDDO!lp + ENDDO!mtil1 + ENDDO!ltil1 + +#if (defined(CPP_MPI) && !defined(CPP_T90)) + CALL MPI_BARRIER(MPI_COMM_WORLD,ierr) +#endif + + deallocate( ulovulo ) + deallocate( uvulo, dvulo, ulovu, ulovd ) + deallocate( plo,plo_b ) + deallocate( x ) + deallocate( v0, vso ) + + END SUBROUTINE wann_uHu_soc_tlo + END MODULE m_wann_uHu_soc_tlo diff --git a/wannier/uhu/wann_uHu_sph.F b/wannier/uhu/wann_uHu_sph.F new file mode 100644 index 00000000..1f3ddf2f --- /dev/null +++ b/wannier/uhu/wann_uHu_sph.F @@ -0,0 +1,234 @@ +c****************************************c +c Muffin tin contribution to uHu c +c < u_{k+b1} | H_{k}^{mt} | u_{k+b2} > c +c****************************************c +c Use T(lmp,lm) calculated before for c +c every pair (b1,b2) and all atoms n c +c c +c acof ,bcof ,ccof : coefficients c +c at k+b1 c +c acof_b,bcof_b,ccof_b: coefficients c +c at k+b2 c +c c +c bkpt : k-point c +c bkpt_b : (k+b1)-point c +c bkpt_b2: (k+b2)-point c +c****************************************c +c J.-P. Hanke, Dec. 2015 c +c****************************************c + MODULE m_wann_uHu_sph + contains + subroutine wann_uHu_sph( + > chi,nbnd,llod,nslibd,nslibd_b,nlod,natd,ntypd,lmd,jmtd, + > taual,nop,lmax, + > ntype,neq,nlo,llo,acof,bcof,ccof,bkpt_b2, + > acof_b,bcof_b,ccof_b,bkpt_b,bkpt,gb_b,gb_b2, + > tuu,tud,tdu,tdd,tuulo,tulou,tdulo,tulod,tuloulo, + > kdiff,kdiff2,nntot,nntot2,uHu) +#include "cpp_double.h" + USE m_fleurenv + use m_constants, only : pimach + use m_matmul , only : matmul3,matmul3r + use m_cotra + + implicit none + +c .. scalar arguments .. + integer, intent (in) :: llod,nlod,natd,ntypd,lmd,nbnd + integer, intent (in) :: nntot,nntot2 + integer, intent (in) :: ntype,nslibd,nslibd_b,nop,jmtd + complex, intent (in) :: chi + +c .. array arguments .. + integer, intent (in) :: neq(:) !(ntypd) + integer, intent (in) :: lmax(:) !(ntypd) + integer, intent (in) :: nlo(:) !(ntypd) + integer, intent (in) :: llo(:,:) !(nlod,ntypd) + real, intent (in) :: bkpt_b(:) !(3) + real, intent (in) :: bkpt_b2(:) !(3) + real, intent (in) :: taual(:,:) !(3,natd) + real, intent (in) :: bkpt(:) !(3) + integer, intent (in) :: gb_b(:) !(3) + integer, intent (in) :: gb_b2(:) !(3) + complex, intent (in) :: ccof(-llod:,:,:,:) !(-llod:llod,nslibd,nlod,natd) + complex, intent (in) :: acof(:,0:,:) !(nslibd,0:lmd,natd) + complex, intent (in) :: bcof(:,0:,:) !(nslibd,0:lmd,natd) + complex, intent (in) :: ccof_b(-llod:,:,:,:) !(-llod:llod,nslibd_b,nlod,natd) + complex, intent (in) :: acof_b(:,0:,:) !(nslibd_b,0:lmd,natd) + complex, intent (in) :: bcof_b(:,0:,:) !(nslibd_b,0:lmd,natd) + + complex, intent (in) :: tuu(0:,0:,:,:) + complex, intent (in) :: tud(0:,0:,:,:) + complex, intent (in) :: tdu(0:,0:,:,:) + complex, intent (in) :: tdd(0:,0:,:,:) + complex, intent (in) :: tuulo(0:,:,-llod:,:,:) + complex, intent (in) :: tulou(0:,:,-llod:,:,:) + complex, intent (in) :: tdulo(0:,:,-llod:,:,:) + complex, intent (in) :: tulod(0:,:,-llod:,:,:) + complex, intent (in) :: tuloulo(:,-llod:,:,-llod:,:,:) + + real, intent (in) :: kdiff(:,:),kdiff2(:,:) + complex,intent(inout) :: uHu(:,:) + + +c .. local scalars .. + integer i,lm,nn,n,na,j,lmp,l,lp,m,mp,lwn,lo,lop + integer ll,llp,lmd2 + real rph,cph,tpi,sqpi16,th,t1nn,t2nn,t3nn + integer nene,nene2,indexx + complex :: fac1,fac2,fac3,fac4 + complex :: mat(0:lmd,nslibd_b) +C .. +C .. local arrays .. + real bpt(3) + real bpt2(3) + +C .. +C .. intrinsic functions .. + intrinsic conjg,cmplx,sqrt,cos,sin + + tpi = 2* pimach() + sqpi16 = 4*tpi*tpi + lmd2 = lmd+1 + + na = 0 + + ! find neighbor k+b1 + bpt(:) = bkpt_b(:) + gb_b(:) - bkpt(:) + do nene=1,nntot + if(all(abs(bpt(:)-kdiff(:,nene)).lt.1e-4)) exit + enddo + IF(nene==nntot+1) CALL fleur_err + + ("cannot find matching nearest neighbor k+b1",calledby + + ="wann_uHu_sph") + + ! find neighbor k+b2 + bpt2(:) = bkpt_b2(:) + gb_b2(:) - bkpt(:) + do nene2=1,nntot2 + if(all(abs(bpt2(:)-kdiff2(:,nene2)).lt.1e-4)) exit + enddo + IF(nene2==nntot2+1) CALL fleur_err + + ("cannot find matching nearest neighbor k+b2",calledby + + ="wann_uHu_sph") + + indexx=nene2+(nene-1)*nntot2 + +c if(nene2.ne.1) stop 'nene2.ne.1' +c if(indexx.ne.nene) stop 'nene.ne.indexx' +c if(ANY(bpt2.ne.0.0)) stop 'bpt2.ne.0' + + do n=1,ntype + lwn = lmax(n) + do nn = 1,neq(n) ! cycle by the atoms within the atom type + na = na + 1 +c...set up phase factors ( 4pi e^{ib2\tau} 4pi e^{-ib1\tau} ) + + t1nn = tpi*taual(1,na) + t2nn = tpi*taual(2,na) + t3nn = tpi*taual(3,na) + + th = (bpt2(1)-bpt(1))*t1nn + > +(bpt2(2)-bpt(2))*t2nn + > +(bpt2(3)-bpt(3))*t3nn + rph = sqpi16*cos(th) + cph = sqpi16*sin(th) + + +c...apw-apw + call CPP_BLAS_cgemm('T','C',lmd2,nslibd_b,lmd2,cmplx(rph,cph), + > tuu(0,0,n,indexx),lmd2, + > acof_b(1,0,na),nslibd_b, + > cmplx(0.0),mat(0,1),lmd2) + call CPP_BLAS_cgemm('N','N',nslibd,nslibd_b,lmd2,chi, + > acof(1,0,na),nslibd,mat(0,1),lmd2, + > cmplx(1.0),uHu,nbnd) + + call CPP_BLAS_cgemm('T','C',lmd2,nslibd_b,lmd2,cmplx(rph,cph), + > tud(0,0,n,indexx),lmd2, + > bcof_b(1,0,na),nslibd_b, + > cmplx(0.0),mat(0,1),lmd2) + call CPP_BLAS_cgemm('N','N',nslibd,nslibd_b,lmd2,chi, + > acof(1,0,na),nslibd,mat(0,1),lmd2, + > cmplx(1.0),uHu,nbnd) + + call CPP_BLAS_cgemm('T','C',lmd2,nslibd_b,lmd2,cmplx(rph,cph), + > tdu(0,0,n,indexx),lmd2, + > acof_b(1,0,na),nslibd_b, + > cmplx(0.0),mat(0,1),lmd2) + call CPP_BLAS_cgemm('N','N',nslibd,nslibd_b,lmd2,chi, + > bcof(1,0,na),nslibd,mat(0,1),lmd2, + > cmplx(1.0),uHu,nbnd) + + call CPP_BLAS_cgemm('T','C',lmd2,nslibd_b,lmd2,cmplx(rph,cph), + > tdd(0,0,n,indexx),lmd2, + > bcof_b(1,0,na),nslibd_b, + > cmplx(0.0),mat(0,1),lmd2) + call CPP_BLAS_cgemm('N','N',nslibd,nslibd_b,lmd2,chi, + > bcof(1,0,na),nslibd,mat(0,1),lmd2, + > cmplx(1.0),uHu,nbnd) + + if(nlo(n).ge.1) then + +c...apw-lo + do lo = 1,nlo(n) + l = llo(lo,n) + do m = -l, l + + do lp = 0, lwn + llp = lp*(lp+1) + do mp = -lp, lp + lmp = llp + mp + + fac1=cmplx(rph,cph)*tulou(lmp,lo,m,n,indexx)*chi + fac2=cmplx(rph,cph)*tulod(lmp,lo,m,n,indexx)*chi + fac3=cmplx(rph,cph)*tuulo(lmp,lo,m,n,indexx)*chi + fac4=cmplx(rph,cph)*tdulo(lmp,lo,m,n,indexx)*chi + + do i = 1,nslibd + do j = 1,nslibd_b + uHu(i,j) = uHu(i,j) + > + ccof(m,i,lo,na)* fac1 *conjg(acof_b(j,lmp,na)) + > + ccof(m,i,lo,na)* fac2 *conjg(bcof_b(j,lmp,na)) + > + acof(i,lmp,na) * fac3 *conjg(ccof_b(m,j,lo,na)) + > + bcof(i,lmp,na) * fac4 *conjg(ccof_b(m,j,lo,na)) + enddo + enddo + + enddo !mp + enddo !lp + + enddo ! m + enddo ! lo + +c...lo-lo + do lo = 1,nlo(n) + l = llo(lo,n) + do m = -l, l + + do lop = 1,nlo(n) + lp = llo(lop,n) + do mp = -lp, lp + + fac1=cmplx(rph,cph)*tuloulo(lop,mp,lo,m,n,indexx)*chi + + do i = 1,nslibd + do j = 1,nslibd_b + uHu(i,j) = uHu(i,j) + > + ccof(m,i,lo,na)*fac1*conjg(ccof_b(mp,j,lop,na)) + enddo + enddo + + enddo !mp + enddo !lop + + enddo ! m + enddo ! lo + + endif !(nlo(n).ge.1) + + enddo ! atoms in the type + + enddo ! atom type + + end subroutine wann_uHu_sph + end module m_wann_uHu_sph diff --git a/wannier/uhu/wann_uHu_symcheck.F b/wannier/uhu/wann_uHu_symcheck.F new file mode 100644 index 00000000..93b4d35f --- /dev/null +++ b/wannier/uhu/wann_uHu_symcheck.F @@ -0,0 +1,71 @@ +c*********************************************c +c Check whether uHu matrix is Hermitian c +c*********************************************c +c J.-P. Hanke, Dec. 2015 c +c*********************************************c + module m_wann_uHu_symcheck + contains + subroutine wann_uHu_symcheck(uHu,nbnd,nntot,nntot2,fullnkpts) + use m_fleurenv + implicit none + integer,intent(in) :: nbnd,nntot,nntot2,fullnkpts + complex,intent(in) :: uHu(nbnd,nbnd,nntot2,nntot,fullnkpts) + + logical :: l_check,l_fdiag,l_foffd + integer :: i,j,ikpt,ikpt_b,ikpt_b2 + integer :: maxi,maxj,maxb1,maxb2,maxk + real :: eps,diff,maxdiff + + eps = 1.e-10 + l_check = .true. + l_fdiag = .false. + l_foffd = .false. + maxdiff = 0.0 + + open(999,file='out_symcheck') + + do ikpt=1,fullnkpts + do ikpt_b=1,nntot + do ikpt_b2=1,nntot2 + do i=1,nbnd + do j=1,i + diff= abs(uHu(j,i,ikpt_b2,ikpt_b,ikpt) + > -conjg(uHu(i,j,ikpt_b,ikpt_b2,ikpt))) + if(diff.gt.eps) then + write(999,'(5i7)')j,i,ikpt_b2,ikpt_b,ikpt + write(999,'(4f16.10)') + > uHu(j,i,ikpt_b2,ikpt_b,ikpt),diff, + > diff/abs(uHu(j,i,ikpt_b2,ikpt_b,ikpt))*100.0 + if(diff.gt.maxdiff) then + maxj = j + maxi = i + maxb2= ikpt_b2 + maxb1= ikpt_b + maxk = ikpt + maxdiff=diff + endif + l_check = .false. + if(i.eq.j .and. ikpt_b.eq.ikpt_b2) then + l_fdiag=.true. + else + l_foffd=.true. + endif + endif + enddo + enddo + enddo + enddo + enddo + close(999) + + if(l_check)write(*,*)'*** uHu_symcheck: fine ***' + if(.not. l_check) then + write(*,*)'*** uHu_symcheck: problem ***' + if(l_fdiag) write(*,*)' --> fail on diagonal' + if(l_foffd) write(*,*)' --> fail on off-diag' + write(*,*)' maxdiff:',maxdiff + write(*,'(a,5(i8,1x))')' index: ',maxj,maxi,maxb2,maxb1,maxk + endif + + end subroutine wann_uHu_symcheck + end module m_wann_uHu_symcheck diff --git a/wannier/uhu/wann_uHu_tlmplm.F b/wannier/uhu/wann_uHu_tlmplm.F new file mode 100644 index 00000000..13f03890 --- /dev/null +++ b/wannier/uhu/wann_uHu_tlmplm.F @@ -0,0 +1,779 @@ +c****************************************c +c Muffin tin contribution to uHu c +c < u_{k+b1} | H_{k}^{mt} | u_{k+b2} > c +c****************************************c +c Routine to set up T(lm,lmp) for all c +c pairs (b1,b2) and every atom n c +c c +c Includes spherical and non-sph. c +c contributions to Hamiltonian: c +c H^{mt} ~ H^{sph} + H^{non-sph} c +c c +c possible SOC contribution is dealt c +c with in a separate routine c +c****************************************c +c J.-P. Hanke, Dec. 2015 c +c****************************************c + MODULE m_wann_uHu_tlmplm + CONTAINS + SUBROUTINE wann_uHu_tlmplm( + > memd,nlhd,ntypsd,ntypd,jmtd,lmaxd,jspd, + > ntype,dx,rmsh,jri,lmax,ntypsy,natd, + > lnonsph,lmd,lmplmd,clnu,mlh,nmem,llh,nlh,neq, + > irank,mlotot,mlolotot, + > vr,nlod,llod,loplod,ello,llo,nlo,lo1l,l_dulo, + > ulo_der,f,g,flo,f_b,g_b,flo_b, + > kdiff,kdiff2,nntot,nntot2,bmat,bbmat,vr0,epar, + > invsat, + > l_skip_sph,l_skip_non,l_skip_loc, + < tuu,tud,tdu,tdd,tuulo,tulou,tdulo,tulod,tuloulo) + + USE m_intgr, ONLY : intgr3 + USE m_radflo + USE m_radfun + USE m_tlo + USE m_sphbes + USE m_dotir + USE m_ylm + USE m_cotra + USE m_gaunt, ONLY: gaunt1 + USE m_dujdr + USE m_wann_uHu_radintsra5 + USE m_wann_uHu_radintsra3 + USE m_wann_uHu_tlo + USE m_constants, ONLY : pimach + + IMPLICIT NONE +C .. +C .. Scalar Arguments .. + INTEGER, INTENT (IN) :: memd,nlhd,ntypsd,ntypd,jmtd,lmaxd,jspd + INTEGER, INTENT (IN) :: lmd,lmplmd,ntype,irank + INTEGER, INTENT (IN) :: nlod,llod,loplod,natd,mlotot,mlolotot + INTEGER, INTENT (IN) :: nntot,nntot2 + LOGICAL, INTENT (IN) :: l_skip_sph,l_skip_non,l_skip_loc +C .. +C .. Array Arguments .. + COMPLEX, INTENT (OUT):: + > tdd(0:lmd,0:lmd,ntypd,nntot*nntot2), + > tdu(0:lmd,0:lmd,ntypd,nntot*nntot2), + > tud(0:lmd,0:lmd,ntypd,nntot*nntot2), + > tuu(0:lmd,0:lmd,ntypd,nntot*nntot2) + COMPLEX, INTENT (OUT):: + > tdulo(0:lmd,nlod,-llod:llod,ntypd,nntot*nntot2), + > tuulo(0:lmd,nlod,-llod:llod,ntypd,nntot*nntot2), + > tulou(0:lmd,nlod,-llod:llod,ntypd,nntot*nntot2), + > tulod(0:lmd,nlod,-llod:llod,ntypd,nntot*nntot2), + > tuloulo(nlod,-llod:llod,nlod,-llod:llod,ntypd,nntot*nntot2) + COMPLEX, INTENT (IN) :: clnu(memd,0:nlhd,ntypsd) + INTEGER, INTENT (IN) :: llo(nlod,ntypd),nlo(ntypd) + INTEGER, INTENT (IN) :: lo1l(0:llod,ntypd),neq(ntypd) + INTEGER, INTENT (IN) :: mlh(memd,0:nlhd,ntypsd),nlh(ntypsd) + INTEGER, INTENT (IN) :: nmem(0:nlhd,ntypsd),llh(0:nlhd,ntypsd) + INTEGER, INTENT (IN) :: jri(ntypd),lmax(ntypd),ntypsy(natd) + INTEGER, INTENT (IN) :: lnonsph(ntypd),ulo_der(nlod,ntypd) + INTEGER, INTENT (IN) :: invsat(natd) + REAL, INTENT (IN) :: dx(ntypd),rmsh(jmtd,ntypd) + REAL, INTENT (IN) :: vr(jmtd,0:nlhd,ntypd) + REAL, INTENT (IN) :: ello(nlod,ntypd) + REAL, INTENT (IN) :: epar(0:lmaxd,ntypd) + REAL, INTENT (IN) :: vr0(jmtd,ntypd) + REAL, INTENT (IN) :: f (ntypd,jmtd,2,0:lmaxd), + > g (ntypd,jmtd,2,0:lmaxd), + > f_b(ntypd,jmtd,2,0:lmaxd), + > g_b(ntypd,jmtd,2,0:lmaxd), + > flo (ntypd,jmtd,2,nlod), + > flo_b(ntypd,jmtd,2,nlod) + REAL, INTENT (IN) :: bmat(3,3),bbmat(3,3) + REAL, INTENT (IN) :: kdiff (3,nntot) + REAL, INTENT (IN) :: kdiff2(3,nntot2) + LOGICAL, INTENT (IN) :: l_dulo(nlod,ntypd) +C .. +C .. Local Scalars .. + COMPLEX cil,ci,cci,cil1,fac1,fac2,fac3,cilp,cciljj1,ciljj2 + INTEGER i,l,l2,lamda,lh,lm,lmin,lmp,lp + INTEGER lp1,lpl,m,mem,mems,mp,mu,n,nh,noded,nodeu,nrec,nsym,na,ne + INTEGER ljj1,ljj2,mjj1,mjj2,lo,lop + INTEGER ltil1,ltil2,mtil1,mtil2 + INTEGER mlo, mlolo, iu + INTEGER :: lmini,lmini2,lmini3 + INTEGER :: lmaxi,lmaxi2,lmaxi3 + INTEGER :: lmx,lmx2,lmx3 + INTEGER :: ll,llp,lljj1,lljj2,lmjj1,lmjj2 + INTEGER :: ikpt_b,ikpt_b2 + INTEGER :: lwn,indexx,indexx2 + REAL gs,rk1,rk2,sign + REAL gc1,gc2,gc3,invsfct,e,temp_val1,temp_val2 + REAL t1,t0,t_sphbes,t_ylm,t_radint,t_gggint,t_sphint,t_lo + REAL tt1,tt2,tt3,sy1,sy2 + LOGICAL :: l_nns,l_oldsym +C .. +C .. Local Arrays .. + COMPLEX, ALLOCATABLE :: yl1(:),yl2(:) + REAL, ALLOCATABLE :: dvd_non(:,:,:,:,:),dvu_non(:,:,:,:,:) + REAL, ALLOCATABLE :: uvd_non(:,:,:,:,:),uvu_non(:,:,:,:,:) + REAL, ALLOCATABLE :: dvd_sph(:,:,:,:,:),dvu_sph(:,:,:,:,:) + REAL, ALLOCATABLE :: uvd_sph(:,:,:,:,:),uvu_sph(:,:,:,:,:) + REAL, ALLOCATABLE :: p(:,:,:,:),p_b(:,:,:,:),dp_b(:,:,:,:) + REAL, ALLOCATABLE :: q(:,:,:,:),q_b(:,:,:,:),dq_b(:,:,:,:) + REAL, ALLOCATABLE :: dp(:,:,:,:),dq(:,:,:,:) + REAL, ALLOCATABLE :: x(:) + REAL, ALLOCATABLE :: jlpp(:),jj1(:,:),jj2(:,:) + REAL :: bpt(3),bpt2(3),bkrot(3) + +#if (defined(CPP_MPI) && !defined(CPP_T90)) + INCLUDE 'mpif.h' + INTEGER ierr(3) +#endif +C .. Intrinsic Functions .. + INTRINSIC abs,cmplx,max,mod +C .. + + l_oldsym=.false. + + sy1=1.0 + sy2=0.0 + if(l_oldsym) then + sy1=0.5 + sy2=0.5 + endif + + t_sphbes = 0. + t_ylm = 0. + t_radint = 0. + t_sphint = 0. + t_gggint = 0. + t_lo = 0. + tt1 = 0. + tt2 = 0. + tt3 = 0. + + ci = cmplx(0., 1.) + cci = cmplx(0.,-1.) + tdulo = cmplx(0.,0.); tuulo = cmplx(0.,0.); tuloulo = cmplx(0.,0.) + tuu = cmplx(0.,0.); tdu = cmplx(0.,0.) + tud = cmplx(0.,0.); tdd = cmplx(0.,0.) + + allocate( yl1((lmaxd+1)**2), yl2((lmaxd+1)**2) ) + allocate( dvd_non(1:nlhd,0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd) ) + allocate( dvu_non(1:nlhd,0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd) ) + allocate( uvd_non(1:nlhd,0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd) ) + allocate( uvu_non(1:nlhd,0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd) ) + allocate( dvd_sph(0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd) ) + allocate( dvu_sph(0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd) ) + allocate( uvd_sph(0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd) ) + allocate( uvu_sph(0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd) ) + allocate( p(jmtd,2,0:lmaxd,0:lmaxd), p_b(jmtd,2,0:lmaxd,0:lmaxd) ) + allocate( q(jmtd,2,0:lmaxd,0:lmaxd), q_b(jmtd,2,0:lmaxd,0:lmaxd) ) + allocate( dp(jmtd,2,0:lmaxd,0:lmaxd) ) + allocate( dp_b(jmtd,2,0:lmaxd,0:lmaxd) ) + allocate( dq(jmtd,2,0:lmaxd,0:lmaxd) ) + allocate( dq_b(jmtd,2,0:lmaxd,0:lmaxd) ) + allocate( x(jmtd) ) + allocate( jlpp(0:lmaxd), jj1(0:lmaxd,jmtd), jj2(0:lmaxd,jmtd) ) + +c***************************************c +c begin 1st neighbor loop: c +c***************************************c + do ikpt_b2=1,nntot2 + indexx = ikpt_b2 + (ikpt_b-1)*nntot2 + bpt2 = kdiff2(:,ikpt_b2) + rk2= sqrt(dotirp(bpt2,bpt2,bbmat)) + + na = 1 + mlo = 1 ; mlolo = 1 + + ! loop over atoms + DO 210 n = 1,ntype + lwn = lmax(n) + nsym = ntypsy(na) + nh = nlh(nsym) + + l_nns = l_skip_non .OR. (lnonsph(n).LT.0) .OR. + > ( (invsat(na).ne.0).and.(invsat(na).ne.1) ) + if(invsat(na).eq.0) invsfct = 1.0 + if(invsat(na).eq.1) invsfct = 2.0 + if(indexx.eq.1 .and. irank.eq.0) write(*,*)'invsfct=',invsfct + + ! set up spherical Bessel functions + ! jj1(l,b1*r) and jj2(l,b2*r) + call cpu_time(t0) + do i=1,jri(n) + gs = rk1*rmsh(i,n) + call sphbes(lwn,gs,jlpp) + jj1(:,i) = jlpp(:) + + gs = rk2*rmsh(i,n) + call sphbes(lwn,gs,jlpp) + jj2(:,i) = jlpp(:) + enddo + call cpu_time(t1) + t_sphbes=t_sphbes + t1-t0 + + ! set up spherical harmonics + ! yl1(lm) for b1 and yl2(lm) for b2 + yl1 = cmplx(0.,0.) + call cotra3(bpt,bkrot,bmat) + call ylm4(lwn,bkrot,yl1) + + yl2 = cmplx(0.,0.) + call cotra3(bpt2,bkrot,bmat) + call ylm4(lwn,bkrot,yl2) + + call cpu_time(t0) + t_ylm=t_ylm + t0-t1 + + ! set up products of radial functions and sph. Bessel + DO ljj1 = 0, lwn + DO l = 0, lwn + DO i=1,jri(n) + p(i,:,l,ljj1) = f(n,i,:,l)*jj1(ljj1,i) + q(i,:,l,ljj1) = g(n,i,:,l)*jj1(ljj1,i) + p_b(i,:,l,ljj1) = f_b(n,i,:,l)*jj2(ljj1,i) + q_b(i,:,l,ljj1) = g_b(n,i,:,l)*jj2(ljj1,i) + ENDDO + CALL dujdr(jmtd,jri(n),rmsh(1,n),dx(n),f(n,:,:,l), + > jj1,rk1,ljj1,lmaxd,dp(:,:,l,ljj1)) + CALL dujdr(jmtd,jri(n),rmsh(1,n),dx(n),g(n,:,:,l), + > jj1,rk1,ljj1,lmaxd,dq(:,:,l,ljj1)) + CALL dujdr(jmtd,jri(n),rmsh(1,n),dx(n),f_b(n,:,:,l), + > jj2,rk2,ljj1,lmaxd,dp_b(:,:,l,ljj1)) + CALL dujdr(jmtd,jri(n),rmsh(1,n),dx(n),g_b(n,:,:,l), + > jj2,rk2,ljj1,lmaxd,dq_b(:,:,l,ljj1)) + ENDDO + ENDDO + +c****************************************************c +c compute radial integrals c +c c +c where v(lamda,nu) ~ V^{sph} + V^{non-sph} c +c****************************************************c + ! spherical part + IF(.not.l_skip_sph) THEN + uvu_sph = 0. + uvd_sph = 0. + dvu_sph = 0. + dvd_sph = 0. + DO ljj1 = 0, lwn + DO lp = 0, lwn + lmini = abs(lp-ljj1) + lmaxi = lp+ljj1 + lmx = min(lmaxi,lwn) + DO lh=lmini,lmx + if(mod(lmaxi+lh,2).eq.1) cycle + DO ljj2 = 0, lwn + lmini2= abs(lh-ljj2) + lmaxi2= lh+ljj2 + lmx2 = min(lmaxi2,lwn) + DO l = lmini2, lmx2 + if(mod(lmaxi2+l,2).eq.1) cycle + e = (epar(l,n)+epar(lp,n))/2.0!epar(lh,n) + if(.not.l_oldsym) then + call wann_uHu_radintsra5(jmtd,jri(n),rmsh(1,n),dx(n), + > e,vr0(1,n),p(:,:,lp,ljj1),p_b(:,:,l,ljj2), + > dp(:,:,lp,ljj1),dp_b(:,:,l,ljj2),lmaxd,lh, + > uvu_sph(lh,l,lp,ljj2,ljj1),irank) + + call wann_uHu_radintsra5(jmtd,jri(n),rmsh(1,n),dx(n), + > e,vr0(1,n),p(:,:,lp,ljj1),q_b(:,:,l,ljj2), + > dp(:,:,lp,ljj1),dq_b(:,:,l,ljj2),lmaxd,lh, + > uvd_sph(lh,l,lp,ljj2,ljj1),irank) + + call wann_uHu_radintsra5(jmtd,jri(n),rmsh(1,n),dx(n), + > e,vr0(1,n),q(:,:,lp,ljj1),p_b(:,:,l,ljj2), + > dq(:,:,lp,ljj1),dp_b(:,:,l,ljj2),lmaxd,lh, + > dvu_sph(lh,l,lp,ljj2,ljj1),irank) + + call wann_uHu_radintsra5(jmtd,jri(n),rmsh(1,n),dx(n), + > e,vr0(1,n),q(:,:,lp,ljj1),q_b(:,:,l,ljj2), + > dq(:,:,lp,ljj1),dq_b(:,:,l,ljj2),lmaxd,lh, + > dvd_sph(lh,l,lp,ljj2,ljj1),irank) + + else + + e = epar(l,n)!( epar(l,n) + epar(lp,n) )/2.0 + call wann_uHu_radintsra3(jmtd,jri(n),rmsh(1,n),dx(n), + > e,vr0(1,n),p(:,:,lp,ljj1),p_b(:,:,l,ljj2), + > dp_b(:,:,l,ljj2),lmaxd,lh,uvu_sph(lh,l,lp,ljj2,ljj1)) + + call wann_uHu_radintsra3(jmtd,jri(n),rmsh(1,n),dx(n), + > e,vr0(1,n),p(:,:,lp,ljj1),q_b(:,:,l,ljj2), + > dq_b(:,:,l,ljj2),lmaxd,lh,uvd_sph(lh,l,lp,ljj2,ljj1)) + + call wann_uHu_radintsra3(jmtd,jri(n),rmsh(1,n),dx(n), + > e,vr0(1,n),q(:,:,lp,ljj1),p_b(:,:,l,ljj2), + > dp_b(:,:,l,ljj2),lmaxd,lh,dvu_sph(lh,l,lp,ljj2,ljj1)) + + call wann_uHu_radintsra3(jmtd,jri(n),rmsh(1,n),dx(n), + > e,vr0(1,n),q(:,:,lp,ljj1),q_b(:,:,l,ljj2), + > dq_b(:,:,l,ljj2),lmaxd,lh,dvd_sph(lh,l,lp,ljj2,ljj1)) + endif + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + + if(.false. .and. (irank.eq.0)) then + DO ljj1=0,lwn + DO ljj2=0,lwn + DO lp=0,lwn + DO l=0,lwn + DO lh=0,lwn + if(abs(uvu_sph(lh,l,lp,ljj2,ljj1)- + > uvu_sph(lh,lp,l,ljj1,ljj2)).gt.1e-10) then + write(*,*)'uvu',ikpt_b,ikpt_b2,n + write(*,*)'bpt',bpt + write(*,*)'bpt2',bpt2 + write(*,*)ljj1,ljj2,lp,l,lh + write(*,*)uvu_sph(lh,l,lp,ljj2,ljj1) + write(*,*)uvu_sph(lh,lp,l,ljj1,ljj2) + endif + if(abs(dvd_sph(lh,l,lp,ljj2,ljj1)- + > dvd_sph(lh,lp,l,ljj1,ljj2)).gt.1e-10) then + write(*,*)'dvd',ikpt_b,ikpt_b2,n + write(*,*)'bpt',bpt + write(*,*)'bpt2',bpt2 + write(*,*)ljj1,ljj2,lp,l,lh + write(*,*)dvd_sph(lh,l,lp,ljj2,ljj1) + write(*,*)dvd_sph(lh,lp,l,ljj1,ljj2) + endif + if(abs(dvu_sph(lh,l,lp,ljj2,ljj1)- + > uvd_sph(lh,lp,l,ljj1,ljj2)).gt.1e-10) then + write(*,*)'dvu',ikpt_b,ikpt_b2,n + write(*,*)'bpt',bpt + write(*,*)'bpt2',bpt2 + write(*,*)ljj1,ljj2,lp,l,lh + write(*,*)dvu_sph(lh,l,lp,ljj2,ljj1) + write(*,*)uvd_sph(lh,lp,l,ljj1,ljj2) + endif + if(abs(uvd_sph(lh,l,lp,ljj2,ljj1)- + > dvu_sph(lh,lp,l,ljj1,ljj2)).gt.1e-10) then + write(*,*)'uvd',ikpt_b,ikpt_b2,n + write(*,*)'bpt',bpt + write(*,*)'bpt2',bpt2 + write(*,*)ljj1,ljj2,lp,l,lh + write(*,*)uvd_sph(lh,l,lp,ljj2,ljj1) + write(*,*)dvu_sph(lh,lp,l,ljj1,ljj2) + goto 777 + endif + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + +777 continue + endif + + ENDIF + + + ! nonspherical part + IF(.not.l_nns) then + DO ljj1 = 0, lwn + DO ljj2 = 0, lwn + DO lp = 0, lwn + DO l = 0, lp +c DO l = 0, lwn + DO lh = 1, nh + DO i = 1,jri(n) + x(i) = ( p(i,1,lp,ljj1)*p_b(i,1,l,ljj2) + > + p(i,2,lp,ljj1)*p_b(i,2,l,ljj2) ) + > * vr(i,lh,n) + ENDDO + CALL intgr3(x(1:jri(n)),rmsh(1,n),dx(n),jri(n), + > uvu_non(lh,l,lp,ljj2,ljj1)) + DO i = 1,jri(n) + x(i) = ( q(i,1,lp,ljj1)*p_b(i,1,l,ljj2) + > + q(i,2,lp,ljj1)*p_b(i,2,l,ljj2) ) + > * vr(i,lh,n) + ENDDO + CALL intgr3(x(1:jri(n)),rmsh(1,n),dx(n),jri(n), + > dvu_non(lh,l,lp,ljj2,ljj1)) + DO i = 1,jri(n) + x(i) = ( p(i,1,lp,ljj1)*q_b(i,1,l,ljj2) + > + p(i,2,lp,ljj1)*q_b(i,2,l,ljj2) ) + > * vr(i,lh,n) + ENDDO + CALL intgr3(x(1:jri(n)),rmsh(1,n),dx(n),jri(n), + > uvd_non(lh,l,lp,ljj2,ljj1)) + DO i = 1,jri(n) + x(i) = ( q(i,1,lp,ljj1)*q_b(i,1,l,ljj2) + > + q(i,2,lp,ljj1)*q_b(i,2,l,ljj2) ) + > * vr(i,lh,n) + ENDDO + CALL intgr3(x(1:jri(n)),rmsh(1,n),dx(n),jri(n), + > dvd_non(lh,l,lp,ljj2,ljj1)) + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + + ! symmetry can be used if f=f_b and g=g_b + ! i.e. if jspin = jspin_b + DO lp=0,lwn + DO l=lp+1,lwn + uvu_non(:,l,lp,:,:) = uvu_non(:,lp,l,:,:) + dvd_non(:,l,lp,:,:) = dvd_non(:,lp,l,:,:) + uvd_non(:,l,lp,:,:) = dvu_non(:,lp,l,:,:) + dvu_non(:,l,lp,:,:) = uvd_non(:,lp,l,:,:) + ENDDO + ENDDO + ENDIF + + call cpu_time(t0) + t_radint = t_radint + t0-t1 + + tuu(:,:,n,indexx) = cmplx(0.,0.) + tdu(:,:,n,indexx) = cmplx(0.,0.) + tud(:,:,n,indexx) = cmplx(0.,0.) + tdd(:,:,n,indexx) = cmplx(0.,0.) + + if(l_skip_sph) GOTO 444 +c************** SPHERICAL CONTRIBUTION *******************c +c compute product of the two Gaunt coefficients c +c with the radial integrals (+prefactors) c +c*********************************************************c +c We deal with two Gaunt coefficients: c +c G1 = G( (ltil1,mtil1), (ljj1,mjj1) , ( lp, mp) ) c +c G2 = G( (l , m) , (ljj2, mjj2), (ltil1, mtil1) ) c +c*********************************************************c +c use Gaunt conditions to reduce number of operations. c +c coefficient G(L1,L2,L3) only nonzero if c +c a) l1 + l2 + l3 = even c +c b) |l2-l3| <= l1 <= l2+l3 c +c c) m1 = m2 + m3 c +c*********************************************************c + DO ljj1=0,lwn + lljj1 = ljj1 * (ljj1 + 1) + cciljj1 = cci**ljj1 + DO mjj1=-ljj1,ljj1 + lmjj1 = lljj1 + mjj1 + fac1 = cciljj1*conjg(yl1(lmjj1 + 1)) + if(fac1.eq.0.0) cycle + + DO lp=0,lwn + llp = lp*(lp+1) + lmini = abs(ljj1-lp) + lmaxi = ljj1+lp + lmx = min(lmaxi,lwn) + DO mp=-lp,lp + lmp = llp+mp + mtil1=mjj1+mp + IF(abs(mtil1).gt.lmx) cycle + + DO ltil1=lmini,lmx + ! Gaunt conditions (G1): + if((mod(lmaxi+ltil1,2).eq.1).or. + > (abs(mtil1).gt.ltil1)) cycle + + gc1 = gaunt1(ltil1, ljj1, lp, + > mtil1, mjj1, mp, lmaxd) + + cil1 = (ci**lp) * fac1 * gc1 + + DO ljj2=0,lwn + lljj2 = ljj2 * (ljj2 + 1) + lmini2 = abs(ltil1-ljj2) + lmaxi2 = ltil1+ljj2 + lmx2 = min(lmaxi2,lwn) + DO mjj2=-ljj2,ljj2 + lmjj2 = lljj2 + mjj2 + m=mjj2+mtil1 + IF(abs(m).gt.lmx2) cycle + + DO l=lmini2,lmx2 + ! Gaunt conditions (G2): + if((mod(lmaxi2+l,2).eq.1).or. + > (abs(m).gt.l)) cycle + ll = l*(l+1) + lm = ll+m + + gc2 = gaunt1( l, ljj2, ltil1, + > m, mjj2, mtil1, lmaxd) + + ! set up prefactor + cil = cil1* ( ci ** (ljj2 - l) ) + + * gc2 * conjg( yl2(lmjj2 + 1) ) + + if(cil.eq.0.0) cycle + + ! additional factor from symmetrization (below) +c cil = 0.5 * cil + + ! compute T-coefficients + ! using symmetrized uvu,uvd,dvu,dvd integrals + tuu(lm, lmp, n, indexx) + > = tuu(lm, lmp, n, indexx) + > + cil * ( sy1*uvu_sph(ltil1, l, lp, ljj2, ljj1) + > + sy2*uvu_sph(ltil1,lp, l, ljj1, ljj2) ) + + tdd(lm, lmp, n, indexx) + > = tdd(lm, lmp, n, indexx) + > + cil * ( sy1*dvd_sph(ltil1, l, lp, ljj2, ljj1) + > + sy2*dvd_sph(ltil1,lp, l, ljj1, ljj2) ) + + tud(lm, lmp, n, indexx) + > = tud(lm, lmp, n, indexx) + > + cil * ( sy1*uvd_sph(ltil1, l, lp, ljj2, ljj1) + > + sy2*dvu_sph(ltil1,lp, l, ljj1, ljj2) ) + + tdu(lm, lmp, n, indexx) + > = tdu(lm, lmp, n, indexx) + > + cil * ( sy1*dvu_sph(ltil1, l, lp, ljj2, ljj1) + > + sy2*uvd_sph(ltil1,lp, l, ljj1, ljj2) ) + ENDDO!ljj2 + ENDDO!m + ENDDO!l + ENDDO!ljj1 + ENDDO!mp + ENDDO!lp + ENDDO!mtil1 + ENDDO!ltil1 + + 444 CONTINUE + call cpu_time(t1) + t_sphint = t_sphint + t1-t0 + + IF( l_nns ) GOTO 555 +c************** NON-SPHERICAL CONTRIBUTION ***************c +c compute product of the three Gaunt coefficients c +c with the radial integrals (+prefactors) c +c*********************************************************c +c We deal with three Gaunt coefficients: c +c G1 = G( (ltil1,mtil1) , (lamda,mu) , (ltil2,mtil2) ) c +c G2 = G( (ltil1,mtil1) , (ljj1,mjj1) , (lp,mp) ) c +c G3 = G( (l,m) , (ljj2,mjj2) , (ltil2,mtil2) ) c +c*********************************************************c +c use Gaunt conditions to reduce number of operations. c +c coefficient G(L1,L2,L3) only nonzero if c +c a) l1 + l2 + l3 = even c +c b) |l2-l3| <= l1 <= l2+l3 c +c c) m1 = m2 + m3 c +c*********************************************************c + DO ltil2 = 0, lwn + DO mtil2 = -ltil2, ltil2 + DO lh = 1, nh + lamda = llh(lh,nsym) + lmini = abs(ltil2 - lamda) + lmaxi = ltil2 + lamda + lmx = min(lmaxi,lwn) + mems = nmem(lh,nsym) + DO mem = 1, mems + mu = mlh(mem,lh,nsym) + mtil1 = mtil2+mu + IF(abs(mtil1).GT.lmx) CYCLE + + DO ltil1 = lmini, lmx + + ! Gaunt conditions (G1): + if((mod(lmaxi+ltil1,2).eq.1).or. + > (abs(mtil1).gt.ltil1)) cycle + + gc1 = gaunt1(ltil1, lamda, ltil2, + > mtil1, mu, mtil2, lmaxd) + fac1 = conjg(clnu(mem,lh,nsym)) * gc1 * invsfct + if(fac1.eq.0.0) CYCLE + + DO lp = 0, lnonsph(n) + llp = lp * (lp + 1) + cilp = ci**lp + DO mp = -lp, lp + lmp = llp + mp + mjj1 = mtil1 - mp + IF(abs(mjj1).GT.lwn) CYCLE + + DO ljj1 = 0, lwn + lmini2 = abs(lp-ljj1) + lmaxi2 = lp+ljj1 + + ! Gaunt conditions (G2): + if((lmini2.gt.ltil1).or.(lmaxi2.lt.ltil1).or. + > (mod(lmaxi2+ltil1,2).eq.1).or. + > (abs(mjj1).gt.ljj1)) cycle + + lljj1 = ljj1 * (ljj1 + 1) + lmjj1 = lljj1 + mjj1 + + gc2 = gaunt1(ltil1, ljj1, lp, + > mtil1, mjj1, mp, lmaxd) + fac2 = fac1 * cilp * (cci**ljj1) * gc2 + > * conjg( yl1(lmjj1 + 1) ) + IF(fac2.eq.0.0) CYCLE + + DO ljj2 = 0, lwn + lljj2 = ljj2 * (ljj2 + 1) + ciljj2 = ci**ljj2 + lmini3 = abs(ltil2 - ljj2) + lmaxi3 = ltil2 + ljj2 + lmx3 = min(lmaxi3,lnonsph(n)) + DO mjj2 = -ljj2,ljj2 + m = mjj2+mtil2 + IF(abs(m).GT.lmx3) CYCLE + lmjj2 = lljj2 + mjj2 + fac3 = fac2 * ciljj2 * conjg(yl2(lmjj2 + 1)) + if(fac3.eq.0.0) CYCLE + + DO l = lmini3,lmx3 + + ! Gaunt conditions (G3): + if((mod(lmaxi3+l,2).eq.1).or. + > (abs(m).gt.l)) cycle + + ll = l * (l + 1) + lm = ll + m + + gc3 = gaunt1(l, ljj2, ltil2, + > m, mjj2, mtil2, lmaxd) + + ! set up prefactor + cil = fac3 * (cci**l) * gc3 + + ! compute T-coefficients + tuu(lm, lmp, n, indexx) + > = tuu(lm, lmp, n, indexx) + > + cil * uvu_non(lh, l, lp, ljj2, ljj1) + + tdd(lm, lmp, n, indexx) + > = tdd(lm, lmp, n, indexx) + > + cil * dvd_non(lh, l, lp, ljj2, ljj1) + + tud(lm, lmp, n, indexx) + > = tud(lm, lmp, n, indexx) + > + cil * uvd_non(lh, l, lp, ljj2, ljj1) + + tdu(lm, lmp, n, indexx) + > = tdu(lm, lmp, n, indexx) + > + cil * dvu_non(lh, l, lp, ljj2, ljj1) + ENDDO !l + ENDDO !mjj2 + ENDDO !ljj2 + ENDDO !lp + ENDDO !mjj1 + ENDDO !mjj1 + ENDDO !ltil1 + ENDDO !mem + ENDDO !lh + ENDDO !mtil2 + ENDDO !ltil2 + + 555 CONTINUE + call cpu_time(t0) + t_gggint = t_gggint + t0-t1 + +c************** LOCAL ORBITAL CONTRIBUTION ***************c +c determine contributions to T-matrix due to loc. orb. c +c*********************************************************c + IF((nlo(n).GE.1).AND.(.NOT.l_skip_loc)) THEN + call wann_uHu_tlo( + > memd,nlhd,ntypsd,jmtd,lmaxd,dx(n),rmsh(1,n),jri(n), + > lmax(n),ntypsy,natd,lnonsph(n),lmd,lmplmd,clnu, + > mlh,nmem,llh,nlh,irank,vr(1,0,n),nlod,llod, + > loplod,ello(1,n), + > llo(1,n),nlo(n),lo1l(0,n),l_dulo(1,n),ulo_der(1,n), + > f(n,1:,1:,0:),g(n,1:,1:,0:),flo(n,1:,1:,1:), + > f_b(n,1:,1:,0:),g_b(n,1:,1:,0:),flo_b(n,1:,1:,1:), + > vr0(1,n),epar(0,n),l_skip_sph, + > l_nns,rk1,rk2,invsfct,yl1,yl2,jj1,jj2, + > p,dp,p_b,dp_b,q,dq,q_b,dq_b, + > tuulo(0,1,-llod,n,indexx), + > tdulo(0,1,-llod,n,indexx), + > tulou(0,1,-llod,n,indexx), + > tulod(0,1,-llod,n,indexx), + > tuloulo(1,-llod,1,-llod,n,indexx)) + call cpu_time(t1) + t_lo = t_lo + t1-t0 + ENDIF + + na = na + neq(n) + 210 ENDDO !loop over atoms + +c write(*,*)ikpt_b,ikpt_b2 +c write(*,*)'t_radint=',t_radint-tt1 +c write(*,*)'t_sphint=',t_sphint-tt2 +c write(*,*)'t_gggint=',t_gggint-tt3 +c tt1 = t_radint +c tt2 = t_sphint +c tt3 = t_gggint + + enddo !ikpt_b2 + enddo !ikpt_b + + if(.false. .and. (irank.eq.0)) then + do ikpt_b=1,nntot + do ikpt_b2=1,nntot2 + indexx = ikpt_b2 + (ikpt_b-1)*nntot2 + indexx2= ikpt_b + (ikpt_b2-1)*nntot + do n = 1,ntype + do l=0,lwn + do m=-l,l + lm=l*(l+1)+m + do lp=0,lwn + do mp=-lp,lp + lmp=lp*(lp+1)+mp + + if(abs(tuu(lm,lmp,n,indexx)-conjg(tuu(lmp,lm,n,indexx2))) + > .gt.1.e-10) then + write(*,*)'tuu',lm,lmp,n,ikpt_b,ikpt_b2 + write(*,*)tuu(lm,lmp,n,indexx) + write(*,*)tuu(lmp,lm,n,indexx2) + endif + if(abs(tdd(lm,lmp,n,indexx)-conjg(tdd(lmp,lm,n,indexx2))) + > .gt.1.e-10) then + write(*,*)'tdd',lm,lmp,n,ikpt_b,ikpt_b2 + write(*,*)tdd(lm,lmp,n,indexx) + write(*,*)tdd(lmp,lm,n,indexx2) + endif + if(abs(tud(lm,lmp,n,indexx)-conjg(tdu(lmp,lm,n,indexx2))) + > .gt.1.e-10) then + write(*,*)'tud',lm,lmp,n,ikpt_b,ikpt_b2 + write(*,*)tud(lm,lmp,n,indexx) + write(*,*)tdu(lmp,lm,n,indexx2) + endif + if(abs(tdu(lm,lmp,n,indexx)-conjg(tud(lmp,lm,n,indexx2))) + > .gt.1.e-10) then + write(*,*)'tdu',lm,lmp,n,ikpt_b,ikpt_b2 + write(*,*)tdu(lm,lmp,n,indexx) + write(*,*)tud(lmp,lm,n,indexx2) + endif + + enddo + enddo + enddo + enddo + enddo + enddo + enddo + endif + +#if (defined(CPP_MPI) && !defined(CPP_T90)) + CALL MPI_BARRIER(MPI_COMM_WORLD,ierr) +#endif + + deallocate( yl1, yl2 ) + deallocate( dvd_sph, dvu_sph, uvd_sph, uvu_sph ) + deallocate( dvd_non, dvu_non, uvd_non, uvu_non ) + deallocate( p, p_b, dp_b, q, q_b, dq_b ) + deallocate( dp, dq ) + deallocate( x ) + deallocate( jlpp, jj1, jj2 ) + + if(irank.eq.0) then + write(*,*)'t_sphbes=',t_sphbes + write(*,*)'t_ylm =',t_ylm + write(*,*)'t_radint=',t_radint + write(*,*)'t_sphint=',t_sphint + write(*,*)'t_gggint=',t_gggint + write(*,*)'t_locorb=',t_lo + endif + + END SUBROUTINE wann_uHu_tlmplm + END MODULE m_wann_uHu_tlmplm diff --git a/wannier/uhu/wann_uHu_tlmplm2.F b/wannier/uhu/wann_uHu_tlmplm2.F new file mode 100644 index 00000000..dbd1f31e --- /dev/null +++ b/wannier/uhu/wann_uHu_tlmplm2.F @@ -0,0 +1,715 @@ +c*******************************************c +c Muffin tin contribution to uHu-dmi c +c c +c*******************************************c +c Routine to set up T(lm,lmp) for all c +c pairs (b1,b2) and every atom n c +c c +c Includes spherical and non-sph. c +c contributions to Hamiltonian: c +c H^{mt} ~ H^{sph} + H^{non-sph} c +c c +c possible SOC contribution is dealt c +c with in a separate routine c +c*******************************************c +c J.-P. Hanke, Feb. 2016 c +c*******************************************c +c TODO: local orbital part: epar(jspin) c +c*******************************************c + MODULE m_wann_uHu_tlmplm2 + CONTAINS + SUBROUTINE wann_uHu_tlmplm2( + > memd,nlhd,ntypsd,ntypd,jmtd,lmaxd,jspd, + > ntype,dx,rmsh,jri,lmax,ntypsy,natd, + > lnonsph,lmd,lmplmd,clnu,mlh,nmem,llh,nlh,neq, + > irank,mlotot,mlolotot, + > vr,nlod,llod,loplod,ello,llo,nlo,lo1l,l_dulo, + > ulo_der,f,g,flo,f_b,g_b,flo_b, + > kdiff,kdiff2,nntot,nntot2,bmat,bbmat,vr0,epar, + > invsat,jspin,jspin_b, + > l_skip_sph,l_skip_non,l_skip_loc, + < tuu,tud,tdu,tdd, + > tuulo,tulou,tdulo,tulod,tuloulo) + + USE m_intgr, ONLY : intgr3 + USE m_radflo + USE m_radfun + USE m_tlo + USE m_sphbes + USE m_dotir + USE m_ylm + USE m_cotra + USE m_gaunt, ONLY: gaunt1 + USE m_dujdr + USE m_wann_uHu_radintsra5 + USE m_wann_uHu_tlo + USE m_constants, ONLY : pimach + + IMPLICIT NONE +C .. +C .. Scalar Arguments .. + INTEGER, INTENT (IN) :: memd,nlhd,ntypsd,ntypd,jmtd,lmaxd,jspd + INTEGER, INTENT (IN) :: lmd,lmplmd,ntype,irank + INTEGER, INTENT (IN) :: nlod,llod,loplod,natd,mlotot,mlolotot + INTEGER, INTENT (IN) :: nntot,nntot2,jspin,jspin_b + LOGICAL, INTENT (IN) :: l_skip_sph,l_skip_non,l_skip_loc +C .. +C .. Array Arguments .. + COMPLEX, INTENT (OUT):: + > tdd(0:lmd,0:lmd,ntypd,nntot*nntot2), + > tdu(0:lmd,0:lmd,ntypd,nntot*nntot2), + > tud(0:lmd,0:lmd,ntypd,nntot*nntot2), + > tuu(0:lmd,0:lmd,ntypd,nntot*nntot2) + COMPLEX, INTENT (OUT):: + > tdulo(0:lmd,nlod,-llod:llod,ntypd,nntot*nntot2), + > tuulo(0:lmd,nlod,-llod:llod,ntypd,nntot*nntot2), + > tulou(0:lmd,nlod,-llod:llod,ntypd,nntot*nntot2), + > tulod(0:lmd,nlod,-llod:llod,ntypd,nntot*nntot2), + > tuloulo(nlod,-llod:llod,nlod,-llod:llod,ntypd,nntot*nntot2) + COMPLEX, INTENT (IN) :: clnu(memd,0:nlhd,ntypsd) + INTEGER, INTENT (IN) :: llo(nlod,ntypd),nlo(ntypd) + INTEGER, INTENT (IN) :: lo1l(0:llod,ntypd),neq(ntypd) + INTEGER, INTENT (IN) :: mlh(memd,0:nlhd,ntypsd),nlh(ntypsd) + INTEGER, INTENT (IN) :: nmem(0:nlhd,ntypsd),llh(0:nlhd,ntypsd) + INTEGER, INTENT (IN) :: jri(ntypd),lmax(ntypd),ntypsy(natd) + INTEGER, INTENT (IN) :: lnonsph(ntypd),ulo_der(nlod,ntypd) + INTEGER, INTENT (IN) :: invsat(natd) + REAL, INTENT (IN) :: dx(ntypd),rmsh(jmtd,ntypd) + REAL, INTENT (IN) :: vr(jmtd,0:nlhd,ntypd) + REAL, INTENT (IN) :: ello(nlod,ntypd) + REAL, INTENT (IN) :: epar(0:lmaxd,ntypd,2) + REAL, INTENT (IN) :: vr0(jmtd,ntypd) + REAL, INTENT (IN) :: f (ntypd,jmtd,2,0:lmaxd), + > g (ntypd,jmtd,2,0:lmaxd), + > f_b(ntypd,jmtd,2,0:lmaxd), + > g_b(ntypd,jmtd,2,0:lmaxd), + > flo (ntypd,jmtd,2,nlod), + > flo_b(ntypd,jmtd,2,nlod) + REAL, INTENT (IN) :: bmat(3,3),bbmat(3,3) + REAL, INTENT (IN) :: kdiff (3,nntot) + REAL, INTENT (IN) :: kdiff2(3,nntot2) + LOGICAL, INTENT (IN) :: l_dulo(nlod,ntypd) +C .. +C .. Local Scalars .. + COMPLEX cil,ci,cci,cil1,fac1,fac2,fac3,cilp,cciljj1,ciljj2 + INTEGER i,ii,l,l2,lamda,lh,lm,lmin,lmp,lp + INTEGER lp1,lpl,m,mem,mems,mp,mu,n,nh,noded,nodeu,nrec,nsym,na,ne + INTEGER ljj1,ljj2,mjj1,mjj2,lo,lop + INTEGER ltil1,ltil2,mtil1,mtil2 + INTEGER mlo, mlolo, iu + INTEGER :: lmini,lmini2,lmini3 + INTEGER :: lmaxi,lmaxi2,lmaxi3 + INTEGER :: lmx,lmx2,lmx3 + INTEGER :: lzb,ll,llp,lljj1,lljj2,lmjj1,lmjj2 + INTEGER :: ikpt_b,ikpt_b2 + INTEGER :: lwn,indexx + REAL gs,rk1,rk2,sign + REAL gc1,gc2,gc3,invsfct,e,temp_val1,temp_val2 + REAL t1,t0,t_sphbes,t_ylm,t_radint,t_gggint,t_sphint,t_lo + REAL tt1,tt2,tt3 + LOGICAL :: l_nns +C .. +C .. Local Arrays .. + COMPLEX, ALLOCATABLE :: yl1(:),yl2(:) + REAL, ALLOCATABLE :: dvd_non(:,:,:,:,:),dvu_non(:,:,:,:,:) + REAL, ALLOCATABLE :: uvd_non(:,:,:,:,:),uvu_non(:,:,:,:,:) + REAL, ALLOCATABLE :: dvd_sph(:,:,:,:,:),dvu_sph(:,:,:,:,:) + REAL, ALLOCATABLE :: uvd_sph(:,:,:,:,:),uvu_sph(:,:,:,:,:) + REAL, ALLOCATABLE :: p(:,:,:,:),p_b(:,:,:,:),dp_b(:,:,:,:) + REAL, ALLOCATABLE :: q(:,:,:,:),q_b(:,:,:,:),dq_b(:,:,:,:) + REAL, ALLOCATABLE :: dp(:,:,:,:),dq(:,:,:,:) + REAL, ALLOCATABLE :: x(:),vv(:),vm(:) + REAL, ALLOCATABLE :: jlpp(:),jj1(:,:),jj2(:,:) + REAL :: bpt(3),bpt2(3),bkrot(3) + +#if (defined(CPP_MPI) && !defined(CPP_T90)) + INCLUDE 'mpif.h' + INTEGER ierr(3) +#endif +C .. Intrinsic Functions .. + INTRINSIC abs,cmplx,max,mod +C .. + + t_sphbes = 0. + t_ylm = 0. + t_radint = 0. + t_sphint = 0. + t_gggint = 0. + t_lo = 0. + tt1 = 0. + tt2 = 0. + tt3 = 0. + + ci = cmplx(0., 1.) + cci = cmplx(0.,-1.) + tulou = cmplx(0.,0.); tulod = cmplx(0.,0.) + tdulo = cmplx(0.,0.); tuulo = cmplx(0.,0.); tuloulo = cmplx(0.,0.) + tuu = cmplx(0.,0.); tdu = cmplx(0.,0.) + tud = cmplx(0.,0.); tdd = cmplx(0.,0.) + + allocate( yl1((lmaxd+1)**2), yl2((lmaxd+1)**2) ) + allocate( dvd_non(1:nlhd,0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd) ) + allocate( dvu_non(1:nlhd,0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd) ) + allocate( uvd_non(1:nlhd,0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd) ) + allocate( uvu_non(1:nlhd,0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd) ) + allocate( dvd_sph(0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd) ) + allocate( dvu_sph(0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd) ) + allocate( uvd_sph(0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd) ) + allocate( uvu_sph(0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd) ) + allocate( p(jmtd,2,0:lmaxd,0:lmaxd) ) + allocate( p_b(jmtd,2,0:lmaxd,0:lmaxd) ) + allocate( q(jmtd,2,0:lmaxd,0:lmaxd) ) + allocate( q_b(jmtd,2,0:lmaxd,0:lmaxd) ) + allocate( dp(jmtd,2,0:lmaxd,0:lmaxd) ) + allocate( dp_b(jmtd,2,0:lmaxd,0:lmaxd) ) + allocate( dq(jmtd,2,0:lmaxd,0:lmaxd) ) + allocate( dq_b(jmtd,2,0:lmaxd,0:lmaxd) ) + allocate( x(jmtd),vv(jmtd) ) + allocate( vm(jmtd) ) + allocate( jlpp(0:lmaxd), jj1(0:lmaxd,jmtd), jj2(0:lmaxd,jmtd) ) + +c***************************************c +c begin 1st neighbor loop: c +c***************************************c + do ikpt_b2=1,nntot2 + indexx = ikpt_b2 + (ikpt_b-1)*nntot2 + bpt2 = kdiff2(:,ikpt_b2) + rk2= sqrt(dotirp(bpt2,bpt2,bbmat)) + if(rk2.ne.0.0) stop 'dmi but rk2.ne.0' + + na = 1 + mlo = 1 ; mlolo = 1 + + ! loop over atoms + DO 210 n = 1,ntype + lwn = lmax(n) + nsym = ntypsy(na) + nh = nlh(nsym) + + !if(indexx.eq.1 .and. irank.eq.0) then + ! write(*,*)'atom n=',n + ! write(*,*)'spins=',jspin,jspin_b + ! do l=0,lwn + ! write(*,*)'l=',l,epar(l,n,jspin),epar(l,n,jspin_b) + ! enddo + !endif + + l_nns = l_skip_non .OR. (lnonsph(n).LT.0) .OR. + > ( (invsat(na).ne.0).and.(invsat(na).ne.1) ) + if(invsat(na).eq.0) invsfct = 1.0 + if(invsat(na).eq.1) invsfct = 2.0 + if(indexx.eq.1 .and. irank.eq.0) write(*,*)'invsfct=',invsfct + + ! set up spherical Bessel functions + ! jj1(l,b1*r) and jj2(l,b2*r) + call cpu_time(t0) + do i=1,jri(n) + gs = rk1*rmsh(i,n) + call sphbes(lwn,gs,jlpp) + jj1(:,i) = jlpp(:) + + gs = rk2*rmsh(i,n) + call sphbes(lwn,gs,jlpp) + jj2(:,i) = jlpp(:) + +c if(rk1.eq.0.0) then +c if(jj1(0,i).ne.1.0) write(*,*)'jj1.ne.1',i,rmsh(i,n),jj1(0,i) +c if(ANY(jj1(1:lwn,i).ne.0.0)) write(*,*)'jj1.ne.0',i,rmsh(i,n) +c endif + if(jj2(0,i).ne.1.0) stop 'dmi but jj2.ne.1' + if(ANY(jj2(1:lwn,i).ne.0.0)) stop 'dmi but jj2.ne.0' + + enddo + call cpu_time(t1) + t_sphbes=t_sphbes + t1-t0 + + ! set up spherical harmonics + ! yl1(lm) for b1 and yl2(lm) for b2 + yl1 = cmplx(0.,0.) + call cotra3(bpt,bkrot,bmat) + call ylm4(lwn,bkrot,yl1) + + yl2 = cmplx(0.,0.) + call cotra3(bpt2,bkrot,bmat) + if(ANY(bkrot.ne.0.0)) stop 'dmi but bkrot.ne.0' + call ylm4(lwn,bkrot,yl2) + !if(indexx.eq.1 .and. irank.eq.0) write(*,*)'yl2',yl2(1) + + call cpu_time(t0) + t_ylm=t_ylm + t0-t1 + + ! set up products of radial functions and sph. Bessel + DO ljj1 = 0, lwn + DO l = 0, lwn + DO i=1,jri(n) + p(i,:,l,ljj1) = f(n,i,:,l)*jj1(ljj1,i) + q(i,:,l,ljj1) = g(n,i,:,l)*jj1(ljj1,i) + p_b(i,:,l,ljj1) = f_b(n,i,:,l)*jj2(ljj1,i) + q_b(i,:,l,ljj1) = g_b(n,i,:,l)*jj2(ljj1,i) + ENDDO + CALL dujdr(jmtd,jri(n),rmsh(1,n),dx(n),f(n,:,:,l), + > jj1,rk1,ljj1,lmaxd,dp(:,:,l,ljj1)) + CALL dujdr(jmtd,jri(n),rmsh(1,n),dx(n),g(n,:,:,l), + > jj1,rk1,ljj1,lmaxd,dq(:,:,l,ljj1)) + CALL dujdr(jmtd,jri(n),rmsh(1,n),dx(n),f_b(n,:,:,l), + > jj2,rk2,ljj1,lmaxd,dp_b(:,:,l,ljj1)) + CALL dujdr(jmtd,jri(n),rmsh(1,n),dx(n),g_b(n,:,:,l), + > jj2,rk2,ljj1,lmaxd,dq_b(:,:,l,ljj1)) + ENDDO + ENDDO + + if(.false. .and. irank.eq.0 .and. n.eq.1) then + open(876,file='out_radff') + open(877,file='out_radgg') + open(878,file='out_raddf') + open(879,file='out_raddg') + open(880,file='out_radjj') + do i=1,jri(n) + do l=0,lwn + write(876,*)rmsh(i,n),f(n,i,1,l),f(n,i,2,l) + write(877,*)rmsh(i,n),g(n,i,1,l),g(n,i,2,l) + write(878,*)rmsh(i,n),dp(i,1,l,1),dp(i,2,l,1) + write(879,*)rmsh(i,n),dq(i,1,l,1),dq(i,2,l,1) + write(880,*)rmsh(i,n),jj1(l,i),jj2(l,i) + enddo + enddo + close(876) + close(877) + close(878) + close(879) + close(880) + stop + endif + +c****************************************************c +c compute radial integrals c +c c +c where v(lamda,nu) ~ V^{sph} + V^{non-sph} c +c****************************************************c + ! spherical part + IF(.not.l_skip_sph) THEN + uvu_sph = 0. + uvd_sph = 0. + dvu_sph = 0. + dvd_sph = 0. + DO ljj1 = 0, lwn + DO lp = 0, lwn + lmini = abs(lp-ljj1) + lmaxi = lp+ljj1 + lmx = min(lmaxi,lwn) + DO lh=lmini,lmx + if(mod(lmaxi+lh,2).eq.1) cycle + DO ljj2 = 0,0!lwn + lmini2= abs(lh-ljj2) + lmaxi2= lh+ljj2 + lmx2 = min(lmaxi2,lwn) + DO l = lmini2, lmx2 + if(mod(lmaxi2+l,2).eq.1) cycle + e=(epar(lp,n,jspin)+epar(l,n,jspin_b))/2.0!epar(lh,n,jspin) + lzb = lh + + !if(irank.eq.0) write(*,*)lh,l,lp,ljj2,ljj1 + + !if(irank.eq.0) write(*,*)'uvu',epar(lp,n,jspin) + call wann_uHu_radintsra5(jmtd,jri(n),rmsh(1,n),dx(n), + > e,vr0(1,n), + > p(:,:,lp,ljj1),p_b(:,:,l,ljj2), + > dp(:,:,lp,ljj1),dp_b(:,:,l,ljj2), + > lmaxd,lzb,uvu_sph(lh,l,lp,ljj2,ljj1),irank) + + !if(irank.eq.0) write(*,*)'uvd',1.0 + call wann_uHu_radintsra5(jmtd,jri(n),rmsh(1,n),dx(n), + > e,vr0(1,n), + > p(:,:,lp,ljj1),q_b(:,:,l,ljj2), + > dp(:,:,lp,ljj1),dq_b(:,:,l,ljj2), + > lmaxd,lzb,uvd_sph(lh,l,lp,ljj2,ljj1),irank) + + !if(irank.eq.0) write(*,*)'dvu',0.0 + call wann_uHu_radintsra5(jmtd,jri(n),rmsh(1,n),dx(n), + > e,vr0(1,n), + > q(:,:,lp,ljj1),p_b(:,:,l,ljj2), + > dq(:,:,lp,ljj1),dp_b(:,:,l,ljj2), + > lmaxd,lzb,dvu_sph(lh,l,lp,ljj2,ljj1),irank) + +c ! TODO: check influence of symmetrization on OM and DMI +c uvd_sph(lh,l,lp,ljj2,ljj1) = (uvd_sph(lh,l,lp,ljj2,ljj1) +c > +dvu_sph(lh,l,lp,ljj2,ljj1))/2.0 +c dvu_sph(lh,l,lp,ljj2,ljj1) = uvd_sph(lh,l,lp,ljj2,ljj1) + + !if(irank.eq.0) write(*,*)'dvd',epar(lp,n,jspin) + call wann_uHu_radintsra5(jmtd,jri(n),rmsh(1,n),dx(n), + > e,vr0(1,n), + > q(:,:,lp,ljj1),q_b(:,:,l,ljj2), + > dq(:,:,lp,ljj1),dq_b(:,:,l,ljj2), + > lmaxd,lzb,dvd_sph(lh,l,lp,ljj2,ljj1),irank) + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDIF + + + ! nonspherical part + IF(.not.l_nns) then + uvu_non = 0. + uvd_non = 0. + dvu_non = 0. + dvd_non = 0. + DO ljj1 = 0, lwn + DO ljj2 = 0, 0!lwn + DO lp = 0, lwn +c DO l = 0, lp + DO l = 0, lwn + DO lh = 1, nh + DO i = 1,jri(n) + x(i)=(p(i,1,lp,ljj1)*p_b(i,1,l,ljj2) + > +p(i,2,lp,ljj1)*p_b(i,2,l,ljj2)) + > * vr(i,lh,n) + ENDDO + CALL intgr3(x(1:jri(n)),rmsh(1,n),dx(n),jri(n), + > uvu_non(lh,l,lp,ljj2,ljj1)) + DO i = 1,jri(n) + x(i)=(q(i,1,lp,ljj1)*p_b(i,1,l,ljj2) + > +q(i,2,lp,ljj1)*p_b(i,2,l,ljj2)) + > * vr(i,lh,n) + ENDDO + CALL intgr3(x(1:jri(n)),rmsh(1,n),dx(n),jri(n), + > dvu_non(lh,l,lp,ljj2,ljj1)) + DO i = 1,jri(n) + x(i)=(p(i,1,lp,ljj1)*q_b(i,1,l,ljj2) + > +p(i,2,lp,ljj1)*q_b(i,2,l,ljj2)) + > * vr(i,lh,n) + ENDDO + CALL intgr3(x(1:jri(n)),rmsh(1,n),dx(n),jri(n), + > uvd_non(lh,l,lp,ljj2,ljj1)) + DO i = 1,jri(n) + x(i)=(q(i,1,lp,ljj1)*q_b(i,1,l,ljj2) + > +q(i,2,lp,ljj1)*q_b(i,2,l,ljj2)) + > * vr(i,lh,n) + ENDDO + CALL intgr3(x(1:jri(n)),rmsh(1,n),dx(n),jri(n), + > dvd_non(lh,l,lp,ljj2,ljj1)) + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ! symmetry can be used if f=f_b and g=g_b + ! i.e. if jspin = jspin_b +c DO lp=0,lwn +c DO l=lp+1,lwn +c uvu_non(:,l,lp,:,:) = uvu_non(:,lp,l,:,:) +c dvd_non(:,l,lp,:,:) = dvd_non(:,lp,l,:,:) +c uvd_non(:,l,lp,:,:) = dvu_non(:,lp,l,:,:) +c dvu_non(:,l,lp,:,:) = uvd_non(:,lp,l,:,:) +c ENDDO +c ENDDO + ENDIF + + call cpu_time(t0) + t_radint = t_radint + t0-t1 + + tuu(:,:,n,indexx) = cmplx(0.,0.) + tdu(:,:,n,indexx) = cmplx(0.,0.) + tud(:,:,n,indexx) = cmplx(0.,0.) + tdd(:,:,n,indexx) = cmplx(0.,0.) + + if(l_skip_sph) GOTO 444 +c************** SPHERICAL CONTRIBUTION *******************c +c compute product of the two Gaunt coefficients c +c with the radial integrals (+prefactors) c +c*********************************************************c +c We deal with two Gaunt coefficients: c +c G1 = G( (ltil1,mtil1), (ljj1,mjj1) , ( lp, mp) ) c +c G2 = G( (l , m) , (ljj2, mjj2), (ltil1, mtil1) ) c +c*********************************************************c +c use Gaunt conditions to reduce number of operations. c +c coefficient G(L1,L2,L3) only nonzero if c +c a) l1 + l2 + l3 = even c +c b) |l2-l3| <= l1 <= l2+l3 c +c c) m1 = m2 + m3 c +c*********************************************************c + DO ljj1=0,lwn + lljj1 = ljj1 * (ljj1 + 1) + cciljj1 = cci**ljj1 + DO mjj1=-ljj1,ljj1 + lmjj1 = lljj1 + mjj1 + fac1 = cciljj1*conjg(yl1(lmjj1 + 1)) + if(fac1.eq.0.0) cycle + + DO lp=0,lwn + llp = lp*(lp+1) + lmini = abs(ljj1-lp) + lmaxi = ljj1+lp + lmx = min(lmaxi,lwn) + DO mp=-lp,lp + lmp = llp+mp + mtil1=mjj1+mp + IF(abs(mtil1).gt.lmx) cycle + + DO ltil1=lmini,lmx + ! Gaunt conditions (G1): + if((mod(lmaxi+ltil1,2).eq.1).or. + > (abs(mtil1).gt.ltil1)) cycle + + gc1 = gaunt1(ltil1, ljj1, lp, + > mtil1, mjj1, mp, lmaxd) + + cil1 = (ci**lp) * fac1 * gc1 + + DO ljj2=0,0!lwn + lljj2 = ljj2 * (ljj2 + 1) + lmini2 = abs(ltil1-ljj2) + lmaxi2 = ltil1+ljj2 + lmx2 = min(lmaxi2,lwn) + DO mjj2=-ljj2,ljj2 + lmjj2 = lljj2 + mjj2 + m=mjj2+mtil1 + IF(abs(m).gt.lmx2) cycle + + DO l=lmini2,lmx2 + ! Gaunt conditions (G2): + if((mod(lmaxi2+l,2).eq.1).or. + > (abs(m).gt.l)) cycle + ll = l*(l+1) + lm = ll+m + + gc2 = gaunt1( l, ljj2, ltil1, + > m, mjj2, mtil1, lmaxd) + + ! set up prefactor + cil = cil1* ( ci ** (ljj2 - l) ) + + * gc2 * conjg( yl2(lmjj2 + 1) ) + + if(cil.eq.0.0) cycle + + ! additional factor from symmetrization (below) +c cil = 0.5 * cil + + ! compute T-coefficients + ! using symmetrized uvu,uvd,dvu,dvd integrals + tuu(lm, lmp, n, indexx) + > = tuu(lm, lmp, n, indexx) + > + cil * ( uvu_sph(ltil1, l, lp, ljj2, ljj1) ) + + tdd(lm, lmp, n, indexx) + > = tdd(lm, lmp, n, indexx) + > + cil * ( dvd_sph(ltil1, l, lp, ljj2, ljj1) ) + + tud(lm, lmp, n, indexx) + > = tud(lm, lmp, n, indexx) + > + cil * ( uvd_sph(ltil1, l, lp, ljj2, ljj1) ) + + tdu(lm, lmp, n, indexx) + > = tdu(lm, lmp, n, indexx) + > + cil * ( dvu_sph(ltil1, l, lp, ljj2, ljj1) ) + ENDDO!ljj2 + ENDDO!m + ENDDO!l + ENDDO!ljj1 + ENDDO!mp + ENDDO!lp + ENDDO!mtil1 + ENDDO!ltil1 + + 444 CONTINUE + call cpu_time(t1) + t_sphint = t_sphint + t1-t0 + + IF( l_nns ) GOTO 555 +c************** NON-SPHERICAL CONTRIBUTION ***************c +c compute product of the three Gaunt coefficients c +c with the radial integrals (+prefactors) c +c*********************************************************c +c We deal with three Gaunt coefficients: c +c G1 = G( (ltil1,mtil1) , (lamda,mu) , (ltil2,mtil2) ) c +c G2 = G( (ltil1,mtil1) , (ljj1,mjj1) , (lp,mp) ) c +c G3 = G( (l,m) , (ljj2,mjj2) , (ltil2,mtil2) ) c +c*********************************************************c +c use Gaunt conditions to reduce number of operations. c +c coefficient G(L1,L2,L3) only nonzero if c +c a) l1 + l2 + l3 = even c +c b) |l2-l3| <= l1 <= l2+l3 c +c c) m1 = m2 + m3 c +c*********************************************************c + DO ltil2 = 0, lwn + DO mtil2 = -ltil2, ltil2 + DO lh = 1, nh + lamda = llh(lh,nsym) + lmini = abs(ltil2 - lamda) + lmaxi = ltil2 + lamda + lmx = min(lmaxi,lwn) + mems = nmem(lh,nsym) + DO mem = 1, mems + mu = mlh(mem,lh,nsym) + mtil1 = mtil2+mu + IF(abs(mtil1).GT.lmx) CYCLE + + DO ltil1 = lmini, lmx + + ! Gaunt conditions (G1): + if((mod(lmaxi+ltil1,2).eq.1).or. + > (abs(mtil1).gt.ltil1)) cycle + + gc1 = gaunt1(ltil1, lamda, ltil2, + > mtil1, mu, mtil2, lmaxd) + fac1 = conjg(clnu(mem,lh,nsym)) * gc1 * invsfct + if(fac1.eq.0.0) CYCLE + + DO lp = 0, lnonsph(n) + llp = lp * (lp + 1) + cilp = ci**lp + DO mp = -lp, lp + lmp = llp + mp + mjj1 = mtil1 - mp + IF(abs(mjj1).GT.lwn) CYCLE + + DO ljj1 = 0, lwn + lmini2 = abs(lp-ljj1) + lmaxi2 = lp+ljj1 + + ! Gaunt conditions (G2): + if((lmini2.gt.ltil1).or.(lmaxi2.lt.ltil1).or. + > (mod(lmaxi2+ltil1,2).eq.1).or. + > (abs(mjj1).gt.ljj1)) cycle + + lljj1 = ljj1 * (ljj1 + 1) + lmjj1 = lljj1 + mjj1 + + gc2 = gaunt1(ltil1, ljj1, lp, + > mtil1, mjj1, mp, lmaxd) + fac2 = fac1 * cilp * (cci**ljj1) * gc2 + > * conjg( yl1(lmjj1 + 1) ) + IF(fac2.eq.0.0) CYCLE + + DO ljj2 = 0, 0!lwn + lljj2 = ljj2 * (ljj2 + 1) + ciljj2 = ci**ljj2 + lmini3 = abs(ltil2 - ljj2) + lmaxi3 = ltil2 + ljj2 + lmx3 = min(lmaxi3,lnonsph(n)) + DO mjj2 = -ljj2,ljj2 + m = mjj2+mtil2 + IF(abs(m).GT.lmx3) CYCLE + lmjj2 = lljj2 + mjj2 + fac3 = fac2 * ciljj2 * conjg(yl2(lmjj2 + 1)) + if(fac3.eq.0.0) CYCLE + + DO l = lmini3,lmx3 + + ! Gaunt conditions (G3): + if((mod(lmaxi3+l,2).eq.1).or. + > (abs(m).gt.l)) cycle + + ll = l * (l + 1) + lm = ll + m + + gc3 = gaunt1(l, ljj2, ltil2, + > m, mjj2, mtil2, lmaxd) + + ! set up prefactor + cil = fac3 * (cci**l) * gc3 + + ! compute T-coefficients + tuu(lm, lmp, n, indexx) + > = tuu(lm, lmp, n, indexx) + > + cil * uvu_non(lh, l, lp, ljj2, ljj1) + + tdd(lm, lmp, n, indexx) + > = tdd(lm, lmp, n, indexx) + > + cil * dvd_non(lh, l, lp, ljj2, ljj1) + + tud(lm, lmp, n, indexx) + > = tud(lm, lmp, n, indexx) + > + cil * uvd_non(lh, l, lp, ljj2, ljj1) + + tdu(lm, lmp, n, indexx) + > = tdu(lm, lmp, n, indexx) + > + cil * dvu_non(lh, l, lp, ljj2, ljj1) + ENDDO !l + ENDDO !mjj2 + ENDDO !ljj2 + ENDDO !lp + ENDDO !mjj1 + ENDDO !mjj1 + ENDDO !ltil1 + ENDDO !mem + ENDDO !lh + ENDDO !mtil2 + ENDDO !ltil2 + + 555 CONTINUE + call cpu_time(t0) + t_gggint = t_gggint + t0-t1 + +c************** LOCAL ORBITAL CONTRIBUTION ***************c +c determine contributions to T-matrix due to loc. orb. c +c*********************************************************c + IF((nlo(n).GE.1).AND.(.NOT.l_skip_loc)) THEN + !write(*,*)'TODO: include loc. orb. for DMI' + call wann_uHu_tlo( + > memd,nlhd,ntypsd,jmtd,lmaxd,dx(n),rmsh(1,n),jri(n), + > lmax(n),ntypsy,natd,lnonsph(n),lmd,lmplmd,clnu, + > mlh,nmem,llh,nlh,irank,vr(1,0,n),nlod,llod, + > loplod,ello(1,n), + > llo(1,n),nlo(n),lo1l(0,n),l_dulo(1,n),ulo_der(1,n), + > f(n,1:,1:,0:),g(n,1:,1:,0:),flo(n,1:,1:,1:), + > f_b(n,1:,1:,0:),g_b(n,1:,1:,0:),flo_b(n,1:,1:,1:), + > vr0(1,n),epar(0,n,jspin),l_skip_sph, + > l_nns,rk1,rk2,invsfct,yl1,yl2,jj1,jj2, + > p,dp,p_b,dp_b,q,dq,q_b,dq_b, + > tuulo(0,1,-llod,n,indexx), + > tdulo(0,1,-llod,n,indexx), + > tulou(0,1,-llod,n,indexx), + > tulod(0,1,-llod,n,indexx), + > tuloulo(1,-llod,1,-llod,n,indexx)) + call cpu_time(t1) + t_lo = t_lo + t1-t0 + ENDIF + + na = na + neq(n) + 210 ENDDO !loop over atoms + +c write(*,*)ikpt_b,ikpt_b2 +c write(*,*)'t_radint=',t_radint-tt1 +c write(*,*)'t_sphint=',t_sphint-tt2 +c write(*,*)'t_gggint=',t_gggint-tt3 +c tt1 = t_radint +c tt2 = t_sphint +c tt3 = t_gggint + + enddo !ikpt_b2 + enddo !ikpt_b + +#if (defined(CPP_MPI) && !defined(CPP_T90)) + CALL MPI_BARRIER(MPI_COMM_WORLD,ierr) +#endif + + deallocate( yl1, yl2 ) + deallocate( dvd_sph, dvu_sph, uvd_sph, uvu_sph ) + deallocate( dvd_non, dvu_non, uvd_non, uvu_non ) + deallocate( p, dp, p_b, dp_b, q, dq, q_b, dq_b ) + deallocate( x,vv ) + deallocate( vm ) + deallocate( jlpp, jj1, jj2 ) + +c if(irank.eq.0) then +c write(*,*)'t_sphbes=',t_sphbes +c write(*,*)'t_ylm =',t_ylm +c write(*,*)'t_radint=',t_radint +c write(*,*)'t_sphint=',t_sphint +c write(*,*)'t_gggint=',t_gggint +c write(*,*)'t_locorb=',t_lo +c endif + + END SUBROUTINE wann_uHu_tlmplm2 + END MODULE m_wann_uHu_tlmplm2 diff --git a/wannier/uhu/wann_uHu_tlo.F b/wannier/uhu/wann_uHu_tlo.F new file mode 100644 index 00000000..5666d7c1 --- /dev/null +++ b/wannier/uhu/wann_uHu_tlo.F @@ -0,0 +1,832 @@ +c****************************************c +c Muffin tin contribution to uHu c +c < u_{k+b1} | H_{k}^{mt} | u_{k+b2} > c +c****************************************c +c Routine to set up T(lm,lmp) for all c +c pairs (b1,b2) and every atom n c +c due to local orbitals c +c c +c****************************************c +c J.-P. Hanke, Dec. 2015 c +c****************************************c + MODULE m_wann_uHu_tlo + CONTAINS + SUBROUTINE wann_uHu_tlo( + > memd,nlhd,ntypsd,jmtd,lmaxd, + > dx,rmsh,jri,lmax,ntypsy,natd, + > lnonsph,lmd,lmplmd,clnu,mlh,nmem,llh,nlh, + > irank,vr,nlod,llod,loplod,ello,llo,nlo,lo1l,l_dulo, + > ulo_der,f,g,flo,f_b,g_b,flo_b,vr0,epar, + > l_skip_sph,l_nns, + > rk1,rk2,invsfct,yl1,yl2,jj1,jj2,p,dp,p_b,dp_b, + > q,dq,q_b,dq_b, + > tuulo,tdulo,tulou,tulod,tuloulo) + + USE m_intgr, ONLY : intgr3 + USE m_radflo + USE m_radfun + USE m_tlo + USE m_sphbes + USE m_dotir + USE m_ylm + USE m_cotra + USE m_gaunt, ONLY: gaunt1 + USE m_wann_uHu_radintsra3 + USE m_wann_uHu_radintsra5 + USE m_constants, ONLY : pimach + USE m_dujdr + + IMPLICIT NONE +C .. +C .. Scalar Arguments .. + REAL, INTENT (IN) :: rk1,rk2,invsfct + INTEGER, INTENT (IN) :: memd,nlhd,ntypsd,jmtd,lmaxd + INTEGER, INTENT (IN) :: lmd,lmplmd,irank + INTEGER, INTENT (IN) :: nlod,llod,loplod,natd + LOGICAL, INTENT (IN) :: l_skip_sph,l_nns +C .. +C .. Array Arguments .. + COMPLEX, INTENT (OUT):: tdulo(0:lmd,nlod,-llod:llod) + COMPLEX, INTENT (OUT):: tuulo(0:lmd,nlod,-llod:llod) + COMPLEX, INTENT (OUT):: tulod(0:lmd,nlod,-llod:llod) + COMPLEX, INTENT (OUT):: tulou(0:lmd,nlod,-llod:llod) + COMPLEX, INTENT (OUT):: tuloulo(nlod,-llod:llod,nlod,-llod:llod) + COMPLEX, INTENT (IN) :: clnu(memd,0:nlhd,ntypsd) + COMPLEX, INTENT (IN) :: yl1((lmaxd+1)**2),yl2((lmaxd+1)**2) + INTEGER, INTENT (IN) :: llo(nlod),nlo + INTEGER, INTENT (IN) :: lo1l(0:llod) + INTEGER, INTENT (IN) :: mlh(memd,0:nlhd,ntypsd),nlh(ntypsd) + INTEGER, INTENT (IN) :: nmem(0:nlhd,ntypsd),llh(0:nlhd,ntypsd) + INTEGER, INTENT (IN) :: jri,lmax,ntypsy(natd) + INTEGER, INTENT (IN) :: lnonsph,ulo_der(nlod) + REAL, INTENT (IN) :: dx,rmsh(jmtd) + REAL, INTENT (IN) :: vr(jmtd,0:nlhd) + REAL, INTENT (IN) :: ello(nlod) + REAL, INTENT (IN) :: epar(0:lmaxd) + REAL, INTENT (IN) :: vr0(jmtd) + REAL, INTENT (IN) :: f (jmtd,2,0:lmaxd), + > g (jmtd,2,0:lmaxd), + > f_b(jmtd,2,0:lmaxd), + > g_b(jmtd,2,0:lmaxd), + > flo (jmtd,2,nlod), + > flo_b(jmtd,2,nlod) + REAL, INTENT (IN) :: p(jmtd,2,0:lmaxd,0:lmaxd), + > q(jmtd,2,0:lmaxd,0:lmaxd), + > dp(jmtd,2,0:lmaxd,0:lmaxd), + > dq(jmtd,2,0:lmaxd,0:lmaxd), + > p_b(jmtd,2,0:lmaxd,0:lmaxd), + > q_b(jmtd,2,0:lmaxd,0:lmaxd), + > dp_b(jmtd,2,0:lmaxd,0:lmaxd), + > dq_b(jmtd,2,0:lmaxd,0:lmaxd) + REAL, INTENT (IN) :: jj1(0:lmaxd,jmtd),jj2(0:lmaxd,jmtd) + LOGICAL, INTENT (IN) :: l_dulo(nlod) +C .. +C .. Local Scalars .. + COMPLEX cil,ci,cil2 + INTEGER i,l,l2,lamda,lh,lm,lmin,lmp,lp + INTEGER lp1,lpl,m,mem,mems,mp,mu,n,nh,noded,nodeu,nrec,nsym,na,ne + INTEGER ljj1,ljj2,mjj1,mjj2,lo,lop + INTEGER ltil1,ltil2,mtil1,mtil2 + INTEGER mlo, mlolo, iu + INTEGER :: lmini,lmini2,lmini3 + INTEGER :: lmaxi,lmaxi2,lmaxi3 + INTEGER :: ll,llp,lljj1,lljj2,lmjj1,lmjj2 + INTEGER :: ikpt_b,ikpt_b2 + INTEGER :: lwn + REAL gc1,gc2,gc3,e,sy1,sy2 + REAL t1,t0,t_sphbes,t_ylm,t_radint,t_gggint,t_sphint + LOGICAL :: L_oldsym +C .. +C .. Local Arrays .. + REAL, ALLOCATABLE :: ulovulo_sph(:,:,:,:,:) + REAL, ALLOCATABLE :: ulovulo_non(:,:,:,:,:) + REAL, ALLOCATABLE :: ulovu_sph(:,:,:,:,:),ulovu_non(:,:,:,:,:) + REAL, ALLOCATABLE :: ulovd_sph(:,:,:,:,:),ulovd_non(:,:,:,:,:) + REAL, ALLOCATABLE :: uvulo_sph(:,:,:,:,:),uvulo_non(:,:,:,:,:) + REAL, ALLOCATABLE :: dvulo_sph(:,:,:,:,:),dvulo_non(:,:,:,:,:) + REAL, ALLOCATABLE :: plo(:,:,:,:),dplo(:,:,:,:) + REAL, ALLOCATABLE :: plo_b(:,:,:,:),dplo_b(:,:,:,:) + REAL, ALLOCATABLE :: x(:) + + +#if (defined(CPP_MPI) && !defined(CPP_T90)) + INCLUDE 'mpif.h' + INTEGER ierr(3) +#endif +C .. Intrinsic Functions .. + INTRINSIC abs,cmplx,max,mod +C .. + + l_oldsym=.false. + sy1=1.0 + sy2=0.0 + if(l_oldsym) then + sy1=0.5 + sy2=0.5 + endif + + t_sphbes = 0. + t_ylm = 0. + t_radint = 0. + t_sphint = 0. + t_gggint = 0. + + lwn = lmax + ci = cmplx(0.0,1.0) + tdulo(:,:,:) = cmplx(0.0,0.0) + tuulo(:,:,:) = cmplx(0.0,0.0) + tulod(:,:,:) = cmplx(0.0,0.0) + tulou(:,:,:) = cmplx(0.0,0.0) + tuloulo(:,:,:,:) = cmplx(0.0,0.0) + + allocate( ulovulo_sph(0:lmaxd,0:lmaxd,0:lmaxd,nlod,nlod) ) + allocate( ulovu_sph(0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd,nlod) ) + allocate( ulovd_sph(0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd,nlod) ) + allocate( uvulo_sph(0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd,nlod) ) + allocate( dvulo_sph(0:lmaxd,0:lmaxd,0:lmaxd,0:lmaxd,nlod) ) + allocate( ulovulo_non(1:nlhd,0:lmaxd,0:lmaxd,nlod,nlod) ) + allocate( ulovu_non(1:nlhd,0:lmaxd,0:lmaxd,0:lmaxd,nlod) ) + allocate( ulovd_non(1:nlhd,0:lmaxd,0:lmaxd,0:lmaxd,nlod) ) + allocate( uvulo_non(1:nlhd,0:lmaxd,0:lmaxd,0:lmaxd,nlod) ) + allocate( dvulo_non(1:nlhd,0:lmaxd,0:lmaxd,0:lmaxd,nlod) ) + allocate( x(jmtd) ) + allocate( plo(jmtd,2,0:lmaxd,nlod), plo_b(jmtd,2,0:lmaxd,nlod) ) + allocate( dplo(jmtd,2,0:lmaxd,nlod) ) + allocate( dplo_b(jmtd,2,0:lmaxd,nlod) ) + + DO lo = 1,nlo + DO ljj1=0, lwn + DO i=1,jri + plo(i,:,ljj1,lo) = flo(i,:,lo)*jj1(ljj1,i) + plo_b(i,:,ljj1,lo) = flo_b(i,:,lo)*jj2(ljj1,i) + ENDDO + CALL dujdr(jmtd,jri,rmsh(1),dx,flo(:,:,lo), + > jj1,rk1,ljj1,lmaxd,dplo(:,:,ljj1,lo)) + CALL dujdr(jmtd,jri,rmsh(1),dx,flo_b(:,:,lo), + > jj2,rk2,ljj1,lmaxd,dplo_b(:,:,ljj1,lo)) + ENDDO + ENDDO + +c****************************************************c +c compute radial integrals c +c c +c where v(lamda,nu) ~ V^{sph} + V^{non-sph} c +c****************************************************c +! lo - lo + do lop = 1,nlo + lp = llo(lop) + do lo = 1,nlo + l = llo(lo) + do ljj1=0, lwn + do ljj2=0, lwn + + if(l_skip_sph) GOTO 1232 + do lh=0,lwn + lmini = abs(lp-ljj1) + lmini2= abs(lh-ljj2) + lmaxi = lp+ljj1 + lmaxi2= lh+ljj2 + if((lmini.gt.lh) .or. (lmaxi.lt.lh).or. + > (lmini2.gt.l) .or. (lmaxi2.lt.l).or. + > (mod(lp+lh+ljj1,2).eq.1).or. + > (mod( l+lh+ljj2,2).eq.1)) then + ulovulo_sph(lh,ljj2,ljj1,lo,lop) = 0. + else + e = (ello(lo)+ello(lop))/2.0!epar(lh) + if(.not.l_oldsym) then + call wann_uHu_radintsra5(jmtd,jri,rmsh(1),dx, + > e,vr0(1),plo(:,:,ljj1,lop),plo_b(:,:,ljj2,lo), + > dplo(:,:,ljj1,lop),dplo_b(:,:,ljj2,lo),lmaxd,lh, + > ulovulo_sph(lh,ljj2,ljj1,lo,lop),irank) + else + call wann_uHu_radintsra3(jmtd,jri,rmsh(1),dx, + > ello(lo),vr0(1),plo(:,:,ljj1,lop),plo_b(:,:,ljj2,lo), + > dplo_b(:,:,ljj2,lo),lmaxd,lh, + > ulovulo_sph(lh,ljj2,ljj1,lo,lop)) + endif + endif + enddo + 1232 continue + + if(l_nns) GOTO 1230 + do lh = 1, nh + do i = 1,jri + x(i) = ( plo(i,1,ljj1,lop)*plo_b(i,1,ljj2,lo) + > + plo(i,2,ljj1,lop)*plo_b(i,2,ljj2,lo) ) + > * vr(i,lh) + enddo + CALL intgr3(x(1:jri),rmsh(1),dx,jri, + > ulovulo_non(lh,ljj2,ljj1,lo,lop)) + enddo + 1230 continue + enddo + enddo + enddo + enddo + +! apw - lo + do lop = 1,nlo + lp = llo(lop) + do ljj1 = 0,lwn + do ljj2 = 0,lwn + do l = 0,lwn + + if(l_skip_sph) GOTO 1233 + do lh=0,lwn + lmini = abs(lp-ljj1) + lmini2= abs(lh-ljj2) + lmaxi = lp+ljj1 + lmaxi2= lh+ljj2 + if((lmini.gt.lh) .or. (lmaxi.lt.lh).or. + > (lmini2.gt.l) .or. (lmaxi2.lt.l).or. + > (mod(lp+lh+ljj1,2).eq.1).or. + > (mod( l+lh+ljj2,2).eq.1)) then + ulovu_sph(lh,l,ljj2,ljj1,lop) = 0. + ulovd_sph(lh,l,ljj2,ljj1,lop) = 0. + else + e = (ello(lop)+epar(l))/2.0!epar(lh) + if(.not.l_oldsym) then + call wann_uHu_radintsra5(jmtd,jri,rmsh(1),dx, + > e,vr0(1),plo(:,:,ljj1,lop),p_b(:,:,l,ljj2), + > dplo(:,:,ljj1,lop),dp_b(:,:,l,ljj2),lmaxd,lh, + > ulovu_sph(lh,l,ljj2,ljj1,lop),irank) + call wann_uHu_radintsra5(jmtd,jri,rmsh(1),dx, + > e,vr0(1),plo(:,:,ljj1,lop),q_b(:,:,l,ljj2), + > dplo(:,:,ljj1,lop),dq_b(:,:,l,ljj2),lmaxd,lh, + > ulovd_sph(lh,l,ljj2,ljj1,lop),irank) + else + call wann_uHu_radintsra3(jmtd,jri,rmsh(1),dx, + > epar(l),vr0(1),plo(:,:,ljj1,lop),p_b(:,:,l,ljj2), + > dp_b(:,:,l,ljj2),lmaxd,lh, + > ulovu_sph(lh,l,ljj2,ljj1,lop)) + call wann_uHu_radintsra3(jmtd,jri,rmsh(1),dx, + > epar(l),vr0(1),plo(:,:,ljj1,lop),q_b(:,:,l,ljj2), + > dq_b(:,:,l,ljj2),lmaxd,lh, + > ulovd_sph(lh,l,ljj2,ljj1,lop)) + endif + endif + + lmini = abs(l-ljj1) + lmini2= abs(lh-ljj2) + lmaxi = l+ljj1 + lmaxi2= lh+ljj2 + if((lmini.gt.lh) .or. (lmaxi.lt.lh).or. + > (lmini2.gt.lp) .or. (lmaxi2.lt.lp).or. + > (mod(l+lh+ljj1,2).eq.1).or. + > (mod(lp+lh+ljj2,2).eq.1)) then + uvulo_sph(lh,l,ljj2,ljj1,lop) = 0. + dvulo_sph(lh,l,ljj2,ljj1,lop) = 0. + else + e=(ello(lop)+epar(l))/2.0!epar(lh) + if(.not.l_oldsym) then + call wann_uHu_radintsra5(jmtd,jri,rmsh(1),dx, + > e,vr0(1),p(:,:,l,ljj1),plo_b(:,:,ljj2,lop), + > dp(:,:,l,ljj1),dplo_b(:,:,ljj2,lop),lmaxd,lh, + > uvulo_sph(lh,l,ljj2,ljj1,lop),irank) + call wann_uHu_radintsra5(jmtd,jri,rmsh(1),dx, + > e,vr0(1),q(:,:,l,ljj1),plo_b(:,:,ljj2,lop), + > dq(:,:,l,ljj1),dplo_b(:,:,ljj2,lop),lmaxd,lh, + > dvulo_sph(lh,l,ljj2,ljj1,lop),irank) + else + call wann_uHu_radintsra3(jmtd,jri,rmsh(1),dx, + > ello(lop),vr0(1),p(:,:,l,ljj1),plo_b(:,:,ljj2,lop), + > dplo_b(:,:,ljj2,lop),lmaxd,lh, + > uvulo_sph(lh,l,ljj2,ljj1,lop)) + call wann_uHu_radintsra3(jmtd,jri,rmsh(1),dx, + > ello(lop),vr0(1),q(:,:,l,ljj1),plo_b(:,:,ljj2,lop), + > dplo_b(:,:,ljj2,lop),lmaxd,lh, + > dvulo_sph(lh,l,ljj2,ljj1,lop)) + endif + endif + enddo + 1233 continue + + if(l_nns) GOTO 1231 + do lh = 1, nh + do i = 1,jri + x(i) = ( plo(i,1,ljj1,lop)*p_b(i,1,l,ljj2) + > + plo(i,2,ljj1,lop)*p_b(i,2,l,ljj2) ) + > * vr(i,lh) + enddo + CALL intgr3(x(1:jri),rmsh(1),dx,jri, + > ulovu_non(lh,l,ljj2,ljj1,lop)) + do i = 1,jri + x(i) = ( plo(i,1,ljj1,lop)*q_b(i,1,l,ljj2) + > + plo(i,2,ljj1,lop)*q_b(i,2,l,ljj2) ) + > * vr(i,lh) + enddo + CALL intgr3(x(1:jri),rmsh(1),dx,jri, + > ulovd_non(lh,l,ljj2,ljj1,lop)) + do i = 1,jri + x(i) = ( p(i,1,l,ljj1)*plo_b(i,1,ljj2,lop) + > + p(i,2,l,ljj1)*plo_b(i,2,ljj2,lop) ) + > * vr(i,lh) + enddo + CALL intgr3(x(1:jri),rmsh(1),dx,jri, + > uvulo_non(lh,l,ljj2,ljj1,lop)) + do i = 1,jri + x(i) = ( q(i,1,l,ljj1)*plo_b(i,1,ljj2,lop) + > + q(i,2,l,ljj1)*plo_b(i,2,ljj2,lop) ) + > * vr(i,lh) + enddo + CALL intgr3(x(1:jri),rmsh(1),dx,jri, + > dvulo_non(lh,l,ljj2,ljj1,lop)) + enddo + 1231 continue + enddo + enddo + enddo + enddo + + if(l_skip_sph) GOTO 444 +c************** SPHERICAL CONTRIBUTION *******************c +c compute product of the two Gaunt coefficients c +c with the radial integrals (+prefactors) c +c*********************************************************c +c We deal with two Gaunt coefficients: c +c G1 = G( (ltil1,mtil1), (ljj1,mjj1) , ( lp, mp) ) c +c G2 = G( (l , m) , (ljj2, mjj2), (ltil1, mtil1) ) c +c*********************************************************c +c use Gaunt conditions to reduce number of operations. c +c coefficient G(L1,L2,L3) only nonzero if c +c a) l1 + l2 + l3 = even c +c b) |l2-l3| <= l1 <= l2+l3 c +c c) m1 = m2 + m3 c +c*********************************************************c + +! lo-lo + DO lop=1,nlo + lp = llo(lop) + DO mp=-lp,lp + DO ltil1=0,lwn + DO mtil1=-ltil1,ltil1 + mjj1=mtil1-mp + DO ljj1=0,lwn + lljj1 = ljj1 * (ljj1 + 1) + lmjj1 = lljj1 + mjj1 + lmini = abs(ljj1-lp) + lmaxi = ljj1+lp + ! Gaunt conditions (G1): + if((lmini.gt.ltil1).or.(lmaxi.lt.ltil1).or. + > (mod(lp+ltil1+ljj1,2).ne.0).or. + > (abs(mjj1).gt.ljj1)) cycle + + gc1 = gaunt1(ltil1, ljj1, lp, + > mtil1, mjj1, mp, lmaxd) + + DO lo=1,nlo + l = llo(lo) + DO m=-l,l + mjj2=m-mtil1 + DO ljj2=0,lwn + lljj2 = ljj2 * (ljj2 + 1) + lmjj2 = lljj2 + mjj2 + lmini2 = abs(ltil1-ljj2) + lmaxi2 = ltil1+ljj2 + ! Gaunt conditions (G2): + if((lmini2.gt.l).or.(lmaxi2.lt.l).or. + > (mod(l+ltil1+ljj2,2).ne.0).or. + > (abs(mjj2).gt.ljj2)) cycle + + gc2 = gaunt1( l, ljj2, ltil1, + > m, mjj2, mtil1, lmaxd) + + ! set up prefactor + cil = ( ci ** (lp - l + ljj1 + ljj2) ) + + *( (-1.0) **ljj1 ) + + * gc1 * gc2 + + * conjg( yl1(lmjj1 + 1) ) + + * conjg( yl2(lmjj2 + 1) ) + + ! additional factor from symmetrization (below) +c cil = 0.5 * cil + + ! compute T-coefficients + ! using symmetrized uvu,uvd,dvu,dvd integrals + tuloulo(lo, m, lop, mp) + > = tuloulo(lo, m, lop, mp) + > + cil * ( sy1*ulovulo_sph(ltil1, ljj2, ljj1, lo, lop) + > + sy2*ulovulo_sph(ltil1, ljj1, ljj2, lop, lo) ) + + ENDDO!ljj2 + ENDDO!m + ENDDO!l + ENDDO!ljj1 + ENDDO!mp + ENDDO!lp + ENDDO!mtil1 + ENDDO!ltil1 + +! apw-lo + DO lop=1,nlo + lp = llo(lop) + DO mp=-lp,lp + DO ltil1=0,lwn + DO mtil1=-ltil1,ltil1 + mjj1=mtil1-mp + DO ljj1=0,lwn + lljj1 = ljj1 * (ljj1 + 1) + lmjj1 = lljj1 + mjj1 + lmini = abs(ljj1-lp) + lmaxi = ljj1+lp + ! Gaunt conditions (G1): + if((lmini.gt.ltil1).or.(lmaxi.lt.ltil1).or. + > (mod(lp+ltil1+ljj1,2).ne.0).or. + > (abs(mjj1).gt.ljj1)) cycle + + gc1 = gaunt1(ltil1, ljj1, lp, + > mtil1, mjj1, mp, lmaxd) + + DO l=0,lwn + ll = l*(l+1) + DO m=-l,l + lm = ll+m + mjj2=m-mtil1 + DO ljj2=0,lwn + lljj2 = ljj2 * (ljj2 + 1) + lmjj2 = lljj2 + mjj2 + lmini2 = abs(ltil1-ljj2) + lmaxi2 = ltil1+ljj2 + ! Gaunt conditions (G2): + if((lmini2.gt.l).or.(lmaxi2.lt.l).or. + > (mod(l+ltil1+ljj2,2).ne.0).or. + > (abs(mjj2).gt.ljj2)) cycle + + gc2 = gaunt1( l, ljj2, ltil1, + > m, mjj2, mtil1, lmaxd) + + ! set up prefactor + cil = ( ci ** (lp - l + ljj1 + ljj2) ) + + *( (-1.0) **ljj1 ) + + * gc1 * gc2 + + * conjg( yl1(lmjj1 + 1) ) + + * conjg( yl2(lmjj2 + 1) ) + + ! additional factor from symmetrization (below) +c cil = 0.5 * cil + + ! compute T-coefficients + ! using symmetrized uvu,uvd,dvu,dvd integrals + tulou(lm, lop, mp) + > = tulou(lm, lop, mp) + > + cil * ( sy1*ulovu_sph(ltil1, l, ljj2, ljj1, lop) + > + sy2*uvulo_sph(ltil1, l, ljj1, ljj2, lop) ) + + tulod(lm, lop, mp) + > = tulod(lm, lop, mp) + > + cil * ( sy1*ulovd_sph(ltil1, l, ljj2, ljj1, lop) + > + sy2*dvulo_sph(ltil1, l, ljj1, ljj2, lop) ) + + ENDDO!ljj2 + ENDDO!m + ENDDO!l + ENDDO!ljj1 + ENDDO!mp + ENDDO!lp + ENDDO!mtil1 + ENDDO!ltil1 + + DO ltil1=0,lwn + DO mtil1=-ltil1,ltil1 + DO l=0,lwn + ll = l*(l+1) + DO m=-l,l + lm = ll+m + mjj1=mtil1-m + DO ljj1=0,lwn + lljj1 = ljj1 * (ljj1 + 1) + lmjj1 = lljj1 + mjj1 + lmini = abs(ljj1-l) + lmaxi = ljj1+l + ! Gaunt conditions (G1): + if((lmini.gt.ltil1).or.(lmaxi.lt.ltil1).or. + > (mod(l+ltil1+ljj1,2).ne.0).or. + > (abs(mjj1).gt.ljj1)) cycle + + gc1 = gaunt1(ltil1, ljj1, l, + > mtil1, mjj1, m, lmaxd) + + DO lop=1,nlo + lp = llo(lop) + DO mp=-lp,lp + mjj2=mp-mtil1 + DO ljj2=0,lwn + lljj2 = ljj2 * (ljj2 + 1) + lmjj2 = lljj2 + mjj2 + lmini2 = abs(ltil1-ljj2) + lmaxi2 = ltil1+ljj2 + ! Gaunt conditions (G2): + if((lmini2.gt.lp).or.(lmaxi2.lt.lp).or. + > (mod(lp+ltil1+ljj2,2).ne.0).or. + > (abs(mjj2).gt.ljj2)) cycle + + gc2 = gaunt1( lp, ljj2, ltil1, + > mp, mjj2, mtil1, lmaxd) + + ! set up prefactor + cil = ( ci ** (l - lp + ljj1 + ljj2) ) + + *( (-1.0) **ljj1 ) + + * gc1 * gc2 + + * conjg( yl1(lmjj1 + 1) ) + + * conjg( yl2(lmjj2 + 1) ) + + ! additional factor from symmetrization (below) +c cil = 0.5 * cil + + ! compute T-coefficients + ! using symmetrized uvu,uvd,dvu,dvd integrals + tuulo(lm, lop, mp) + > = tuulo(lm, lop, mp) + > + cil * ( sy1*uvulo_sph(ltil1, l, ljj2, ljj1, lop) + > + sy2*ulovu_sph(ltil1, l, ljj1, ljj2, lop) ) + + tdulo(lm, lop, mp) + > = tdulo(lm, lop, mp) + > + cil * ( sy1*dvulo_sph(ltil1, l, ljj2, ljj1, lop) + > + sy2*ulovd_sph(ltil1, l, ljj1, ljj2, lop) ) + + ENDDO!ljj2 + ENDDO!m + ENDDO!l + ENDDO!ljj1 + ENDDO!mp + ENDDO!lp + ENDDO!mtil1 + ENDDO!ltil1 + + 444 CONTINUE + call cpu_time(t1) + t_sphint = t_sphint + t1-t0 + + IF( l_nns ) GOTO 555 +c************** NON-SPHERICAL CONTRIBUTION ***************c +c compute product of the three Gaunt coefficients c +c with the radial integrals (+prefactors) c +c*********************************************************c +c We deal with three Gaunt coefficients: c +c G1 = G( (ltil1,mtil1) , (lamda,mu) , (ltil2,mtil2) ) c +c G2 = G( (ltil1,mtil1) , (ljj1,mjj1) , (lp,mp) ) c +c G3 = G( (l,m) , (ljj2,mjj2) , (ltil2,mtil2) ) c +c*********************************************************c +c use Gaunt conditions to reduce number of operations. c +c coefficient G(L1,L2,L3) only nonzero if c +c a) l1 + l2 + l3 = even c +c b) |l2-l3| <= l1 <= l2+l3 c +c c) m1 = m2 + m3 c +c*********************************************************c + +! lo-lo + DO ltil1 = 0, lwn + DO mtil1 = -ltil1, ltil1 + DO 120 lh = 1, nh + lamda = llh(lh,nsym) + mems = nmem(lh,nsym) + DO 110 mem = 1, mems + mu = mlh(mem,lh,nsym) + mtil2 = mtil1-mu + DO 1111 ltil2 = 0, lwn + lmini = abs(ltil2 - lamda) + lmaxi = ltil2 + lamda + + ! Gaunt conditions (G1): + if((lmini.gt.ltil1).or.(lmaxi.lt.ltil1).or. + > (mod(ltil1+ltil2+lamda,2).ne.0).or. + > (abs(mtil2).gt.ltil2)) cycle + + gc1 = gaunt1(ltil1, lamda, ltil2, + > mtil1, mu, mtil2, lmaxd) + + DO 1001 lop = 1,nlo + lp = llo(lop) + if(lp.GT.lnonsph) cycle + DO mp = -lp, lp + mjj1 = mtil1 - mp + DO 140 ljj1 = 0, lwn + lljj1 = ljj1 * (ljj1 + 1) + lmjj1 = lljj1 + mjj1 + lmini2 = abs(lp-ljj1) + lmaxi2 = lp+ljj1 + + ! Gaunt conditions (G2): + if((lmini2.gt.ltil1).or.(lmaxi2.lt.ltil1).or. + > (mod(lp+ltil1+ljj1,2).ne.0).or. + > (abs(mjj1).gt.ljj1)) cycle + + gc2 = gaunt1(ltil1, ljj1, lp, + > mtil1, mjj1, mp, lmaxd) + + DO 100 lo = 1,nlo + l = llo(lo) + if(l.GT.lnonsph) cycle + DO m = -l, l + mjj2 = m - mtil2 + DO 901 ljj2 = 0, lwn + lljj2 = ljj2 * (ljj2 + 1) + lmjj2 = lljj2 + mjj2 + lmini3 = abs(ltil2 - ljj2) + lmaxi3 = ltil2 + ljj2 + + ! Gaunt conditions (G3): + if((lmini3.gt.l).or.(lmaxi3.lt.l).or. + > (mod(l+ltil2+ljj2,2).ne.0).or. + > (abs(mjj2).gt.ljj2)) cycle + + gc3 = gaunt1(l, ljj2, ltil2, + > m, mjj2, mtil2, lmaxd) + + ! set up prefactor + cil = ( ci ** (lp - l + ljj1 + ljj2) ) + + * conjg(clnu(mem,lh,nsym)) + + *( (-1.0) ** ljj1 ) + + * gc1 * gc2 * gc3 + + * conjg( yl1(lmjj1 + 1) ) + + * conjg( yl2(lmjj2 + 1) ) + + * invsfct + + ! compute T-coefficients + tuloulo(lo, m, lop, mp) + > = tuloulo(lo, m, lop, mp) + > + cil * ulovulo_non(lh, ljj2, ljj1, lo, lop) + + 901 CONTINUE !l + ENDDO !mjj2 + 100 CONTINUE !ljj2 + 140 CONTINUE !lp + ENDDO !mjj1 + 1001 CONTINUE !mjj1 + 1111 CONTINUE !ltil1 + 110 CONTINUE !mem + 120 CONTINUE !lh + ENDDO !mtil2 + ENDDO !ltil2 + +! apw-lo + DO ltil1 = 0, lwn + DO mtil1 = -ltil1, ltil1 + DO lh = 1, nh + lamda = llh(lh,nsym) + mems = nmem(lh,nsym) + DO mem = 1, mems + mu = mlh(mem,lh,nsym) + mtil2 = mtil1-mu + DO ltil2 = 0, lwn + lmini = abs(ltil2 - lamda) + lmaxi = ltil2 + lamda + + ! Gaunt conditions (G1): + if((lmini.gt.ltil1).or.(lmaxi.lt.ltil1).or. + > (mod(ltil1+ltil2+lamda,2).ne.0).or. + > (abs(mtil2).gt.ltil2)) cycle + + gc1 = gaunt1(ltil1, lamda, ltil2, + > mtil1, mu, mtil2, lmaxd) + + DO lop = 1,nlo + lp = llo(lop) + if(lp.GT.lnonsph) cycle + DO mp = -lp, lp + mjj1 = mtil1 - mp + DO ljj1 = 0, lwn + lljj1 = ljj1 * (ljj1 + 1) + lmjj1 = lljj1 + mjj1 + lmini2 = abs(lp-ljj1) + lmaxi2 = lp+ljj1 + + ! Gaunt conditions (G2): + if((lmini2.gt.ltil1).or.(lmaxi2.lt.ltil1).or. + > (mod(lp+ltil1+ljj1,2).ne.0).or. + > (abs(mjj1).gt.ljj1)) cycle + + gc2 = gaunt1(ltil1, ljj1, lp, + > mtil1, mjj1, mp, lmaxd) + + DO l = 0,lnonsph + ll = l*(l+1) + DO m = -l, l + lm = ll+m + mjj2 = m - mtil2 + DO ljj2 = 0, lwn + lljj2 = ljj2 * (ljj2 + 1) + lmjj2 = lljj2 + mjj2 + lmini3 = abs(ltil2 - ljj2) + lmaxi3 = ltil2 + ljj2 + + ! Gaunt conditions (G3): + if((lmini3.gt.l).or.(lmaxi3.lt.l).or. + > (mod(l+ltil2+ljj2,2).ne.0).or. + > (abs(mjj2).gt.ljj2)) cycle + + gc3 = gaunt1(l, ljj2, ltil2, + > m, mjj2, mtil2, lmaxd) + + ! set up prefactor + cil = ( ci ** (lp - l + ljj1 + ljj2) ) + + * conjg(clnu(mem,lh,nsym)) + + *( (-1.0) ** ljj1 ) + + * gc1 * gc2 * gc3 + + * conjg( yl1(lmjj1 + 1) ) + + * conjg( yl2(lmjj2 + 1) ) + + * invsfct + + ! compute T-coefficients + tulou(lm, lop, mp) + > = tulou(lm, lop, mp) + > + cil * ulovu_non(lh, l, ljj2, ljj1, lop) + + tulod(lm, lop, mp) + > = tulod(lm, lop, mp) + > + cil * ulovd_non(lh, l, ljj2, ljj1, lop) + + ENDDO !l + ENDDO !mjj2 + ENDDO !ljj2 + ENDDO !lp + ENDDO !mjj1 + ENDDO !mjj1 + + DO l = 0,lnonsph + ll = l*(l+1) + DO m = -l, l + lm = ll+m + mjj1 = mtil1 - m + DO ljj1 = 0, lwn + lljj1 = ljj1 * (ljj1 + 1) + lmjj1 = lljj1 + mjj1 + lmini2 = abs(l-ljj1) + lmaxi2 = l+ljj1 + + ! Gaunt conditions (G2): + if((lmini2.gt.ltil1).or.(lmaxi2.lt.ltil1).or. + > (mod(l+ltil1+ljj1,2).ne.0).or. + > (abs(mjj1).gt.ljj1)) cycle + + gc2 = gaunt1(ltil1, ljj1, l, + > mtil1, mjj1, m, lmaxd) + + DO lop = 1,nlo + lp = llo(lop) + if(lp.GT.lnonsph) cycle + DO mp = -lp, lp + mjj2 = mp - mtil2 + DO ljj2 = 0, lwn + lljj2 = ljj2 * (ljj2 + 1) + lmjj2 = lljj2 + mjj2 + lmini3 = abs(ltil2 - ljj2) + lmaxi3 = ltil2 + ljj2 + + ! Gaunt conditions (G3): + if((lmini3.gt.lp).or.(lmaxi3.lt.lp).or. + > (mod(lp+ltil2+ljj2,2).ne.0).or. + > (abs(mjj2).gt.ljj2)) cycle + + gc3 = gaunt1(lp, ljj2, ltil2, + > mp, mjj2, mtil2, lmaxd) + + ! set up prefactor + cil = ( ci ** (l - lp + ljj1 + ljj2) ) + + * conjg(clnu(mem,lh,nsym)) + + *( (-1.0) ** ljj1 ) + + * gc1 * gc2 * gc3 + + * conjg( yl1(lmjj1 + 1) ) + + * conjg( yl2(lmjj2 + 1) ) + + * invsfct + + ! compute T-coefficients + tuulo(lm, lop, mp) + > = tuulo(lm, lop, mp) + > + cil * uvulo_non(lh, l, ljj2, ljj1, lop) + + tdulo(lm, lop, mp) + > = tdulo(lm, lop, mp) + > + cil * dvulo_non(lh, l, ljj2, ljj1, lop) + + ENDDO !l + ENDDO !mjj2 + ENDDO !ljj2 + ENDDO !lp + ENDDO !mjj1 + ENDDO !mjj1 + + ENDDO !ltil2 + ENDDO !mem + ENDDO !lh + ENDDO !mtil1 + ENDDO !ltil1 + + 555 CONTINUE + call cpu_time(t0) + t_gggint = t_gggint + t0-t1 + +#if (defined(CPP_MPI) && !defined(CPP_T90)) + CALL MPI_BARRIER(MPI_COMM_WORLD,ierr) +#endif + + deallocate( ulovulo_sph, ulovulo_non) + deallocate( ulovu_sph, uvulo_sph, ulovd_sph, dvulo_sph ) + deallocate( ulovu_non, uvulo_non, ulovd_non, dvulo_non ) + deallocate( plo, dplo, plo_b, dplo_b ) + deallocate( x ) + + + END SUBROUTINE wann_uHu_tlo + END MODULE m_wann_uHu_tlo diff --git a/wannier/uhu/wann_uHu_util.F b/wannier/uhu/wann_uHu_util.F new file mode 100644 index 00000000..047d21b8 --- /dev/null +++ b/wannier/uhu/wann_uHu_util.F @@ -0,0 +1,54 @@ + module m_wann_uHu_util + implicit none + contains + + subroutine array_split(nkpts,nnodes,counts,displs) + implicit none + integer, intent(in) :: nkpts,nnodes + integer, intent(inout) :: counts(0:nnodes-1),displs(0:nnodes-1) + integer :: ratio,remainder,i + + counts = 0; displs = 0 + + ratio = nkpts / nnodes + remainder = mod(nkpts,nnodes) + do i=0,nnodes-1 + if(i c +c***************************************c +c J.-P. Hanke, Dec. 2015 c +c***************************************c + MODULE m_wann_uHu_vac + USE m_fleurenv + + CONTAINS + SUBROUTINE wann_uHu_vac( + > chi,l_noco,l_soc,zrfs,jspins,nlotot,qss,nbnd,z1,nmzxyd, + > nmzd,n2d,nv2d,k1d,k2d,k3d,n3d,nvac,ig,rgphs,nmzxy, + > nmz,delz,ig2,nq2,kv2,area,bmat,bbmat,evac,evac_b, + > bkpt,bkpt_b,vzxy,vz,nslibd,nslibd_b,jspin,jspin_b, + > ico,k1,k2,k3,k1_b,k2_b,k3_b,jspd,nvd,nbasfcn,neigd, + > z,z_b,nv,nv_b,omtil,gb,gb2,sign2,uHu) +#include "cpp_double.h" + use m_constants, only : pimach + use m_intgr, only : intgz0 + use m_dotir + use m_d2fdz2cmplx + + implicit none +c .. scalar Arguments.. + logical, intent (in) :: l_noco,l_soc,zrfs + integer, intent (in) :: nlotot,jspin_b,n2d,jspins,ico + integer, intent (in) :: nmzxyd,nmzd,nv2d,k1d,k2d,k3d,n3d,nbnd + integer, intent (in) :: nmzxy,nmz,nslibd,nslibd_b,nvac + integer, intent (in) :: jspin,jspd,nvd,nq2 + integer, intent (in) :: nbasfcn,neigd + real, intent (in) :: delz,z1,omtil,area + complex, intent (in) :: chi + +c ..array arguments.. + real, intent (in) :: bkpt(3),bkpt_b(3),evac(2),evac_b(2) + real, intent (in) :: qss(3) + real, intent (in) :: vz(nmzd,2,4) + real, intent (in) :: bbmat(3,3),bmat(3,3) + real, intent (in) :: rgphs(-k1d:k1d,-k2d:k2d,-k3d:k3d) + integer, intent (in) :: ig(-k1d:k1d,-k2d:k2d,-k3d:k3d) + integer, intent (in) :: ig2(n3d),nv(jspd),nv_b(jspd) + integer, intent (in) :: kv2(2,n2d) + integer, intent (in) :: gb(3),gb2(3) + integer, intent (in) :: k1(nvd,jspd),k2(nvd,jspd),k3(nvd,jspd) + integer, intent (in) :: k1_b(nvd,jspd),k2_b(nvd,jspd) + integer, intent (in) :: k3_b(nvd,jspd) + complex, intent (in) :: vzxy(nmzxyd,n2d-1,2) + complex, intent (inout) :: uHu(nbnd,nbnd) + +#if ( !defined(CPP_INVERSION) || defined(CPP_SOC) ) + complex, intent (in):: z(nbasfcn,neigd),z_b(nbasfcn,neigd) +#else + real, intent (in):: z(nbasfcn,neigd),z_b(nbasfcn,neigd) +#endif + +c ..local arrays.. + complex, allocatable :: ac(:,:),bc(:,:),ac_b(:,:),bc_b(:,:) + complex, allocatable :: vv(:),fac(:),fac_b(:),fac1(:) + complex, allocatable :: du(:),due(:),du_b(:),due_b(:) + complex, allocatable :: vxy(:,:),vxy_help(:) + real, allocatable :: dt(:),dte(:) + real, allocatable :: t(:),te(:),tei(:) + real, allocatable :: u(:,:),ue(:,:),v(:) + real, allocatable :: dt_b(:),dte_b(:) + real, allocatable :: t_b(:),te_b(:),tei_b(:) + real, allocatable :: u_b(:,:),ue_b(:,:) + real, allocatable :: zmsh(:) + +c ..local scalars.. + logical tail + real wronk,arg,zks,zks_b,tpi,vz0(2),vz0_b(2),scale,evacp,ev,const + real xx(nmz),xximag(nmz),phase,phase2,rk,rk_b + real :: qss1,qss2,xv,yv,s(3) + integer i,m,l,j,k,n,nv2,nv2_b,ivac,n2,n2_b,sign,ik,sign2 + integer :: lp,np0,np1,addnoco,addnoco2,jspin2,jspin2_b,jspin2H + complex :: av,bv,ic,c_1 +c complex :: tuu,tud,tdu,tdd + complex, allocatable :: tuu(:,:),tud(:,:),tdu(:,:),tdd(:,:) + complex, allocatable :: mat(:,:) + integer, allocatable :: kvac1(:),kvac2(:),map2(:) + integer, allocatable :: kvac1_b(:),kvac2_b(:),map2_b(:) + integer symvac,symvacvac,igvm2,igvm2i + integer :: j1,j2,i1,i2,ind3,ind2 + character(len=20) :: fname +c ..intrinsic functions.. + intrinsic aimag,cmplx,conjg,real,sqrt + +c.. external functions + external vacudz,vacuz + + allocate ( ac(nv2d,nslibd),bc(nv2d,nslibd), + + ac_b(nv2d,nslibd_b),bc_b(nv2d,nslibd_b), + + dt(nv2d),dte(nv2d),t(nv2d),te(nv2d), + + tei(nv2d),u(nmzd,nv2d),ue(nmzd,nv2d), + + dt_b(nv2d),dte_b(nv2d),t_b(nv2d),te_b(nv2d), + + tei_b(nv2d),u_b(nmzd,nv2d),ue_b(nmzd,nv2d), + + v(3),kvac1(nv2d),kvac2(nv2d),map2(nvd), + + kvac1_b(nv2d),kvac2_b(nv2d),map2_b(nvd), + + vv(nmzd),zmsh(nmzd),vxy(nmzxyd,n2d-1),vxy_help(n2d-1), + + fac1(nmzd), fac(nmzd), fac_b(nmzd), + + du(nmzd), due(nmzd), du_b(nmzd), due_b(nmzd), + + tuu(nv2d,nv2d),tud(nv2d,nv2d),tdu(nv2d,nv2d), + + tdd(nv2d,nv2d),mat(nslibd_b,nv2d) ) + + tpi = 2 * pimach() ; ic = cmplx(0.,1.) + tail = .true. + np0 = nmzxy + 1 + np1 = nmz + 1 + + jspin2 = jspin + jspin2_b = jspin_b + jspin2H = ico + if(l_soc.and.jspins.eq.1) then + jspin2 = 1 + jspin2_b = 1 + jspin2H = 1 + endif + +c.. determining the indexing array (in-plane stars) +c.. for the k-point + + wronk = 2.0 + const = 1.0 / ( sqrt(omtil)*wronk ) + + do ivac = 1,2 + vz0(ivac) = vz(nmz,ivac,jspin2) + vz0_b(ivac) = vz(nmz,ivac,jspin2_b) +c write(*,*)'vz0',ivac,vz0(ivac),vz0_b(ivac) + enddo + + n2 = 0 ; n2_b = 0 + + addnoco=0 + addnoco2=0 + if(l_noco.and.jspin.eq.2)then + addnoco=nv(1)+nlotot + endif + if(l_noco.and.jspin_b.eq.2)then + addnoco2=nv_b(1)+nlotot + endif + + do 40 k = 1,nv(jspin) + do 30 j = 1,n2 + if ( k1(k,jspin).eq.kvac1(j) .and. + + k2(k,jspin).eq.kvac2(j) ) then + map2(k) = j + goto 40 + endif + 30 continue + n2 = n2 + 1 + + IF(n2>nv2d) then + write(*,*)n2,nv2d,'jspin',jspin + endif + + IF (n2>nv2d) CALL fleur_err("wannier uHu vac",calledby + + ="wann_uHu_vac") + + kvac1(n2) = k1(k,jspin) + kvac2(n2) = k2(k,jspin) + map2(k) = n2 + 40 continue + + +c.. and for the b-point + + do 41 k = 1,nv_b(jspin_b) + do 31 j = 1,n2_b + if ( k1_b(k,jspin_b).eq.kvac1_b(j) .and. + + k2_b(k,jspin_b).eq.kvac2_b(j) ) then + map2_b(k) = j + goto 41 + endif + 31 continue + n2_b = n2_b + 1 + + IF(n2_b>nv2d) then + write(*,*)n2_b,nv2d,'jspin_b',jspin_b + endif + + IF (n2_b>nv2d) CALL fleur_err("wannier uHu vac",calledby + + ="wann_uHu_vac") + + kvac1_b(n2_b) = k1_b(k,jspin_b) + kvac2_b(n2_b) = k2_b(k,jspin_b) + map2_b(k) = n2_b + 41 continue + + + + +c...cycle by the vacua + do 140 ivac = 1,2!nvac + + sign = 3. - 2.*ivac + evacp = evac(ivac) + + vxy(:,:) = vzxy(:,:,ivac) + IF(l_noco) THEN ! symmetrization + IF (nvac.EQ.1 .and. ivac.EQ.2 .AND.(.NOT.zrfs) ) THEN + DO i=1,nmzxy + DO igvm2 = 2,nq2 + igvm2i = ig2(ig(-kv2(1,igvm2),-kv2(2,igvm2),0)) + vxy_help(igvm2-1) = vxy(i,igvm2i-1) + ENDDO + DO igvm2 = 2,nq2 + vxy(i,igvm2-1) = vxy_help(igvm2-1) + ENDDO + ENDDO + ENDIF + ENDIF + + tuu = cmplx(0.,0.) + tud = cmplx(0.,0.) + tdu = cmplx(0.,0.) + tdd = cmplx(0.,0.) + + nv2 = n2 ; nv2_b = n2_b + +c.. the body of the routine + + qss1=0.0 + qss2=0.0 + if(l_noco.and.jspin.eq.1)then + qss1=-qss(1)/2.0 + qss2=-qss(2)/2.0 + elseif(l_noco.and.jspin.eq.2)then + qss1=qss(1)/2.0 + qss2=qss(2)/2.0 + endif + + do ik = 1,nv2 + v(1) = bkpt(1) + kvac1(ik) + qss1 + v(2) = bkpt(2) + kvac2(ik) + qss2 + v(3) = 0. + ev = evacp - 0.5*dotirp(v,v,bbmat) + call vacuz(ev,vz(1,ivac,jspin2),vz0(ivac),nmz,delz,t(ik), + + dt(ik),u(1,ik)) + call vacudz(ev,vz(1,ivac,jspin2),vz0(ivac),nmz,delz,te(ik), + + dte(ik),tei(ik),ue(1,ik),dt(ik), + + u(1,ik)) + scale = wronk/ (te(ik)*dt(ik)-dte(ik)*t(ik)) + te(ik) = scale*te(ik) + dte(ik) = scale*dte(ik) + tei(ik) = scale*tei(ik) + do j = 1,nmz + ue(j,ik) = scale*ue(j,ik) + enddo + enddo +c-----> construct a and b coefficients for the k-point + symvacvac=1 +c if (nvac==1) symvacvac=2 + do symvac=1,symvacvac + do i = 1,nv2d + do n = 1,nslibd + ac(i,n) = cmplx(0.0,0.0) + bc(i,n) = cmplx(0.0,0.0) + enddo + do n = 1,nslibd_b + ac_b(i,n) = cmplx(0.0,0.0) + bc_b(i,n) = cmplx(0.0,0.0) + enddo + enddo + + if (symvac==2) sign=-1.0 + + do k = 1,nv(jspin) + l = map2(k) + zks = k3(k,jspin)*bmat(3,3)*sign + arg = zks*z1 + c_1 = cmplx(cos(arg),sin(arg)) * const + av = -c_1 * cmplx( dte(l),zks*te(l) ) + bv = c_1 * cmplx( dt(l),zks* t(l) ) +c-----> loop over basis functions + do n = 1,nslibd + ac(l,n) = ac(l,n) + z(k+addnoco,n)*av + bc(l,n) = bc(l,n) + z(k+addnoco,n)*bv + enddo + enddo + + +c...now for the k+b point + + evacp = evac_b(ivac) + do ik = 1,nv2_b + v(1) = bkpt_b(1) + kvac1_b(ik) + qss1 + v(2) = bkpt_b(2) + kvac2_b(ik) + qss2 + v(3) = 0. + ev = evacp - 0.5*dotirp(v,v,bbmat) + call vacuz(ev,vz(1,ivac,jspin2_b),vz0_b(ivac),nmz,delz, + + t_b(ik),dt_b(ik),u_b(1,ik)) + call vacudz(ev,vz(1,ivac,jspin2_b),vz0_b(ivac),nmz,delz, + + te_b(ik),dte_b(ik),tei_b(ik),ue_b(1,ik),dt_b(ik), + + u_b(1,ik)) + scale = wronk/ (te_b(ik)*dt_b(ik)-dte_b(ik)*t_b(ik)) + te_b(ik) = scale*te_b(ik) + dte_b(ik) = scale*dte_b(ik) + tei_b(ik) = scale*tei_b(ik) + do j = 1,nmz + ue_b(j,ik) = scale*ue_b(j,ik) + enddo + enddo +c-----> construct a and b coefficients for the k+b point + + do k = 1,nv_b(jspin_b) + l = map2_b(k) + zks = k3_b(k,jspin_b)*bmat(3,3)*sign + arg = zks*z1 + c_1 = cmplx(cos(arg),sin(arg)) * const + av = -c_1 * cmplx( dte_b(l),zks*te_b(l) ) + bv = c_1 * cmplx( dt_b(l),zks*t_b(l) ) +c-----> loop over basis functions + do n = 1,nslibd_b + ac_b(l,n) = ac_b(l,n) + z_b(k+addnoco2,n)*av + bc_b(l,n) = bc_b(l,n) + z_b(k+addnoco2,n)*bv + enddo + enddo + + + ! set up z-mesh and plane-wave factors + zks = gb(3) *bmat(3,3) ! TODO: different sign before + zks_b= -gb2(3)*bmat(3,3) ! TODO: different sign before + do i=1,nmz + zmsh(i)= ( z1 + (i-1)*delz )*sign + fac(i) = cmplx( cos(zmsh(i)*zks), sin(zmsh(i)*zks) ) + fac_b(i)= cmplx( cos(zmsh(i)*zks_b),sin(zmsh(i)*zks_b)) + fac1(i) = fac(i) * fac_b(i) + enddo + + + ! calculate uHu matrix elements + do l = 1,nv2 + + j1 = kvac1(l) - gb(1) + j2 = kvac2(l) - gb(2) + + do lp = 1,nv2_b + i1 = j1 - kvac1_b(lp) + gb2(1) + i2 = j2 - kvac2_b(lp) + gb2(2) + +c i1 = -i1 +c i2 = -i2 + + ind3 = ig(sign2*i1,sign2*i2,0) + IF (ind3.EQ.0) CYCLE + + phase = rgphs(i1,i2,0) ! TODO: sign also here? + phase2= rgphs(sign2*i1,sign2*i2,0) + if(phase.ne.phase2) then + stop 'rgphs in wann_uHu_vac' + endif + + ind2 = ig2(ind3) + IF (ind2.EQ.0) CALL fleur_err("error in map2 for 2-d stars", + > calledby="wann_uHu_vac") + ind2 = ind2 - 1 + IF (ind2.NE.0) THEN ! warping components G=/=0 + ! need integral with vxy and plane-waves + ! tuu + DO i=1,nmzxy + xx(np0-i) = u(i,l)*u_b(i,lp) + > * real( fac1(i)*vxy(i,ind2) ) + xximag(np0-i) = u(i,l)*u_b(i,lp) + > * aimag( fac1(i)*vxy(i,ind2) ) + ENDDO + CALL intgz0(xx,delz,nmzxy,xv,tail) + CALL intgz0(xximag,delz,nmzxy,yv,tail) + tuu(lp,l) = phase*cmplx(xv,yv) + + ! tud + DO i=1,nmzxy + xx(np0-i) = u(i,l)*ue_b(i,lp) + > * real( fac1(i)*vxy(i,ind2) ) + xximag(np0-i) = u(i,l)*ue_b(i,lp) + > * aimag( fac1(i)*vxy(i,ind2) ) + ENDDO + CALL intgz0(xx,delz,nmzxy,xv,tail) + CALL intgz0(xximag,delz,nmzxy,yv,tail) + tud(lp,l) = phase*cmplx(xv,yv) + + ! tdu + DO i=1,nmzxy + xx(np0-i) = ue(i,l)*u_b(i,lp) + > * real( fac1(i)*vxy(i,ind2) ) + xximag(np0-i) = ue(i,l)*u_b(i,lp) + > * aimag( fac1(i)*vxy(i,ind2) ) + ENDDO + CALL intgz0(xx,delz,nmzxy,xv,tail) + CALL intgz0(xximag,delz,nmzxy,yv,tail) + tdu(lp,l) = phase*cmplx(xv,yv) + + ! tdd + DO i=1,nmzxy + xx(np0-i) = ue(i,l)*ue_b(i,lp) + > * real( fac1(i)*vxy(i,ind2) ) + xximag(np0-i) = ue(i,l)*ue_b(i,lp) + > * aimag( fac1(i)*vxy(i,ind2) ) + ENDDO + CALL intgz0(xx,delz,nmzxy,xv,tail) + CALL intgz0(xximag,delz,nmzxy,yv,tail) + tdd(lp,l) = phase*cmplx(xv,yv) + + ELSE ! non-warping components G==0 + ! need integral with H(z) = -1/2 d2/dz2 + vz + (G+k)^2 + + IF ( (ico.EQ.1) .OR. (ico.EQ.2) ) THEN ! spin-diagonal + + ! determine second derivative of (u*fac) etc. + CALL d2fdz2cmplx(nmzd,nmz,zmsh,delz, + > u(:,l),fac,du) + CALL d2fdz2cmplx(nmzd,nmz,zmsh,delz, + > ue(:,l),fac,due) + CALL d2fdz2cmplx(nmzd,nmz,zmsh,delz, + > u_b(:,lp),fac_b,du_b) + CALL d2fdz2cmplx(nmzd,nmz,zmsh,delz, + > ue_b(:,lp),fac_b,due_b) + + ! determine |G+k+b1|^2 and |G'+k+b2|^2 + s(1) = bkpt(1) + kvac1(l) + s(2) = bkpt(2) + kvac2(l) + s(3) = 0.0 + rk = dotirp(s,s,bbmat) + + s(1) = bkpt_b(1) + kvac1_b(lp) + s(2) = bkpt_b(2) + kvac2_b(lp) + s(3) = 0.0 + rk_b = dotirp(s,s,bbmat) + +c ! no kinetic energy if jspin =/= jspin_b +c if(jspin.ne.jspin_b) then +c rk = 0.0 +c rk_b = 0.0 +c du=cmplx(0.0,0.0) +c due=cmplx(0.0,0.0) +c du_b=cmplx(0.0,0.0) +c due_b=cmplx(0.0,0.0) +c endif + +c rk_b=0.0 +c du_b=cmplx(0.,0.) +c due_b=cmplx(0.,0.) + + ! tuu + DO i=1,nmz + xx(np1-i) = u(i,l)*u_b(i,lp) + > * real(fac1(i)) * ( vz(i,ivac,jspin2H)+0.25*(rk+rk_b) ) + > - 0.25*real( fac(i)*u(i,l)*du_b(i) + > + du(i)*u_b(i,lp)*fac_b(i) ) + + xximag(np1-i) = u(i,l)*u_b(i,lp) + > * aimag(fac1(i)) *( vz(i,ivac,jspin2H)+0.25*(rk+rk_b) ) + > - 0.25*aimag( fac(i)*u(i,l)*du_b(i) + > + du(i)*u_b(i,lp)*fac_b(i) ) + ENDDO + CALL intgz0(xx,delz,nmz,xv,tail) + CALL intgz0(xximag,delz,nmz,yv,tail) + tuu(lp,l) = cmplx(xv,yv) + + ! tud + DO i=1,nmz + xx(np1-i) = u(i,l)*ue_b(i,lp) + > * real(fac1(i)) * ( vz(i,ivac,jspin2H)+0.25*(rk+rk_b) ) + > - 0.25*real( fac(i)*u(i,l)*due_b(i) + > + du(i)*ue_b(i,lp)*fac_b(i) ) + + xximag(np1-i) = u(i,l)*ue_b(i,lp) + > * aimag(fac1(i)) *( vz(i,ivac,jspin2H)+0.25*(rk+rk_b) ) + > - 0.25*aimag( fac(i)*u(i,l)*due_b(i) + > + du(i)*ue_b(i,lp)*fac_b(i) ) + ENDDO + CALL intgz0(xx,delz,nmz,xv,tail) + CALL intgz0(xximag,delz,nmz,yv,tail) + tud(lp,l) = cmplx(xv,yv) + + ! tdu + DO i=1,nmz + xx(np1-i) = ue(i,l)*u_b(i,lp) + > * real(fac1(i)) * ( vz(i,ivac,jspin2H)+0.25*(rk+rk_b) ) + > - 0.25*real( fac(i)*ue(i,l)*du_b(i) + > + due(i)*u_b(i,lp)*fac_b(i) ) + + xximag(np1-i) = ue(i,l)*u_b(i,lp) + > * aimag(fac1(i)) *( vz(i,ivac,jspin2H)+0.25*(rk+rk_b) ) + > - 0.25*aimag( fac(i)*ue(i,l)*du_b(i) + > + due(i)*u_b(i,lp)*fac_b(i) ) + ENDDO + CALL intgz0(xx,delz,nmz,xv,tail) + CALL intgz0(xximag,delz,nmz,yv,tail) + tdu(lp,l) = cmplx(xv,yv) + + ! tdd + DO i=1,nmz + xx(np1-i) = ue(i,l)*ue_b(i,lp) + > * real(fac1(i)) * ( vz(i,ivac,jspin2H)+0.25*(rk+rk_b) ) + > - 0.25*real( fac(i)*ue(i,l)*due_b(i) + > + due(i)*ue_b(i,lp)*fac_b(i) ) + + xximag(np1-i) = ue(i,l)*ue_b(i,lp) + > * aimag(fac1(i)) *( vz(i,ivac,jspin2H)+0.25*(rk+rk_b) ) + > - 0.25*aimag( fac(i)*ue(i,l)*due_b(i) + > + due(i)*ue_b(i,lp)*fac_b(i) ) + ENDDO + CALL intgz0(xx,delz,nmz,xv,tail) + CALL intgz0(xximag,delz,nmz,yv,tail) + tdd(lp,l) = cmplx(xv,yv) + + ELSE ! spin-off-diagonal + + DO i=1,nmz + vv(i) = cmplx( vz(i,ivac,3), vz(i,ivac,4) ) + ENDDO + IF ( ico.EQ.4 ) vv = conjg(vv) + + ! tuu + DO i=1,nmz + xx(np1-i) = u(i,l)*u_b(i,lp) + > * real( fac1(i)*vv(i) ) + xximag(np1-i) = u(i,l)*u_b(i,lp) + > * aimag( fac1(i)*vv(i) ) + ENDDO + CALL intgz0(xx,delz,nmz,xv,tail) + CALL intgz0(xximag,delz,nmz,yv,tail) + tuu(lp,l) = cmplx(xv,yv) + + ! tud + DO i=1,nmz + xx(np1-i) = u(i,l)*ue_b(i,lp) + > * real( fac1(i)*vv(i) ) + xximag(np1-i) = u(i,l)*ue_b(i,lp) + > * aimag( fac1(i)*vv(i) ) + ENDDO + CALL intgz0(xx,delz,nmz,xv,tail) + CALL intgz0(xximag,delz,nmz,yv,tail) + tud(lp,l) = cmplx(xv,yv) + + ! tdu + DO i=1,nmz + xx(np1-i) = ue(i,l)*u_b(i,lp) + > * real( fac1(i)*vv(i) ) + xximag(np1-i) = ue(i,l)*u_b(i,lp) + > * aimag( fac1(i)*vv(i) ) + ENDDO + CALL intgz0(xx,delz,nmz,xv,tail) + CALL intgz0(xximag,delz,nmz,yv,tail) + tdu(lp,l) = cmplx(xv,yv) + + ! tdd + DO i=1,nmz + xx(np1-i) = ue(i,l)*ue_b(i,lp) + > * real( fac1(i)*vv(i) ) + xximag(np1-i) = ue(i,l)*ue_b(i,lp) + > * aimag( fac1(i)*vv(i) ) + ENDDO + CALL intgz0(xx,delz,nmz,xv,tail) + CALL intgz0(xximag,delz,nmz,yv,tail) + tdd(lp,l) = cmplx(xv,yv) + + ENDIF !(ico.eq.1).or.(ico.eq.2) + + ENDIF !(ind2.ne.0) + + + ! contraction of integrals with a,b coefficients + ! yields contribution to uHu matrix +c do i = 1,nslibd +c do j = 1,nslibd_b +c uHu(i,j) = uHu(i,j) + area* +c * ( ac(l,i)*conjg(ac_b(lp,j))*tuu + +c + ac(l,i)*conjg(bc_b(lp,j))*tud + +c * bc(l,i)*conjg(ac_b(lp,j))*tdu + +c + bc(l,i)*conjg(bc_b(lp,j))*tdd ) +c enddo +c enddo + + + enddo ! lp + enddo ! l + + if(.false.) then + call CPP_BLAS_cgemm('C','N',nslibd_b,nv2d,nv2d,cmplx(area), + > ac_b(1,1),nv2d,tuu(1,1),nv2d,cmplx(0.0), + > mat(1,1),nslibd_b) + call CPP_BLAS_cgemm('T','T',nslibd,nslibd_b,nv2d,chi, + > ac(1,1),nv2d,mat(1,1),nslibd_b,cmplx(1.0), + > uHu,nbnd) + + call CPP_BLAS_cgemm('C','N',nslibd_b,nv2d,nv2d,cmplx(area), + > bc_b(1,1),nv2d,tud(1,1),nv2d,cmplx(0.0), + > mat(1,1),nslibd_b) + call CPP_BLAS_cgemm('T','T',nslibd,nslibd_b,nv2d,chi, + > ac(1,1),nv2d,mat(1,1),nslibd_b,cmplx(1.0), + > uHu,nbnd) + + call CPP_BLAS_cgemm('C','N',nslibd_b,nv2d,nv2d,cmplx(area), + > ac_b(1,1),nv2d,tdu(1,1),nv2d,cmplx(0.0), + > mat(1,1),nslibd_b) + call CPP_BLAS_cgemm('T','T',nslibd,nslibd_b,nv2d,chi, + > bc(1,1),nv2d,mat(1,1),nslibd_b,cmplx(1.0), + > uHu,nbnd) + + call CPP_BLAS_cgemm('C','N',nslibd_b,nv2d,nv2d,cmplx(area), + > bc_b(1,1),nv2d,tdd(1,1),nv2d,cmplx(0.0), + > mat(1,1),nslibd_b) + call CPP_BLAS_cgemm('T','T',nslibd,nslibd_b,nv2d,chi, + > bc(1,1),nv2d,mat(1,1),nslibd_b,cmplx(1.0), + > uHu,nbnd) + endif + + if(.true.)then ! standard so far + call CPP_BLAS_cgemm('T','N',nslibd_b,nv2d,nv2d,cmplx(area), + > ac_b(1,1),nv2d,tuu(1,1),nv2d,cmplx(0.0), + > mat(1,1),nslibd_b) + call CPP_BLAS_cgemm('T','C',nslibd,nslibd_b,nv2d,chi, + > ac(1,1),nv2d,mat(1,1),nslibd_b,cmplx(1.0), + > uHu,nbnd) + + call CPP_BLAS_cgemm('T','N',nslibd_b,nv2d,nv2d,cmplx(area), + > bc_b(1,1),nv2d,tud(1,1),nv2d,cmplx(0.0), + > mat(1,1),nslibd_b) + call CPP_BLAS_cgemm('T','C',nslibd,nslibd_b,nv2d,chi, + > ac(1,1),nv2d,mat(1,1),nslibd_b,cmplx(1.0), + > uHu,nbnd) + + call CPP_BLAS_cgemm('T','N',nslibd_b,nv2d,nv2d,cmplx(area), + > ac_b(1,1),nv2d,tdu(1,1),nv2d,cmplx(0.0), + > mat(1,1),nslibd_b) + call CPP_BLAS_cgemm('T','C',nslibd,nslibd_b,nv2d,chi, + > bc(1,1),nv2d,mat(1,1),nslibd_b,cmplx(1.0), + > uHu,nbnd) + + call CPP_BLAS_cgemm('T','N',nslibd_b,nv2d,nv2d,cmplx(area), + > bc_b(1,1),nv2d,tdd(1,1),nv2d,cmplx(0.0), + > mat(1,1),nslibd_b) + call CPP_BLAS_cgemm('T','C',nslibd,nslibd_b,nv2d,chi, + > bc(1,1),nv2d,mat(1,1),nslibd_b,cmplx(1.0), + > uHu,nbnd) + endif + + enddo !symvac +c... cycle by the vacua finishes + 140 enddo + + deallocate ( ac,bc,dt,dte,t,te,tei,u,ue, + + v,kvac1,kvac2,map2 ) + deallocate ( ac_b,bc_b,dt_b,dte_b,t_b,te_b,tei_b,u_b,ue_b, + + kvac1_b,kvac2_b,map2_b ) + deallocate ( vxy, vxy_help, vv, zmsh, fac1, fac, fac_b ) + deallocate ( du,due,du_b,due_b ) + deallocate ( tuu,tud,tdu,tdd,mat ) + +c call fleur_end("stop") + + END SUBROUTINE wann_uHu_vac + END MODULE m_wann_uHu_vac diff --git a/wannier/uhu/wann_write_uHu.F b/wannier/uhu/wann_write_uHu.F new file mode 100644 index 00000000..a9c11e01 --- /dev/null +++ b/wannier/uhu/wann_write_uHu.F @@ -0,0 +1,151 @@ +c**************************c +c write out uHu matrix c +c**************************c + module m_wann_write_uHu + contains + subroutine wann_write_uHu( + > jspin2,l_p0,fullnkpts,nntot,nntot2,wann, + > nbnd,bpt,gb,isize,irank,fending,ftype, + < uHu_in,nkpt_loc,counts,displs,nnodes, + > l_unformatted,l_symcc,l_check) + use m_types + use m_fleurenv + use m_wann_uHu_symcheck + + implicit none + integer, intent(in) :: jspin2 + logical, intent(in) :: l_p0,l_unformatted,l_symcc,l_check + integer, intent(in) :: fullnkpts,nkpt_loc + integer, intent(in) :: nntot,nntot2,nnodes + type(t_wann),intent(in) :: wann + + integer, intent(in) :: nbnd + integer, intent(in) :: bpt(nntot,fullnkpts) + integer, intent(in) :: gb(3,nntot,fullnkpts) + integer, intent(in) :: counts(0:nnodes-1),displs(0:nnodes-1) + + integer, intent(in) :: isize,irank + + CHARACTER(len=12), INTENT(IN) :: fending !for file ending + CHARACTER(len=*), INTENT(IN) :: ftype + complex, intent(inout) :: uHu_in(nbnd,nbnd,nntot2,nntot,nkpt_loc) + + complex, allocatable :: uHu(:,:,:,:,:) + integer :: ikpt,i,j,length + integer :: ikpt_b,ikpt_b2 + character(len=3) :: spin12(2) + integer :: cpu_index + data spin12/'WF1' , 'WF2'/ + +#ifdef CPP_MPI + include 'mpif.h' + integer :: ierr(3) + integer :: stt(MPI_STATUS_SIZE) +#include "cpp_double.h" +#endif + + if(isize.gt.1) then + if(l_p0) allocate(uHu(nbnd,nbnd,nntot2,nntot,fullnkpts)) +#ifdef CPP_MPI +c****************************************************** +c Collect contributions to the mmnk matrix from the +c various processors. +c****************************************************** + length = nbnd*nbnd*nntot2*nntot + CALL MPI_BARRIER(MPI_COMM_WORLD,ierr) + CALL MPI_GATHERV( + > uHu_in,length*nkpt_loc,MPI_DOUBLE_COMPLEX, + > uHu,length*counts,length*displs,MPI_DOUBLE_COMPLEX, + > 0,MPI_COMM_WORLD,ierr) +#else +c uHu = uHu_in +#endif + endif + +c****************************************************** +c Write mmnk matrix to file. +c****************************************************** + if (l_p0) then + write(*,*)'symmetry-complete uHu: ',l_symcc + + if(l_symcc.and.(nntot.ne.nntot2)) stop 'wann_write_uHu' + + if(.false. .and. l_symcc) then + ! exploit symmetry to complete matrix + do ikpt = 1,fullnkpts + do ikpt_b = 1,nntot + do ikpt_b2 = 1,ikpt_b-1 + do i=1,nbnd + do j=1,nbnd + if(isize.gt.1) then + uHu(j,i,ikpt_b,ikpt_b2,ikpt) + > = conjg(uHu(i,j,ikpt_b2,ikpt_b,ikpt)) + else + uHu_in(j,i,ikpt_b,ikpt_b2,ikpt) + > = conjg(uHu_in(i,j,ikpt_b2,ikpt_b,ikpt)) + endif + enddo + enddo + enddo + enddo + enddo + endif + + if(.not.l_unformatted) then + open (305,file=spin12(jspin2)//trim(fending)//'.uHu' + > //trim(ftype)) + write (305,*) 'Elements uHu at k+b1 and k+b2' + write (305,'(3i5)') nbnd,fullnkpts,nntot,nntot2 + do ikpt = 1,fullnkpts + do ikpt_b = 1,nntot + do ikpt_b2 = 1,nntot2 + write(305,'(i6,i6,i6)')ikpt,ikpt_b,ikpt_b2 + do i = 1,nbnd + do j = 1,nbnd + if(isize.gt.1) then + write (305,'(2f24.18)') + & real(uHu(j,i,ikpt_b2,ikpt_b,ikpt)), + & -aimag(uHu(j,i,ikpt_b2,ikpt_b,ikpt)) + else + write (305,'(2f24.18)') + & real(uHu_in(j,i,ikpt_b2,ikpt_b,ikpt)), + & -aimag(uHu_in(j,i,ikpt_b2,ikpt_b,ikpt)) + endif + enddo + enddo + enddo + enddo + enddo !ikpt + close (305) + else + open (305,file=spin12(jspin2)//trim(fending)//'.uHu' + > //trim(ftype),form='unformatted') + write (305) nbnd,fullnkpts,nntot,nntot2 + write (305) bpt,gb + if(isize.gt.1) then + write (305) conjg(uHu) + else + write (305) conjg(uHu_in) + endif + close (305) + endif + + if((trim(ftype).ne.'_kq').and.l_check) then + write(*,*)'perform symcheck...' + if(isize.gt.1) then + CALL wann_uHu_symcheck(uHu,nbnd,nntot,nntot2,fullnkpts) + else + CALL wann_uHu_symcheck(uHu_in,nbnd,nntot,nntot2,fullnkpts) + endif + endif + + endif !l_p0 + + if(allocated(uHu)) deallocate( uHu ) + +#ifdef CPP_MPI + CALL MPI_BARRIER(MPI_COMM_WORLD,ierr) +#endif + + end subroutine wann_write_uHu + end module m_wann_write_uHu diff --git a/wannier/wann_1dvacabcof.F b/wannier/wann_1dvacabcof.F new file mode 100644 index 00000000..60c97ee5 --- /dev/null +++ b/wannier/wann_1dvacabcof.F @@ -0,0 +1,151 @@ +c******************************************************** +c calculate a-, and b-coefficients of 1d-vacuum +c Y. Mokrousov from Frank's routine, January 2007 +c******************************************************** + module m_wann_1dvacabcof + contains + subroutine wann_1dvacabcof( + > nv2d,nslibd,nmzd,nmz,omtil,vz, + > nv,bkpt,z1,odi,ods, + > nvd,k1,k2,k3,evac, + > bbmat,delz,bmat,nbasfcn,neigd,z, + > n2d,n3d,ig,nmzxy,nmzxyd,ig2,sk2, + > phi2,k1d,k2d,k3d, + < ac,bc,u,ue,addnoco,l_ss,qss,jspin) + + use m_dotir + use m_od_types + use m_od_abvac + use m_constants, only : pimach + use m_cylbes + use m_dcylbs + implicit none + + integer,intent(in)::nv2d,n2d,n3d + integer,intent(in)::nslibd + integer,intent(in)::k1d,k2d,k3d + integer,intent(in)::nmzd,nmzxyd + integer,intent(in)::nmz,nmzxy + integer,intent(in)::nbasfcn,neigd + real,intent(in)::omtil + real,intent(in)::vz(nmzd,2) + real,intent(in)::evac(2) + real,intent(in)::bbmat(3,3) + real,intent(in)::delz + real,intent(in)::bmat(3,3) + real,intent(in)::z1 + integer,intent(in)::nv + integer,intent(in)::nvd + integer,intent(in)::k1(nvd) + integer,intent(in)::k2(nvd) + integer,intent(in)::k3(nvd) + integer,intent(in)::ig(-k1d:k1d,-k2d:k2d,-k3d:k3d),ig2(n3d) + integer,intent(in)::addnoco,jspin + real,intent(in) :: sk2(n2d),phi2(n2d) + real,intent(in)::bkpt(3),qss(3) + logical,intent(in)::l_ss + + type (od_inp), intent (in) :: odi + type (od_sym), intent (in) :: ods + + complex,intent(out)::ac(nv2d,-odi%mb:odi%mb,nslibd) + complex,intent(out)::bc(nv2d,-odi%mb:odi%mb,nslibd) + real,intent(out)::u(nmzd,nv2d,-odi%mb:odi%mb) + real,intent(out)::ue(nmzd,nv2d,-odi%mb:odi%mb) +#if ( !defined(CPP_INVERSION) || defined(CPP_SOC) ) + COMPLEX, INTENT (IN) :: z(nbasfcn,neigd) +#else + REAL, INTENT (IN) :: z(nbasfcn,neigd) +#endif + real wronk,const,wronk_1 + complex av,bv,ic + real, allocatable :: dt(:,:),dte(:,:) + real, allocatable :: t(:,:),te(:,:),tei(:,:) + integer n2,k,nv2,ik,n,l,ispin + real vz0,evacp,ev,zks,arg,tpi + integer kvac3(nv2d),map1(nvd),i,j,irec3,irec2,m,nvac + real bess(-odi%mb:odi%mb),dbss(-odi%mb:odi%mb) + real qssbti(3,2) + ic = cmplx(0.,1.) + tpi = 2.*pimach() + wronk = 2.0 + const = 1.0 / ( sqrt(omtil)*wronk ) + allocate (dt(nv2d,-odi%mb:odi%mb),dte(nv2d,-odi%mb:odi%mb), + & t(nv2d,-odi%mb:odi%mb),te(nv2d,-odi%mb:odi%mb), + & tei(nv2d,-odi%mb:odi%mb)) + + nvac = 1 + vz0 = vz(nmz,nvac) + + n2 = 0 + do 35 k = 1,nv + do 45 j = 1,n2 + if (k3(k).eq.kvac3(j)) then + map1(k) = j + goto 35 + end if + 45 continue + n2 = n2 + 1 + if (n2.gt.nv2d) stop 'wann_plot:vac' + kvac3(n2) = k3(k) + map1(k) = n2 + 35 continue + nv2 = n2 + + ac(:,:,:) = cmplx(0.,0.) ; bc (:,:,:) = cmplx(0.,0.) + + evacp = evac(1) + if(l_ss) then + qssbti(1,1)=-qss(1)/2. + qssbti(2,1)=-qss(2)/2. + qssbti(3,1)=-qss(3)/2. + qssbti(1,2)=+qss(1)/2. + qssbti(2,2)=+qss(2)/2. + qssbti(3,2)=+qss(3)/2. + else + qssbti(:,:)=0.0 + endif + ispin=1 + call od_abvac( + > z1,nmzxyd,nmzd,nv2d,k1d,k2d,k3d,n2d,n3d, + > ig,odi%ig,tpi,qssbti(3,jspin), + > nmzxy,nmz,delz,ig2,odi%n2d,bbmat,wronk,evacp,bkpt, + > odi%M,odi%mb,vz(1,nvac),kvac3(1),nv2, + > t(1,-odi%mb),dt(1,-odi%mb),u(1,1,-odi%mb), + < te(1,-odi%mb),dte(1,-odi%mb),tei(1,-odi%mb), + < ue(1,1,-odi%mb)) + + do k = 1,nv + l = map1(k) + irec3 = ig(k1(k),k2(k),k3(k)) + if (irec3.ne.0) then + irec2 = ig2(irec3) + zks = sk2(irec2)*z1 + arg = phi2(irec2) + call cylbes(odi%mb,zks,bess) + call dcylbs(odi%mb,zks,bess,dbss) + do m = -odi%mb,odi%mb + wronk_1 = t(l,m)*dte(l,m) - te(l,m)*dt(l,m) + av = exp(-cmplx(0.0,m*arg))*(ic**m)* + * cmplx(dte(l,m)*bess(m) - + + te(l,m)*sk2(irec2)*dbss(m),0.0)/ + / ((wronk_1)*sqrt(omtil)) + bv = exp(-cmplx(0.0,m*arg))*(ic**m)* + * cmplx(-dt(l,m)*bess(m) + + - t(l,m)*sk2(irec2)*dbss(m),0.0)/ + / ((wronk_1)*sqrt(omtil)) + do n = 1,nslibd + ac(l,m,n) = ac(l,m,n) + z(k+addnoco,n)*av + bc(l,m,n) = bc(l,m,n) + z(k+addnoco,n)*bv + end do + end do ! -mb:mb + end if + end do ! k = 1,nv + + deallocate (dt,dte,t,te,tei) + + end subroutine + end module m_wann_1dvacabcof + + + diff --git a/wannier/wann_get_qpts.f b/wannier/wann_get_qpts.f new file mode 100644 index 00000000..47385a28 --- /dev/null +++ b/wannier/wann_get_qpts.f @@ -0,0 +1,72 @@ + module m_wann_get_qpts + USE m_fleurenv + contains + subroutine wann_get_qpts( + > l_bzsym,film,l_onedimens,l_readqpts, + < nqpts,qpoints,param_file) +c******************************************************** +c Read in the q-points from qpts file. +c +c +c******************************************************** + implicit none + logical,intent(in) :: l_bzsym,film + logical,intent(in) :: l_onedimens,l_readqpts + integer,intent(out) :: nqpts + real,intent(inout) :: qpoints(:,:) + character(len=20),intent(in) :: param_file + + real :: scale + !integer :: at,j + integer :: iter!,len,num_wann,num_bands,nn,i + logical :: l_file + + if(l_bzsym)then + inquire(file='w90qpts',exist=l_file) + IF(.NOT.l_file) CALL fleur_err("where is w90qpts?",calledby + + ="wann_get_qpts") + open(987,file='w90qpts',status='old',form='formatted') + read(987,*)nqpts, scale + write(6,*)"wann_get_qpts: nqpts=",nqpts + if(l_readqpts)then + IF(SIZE(qpoints,1)/=3) CALL fleur_err("wann_get_qpts: 1" + + ,calledby ="wann_get_qpts") + IF(SIZE(qpoints,2)/=nqpts) CALL fleur_err("wann_get_qpts: 2" + + ,calledby ="wann_get_qpts") + do iter=1,nqpts + read(987,*)qpoints(:,iter) + enddo + endif + else + inquire(file=param_file,exist=l_file) + IF(.NOT.l_file) CALL fleur_err( + > "where is "//trim(param_file)//"?",calledby + + ="wann_get_qpts") + open(987,file=param_file,status='old',form='formatted') + read(987,*)nqpts,scale + write(6,*)"wann_get_qpts: nqpts=",nqpts + if(l_readqpts)then + IF(SIZE(qpoints,1)/=3) CALL fleur_err("wann_get_qpts: 1" + + ,calledby ="wann_get_qpts") + IF(SIZE(qpoints,2)/=nqpts) CALL fleur_err("wann_get_qpts: 2" + + ,calledby ="wann_get_qpts") + do iter=1,nqpts + read(987,*)qpoints(:,iter) + enddo + endif + endif + + close(987) + + if(l_readqpts)then + qpoints=qpoints/scale !* 2.0 !2xBZ + if(film.and..not.l_onedimens)then + qpoints(3,:)=0.0 + endif + do iter=1,nqpts + write(6,*)qpoints(:,iter) + enddo + endif + + end subroutine wann_get_qpts + end module m_wann_get_qpts diff --git a/wannier/wann_gwf_anglmom.f b/wannier/wann_gwf_anglmom.f new file mode 100644 index 00000000..4df819e4 --- /dev/null +++ b/wannier/wann_gwf_anglmom.f @@ -0,0 +1,82 @@ +c*************************c +c routine to set up the c +c composite matrix anglmom c +c*************************c + module m_wann_gwf_anglmom + USE m_fleurenv + implicit none + contains + + subroutine wann_gwf_anglmom(nkpts,nqpts,l_unformatted) + use m_wann_gwf_tools + + implicit none + + ! input parameters + logical,intent(in) :: l_unformatted + integer,intent(in) :: nkpts,nqpts + + integer :: nwfs,nbnd,nkqpts + integer :: d,i,j,k,q,kq,t1,t2,t3,t4 + real :: tempr,tempi + + complex,allocatable :: anglmom(:,:,:,:) + character(len=12) :: fending + + nkqpts = nkpts*nqpts + + ! get number of bands and wfs from proj + open(405,file='proj',status='old') + read(405,*)nwfs,nbnd + close(405) + write(*,*)'nbnd=',nbnd + write(*,*)'nwfs=',nwfs + + allocate(anglmom(3,nbnd,nbnd,nkqpts)) + + ! read in separate files + do q=1,nqpts + WRITE(fending,'("_",i4.4)')q + open(405,file='WF1'//trim(fending)//'.anglmom') + read(405,*) !header + read(405,*) !nbnd and nkpts + do k=1,nkpts + kq=get_index_kq(k,q,nkpts) + do i=1,nbnd + do j=1,nbnd + do d=1,3 + read(405,*)t1,t2,t3,t4,tempr,tempi + anglmom(d,j,i,kq) = cmplx(tempr,tempi) + enddo + enddo + enddo + enddo + close(405,status='delete') + enddo + + ! write file either unformatted or formatted + if(l_unformatted) then + open(405,file='WF1_gwf.anglmom',form='unformatted') + write(405)anglmom + close(405) + else + open(405,file='WF1_gwf.anglmom') + write(405,*)'Matrix elements of angular momentum' + write(405,'(3i5)')nbnd,nbnd,nkqpts + do kq=1,nkqpts + do i=1,nbnd + do j=1,nbnd + do d=1,3 + write(405,'(4i5,3x,2f18.12)')d,j,i,kq, + > anglmom(d,j,i,kq) + enddo + enddo + enddo + enddo + close(405) + endif + + deallocate(anglmom) + + end subroutine wann_gwf_anglmom + end module m_wann_gwf_anglmom diff --git a/wannier/wann_gwf_auxbrav.F b/wannier/wann_gwf_auxbrav.F new file mode 100644 index 00000000..e0930540 --- /dev/null +++ b/wannier/wann_gwf_auxbrav.F @@ -0,0 +1,43 @@ +c*****************************c +c routine to define Bravais c +c in the auxiliary space c +c*****************************c + module m_wann_gwf_auxbrav + implicit none + contains + + subroutine wann_gwf_auxbrav(a,l_sgwf,l_socgwf,amat,bmat,l_dim) + use m_inv3 + use m_constants, only : pimach + + implicit none + real, intent(in) :: a + logical, intent(in) :: l_sgwf,l_socgwf,l_dim(3) + real, intent(out) :: amat(3,3),bmat(3,3) + real :: tpi, omtil,kmesh_tol + + write(*,*)'auxiliary lattice constant a=',a + + tpi = 2.0*pimach() + kmesh_tol = 0.001 + amat = 0.0 + bmat = 0.0 + + amat(1,1)=1.1*a; amat(2,2)=1.1*a; amat(3,3)=1.1*a + if(l_dim(1))amat(1,1)=a + if(l_dim(2))amat(2,2)=a + if(l_dim(3))amat(3,3)=a + if(l_sgwf.or.l_socgwf) then + amat = amat/2.0 +c amat(1,1)=amat(1,1)-kmesh_tol +c amat(2,2)=amat(2,2)-kmesh_tol +c amat(3,3)=amat(3,3)-kmesh_tol + endif + call inv3(amat,bmat,omtil) + bmat = tpi*bmat + + !write(*,*)'aux. amat',amat + !write(*,*)'aux. bmat',bmat + end subroutine wann_gwf_auxbrav + + end module m_wann_gwf_auxbrav diff --git a/wannier/wann_gwf_auxovlp.F b/wannier/wann_gwf_auxovlp.F new file mode 100644 index 00000000..6ba3b048 --- /dev/null +++ b/wannier/wann_gwf_auxovlp.F @@ -0,0 +1,37 @@ + module m_wann_gwf_auxovlp + implicit none + contains + + subroutine wann_gwf_auxovlp(q1,q2,a,mmnaux) + use m_constants, only : pimach + + implicit none + real, intent(in) :: q1(3),q2(3),a + complex, intent(out) :: mmnaux + + integer :: i + real :: pi, a_aux, b_aux, tau(3) + complex :: ov(3) + + pi = pimach() + a_aux = a + b_aux = 0.98*a + tau = 2.0*pi*(q1-q2)/a_aux + ov = cmplx(1.,0.) + + do i=1,3 + if(abs(tau(i)).lt.1e-10) cycle + ov(i) = 8.0*pi*pi*sin(tau(i)*b_aux/2.0) + ov(i) = ov(i) / ( 4.0*pi*pi - (tau(i)*b_aux)**2 ) + ov(i) = ov(i) / ( tau(i)*b_aux ) + enddo + mmnaux = ov(1)*ov(2)*ov(3) + + write(*,*)'ov(1) =',ov(1) + write(*,*)'ov(2) =',ov(2) + write(*,*)'ov(3) =',ov(3) + write(*,*)'mmnaux=',mmnaux + + end subroutine wann_gwf_auxovlp + + end module m_wann_gwf_auxovlp diff --git a/wannier/wann_gwf_commat.f b/wannier/wann_gwf_commat.f new file mode 100644 index 00000000..81c06e8e --- /dev/null +++ b/wannier/wann_gwf_commat.f @@ -0,0 +1,460 @@ +c*************************c +c routine to set up the c +c composite matrices as c +c input for wannier90 c +c*************************c + module m_wann_gwf_commat + USE m_fleurenv + implicit none + contains + + subroutine wann_gwf_commat(nkpts,nntot,bpt,nqpts,nntot_q, + > bpt_q,gb,gb_q,latt_const_q, + > l_unformatted,l_amn,l_mmn,l_dim, + > nparampts,param_vec) + use m_wann_gwf_tools + use m_wann_gwf_auxovlp + use m_constants, only : pimach + use m_intgr, only : intgz0 + + implicit none + + ! input parameters + logical,intent(in) :: l_unformatted,l_amn,l_mmn,l_dim(3) + integer,intent(in) :: nkpts,nntot,nqpts,nntot_q,nparampts + integer,intent(in) :: bpt(nntot,nkpts),bpt_q(nntot_q,nqpts) + integer,intent(in) :: gb(3,nntot,nkpts),gb_q(3,nntot_q,nqpts) + real, intent(in) :: latt_const_q,param_vec(3,nparampts) + + ! allocatable arrays + integer,allocatable :: gb_kq(:,:,:) + integer,allocatable :: bpt_kq(:,:) + integer,allocatable :: g1(:,:,:),g2(:,:) + integer,allocatable :: b1(:,:),b2(:) + real, allocatable :: xxr(:),xxi(:) + complex,allocatable :: tmp_a(:,:,:),tmp_m(:,:,:,:) + complex,allocatable :: mmnk(:,:,:,:),mmnq(:,:,:,:) + complex,allocatable :: mk(:,:,:),mq(:,:,:) + complex,allocatable :: mmn(:,:,:,:) + complex,allocatable :: amn_arti2(:) + character(len=20),allocatable :: feig(:),famn(:) + character(len=20),allocatable :: fmmn(:),fmmn2(:) + + ! further variables + integer :: nbnd,nwfs,kb,qb,nn_kq,kqb,arr_len,shift(3) + integer :: i,j,ikqpt,ikqpt_b,nk,nq,g(3) + integer :: nbnd_arti,nqpts_arti,nntot_arti + integer :: nkqpts,nntot_kq,nn,ikqpt_help + integer :: dump,nn_arti,nkp,k,b,q,nwf,n,is,ie,nx + real :: mmn_r,mmn_i,tau,tpi,a_arti,b_arti,eig + real :: dx,x0,sig,center,amnr,amni,norm,bf + complex :: mmn_arti,amn_arti,amn,psi,wftrial + logical :: l_exist,l_miss,l_fe,l_fa,l_fm,l_fm2,l_proj + character(len=20) :: fq + character(len=32) :: fmt,fmt2 + + write(*,*)'create HDWFs input for w90...' + +! arr_len=3; shifty=0; shiftz=0 +! if(l_dim(1))then +! arr_len=arr_len+1 +! shifty=shifty+1 +! shiftz=shiftz+1 +! endif +! if(l_dim(2))then +! arr_len=arr_len+1 +! shiftz=shiftz+1 +! endif +! if(l_dim(3))arr_len=arr_len+1 + + call get_dimension(l_dim,arr_len) + call get_shift(l_dim,shift) + + write(*,*)'dimension:',arr_len + write(*,*)'x?,y?,z? :',l_dim(1:3) + if(arr_len.le.3) call fleur_err("dimension<4", + > calledby='wann_gwf_commat') + + nkqpts=nkpts*nqpts + tpi = 2.0*pimach() + a_arti = latt_const_q + b_arti = 0.98*latt_const_q +! b_arti = 0.5*latt_const_q +! b_arti = 0.7*latt_const_q +! b_arti = 0.3*latt_const_q +! b_arti = 0.05*latt_const_q + l_fe = .true. + l_fa = .true. + l_fm = .true. + l_fm2 = .true. + l_exist= .true. + +! compute auxiliary overlaps and projections + tau = 1.0*tpi/real(nqpts)/a_arti + mmn_arti = 2.0*tpi*tpi*sin(tau*b_arti/2.0) + mmn_arti = mmn_arti/(tpi*tpi-tau*tau*b_arti*b_arti) + mmn_arti = mmn_arti/(tau*b_arti) +c mmn_arti = 0.5 + write(*,*)'ov(0) =',mmn_arti +c CALL wann_gwf_auxovlp(param_vec(:,1),param_vec(:,2), +c > latt_const_q,mmn_arti) + + amn_arti = cmplx(1.0,0.0) + + open(777,file='ma_aux') + write(777,'(2(f24.18))')real(mmn_arti),aimag(mmn_arti) + write(777,'(2(f24.18))')real(amn_arti),aimag(amn_arti) + write(777,*)a_arti + write(777,*)b_arti + close(777) + + bf = b_arti/a_arti + sig = 1.00!1.2!0.05 + center = 0.0 + !norm = sqrt(sqrt(2./pimach())/sig)*sqrt(2./bf) + nx=301*nqpts+1 + dx = 1./real(nx-1)*nqpts + allocate(xxr(nx),xxi(nx)) + allocate(amn_arti2(nqpts)) + open(555,file='debug_wfaux') + do q=1,nqpts + do i=1,nx + !x0 = -bf/2. + (i-1)*dx*bf + !xx(i) = exp(-x0*x0/sig/sig)*cos(pimach()/bf*x0) + x0 = -nqpts/2. + (i-1)*dx + psi=wfpsi(x0,param_vec(3,q),bf) + wftrial = trialorb(x0,center,sig) + xxr(i) = real(conjg(wftrial)*psi) + xxi(i) = aimag(conjg(wftrial)*psi) + write(555,'(6(f10.6,1x))')param_vec(3,q),x0, + > real(psi),aimag(psi),real(wftrial),aimag(wftrial) + enddo + !call intgz0(xx,dx,nx,amnr,.false.) + !amn_arti2(q) = amnr*norm + call intgz0(xxr,dx,nx,amnr,.false.) + call intgz0(xxi,dx,nx,amni,.false.) + amn_arti2(q) = cmplx(amnr,amni) + enddo + close(555) + + open(777,file='debug_amn') + do q=1,nqpts + write(777,*)q,amn_arti2(q) + enddo + close(777) + deallocate(xxr,xxi) + +! are all necessary files present? + allocate(feig(nqpts),famn(nqpts),fmmn(nqpts),fmmn2(nqpts)) + l_miss=.false. + do q=1,nqpts + write(fq,'(i4.4)')q + feig(q) = 'WF1_'//trim(fq)//'.eig' ! energies + famn(q) = 'WF1_'//trim(fq)//'.amn' ! projections + fmmn(q) = 'WF1_'//trim(fq)//'.mmn' ! k-overlaps + fmmn2(q)= 'param_'//trim(fq)//'.mmn' ! q-overlaps + + inquire(file=feig(q) ,exist=l_fe ) + if(l_amn) inquire(file=famn(q) ,exist=l_fa ) + if(l_mmn) inquire(file=fmmn(q) ,exist=l_fm ) + if(l_mmn) inquire(file=fmmn2(q),exist=l_fm2) + + if(.not.l_fe ) write(*,*)'missing: ',feig(q) + if(.not.l_fa ) write(*,*)'missing: ',famn(q) + if(.not.l_fm ) write(*,*)'missing: ',fmmn(q) + if(.not.l_fm2) write(*,*)'missing: ',fmmn2(q) + if(.not.(l_fe.and.l_fa.and.l_fm.and.l_fm2))l_miss=.true. + enddo + if(l_mmn) inquire(file='bkqpts',exist=l_exist) + if(.not.l_exist) write(*,*)'missing: bkqpts' + inquire(file='proj',exist=l_proj) + if(.not.l_proj) write(*,*)'missing: proj' + if(l_miss.or.(.not.l_exist).or.(.not.l_proj)) + > call fleur_err("missing file(s) for HDWFs") + +! get number of bands and wfs from proj + open(405,file='proj',status='old') + read(405,*)nwfs,nbnd + close(405) + write(*,*)'nbnd=',nbnd + write(*,*)'nwfs=',nwfs + + +c*****************************c +c COMPOSITE .EIG FILE c +c*****************************c + open(305,file='WF1_gwf.eig') + do q=1,nqpts + open(405,file=feig(q)) + do k=1,nkpts + ikqpt=get_index_kq(k,q,nkpts) + do i=1,nbnd + read(405,*)b,nk,eig + write(305,'(2i12,f19.13)')b,ikqpt,eig + enddo + enddo + close(405)!,status='delete') + enddo + close(305) + + +c*****************************c +c COMPOSITE .AMN FILE c +c*****************************c + if(.not.l_amn) goto 100 ! skip amn part + + if(l_unformatted) then + allocate(tmp_a(nbnd,nwfs,nkqpts)) + do q=1,nqpts + is = get_index_kq(1,q,nkpts) + ie = get_index_kq(nkpts,q,nkpts) + open(405,file=famn(q),form='unformatted') + read(405)b,k,nwf + read(405)tmp_a(:,:,is:ie) + do i=1,nwfs + tmp_a(:,i,is:ie) = tmp_a(:,i,is:ie)*amn_arti2(q) + enddo + close(405)!,status='delete') + enddo + + open(306,file='WF1_gwf.amn',form='unformatted') + write(306)nbnd,nkqpts,nwfs + write(306)tmp_a!*amn_arti + close(306) + deallocate(tmp_a) + else + open(306,file='WF1_gwf.amn') + write(306,*)'Projections for HDWFs' + write(306,'(i5,i7,i5)')nbnd,nkqpts,nwfs + + do q=1,nqpts + open(405,file=famn(q)) + read(405,*)!title + read(405,*)b,k,nwf + do k=1,nkpts + ikqpt=get_index_kq(k,q,nkpts) + do nwf=1,nwfs + do i=1,nbnd + read(405,*)b,n,nk,mmn_r,mmn_i + amn = cmplx(mmn_r,mmn_i) + amn = amn*amn_arti2(q) !*amn_arti + write(306,'(i5,i5,i7,3x,2f18.12)') + > b,n,ikqpt,real(amn),aimag(amn) + enddo + enddo + enddo + close(405,status='delete') + enddo + close(306) + endif!l_unformatted + + 100 continue + + +c*****************************c +c COMPOSITE .MMN FILE c +c*****************************c + if(.not.l_mmn) goto 200 ! skip mmn part + + write(fmt,'(a,i1,a)')'(2i6,3x,',arr_len,'i4)' + write(fmt2,'(a,i1,a)')'(i7,i7,3x,',arr_len,'i4)' + + open (202,file='bkqpts',form='formatted',status='old') + rewind (202) + read (202,'(i4)') nntot_kq + write (*,*) 'nntot_kq=',nntot_kq + allocate ( gb_kq(arr_len,nntot_kq,nkqpts), + & bpt_kq(nntot_kq,nkqpts)) + do ikqpt=1,nkqpts + do nn=1,nntot_kq + read (202,fmt) + & ikqpt_help,bpt_kq(nn,ikqpt),(gb_kq(i,nn,ikqpt),i=1,arr_len) + enddo + enddo + close (202) + + if(l_unformatted) then + allocate(mmnk(nbnd,nbnd,nntot,nkpts)) + allocate(mmnq(nbnd,nbnd,nntot_q,nkpts)) + allocate(g1(3,nntot,nkpts),g2(3,nntot_q)) + allocate(b1(nntot,nkpts),b2(nntot_q)) + allocate(mmn(nbnd,nbnd,nntot_kq,nkqpts)) + + do q=1,nqpts + is = get_index_kq(1,q,nkpts) + ie = get_index_kq(nkpts,q,nkpts) + + open(405,file=fmmn(q),form='unformatted') + read(405)b,k,nn + read(405)b1,g1 + read(405)mmnk + close(405,status='delete') + + open(405,file=fmmn2(q),form='unformatted') + read(405)b,k,nn + read(405)b2,g2 + read(405)mmnq + close(405,status='delete') + mmnq = mmnq*conjg(mmn_arti) + + do k=1,nkpts + ikqpt=get_index_kq(k,q,nkpts) + do nn=1,nntot_kq + kqb = bpt_kq(nn,ikqpt) + kb=get_index_k(kqb,nkpts) + qb=get_index_q(kqb,nkpts) + if(q.eq.qb) then ! k-overlap + nk=get_index_nn_k(bpt(:,k),nntot,kb, + > gb_kq(:,nn,ikqpt), + > gb(1:3,1:nntot,k),arr_len) + mmn(:,:,nn,ikqpt)=mmnk(:,:,nk,k) + !write(*,*)'k neig',k,kb,nk + elseif(k.eq.kb) then ! q-overlap + nq=get_index_nn_q(bpt_q(:,q),nntot_q,qb, + > gb_kq(:,nn,ikqpt), + > gb_q(1:3,1:nntot_q,q), + > arr_len,shift,l_dim) + mmn(:,:,nn,ikqpt)=mmnq(:,:,nq,k) + !write(*,*)'q neig',q,qb,nq + else ! otherwise problem + call fleur_err("problem in overlap mmn gwf", + > calledby="wann_gwf_commat") + endif + enddo!nn + enddo!k + enddo!q + deallocate(b1,b2,g1,g2,mmnk,mmnq) + + open(307,file='WF1_gwf.mmn',form='unformatted') + write(307)nbnd,nkqpts,nntot_kq + write(307)bpt_kq,gb_kq + write(307)mmn + close(307) + deallocate(mmn) + else + allocate(mk(nbnd,nbnd,nntot)) + allocate(mq(nbnd,nbnd,nntot_q)) + open(307,file='WF1_gwf.mmn') + write(307,*)'Overlaps for HDWFs' + write(307,'(i5,i7,i5)')nbnd,nkqpts,nntot_kq + + do q=1,nqpts + open(405,file=fmmn(q)) + read(405,*)!title + read(405,*)b,k,nn + open(406,file=fmmn2(q)) + read(406,*)!title + read(406,*)b,k,nn + do k=1,nkpts + ikqpt=get_index_kq(k,q,nkpts) + + do nn=1,nntot ! read k-overlaps + kb = bpt(nn,k) + read(405,*)nkp,b,g(1:3) + do i=1,nbnd + do j=1,nbnd + read(405,*)mmn_r,mmn_i + mk(j,i,nn)=cmplx(mmn_r,mmn_i) + enddo + enddo + enddo + + do nn=1,nntot_q ! read q-overlaps + qb = bpt_q(nn,q) + read(406,*)nkp,b,g(1:3) + do i=1,nbnd + do j=1,nbnd + read(406,*)mmn_r,mmn_i + mq(j,i,nn)=cmplx(mmn_r,mmn_i) + enddo + enddo + enddo + mq = mq*conjg(mmn_arti) + + do nn=1,nntot_kq ! write composite overlaps + kqb = bpt_kq(nn,ikqpt) + kb=get_index_k(kqb,nkpts) + qb=get_index_q(kqb,nkpts) + write(307,fmt2)ikqpt,kqb,gb_kq(1:arr_len,nn,ikqpt) + if(q.eq.qb) then ! k-overlap + nk=get_index_nn_k(bpt(:,k),nntot,kb, + > gb_kq(:,nn,ikqpt), + > gb(1:3,1:nntot,k),arr_len) + do i=1,nbnd + do j=1,nbnd + write(307,'(2f24.18)') + > real(mk(j,i,nk)),aimag(mk(j,i,nk)) + enddo + enddo + elseif(k.eq.kb) then ! q-overlap + nq=get_index_nn_q(bpt_q(:,q),nntot_q,qb, + > gb_kq(:,nn,ikqpt), + > gb_q(1:3,1:nntot_q,q), + > arr_len,shift,l_dim) + do i=1,nbnd + do j=1,nbnd + write(307,'(2f24.18)') + > real(mq(j,i,nq)),aimag(mq(j,i,nq)) + enddo + enddo + else ! otherwise problem + call fleur_err("problem in overlap mmn gwf", + > calledby="wann_gwf_commat") + endif + enddo!nn + enddo!k + close(406,status='delete') + close(405,status='delete') + enddo!q + close(307) + deallocate(mk,mq) + endif!l_unformatted + + deallocate(gb_kq,bpt_kq) + 200 continue + deallocate(feig,famn,fmmn,fmmn2) + deallocate(amn_arti2) + + contains + + + complex function wfu(x0,qpt,bb) + implicit none + real,intent(in) :: x0,qpt,bb + integer :: i0 + real :: qx,xshift + complex :: pha + + wfu = cmplx(0.,0.) + i0=floor(x0+0.5) + xshift=x0-real(i0) + if(abs(xshift) .ge. bb/2.) return + + qx = 2.*pimach()*qpt*xshift + pha = cmplx( cos(qx), -sin(qx) ) + wfu = pha*sqrt(2./bb)*cos(pimach()*xshift/bb) + end function wfu + + complex function wfpsi(x0,qpt,bb) + implicit none + real,intent(in) :: x0,qpt,bb + complex :: pha + real :: qx + + qx = 2.*pimach()*qpt*x0 + pha = cmplx( cos(qx), sin(qx) ) + wfpsi = pha*wfu(x0,qpt,bb) + end function wfpsi + + + real function trialorb(x0,center,sigma) + implicit none + real,intent(in) :: x0,center,sigma + real :: xp + + xp = (x0-center)/sigma + trialorb = exp(-xp*xp)*sqrt(sqrt(2./pimach())/sigma) + end function trialorb + + end subroutine wann_gwf_commat + end module m_wann_gwf_commat diff --git a/wannier/wann_gwf_commat2.f b/wannier/wann_gwf_commat2.f new file mode 100644 index 00000000..dd13c82d --- /dev/null +++ b/wannier/wann_gwf_commat2.f @@ -0,0 +1,360 @@ +c*************************c +c routine to set up the c +c composite matrices as c +c input for wannier90 c +c*************************c + module m_wann_gwf_commat2 + USE m_fleurenv + implicit none + contains + + subroutine wann_gwf_commat2(nkpts,nntot,bpt,nqpts,nntot_q, + > bpt_q,gb,gb_q,latt_const_q, + > l_unformatted,l_amn,l_mmn) + use m_wann_gwf_tools + use m_constants, only : pimach + + implicit none + + ! input parameters + logical,intent(in) :: l_unformatted,l_amn,l_mmn + integer,intent(in) :: nkpts,nntot,nqpts,nntot_q + integer,intent(in) :: bpt(nntot,nkpts),bpt_q(nntot_q,nqpts) + integer,intent(in) :: gb(3,nntot,nkpts),gb_q(3,nntot_q,nqpts) + real, intent(in) :: latt_const_q + + ! allocatable arrays + integer,allocatable :: gb_kq(:,:,:) + integer,allocatable :: bpt_kq(:,:) + integer,allocatable :: g1(:,:,:),g2(:,:) + integer,allocatable :: b1(:,:),b2(:) + complex,allocatable :: tmp_a(:,:,:),tmp_m(:,:,:,:) + complex,allocatable :: mmnk(:,:,:,:),mmnq(:,:,:,:) + complex,allocatable :: mk(:,:,:),mq(:,:,:) + complex,allocatable :: mmn(:,:,:,:) + character(len=20),allocatable :: feig(:),famn(:) + character(len=20),allocatable :: fmmn(:),fmmn2(:) + + ! further variables + integer :: nbnd,nwfs,kb,qb,nn_kq,kqb + integer :: i,j,ikqpt,ikqpt_b,nk,nq,g(3) + integer :: nbnd_arti,nqpts_arti,nntot_arti + integer :: nkqpts,nntot_kq,nn,ikqpt_help + integer :: dump,nn_arti,nkp,k,b,q,nwf,n,is,ie + real :: mmn_r,mmn_i,tau,tpi,a_arti,b_arti,eig + complex :: mmn_arti,amn_arti,amn + logical :: l_exist,l_miss,l_fe,l_fa,l_fm,l_fm2,l_proj + character(len=20) :: fq + + integer :: ncpu + + ncpu = 8 + + write(*,*)'create HDWFs input for w90...' + + nkqpts=nkpts*nqpts + tpi = 2.0*pimach() + a_arti = latt_const_q + b_arti = 0.98*latt_const_q + l_fe = .true. + l_fa = .true. + l_fm = .true. + l_fm2 = .true. + l_exist= .true. + +! compute auxiliary overlaps and projections + tau = tpi/real(nqpts)/a_arti + mmn_arti = 2.0*tpi*tpi*sin(tau*b_arti/2.0) + mmn_arti = mmn_arti/(tpi*tpi-tau*tau*b_arti*b_arti) + mmn_arti = mmn_arti/(tau*b_arti) + + amn_arti = cmplx(1.0,0.0) + + open(777,file='ma_aux') + write(777,'(2(f24.18))')real(mmn_arti),aimag(mmn_arti) + write(777,'(2(f24.18))')real(amn_arti),aimag(amn_arti) + close(777) + +! are all necessary files present? + allocate(feig(nqpts),famn(nqpts),fmmn(nqpts),fmmn2(nqpts)) + l_miss=.false. + do q=1,nqpts + write(fq,'(i4.4)')q + feig(q) = 'WF1_'//trim(fq)//'.eig' ! energies + famn(q) = 'WF1_'//trim(fq)//'.amn' ! projections + fmmn(q) = 'WF1_'//trim(fq)//'.mmn' ! k-overlaps + fmmn2(q)= 'param_'//trim(fq)//'.mmn' ! q-overlaps + + inquire(file=feig(q) ,exist=l_fe ) + if(l_amn) inquire(file=famn(q) ,exist=l_fa ) + if(l_mmn) inquire(file=fmmn(q) ,exist=l_fm ) + if(l_mmn) inquire(file=fmmn2(q),exist=l_fm2) + + if(.not.l_fe ) write(*,*)'missing: ',feig(q) + if(.not.l_fa ) write(*,*)'missing: ',famn(q) + if(.not.l_fm ) write(*,*)'missing: ',fmmn(q) + if(.not.l_fm2) write(*,*)'missing: ',fmmn2(q) + if(.not.(l_fe.and.l_fa.and.l_fm.and.l_fm2))l_miss=.true. + enddo + if(l_mmn) inquire(file='bkqpts',exist=l_exist) + if(.not.l_exist) write(*,*)'missing: bkqpts' + inquire(file='proj',exist=l_proj) + if(.not.l_proj) write(*,*)'missing: proj' + if(l_miss.or.(.not.l_exist).or.(.not.l_proj)) + > call fleur_err("missing file(s) for HDWFs") + +! get number of bands and wfs from proj + open(405,file='proj',status='old') + read(405,*)nwfs,nbnd + close(405) + write(*,*)'nbnd=',nbnd + write(*,*)'nwfs=',nwfs + + +c*****************************c +c COMPOSITE .EIG FILE c +c*****************************c + open(305,file='WF1_gwf.eig') + do q=1,nqpts + open(405,file=feig(q)) + do k=1,nkpts + ikqpt=get_index_kq(k,q,nkpts) + do i=1,nbnd + read(405,*)b,nk,eig + write(305,'(2i12,f19.13)')b,ikqpt,eig + enddo + enddo + close(405) + enddo + close(305) + + +c*****************************c +c COMPOSITE .AMN FILE c +c*****************************c + if(.not.l_amn) goto 100 ! skip amn part + + if(l_unformatted) then + allocate(tmp_a(nbnd,nwfs,nkqpts)) + do q=1,nqpts + is = get_index_kq(1,q,nkpts) + ie = get_index_kq(nkpts,q,nkpts) + open(405,file=famn(q),form='unformatted') + read(405)b,k,nwf + read(405)tmp_a(:,:,is:ie) + close(405) + enddo + + open(306,file='WF1_gwf.amn',form='unformatted') + write(306)nbnd,nkqpts,nwfs + write(306)tmp_a*amn_arti + close(306) + deallocate(tmp_a) + else + open(306,file='WF1_gwf.amn') + write(306,*)'Projections for HDWFs' + write(306,'(i5,i7,i5)')nbnd,nkqpts,nwfs + + do q=1,nqpts + open(405,file=famn(q)) + read(405,*)!title + read(405,*)b,k,nwf + do k=1,nkpts + ikqpt=get_index_kq(k,q,nkpts) + do nwf=1,nwfs + do i=1,nbnd + read(405,*)b,n,nk,mmn_r,mmn_i + amn = cmplx(mmn_r,mmn_i) + amn = amn*amn_arti + write(306,'(i5,i5,i7,3x,2f18.12)') + > b,n,ikqpt,real(amn),aimag(amn) + enddo + enddo + enddo + enddo + close(306) + endif!l_unformatted + + 100 continue + + +c*****************************c +c COMPOSITE .MMN FILE c +c*****************************c + if(.not.l_mmn) goto 200 ! skip mmn part + + open (202,file='bkqpts',form='formatted',status='old') + rewind (202) + read (202,'(i4)') nntot_kq + write (*,*) 'nntot_kq=',nntot_kq + allocate ( gb_kq(4,nntot_kq,nkqpts), + & bpt_kq(nntot_kq,nkqpts)) + do ikqpt=1,nkqpts + do nn=1,nntot_kq + read (202,'(2i6,3x,4i4)') + & ikqpt_help,bpt_kq(nn,ikqpt),(gb_kq(i,nn,ikqpt),i=1,4) + enddo + enddo + close (202) + + if(l_unformatted) then + allocate(mmnk(nbnd,nbnd,nntot,nkpts)) + allocate(mmnq(nbnd,nbnd,nntot_q,nkpts)) + allocate(g1(3,nntot,nkpts),g2(3,nntot_q)) + allocate(b1(nntot,nkpts),b2(nntot_q)) + allocate(mmn(nbnd,nbnd,nntot_kq,nkqpts)) + + do q=1,nqpts + is = get_index_kq(1,q,nkpts) + ie = get_index_kq(nkpts,q,nkpts) + + open(405,file=fmmn(q),form='unformatted') + read(405)b,k,nn + read(405)b1,g1 + read(405)mmnk + close(405) + + open(405,file=fmmn2(q),form='unformatted') + read(405)b,k,nn + read(405)b2,g2 + read(405)mmnq + close(405) + mmnq = mmnq*conjg(mmn_arti) + + do k=1,nkpts + ikqpt=get_index_kq(k,q,nkpts) + do nn=1,nntot_kq + kqb = bpt_kq(nn,ikqpt) + kb=get_index_k(kqb,nkpts) + qb=get_index_q(kqb,nkpts) + if(q.eq.qb) then ! k-overlap + nk=get_index_nn_k(bpt(:,k),nntot,kb, + > gb_kq(:,nn,ikqpt), + > gb(1:3,1:nntot,k)) + mmn(:,:,nn,ikqpt)=mmnk(:,:,nk,k) + elseif(k.eq.kb) then ! q-overlap + nq=get_index_nn_q(bpt_q(:,q),nntot_q,qb, + > gb_kq(:,nn,ikqpt), + > gb_q(1:3,1:nntot_q,q)) + mmn(:,:,nn,ikqpt)=mmnq(:,:,nq,k) + else ! otherwise problem + call fleur_err("problem in overlap mmn gwf", + > calledby="wann_gwf_commat") + endif + enddo!nn + enddo!k + enddo!q + deallocate(b1,b2,g1,g2,mmnk,mmnq) + + open(307,file='WF1_gwf.mmn',form='unformatted') + write(307)nbnd,nkqpts,nntot_kq + write(307)bpt_kq,gb_kq + write(307)mmn + close(307) + deallocate(mmn) + else + allocate(mk(nbnd,nbnd,nntot)) + allocate(mq(nbnd,nbnd,nntot_q)) + open(307,file='WF1_gwf.mmn') + write(307,*)'Overlaps for HDWFs' + write(307,'(i5,i7,i5)')nbnd,nkqpts,nntot_kq + + do q=1,nqpts + open(405,file=fmmn(q)) + read(405,*)!title + read(405,*)b,k,nn + open(406,file=fmmn2(q)) + read(406,*)!title + read(406,*)b,k,nn + do k=1,nkpts + ikqpt=get_index_kq(k,q,nkpts) + + do nn=1,nntot ! read k-overlaps + kb = bpt(nn,k) + read(405,*)nkp,b,g(1:3) + do i=1,nbnd + do j=1,nbnd + read(405,*)mmn_r,mmn_i + mk(j,i,nn)=cmplx(mmn_r,mmn_i) + enddo + enddo + enddo + + do nn=1,nntot_q ! read q-overlaps + qb = bpt_q(nn,q) + read(406,*)nkp,b,g(1:3) + do i=1,nbnd + do j=1,nbnd + read(406,*)mmn_r,mmn_i + mq(j,i,nn)=cmplx(mmn_r,mmn_i) + enddo + enddo + enddo + mq = mq*conjg(mmn_arti) + + do nn=1,nntot_kq ! write composite overlaps + kqb = bpt_kq(nn,ikqpt) + kb=get_index_k(kqb,nkpts) + qb=get_index_q(kqb,nkpts) + write(307,'(i7,i7,3x,4i4)')ikqpt,kqb,gb_kq(1:4,nn,ikqpt) + if(q.eq.qb) then ! k-overlap + nk=get_index_nn_k(bpt(:,k),nntot,kb, + > gb_kq(:,nn,ikqpt), + > gb(1:3,1:nntot,k)) + do i=1,nbnd + do j=1,nbnd + write(307,'(2f24.18)') + > real(mk(j,i,nk)),aimag(mk(j,i,nk)) + enddo + enddo + elseif(k.eq.kb) then ! q-overlap + nq=get_index_nn_q(bpt_q(:,q),nntot_q,qb, + > gb_kq(:,nn,ikqpt), + > gb_q(1:3,1:nntot_q,q)) + do i=1,nbnd + do j=1,nbnd + write(307,'(2f24.18)') + > real(mq(j,i,nq)),aimag(mq(j,i,nq)) + enddo + enddo + else ! otherwise problem + call fleur_err("problem in overlap mmn gwf", + > calledby="wann_gwf_commat") + endif + enddo!nn + enddo!k + close(406) + close(405) + enddo!q + close(307) + deallocate(mk,mq) + endif!l_unformatted + + deallocate(gb_kq,bpt_kq) + 200 continue + deallocate(feig,famn,fmmn,fmmn2) + + end subroutine wann_gwf_commat2 + + + subroutine split_array(numpoints,n,ncpu,counts,displs) + implicit none + integer, intent(in) :: numpoints,ncpu,n + integer, intent(out) :: counts,displs + + integer :: ratio, remainder, i + + ratio = numpoints / ncpu + remainder = mod(numpoints,ncpu) + + if(n < remainder) then + counts = ratio+1 + displs = i*(ratio+1) + else + counts = ratio + displs = remainder*(ratio+1)+(i-remainder)*ratio + endif + + end subroutine split_array + + end module m_wann_gwf_commat2 diff --git a/wannier/wann_gwf_commat_old.f b/wannier/wann_gwf_commat_old.f new file mode 100644 index 00000000..cc49981e --- /dev/null +++ b/wannier/wann_gwf_commat_old.f @@ -0,0 +1,251 @@ + module m_wann_gwf_commat + USE m_fleurenv + implicit none + + contains + + subroutine wann_gwf_commat(nbnd,nwfs,nkpts,nntot,bpt, + > nqpts,nntot_q,bpt_q,gb,gb_q, + > mmnk,mmnq,amn,eig,latt_const_q) + use m_wann_gwf_tools + use m_wann_gwf_write_mmnk + use m_wann_write_amn + use m_constants, only : pimach + + implicit none + integer,intent(in) :: nbnd,nkpts,nntot,nqpts,nntot_q,nwfs + integer,intent(in) :: bpt(nntot,nkpts),bpt_q(nntot_q,nqpts) + integer,intent(in) :: gb(3,nntot,nkpts),gb_q(3,nntot_q,nqpts) + complex,intent(in) :: mmnk(nbnd,nbnd,nntot,nkpts,nqpts) + complex,intent(inout) :: mmnq(nbnd,nbnd,nntot_q,nqpts,nkpts) + complex,intent(inout) :: amn(nbnd,nwfs,nkpts,nqpts) + real, intent(in) :: eig(nbnd,nkpts,nqpts) + real, intent(in) :: latt_const_q + + integer :: iqpt,iqpt_b,i,j,ikqpt,ikqpt_b,iqpt_help + integer :: ikpt,ikpt_b,nbnd_arti,nqpts_arti,nntot_arti + integer :: nkqpts,nntot_kq,nn,ikqpt_help + integer,allocatable :: gb_kq(:,:,:),bpt_kq(:,:) + integer,allocatable :: bpt_arti(:,:) + integer :: dump,nn_arti + logical :: l_file,l_debug + complex :: temp_mmn + complex,allocatable :: mmn_arti(:,:),amn_arti(:) + complex,allocatable :: mmn_comp(:,:,:,:) + complex,allocatable :: amn_comp(:,:,:) + real,allocatable :: eig_comp(:,:) + real :: mmn_r,mmn_i,tau,tpi,a_arti,b_arti + character(len=20) :: filename + + l_debug = .false. + tpi = 2.0*pimach() + a_arti = latt_const_q + b_arti = 0.98*latt_const_q + +! read in overlaps to artifical potential + allocate(mmn_arti(nntot_q,nqpts)) + allocate(bpt_arti(nntot_q,nqpts)) + mmn_arti = cmplx(0.,0.) + + tau = tpi/real(nqpts)/a_arti + temp_mmn = 2.0*tpi*tpi*sin(tau*b_arti/2.0) + temp_mmn = temp_mmn/(tpi*tpi-tau*tau*b_arti*b_arti) + temp_mmn = temp_mmn/(tau*b_arti) + +! temp_mmn=1.0 + + write(*,*) temp_mmn + +c inquire(file='WF1_arti.mmn',exist=l_file) +c if(.not.l_file) +c > call fleur_err("provide WF1_arti.mmn",calledby ="wann_gwf_mmkb") +c +c open(200,file='WF1_arti.mmn',status='old',action='read') +c read(200,*)!header +c read(200,*)nbnd_arti,nqpts_arti,nntot_arti +c +c if(nbnd_arti.ne.1 .or. nqpts_arti.ne.nqpts +c > .or. nntot_arti.ne.nntot_q) then +c close(200) +c call fleur_err("check format WF1_arti.mmn", +c > calledby="wann_gwf_mmkb") +c endif +c +c do iqpt=1,nqpts +c do iqpt_b=1,nntot_q +c read(200,*)iqpt_help,bpt_arti(iqpt_b,iqpt),dump,dump,dump +c read(200,*)mmn_r,mmn_i +c mmn_arti(iqpt_b,iqpt) = cmplx(mmn_r,-mmn_i) +c enddo +c enddo +c close(200) + +! read in projections to artificial potential + allocate(amn_arti(nqpts)) + amn_arti = cmplx(0.,0.) + + amn_arti = 1.0 + +c inquire(file='WF1_arti.amn',exist=l_file) +c if(.not.l_file) +c > call fleur_err("provide WF1_arti.amn",calledby ="wann_gwf_mmkb") +c +c open(200,file='WF1_arti.amn',status='old',action='read') +c read(200,*)!header +c read(200,*)nbnd_arti,nqpts_arti,nntot_arti +c +c if(nbnd_arti.ne.1 .or. nqpts_arti.ne.nqpts +c > .or. nntot_arti.ne.1) then +c close(200) +c call fleur_err("check format WF1_arti.amn", +c > calledby="wann_gwf_mmkb") +c endif + +c do iqpt=1,nqpts +c read(200,*)nbnd_arti,nbnd_arti,iqpt_help,mmn_r,mmn_i +c if(iqpt_help.ne.iqpt) call fleur_err("iqpt_help.ne.iqpt", +c > calledby="wann_gwf_mmkb") +c amn_arti(iqpt) = cmplx(mmn_r,mmn_i) +c enddo +c close(200) + +c call fleur_end("stop in wann_gwf_mmkb") + + +! read in bkqpts + nkqpts=nkpts*nqpts + inquire (file='bkqpts',exist=l_file) + if (.not.l_file) CALL fleur_err("need bkqpts for l_gwf" + + ,calledby ="wann_gwf_mmkb") + open (202,file='bkqpts',form='formatted',status='old') + rewind (202) + read (202,'(i4)') nntot_kq + write (*,*) 'nntot_kq=',nntot_kq + allocate ( gb_kq(4,nntot_kq,nkqpts), + & bpt_kq(nntot_kq,nkqpts)) + do ikqpt=1,nkqpts + do nn=1,nntot_kq + read (202,'(2i6,3x,4i4)') + & ikqpt_help,bpt_kq(nn,ikqpt),(gb_kq(i,nn,ikqpt),i=1,4) + if (ikqpt/=ikqpt_help) CALL fleur_err("ikqpt.ne.ikqpt_help" + + ,calledby ="wann_gwf_mmkb") + if (bpt_kq(nn,ikqpt)>nkqpts) + & CALL fleur_err("bpt_kq.gt.nkqpts", + > calledby ="wann_gwf_mmkb") +c write(*,'(2i6,3x,4i4)')ikqpt_help,bpt_kq(nn,ikqpt), +c > (gb_kq(i,nn,ikqpt),i=1,4) + enddo + enddo + close (202) + + !call fleur_end("stop") + +! construct composite mmn and amn matrices and eig + allocate(mmn_comp(nbnd,nbnd,nntot_kq,nkqpts)) + allocate(amn_comp(nbnd,nwfs,nkqpts)) + allocate(eig_comp(nbnd,nkqpts)) + mmn_comp=cmplx(0.,0.) + amn_comp=cmplx(0.,0.) + eig_comp=cmplx(0.,0.) + + do ikqpt=1,nkqpts + ikpt=get_index_k(ikqpt,nkpts) + iqpt=get_index_q(ikqpt,nkpts) + + ! composite amn + amn_comp(:,:,ikqpt) = amn(:,:,ikpt,iqpt)*amn_arti(iqpt) + + ! composite eig + eig_comp(:,ikqpt) = eig(:,ikpt,iqpt) + + ! composite mmn + do ikqpt_b=1,nntot_kq + ikpt_b=get_index_k(bpt_kq(ikqpt_b,ikqpt),nkpts) + iqpt_b=get_index_q(bpt_kq(ikqpt_b,ikqpt),nkpts) + +c write(*,*)'kq',ikqpt,'kqb',ikqpt_b +c write(*,*)'k',ikpt,'kb',ikpt_b,'q',iqpt,'qb',iqpt_b + + if(iqpt.eq.iqpt_b) then !overlap in k + nn=get_index_nn_k(bpt(:,ikpt),nntot,ikpt_b, + > gb_kq(:,ikqpt_b,ikqpt), + > gb(1:3,1:nntot,ikpt)) +c write(*,*)'k neighbor nr.',nn + mmn_comp(:,:,ikqpt_b,ikqpt) = mmnk(:,:,nn,ikpt,iqpt) + elseif(ikpt.eq.ikpt_b) then !overlap in q + nn=get_index_nn_q(bpt_q(:,iqpt),nntot_q,iqpt_b, + > gb_kq(:,ikqpt_b,ikqpt), + > gb_q(1:3,1:nntot_q,iqpt)) +c write(*,*)'q neighbor nr.',nn +c do nn_arti=1,nntot_q +c if(bpt_arti(nn_arti,iqpt).eq.bpt_q(nn,iqpt)) exit +c if(nn_arti.eq.nntot_q) call fleur_err( +c > "nn_arti not found",calledby="wann_gwf_mmkb") +c enddo +c write(*,*)'q nn',nn,'arti nn',nn_arti + mmn_comp(:,:,ikqpt_b,ikqpt) = mmnq(:,:,nn,iqpt,ikpt) + > * temp_mmn +c > * mmn_arti(nn_arti,iqpt) + else !problem + call fleur_err("overlap mmn gwf", + > calledby="wann_gwf_mmkb") + endif + !write(*,*) + + enddo + enddo + +! write composite mmn + call wann_gwf_write_mmnk("WF1_gwf",nkqpts,nntot_kq,nbnd,bpt_kq, + > gb_kq,mmn_comp) + +! write composite amn + call wann_write_amn(.true.,"WF1_gwf.amn", + > 'Overlaps of the wavefunct. with the trial orbitals', + > nbnd,nkqpts,nwfs,1,1,.false.,.true.,amn_comp) + +! write composite eig + open(300,file="WF1_gwf.eig",form="formatted", + > status="unknown",action="write") + do ikqpt=1,nkqpts + do i=1,nbnd + write(300,'(2i12,f19.13)')i,ikqpt,eig_comp(i,ikqpt) + enddo + enddo + close(300) + +! further output for testing and debugging + if(l_debug) then + do ikpt=1,nkpts + + write(filename,'("WF1_q_",i4.4)')ikpt + + ! write eig_q file + open(300,file=trim(filename)//".eig", + > status='unknown',action='write') + do iqpt=1,nqpts + do i=1,nbnd + write(300,*)i,iqpt,eig(i,ikpt,iqpt) + enddo + enddo + close(300) + + ! write mmnq + call wann_gwf_write_mmnk(filename,nqpts,nntot_q,nbnd,bpt_q, + > gb_q,mmnq(:,:,:,:,ikpt)) + + ! write composite amn + call wann_write_amn(.true.,trim(filename)//".amn", + > 'Overlaps of the wavefunct. with the trial orbitals', + > nbnd,nqpts,nwfs,1,1,.false.,.true.,amn(:,:,ikpt,:)) + enddo + endif!debugging + + deallocate(mmn_arti,mmn_comp) + deallocate(amn_comp,eig_comp) + deallocate(gb_kq,bpt_kq) + + end subroutine wann_gwf_commat + + + end module m_wann_gwf_commat diff --git a/wannier/wann_gwf_tools.f b/wannier/wann_gwf_tools.f new file mode 100644 index 00000000..20eab1dc --- /dev/null +++ b/wannier/wann_gwf_tools.f @@ -0,0 +1,166 @@ +c************************************c +c routines to c +c a) find index of (k,q) point c +c b) write plot template file c +c************************************c + module m_wann_gwf_tools + implicit none + contains + + subroutine get_dimension(l_dim,dim) + implicit none + logical,intent(in) :: l_dim(3) + integer,intent(inout) :: dim + integer :: i + + dim=3 + do i=1,3 + if(l_dim(i))dim=dim+1 + enddo + + end subroutine get_dimension + + + subroutine get_shift(l_dim,shift) + implicit none + logical,intent(in) :: l_dim(3) + integer,intent(inout) :: shift(3) + + shift=0 + if(l_dim(1))then + shift(2)=shift(2)+1 + shift(3)=shift(3)+1 + endif + + if(l_dim(2))then + shift(3)=shift(3)+1 + endif + + end subroutine get_shift + + + integer function get_index_kq(ikpt,iqpt,nkpts) + implicit none + integer,intent(in) :: ikpt,iqpt,nkpts + get_index_kq = ikpt+(iqpt-1)*nkpts + end function get_index_kq + + + integer function get_index_k(ikqpt,nkpts) + implicit none + integer,intent(in) :: ikqpt,nkpts + get_index_k = ikqpt -(get_index_q(ikqpt,nkpts)-1)*nkpts + end function get_index_k + + + integer function get_index_q(ikqpt,nkpts) + implicit none + integer,intent(in) :: ikqpt,nkpts + get_index_q = (ikqpt-1)/nkpts + 1 + end function get_index_q + + + integer function get_index_nn_k(bpt,nntot,ikpt_b,gb_kq,gb,dim) + implicit none + integer,intent(in) :: nntot,ikpt_b,dim + integer,intent(in) :: bpt(nntot) + integer,intent(in) :: gb(3,nntot),gb_kq(dim) + integer :: nn + +c if(ANY(gb_kq(4:).ne.0)) write(*,*)'problem get_index_nn_k' + + do nn=1,nntot + if((bpt(nn).eq.ikpt_b) .and. (gb(1,nn).eq.gb_kq(1)) + > .and.(gb(2,nn).eq.gb_kq(2)) + > .and.(gb(3,nn).eq.gb_kq(3))) exit + enddo + if((nn.eq.(nntot+1)).or.(ANY(gb_kq(4:).ne.0))) then +c write(*,*)'nn not found!' + nn=-1 + endif + + get_index_nn_k = nn + end function get_index_nn_k + + + integer function get_index_nn_q(bpt,nntot,ikpt_b,gb_kq,gb, + > dim,shift,l_dim) + implicit none + integer,intent(in) :: nntot,ikpt_b,dim,shift(3) + integer,intent(in) :: bpt(nntot) + integer,intent(in) :: gb(3,nntot),gb_kq(dim) + logical,intent(in) :: l_dim(3) + integer :: nn,ind(3),g(3) + + g = 0 + do nn=1,3 + ind(nn)=4+shift(nn) + if(l_dim(nn))g(nn)=gb_kq(ind(nn)) + enddo + +c if(any(gb_kq(1:3).ne.0)) write(*,*)'problem get_index_nn_q' + + do nn=1,nntot + if((bpt(nn).eq.ikpt_b) .and. (gb(1,nn).eq.g(1)) + > .and.(gb(2,nn).eq.g(2)).and.(gb(3,nn).eq.g(3))) exit + enddo + if((nn.eq.(nntot+1)).or.(ANY(gb_kq(1:3).ne.0))) then +c write(*,*)'nn not found!' + nn=-1 + endif + + get_index_nn_q = nn + end function get_index_nn_q + + +! integer function get_index_nn_kq(bpt,nntot,kqb,gb_kq,gb,gb_q) +! implicit none +! integer,intent(in) :: nntot,kqb +! integer,intent(in) :: bpt(nntot) +! integer,intent(in) :: gb_kq(4,nntot),gb(3),gb_q(3) +! integer :: nn +! +! do nn=1,nntot +! if((bpt(nn).eq.kqb) .and. (gb_kq(4,nn).eq.gb_q(3)) +! > .and. (gb_kq(3,nn).eq.gb(3)) +! > .and. (gb_kq(2,nn).eq.gb(2)) +! > .and. (gb_kq(1,nn).eq.gb(1))) exit +! enddo +! if(nn==(nntot+1)) stop 'nn not found!' +! +! get_index_nn_kq = nn +! end function get_index_nn_kq + + + subroutine gwf_plottemplate() + use m_fleurenv + implicit none + integer :: i,nwfs,numbands + logical :: l_exist + + inquire(file='proj',exist=l_exist) + if(.not.l_exist) then + call fleur_err('Where is proj?', + > calledby='gwf_plottemplate') + endif + + open(8888,file='proj',status='old') + read(8888,*)nwfs,numbands + close(8888) + + open(8888,file='printhdwf',status='unknown') + write(8888,'(i4,3x,a1,3x,a4,i3)')nwfs,'F','nga=',5 + do i=1,nwfs + write(8888,'(i4,3x,i1,3x,i4)')i,4,0 + enddo + + close(8888) + + write(*,*)'******************************' + write(*,*)'* created printhdwf template *' + write(*,*)'******************************' + + end subroutine gwf_plottemplate + + + end module m_wann_gwf_tools diff --git a/wannier/wann_gwf_write_mmnk.F b/wannier/wann_gwf_write_mmnk.F new file mode 100644 index 00000000..70aa8c97 --- /dev/null +++ b/wannier/wann_gwf_write_mmnk.F @@ -0,0 +1,59 @@ +c************************c +c routine to write the c +c composite overlaps c +c************************c + module m_wann_gwf_write_mmnk + contains + subroutine wann_gwf_write_mmnk(mmnk_filename, + > nkpts,nntot, + > nbnd,bpt,gb,mmnk,l_unformat) + + implicit none + character(len=*),intent(in) :: mmnk_filename + integer, intent(in) :: nkpts,nntot,nbnd + integer, intent(in) :: bpt(nntot,nkpts),gb(4,nntot,nkpts) + complex, intent(inout) :: mmnk(nbnd,nbnd,nntot,nkpts) + logical, intent(in) :: l_unformat + + integer :: ikpt,i,j + integer :: ikpt_b + + if(.not.l_unformat)then + + open (305,file=trim(mmnk_filename)//'.mmn') + write (305,*) 'Overlaps at neighboring (k,q)-points' + write (305,'(i5,i7,i5)') nbnd,nkpts,nntot + do ikpt = 1,nkpts + do ikpt_b = 1,nntot + write (305,'(i7,i7,3x,4i4)') ikpt,bpt(ikpt_b,ikpt), + & gb(1:4,ikpt_b,ikpt) + do i = 1,nbnd + do j = 1,nbnd + write (305,'(2f24.18)') + & real(mmnk(j,i,ikpt_b,ikpt)),-aimag(mmnk(j,i,ikpt_b,ikpt)) + enddo + enddo + enddo + enddo !ikpt + close (305) + + else + + open(305,file=trim(mmnk_filename)//'.mmn',form='unformatted') + write(305) nbnd,nkpts,nntot + do ikpt = 1,nkpts + do ikpt_b = 1,nntot + write (305) ikpt,bpt(ikpt_b,ikpt), + & gb(1:4,ikpt_b,ikpt) + write (305) ((conjg(mmnk(j,i,ikpt_b,ikpt)), + & j=1,nbnd),i=1,nbnd) + enddo + enddo !ikpt + close (305) + + endif !l_unformat + + + end subroutine wann_gwf_write_mmnk + + end module m_wann_gwf_write_mmnk diff --git a/wannier/wann_maxbnd.F b/wannier/wann_maxbnd.F new file mode 100644 index 00000000..07ffdc9f --- /dev/null +++ b/wannier/wann_maxbnd.F @@ -0,0 +1,79 @@ + MODULE m_wann_maxbnd + USE m_fleurenv +c**************************************************************** +c determine maximum of number of bands +c**************************************************************** + CONTAINS + SUBROUTINE wann_maxbnd( + > lmaxd,ntypd,nlod,neigd,nvd,jspd, + > isize,jspin,nbasfcn,nlotot, + > l_ss,l_noco,nrec,fullnkpts,irecl, + > l_bzsym,l_byindex,l_bynumber,l_byenergy, + > irreduc,odi,band_min,band_max,numbands, + > e1s,e2s,ef,nkpt,nbnd,l_gwf,iqpt) + + use m_cdnread, only:cdn_read + use m_od_types,only:od_inp + use m_wann_rw_eig + + IMPLICIT NONE + integer,intent(in) :: lmaxd,ntypd,nlod,neigd,nvd,jspd + integer,intent(in) :: isize,jspin,nbasfcn,nlotot,iqpt + logical,intent(in) :: l_ss,l_noco,l_gwf + integer,intent(in) :: nrec,fullnkpts,irecl + logical,intent(in) :: l_byindex,l_bynumber,l_byenergy + integer,intent(in) :: irreduc(fullnkpts) + type (od_inp),intent(in) :: odi + integer,intent(in) :: band_min,band_max,numbands + logical,intent(in) :: l_bzsym + real,intent(in) :: e1s,e2s,ef + integer,intent(in) :: nkpt + + integer,intent(out):: nbnd + + integer :: ikpt,kptibz + integer :: nmat,nbands,nv(jspd) + real :: wk, bkpt(3),eig(neigd),cp_time(9) + integer :: k1(nvd,jspd),k2(nvd,jspd),k3(nvd,jspd) + integer :: nkbnd,i + REAL :: ello(nlod,ntypd,jspd),evdu(2,jspd) + REAL :: epar(0:lmaxd,ntypd,jspd) + INTEGER :: kveclo(nlotot) + integer :: n_start,n_end,co + integer :: num_bands + +#if ( !defined(CPP_INVERSION) || defined(CPP_SOC) ) + COMPLEX :: z(nbasfcn,neigd) +#else + REAL :: z(nbasfcn,neigd) +#endif + n_start=1 + n_end=neigd + + nbnd=0 + do ikpt = 1,fullnkpts + + kptibz=ikpt + if(l_bzsym) kptibz=irreduc(ikpt) + call wann_read_eig( + > lmaxd,ntypd,nlod,neigd,nvd,jspd, + > 0,isize,kptibz,jspin,nbasfcn,nlotot, + > l_ss,l_noco,nrec,irecl, + < nmat,nv,ello,evdu,epar,kveclo, + < k1,k2,k3,bkpt,wk,nbands,eig,z,cp_time,66, + > l_gwf,iqpt) + + nkbnd = 0 + do i = 1,nbands + if((eig(i).ge.e1s .and. nkbnd.lt.numbands.and.l_bynumber).or. + & (eig(i).ge.e1s.and.eig(i).le.e2s.and.l_byenergy ).or. + & (i.ge.band_min.and.i.le.band_max.and.l_byindex)) then + nkbnd = nkbnd + 1 + endif + enddo + if (nkbnd.ge.nbnd) nbnd = nkbnd + + enddo !ikpt + + end subroutine wann_maxbnd + END MODULE m_wann_maxbnd diff --git a/wannier/wann_mmkb_int2.F b/wannier/wann_mmkb_int2.F new file mode 100644 index 00000000..04d8e78b --- /dev/null +++ b/wannier/wann_mmkb_int2.F @@ -0,0 +1,104 @@ + module m_wann_mmkb_int2 + contains + subroutine wann_mmkb_int2( + > interchi,addnoco,addnoco2,nvd,k1d,k2d,k3d, + > n3d,k1,k2,k3, + > nv,neigd,nbasfcn,z,nslibd, + > k1_b,k2_b,k3_b, + > nv_b,z_b,nslibd_b, + > nbnd,rgphs,ustep,ig,gb, + < mmnk) +#include "cpp_double.h" + implicit none + integer, intent(in) :: addnoco,addnoco2 + integer, intent(in) :: nvd,n3d,k1(nvd),k2(nvd),k3(nvd) + integer, intent(in) :: nv,neigd,nbasfcn,nslibd,nslibd_b + integer, intent(in) :: nv_b,k1_b(nvd),k2_b(nvd),k3_b(nvd) + integer, intent(in) :: nbnd + integer, intent(in) :: k1d,k2d,k3d + real, intent(in) :: rgphs(-k1d:k1d,-k2d:k2d,-k3d:k3d) + complex, intent(in) :: ustep(n3d),interchi + integer, intent(in) :: ig(-k1d:k1d,-k2d:k2d,-k3d:k3d) + integer, intent(in) :: gb(3) +#if (!defined(CPP_INVERSION)||defined(CPP_SOC)) + complex, intent(in) :: z(nbasfcn,neigd) + complex, intent(in) :: z_b(nbasfcn,neigd) +#else + real,intent(in) :: z(nbasfcn,neigd) + real,intent(in) :: z_b(nbasfcn,neigd) +#endif + complex,intent(inout) :: mmnk(nbnd,nbnd) + +#if (!defined(CPP_INVERSION)||defined(CPP_SOC)) + complex,allocatable::stepf(:,:) + complex phasust + complex,allocatable::phasusbmat(:,:) +#else + real,allocatable::stepf(:,:) + real,allocatable::phasusbmat(:,:) + real phasust + real,allocatable::mmnk_tmp(:,:) +#endif + integer i,j1,j2,j3,i1,i2,i3,j,in,m,n + real phase + + allocate(stepf(nv_b,nv)) + allocate(phasusbmat(nv,nslibd_b)) +#if (!defined(CPP_INVERSION)||defined(CPP_SOC)) +#else + allocate(mmnk_tmp(nslibd,nslibd_b)) +#endif + stepf(:,:)=0.0 + do i =1,nv + j1 =-k1(i) + j2 =-k2(i) + j3 =-k3(i) + do j = 1,nv_b +c--> determine index and phase factor + i1 =j1 + k1_b(j) + i2 =j2 + k2_b(j) + i3 =j3 + k3_b(j) + in = ig(i1,i2,i3) + if (in.eq.0) cycle + phase = rgphs(i1,i2,i3) +#if ( !defined(CPP_INVERSION) || defined(CPP_SOC) ) + phasust=conjg(phase*ustep(in)) +#else + phasust=phase*real(ustep(in)) +#endif + stepf(j,i)=phasust + enddo + enddo +#if (!defined(CPP_INVERSION)||defined(CPP_SOC)) + call CPP_BLAS_cgemm('T','N',nv,nslibd_b,nv_b,cmplx(1.0), + & stepf,nv_b,z_b(1+addnoco2,1), +c & stepf,nv_b,z_b, + & nbasfcn,cmplx(0.0), + & phasusbmat,nv) + phasusbmat=conjg(phasusbmat) + call CPP_BLAS_cgemm('T','N',nslibd,nslibd_b,nv,interchi, + & z(1+addnoco,1),nbasfcn,phasusbmat,nv,cmplx(1.0), +c & z,nbasfcn,phasusbmat,nv,cmplx(1.0), + & mmnk,nbnd) +#else + call CPP_BLAS_sgemm('T','N',nv,nslibd_b,nv_b,real(1.0), + & stepf,nv_b,z_b(1+addnoco2,1),nbasfcn,real(0.0), +c & stepf,nv_b,z_b,nbasfcn,real(0.0), + & phasusbmat,nv) + call CPP_BLAS_sgemm('T','N',nslibd,nslibd_b,nv,real(1.0), + & z(1+addnoco,1),nbasfcn,phasusbmat,nv,real(0.0), +c & z,nbasfcn,phasusbmat,nv,real(0.0), + & mmnk_tmp,nbnd) + mmnk(1:nslibd,1:nslibd_b)=mmnk(1:nslibd,1:nslibd_b)+ + & mmnk_tmp(1:nslibd,1:nslibd_b)*interchi +#endif + + + deallocate(stepf) + deallocate(phasusbmat) +#if (!defined(CPP_INVERSION)||defined(CPP_SOC)) +#else + deallocate(mmnk_tmp) +#endif + end subroutine + end module m_wann_mmkb_int2 diff --git a/wannier/wann_mmkb_od_vac2.F b/wannier/wann_mmkb_od_vac2.F new file mode 100644 index 00000000..477aee92 --- /dev/null +++ b/wannier/wann_mmkb_od_vac2.F @@ -0,0 +1,331 @@ + MODULE m_wann_mmkb_od_vac2 +c************************************************************** +c Determines the overlap matrix Mmn(k,k+b) in the vacuum +c for the wannier functions. +c For more details see routine wannier.F and wann_mmk0_od_vac.F +c +c Y. Mokrousov, F. Freimuth +c*************************************************************** + CONTAINS + SUBROUTINE wann_mmkb_od_vac2( + > vacchi,l_noco,nlotot, + > nbnd,z1,nmzxyd,nmzd,nv2d,k1d,k2d,k3d,n2d,n3d, + > ig,nmzxy,nmz,delz,ig2,n2d_1, + > bbmat,evac,evac_b,bkpt,bkpt_b,MM,vM,vz,odi, + > nslibd,nslibd_b,jspin,jspin_b,k1,k2,k3,k1_b,k2_b,k3_b, + > jspd,nvd,area,nbasfcn,neigd, + > z,z_b,nv,nv_b,sk2,phi2,omtil,gb,qss, + > l_q, sign_q, + < mmn) + use m_constants, only : pimach + use m_od_types, only : od_inp + use m_od_abvac + use m_cylbes + use m_dcylbs + use m_intgr, only : intgz0 + + implicit none +c .. scalar Arguments.. + logical, intent (in) :: l_noco + integer, intent (in) :: nlotot + integer, intent (in) :: nmzxyd,nmzd,nv2d,k1d,k2d,k3d,n3d + integer, intent (in) :: nmzxy,nmz,MM,n2d,vM,nbnd + integer, intent (in) :: nslibd,nslibd_b + integer, intent (in) :: n2d_1,jspin,jspin_b,jspd,nvd + integer, intent (in) :: nbasfcn,neigd + real, intent (in) :: delz,z1,evac,area,omtil,evac_b + complex, intent (in) :: vacchi + type (od_inp), intent (in) :: odi + + logical, intent (in) :: l_q + integer, intent (in) :: sign_q + +c ..array arguments.. + real, intent (in) :: bkpt(:),bkpt_b(:),qss(:) !bkpt(3),bkpt_b(3),qss(3) + real, intent (in) :: sk2(:),phi2(:) !sk2(n2d),phi2(n2d) + integer, intent (in) :: ig(-k1d:,-k2d:,-k3d:) !ig(-k1d:k1d,-k2d:k2d,-k3d:k3d) + integer, intent (in) :: ig2(:),nv(:),nv_b(:) !ig2(n3d),nv(jspd),nv_b(jspd) + integer, intent (in) :: gb(:) !gb(3) + real, intent (in) :: vz(:),bbmat(:,:) !vz(nmzd),bbmat(3,3) + integer, intent (in) :: k1(:,:),k2(:,:),k3(:,:) !k1(nvd,jspd),k2(nvd,jspd),k3(nvd,jspd) + integer, intent (in) :: k1_b(:,:),k2_b(:,:),k3_b(:,:) !k1_b(nvd,jspd),k2_b(nvd,jspd),k3_b(nvd,jspd) + complex, intent (inout) :: mmn(:,:) !mmn(nbnd,nbnd) + +#if ( !defined(CPP_INVERSION) || defined(CPP_SOC) ) + complex, intent (in):: z(:,:),z_b(:,:) !z(nbasfcn,neigd),z_b(nbasfcn,neigd) +#else + real, intent (in):: z(:,:),z_b(:,:) !z(nbasfcn,neigd),z_b(nbasfcn,neigd) +#endif + + + !logical, intent (in) :: l_q ! dealing with q points? + +c ..basis wavefunctions in the vacuum + real, allocatable :: udz(:,:) + real, allocatable :: uz(:,:) + real, allocatable :: dudz(:,:) + real, allocatable :: duz(:,:) + real, allocatable :: u(:,:,:) + real, allocatable :: ud(:,:,:) + real, allocatable :: ddnv(:,:) + + real, allocatable :: udz_b(:,:) + real, allocatable :: uz_b(:,:) + real, allocatable :: dudz_b(:,:) + real, allocatable :: duz_b(:,:) + real, allocatable :: u_b(:,:,:) + real, allocatable :: ud_b(:,:,:) + real, allocatable :: ddnv_b(:,:) + +c ..local scalars.. + logical tail + real wronk,wronk1,arg,zks,tpi,uuo,udo,duo,ddo,zz,xx(nmz),zks0 + integer i,m,l,j,k,irec3,irec2,n,nv2,mp,ispin + integer nv2_b,np1,lprime,addnoco,addnoco2 + complex avac,bvac,ic,phasfc + complex, allocatable :: acof(:,:,:),bcof(:,:,:) + integer, allocatable :: kvac3(:),map1(:) + complex, allocatable :: acof_b(:,:,:),bcof_b(:,:,:) + integer, allocatable :: kvac3_b(:),map1_b(:) + real, allocatable :: bess(:),dbss(:) + real, allocatable :: gbess(:,:),besss(:) + REAL qssbti(3,2) + +c ..intrinsic functions.. + intrinsic aimag,cmplx,conjg,real,sqrt + + addnoco=0 + addnoco2=0 + if(l_noco.and.(jspin.eq.2))then + addnoco = nv(1) + nlotot + endif + if(l_noco.and.(jspin_b.eq.2))then + addnoco2 = nv_b(1) + nlotot + endif + + phasfc=cmplx(1.0,0.0) + + allocate ( udz(nv2d,-vM:vM),uz(nv2d,-vM:vM),dudz(nv2d,-vM:vM), + + duz(nv2d,-vM:vM),u(nmzd,nv2d,-vM:vM), + + ud(nmzd,nv2d,-vM:vM),ddnv(nv2d,-vM:vM), + + udz_b(nv2d,-vM:vM),uz_b(nv2d,-vM:vM), + + dudz_b(nv2d,-vM:vM), + + duz_b(nv2d,-vM:vM),u_b(nmzd,nv2d,-vM:vM), + + ud_b(nmzd,nv2d,-vM:vM),ddnv_b(nv2d,-vM:vM), + + bess(-odi%mb:odi%mb),dbss(-odi%mb:odi%mb), + + besss(-odi%M:odi%M),gbess(-odi%M:odi%M,nmzd), + + acof(nv2d,-odi%mb:odi%mb,nslibd), + + bcof(nv2d,-odi%mb:odi%mb,nslibd), + + acof_b(nv2d,-odi%mb:odi%mb,nslibd_b), + + bcof_b(nv2d,-odi%mb:odi%mb,nslibd_b), + + kvac3(nv2d),map1(nvd), + + kvac3_b(nv2d),map1_b(nvd) ) + + tpi = 2 * pimach() ; ic = cmplx(0.,1.) + + tail = .true. + np1 = nmz + 1 + + acof(:,:,:) = cmplx(0.,0.) ; bcof(:,:,:) = cmplx(0.,0.) + acof_b(:,:,:) = cmplx(0.,0.) ; bcof_b(:,:,:) = cmplx(0.,0.) + + nv2 = 0 ; nv2_b = 0 + + do 20 k = 1,nv(jspin) + do 10 j = 1,nv2 + if (k3(k,jspin).eq.kvac3(j)) then + map1(k) = j + goto 20 + endif + 10 continue + nv2 = nv2 + 1 + if (nv2.gt.nv2d) stop 'nv2d' + kvac3(nv2) = k3(k,jspin) + map1(k) = nv2 + 20 continue + + do 21 k = 1,nv_b(jspin_b) + do 11 j = 1,nv2_b + if (k3_b(k,jspin_b).eq.kvac3_b(j)) then + map1_b(k) = j + goto 21 + endif + 11 continue + nv2_b = nv2_b + 1 + if (nv2_b.gt.nv2d) stop 'nv2d' + kvac3_b(nv2_b) = k3_b(k,jspin_b) + map1_b(k) = nv2_b + 21 continue + + wronk = 2.0 + +c...for the k-point + + qssbti(1,1) = - qss(1)/2. + qssbti(2,1) = - qss(2)/2. + qssbti(1,2) = + qss(1)/2. + qssbti(2,2) = + qss(2)/2. + qssbti(3,1) = - qss(3)/2. + qssbti(3,2) = + qss(3)/2. + DO ispin = 1,1 ! jspins + CALL od_abvac( + > z1,nmzxyd,nmzd,nv2d,k1d,k2d,k3d,n2d,n3d, + > ig,odi%ig,tpi,qssbti(3,jspin), + > nmzxy,nmz,delz,ig2,odi%n2d, + > bbmat,wronk,evac,bkpt,odi%M,odi%mb, + > vz,kvac3,nv2, + < uz(1,-vM),duz(1,-vM),u(1,1,-vM),udz(1,-vM), + < dudz(1,-vM),ddnv(1,-vM),ud(1,1,-vM)) + ENDDO + + do k = 1,nv(jspin) + l = map1(k) + irec3 = ig(k1(k,jspin),k2(k,jspin),k3(k,jspin)) + if (irec3.ne.0) then + irec2 = ig2(irec3) + zks = sk2(irec2)*z1 + arg = phi2(irec2) + call cylbes(odi%mb,zks,bess) + call dcylbs(odi%mb,zks,bess,dbss) + do m = -odi%mb,odi%mb + wronk1 = uz(l,m)*dudz(l,m) - + - udz(l,m)*duz(l,m) + avac = exp(-cmplx(0.0,m*arg))*(ic**m)* + * cmplx(dudz(l,m)*bess(m) - + + udz(l,m)*sk2(irec2)*dbss(m),0.0)/ + / ((wronk1)*sqrt(omtil)) + bvac = exp(-cmplx(0.0,m*arg))*(ic**m)* + * cmplx(-duz(l,m)*bess(m) + + - uz(l,m)*sk2(irec2)*dbss(m),0.0)/ + / ((wronk1)*sqrt(omtil)) + do n = 1,nslibd + acof(l,m,n) = acof(l,m,n) + + + z(k+addnoco,n)*avac +c + conjg(z(k,n))*avac + bcof(l,m,n) = bcof(l,m,n) + + + z(k+addnoco,n)*bvac +c + conjg(z(k,n))*bvac + enddo + enddo ! -mb:mb + endif + enddo + +c...for the b-point + + DO ispin = 1,1 ! jspins + call od_abvac( + > z1,nmzxyd,nmzd,nv2d,k1d,k2d,k3d,n2d,n3d, + > ig,odi%ig,tpi,qssbti(3,jspin_b), + > nmzxy,nmz,delz,ig2,odi%n2d, + > bbmat,wronk,evac_b,bkpt_b,odi%M,odi%mb, + > vz,kvac3_b,nv2_b, + < uz_b(1,-vM),duz_b(1,-vM),u_b(1,1,-vM),udz_b(1,-vM), + < dudz_b(1,-vM),ddnv_b(1,-vM),ud_b(1,1,-vM)) + ENDDO + + do k = 1,nv_b(jspin_b) + l = map1_b(k) + irec3 = ig(k1_b(k,jspin_b),k2_b(k,jspin_b),k3_b(k,jspin_b)) + if (irec3.ne.0) then + irec2 = ig2(irec3) + zks = sk2(irec2)*z1 + arg = phi2(irec2) + call cylbes(odi%mb,zks,bess) + call dcylbs(odi%mb,zks,bess,dbss) + do m = -odi%mb,odi%mb + wronk1 = uz_b(l,m)*dudz_b(l,m) - + - udz_b(l,m)*duz_b(l,m) + avac = exp(-cmplx(0.0,m*arg))*(ic**m)* + * cmplx(dudz_b(l,m)*bess(m) - + + udz_b(l,m)*sk2(irec2)*dbss(m),0.0)/ + / ((wronk1)*sqrt(omtil)) + bvac = exp(-cmplx(0.0,m*arg))*(ic**m)* + & cmplx(-duz_b(l,m)*bess(m) + + - uz_b(l,m)*sk2(irec2)*dbss(m),0.0)/ + / ((wronk1)*sqrt(omtil)) + do n = 1,nslibd_b + acof_b(l,m,n) = acof_b(l,m,n) + + + z_b(k+addnoco2,n)*avac +c + conjg(z(k,n))*avac + bcof_b(l,m,n) = bcof_b(l,m,n) + + + z_b(k+addnoco2,n)*bvac +c + conjg(z(k,n))*bvac + enddo + enddo ! -mb:mb + endif + enddo ! k = 1,nv + +c now actually computing the Mmn matrix + + irec3 = ig(0,0,0) + if (irec3.eq.0) stop 'Gb is not in the list of Gs' + irec2 = ig2(irec3) + zks0 = sk2(irec2) + arg = phi2(irec2) + + gbess(:,:) = 0. + do i = 1,nmz + zz = z1+(i-1)*delz + zks = 0.0!zks0*zz + besss(:) = 0. + call cylbes(odi%M,zks,besss) + do m = 0,0!-odi%M,odi%M + gbess(m,i) = 1.0 !besss(m) +c gbess(i) = 1. + enddo + enddo + + do l = 1,nv2 + lprime = l !1,nv2_b + + if (kvac3(l).eq.kvac3_b(lprime)) then + + do m = -odi%mb,odi%mb + mp = m + + do i = 1,nmz + zz = z1+(i-1)*delz + xx(np1-i) = zz*u(i,l,m)*u_b(i,lprime,mp)!*gbess(mp-m,i) + enddo + call intgz0(xx,delz,nmz,uuo,tail) + + do i = 1,nmz + zz = z1+(i-1)*delz + xx(np1-i) = zz*u(i,l,m)*ud_b(i,lprime,mp)!*gbess(mp-m,i) + enddo + call intgz0(xx,delz,nmz,udo,tail) + + do i = 1,nmz + zz = z1+(i-1)*delz + xx(np1-i) = zz*ud(i,l,m)*u_b(i,lprime,mp)!*gbess(mp-m,i) + enddo + call intgz0(xx,delz,nmz,duo,tail) + + do i = 1,nmz + zz = z1+(i-1)*delz + xx(np1-i) = zz*ud(i,l,m)*ud_b(i,lprime,mp)!*gbess(mp-m,i) + enddo + call intgz0(xx,delz,nmz,ddo,tail) + + do i = 1,nslibd + do j = 1,nslibd_b + mmn(i,j) = mmn(i,j) + phasfc*area*( + * acof(l,m,i)*conjg(acof_b(lprime,mp,j))*uuo + + + acof(l,m,i)*conjg(bcof_b(lprime,mp,j))*udo + + + bcof(l,m,i)*conjg(acof_b(lprime,mp,j))*duo + + + bcof(l,m,i)*conjg(bcof_b(lprime,mp,j))*ddo )*vacchi + enddo + enddo + + enddo !m + + endif ! kvac(k)=kvac(k+b) + + enddo ! l + + deallocate ( udz,uz,dudz,duz,u,ud,ddnv,bess,dbss,acof,bcof ) + deallocate ( udz_b,uz_b,dudz_b,duz_b,u_b,ud_b,ddnv_b,gbess,besss ) + deallocate ( acof_b,bcof_b ) + + END SUBROUTINE wann_mmkb_od_vac2 + END MODULE m_wann_mmkb_od_vac2 diff --git a/wannier/wann_mmkb_sph2.F b/wannier/wann_mmkb_sph2.F new file mode 100644 index 00000000..ebafaa9b --- /dev/null +++ b/wannier/wann_mmkb_sph2.F @@ -0,0 +1,247 @@ + MODULE m_wann_mmkb_sph2 + contains + subroutine wann_mmkb_sph2( +c*********************************************************************** +c computes the Mmn(k,b) matrix elements which are the overlaps +c between the Bloch wavefunctions at the state m and n +c at the k-point and its nearest neighbor b (bpt), in the spheres +c Y.Mokrousov 15.6.06 +c*********************************************************************** +c the gaunt coefficients impose certain conditions (which can be +c seen in the gaunt.F) on the l,lp,lpp angular momenta, which can be +c used in order to speedup the procedure. +c The conditions are the following: +c 1. |l - l''| <= l' <= l + l'' +c 2. m' = m + m'' +c 3. l + l' + l'' - is even +c*********************************************************************** +c modified for use in conjunction with wann_ujugaunt, which +c calculates certain matrix elements that have to be treated only +c once per calculation +c Frank Freimuth, October 2006 +c*********************************************************************** + > nbnd,llod,nslibd,nslibd_b,nlod,natd,ntypd,lmd,jmtd, + > taual,nop,lmax, + > ntype,neq,nlo,llo,acof,bcof,ccof,bbpt, + > acof_b,bcof_b,ccof_b,gb,bkpt,ujug,ujdg,djug,djdg,ujulog, + > djulog,ulojug,ulojdg,ulojulog,kdiff,nntot,chi, + = mmn) + + USE m_fleurenv + use m_constants, only : pimach + use m_matmul , only : matmul3,matmul3r + use m_sphbes + use m_ylm + use m_intgr, only : intgr3 + use m_gaunt, only: gaunt1 + use m_cotra + + implicit none + +c .. scalar arguments .. + integer, intent (in) :: llod,nlod,natd,ntypd,lmd,nbnd + integer, intent (in) :: nntot + integer, intent (in) :: ntype,nslibd,nslibd_b,nop,jmtd + +c .. array arguments .. + integer, intent (in) :: neq(:) !(ntypd) + integer, intent (in) :: lmax(:) !(ntypd) + integer, intent (in) :: nlo(:) !(ntypd) + integer, intent (in) :: llo(:,:) !(nlod,ntypd) + complex, intent (in) :: chi + real, intent (in) :: bbpt(:) !(3) + real, intent (in) :: taual(:,:) !(3,natd) + real, intent (in) :: bkpt(:) !(3) + integer, intent (in) :: gb(:) !(3) + complex, intent (in) :: ccof(-llod:,:,:,:) !(-llod:llod,nslibd,nlod,natd) + complex, intent (in) :: acof(:,0:,:) !(nslibd,0:lmd,natd) + complex, intent (in) :: bcof(:,0:,:) !(nslibd,0:lmd,natd) + complex, intent (in) :: ccof_b(-llod:,:,:,:) !(-llod:llod,nslibd_b,nlod,natd) + complex, intent (in) :: acof_b(:,0:,:) !(nslibd_b,0:lmd,natd) + complex, intent (in) :: bcof_b(:,0:,:) !(nslibd_b,0:lmd,natd) + + complex, intent (in) :: ujug(0:,0:,:,:) !(0:lmd,0:lmd,1:ntype,1:nntot) + complex, intent (in) :: ujdg(0:,0:,:,:) !(0:lmd,0:lmd,1:ntype,1:nntot) + complex, intent (in) :: djug(0:,0:,:,:) !(0:lmd,0:lmd,1:ntype,1:nntot) + complex, intent (in) :: djdg(0:,0:,:,:) !(0:lmd,0:lmd,1:ntype,1:nntot) + complex, intent (in) :: ujulog(0:,:,-llod:,:,:) !(0:lmd,nlod,-llod:llod,1:ntype,1:nntot) + complex, intent (in) :: djulog(0:,:,-llod:,:,:) !(0:lmd,nlod,-llod:llod,1:ntype,1:nntot) + complex, intent (in) :: ulojug(0:,:,-llod:,:,:) !(0:lmd,nlod,-llod:llod,1:ntype,1:nntot) + complex, intent (in) :: ulojdg(0:,:,-llod:,:,:) !(0:lmd,nlod,-llod:llod,1:ntype,1:nntot) + complex, intent (in) :: ulojulog(:,-llod:,:,-llod:,:,:) !(1:nlod,-llod:llod,1:nlod,-llod:llod,1:ntype,1:nntot) + + real, intent (in) :: kdiff(:,:) !(3,nntot) + complex,intent(inout) :: mmn(:,:) !(nbnd,nbnd) + + +c .. local scalars .. + integer i,lm,nn,n,na,j,lmp,l,lp,m,mp,lwn,lo,lop + integer ll,llp + real rph,cph,tpi,th,t1nn,t2nn,t3nn,dummy + complex ic + integer nene + complex :: fac1,fac2,fac3,fac4 + complex :: fac5,fac6,fac7,fac8 +C .. +C .. local arrays .. + real bpt(3) + +C .. +C .. intrinsic functions .. + intrinsic conjg,cmplx,sqrt,cos,sin + + ic = cmplx(0.,1.) + tpi = 2* pimach() + + na = 0 + +! bpt(:) = bbpt(:) + gb(:) - bkpt(:) +! do nene=1,nntot +! if(all(abs(bpt(:)-kdiff(:,nene)).lt.1e-4)) exit +! enddo +! IF(nene==nntot+1) CALL fleur_err +! + ("cannot find matching nearest neighbor k",calledby +! + ="wann_mmkb_sph") + + nene=1 + + do n=1,ntype + lwn = lmax(n) + do nn = 1,neq(n) ! cycle by the atoms within the atom type + na = na + 1 +c...set up phase factors ( e^{ib\tau} ) + +! t1nn = tpi*taual(1,na) +! t2nn = tpi*taual(2,na) +! t3nn = tpi*taual(3,na) + +! th = bpt(1)*t1nn + bpt(2)*t2nn + bpt(3)*t3nn + rph = 2*tpi!*cos(th) + cph = 0.0!2*tpi*sin(th) + +c...contributions from the apws + + do l = 0,lwn + ll = l*(l+1) + do m = -l,l + lm = ll + m + + lp = l + mp = m + +! do lp = 0,lwn + llp = lp*(lp+1) +! do mp = -lp,lp + lmp = llp + mp + fac1=cmplx(rph,cph)*ujug(lmp,lm,n,nene)*chi + fac2=cmplx(rph,cph)*ujdg(lmp,lm,n,nene)*chi + fac3=cmplx(rph,cph)*djug(lmp,lm,n,nene)*chi + fac4=cmplx(rph,cph)*djdg(lmp,lm,n,nene)*chi + + do j = 1,nslibd_b + fac5=conjg(acof_b(j,lmp,na))*fac1 + fac6=conjg(bcof_b(j,lmp,na))*fac2 + fac7=conjg(acof_b(j,lmp,na))*fac3 + fac8=conjg(bcof_b(j,lmp,na))*fac4 + do i = 1,nslibd + mmn(i,j) = mmn(i,j) + + + acof(i,lm,na)*fac5+ + + acof(i,lm,na)*fac6+ + + bcof(i,lm,na)*fac7+ + + bcof(i,lm,na)*fac8 + enddo + enddo + +! enddo ! mp +! enddo ! lp + + enddo ! m + enddo ! l + + +c...contributions from the local orbitals with apws + + if (nlo(n).ge.1) then + + do lo = 1,nlo(n) + l = llo(lo,n) + ll = l*(l+1) + do m = -l,l + lm = ll + m + + lp = l + mp = m + +! do lp = 0,lwn + llp = lp*(lp+1) +! do mp = -lp,lp + lmp = llp + mp + + fac1=cmplx(rph,cph)*ujulog(lmp,lo,m,n,nene)*chi + fac2=cmplx(rph,cph)*djulog(lmp,lo,m,n,nene)*chi + fac3=cmplx(rph,cph)*ulojdg(lmp,lo,m,n,nene)*chi + fac4=cmplx(rph,cph)*ulojug(lmp,lo,m,n,nene)*chi + + do j = 1,nslibd_b + do i = 1,nslibd + mmn(i,j) = mmn(i,j) + + + ccof(m,i,lo,na)* + * (conjg(acof_b(j,lmp,na))*fac1+ + + conjg(bcof_b(j,lmp,na))*fac2 )+ + + + conjg(ccof_b(m,j,lo,na))* + * ( bcof(i,lmp,na)*fac3 + + + acof(i,lmp,na)*fac4 ) + enddo + enddo + + +! enddo ! mp +! enddo ! lp + + enddo ! lo + enddo ! m lo + +c...contributions from lo*lo + + do lo = 1,nlo(n) + l = llo(lo,n) + ll = l*(l+1) + do m = -l,l + lm = ll + m + + do lop = 1,nlo(n) + lp = llo(lop,n) + if(lp.ne.l) cycle + llp = lp*(lp+1) +! do mp = -lp,lp + mp = m + lmp = llp + mp + + fac1=cmplx(rph,cph)*ulojulog(lop,mp,lo,m,n,nene)*chi + + do j = 1,nslibd_b + do i = 1,nslibd + + mmn(i,j) = mmn(i,j) + + + ccof(m,i,lo,na)*conjg(ccof_b(mp,j,lop,na))* + * fac1 + + enddo + enddo + +! enddo ! mp lop + enddo ! lop + + enddo ! m lo + enddo ! lo + + endif ! local orbitals on this atom + + enddo ! atoms in the type + + enddo ! atom type + + + end subroutine wann_mmkb_sph2 + end module m_wann_mmkb_sph2 diff --git a/wannier/wann_nocoplot.F b/wannier/wann_nocoplot.F new file mode 100644 index 00000000..4513ea70 --- /dev/null +++ b/wannier/wann_nocoplot.F @@ -0,0 +1,308 @@ + MODULE m_wann_nocoplot + USE m_fleurenv +c ++++++++++++++++++++++++++++++++++++++++++++++++ +c + If noco=t, transform wave functions within + +c + mu-th MT back to the global frame to plot + +c + to plot WFs in a meaningful way. + +c + + +c ++++++++++++++++++++++++++++++++++++++++++++++++ + CONTAINS + SUBROUTINE wann_nocoplot(slice,nnne,amat,bmat + > ,nkpts,odi,film,natd,ntypd,jmtd + > ,ntype,neq,pos,jri,rmsh,alph,beta + > ,nqpts,qss,z1,zatom) +! ***************************************************** + USE m_od_types, ONLY : od_inp, od_sym + USE m_dotir + USE m_xsf_io + USE m_cotra, ONLY : cotra1 + USE m_wann_gwf_tools, ONLY : get_index_q + USE m_constants, ONLY : pimach + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: slice,film + INTEGER, INTENT(IN) :: nnne,nkpts,ntypd,jmtd,natd + INTEGER, INTENT(IN) :: ntype,neq(ntypd) + INTEGER, INTENT(IN) :: jri(ntypd),nqpts + REAL, INTENT(IN) :: amat(3,3),bmat(3,3),qss(3,nqpts) + REAL, INTENT(IN) :: rmsh(jmtd,ntypd) + REAL, INTENT(IN) :: pos(3,natd),z1,zatom(:) + REAL, INTENT(IN) :: alph(ntypd),beta(ntypd) + + TYPE(od_inp), INTENT(in) :: odi + + LOGICAL :: twodim,xsf,cartesian + INTEGER :: nbmin,nbmax,nplot,nplo,nbn + INTEGER :: nslibd,nkqpts + INTEGER :: ix,iy,iz,ikpt,jspin + INTEGER :: ii1,ii2,ii3 + INTEGER :: i1,i2,i3,iintsp + INTEGER :: gx,gy,gz,help_kpt + INTEGER :: na,nt,nq,iqpt + INTEGER :: grid(3),count_mt,count_int,count_vac + REAL :: vec1(3),vec2(3),vec3(3),zero(3) + REAL :: pt(3),point(3),rcc2(3) + REAL :: s,arg,pi,u_r,u_i + COMPLEX :: ci,phasfac + COMPLEX :: U(2,2) + COMPLEX :: wf_local(2),wf_global,xdnout + CHARACTER(len=30) :: filename + CHARACTER(len=20) :: vandername,name1,name2,name3 + + NAMELIST /plot/twodim,cartesian,vec1,vec2,vec3,grid,zero,filename + + intrinsic real,aimag,conjg,exp,cmplx + + pi = pimach() + ci = cmplx(0.0,1.0) + nkqpts = nkpts*nqpts + + INQUIRE(file ="plot_inp",exist=twodim) + IF(.NOT.twodim) THEN + CALL fleur_err("Need the plot_inp from RNK generation!" + > ,calledby="wann_nocoplot") + ENDIF + + !<-- Open the plot_inp file for input + OPEN (18,file='plot_inp') + READ(18,'(i2,5x,l1)') nplot,xsf + + IF (nplot.ge.2) + & CALL fleur_err + + ("plots one by one, please, this is not charge density" + + ,calledby="wann_nocoplot") + + ! the defaults + twodim = .TRUE.;cartesian=.TRUE.;grid=(/100,100,100/) + vec1 = (/0.,0.,0./);vec2=(/0.,0.,0./);vec3=(/0.,0.,0./) + zero = (/0.,0.,0./);filename="default" + READ(18,plot) + IF (twodim.AND.ANY(grid(1:2)<1)) + + CALL fleur_err("Illegal grid size in plot",calledby + + ="wann_nocoplot") + IF (.NOT.twodim.AND.ANY(grid<1)) + + CALL fleur_err("Illegal grid size in plot",calledby + + ="wann_nocoplot") + IF (twodim) grid(3) = 1 + !calculate cartesian coordinates if needed + IF (.NOT.cartesian) THEN + vec1=matmul(amat,vec1) + vec2=matmul(amat,vec2) + vec3=matmul(amat,vec3) + zero=matmul(amat,zero) + ENDIF + IF (filename =="default") WRITE(filename,'(a,i2)') "plot",1 + CLOSE(18) + + ! loop over k-points + DO ikpt=1,nkqpts + count_mt=0; count_int=0; count_vac=0 + iqpt = get_index_q(ikpt,nkpts) + write(*,*)'kq',ikpt,' q',iqpt,' qz',qss(3,iqpt) + + ! open the old RNK.ikpt.jspin files + DO jspin=1,2 ! local frame axis (inside MT) + WRITE(vandername,202) ikpt,jspin + OPEN(400+jspin,file=vandername) + READ(400+jspin,7)gx,gy,gz,help_kpt,nslibd + ENDDO + + IF(.not.xsf) THEN + ! open the new UNK.ikpt.iintsp files + DO iintsp=1,2 ! global frame axis (INT and vacuum) + WRITE(vandername,201) ikpt,iintsp + OPEN(500+iintsp,file=vandername,status='unknown') + WRITE(500+iintsp,7)grid(1),grid(2),grid(3),ikpt,nslibd + ENDDO + ENDIF + + ! loop over all bands + nbmin=1 + nbmax=nslibd + bands:DO nbn = nbmin,nbmax + + IF (xsf) THEN + do jspin=1,2 + write (name1,22) ikpt,nbn,jspin + 22 format (i5.5,'.',i3.3,'.real.',i1,'.xsf') + write (name2,23) ikpt,nbn,jspin + 23 format (i5.5,'.',i3.3,'.imag.',i1,'.xsf') + write (name3,24) ikpt,nbn,jspin + 24 format (i5.5,'.',i3.3,'.absv.',i1,'.xsf') + OPEN(600+jspin,file=name1) + CALL xsf_WRITE_atoms( + > 600+jspin,film,odi%d1,amat,neq(:ntype), + > zatom(:ntype),pos) + OPEN(602+jspin,file=name2) + CALL xsf_WRITE_atoms( + > 602+jspin,film,odi%d1,amat,neq(:ntype), + > zatom(:ntype),pos) + OPEN(604+jspin,file=name3) + CALL xsf_WRITE_atoms( + > 604+jspin,film,odi%d1,amat,neq(:ntype), + > zatom(:ntype),pos) + CALL xsf_WRITE_header(600+jspin,twodim,filename,(vec1), + & (vec2),(vec3),zero + $ ,grid) + CALL xsf_WRITE_header(602+jspin,twodim,filename,(vec1), + & (vec2),(vec3),zero + $ ,grid) + CALL xsf_WRITE_header(604+jspin,twodim,filename,(vec1), + & (vec2),(vec3),zero + $ ,grid) + enddo + ENDIF + + ! loop over real space grid points + DO iz = 0,grid(3)-1 + DO iy = 0,grid(2)-1 + xloop:DO ix = 0,grid(1)-1 + point = zero+vec1*REAL(ix)/grid(1)+vec2*REAL(iy) + $ /grid(2) + IF (.NOT.twodim) point = point+vec3*REAL(iz)/grid(3) + + ! read old RNK information at grid point + DO jspin=1,2 + READ(400+jspin,8)u_r,u_i + wf_local(jspin) = cmplx(u_r,u_i) + ENDDO + + ! is point in MT? + ii1 = 3 + ii2 = 3 + ii3 = 3 + IF (film .AND. .NOT.odi%d1) ii3 = 0 + IF (odi%d1) THEN + ii1 = 0 ; ii2 = 0 + END IF + DO i1 = -ii1,ii1 + DO i2 = -ii2,ii2 + DO i3 = -ii3,ii3 + pt = point+MATMUL(amat,(/i1,i2,i3/)) + na = 0 + DO nt = 1,ntype + DO nq = 1,neq(nt) + na = na + 1 + s = SQRT(dot_PRODUCT(pos(:,na)-pt,pos(:,na)-pt)) + IF (s global + U(1,1) = exp(-ci*alph(nt)/2.)*cos(beta(nt)/2.) + U(1,2) = -exp(-ci*alph(nt)/2.)*sin(beta(nt)/2.) + U(2,1) = exp( ci*alph(nt)/2.)*sin(beta(nt)/2.) + U(2,2) = exp( ci*alph(nt)/2.)*cos(beta(nt)/2.) + + ! transform wfs to global frame + DO iintsp=1,2 + CALL cotra1(pt(1),rcc2,bmat) + arg = -pi*real(2*iintsp-3)*( qss(1,iqpt)*rcc2(1) + > +qss(2,iqpt)*rcc2(2) + > +qss(3,iqpt)*rcc2(3)) + phasfac = cmplx(cos(arg),sin(arg)) + + wf_global= phasfac*( U(iintsp,1)*wf_local(1) + > + U(iintsp,2)*wf_local(2) ) + + if(xsf) THEN + xdnout=wf_global + WRITE(600+iintsp,*) real(xdnout) + WRITE(602+iintsp,*) aimag(xdnout) + WRITE(604+iintsp,*) real(xdnout*conjg(xdnout)) + ELSE + WRITE(500+iintsp,8)real(wf_global), + > aimag(wf_global) + ENDIF + ENDDO + + CYCLE xloop + ENDIF + ENDDO + ENDDO !nt + ENDDO + ENDDO + ENDDO !i1 + + ! VACUUM region + IF (SQRT((pt(1))**2+(pt(2))**2)>=z1)THEN + count_vac=count_vac+1 + DO iintsp=1,2 + phasfac=cmplx(1.,0.) + wf_global = phasfac*wf_local(iintsp) + + if(xsf) THEN + xdnout=wf_global + WRITE(600+iintsp,*) real(xdnout) + WRITE(602+iintsp,*) aimag(xdnout) + WRITE(604+iintsp,*) real(xdnout*conjg(xdnout)) + ELSE + WRITE(500+iintsp,8)real(wf_global), + > aimag(wf_global) + ENDIF + ENDDO + + CYCLE xloop + ENDIF + + ! if we are here, point is in INTERSTITIAL + ! therefore just copy wfs + count_int = count_int+1 + DO iintsp=1,2 + phasfac=cmplx(1.,0.) + wf_global = phasfac*wf_local(iintsp) + + if(xsf) THEN + xdnout=wf_global + WRITE(600+iintsp,*) real(xdnout) + WRITE(602+iintsp,*) aimag(xdnout) + WRITE(604+iintsp,*) real(xdnout*conjg(xdnout)) + ELSE + WRITE(500+iintsp,8)real(wf_global), + > aimag(wf_global) + ENDIF + ENDDO + + ENDDO xloop + ENDDO + ENDDO !z-loop + + IF (xsf) THEN + DO iintsp=1,2 + CALL xsf_WRITE_endblock(600+iintsp,twodim) + CALL xsf_WRITE_endblock(602+iintsp,twodim) + CALL xsf_WRITE_endblock(604+iintsp,twodim) + CLOSE(600+iintsp); CLOSE(602+iintsp); CLOSE(604+iintsp) + ENDDO + ENDIF + + ENDDO bands + + IF(.not.xsf) THEN + ! close new UNK.ikpt.iintsp files + DO iintsp=1,2 + CLOSE(500+iintsp) + ENDDO + ENDIF + + ! delete RNK.ikpt.jspin files + DO jspin=1,2 + IF(xsf) THEN + CLOSE(400+jspin) + ELSE + CLOSE(400+jspin,status='delete') + ENDIF + ENDDO + + write(*,*)count_mt,count_int,count_vac + + ENDDO ! end ikpt loop + + 201 FORMAT ('UNK',i5.5,'.',i1) + 202 FORMAT ('RNK',i5.5,'.',i1) + 7 FORMAT (5i4) + 8 FORMAT (f20.12,1x,f20.12) + + END SUBROUTINE wann_nocoplot +!------------------------------------------ + + END MODULE m_wann_nocoplot diff --git a/wannier/wann_orbmag.F b/wannier/wann_orbmag.F new file mode 100644 index 00000000..898e2e4c --- /dev/null +++ b/wannier/wann_orbmag.F @@ -0,0 +1,925 @@ + MODULE m_wann_orbmag + USE m_fleurenv + CONTAINS + SUBROUTINE wann_orbmag( + > 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,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,irecl,l_soc, + > memd,lnonsph,clnu,lmplmd,mlh,nmem,llh,lo1l, + > theta,phi,soc_opt, + > ikpt,nntot,fullnkpts,bpt,wannierspin,jspin,jspin_b, + > nlotot,nrec,nrec_b, + > l_gwf,iqpt,numbands,wann,lmd,ngopr1, + > us,uds,dus,duds,ddn,ulos,dulos,uulon,dulon, + > qpt_i,alph_i,beta_i,k1,k2,k3,nv,nmat,noccbd,nslibd, + > kveclo,bkpt,chi, + > flo,ff,gg, + > gb,kdiff,nbnd,uHu) + + use m_types + use m_wann_rw_eig + use m_abcof_small + use m_radfun + use m_radflo + use m_cdnread, only : cdn_read0, cdn_read + use m_od_types, only : od_inp, od_sym + use m_wann_abinv + use m_wann_kptsrotate + use m_matmul,only : matmul3,matmul3r + use m_wann_uHu_int2 + use m_wann_mmkb_sph + use m_wann_ujugaunt + + IMPLICIT NONE +#include "cpp_double.h" +#ifdef CPP_MPI + include 'mpif.h' + integer ierr(3) + integer cpu_index + integer stt(MPI_STATUS_SIZE) + +#endif + logical, intent (in) :: invs,invs2,film,slice,symor + integer, intent (in) :: lmaxd,ntypd,neigd,nkptd,kk,nnne + integer, intent (in) :: natd,nop,nvd,jspd,nbasfcn,nq2,nop2 + integer, intent (in) :: llod,nlod,ntype,nwdd,n3d,n2d + integer, intent (in) :: nmzxyd,nmzd,jmtd,nlhd,nq3,nvac + integer, intent (in) :: ntypsd,jspins,k1d,k2d,k3d + real, intent (in) :: omtil,e1s,e2s,delz,area,z1,volint + integer, intent (in) :: ig(-k1d:k1d,-k2d:k2d,-k3d:k3d) + real, intent (in) :: rgphs(-k1d:k1d,-k2d:k2d,-k3d:k3d) + integer, intent (in) :: nlh(ntypsd),jri(ntypd),ntypsy(natd) + integer, intent (in) :: nlo(ntypd),llo(nlod,ntypd),lapw_l(ntypd) + integer, intent (in) :: invtab(nop),mrot(3,3,nop),ngopr(natd) + integer, intent (in) :: neq(ntypd),lmax(ntypd) + integer, intent (in) :: invsat(natd),invsatnr(natd),nkpt(nwdd) + integer, intent (in) :: irank,isize,nv2d,nmzxy,nmz + integer, intent (in) :: ulo_der(nlod,ntypd),ig2(n3d) + real, intent (in) :: taual(3,natd),rmt(ntypd),dx(ntypd) + real, intent (in) :: amat(3,3),bmat(3,3),bbmat(3,3) + real, intent (in) :: rmsh(jmtd,ntypd),tau(3,nop),zatom(ntype) + real, intent (inout) :: alph(ntypd),beta(ntypd),qss(3) + real, intent (in) :: pos(3,natd) + real, intent(in) :: ef + + complex, intent (in) :: ustep(n3d) + logical, intent (in) :: l_dulo(nlod,ntypd),l_noco,l_ss + integer, intent (in) :: irecl + logical, intent (in) :: l_soc + integer, intent (in) :: memd + integer, intent (in) :: lnonsph(ntypd) + complex, intent (in) :: clnu(memd,0:nlhd,ntypsd) + integer, intent (in) :: lmplmd + integer, intent (in) :: mlh(memd,0:nlhd,ntypsd) + integer, intent (in) :: nmem(0:nlhd,ntypsd) + integer, intent (in) :: llh(0:nlhd,ntypsd) + integer, intent (in) :: lo1l(0:llod,ntypd) + real, intent (in) :: sk2(n2d),phi2(n2d) + type (od_inp), intent (in) :: odi + type (od_sym), intent (in) :: ods + real, intent(in) :: theta,phi + logical,intent(in) :: soc_opt(ntype+2) + + integer, intent(in) :: ikpt,nntot,fullnkpts,lmd + integer, intent(in) :: bpt(nntot,fullnkpts) + integer, intent(in) :: ngopr1(natd) + integer, intent(in) :: wannierspin,jspin,jspin_b,nbnd,nslibd + integer, intent(in) :: nv(wannierspin) + integer, intent(in) :: nlotot,nrec,nrec_b,iqpt,numbands + integer, intent(in) :: nmat,noccbd,kveclo(nlotot) + real, intent(in) :: bkpt(3) + + integer,intent(in) :: k1(nvd,wannierspin) + integer,intent(in) :: k2(nvd,wannierspin) + integer,intent(in) :: k3(nvd,wannierspin) + logical, intent(in) :: l_gwf + type(t_wann), intent(in) :: wann + real, intent(in) :: us(0:lmaxd,ntypd,2) + real, intent(in) :: uds(0:lmaxd,ntypd,2) + real, intent(in) :: dus(0:lmaxd,ntypd,2) + real, intent(in) :: duds(0:lmaxd,ntypd,2) + real, intent(in) :: ddn(0:lmaxd,ntypd,2) + real, intent(in) :: ulos(nlod,ntypd,2) + real, intent(in) :: uulon(nlod,ntypd,2) + real, intent(in) :: dulon(nlod,ntypd,2) + real, intent(in) :: dulos(nlod,ntypd,2) + real, intent(in) :: qpt_i(3),alph_i(ntypd),beta_i(ntypd) + + real, intent(in) :: ff(ntypd,jmtd,2,0:lmaxd,2) + real, intent(in) :: gg(ntypd,jmtd,2,0:lmaxd,2) + real, intent(in) :: flo(ntypd,jmtd,2,nlod,2) + + complex, intent(in) :: chi(ntypd) + complex :: ujug(0:lmd,0:lmd,ntype,nntot,4), + > ujdg(0:lmd,0:lmd,ntype,nntot,4), + > djug(0:lmd,0:lmd,ntype,nntot,4), + > djdg(0:lmd,0:lmd,ntype,nntot,4), + > ujulog(0:lmd,nlod,-llod:llod,ntype,nntot,4), + > djulog(0:lmd,nlod,-llod:llod,ntype,nntot,4), + > ulojug(0:lmd,nlod,-llod:llod,ntype,nntot,4), + > ulojdg(0:lmd,nlod,-llod:llod,ntype,nntot,4), + > ulojulog(nlod,-llod:llod,nlod,-llod:llod,ntype,nntot,4) + integer, intent (in) :: gb(3,nntot,fullnkpts) + real, intent (in) :: kdiff(3,nntot) + + + complex, intent(inout) :: uHu(nbnd,nbnd,nntot,nntot) + + integer :: i,j,g1,g2,g3,g4,n + integer :: funbas + integer :: info + integer, allocatable :: ipiv(:) + complex, allocatable :: work(:) + complex, allocatable :: tmp_mat1(:,:),tmp_mat2(:,:) + + integer :: ikpt_b,n_start,n_end,kptibz_b + integer :: jspin2,jspin3,jspin4,jspin5 + integer :: addnoco_kb,addnoco_kb2,addnoco,addnoco2 + integer :: nmat_b,nbands_b,nslibd_b,noccbd_b + integer :: nv_b(wannierspin) + integer :: kveclo_b(nlotot) + integer :: k1_b(nvd,wannierspin) + integer :: k2_b(nvd,wannierspin) + integer :: k3_b(nvd,wannierspin) + real :: eig_b(neigd),we_b(neigd) + + integer :: ikpt_b2,kptibz_b2 + integer :: nmat_b2,nbands_b2,nslibd_b2,noccbd_b2 + integer :: nv_b2(wannierspin) + integer :: kveclo_b2(nlotot) + integer :: k1_b2(nvd,wannierspin) + integer :: k2_b2(nvd,wannierspin) + integer :: k3_b2(nvd,wannierspin) + real :: eig_b2(neigd),we_b2(neigd) + + complex, allocatable :: acof(:,:,:,:) + complex, allocatable :: bcof(:,:,:,:) + complex, allocatable :: ccof(:,:,:,:,:) + + complex, allocatable :: acof_b(:,:,:) + complex, allocatable :: bcof_b(:,:,:) + complex, allocatable :: ccof_b(:,:,:,:) + + complex, allocatable :: acof_b2(:,:,:) + complex, allocatable :: bcof_b2(:,:,:) + complex, allocatable :: ccof_b2(:,:,:,:) + + complex, allocatable :: acof_tmp(:,:,:) + complex, allocatable :: bcof_tmp(:,:,:) + complex, allocatable :: ccof_tmp(:,:,:,:) + + complex :: I1(nvd,nvd),II1(neigd,nvd),III1(neigd,nvd) + complex :: I2(nvd,nvd),II2(nvd,neigd) + + real :: cp_time(9) + real :: bkpt_b(3),wk_b + real :: bkpt_b2(3),wk_b2 + real :: ello(nlod,ntypd,max(2,jspd)),evac(2,max(2,jspd)) + real :: epar(0:lmaxd,ntypd,max(2,jspd)),evdu(2,max(jspd,2)) + real :: eigg(neigd) + +#if ( !defined(CPP_INVERSION) || defined(CPP_SOC) ) + complex :: zz(nbasfcn,neigd) + complex :: z_b(nbasfcn,neigd),z_tmp(nbasfcn,neigd) + complex :: z_b2(nbasfcn,neigd) +#else + real :: zz(nbasfcn,neigd) + real :: z_b(nbasfcn,neigd),ztemp(nbasfcn,neigd) + real :: z_b2(nbasfcn,neigd) +#endif + +#ifdef CPP_INVERSION + real,allocatable :: hpack(:), ham(:,:) + real,allocatable :: Spack(:), Sinv(:,:) +#else + complex,allocatable :: hpack(:), ham(:,:) + complex,allocatable :: Spack(:), Sinv(:,:) + complex,allocatable :: S(:,:) +#endif + integer :: matsize,nv1,nv2,nbasfcn2,lwork + integer :: ind_uu(2),ind_dd(2),ind_du(2) + real :: diff,mdiff + character(len=20)::fn + + info=0 + addnoco =0 + addnoco2=0 + + addnoco_kb =0 + addnoco_kb2=0 + + nbasfcn2 = nbasfcn + nbasfcn2 = nv(1)+nv(2)+nlotot +!**************************************! +! read in Hamiltonian at k ! +!**************************************! + jspin2 = jspin + if(l_noco) jspin2 = 1 + write(*,'(a,f8.5,1x,f8.5,1x,f8.5)')'k : ',bkpt + write(fn,'("ham_",i4.4,".",i1)')ikpt,jspin2 + open(879,file=trim(fn),form='unformatted') + read(879)matsize,nv1,nv2 + if(nv1.ne.nv(1)) stop 'nv1.ne.nv(1)' + if(nv2.ne.nv(2)) stop 'nv2.ne.nv(2)' + allocate(hpack(matsize)) + allocate(Spack(matsize)) + read(879)hpack(1:matsize) + read(879)Spack(1:matsize) + close(879) + write(*,*)'matsize',matsize + + ! indices for checks of up-up, down-down, and down-up blocks + !ind_uu(1)=1 + !ind_uu(2)=nv1*(nv1+1)/2 + !ind_dd(1)=ind_uu(2)+nv(1)+1 + !ind_dd(2)=(nv1+nv2)*(nv1+nv2+1)/2 + !do i=ind_uu(1),ind_uu(2) + ! write(*,*)'up-up',i,Spack(i) + !enddo + !do i=ind_dd(1),ind_dd(2) + ! write(*,*)'down-down',i,Spack(i) + !enddo + + ! are overlaps real? + do i=1,matsize + if(aimag(Spack(i)).ne.0.0) write(*,*)'imag',i + enddo + + ! set up S for later check 1=SS^{-1} + allocate(S(nbasfcn2,nbasfcn2)) + do j=1,nbasfcn2 + do i=1,j + n = i+(j-1)*j/2 + S(i,j)= Spack(n) + enddo + enddo + do j=1,nbasfcn2 + do i=j+1,nbasfcn2 + S(i,j) = conjg(S(j,i)) + enddo + enddo + + ! write out diagonal of S + !do i=1,nbasfcn2 + ! write(*,*)'S(i,i)',i,S(i,i) + !enddo + + ! S^{-1} for indefinite Hermitian S (packed) + !allocate(ipiv(nbasfcn2), work(nbasfcn2)) + !call zhptrf('U',nbasfcn2,Spack,ipiv,info) + !if(info.ne.0) then stop 'info1' + !call zhptri('U',nbasfcn2,Spack,ipiv,work,info) + !if(info.ne.0) then stop 'info2' + !deallocate(ipiv,work) + + ! set up H and S^{-1} resp. S matrices + allocate(ham(nbasfcn2,nbasfcn2)) + allocate(Sinv(nbasfcn2,nbasfcn2)) + do j=1,nbasfcn2 ! FOR 'U' + do i=1,j + n = i+(j-1)*j/2 + ham(i,j) = hpack(n) + Sinv(i,j)= Spack(n) + enddo + enddo + !do i=1,nbasfcn2 ! FOR 'L' + ! do j=1,i + ! n = i+(j-1)*(2*nbasfcn2-j)/2 + ! ham(i,j) = hpack(n) + ! Sinv(i,j)= Spack(n) + ! enddo + !enddo + deallocate(hpack) + deallocate(Spack) + + ! complete Hermitian S^{-1} + do j=1,nbasfcn2 ! FOR 'U' + do i=j+1,nbasfcn2 + ham(i,j) = conjg(ham(j,i)) + Sinv(i,j) = conjg(Sinv(j,i)) + enddo + enddo + !do i=1,nbasfcn2 ! FOR 'L' + ! do j=i+1,nbasfcn2 + ! ham(i,j) = conjg(ham(j,i)) + ! Sinv(i,j) = conjg(Sinv(j,i)) + ! enddo + !enddo + + ! is S^{-1} real? + do i=1,nbasfcn2 + do j=1,i + if(aimag(Sinv(i,j)).ne.0.0) write(*,*)'imag',i,j + enddo + enddo + + ! S^{-1} from positive definite Hermitian S + call zpotrf('U',nbasfcn2,Sinv,nbasfcn2,info) + if(info.ne.0) stop 'info1' + call zpotri('U',nbasfcn2,Sinv,nbasfcn2,info) + if(info.ne.0) stop 'info2' + + ! S^{-1} from indefinite Hermitian S + !lwork = nbasfcn2 + !allocate(ipiv(nbasfcn2),work(lwork)) + !call zhetrf('U',nbasfcn2,Sinv,nbasfcn2, + >! ipiv,work,lwork,info) + !if(info.ne.0) stop 'info1' + !call zhetri('U',nbasfcn2,Sinv,nbasfcn2, + >! ipiv,work,info) + !call zgetrf(nbasfcn2,nbasfcn2,Sinv,nbasfcn2,ipiv,info) + !if(info.ne.0) stop 'info1' + !call zgetri(nbasfcn2,Sinv,nbasfcn2,ipiv,work,lwork,info) + !deallocate(ipiv,work) + !if(info.ne.0) stop 'info2' + + do j=1,nbasfcn2 + do i=j+1,nbasfcn2 + Sinv(i,j) = conjg(Sinv(j,i)) + enddo + enddo + + ! write out some elements of S^{-1} and H + do i=1,2 + do j=1,2 + write(*,'(a,i2,i2,1x,2f24.18)')'Sinv',i,j,Sinv(i,j) + write(*,'(a,i2,i2,1x,2f24.18)')'H ',i,j,ham(i,j) + enddo + enddo + write(*,*) + + ! check whether spin-offdiagonal blocks are zero for overlaps + do j=1+nv(1)+nlotot,nbasfcn2 + do i=1,nv(1) + if(S(i,j).ne.cmplx(0.,0.)) write(*,*)'S up-down',i,j + if(S(i,j).ne.cmplx(0.,0.)) write(*,*)'S up-down',i,j + if(Sinv(i,j).ne.cmplx(0.,0.)) write(*,*)'Sinv up-down',i,j + if(Sinv(j,i).ne.cmplx(0.,0.)) write(*,*)'Sinv down-up',i,j + enddo + enddo + + ! check whether resulting matrices are Hermitian + do i=1,nbasfcn2 + do j=1,i!nbasfcn2 + if(abs(ham(j,i)-conjg(ham(i,j))).gt.1e-14) then + write(*,*)'H not Hermitian',j,i,ikpt,jspin2 + endif + if(abs(Sinv(j,i)-conjg(Sinv(i,j))).gt.1e-14) then + write(*,*)'inv. S not Hermitian',j,i,ikpt,jspin2 + endif + enddo + enddo + + allocate(tmp_mat1(nbasfcn2,nbasfcn2)) + ! compute S^{-1} S = 1 + call zgemm('N','N',nbasfcn2,nbasfcn2,nbasfcn2, + > cmplx(1.0,0.0),Sinv,nbasfcn2, + > S,nbasfcn2,cmplx(0.0,0.0),tmp_mat1,nbasfcn2) + do i=1,nbasfcn2 + do j=1,nbasfcn2 + if(i.eq.j) then + if(abs(tmp_mat1(i,j)-1.0).gt.1e-10) + > write(*,*)'diag',i,tmp_mat1(i,j) + else + if(abs(tmp_mat1(i,j)).gt.1e-10) + > write(*,*)'offd',i,j,tmp_mat1(i,j) + endif + enddo + enddo + + ! replace H with S^{-1} H S^{-1} + call zgemm('N','N',nbasfcn2,nbasfcn2,nbasfcn2, + > cmplx(1.0,0.0),Sinv,nbasfcn2, + > ham,nbasfcn2,cmplx(0.0,0.0),tmp_mat1,nbasfcn2) + call zgemm('N','N',nbasfcn2,nbasfcn2,nbasfcn2, + > cmplx(1.0,0.0),tmp_mat1,nbasfcn2, + > Sinv,nbasfcn2,cmplx(0.0,0.0),ham,nbasfcn2) + deallocate(tmp_mat1) + deallocate(Sinv) + deallocate(S) + + ! write out elements of S^{-1} H S^{-1} + do i=1,2 + do j=1,2 + !write(*,'(i2,i2,2(f24.18))')j,i,real(ham(j,i)), + > ! aimag(ham(j,i)) + write(*,'(i2,i2,1x,2(f24.12))')j,i,real(ham(j,i)), + > aimag(ham(j,i)) + enddo + enddo + + !mdiff = 0.0 + !do i=1,nbasfcn2 + ! do j=1,i + ! diff = abs(ham(j,i)-conjg(ham(i,j))) + ! !if(diff.gt.1e-8) write(*,*)j,i,diff + ! if(diff.gt.mdiff) mdiff=diff + ! !if(abs(ham(j,i)-conjg(ham(i,j))).gt.1e-14) then + ! ! write(*,*)'S^-1 H S^-1 not Hermitian',j,i,ikpt,jspin2 + ! !endif + ! enddo + !enddo + !write(*,*)'max. diff',mdiff + + + ! Htr -> eV + ham = 27.2 * ham !not yet tested + + + allocate(tmp_mat2(nbnd,nbnd)) +!**************************************! +! a,b,c coefficients at k ! +!**************************************! + allocate ( acof(nvd,0:lmd,natd,2), + & bcof(nvd,0:lmd,natd,2), + & ccof(-llod:llod,nbasfcn,nlod,natd,2)) + acof = cmplx(0.,0.) + bcof = cmplx(0.,0.) + ccof = cmplx(0.,0.) + allocate ( acof_tmp(noccbd,0:lmd,natd), + & bcof_tmp(noccbd,0:lmd,natd), + & ccof_tmp(-llod:llod,noccbd,nlod,natd)) + do jspin3 = 1,2 + addnoco=0 + if(l_noco.and.jspin3.eq.2) addnoco = nv(1)+nlotot + do i=1,nv(jspin3) + z_tmp = 0.0 + z_tmp(i+addnoco,1)=1.0 + call abcof_small( + > lmaxd,ntypd,neigd,noccbd,natd,nop,nvd,wannierspin, + > lmd,nbasfcn,llod,nlod,nlotot,invtab, + > ntype,mrot,ngopr1,taual,neq,lmax,rmt,omtil, + > bmat,bbmat,bkpt,k1,k2,k3,nv,nmat,noccbd,z_tmp, + > us(0,1,jspin3),dus(0,1,jspin3),uds(0,1,jspin3), + > duds(0,1,jspin3),ddn(0,1,jspin3),invsat,invsatnr, + > ulos(1,1,jspin3),uulon(1,1,jspin3),dulon(1,1,jspin3), + > dulos(1,1,jspin3),llo,nlo,l_dulo,lapw_l, + > l_noco,l_ss,jspin3,alph_i,beta_i,qpt_i, + > kveclo,odi,ods, + < acof_tmp(1,0,1),bcof_tmp(1,0,1), + < ccof_tmp(-llod,1,1,1),i) + + call wann_abinv( + > ntypd,natd,noccbd,lmaxd,lmd,llod,nlod,ntype,neq, + > noccbd,lmax,nlo,llo,invsat,invsatnr,bkpt,taual, + X acof_tmp,bcof_tmp,ccof_tmp) + acof(i,:,:,jspin3) = acof_tmp(1,:,:) + bcof(i,:,:,jspin3) = bcof_tmp(1,:,:) + ccof(:,i,:,:,jspin3)=ccof_tmp(:,1,:,:) + enddo + enddo!jspin3 + deallocate(acof_tmp,bcof_tmp,ccof_tmp) + + ! compute necessary ujugaunt(spin3,spin4) + ! TODO: ujugaunt are k-point independent->do computation before k-loop + do jspin4=1,2 + do jspin3=1,2 + jspin5=jspin3+2*(jspin4-1) + call wann_ujugaunt( + > llod,nntot,kdiff,lmax,ntype,ntypd,bbmat, + > bmat,nlod,nlo,llo,flo(:,:,:,:,jspin3), + > flo(:,:,:,:,jspin4), + > ff(:,:,:,:,jspin3), + > ff(:,:,:,:,jspin4), + > gg(:,:,:,:,jspin3), + > gg(:,:,:,:,jspin4),jri,rmsh,dx,jmtd, + > lmaxd,lmd, + < ujug(:,:,:,:,jspin5), + > ujdg(:,:,:,:,jspin5), + > djug(:,:,:,:,jspin5), + > djdg(:,:,:,:,jspin5), + < ujulog(:,:,:,:,:,jspin5), + > djulog(:,:,:,:,:,jspin5), + > ulojug(:,:,:,:,:,jspin5), + > ulojdg(:,:,:,:,:,jspin5), + > ulojulog(:,:,:,:,:,:,jspin5),.false.,1) + enddo + enddo + + +!**************************************! +! loop over neighbors b1 ! +!**************************************! + do ikpt_b = 1,2!nntot + kptibz_b=bpt(ikpt_b,ikpt) + n_start=1 + n_end=neigd + + !**************************************! + ! read eigenvectors at k+b1 ! + !**************************************! +#if(!defined(CPP_HDF) && defined(CPP_MPI)) + call wann_read_eig( + > lmaxd,ntypd,nlod,neigd,nvd,wannierspin, + > irank,isize,kptibz_b,jspin,nbasfcn,nlotot, + > l_ss,l_noco,nrec,irecl, + < nmat_b,nv_b,ello,evdu,epar,kveclo_b, + < k1_b,k2_b,k3_b,bkpt_b,wk_b,nbands_b, + < eigg,zz,cp_time,66,l_gwf,iqpt) +#else + call cdn_read( + > lmaxd,ntypd,nlod,neigd,nvd,jspd, + > irank,isize,kptibz_b,jspin,nbasfcn,nlotot, + > l_ss,l_noco,nrec,kptibz_b,66, + > neigd,n_start,n_end, + < nmat_b,nv_b,ello,evdu,epar,kveclo_b, + < k1_b,k2_b,k3_b,bkpt_b,wk_b,nbands_b, + < eigg,zz,cp_time) +#endif + !write(*,'(a,f8.5,1x,f8.5,1x,f8.5)')'k+b1: ',bkpt_b + + nslibd_b = 0 +#if ( !defined(CPP_INVERSION) || defined(CPP_SOC) ) + z_b(:,:) = cmplx(0.,0.) +#else + z_b(:,:) = 0. +#endif + eig_b(:) = 0. + + do i = 1,nbands_b + if((eigg(i).ge.e1s.and.nslibd_b.lt.numbands + & .and.wann%l_bynumber) + & .or.(eigg(i).ge.e1s.and.eigg(i).le.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(l_noco)then + funbas = nv_b(1) + nlotot + funbas = funbas+nv_b(2) + nlotot + else + funbas = nv_b(jspin) + nlotot + endif + do j = 1,funbas + z_b(j,nslibd_b) = zz(j,i) + enddo + endif + enddo + noccbd_b = nslibd_b + + addnoco_kb=0 + if(l_noco.and.jspin.eq.2) addnoco_kb =nv_b(1)+nlotot + !**************************************! + ! a,b,c coefficients at k+b1 ! + !**************************************! + allocate ( acof_b(nv_b(jspin),0:lmd,natd), + & bcof_b(nv_b(jspin),0:lmd,natd), + & ccof_b(-llod:llod,nv_b(jspin),nlod,natd)) + + allocate ( acof_tmp(noccbd_b,0:lmd,natd), + & bcof_tmp(noccbd_b,0:lmd,natd), + & ccof_tmp(-llod:llod,noccbd_b,nlod,natd)) + + do i=1,nv_b(jspin) + z_tmp = 0.0 + z_tmp(i+addnoco_kb,1)=1.0 + call abcof_small( + > lmaxd,ntypd,neigd,noccbd_b,natd,nop,nvd,wannierspin, + > lmd,nbasfcn,llod,nlod,nlotot,invtab, + > ntype,mrot,ngopr1,taual,neq,lmax,rmt,omtil, + > bmat,bbmat,bkpt_b, + > k1_b,k2_b,k3_b,nv_b,nmat_b,noccbd_b,z_tmp, + > us(0,1,jspin),dus(0,1,jspin),uds(0,1,jspin), + > duds(0,1,jspin),ddn(0,1,jspin),invsat,invsatnr, + > ulos(1,1,jspin),uulon(1,1,jspin),dulon(1,1,jspin), + > dulos(1,1,jspin),llo,nlo,l_dulo,lapw_l, + > l_noco,l_ss,jspin,alph_i,beta_i,qpt_i, + > kveclo_b,odi,ods, + < acof_tmp(1,0,1),bcof_tmp(1,0,1), + < ccof_tmp(-llod,1,1,1),i) + + call wann_abinv( + > ntypd,natd,noccbd_b,lmaxd,lmd,llod,nlod,ntype,neq, + > noccbd_b,lmax,nlo,llo,invsat,invsatnr,bkpt_b,taual, + X acof_tmp,bcof_tmp,ccof_tmp) + + acof_b(i,:,:) = acof_tmp(1,:,:) + bcof_b(i,:,:) = bcof_tmp(1,:,:) + ccof_b(:,i,:,:)= ccof_tmp(:,1,:,:) + + enddo + deallocate(acof_tmp,bcof_tmp,ccof_tmp) + + + ! inner spin loop 1 + do jspin3=1,2 + addnoco = 0 + if(l_noco .and. jspin3.eq.2) addnoco =nv(1)+nlotot + + I1 = cmplx(0.,0.) + !**************************************! + ! INT contribution at k+b1 ! + !**************************************! + call wann_uHu_int2( nvd,k1d,k2d,k3d, + > n3d,k1_b(:,jspin),k2_b(:,jspin),k3_b(:,jspin), + > nv_b(jspin), + > k1(:,jspin3),k2(:,jspin3),k3(:,jspin3), + > nv(jspin3), + > rgphs,ustep,ig,-gb(:,ikpt_b,ikpt),I1) + + !write(*,'(a,3f8.5,3f8.5,3i1)')'k,k+b ',bkpt,bkpt_b, + > ! jspin,jspin3,jspin4 + !write(*,*)'I1 int' + !do i=1,2 + ! do j=1,2 + ! write(*,*)I1(j,i) + ! enddo + !enddo + + !do i=1,nv_b(jspin) + ! if(all(acof_b(i,:,:).eq.0.0)) write(*,*)'acof_b',i + ! if(all(bcof_b(i,:,:).eq.0.0)) write(*,*)'bcof_b',i + !enddo + !do i=1,nv(jspin3) + ! if(all(acof(i,:,:,jspin3).eq.0.0)) write(*,*)'acof',i + ! if(all(bcof(i,:,:,jspin3).eq.0.0)) write(*,*)'bcof',i + !enddo + + + !**************************************! + ! MT contribution at k+b1 ! + !**************************************! + jspin5=jspin+2*(jspin3-1) + call wann_mmkb_sph(nvd,llod,nv_b(jspin),nv(jspin3),nlod, + > natd,ntypd,lmd,jmtd,taual,nop,lmax, + > ntype,neq,nlo,llo, + > acof_b,bcof_b, + > ccof_b,bkpt, + > acof(1:nv(jspin3),:,:,jspin3), + > bcof(1:nv(jspin3),:,:,jspin3), + > ccof(:,1:nv(jspin3),:,:,jspin3), + > -gb(:,ikpt_b,ikpt),bkpt_b, + < ujug(:,:,:,:,jspin5), + > ujdg(:,:,:,:,jspin5), + > djug(:,:,:,:,jspin5), + > djdg(:,:,:,:,jspin5), + < ujulog(:,:,:,:,:,jspin5), + > djulog(:,:,:,:,:,jspin5), + > ulojug(:,:,:,:,:,jspin5), + > ulojdg(:,:,:,:,:,jspin5), + > ulojulog(:,:,:,:,:,:,jspin5), + > kdiff,nntot,chi,I1) + + !write(*,*)'I1 tot' + !do i=1,2 + ! do j=1,2 + ! write(*,*)I1(j,i) + ! enddo + !enddo + + !I1 = conjg(I1) + + ! II1 = z_b^\dag . I1 + call zgemm('C','N',nslibd_b,nv(jspin3),nv_b(jspin), + > cmplx(1.0,0.0), + > z_b(1+addnoco_kb,1),nbasfcn, + > I1,nvd,cmplx(0.0,0.0),II1,neigd) + + + !**************************************! + ! loop over neighbors b2 ! + !**************************************! + do ikpt_b2 = 1,2!nntot + kptibz_b2=bpt(ikpt_b2,ikpt) + n_start=1 + n_end=neigd + + !**************************************! + ! read eigenvectors at k+b2 ! + !**************************************! +#if(!defined(CPP_HDF) && defined(CPP_MPI)) + call wann_read_eig( + > lmaxd,ntypd,nlod,neigd,nvd,wannierspin, + > irank,isize,kptibz_b2,jspin_b,nbasfcn,nlotot, + > l_ss,l_noco,nrec_b,irecl, + < nmat_b2,nv_b2,ello,evdu,epar,kveclo_b2, + < k1_b2,k2_b2,k3_b2,bkpt_b2,wk_b2,nbands_b2, + < eigg,zz,cp_time,66,l_gwf,iqpt) +#else + call cdn_read( + > lmaxd,ntypd,nlod,neigd,nvd,jspd, + > irank,isize,kptibz_b2,jspin_b,nbasfcn,nlotot, + > l_ss,l_noco,nrec_b,kptibz_b2,66, + > neigd,n_start,n_end, + < nmat_b2,nv_b2,ello,evdu,epar,kveclo_b2, + < k1_b2,k2_b2,k3_b2,bkpt_b2,wk_b2,nbands_b2, + < eigg,zz,cp_time) +#endif +! write(*,'(a,f8.5,1x,f8.5,1x,f8.5)')'k+b2: ',bkpt_b2 + + nslibd_b2 = 0 +#if ( !defined(CPP_INVERSION) || defined(CPP_SOC) ) + z_b2(:,:) = cmplx(0.,0.) +#else + z_b2(:,:) = 0. +#endif + eig_b2(:) = 0. + + do i = 1,nbands_b2 + if((eigg(i).ge.e1s.and.nslibd_b2.lt.numbands + & .and.wann%l_bynumber) + & .or.(eigg(i).ge.e1s.and.eigg(i).le.e2s.and.wann%l_byenergy) + & .or.(i.ge.wann%band_min(jspin_b) + & .and.(i.le.wann%band_max(jspin_b)) + & .and.wann%l_byindex))then + nslibd_b2 = nslibd_b2 + 1 + eig_b2(nslibd_b2) = eigg(i) + we_b2(nslibd_b2) = we_b2(i) + if(l_noco)then + funbas = nv_b2(1) + nlotot + funbas = funbas+nv_b2(2) + nlotot + else + funbas = nv_b2(jspin_b) + nlotot + endif + do j = 1,funbas + z_b2(j,nslibd_b2) = zz(j,i) + enddo + endif + enddo + noccbd_b2 = nslibd_b2 + + addnoco_kb2=0 + if(l_noco.and.jspin_b.eq.2) addnoco_kb2=nv_b2(1)+nlotot + !**************************************! + ! a,b,c coefficients at k+b2 ! + !**************************************! + allocate ( acof_b2(nv_b2(jspin_b),0:lmd,natd), + & bcof_b2(nv_b2(jspin_b),0:lmd,natd), + & ccof_b2(-llod:llod,nv_b2(jspin_b),nlod,natd)) + + allocate ( acof_tmp(noccbd_b2,0:lmd,natd), + & bcof_tmp(noccbd_b2,0:lmd,natd), + & ccof_tmp(-llod:llod,noccbd_b2,nlod,natd)) + + do i=1,nv_b2(jspin_b) + z_tmp = 0.0 + z_tmp(i+addnoco_kb2,1)=1.0 + call abcof_small( + > lmaxd,ntypd,neigd,noccbd_b2,natd,nop,nvd,wannierspin, + > lmd,nbasfcn,llod,nlod,nlotot,invtab, + > ntype,mrot,ngopr1,taual,neq,lmax,rmt,omtil, + > bmat,bbmat,bkpt_b2, + > k1_b2,k2_b2,k3_b2,nv_b2,nmat_b2,noccbd_b2,z_tmp, + > us(0,1,jspin_b),dus(0,1,jspin_b),uds(0,1,jspin_b), + > duds(0,1,jspin_b),ddn(0,1,jspin_b),invsat,invsatnr, + > ulos(1,1,jspin_b),uulon(1,1,jspin_b), + > dulon(1,1,jspin_b), + > dulos(1,1,jspin_b),llo,nlo,l_dulo,lapw_l, + > l_noco,l_ss,jspin_b,alph_i,beta_i,qpt_i, + > kveclo_b2,odi,ods, + < acof_tmp(1,0,1),bcof_tmp(1,0,1), + < ccof_tmp(-llod,1,1,1),i) + + call wann_abinv( + > ntypd,natd,noccbd_b2,lmaxd,lmd,llod,nlod,ntype,neq, + > noccbd_b2,lmax,nlo,llo,invsat,invsatnr,bkpt_b2,taual, + X acof_tmp,bcof_tmp,ccof_tmp) + + acof_b2(i,:,:) = acof_tmp(1,:,:) + bcof_b2(i,:,:) = bcof_tmp(1,:,:) + ccof_b2(:,i,:,:)=ccof_tmp(:,1,:,:) + enddo + deallocate(acof_tmp,bcof_tmp,ccof_tmp) + + + ! inner spin loop 2 + do jspin4=1,2 + addnoco2 = 0 + if(l_noco .and. jspin4.eq.2) addnoco2=nv(1)+nlotot + + I2 = cmplx(0.,0.) + !**************************************! + ! INT contribution at k+b2 ! + !**************************************! + call wann_uHu_int2( nvd,k1d,k2d,k3d, + > n3d,k1(:,jspin4),k2(:,jspin4),k3(:,jspin4), + > nv(jspin4), + > k1_b2(:,jspin_b),k2_b2(:,jspin_b), + > k3_b2(:,jspin_b),nv_b2(jspin_b), + > rgphs,ustep,ig,gb(:,ikpt_b2,ikpt),I2) + + !write(*,'(a,3f8.5,3f8.5,3i1)')'k,k+b2 ',bkpt,bkpt_b2, + > ! jspin,jspin3,jspin4 + !write(*,*)'I2 int' + !do i=1,2 + ! do j=1,2 + ! write(*,*)I2(j,i) + ! enddo + !enddo + + !do i=1,nv_b2(jspin) + ! if(all(acof_b2(i,:,:).eq.0.0)) write(*,*)'acof_b',i + ! if(all(bcof_b2(i,:,:).eq.0.0)) write(*,*)'bcof_b',i + !enddo + !do i=1,nv(jspin4) + ! if(all(acof(i,:,:,jspin4).eq.0.0)) write(*,*)'acof',i + ! if(all(bcof(i,:,:,jspin4).eq.0.0)) write(*,*)'bcof',i + !enddo + + !**************************************! + ! MT contribution at k+b2 ! + !**************************************! + jspin5=jspin4+2*(jspin_b-1) + call wann_mmkb_sph(nvd,llod,nv(jspin4),nv_b2(jspin_b),nlod, + > natd,ntypd,lmd,jmtd,taual,nop,lmax, + > ntype,neq,nlo,llo, + > acof(1:nv(jspin4),:,:,jspin4), + > bcof(1:nv(jspin4),:,:,jspin4), + > ccof(:,1:nv(jspin4),:,:,jspin4),bkpt_b2, + > acof_b2,bcof_b2, + > ccof_b2,gb(:,ikpt_b2,ikpt),bkpt, + < ujug(:,:,:,:,jspin5), + > ujdg(:,:,:,:,jspin5), + > djug(:,:,:,:,jspin5), + > djdg(:,:,:,:,jspin5), + < ujulog(:,:,:,:,:,jspin5), + > djulog(:,:,:,:,:,jspin5), + > ulojug(:,:,:,:,:,jspin5), + > ulojdg(:,:,:,:,:,jspin5), + > ulojulog(:,:,:,:,:,:,jspin5), + > kdiff,nntot,chi,I2) + + !write(*,*)'I2 tot' + !do i=1,2 + ! do j=1,2 + ! write(*,*)I2(j,i) + ! enddo + !enddo + + !I2 = conjg(I2) + + ! II2 = I2 . z_b2 + call zgemm('N','N',nv(jspin4),nslibd_b2,nv_b2(jspin_b), + > cmplx(1.0,0.0),I2,nvd, + > z_b2(1+addnoco_kb2,1),nbasfcn,cmplx(0.0,0.0), + > II2,nvd) + + ! III1 = II1 . H + call zgemm('N','N',nslibd_b,nv(jspin4),nv(jspin3), + > cmplx(1.0,0.0),II1,neigd, + > ham(1+addnoco,1+addnoco2),nbasfcn2, + > cmplx(0.0,0.0),III1,neigd) + + !write(*,*)'III1' + !do i=1,2 + ! do j=1,2 + ! write(*,*)III1(j,i) + ! enddo + !enddo + + tmp_mat2 = cmplx(0.,0.) + ! uHu = III1 . II2 = z_b^\dag . I1 . H . I2 . z_b2 + call zgemm('N','N',nslibd_b,nslibd_b2,nv(jspin4), + > cmplx(1.0,0.0),III1,neigd, + > II2,nvd,cmplx(0.0,0.0), + > tmp_mat2,nbnd) + uHu(:,:,ikpt_b2,ikpt_b) = uHu(:,:,ikpt_b2,ikpt_b) + > + tmp_mat2 + !write(*,'(a,i3,i3,i3)')'(k,k+b1,k+b2): ',ikpt,ikpt_b,ikpt_b2 + !do i=1,2 + ! do j=1,2 + ! write(*,'(i2,i2,2(f20.14))')j,i,tmp_mat2(j,i) + ! enddo + !enddo + ! uHu(n,m,i,j) = < u_{jn} | H | u_{im} > + + enddo!jspin4 + + deallocate(acof_b2,bcof_b2,ccof_b2) + enddo ! loop b2 + enddo!jspin3 + + deallocate(acof_b,bcof_b,ccof_b) + enddo ! loop b1 + + !write(*,'(a,i2,i2)')'spins:',jspin,jspin_b + !do ikpt_b=1,2 + ! do ikpt_b2=1,2 + !do i=1,2 + ! do j=1,2 + ! write(*,'(i2,i2,i2,i2,2f20.14)')j,i,ikpt_b2,ikpt_b, + >! uHu(j,i,ikpt_b2,ikpt_b) + ! enddo + !enddo + ! enddo + !enddo + + deallocate(acof,bcof,ccof) + deallocate(tmp_mat2) + deallocate(ham) + + END SUBROUTINE wann_orbmag + + + END MODULE m_wann_orbmag + + diff --git a/wannier/wann_postproc_setup4.f b/wannier/wann_postproc_setup4.f new file mode 100644 index 00000000..66a15658 --- /dev/null +++ b/wannier/wann_postproc_setup4.f @@ -0,0 +1,157 @@ + MODULE m_wann_postproc_setup4 + CONTAINS + SUBROUTINE wann_postproc_setup4( + > natd,nkpts,kpoints,amat,bmat, + > num,num_bands,ntype,neq, + > zatom,taual,namat,seed,bkpts_filename) +c****************************************************** +c Call the Wannier90 4d setup routine. +c Purpose: get the file of nearest-neighbor kpoints +c J. HANKE +c****************************************************** + IMPLICIT NONE + + integer, intent(in) :: natd + integer, intent(in) :: nkpts + real, intent(in) :: kpoints(4,nkpts) + real, intent(in) :: amat(4,4) + real, intent(in) :: bmat(4,4) + integer, intent(in) :: num(4) + integer, intent(in) :: num_bands + integer, intent(in) :: ntype + integer, intent(in) :: neq(ntype) + real, intent(in) :: zatom(ntype) + real, intent(in) :: taual(:,:) + character(len=2),intent(in) :: namat(0:103) + character(len=*),intent(in) :: seed ! QPOINTS + character(len=*),intent(in) :: bkpts_filename ! QPOINTS + + integer :: i,j,at + character(len=50) :: seedname + integer :: num_atoms + character(len=2) :: atom_symbols(natd) + logical :: gamma_only + logical :: spinors + integer,parameter :: num_nnmax=14 + integer :: nntot + integer :: nnlist(nkpts,num_nnmax) + integer :: nncell(4,nkpts,num_nnmax) + integer :: num_bands2 + integer :: num_wann2 + real :: proj_site(3,num_bands) + integer :: proj_l(num_bands) + integer :: proj_m(num_bands) + integer :: proj_radial(num_bands) + real :: proj_z(3,num_bands) + real :: proj_x(3,num_bands) + real :: proj_zona(num_bands) + integer :: exclude_bands(num_bands) + integer :: nn,ikpt + real :: pos(4,natd) + + + ! Taken from wannier90-1.2/src/wannier_lib.F90 + interface + subroutine wannier_setup4(seed__name, mp_grid_loc, + + num_kpts_loc, + + real_lattice_loc, recip_lattice_loc, kpt_latt_loc, + + num_bands_tot, num_atoms_loc, atom_symbols_loc, + + atoms_cart_loc, gamma_only_loc, spinors_loc, nntot_loc, + + nnlist_loc, nncell_loc, num_bands_loc, num_wann_loc, + + proj_site_loc, proj_l_loc, proj_m_loc, proj_radial_loc, + + proj_z_loc, proj_x_loc, proj_zona_loc, exclude_bands_loc) + + implicit none + integer, parameter :: dp = selected_real_kind(15,300) + integer, parameter :: num_nnmax=14 + character(len=*), intent(in) :: seed__name + integer, dimension(4), intent(in) :: mp_grid_loc + integer, intent(in) :: num_kpts_loc + real(kind=dp), dimension(4,4), intent(in) :: real_lattice_loc + real(kind=dp), dimension(4,4), intent(in) :: recip_lattice_loc + real(kind=dp), dimension(4,num_kpts_loc), intent(in) :: + + kpt_latt_loc + integer, intent(in) :: num_bands_tot + integer, intent(in) :: num_atoms_loc + character(len=*), dimension(num_atoms_loc), intent(in) :: + + atom_symbols_loc + real(kind=dp), dimension(4,num_atoms_loc), intent(in) :: + + atoms_cart_loc + logical, intent(in) :: gamma_only_loc + logical, intent(in) :: spinors_loc + + integer, intent(out) :: nntot_loc + integer, dimension(num_kpts_loc,num_nnmax), intent(out) :: + + nnlist_loc + integer,dimension(4,num_kpts_loc,num_nnmax), intent(out) :: + + nncell_loc + integer, intent(out) :: num_bands_loc + integer, intent(out) :: num_wann_loc + real(kind=dp), dimension(3,num_bands_tot), intent(out) :: + + proj_site_loc + integer, dimension(num_bands_tot), intent(out) :: proj_l_loc + integer, dimension(num_bands_tot), intent(out) :: proj_m_loc + integer, dimension(num_bands_tot), intent(out) :: + + proj_radial_loc + real(kind=dp), dimension(3,num_bands_tot), intent(out) :: + + proj_z_loc + real(kind=dp), dimension(3,num_bands_tot), intent(out) :: + + proj_x_loc + real(kind=dp), dimension(num_bands_tot), intent(out) :: + + proj_zona_loc + integer, dimension(num_bands_tot), intent(out) :: + + exclude_bands_loc + end subroutine wannier_setup4 + end interface + + do j=1,natd + pos(:,j)=matmul(amat(:,:),taual(:,j)) + enddo + + !seedname='WF1' + seedname=seed + gamma_only=.false. + spinors=.false. + + num_atoms=0 + do i=1,ntype + at=nint(zatom(i)) + do j=1,neq(i) + num_atoms=num_atoms+1 + atom_symbols(num_atoms)=namat(at) + enddo !j + enddo !i + +c********************************************************** +c Call Wannier90 routine for preparation. +c********************************************************** + call wannier_setup4( + > seedname,num, + > nkpts, + > transpose(amat),bmat, + > kpoints,num_bands, + > num_atoms,atom_symbols,pos, + > gamma_only,spinors, + > nntot,nnlist,nncell,num_bands2, + > num_wann2, + > proj_site,proj_l,proj_m, + > proj_radial,proj_z, + > proj_x,proj_zona,exclude_bands) + +c****************************************************** +c write bkpts +c****************************************************** + open(202,file=bkpts_filename,form='formatted') + write (202,'(i4)') nntot + do ikpt=1,nkpts + do nn=1,nntot + write (202,'(2i6,3x,4i4)') +c & ikpt,bpt(nn,ikpt),(gb(i,nn,ikpt),i=1,3) + & ikpt,nnlist(ikpt,nn),(nncell(i,ikpt,nn),i=1,4) + enddo + enddo + close(202) + + + END SUBROUTINE wann_postproc_setup4 + END MODULE m_wann_postproc_setup4 diff --git a/wannier/wann_postproc_setup5.f b/wannier/wann_postproc_setup5.f new file mode 100644 index 00000000..d897c837 --- /dev/null +++ b/wannier/wann_postproc_setup5.f @@ -0,0 +1,157 @@ + MODULE m_wann_postproc_setup5 + CONTAINS + SUBROUTINE wann_postproc_setup5( + > natd,nkpts,kpoints,amat,bmat, + > num,num_bands,ntype,neq, + > zatom,taual,namat,seed,bkpts_filename) +c****************************************************** +c Call the Wannier90 5d setup routine. +c Purpose: get the file of nearest-neighbor kpoints +c J. HANKE +c****************************************************** + IMPLICIT NONE + + integer, intent(in) :: natd + integer, intent(in) :: nkpts + real, intent(in) :: kpoints(5,nkpts) + real, intent(in) :: amat(5,5) + real, intent(in) :: bmat(5,5) + integer, intent(in) :: num(5) + integer, intent(in) :: num_bands + integer, intent(in) :: ntype + integer, intent(in) :: neq(ntype) + real, intent(in) :: zatom(ntype) + real, intent(in) :: taual(:,:) + character(len=2),intent(in) :: namat(0:103) + character(len=*),intent(in) :: seed ! QPOINTS + character(len=*),intent(in) :: bkpts_filename ! QPOINTS + + integer :: i,j,at + character(len=50) :: seedname + integer :: num_atoms + character(len=2) :: atom_symbols(natd) + logical :: gamma_only + logical :: spinors + integer,parameter :: num_nnmax=14 + integer :: nntot + integer :: nnlist(nkpts,num_nnmax) + integer :: nncell(5,nkpts,num_nnmax) + integer :: num_bands2 + integer :: num_wann2 + real :: proj_site(3,num_bands) + integer :: proj_l(num_bands) + integer :: proj_m(num_bands) + integer :: proj_radial(num_bands) + real :: proj_z(3,num_bands) + real :: proj_x(3,num_bands) + real :: proj_zona(num_bands) + integer :: exclude_bands(num_bands) + integer :: nn,ikpt + real :: pos(5,natd) + + + ! Taken from wannier90-1.2/src/wannier_lib.F90 + interface + subroutine wannier_setup5(seed__name, mp_grid_loc, + + num_kpts_loc, + + real_lattice_loc, recip_lattice_loc, kpt_latt_loc, + + num_bands_tot, num_atoms_loc, atom_symbols_loc, + + atoms_cart_loc, gamma_only_loc, spinors_loc, nntot_loc, + + nnlist_loc, nncell_loc, num_bands_loc, num_wann_loc, + + proj_site_loc, proj_l_loc, proj_m_loc, proj_radial_loc, + + proj_z_loc, proj_x_loc, proj_zona_loc, exclude_bands_loc) + + implicit none + integer, parameter :: dp = selected_real_kind(15,300) + integer, parameter :: num_nnmax=14 + character(len=*), intent(in) :: seed__name + integer, dimension(5), intent(in) :: mp_grid_loc + integer, intent(in) :: num_kpts_loc + real(kind=dp), dimension(5,5), intent(in) :: real_lattice_loc + real(kind=dp), dimension(5,5), intent(in) :: recip_lattice_loc + real(kind=dp), dimension(5,num_kpts_loc), intent(in) :: + + kpt_latt_loc + integer, intent(in) :: num_bands_tot + integer, intent(in) :: num_atoms_loc + character(len=*), dimension(num_atoms_loc), intent(in) :: + + atom_symbols_loc + real(kind=dp), dimension(5,num_atoms_loc), intent(in) :: + + atoms_cart_loc + logical, intent(in) :: gamma_only_loc + logical, intent(in) :: spinors_loc + + integer, intent(out) :: nntot_loc + integer, dimension(num_kpts_loc,num_nnmax), intent(out) :: + + nnlist_loc + integer,dimension(5,num_kpts_loc,num_nnmax), intent(out) :: + + nncell_loc + integer, intent(out) :: num_bands_loc + integer, intent(out) :: num_wann_loc + real(kind=dp), dimension(3,num_bands_tot), intent(out) :: + + proj_site_loc + integer, dimension(num_bands_tot), intent(out) :: proj_l_loc + integer, dimension(num_bands_tot), intent(out) :: proj_m_loc + integer, dimension(num_bands_tot), intent(out) :: + + proj_radial_loc + real(kind=dp), dimension(3,num_bands_tot), intent(out) :: + + proj_z_loc + real(kind=dp), dimension(3,num_bands_tot), intent(out) :: + + proj_x_loc + real(kind=dp), dimension(num_bands_tot), intent(out) :: + + proj_zona_loc + integer, dimension(num_bands_tot), intent(out) :: + + exclude_bands_loc + end subroutine wannier_setup5 + end interface + + do j=1,natd + pos(:,j)=matmul(amat(:,:),taual(:,j)) + enddo + + !seedname='WF1' + seedname=seed + gamma_only=.false. + spinors=.false. + + num_atoms=0 + do i=1,ntype + at=nint(zatom(i)) + do j=1,neq(i) + num_atoms=num_atoms+1 + atom_symbols(num_atoms)=namat(at) + enddo !j + enddo !i + +c********************************************************** +c Call Wannier90 routine for preparation. +c********************************************************** + call wannier_setup5( + > seedname,num, + > nkpts, + > transpose(amat),bmat, + > kpoints,num_bands, + > num_atoms,atom_symbols,pos, + > gamma_only,spinors, + > nntot,nnlist,nncell,num_bands2, + > num_wann2, + > proj_site,proj_l,proj_m, + > proj_radial,proj_z, + > proj_x,proj_zona,exclude_bands) + +c****************************************************** +c write bkpts +c****************************************************** + open(202,file=bkpts_filename,form='formatted') + write (202,'(i4)') nntot + do ikpt=1,nkpts + do nn=1,nntot + write (202,'(2i6,3x,5i4)') +c & ikpt,bpt(nn,ikpt),(gb(i,nn,ikpt),i=1,3) + & ikpt,nnlist(ikpt,nn),(nncell(i,ikpt,nn),i=1,5) + enddo + enddo + close(202) + + + END SUBROUTINE wann_postproc_setup5 + END MODULE m_wann_postproc_setup5 diff --git a/wannier/wann_write_mmnk2.F b/wannier/wann_write_mmnk2.F new file mode 100644 index 00000000..157c9119 --- /dev/null +++ b/wannier/wann_write_mmnk2.F @@ -0,0 +1,107 @@ + module m_wann_write_mmnk2 + contains + subroutine wann_write_mmnk2( + > l_p0,fullnkpts,nntot_q,wann, + > nbnd,bpt_q,gb_q,isize,irank, + > fname,mmnk_q,l_unformatted) +c********************************************************** + +c********************************************************** + use m_types + use m_fleurenv + implicit none + logical, intent(in) :: l_p0,l_unformatted + integer, intent(in) :: fullnkpts + integer, intent(in) :: nntot_q + type(t_wann),intent(in) :: wann + + integer, intent(in) :: nbnd + integer, intent(in) :: bpt_q(:) + integer, intent(in) :: gb_q(:,:) + + integer, intent(in) :: isize,irank + + CHARACTER(len=30), INTENT(IN) :: fname + complex, intent(in) :: mmnk_q(:,:,:,:) + + integer :: ikpt,i,j + integer :: ikpt_b + character(len=3) :: spin12(2) + integer :: cpu_index + data spin12/'WF1' , 'WF2'/ + +#ifdef CPP_MPI + include 'mpif.h' + integer :: ierr(3) + integer :: stt(MPI_STATUS_SIZE) +#include "cpp_double.h" +#endif + +#ifdef CPP_MPI +c****************************************************** +c Collect contributions to the mmnk matrix from the +c various processors. +c****************************************************** + if(isize.ne.1)then + do ikpt=1,fullnkpts + if(l_p0)then + do cpu_index=1,isize-1 + if(mod(ikpt-1,isize).eq.cpu_index)then + do ikpt_b=1,nntot_q !nearest neighbors + call MPI_RECV( + & mmnk_q(1:nbnd,1:nbnd,ikpt_b,ikpt),nbnd*nbnd, + & CPP_MPI_COMPLEX,cpu_index,5*fullnkpts, + & MPI_COMM_WORLD,stt,ierr) + + enddo !nearest neighbors + endif !processors + enddo !cpu_index + else + if(mod(ikpt-1,isize).eq.irank)then + do ikpt_b=1,nntot_q !loop over nearest neighbors + call MPI_SEND( + & mmnk_q(1:nbnd,1:nbnd,ikpt_b,ikpt), + & nbnd*nbnd,CPP_MPI_COMPLEX,0,5*fullnkpts, + & MPI_COMM_WORLD,ierr) + enddo !loop over nearest neighbors + endif !processors + endif ! l_p0 + call MPI_BARRIER(MPI_COMM_WORLD,ierr) + enddo !ikpt + endif !isize +#endif + + +c****************************************************** +c Write mmnk matrix to file. +c****************************************************** + if (l_p0) then + if(.not.l_unformatted) then + open(305,file=trim(fname)) + write(305,*)'Overlaps between parameter points' + write(305,'(3i5)')nbnd,fullnkpts,nntot_q + do ikpt=1,fullnkpts + do ikpt_b=1,nntot_q + write(305,'(2i5,3x,3i4)')ikpt,bpt_q(ikpt_b), + > gb_q(1:3,ikpt_b) + do i=1,nbnd + do j=1,nbnd + write(305,'(2f24.18)') + > real(mmnk_q(j,i,ikpt_b,ikpt)), + > -aimag(mmnk_q(j,i,ikpt_b,ikpt)) + enddo + enddo + enddo + enddo + close(305) + else + open(305,file=trim(fname),form='unformatted') + write(305)nbnd,fullnkpts,nntot_q + write(305)bpt_q,gb_q + write(305)conjg(mmnk_q) + close(305) + endif + endif !l_p0 + + end subroutine wann_write_mmnk2 + end module m_wann_write_mmnk2 -- GitLab