Skip to content

GitLab

fleur
fleur
Commit c5ee8c07 authored by Daniel Wortmann's avatar Daniel Wortmann
Browse files
Options

Redesign of relaxation part

parent c06c57f7
Hide whitespace changes
Inline Side-by-side
Showing with 525 additions and 245 deletions
force/CMakeLists.txt
View file @ c5ee8c07
......@@ -16,7 +16,8 @@ force/force_a4_add.f90
force/force_a8.F90
force/force_b8.f90
force/force_sf.F90
force/force_w.f90
force/force_w.F90
force/geo.f90
force/stern.f90
force/relaxation.F90
)
force/force_w.f90 → force/force_w.F90
View file @ c5ee8c07
......@@ -3,14 +3,14 @@
! Printing force components
! ************************************************************
CONTAINS
SUBROUTINE force_w(&
& input,atoms,sym,results,cell,oneD,vacuum)
SUBROUTINE force_w(mpi,input,atoms,sym,results,cell,oneD,vacuum)
USE m_geo
USE m_relax
USE m_types
USE m_xmlOutput
use m_relaxation
IMPLICIT NONE
TYPE(t_mpi),INTENT(IN) :: mpi
TYPE(t_results),INTENT(IN) :: results
TYPE(t_oneD),INTENT(IN) :: oneD
TYPE(t_input),INTENT(IN) :: input
......@@ -24,7 +24,7 @@
REAL sum
INTEGER i,jsp,n,nat1,ierr
REAL eps_force
LOGICAL :: l_new
LOGICAL :: l_new,l_relax
! ..
! .. Local Arrays ..
REAL forcetot(3,atoms%ntype)
......@@ -32,6 +32,7 @@
!
! write spin-dependent forces
!
IF (mpi%irank==0) THEN
nat1 = 1
DO n = 1,atoms%ntype
IF (atoms%l_geo(n)) THEN
......@@ -107,19 +108,12 @@
WRITE (6,8020) eps_force,sum
8020 FORMAT ('eps_force=',f8.5,'max=',f8.5)
INQUIRE(file ="relax_inp",exist= l_new)
IF (l_new) THEN
CALL relax(input%film,atoms%pos,atoms%neq,sym%mrot,sym%tau,cell%amat,cell%bmat,atoms%ngopr,sym%invtab&
& ,forcetot)
ELSE
IF ((sum<eps_force).AND.input%l_f) THEN
CALL geo(&
& atoms,sym,cell,&
& oneD,vacuum,input,results%tote,forcetot)
END IF
ENDIF
END SUBROUTINE force_w
END MODULE m_forcew
ENDIF
l_relax=sum<eps_force
#ifdef CPP_MPI
CALL MPI_BCAST(l_relax,1,MPI_LOGICAL,0,ierr)
#endif
IF (l_relax.and.input%l_f) CALL relaxation(mpi,input,atoms,cell,sym,forcetot,results%tote)
END SUBROUTINE force_w
END MODULE m_forcew
force/relaxation.F90 0 → 100644
View file @ c5ee8c07
MODULE m_relaxation
USE m_judft
IMPLICIT NONE
PRIVATE
integer:: input_force_relax=3
public relaxation
CONTAINS
SUBROUTINE relaxation(mpi,input,atoms,cell,sym,force_new,energies_new)
USE m_types
use m_relaxio
use m_broyd_io
TYPE(t_mpi),INTENT(IN) :: mpi
TYPE(t_input),INTENT(IN) :: input
TYPE(t_atoms),INTENT(IN) :: atoms
TYPE(t_sym),INTENT(IN) :: sym
TYPE(t_cell),INTENT(IN) :: cell
REAL,INTENT(in) :: force_new(:,:),energies_new
REAL,ALLOCATABLE :: pos(:,:,:),force(:,:,:),energies(:)
REAL,ALLOCATABLE :: displace(:,:),old_displace(:,:)
REAL :: alpha
INTEGER :: n
IF (mpi%irank==0) THEN
ALLOCATE(pos(3,atoms%ntype,1));
DO n=1,atoms%ntype
pos(:,n,1)=atoms%taual(:,SUM(atoms%neq(:n-1))+1)
END DO
ALLOCATE(force(3,atoms%ntype,1)); force(:,:,1)=force_new
ALLOCATE(energies(1));energies(1)=energies_new
ALLOCATE(displace(3,atoms%ntype),old_displace(3,atoms%ntype))
! add history
CALL read_relax(pos,force,energies)
!determine new positions
IF (SIZE(energies)==1.OR.input_force_relax==0) THEN
!no history present simple step
! choose a reasonable first guess for scaling
! this choice is based on a Debye temperature of 330K;
! modify as needed
alpha = (250.0/(MAXVAL(atoms%zatom)*input%xa))*((330./input%thetad)**2)
CALL simple_step(alpha,force,displace)
ELSEIF (input_force_relax==1) THEN
CALL simple_cg(pos,force,displace)
ELSE
CALL simple_bfgs(pos,force,displace)
ENDIF
CALL read_displacements(atoms,old_displace)
DO n=1,atoms%ntype
PRINT *,"OD:",old_displace(:,n)
PRINT *,"ND:",displace(:,n)
END DO
displace=displace+old_displace
!Write file
CALL write_relax(pos,force,energies,displace)
ENDIF
CALL resetBroydenHistory()
CALL judft_end("Structual relaxation done",0)
END SUBROUTINE relaxation
SUBROUTINE simple_step(alpha,force,displace)
!-----------------------------------------------
IMPLICIT NONE
REAL,INTENT(in) :: alpha
REAL,INTENT(in) :: force(:,:,:)
REAL,INTENT(OUT) :: displace(:,:)
displace = alpha*force(:,:,SIZE(force,3))
END SUBROUTINE simple_step
SUBROUTINE simple_bfgs(pos,force,shift)
!-----------------------------------------------
! Simple BFGS method to calculate shift out of old positions and forces
!-----------------------------------------------
IMPLICIT NONE
REAL,INTENT(in) :: pos(:,:,:),force(:,:,:)
real,INTENT(OUT) :: shift(:,:)
INTEGER :: n,i,j,hist_length,n_force
REAL,ALLOCATABLE:: h(:,:)
REAL,ALLOCATABLE:: p(:),y(:),v(:)
REAL :: py,yy,gamma
n_force=3*size(pos,2)
allocate(h(n_force,n_force))
allocate(p(n_force),y(n_force),v(n_force))
!calculate approx. Hessian
!initialize H
h = 0.0
DO n = 1,n_force
h(n,n) = 1.0
ENDDO
!loop over all iterations (including current)
hist_length=size(pos,3)
DO n = 2,hist_length
! differences
p(:) = RESHAPE(pos(:,:,n)-pos(:,:,n-1),(/SIZE(p)/))
y(:) = RESHAPE(force(:,:,n)-force(:,:,n-1),(/SIZE(p)/))
! get necessary inner products and H|y>
py = dot_PRODUCT(p,y)
v = MATMUL(y,h)
yy = dot_PRODUCT(y,v)
!check that update will leave h positive definite;
IF (py <= 0.0) THEN
WRITE (6,*) ' bfgs: <p|y> < 0'
WRITE (6,*) ' check convergence of forces'
!Starting over with initial hessian
h = 0.0
DO j = 1,n_force
h(j,j) = 1.0
ENDDO
CYCLE
ELSE
!update h
IF (n == 2) THEN
gamma = py/yy
ELSE
gamma = 1.0
ENDIF
DO j = 1,n_force
DO i = 1,n_force
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
ENDIF
ENDDO
y(:) = RESHAPE(force(:,:,hist_length),(/SIZE(p)/))
shift = reshape(MATMUL(y,h),shape(shift))
END SUBROUTINE simple_bfgs
SUBROUTINE simple_cg(pos,force,shift)
!-----------------------------------------------
IMPLICIT NONE
REAL,intent(in) :: pos(:,:,:),force(:,:,:)
real,INTENT(OUT) :: shift(:,:)
REAL :: f1(3,SIZE(pos,2)),f2(3,SIZE(pos,2))
INTEGER :: n_old
n_old = SIZE(pos,3)-1
f1 = (force(:,:,n_old+1)-force(:,:,n_old))/(pos(:,:,n_old+1)-pos(:,:,n_old))
f2 = force(:,:,n_old+1)-f1*pos(:,:,n_old+1)
shift = -1.*f2/f1-force(:,:,n_old+1)
END SUBROUTINE simple_cg
END MODULE m_relaxation
global/chkmt.f90
View file @ c5ee8c07
......@@ -15,10 +15,9 @@
! GM'16
!---------------------------------------------------------------------
CONTAINS
SUBROUTINE chkmt(&
& atoms,input,vacuum,cell,oneD,&
& l_gga,noel,l_test,&
& kmax,dtild,dvac1,lmax1,jri1,rmt1,dx1)
SUBROUTINE chkmt(atoms,input,vacuum,cell,oneD,l_test,&
l_gga,noel, kmax,dtild,dvac1,lmax1,jri1,rmt1,dx1,&!optional, if l_gga and ... are present suggestions are calculated
overlap)!this is optional, if present and l_test the routine returns the overlaps and does not stop
USE m_types
USE m_sort
......@@ -32,13 +31,15 @@
TYPE(t_vacuum),INTENT(IN):: vacuum
TYPE(t_cell),INTENT(IN) :: cell
TYPE(t_oneD),INTENT(IN) :: oneD
CHARACTER*3, INTENT (IN) :: noel(atoms%ntype)
LOGICAL, INTENT (IN) :: l_gga,l_test
REAL, INTENT (OUT) :: kmax,dtild,dvac1
CHARACTER*3, INTENT (IN),OPTIONAL :: noel(atoms%ntype)
LOGICAL, INTENT (IN),OPTIONAL :: l_gga
LOGICAL, INTENT (IN) ::l_test
REAL, INTENT (OUT),OPTIONAL :: kmax,dtild,dvac1
! ..
! .. Array Arguments ..
INTEGER, INTENT (OUT) :: lmax1(atoms%ntype),jri1(atoms%ntype)
REAL, INTENT (OUT) :: rmt1(atoms%ntype),dx1(atoms%ntype)
INTEGER, INTENT (OUT),OPTIONAL :: lmax1(atoms%ntype),jri1(atoms%ntype)
REAL, INTENT (OUT),OPTIONAL :: rmt1(atoms%ntype),dx1(atoms%ntype)
REAL,OPTIONAL,INTENT(OUT):: overlap(0:atoms%ntype,atoms%ntype)
! ..
! .. Local Scalars ..
INTEGER na,n
......@@ -92,6 +93,7 @@
! 0. Do initializations and set some constants
if (present(overlap)) overlap=0.0
rmtMaxDefault = 2.8
rmtMax = rmtMaxDefault
......@@ -291,6 +293,7 @@
END IF
END DO
IF (PRESENT(l_gga)) THEN
! Sort distances and set MT radii for the atoms
CALL sort(sortedDistList,nearestAtomDists)
......@@ -405,6 +408,7 @@
WRITE (6,'("k_max =",f8.5)') rkm
WRITE (6,'("G_max =",f8.5)') 3*rkm
kmax = rkm
ENDIF
! 7. Test old MT radii
......@@ -415,6 +419,7 @@
k = nearestNeighbors(j,i)
IF (atoms%rmt(i)+atoms%rmt(k).GE.nearestNeighborDists(j,i)) THEN
error = .TRUE.
IF (PRESENT(overlap)) overlap(i,k)=atoms%rmt(i)+atoms%rmt(k)-nearestNeighborDists(j,i)
WRITE(6,240) i,k,nearestNeighborDists(j,i),atoms%rmt(i),atoms%rmt(k)
END IF
END DO
......@@ -434,13 +439,14 @@
((atoms%pos(3,iAtom)-atoms%rmt(i)).LT.-vacuum%dvac/2.)) THEN
error=.TRUE.
WRITE(6,241) i ,na
IF (PRESENT(overlap)) overlap(0,i)=MAX(atoms%pos(3,iAtom)+atoms%rmt(i)-vacuum%dvac/2.,atoms%pos(3,iAtom)-atoms%rmt(i)+vacuum%dvac/2.)
WRITE(6,*) atoms%pos(3,iAtom),atoms%rmt(i),vacuum%dvac/2.
ENDIF
ENDIF
END DO
END IF
END DO
IF (error) CALL juDFT_error("Error checking M.T. radii",calledby ="chkmt")
IF (error.AND..NOT.PRESENT(overlap)) CALL juDFT_error("Error checking M.T. radii",calledby ="chkmt")
END IF
DEALLOCATE(nearestNeighbors,numNearestNeighbors,nearestNeighborDists)
......
init/old_inp/inped.F90
View file @ c5ee8c07
......@@ -349,7 +349,7 @@
!
l_gga= xcpot%is_gga()
l_test = .TRUE. ! only checking, dont use new parameters
CALL chkmt(atoms,input,vacuum,cell,oneD,l_gga,noel,l_test, kmax1,dtild,dvac1,lmax1,jri1,rmt1,dx1)
CALL chkmt(atoms,input,vacuum,cell,oneD,l_test,l_gga,noel, kmax1,dtild,dvac1,lmax1,jri1,rmt1,dx1)
WRITE (6,FMT=8180) cell%volint
8180 FORMAT (13x,' volume of interstitial region=',f12.6)
......
init/postprocessInput.F90
View file @ c5ee8c07
......@@ -38,6 +38,7 @@ SUBROUTINE postprocessInput(mpi,input,field,sym,stars,atoms,vacuum,obsolete,kpts
USE m_nocoInputCheck
USE m_kpoints
USE m_types_forcetheo_extended
USE m_relaxio
IMPLICIT NONE
......@@ -319,15 +320,7 @@ SUBROUTINE postprocessInput(mpi,input,field,sym,stars,atoms,vacuum,obsolete,kpts
END DO
! Check muffin tin radii
ALLOCATE (jri1(atoms%ntype), lmax1(atoms%ntype))
ALLOCATE (rmt1(atoms%ntype), dx1(atoms%ntype))
l_test = .TRUE. ! only checking, dont use new parameters
l_gga=xcpot%is_gga()
CALL chkmt(atoms,input,vacuum,cell,oneD,l_gga,noel,l_test,&
kmax1,dtild1,dvac1,lmax1,jri1,rmt1,dx1)
DEALLOCATE (jri1,lmax1,rmt1,dx1)
! Dimensioning of lattice harmonics
......@@ -468,6 +461,7 @@ SUBROUTINE postprocessInput(mpi,input,field,sym,stars,atoms,vacuum,obsolete,kpts
IF (atoms%n_u.GT.0) THEN
CALL d_wigner(sym%nop,sym%mrot,cell%bmat,3,sym%d_wgn)
END IF
IF (.NOT.oneD%odd%d1) THEN
CALL mapatom(sym,atoms,cell,input,noco)
oneD%ngopr1(1:atoms%nat) = atoms%ngopr(1:atoms%nat)
......@@ -477,6 +471,13 @@ SUBROUTINE postprocessInput(mpi,input,field,sym,stars,atoms,vacuum,obsolete,kpts
CALL mapatom(sym,atoms,cell,input,noco)
CALL od_mapatom(oneD,atoms,sym,cell)
END IF
! Check muffin tin radii
l_test = .TRUE. ! only checking, dont use new parameters
CALL chkmt(atoms,input,vacuum,cell,oneD,l_test)
!adjust positions by displacements
CALL apply_displacements(cell,input,vacuum,oneD,sym,noco,atoms)
!Calculate kpoint in the full BZ
IF (kpts%l_gamma.and. banddos%ndir .eq. 0.and.kpts%specificationType==2) THEN
......@@ -551,7 +552,7 @@ SUBROUTINE postprocessInput(mpi,input,field,sym,stars,atoms,vacuum,obsolete,kpts
END IF !(mpi%irank.EQ.0)
END IF
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!! End of input postprocessing (calculate missing parameters)
......
inpgen/set_inp.f90
View file @ c5ee8c07
......@@ -201,8 +201,8 @@
a1(:) = cell%amat(:,1) ; a2(:) = cell%amat(:,2) ; a3(:) = cell%amat(:,3)
CALL chkmt(&
& atoms,input,vacuum,cell,oneD,&
& l_gga,noel,l_test,&
& atoms,input,vacuum,cell,oneD,l_test,&
& l_gga,noel,&
& kmax,dtild,vacuum%dvac,atoms%lmax,atoms%jri,atoms%rmt,atoms%dx)
! --> read in (possibly) atomic info
......@@ -236,8 +236,8 @@
rmtTemp = 999.0
l_test = .true.
CALL chkmt(&
& atoms,input,vacuum,cell,oneD,&
& l_gga,noel,l_test,&
& atoms,input,vacuum,cell,oneD,l_test,&
& l_gga,noel,&
& kmax0,dtild0,dvac0,lmax0,jri0,rmtTemp,dx0)
IF ( ANY(atoms%nlo(:).NE.0) ) THEN
......
io/r_inpXML.F90
View file @ c5ee8c07
......@@ -704,6 +704,10 @@ input%preconditioning_param = evaluateFirstOnly(xmlGetAttributeValue('/fleurInpu
xPathA = '/fleurInput/calculationSetup/fields'
numberNodes = xmlGetNumberOfNodes(xPathA)
field%b_field=0.0
field%l_b_field=.FALSE.
field%efield%sigma=0.0
IF (numberNodes.EQ.1) THEN
IF (xmlGetNumberOfNodes(TRIM(ADJUSTL(xPathA))//'/@b_field')>0) THEN
......@@ -725,7 +729,8 @@ input%preconditioning_param = evaluateFirstOnly(xmlGetAttributeValue('/fleurInpu
WRITE(xPathB,"(a,a,i0,a)") TRIM(ADJUSTL(xpathA)),'/shape[',i,']'
field%efield%shapes(i)=TRIM(ADJUSTL(xmlGetAttributeValue(TRIM(ADJUSTL(xPathB)))))
ENDDO
ELSE
ALLOCATE(field%efield%shapes(0))
END IF
! Read in optional energy parameter limits
......@@ -2139,12 +2144,13 @@ input%preconditioning_param = evaluateFirstOnly(xmlGetAttributeValue('/fleurInpu
CALL inpnoco(atoms,input,vacuum,noco)
END IF
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!! End of non-XML input
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!CALL xmlFreeResources()
!WRITE(*,*) 'Reading of inp.xml file finished'
DEALLOCATE(speciesNLO)
......
io/relax_io.F90
View file @ c5ee8c07
......@@ -8,7 +8,7 @@ MODULE m_relaxio
USE m_judft
IMPLICIT NONE
PRIVATE
PUBLIC :: read_relax,write_relax
PUBLIC :: read_relax,write_relax,apply_displacements,read_displacements
CONTAINS
SUBROUTINE write_relax(positions,forces,energies,displace)
REAL,INTENT(in):: positions(:,:,:)
......@@ -19,16 +19,17 @@ CONTAINS
INTEGER :: no_steps,n,ntype,step
No_steps=SIZE(positions,3)
ntype=SIZE(positions,2)
IF (ntype.NE.SIZE(forces,2).OR.ntype<SIZE(displace,2).OR.&
no_steps.NE.SIZE(forces,3).OR.no_steps.NE.SIZE(energies)) &
CALL judft_error("BUG in relax_io")
OPEN(765,file="relax.inp",status="replace")
IF (ntype.NE.SIZE(forces,2).OR.ntype.ne.SIZE(displace,2).OR.&
no_steps.NE.SIZE(forces,3).OR.no_steps.NE.SIZE(energies))THEN
CALL judft_error("BUG in relax_io")
ENDIF
OPEN(765,file="relax.xml",status="replace")
WRITE(765,*) "<relaxation>"
!write current set of displacements
WRITE(765,*) " <displacements>"
DO n=1,SIZE(displace,2)
WRITE(765,"(a,i0,a,3(f15.10,1x),a)") &
' <displace na="',n,'">',displace(:,n),'</displace>'
WRITE(765,"(a,3(f15.10,1x),a)") &
' <displace>',displace(:,n),'</displace>'
END DO
WRITE(765,"(a)") ' </displacements>'
......@@ -37,10 +38,8 @@ CONTAINS
DO step=1,no_steps
WRITE(765,"(a,f20.10,a)") ' <step energy="',energies(step),'">'
DO n=1,ntype
WRITE(765,"(a,i0,a,3(f15.10,1x),a)") &
' <pos n="',n,'">',positions(:,n,step),'</pos>'
WRITE(765,"(a,i0,a,3(f15.10,1x),a)") &
' <force n="',n,'">',forces(:,n,step),'</force>'
WRITE(765,"(a,6(f15.10,1x),a)") &
' <posforce>',positions(:,n,step),forces(:,n,step),'</posforce>'
END DO
WRITE(765,"(a)") ' </step>'
ENDDO
......@@ -52,61 +51,144 @@ CONTAINS
SUBROUTINE read_relax(positions,forces,energies)
USE m_xmlIntWrapFort
USE m_calculator
REAL,INTENT(OUT),ALLOCATABLE:: positions(:,:,:)
REAL,INTENT(OUT),ALLOCATABLE:: forces(:,:,:)
REAL,INTENT(OUT),ALLOCATABLE:: energies(:)
REAL,INTENT(INOUT),ALLOCATABLE:: positions(:,:,:)
REAL,INTENT(INOUT),ALLOCATABLE:: forces(:,:,:)
REAL,INTENT(INOUT),ALLOCATABLE:: energies(:)
REAL,ALLOCATABLE::rtmp(:,:,:)
INTEGER:: no_steps
INTEGER:: ntype,step,n
CHARACTER(len=50):: path,p,str
CHARACTER(len=100):: path,p,str
no_steps=xmlGetNumberOfNodes('/fleurInput/relaxation/relaxation-history/step')
ntype=SIZE(positions,2)
IF (no_steps==0) THEN
ALLOCATE(positions(0,0,0),forces(0,0,0),energies(0))
IF (.NOT.ALLOCATED(positions)) ALLOCATE(positions(0,0,0),forces(0,0,0),energies(0))
RETURN
END IF
IF (ALLOCATED(positions)) THEN
!Assume that we got already a set of positions, forces, energy and extend that list
rtmp=positions
deallocate(positions)
ALLOCATE(positions(3,ntype,no_steps+SIZE(rtmp,3)))
positions(:,:,no_steps+1:)=rtmp
rtmp=forces
deallocate(forces)
ALLOCATE(forces(3,ntype,no_steps+SIZE(rtmp,3)))
forces(:,:,no_steps+1:)=rtmp
rtmp(1,1,:)=energies
deallocate(energies)
ALLOCATE(energies(no_steps+SIZE(rtmp,3)))
energies(no_steps+1:)=rtmp(1,1,:)
ELSE
ntype=xmlGetNumberOfNodes('/fleurInput/relaxation/relaxation-history/step[1]/pos')
ALLOCATE(positions(3,ntype,no_steps))
ALLOCATE(forces(3,ntype,no_steps))
ALLOCATE(energies(no_steps))
END IF
ALLOCATE(positions(3,ntype,no_steps))
ALLOCATE(forces(3,ntype,no_steps))
ALLOCATE(energies(no_steps))
DO step=1,no_steps
WRITE(path,"(a,i0,a)") '/fleurInput/relaxation/relaxation-history/step[',step,']'
energies(step)=evaluateFirstOnly(xmlGetAttributeValue(TRIM(path)//"/energy"))
energies(step)=evaluateFirstOnly(xmlGetAttributeValue(TRIM(path)//"/@energy"))
DO n=1,ntype
WRITE(p,"(a,a,i0,a)") TRIM(path),"/pos[",n,"]"
WRITE(p,"(a,a,i0,a)") TRIM(path),"/posforce[",n,"]"
str=xmlGetAttributeValue(p)
positions(:,n,step)=(/evaluateFirst(str),evaluateFirst(str),evaluateFirst(str)/)
WRITE(p,"(a,a,i0,a)") TRIM(path),"/force[",n,"]"
str=xmlGetAttributeValue(p)
forces(:,n,step)=(/evaluateFirst(str),evaluateFirst(str),evaluateFirst(str)/)
Forces(:,n,step)=(/evaluateFirst(str),evaluateFirst(str),evaluateFirst(str)/)
ENDDO
END DO
END SUBROUTINE read_relax
SUBROUTINE read_displacements(cell,atoms)
SUBROUTINE read_displacements(atoms,disp)
USE m_xmlIntWrapFort
USE m_calculator
USE m_types
TYPE(t_cell),INTENT(INOUT) :: cell
TYPE(t_atoms),INTENT(in)::atoms
REAL,INTENT(out)::disp(:,:)
CHARACTER(len=50):: path,str
integer :: n
disp=0.0
IF (xmlGetNumberOfNodes('/fleurInput/relaxation/displacements')==0) RETURN
!read displacements and apply to positions
IF (atoms%ntype.NE.xmlGetNumberOfNodes('/fleurInput/relaxation/displacements/displace')) CALL judft_error("Wrong number of displacements in relaxation")
DO n=1,atoms%ntype
WRITE(path,"(a,i0,a)") '/fleurInput/relaxation/displacements/displace[',n,']'
str=xmlGetAttributeValue(path)
disp(:,n)=(/evaluateFirst(str),evaluateFirst(str),evaluateFirst(str)/)
END DO
END SUBROUTINE read_displacements
SUBROUTINE apply_displacements(cell,input,vacuum,oneD,sym,noco,atoms)
USE m_types
USE m_chkmt
use m_mapatom
TYPE(t_input),INTENT(IN) :: input
TYPE(t_vacuum),INTENT(IN) :: vacuum
TYPE(t_cell),INTENT(IN) :: cell
TYPE(t_oneD),INTENT(IN) :: oneD
TYPE(t_sym),INTENT(INOUT) :: sym
TYPE(t_noco),INTENT(IN) :: noco
TYPE(t_atoms),INTENT(INOUT):: atoms
INTEGER:: n,indx(2)
REAL :: disp(3,atoms%ntype),disp_all(3,atoms%nat),taual0(3,atoms%nat),overlap(0:atoms%ntype,atoms%ntype)
CALL read_displacements(atoms,disp)
IF (ALL(ABS(disp)<1E-8)) RETURN
!Fist make sure original MT spheres do not overlap
CALL chkmt(atoms,input,vacuum,cell,oneD,.TRUE.,overlap=overlap)
IF(ANY(overlap>0.0)) CALL judft_error("Overlapping MT-spheres in relaxation before even applying any displacement",hint="You messed up your setup")
INTEGER:: n,na
REAL :: d(3)
CHARACTER(len=50):: path,str
taual0=atoms%taual !Store original positions
IF (xmlGetNumberOfNodes('/fleurInput/relaxation/displacements').NE.0) THEN
!read displacements and apply to positions
DO n=1,xmlGetNumberOfNodes('/fleurInput/relaxation/displacements/displace')
WRITE(path,"(a,i0,a)") '/fleurInput/relaxation/displacements/displace[',n,']'
str=xmlGetAttributeValue(path)
d=(/evaluateFirst(str),evaluateFirst(str),evaluateFirst(str)/)
na=INT(evaluateFirstOnly(xmlGetAttributeValue(TRIM(path)//"/@na")))
IF (na>SIZE(atoms%taual,2)) CALL judft_error&
("Wrong number of displacements. na can not be larger than number of atoms in setup")
atoms%taual(:,na)=atoms%taual(:,na)+d
atoms%pos(:,na) = matmul(cell%amat,atoms%taual(:,na))
!Now check for overlapping mt-spheres
overlap=1.0
DO WHILE(ANY(overlap>1E-10))
atoms%taual=taual0
CALL rotate_to_all_sites(disp,atoms,cell,sym,disp_all)
atoms%taual=taual0+disp_all
atoms%pos=MATMUL(cell%amat,atoms%taual)
CALL chkmt(atoms,input,vacuum,cell,oneD,.TRUE.,overlap=overlap)
IF (ANY(overlap>0.0)) THEN
IF (ANY(overlap(0,:)>1E-10)) CALL judft_error("Atom spills out into vacuum during relaxation")
indx=MAXLOC(overlap(1:,:)) !the two indices with the most overlap