Commit addfc05e authored by Daniel Wortmann's avatar Daniel Wortmann

Merge branch 'develop' into mixer

parents ebcccf8e 0cf0bbf4
......@@ -15,6 +15,7 @@ c This subroutine rotates the direction of the magnetization of the
c density matrix by multiplying with the unitary 2x2 spin rotation
c matrix. --> U*rho*U^dagger
c Philipp Kurz 2000-02-03
c new method for improved stability (l_new=t) gb'19
c***********************************************************************
use m_constants
......@@ -28,11 +29,29 @@ C .. Scalar Arguments ..
C ..
C .. Local Scalars ..
INTEGER ispin
REAL eps
REAL eps,r11n,r22n
COMPLEX r21n
LOGICAL l_new
C ..
C .. Local Arrays ..
COMPLEX u2(2,2),rho(2,2),rhoh(2,2)
C ..
l_new = .true.
IF (l_new) THEN
r11n = 0.5*(1.0+cos(beta))*rho11 - sin(beta)*real(rho21) +
+ 0.5*(1.0-cos(beta))*rho22
r22n = 0.5*(1.0-cos(beta))*rho11 + sin(beta)*real(rho21) +
+ 0.5*(1.0+cos(beta))*rho22
r21n = CMPLX(cos(alph),-sin(alph))*(sin(beta)*(rho11-rho22) +
+ 2.0*(cos(beta)*real(rho21)-cmplx(0.0,aimag(rho21))))*0.5
rho11 = r11n
rho22 = r22n
rho21 = r21n
ELSE
eps = 1.0e-10
......@@ -79,6 +98,8 @@ c---> are real.
rho22 = real(rho(2,2))
rho21 = rho(2,1)
ENDIF
END SUBROUTINE rot_den_mat
END MODULE m_rotdenmat
......@@ -29,7 +29,7 @@ CONTAINS
TYPE(t_lapw),INTENT(IN) :: lapw
TYPE(t_mpi),INTENT(IN) :: mpi
TYPE(t_potden),INTENT(IN) :: v
CLASS(t_mat),INTENT(INOUT) :: hmat(:,:),smat(:,:)
CLASS(t_mat),INTENT(INOUT) :: hmat(:,:),smat(:,:)
! ..
! .. Scalar Arguments ..
INTEGER, INTENT (IN) :: jsp
......@@ -40,14 +40,14 @@ CONTAINS
! .. Local Scalars ..
COMPLEX hij,sij,apw_lo,c_1
REAL d2,gz,sign,th,wronk
INTEGER i,i2,ii,jj,ik,j,jk,k,jspin,ipot,ii0,i0
INTEGER i,i2,ii,jj,ik,j,jk,k,jspin,ii0,i0
INTEGER ivac,irec,imz,igvm2,igvm2i,s1,s2
INTEGER jspin1,jspin2,jmax,jsp_start,jsp_end
INTEGER i_start,nc,nc_0
! ..
! .. Local Arrays ..
INTEGER:: nv2(input%jspins)
INTEGER kvac1(DIMENSION%nv2d,input%jspins),kvac2(DIMENSION%nv2d,input%jspins)
INTEGER kvac(2,DIMENSION%nv2d,input%jspins)
INTEGER map2(DIMENSION%nvd,input%jspins)
COMPLEX tddv(DIMENSION%nv2d,DIMENSION%nv2d),tduv(DIMENSION%nv2d,DIMENSION%nv2d)
COMPLEX tudv(DIMENSION%nv2d,DIMENSION%nv2d),tuuv(DIMENSION%nv2d,DIMENSION%nv2d)
......@@ -66,16 +66,14 @@ CONTAINS
nv2(jspin) = 0
k_loop:DO k = 1,lapw%nv(jspin)
DO j = 1,nv2(jspin)
IF (lapw%k1(k,jspin).EQ.kvac1(j,jspin)&
.AND. lapw%k2(k,jspin).EQ.kvac2(j,jspin)) THEN
IF (all(lapw%gvec(1:2,k,jspin)==kvac(1:2,j,jspin))) THEN
map2(k,jspin) = j
CYCLE k_loop
END IF
ENDDO
nv2(jspin) = nv2(jspin) + 1
IF (nv2(jspin)>DIMENSION%nv2d) CALL juDFT_error("hsvac:dimension%nv2d",calledby ="hsvac")
kvac1(nv2(jspin),jspin) = lapw%k1(k,jspin)
kvac2(nv2(jspin),jspin) = lapw%k2(k,jspin)
kvac(1:2,nv2(jspin),jspin) = lapw%gvec(1:2,k,jspin)
map2(k,jspin) = nv2(jspin)
ENDDO k_loop
ENDDO
......@@ -86,20 +84,16 @@ CONTAINS
s1=MIN(SIZE(hmat,1),jspin1) !in colinear case s1=1
DO jspin2=MERGE(1,jsp,noco%l_noco),MERGE(2,jsp,noco%l_noco) !loop over global spin
s2=MIN(SIZE(hmat,1),jspin2) !in colinear case s2=1
ipot=3
IF (jspin1==jspin2) ipot=jspin1
!---> get the wavefunctions and set up the tuuv, etc matrices
jspin=jsp
CALL vacfun(&
vacuum,DIMENSION,stars,&
jsp,input,noco,jspin1,jspin2,&
sym, cell,ivac,evac(1,1),lapw%bkpt,v%vacxy(:,:,ivac,ipot),v%vacz(:,:,:),kvac1,kvac2,nv2,&
tuuv,tddv,tudv,tduv,uz,duz,udz,dudz,ddnv,wronk)
CALL vacfun(&
vacuum,stars,&
input,noco,jspin1,jspin2,&
sym, cell,ivac,evac,lapw%bkpt,v%vacxy,v%vacz,kvac,nv2,&
tuuv,tddv,tudv,tduv,uz,duz,udz,dudz,ddnv,wronk)
!
!---> generate a and b coeffficients
!
IF (noco%l_noco) THEN
DO jspin = 1,input%jspins
DO jspin = MIN(jspin1,jspin2),MAX(jspin1,jspin2)
DO k = 1,lapw%nv(jspin)
gz = sign*cell%bmat(3,3)*lapw%k3(k,jspin)
i2 = map2(k,jspin)
......@@ -109,16 +103,6 @@ CONTAINS
b(k,jspin) = c_1 * CMPLX(duz(i2,jspin), gz* uz(i2,jspin) )
ENDDO
ENDDO
ELSE
DO k = 1,lapw%nv(jsp)
gz = sign*cell%bmat(3,3)*lapw%gvec(3,k,jsp)
i2 = map2(k,jsp)
th = gz*cell%z1
c_1 = CMPLX( COS(th), SIN(th) )/ (d2*wronk)
a(k,jsp) = - c_1 * CMPLX(dudz(i2,jsp), gz*udz(i2,jsp) )
b(k,jsp) = c_1 * CMPLX(duz(i2,jsp), gz* uz(i2,jsp) )
ENDDO
ENDIF
!---> update hamiltonian and overlap matrices
IF (jspin1==jspin2) THEN
DO i = mpi%n_rank+1,lapw%nv(jspin2),mpi%n_size
......@@ -153,30 +137,25 @@ CONTAINS
!Diagonal term of Overlapp matrix, Hamiltonian later
sij = CONJG(a(i,jspin2))*a(i,jspin2) + CONJG(b(i,jspin2))*b(i,jspin2)*ddnv(ik,jspin2)
IF (hmat(1,1)%l_real) THEN
smat(s1,s2)%data_r(j,i0) = smat(s1,s2)%data_r(j,i0) + REAL(sij)
smat(s2,s1)%data_r(j,i0) = smat(s1,s2)%data_r(j,i0) + REAL(sij)
ELSE
smat(s1,s2)%data_c(j,i0) = smat(s1,s2)%data_c(j,i0) + sij
smat(s2,s1)%data_c(j,i0) = smat(s1,s2)%data_c(j,i0) + sij
ENDIF
ENDDO
ENDIF
!---> hamiltonian update
DO i = mpi%n_rank+1,lapw%nv(jspin2),mpi%n_size
DO i = mpi%n_rank+1,lapw%nv(jspin1),mpi%n_size
i0=(i-1)/mpi%n_size+1 !local column index
ik = map2(i,jspin2)
DO j = 1,MIN(i,lapw%nv(jspin1))
jk = map2(j,jspin1)
IF (jspin2>jspin1) THEN
hij = CONJG(CONJG(a(j,jspin1))* (tuuv(jk,ik)*a(i,jspin2) +tudv(jk,ik)*b(i,jspin2))&
+ CONJG(b(j,jspin1))* (tddv(jk,ik)*b(i,jspin2) +tduv(jk,ik)*a(i,jspin2)))
ELSE
hij = CONJG(a(i,jspin2))* (tuuv(ik,jk)*a(j,jspin1) +tudv(ik,jk)*b(j,jspin1))&
+ CONJG(b(i,jspin2))* (tddv(ik,jk)*b(j,jspin1) +tduv(ik,jk)*a(j,jspin1))
ENDIF
ik = map2(i,jspin1)
DO j = 1,MERGE(i,lapw%nv(jspin2),jspin1==jspin2)
jk = map2(j,jspin2)
hij = CONJG(a(i,jspin1))* (tuuv(ik,jk)*a(j,jspin2) +tudv(ik,jk)*b(j,jspin2))&
+ CONJG(b(i,jspin1))* (tddv(ik,jk)*b(j,jspin2) +tduv(ik,jk)*a(j,jspin2))
IF (hmat(1,1)%l_real) THEN
hmat(s1,s2)%data_r(j,i0) = hmat(s1,s2)%data_r(j,i0) + REAL(hij)
hmat(s2,s1)%data_r(j,i0) = hmat(s2,s1)%data_r(j,i0) + REAL(hij)
ELSE
hmat(s1,s2)%data_c(j,i0) = hmat(s1,s2)%data_c(j,i0) + hij
hmat(s2,s1)%data_c(j,i0) = hmat(s2,s1)%data_c(j,i0) + hij
ENDIF
ENDDO
ENDDO
......
This diff is collapsed.
set(fleur_F77 ${fleur_F77}
force/bfgs.f
force/bfgs0.f
force/relax.F
)
set(fleur_F90 ${fleur_F90}
force/bfgs0.f90
force/bfgs.f90
force/force_b8.f90
force/force_0.f90
force/force_a12.f90
......
MODULE m_bfgs
use m_juDFT
CONTAINS
SUBROUTINE bfgs(
> ntype,istep,istep0,force,
> zat,xa,thetad,epsdisp,epsforce,tote,
X xold,y,h,tau0,
< lconv)
!*******************************************************************
! relaxes the forces using the BFGS quasi-Newton method.
! input:
! istep = atomic step in this run
! istep0 = number of atomic steps in previous runs used
! in updating hessian
!
! output:
! lconv = logical true if forces are converged to tolerance
! given in epsforce
!
! the positions and forces from this step are added
! to file force.dat
!*******************************************************************
IMPLICIT NONE
! ..
! .. Scalar Arguments ..
INTEGER, INTENT (IN) :: ntype,istep,istep0
REAL, INTENT (IN) :: epsdisp,epsforce,tote
REAL, INTENT (INOUT) :: thetad,xa
LOGICAL, INTENT (OUT) :: lconv
! ..
! .. Array Arguments ..
REAL, INTENT (IN) :: force(3,ntype),zat(ntype)
REAL, INTENT (INOUT) :: tau0(3,ntype)
REAL, INTENT (INOUT) :: y(3*ntype),xold(3*ntype)
REAL, INTENT (INOUT) :: h(3*ntype,3*ntype)
! ..
! .. Local Scalars ..
INTEGER :: i,j,n,nn,ist,na
REAL :: py,yy,alpha,s,zatm,fmax,gamma,d2,dispmax
! ..
! .. Local Arrays ..
REAL :: f(3*ntype),p(3*ntype),v(3*ntype),xnew(3*ntype)
!
n=3*ntype
ist = istep+istep0
!--- > get positions and forces in correct form and output
DO na = 1,ntype
nn = 3*(na-1)
xnew(nn+1:nn+3) = tau0(:,na)
f(nn+1:nn+3) = force(:,na)
ENDDO
!Write new entry into forces.dat
OPEN(43,file ='forces.dat',status ='unknown',form='formatted'
$ ,position ='append')
WRITE (43,'(a,f20.10)') "energy =",tote
WRITE (43,'(3f16.9,3f14.9)')
> ((xnew(i+3*j),i = 1,3),(f(i+3*j),i = 1,3),j = 0,ntype-1)
CLOSE(43)
!--- > get maximum force
fmax = 0.0
DO na = 1,ntype
nn = 3*(na-1)
fmax = MAX( fmax, (f(nn+1)**2+f(nn+2)**2+f(nn+3)**2) )
ENDDO
fmax = SQRT(fmax)
WRITE (6,1000) istep,fmax
IF ( fmax<epsforce) THEN
lconv = .TRUE.
RETURN
ELSE
lconv = .FALSE.
ENDIF
1000 FORMAT (1x/,' atomic step',i4,': maximum force =',
+ 1p,e14.6,' hartrees/a.u.')
!------------------------------------------------------------
! ===> if first step, go along gradient
IF (ist==1) THEN
!--- > choose a reasonable first guess for scaling, but
!--- > limit displacement to a maximum of 0.25 a.u.
!--- > (may need to be changed for different systems)
!--- > this choice is based on a Debye temperature of 330K;
!--- > modify as needed (change thetad in param.8)
zatm = 0.0
DO i = 1,ntype
zatm = MAX(zatm,zat(i))
ENDDO
IF (ABS(xa)<1.0e-10) THEN
WRITE (6,*) 'WARNING, xa = 0.0 set to 2.0'
xa = 2.0
ENDIF
IF (ABS(thetad)<1.0e-10) THEN
WRITE (6,*) 'WARNING, thetad = 0.0 set to 330.0'
thetad = 330.0
ENDIF
alpha = (250.0/(zatm*xa))*((330./thetad)**2)
IF ( alpha*fmax*xa > 0.15 ) alpha = 0.25/(fmax*xa)
p(:) = alpha*f(:)
!--- > set h to identity matrix
h = 0.0
DO j = 1,n
h(j,j) = 1.0
ENDDO
ELSE
!------------------------------------------------------------
! ===> k-th step
!
!--- > determine p
p(:) = xnew(:)-xold(:)
!--- > update the change in gradients
y(:) = y(:)-f(:)
!--- > get necessary inner products and H|y>
py = dot_PRODUCT(p,y)
yy = 0.0
DO i = 1,n
s = 0.0
DO j = 1,n
s = s+y(j)*h(j,i)
ENDDO
v(i) = s
yy = yy+y(i)*s
ENDDO
!--- > check that update will leave h positive definite;
!--- > if not, then stop
IF (py<=0.0) THEN
WRITE (6,*) ' bfgs: <p|y> < 0'
WRITE (6,*) ' check convergence of forces'
CALL juDFT_error("bfgs: <p|y><0",calledby="bfgs")
ELSE
!--- > update h
IF (ist==2) THEN
gamma = py/yy
ELSE
gamma = 1.0
ENDIF
DO j = 1,n
DO i = 1,n
h(i,j) = (h(i,j) - (v(i)*p(j)+p(i)*v(j))/py)*gamma
+ + (1.+gamma*yy/py)*p(i)*p(j)/py
ENDDO
ENDDO
!--- > generate p
DO i = 1,n
s = 0.0
DO j = 1,n
s = s+f(j)*h(j,i)
ENDDO
p(i) = s
ENDDO
ENDIF
ENDIF
!-------------------------------------------------------------
!--- > put xold and y in the correct form for the next step
DO i = 1,n
xold(i) = xnew(i)
y(i) = f(i)
ENDDO
!--- > if displacements are all less than epsdisp, then converged
dispmax = 0.0
DO na = 1,ntype
nn = 3*(na-1)
d2 = p(nn+1)**2 + p(nn+2)**2 + p(nn+3)**2
dispmax = MAX( dispmax, d2)
ENDDO
dispmax = xa*SQRT(dispmax)
IF (dispmax<epsdisp) THEN
lconv = .TRUE.
ELSE
lconv = .FALSE.
ENDIF
!--- > get new displacements
DO i = 1,n
xnew(i) = xold(i)+p(i)
ENDDO
DO na = 1,ntype
nn = 3*(na-1)
tau0(1,na) = xnew(nn+1)
tau0(2,na) = xnew(nn+2)
tau0(3,na) = xnew(nn+3)
ENDDO
WRITE (6,'(1x/)')
WRITE (6,*) 'changes in p for step',ist
DO na = 1,ntype
nn = 3*(na-1)
WRITE (6,'(i5,6f12.6)') na,(p(nn+i),i = 1,3),(xnew(nn+j),j=1,3)
ENDDO
END SUBROUTINE bfgs
END MODULE m_bfgs
MODULE m_bfgs
USE m_juDFT
CONTAINS
!*******************************************************************
! relaxes the forces using the BFGS quasi-Newton method.
! input:
! istep = atomic step in this run
! istep0 = number of atomic steps in previous runs used
! in updating hessian
!
! output:
! lconv = logical true if forces are converged to tolerance
! given in epsforce
!
! the positions and forces from this step are added
! to file force.dat
!*******************************************************************
SUBROUTINE bfgs(ntype,istep,istep0,force,zat,xa,thetad,epsdisp,epsforce,tote,&
xold,y,h,tau0,lconv)
IMPLICIT NONE
! Scalar Arguments
INTEGER, INTENT (IN) :: ntype,istep,istep0
REAL, INTENT (IN) :: epsdisp,epsforce,tote
REAL, INTENT (INOUT) :: thetad,xa
LOGICAL, INTENT (OUT) :: lconv
! Array Arguments
REAL, INTENT (IN) :: force(3,ntype),zat(ntype)
REAL, INTENT (INOUT) :: tau0(3,ntype)
REAL, INTENT (INOUT) :: y(3*ntype),xold(3*ntype)
REAL, INTENT (INOUT) :: h(3*ntype,3*ntype)
! Local Scalars
INTEGER :: i,j,n,nn,ist,na
REAL :: py,yy,alpha,s,zatm,fmax,gamma,d2,dispmax
! Local Arrays
REAL :: f(3*ntype),p(3*ntype),v(3*ntype),xnew(3*ntype)
n=3*ntype
ist = istep+istep0
! get positions and forces in correct form and output
DO na = 1,ntype
nn = 3*(na-1)
xnew(nn+1:nn+3) = tau0(:,na)
f(nn+1:nn+3) = force(:,na)
END DO
! Write new entry into forces.dat
OPEN(43,file ='forces.dat',status ='unknown',form='formatted',position ='append')
WRITE (43,'(a,f20.10)') "energy =",tote
WRITE (43,'(3f16.9,3f14.9)') ((xnew(i+3*j),i = 1,3),(f(i+3*j),i = 1,3),j = 0,ntype-1)
CLOSE(43)
! get maximum force
fmax = 0.0
DO na = 1,ntype
nn = 3*(na-1)
fmax = MAX( fmax, (f(nn+1)**2+f(nn+2)**2+f(nn+3)**2) )
END DO
fmax = SQRT(fmax)
WRITE (6,1000) istep,fmax
IF (fmax < epsforce) THEN
lconv = .TRUE.
RETURN
ELSE
lconv = .FALSE.
END IF
1000 FORMAT (1x/,' atomic step',i4,': maximum force =',1p,e14.6,' hartrees/a.u.')
! if first step, go along gradient
IF (ist==1) THEN
! choose a reasonable first guess for scaling, but
! limit displacement to a maximum of 0.25 a.u.
! (may need to be changed for different systems)
! this choice is based on a Debye temperature of 330K;
! modify as needed (change thetad in param.8)
zatm = 0.0
DO i = 1,ntype
zatm = MAX(zatm,zat(i))
END DO
IF (ABS(xa)<1.0e-10) THEN
WRITE (6,*) 'WARNING, xa = 0.0 set to 2.0'
xa = 2.0
END IF
IF (ABS(thetad)<1.0e-10) THEN
WRITE (6,*) 'WARNING, thetad = 0.0 set to 330.0'
thetad = 330.0
END IF
alpha = (250.0/(zatm*xa))*((330./thetad)**2)
IF ( alpha*fmax*xa > 0.15 ) alpha = 0.25/(fmax*xa)
p(:) = alpha*f(:)
! set h to identity matrix
h = 0.0
DO j = 1,n
h(j,j) = 1.0
END DO
ELSE
! k-th step
! determine p
p(:) = xnew(:) - xold(:)
! update the change in gradients
y(:) = y(:) - f(:)
! get necessary inner products and H|y>
py = dot_PRODUCT(p,y)
yy = 0.0
DO i = 1,n
s = 0.0
DO j = 1,n
s = s+y(j)*h(j,i)
END DO
v(i) = s
yy = yy+y(i)*s
END DO
! check that update will leave h positive definite;
! if not, then stop
IF (py <= 0.0) THEN
WRITE (6,*) ' bfgs: <p|y> < 0'
WRITE (6,*) ' check convergence of forces'
CALL juDFT_error("bfgs: <p|y><0",calledby="bfgs")
ELSE
! update h
IF (ist==2) THEN
gamma = py/yy
ELSE
gamma = 1.0
ENDIF
DO j = 1,n
DO i = 1,n
h(i,j) = (h(i,j) - (v(i)*p(j)+p(i)*v(j))/py)*gamma + (1.+gamma*yy/py)*p(i)*p(j)/py
END DO
END DO
! generate p
DO i = 1,n
s = 0.0
DO j = 1,n
s = s+f(j)*h(j,i)
END DO
p(i) = s
END DO
END IF
END IF
! put xold and y in the correct form for the next step
DO i = 1, n
xold(i) = xnew(i)
y(i) = f(i)
END DO
! if displacements are all less than epsdisp, then converged
dispmax = 0.0
DO na = 1,ntype
nn = 3*(na-1)
d2 = p(nn+1)**2 + p(nn+2)**2 + p(nn+3)**2
dispmax = MAX( dispmax, d2)
END DO
dispmax = xa*SQRT(dispmax)
IF (dispmax<epsdisp) THEN
lconv = .TRUE.
ELSE
lconv = .FALSE.
END IF
! get new displacements
DO i = 1,n
xnew(i) = xold(i) + p(i)
END DO
DO na = 1,ntype
nn = 3*(na-1)
tau0(1,na) = xnew(nn+1)
tau0(2,na) = xnew(nn+2)
tau0(3,na) = xnew(nn+3)
END DO
WRITE (6,'(1x/)')
WRITE (6,*) 'changes in p for step',ist
DO na = 1,ntype
nn = 3*(na-1)
WRITE (6,'(i5,6f12.6)') na,(p(nn+i),i = 1,3),(xnew(nn+j),j=1,3)
END DO
END SUBROUTINE bfgs
END MODULE m_bfgs
MODULE m_bfgs0
CONTAINS
SUBROUTINE bfgs0(
> ntype,
< istep0,xold,y,h)
c
c*******************************************************************
c checks whether a file exists with positions and forces to
c use to relax structure using the BFGS quasi-Newton method.
c istep0 is the number of steps included on file.
c h,y, and xold will be saved correctly for further use.
c*******************************************************************
c
IMPLICIT NONE
C ..
C .. Scalar Arguments ..
INTEGER, INTENT (IN) :: ntype
INTEGER, INTENT (OUT):: istep0
C ..
C .. Array Arguments ..
REAL, INTENT (OUT):: y(3*ntype),xold(3*ntype)
REAL, INTENT (OUT):: h(3*ntype,3*ntype)
C ..
C .. Local Scalars ..
INTEGER n,is,i,j
REAL yy,py,s,gamma
CHARACTER :: testchar
INTEGER :: maxhist
LOGICAL :: l_skip