Commit 598c51a1 authored by Daniel Wortmann's avatar Daniel Wortmann

Changes to the fully fully noco version

parent 255270fb
......@@ -22,10 +22,10 @@ CONTAINS
! .. Array Arguments ..
REAL, INTENT(IN) :: we(:)!(nobd)
COMPLEX, INTENT(INOUT) :: uu21(atoms%lmaxd,atoms%ntype)
COMPLEX, INTENT(INOUT) :: ud21(atoms%lmaxd,atoms%ntype)
COMPLEX, INTENT(INOUT) :: du21(atoms%lmaxd,atoms%ntype)
COMPLEX, INTENT(INOUT) :: dd21(atoms%lmaxd,atoms%ntype)
COMPLEX, INTENT(INOUT) :: uu21(0:atoms%lmaxd,atoms%ntype)
COMPLEX, INTENT(INOUT) :: ud21(0:atoms%lmaxd,atoms%ntype)
COMPLEX, INTENT(INOUT) :: du21(0:atoms%lmaxd,atoms%ntype)
COMPLEX, INTENT(INOUT) :: dd21(0:atoms%lmaxd,atoms%ntype)
COMPLEX, INTENT(INOUT) :: uulo21(atoms%nlod,atoms%ntype)
COMPLEX, INTENT(INOUT) :: dulo21(atoms%nlod,atoms%ntype)
COMPLEX, INTENT(INOUT) :: ulou21(atoms%nlod,atoms%ntype)
......
......@@ -31,7 +31,7 @@ CONTAINS
REAL dvu(0:atoms%lmaxd*(atoms%lmaxd+3)/2,0:sphhar%nlhd )
REAL uvd(0:atoms%lmaxd*(atoms%lmaxd+3)/2,0:sphhar%nlhd )
REAL uvu(0:atoms%lmaxd*(atoms%lmaxd+3)/2,0:sphhar%nlhd )
REAL f(atoms%jmtd,2,0:atoms%lmaxd),g(atoms%jmtd,2,0:atoms%lmaxd),x(atoms%jmtd)
REAL f(atoms%jmtd,2,0:atoms%lmaxd,2),g(atoms%jmtd,2,0:atoms%lmaxd,2),x(atoms%jmtd)
REAL flo(atoms%jmtd,2,atoms%nlod)
INTEGER:: indt(0:SIZE(td%tuu,1)-1)
......@@ -40,14 +40,21 @@ CONTAINS
COMPLEX :: cil
REAL :: temp
INTEGER i,l,l2,lamda,lh,lm,lmin,lmin0,lmp,lmpl,lmplm,lmx,lmxx,lp,info,in
INTEGER lp1,lpl ,mem,mems,mp,mu,nh,na,m,nsym,s,i_u
INTEGER lp1,lpl ,mem,mems,mp,mu,nh,na,m,nsym,s,i_u,jspin1,jspin2
vr0=v%mt(:,:,n,jsp)
IF (jsp<3) vr0(:,0)=0.0
CALL genMTBasis(atoms,enpara,v,mpi,n,jspin,ud,f,g,flo)
DO i=MERGE(1,jspin,jspin>2),MERGE(2,jspin,jspin>2)
CALL genMTBasis(atoms,enpara,v,mpi,n,i,ud,f(:,:,:,i),g(:,:,:,i),flo)
ENDDO
IF (jspin>2) THEN
jspin1=1
jspin2=2
ELSE
jspin1=jspin;jspin2=jspin
END IF
na=SUM(atoms%neq(:n-1))+1
nsym = atoms%ntypsy(na)
nh = sphhar%nlh(nsym)
......@@ -73,22 +80,22 @@ CONTAINS
dvu(lpl,lh) = 0.0
ELSE
DO i = 1,atoms%jri(n)
x(i) = (f(i,1,lp)*f(i,1,l)+f(i,2,lp)*f(i,2,l))* vr0(i,lh)
x(i) = (f(i,1,lp,jspin1)*f(i,1,l,jspin2)+f(i,2,lp,jspin1)*f(i,2,l,jspin2))* vr0(i,lh)
END DO
CALL intgr3(x,atoms%rmsh(1,n),atoms%dx(n),atoms%jri(n),temp)
uvu(lpl,lh) = temp
DO i = 1,atoms%jri(n)
x(i) = (g(i,1,lp)*f(i,1,l)+g(i,2,lp)*f(i,2,l))* vr0(i,lh)
x(i) = (g(i,1,lp,jspin1)*f(i,1,l,jspin2)+g(i,2,lp,jspin1)*f(i,2,l,jspin2))* vr0(i,lh)
END DO
CALL intgr3(x,atoms%rmsh(1,n),atoms%dx(n),atoms%jri(n),temp)
dvu(lpl,lh) = temp
DO i = 1,atoms%jri(n)
x(i) = (f(i,1,lp)*g(i,1,l)+f(i,2,lp)*g(i,2,l))* vr0(i,lh)
x(i) = (f(i,1,lp,jspin1)*g(i,1,l,jspin2)+f(i,2,lp,jspin1)*g(i,2,l,jspin2))* vr0(i,lh)
END DO
CALL intgr3(x,atoms%rmsh(1,n),atoms%dx(n),atoms%jri(n),temp)
uvd(lpl,lh) = temp
DO i = 1,atoms%jri(n)
x(i) = (g(i,1,lp)*g(i,1,l)+g(i,2,lp)*g(i,2,l))* vr0(i,lh)
x(i) = (g(i,1,lp,jspin1)*g(i,1,l,jspin2)+g(i,2,lp,jspin1)*g(i,2,l,jspin2))* vr0(i,lh)
END DO
CALL intgr3(x,atoms%rmsh(1,n),atoms%dx(n),atoms%jri(n),temp)
dvd(lpl,lh) = temp
......
......@@ -112,31 +112,30 @@ CONTAINS
ENDDO
END DO
!Now add diagonal contribution to matrices
DO l = 0,atoms%lmax(n)
DO m = -l,l
lm = l* (l+1) + m
lmplm = (lm* (lm+3))/2
td%tuu(lmplm,n,jsp)=td%tuu(lmplm,n,jsp) + enpara%el0(l,n,jsp)
td%tdd(lmplm,n,jsp)=td%tdd(lmplm,n,jsp) + enpara%el0(l,n,jsp)*ud%ddn(l,n,jsp)
td%tud(lmplm,n,jsp)=td%tud(lmplm,n,jsp) + 0.5
td%tdu(lmplm,n,jsp)=td%tdu(lmplm,n,jsp) + 0.5
IF (jsp<3) THEN
DO l = 0,atoms%lmax(n)
DO m = -l,l
lm = l* (l+1) + m
lmplm = (lm* (lm+3))/2
td%tuu(lmplm,n,jsp)=td%tuu(lmplm,n,jsp) + enpara%el0(l,n,jsp)
td%tdd(lmplm,n,jsp)=td%tdd(lmplm,n,jsp) + enpara%el0(l,n,jsp)*ud%ddn(l,n,jsp)
td%tud(lmplm,n,jsp)=td%tud(lmplm,n,jsp) + 0.5
td%tdu(lmplm,n,jsp)=td%tdu(lmplm,n,jsp) + 0.5
ENDDO
ENDDO
ENDDO
!Create Cholesky decomposition of local hamiltonian
!---> Add diagonal terms to make matrix positive definite
DO lp = 0,atoms%lnonsph(n)
DO mp = -lp,lp
lmp = lp* (lp+1) + mp
td%h_loc(lmp,lmp,n,jsp)=td%e_shift(n,jsp)+td%h_loc(lmp,lmp,n,jsp)
td%h_loc(lmp+s,lmp+s,n,jsp)=td%e_shift(n,jsp)*ud%ddn(lp,n,jsp)+td%h_loc(lmp+s,lmp+s,n,jsp)
!Create Cholesky decomposition of local hamiltonian
!---> Add diagonal terms to make matrix positive definite
DO lp = 0,atoms%lnonsph(n)
DO mp = -lp,lp
lmp = lp* (lp+1) + mp
td%h_loc(lmp,lmp,n,jsp)=td%e_shift(n,jsp)+td%h_loc(lmp,lmp,n,jsp)
td%h_loc(lmp+s,lmp+s,n,jsp)=td%e_shift(n,jsp)*ud%ddn(lp,n,jsp)+td%h_loc(lmp+s,lmp+s,n,jsp)
END DO
END DO
END DO
IF (lmp+1.NE.s) CALL judft_error("BUG in tlmpln_cholesky")
!Perform cholesky decomposition
info=0
IF (jsp<3) THEN
IF (lmp+1.NE.s) CALL judft_error("BUG in tlmpln_cholesky")
!Perform cholesky decomposition
info=0
CALL zpotrf("L",2*s,td%h_loc(:,:,n,jsp),SIZE(td%h_loc,1),info)
!Upper part to zero
......
......@@ -37,11 +37,13 @@ SUBROUTINE postprocessInput(mpi,input,field,sym,stars,atoms,vacuum,obsolete,kpts
USE m_od_kptsgen
USE m_gen_bz
USE m_nocoInputCheck
USE m_kpoints
USE m_kpoints
USE m_types_forcetheo_extended
IMPLICIT NONE
TYPE(t_mpi) ,INTENT (IN) :: mpi
CLASS(t_forcetheo),ALLOCATABLE,INTENT(IN) :: forcetheo
CLASS(t_forcetheo),INTENT(IN) :: forcetheo
TYPE(t_input), INTENT(INOUT) :: input
TYPE(t_sym), INTENT(INOUT) :: sym
TYPE(t_stars), INTENT(INOUT) :: stars
......
......@@ -184,6 +184,9 @@
l_kpts)
END IF
CALL mpi_bc_xcpot(xcpot,mpi)
#ifdef CPP_MPI
CALL mpi_dist_forcetheorem(mpi,forcetheo)
#endif
CALL postprocessInput(mpi,input,field,sym,stars,atoms,vacuum,obsolete,kpts,&
oneD,hybrid,cell,banddos,sliceplot,xcpot,forcetheo,&
noco,dimension,enpara,sphhar,l_opti,noel,l_kpts)
......@@ -210,7 +213,7 @@
DIMENSION,cell,sym,xcpot,noco,oneD,hybrid,&
kpts,enpara,sphhar,mpi,obsolete)
#ifndef CPP_OLDINTEL
CALL mpi_dist_forcetheorem(mpi,forcetheo)
! CALL mpi_dist_forcetheorem(mpi,forcetheo)
#endif
#endif
......
......@@ -86,7 +86,7 @@ CONTAINS
that%vacxy(:,:,:,1)=this%vacxy(:,:,:,1)
IF (ALLOCATED(that%pw_w).AND.ALLOCATED(this%pw_w)) that%pw_w(:,1)=this%pw_w(:,1)
IF (SIZE(that%mt,4)==2) THEN
IF (SIZE(that%mt,4)>1) THEN
that%mt(:,0:,:,2)=this%mt(:,0:,:,1)
that%pw(:,2)=this%pw(:,1)
that%vacz(:,:,2)=this%vacz(:,:,1)
......
......@@ -21,7 +21,7 @@ CONTAINS
TYPE(t_xcpot_inbuild) :: xcpot !local xcpot that is LDA to indicate we do not need gradients
TYPE(t_gradients) :: grad
INTEGER :: n,nsp,imesh
INTEGER :: n,nsp,imesh,i
REAL :: rho_11,rho_22,rho_21r,rho_21i,mx,my,mz,magmom
REAL :: rhotot,rho_up,rho_down,theta,phi
REAL,ALLOCATABLE :: ch(:,:)
......@@ -34,7 +34,7 @@ CONTAINS
CALL init_mt_grid(nsp,4,atoms,sphhar,xcpot,sym)
DO n=1,atoms%ntype
CALL mt_to_grid(xcpot,4,atoms,sphhar,den%mt(:,0:,n,:),nsp,n,grad,ch)
DO imesh = 1,nsp
DO imesh = 1,nsp*atoms%jri(n)
rho_11 = ch(imesh,1)
rho_22 = ch(imesh,2)
......@@ -80,6 +80,9 @@ CONTAINS
den%phi_mt(imesh,n) = phi
ENDDO
CALL mt_from_grid(atoms,sphhar,nsp,n,2,ch,den%mt(:,0:,n,:))
DO i=1,atoms%jri(n)
den%mt(i,:,n,:)=den%mt(i,:,n,:)*atoms%rmsh(i,n)**2
ENDDO
END DO
CALL finish_mt_grid()
END SUBROUTINE rotate_mt_den_to_local
......@@ -95,7 +98,7 @@ CONTAINS
TYPE(t_xcpot_inbuild) :: xcpot !local xcpot that is LDA to indicate we do not need gradients
TYPE(t_gradients) :: grad
INTEGER :: n,nsp,imesh
INTEGER :: n,nsp,imesh,i
REAL :: vup,vdown,veff,beff
REAL :: theta,phi
REAL,ALLOCATABLE :: ch(:,:)
......@@ -108,7 +111,7 @@ CONTAINS
CALL init_mt_grid(nsp,4,atoms,sphhar,xcpot,sym)
DO n=1,atoms%ntype
CALL mt_to_grid(xcpot,4,atoms,sphhar,vtot%mt(:,0:,n,:),nsp,n,grad,ch)
DO imesh = 1,nsp
DO imesh = 1,nsp*atoms%jri(n)
vup = ch(imesh,1)
vdown = ch(imesh,2)
theta = den%theta_mt(imesh,n)
......@@ -121,6 +124,9 @@ CONTAINS
ch(imesh,4) = beff*SIN(theta)*SIN(phi)
ENDDO
CALL mt_from_grid(atoms,sphhar,nsp,n,4,ch,vtot%mt(:,0:,n,:))
DO i=1,atoms%jri(n)
vtot%mt(i,:,n,:)=vtot%mt(i,:,n,:)*atoms%rmsh(i,n)**2
ENDDO
END DO
CALL finish_mt_grid()
END SUBROUTINE rotate_mt_den_from_local
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment