Commit c5ee8c07 authored by Daniel Wortmann's avatar Daniel Wortmann

Redesign of relaxation part

parent c06c57f7
...@@ -16,7 +16,8 @@ force/force_a4_add.f90 ...@@ -16,7 +16,8 @@ force/force_a4_add.f90
force/force_a8.F90 force/force_a8.F90
force/force_b8.f90 force/force_b8.f90
force/force_sf.F90 force/force_sf.F90
force/force_w.f90 force/force_w.F90
force/geo.f90 force/geo.f90
force/stern.f90 force/stern.f90
force/relaxation.F90
) )
...@@ -3,14 +3,14 @@ ...@@ -3,14 +3,14 @@
! Printing force components ! Printing force components
! ************************************************************ ! ************************************************************
CONTAINS CONTAINS
SUBROUTINE force_w(& SUBROUTINE force_w(mpi,input,atoms,sym,results,cell,oneD,vacuum)
& input,atoms,sym,results,cell,oneD,vacuum)
USE m_geo USE m_geo
USE m_relax USE m_relax
USE m_types USE m_types
USE m_xmlOutput USE m_xmlOutput
use m_relaxation
IMPLICIT NONE IMPLICIT NONE
TYPE(t_mpi),INTENT(IN) :: mpi
TYPE(t_results),INTENT(IN) :: results TYPE(t_results),INTENT(IN) :: results
TYPE(t_oneD),INTENT(IN) :: oneD TYPE(t_oneD),INTENT(IN) :: oneD
TYPE(t_input),INTENT(IN) :: input TYPE(t_input),INTENT(IN) :: input
...@@ -24,7 +24,7 @@ ...@@ -24,7 +24,7 @@
REAL sum REAL sum
INTEGER i,jsp,n,nat1,ierr INTEGER i,jsp,n,nat1,ierr
REAL eps_force REAL eps_force
LOGICAL :: l_new LOGICAL :: l_new,l_relax
! .. ! ..
! .. Local Arrays .. ! .. Local Arrays ..
REAL forcetot(3,atoms%ntype) REAL forcetot(3,atoms%ntype)
...@@ -32,6 +32,7 @@ ...@@ -32,6 +32,7 @@
! !
! write spin-dependent forces ! write spin-dependent forces
! !
IF (mpi%irank==0) THEN
nat1 = 1 nat1 = 1
DO n = 1,atoms%ntype DO n = 1,atoms%ntype
IF (atoms%l_geo(n)) THEN IF (atoms%l_geo(n)) THEN
...@@ -107,19 +108,12 @@ ...@@ -107,19 +108,12 @@
WRITE (6,8020) eps_force,sum WRITE (6,8020) eps_force,sum
8020 FORMAT ('eps_force=',f8.5,'max=',f8.5) 8020 FORMAT ('eps_force=',f8.5,'max=',f8.5)
ENDIF
INQUIRE(file ="relax_inp",exist= l_new) l_relax=sum<eps_force
IF (l_new) THEN #ifdef CPP_MPI
CALL relax(input%film,atoms%pos,atoms%neq,sym%mrot,sym%tau,cell%amat,cell%bmat,atoms%ngopr,sym%invtab& CALL MPI_BCAST(l_relax,1,MPI_LOGICAL,0,ierr)
& ,forcetot) #endif
ELSE IF (l_relax.and.input%l_f) CALL relaxation(mpi,input,atoms,cell,sym,forcetot,results%tote)
IF ((sum<eps_force).AND.input%l_f) THEN END SUBROUTINE force_w
CALL geo(& END MODULE m_forcew
& atoms,sym,cell,&
& oneD,vacuum,input,results%tote,forcetot)
END IF
ENDIF
END SUBROUTINE force_w
END MODULE m_forcew
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
...@@ -15,10 +15,9 @@ ...@@ -15,10 +15,9 @@
! GM'16 ! GM'16
!--------------------------------------------------------------------- !---------------------------------------------------------------------
CONTAINS CONTAINS
SUBROUTINE chkmt(& SUBROUTINE chkmt(atoms,input,vacuum,cell,oneD,l_test,&
& atoms,input,vacuum,cell,oneD,& l_gga,noel, kmax,dtild,dvac1,lmax1,jri1,rmt1,dx1,&!optional, if l_gga and ... are present suggestions are calculated
& l_gga,noel,l_test,& overlap)!this is optional, if present and l_test the routine returns the overlaps and does not stop
& kmax,dtild,dvac1,lmax1,jri1,rmt1,dx1)
USE m_types USE m_types
USE m_sort USE m_sort
...@@ -32,13 +31,15 @@ ...@@ -32,13 +31,15 @@
TYPE(t_vacuum),INTENT(IN):: vacuum TYPE(t_vacuum),INTENT(IN):: vacuum
TYPE(t_cell),INTENT(IN) :: cell TYPE(t_cell),INTENT(IN) :: cell
TYPE(t_oneD),INTENT(IN) :: oneD TYPE(t_oneD),INTENT(IN) :: oneD
CHARACTER*3, INTENT (IN) :: noel(atoms%ntype) CHARACTER*3, INTENT (IN),OPTIONAL :: noel(atoms%ntype)
LOGICAL, INTENT (IN) :: l_gga,l_test LOGICAL, INTENT (IN),OPTIONAL :: l_gga
REAL, INTENT (OUT) :: kmax,dtild,dvac1 LOGICAL, INTENT (IN) ::l_test
REAL, INTENT (OUT),OPTIONAL :: kmax,dtild,dvac1
! .. ! ..
! .. Array Arguments .. ! .. Array Arguments ..
INTEGER, INTENT (OUT) :: lmax1(atoms%ntype),jri1(atoms%ntype) INTEGER, INTENT (OUT),OPTIONAL :: lmax1(atoms%ntype),jri1(atoms%ntype)
REAL, INTENT (OUT) :: rmt1(atoms%ntype),dx1(atoms%ntype) REAL, INTENT (OUT),OPTIONAL :: rmt1(atoms%ntype),dx1(atoms%ntype)
REAL,OPTIONAL,INTENT(OUT):: overlap(0:atoms%ntype,atoms%ntype)
! .. ! ..
! .. Local Scalars .. ! .. Local Scalars ..
INTEGER na,n INTEGER na,n
...@@ -92,6 +93,7 @@ ...@@ -92,6 +93,7 @@
! 0. Do initializations and set some constants ! 0. Do initializations and set some constants
if (present(overlap)) overlap=0.0
rmtMaxDefault = 2.8 rmtMaxDefault = 2.8
rmtMax = rmtMaxDefault rmtMax = rmtMaxDefault
...@@ -291,6 +293,7 @@ ...@@ -291,6 +293,7 @@
END IF END IF
END DO END DO
IF (PRESENT(l_gga)) THEN
! Sort distances and set MT radii for the atoms ! Sort distances and set MT radii for the atoms
CALL sort(sortedDistList,nearestAtomDists) CALL sort(sortedDistList,nearestAtomDists)
...@@ -405,6 +408,7 @@ ...@@ -405,6 +408,7 @@
WRITE (6,'("k_max =",f8.5)') rkm WRITE (6,'("k_max =",f8.5)') rkm
WRITE (6,'("G_max =",f8.5)') 3*rkm WRITE (6,'("G_max =",f8.5)') 3*rkm
kmax = rkm kmax = rkm
ENDIF
! 7. Test old MT radii ! 7. Test old MT radii
...@@ -415,6 +419,7 @@ ...@@ -415,6 +419,7 @@
k = nearestNeighbors(j,i) k = nearestNeighbors(j,i)
IF (atoms%rmt(i)+atoms%rmt(k).GE.nearestNeighborDists(j,i)) THEN IF (atoms%rmt(i)+atoms%rmt(k).GE.nearestNeighborDists(j,i)) THEN
error = .TRUE. 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) WRITE(6,240) i,k,nearestNeighborDists(j,i),atoms%rmt(i),atoms%rmt(k)
END IF END IF
END DO END DO
...@@ -434,13 +439,14 @@ ...@@ -434,13 +439,14 @@
((atoms%pos(3,iAtom)-atoms%rmt(i)).LT.-vacuum%dvac/2.)) THEN ((atoms%pos(3,iAtom)-atoms%rmt(i)).LT.-vacuum%dvac/2.)) THEN
error=.TRUE. error=.TRUE.
WRITE(6,241) i ,na 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. WRITE(6,*) atoms%pos(3,iAtom),atoms%rmt(i),vacuum%dvac/2.
ENDIF ENDIF
ENDIF ENDIF
END DO END DO
END IF END IF
END DO 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 END IF
DEALLOCATE(nearestNeighbors,numNearestNeighbors,nearestNeighborDists) DEALLOCATE(nearestNeighbors,numNearestNeighbors,nearestNeighborDists)
......
...@@ -349,7 +349,7 @@ ...@@ -349,7 +349,7 @@
! !
l_gga= xcpot%is_gga() l_gga= xcpot%is_gga()
l_test = .TRUE. ! only checking, dont use new parameters 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 WRITE (6,FMT=8180) cell%volint
8180 FORMAT (13x,' volume of interstitial region=',f12.6) 8180 FORMAT (13x,' volume of interstitial region=',f12.6)
......
...@@ -38,6 +38,7 @@ SUBROUTINE postprocessInput(mpi,input,field,sym,stars,atoms,vacuum,obsolete,kpts ...@@ -38,6 +38,7 @@ SUBROUTINE postprocessInput(mpi,input,field,sym,stars,atoms,vacuum,obsolete,kpts
USE m_nocoInputCheck USE m_nocoInputCheck
USE m_kpoints USE m_kpoints
USE m_types_forcetheo_extended USE m_types_forcetheo_extended
USE m_relaxio
IMPLICIT NONE IMPLICIT NONE
...@@ -319,15 +320,7 @@ SUBROUTINE postprocessInput(mpi,input,field,sym,stars,atoms,vacuum,obsolete,kpts ...@@ -319,15 +320,7 @@ SUBROUTINE postprocessInput(mpi,input,field,sym,stars,atoms,vacuum,obsolete,kpts
END DO 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 ! Dimensioning of lattice harmonics
...@@ -468,6 +461,7 @@ SUBROUTINE postprocessInput(mpi,input,field,sym,stars,atoms,vacuum,obsolete,kpts ...@@ -468,6 +461,7 @@ SUBROUTINE postprocessInput(mpi,input,field,sym,stars,atoms,vacuum,obsolete,kpts
IF (atoms%n_u.GT.0) THEN IF (atoms%n_u.GT.0) THEN
CALL d_wigner(sym%nop,sym%mrot,cell%bmat,3,sym%d_wgn) CALL d_wigner(sym%nop,sym%mrot,cell%bmat,3,sym%d_wgn)
END IF END IF
IF (.NOT.oneD%odd%d1) THEN IF (.NOT.oneD%odd%d1) THEN
CALL mapatom(sym,atoms,cell,input,noco) CALL mapatom(sym,atoms,cell,input,noco)
oneD%ngopr1(1:atoms%nat) = atoms%ngopr(1:atoms%nat) 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 ...@@ -477,6 +471,13 @@ SUBROUTINE postprocessInput(mpi,input,field,sym,stars,atoms,vacuum,obsolete,kpts
CALL mapatom(sym,atoms,cell,input,noco) CALL mapatom(sym,atoms,cell,input,noco)
CALL od_mapatom(oneD,atoms,sym,cell) CALL od_mapatom(oneD,atoms,sym,cell)
END IF 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 !Calculate kpoint in the full BZ
IF (kpts%l_gamma.and. banddos%ndir .eq. 0.and.kpts%specificationType==2) THEN 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 ...@@ -551,7 +552,7 @@ SUBROUTINE postprocessInput(mpi,input,field,sym,stars,atoms,vacuum,obsolete,kpts
END IF !(mpi%irank.EQ.0) END IF !(mpi%irank.EQ.0)
END IF END IF
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!! End of input postprocessing (calculate missing parameters) !!! End of input postprocessing (calculate missing parameters)
......
...@@ -201,8 +201,8 @@ ...@@ -201,8 +201,8 @@
a1(:) = cell%amat(:,1) ; a2(:) = cell%amat(:,2) ; a3(:) = cell%amat(:,3) a1(:) = cell%amat(:,1) ; a2(:) = cell%amat(:,2) ; a3(:) = cell%amat(:,3)
CALL chkmt(& CALL chkmt(&
& atoms,input,vacuum,cell,oneD,& & atoms,input,vacuum,cell,oneD,l_test,&
& l_gga,noel,l_test,& & l_gga,noel,&
& kmax,dtild,vacuum%dvac,atoms%lmax,atoms%jri,atoms%rmt,atoms%dx) & kmax,dtild,vacuum%dvac,atoms%lmax,atoms%jri,atoms%rmt,atoms%dx)
! --> read in (possibly) atomic info ! --> read in (possibly) atomic info
...@@ -236,8 +236,8 @@ ...@@ -236,8 +236,8 @@
rmtTemp = 999.0 rmtTemp = 999.0
l_test = .true. l_test = .true.
CALL chkmt(& CALL chkmt(&
& atoms,input,vacuum,cell,oneD,& & atoms,input,vacuum,cell,oneD,l_test,&
& l_gga,noel,l_test,& & l_gga,noel,&
& kmax0,dtild0,dvac0,lmax0,jri0,rmtTemp,dx0) & kmax0,dtild0,dvac0,lmax0,jri0,rmtTemp,dx0)
IF ( ANY(atoms%nlo(:).NE.0) ) THEN IF ( ANY(atoms%nlo(:).NE.0) ) THEN
......
...@@ -704,6 +704,10 @@ input%preconditioning_param = evaluateFirstOnly(xmlGetAttributeValue('/fleurInpu ...@@ -704,6 +704,10 @@ input%preconditioning_param = evaluateFirstOnly(xmlGetAttributeValue('/fleurInpu
xPathA = '/fleurInput/calculationSetup/fields' xPathA = '/fleurInput/calculationSetup/fields'
numberNodes = xmlGetNumberOfNodes(xPathA) numberNodes = xmlGetNumberOfNodes(xPathA)
field%b_field=0.0
field%l_b_field=.FALSE.
field%efield%sigma=0.0
IF (numberNodes.EQ.1) THEN IF (numberNodes.EQ.1) THEN
IF (xmlGetNumberOfNodes(TRIM(ADJUSTL(xPathA))//'/@b_field')>0) THEN IF (xmlGetNumberOfNodes(TRIM(ADJUSTL(xPathA))//'/@b_field')>0) THEN
...@@ -725,7 +729,8 @@ input%preconditioning_param = evaluateFirstOnly(xmlGetAttributeValue('/fleurInpu ...@@ -725,7 +729,8 @@ input%preconditioning_param = evaluateFirstOnly(xmlGetAttributeValue('/fleurInpu
WRITE(xPathB,"(a,a,i0,a)") TRIM(ADJUSTL(xpathA)),'/shape[',i,']' WRITE(xPathB,"(a,a,i0,a)") TRIM(ADJUSTL(xpathA)),'/shape[',i,']'
field%efield%shapes(i)=TRIM(ADJUSTL(xmlGetAttributeValue(TRIM(ADJUSTL(xPathB))))) field%efield%shapes(i)=TRIM(ADJUSTL(xmlGetAttributeValue(TRIM(ADJUSTL(xPathB)))))
ENDDO ENDDO
ELSE
ALLOCATE(field%efield%shapes(0))
END IF END IF
! Read in optional energy parameter limits ! Read in optional energy parameter limits
...@@ -2139,12 +2144,13 @@ input%preconditioning_param = evaluateFirstOnly(xmlGetAttributeValue('/fleurInpu ...@@ -2139,12 +2144,13 @@ input%preconditioning_param = evaluateFirstOnly(xmlGetAttributeValue('/fleurInpu
CALL inpnoco(atoms,input,vacuum,noco) CALL inpnoco(atoms,input,vacuum,noco)
END IF END IF
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!! End of non-XML input !!! End of non-XML input
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!CALL xmlFreeResources() !CALL xmlFreeResources()
!WRITE(*,*) 'Reading of inp.xml file finished' !WRITE(*,*) 'Reading of inp.xml file finished'
DEALLOCATE(speciesNLO) DEALLOCATE(speciesNLO)
......
...@@ -8,7 +8,7 @@ MODULE m_relaxio ...@@ -8,7 +8,7 @@ MODULE m_relaxio
USE m_judft USE m_judft
IMPLICIT NONE IMPLICIT NONE
PRIVATE PRIVATE
PUBLIC :: read_relax,write_relax PUBLIC :: read_relax,write_relax,apply_displacements,read_displacements
CONTAINS CONTAINS
SUBROUTINE write_relax(positions,forces,energies,displace) SUBROUTINE write_relax(positions,forces,energies,displace)
REAL,INTENT(in):: positions(:,:,:) REAL,INTENT(in):: positions(:,:,:)
...@@ -19,16 +19,17 @@ CONTAINS ...@@ -19,16 +19,17 @@ CONTAINS
INTEGER :: no_steps,n,ntype,step INTEGER :: no_steps,n,ntype,step
No_steps=SIZE(positions,3) No_steps=SIZE(positions,3)
ntype=SIZE(positions,2) ntype=SIZE(positions,2)
IF (ntype.NE.SIZE(forces,2).OR.ntype<SIZE(displace,2).OR.& 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)) & no_steps.NE.SIZE(forces,3).OR.no_steps.NE.SIZE(energies))THEN
CALL judft_error("BUG in relax_io") CALL judft_error("BUG in relax_io")
OPEN(765,file="relax.inp",status="replace") ENDIF
OPEN(765,file="relax.xml",status="replace")
WRITE(765,*) "<relaxation>" WRITE(765,*) "<relaxation>"
!write current set of displacements !write current set of displacements
WRITE(765,*) " <displacements>" WRITE(765,*) " <displacements>"
DO n=1,SIZE(displace,2) DO n=1,SIZE(displace,2)
WRITE(765,"(a,i0,a,3(f15.10,1x),a)") & WRITE(765,"(a,3(f15.10,1x),a)") &
' <displace na="',n,'">',displace(:,n),'</displace>' ' <displace>',displace(:,n),'</displace>'
END DO END DO
WRITE(765,"(a)") ' </displacements>' WRITE(765,"(a)") ' </displacements>'
...@@ -37,10 +38,8 @@ CONTAINS ...@@ -37,10 +38,8 @@ CONTAINS
DO step=1,no_steps DO step=1,no_steps
WRITE(765,"(a,f20.10,a)") ' <step energy="',energies(step),'">' WRITE(765,"(a,f20.10,a)") ' <step energy="',energies(step),'">'
DO n=1,ntype DO n=1,ntype
WRITE(765,"(a,i0,a,3(f15.10,1x),a)") & WRITE(765,"(a,6(f15.10,1x),a)") &
' <pos n="',n,'">',positions(:,n,step),'</pos>' ' <posforce>',positions(:,n,step),forces(:,n,step),'</posforce>'
WRITE(765,"(a,i0,a,3(f15.10,1x),a)") &
' <force n="',n,'">',forces(:,n,step),'</force>'
END DO END DO
WRITE(765,"(a)") ' </step>' WRITE(765,"(a)") ' </step>'
ENDDO ENDDO
...@@ -52,61 +51,144 @@ CONTAINS ...@@ -52,61 +51,144 @@ CONTAINS
SUBROUTINE read_relax(positions,forces,energies) SUBROUTINE read_relax(positions,forces,energies)
USE m_xmlIntWrapFort USE m_xmlIntWrapFort
USE m_calculator USE m_calculator
REAL,INTENT(OUT),ALLOCATABLE:: positions(:,:,:)