Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
fleur
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
51
Issues
51
List
Boards
Labels
Service Desk
Milestones
Operations
Operations
Incidents
Packages & Registries
Packages & Registries
Container Registry
Analytics
Analytics
Repository
Value Stream
Wiki
Wiki
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Commits
Issue Boards
Open sidebar
fleur
fleur
Commits
c5ee8c07
Commit
c5ee8c07
authored
Feb 22, 2019
by
Daniel Wortmann
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Redesign of relaxation part
parent
c06c57f7
Changes
12
Hide whitespace changes
Inline
Side-by-side
Showing
12 changed files
with
525 additions
and
245 deletions
+525
-245
force/CMakeLists.txt
force/CMakeLists.txt
+2
-1
force/force_w.F90
force/force_w.F90
+14
-20
force/relaxation.F90
force/relaxation.F90
+156
-0
global/chkmt.f90
global/chkmt.f90
+16
-10
init/old_inp/inped.F90
init/old_inp/inped.F90
+1
-1
init/postprocessInput.F90
init/postprocessInput.F90
+10
-9
inpgen/set_inp.f90
inpgen/set_inp.f90
+4
-4
io/r_inpXML.F90
io/r_inpXML.F90
+8
-2
io/relax_io.F90
io/relax_io.F90
+125
-43
io/xml/FleurInputSchema.xsd
io/xml/FleurInputSchema.xsd
+36
-0
main/fleur.F90
main/fleur.F90
+1
-3
main/totale.f90
main/totale.f90
+152
-152
No files found.
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.
f
90
force/force_w.
F
90
force/geo.f90
force/stern.f90
force/relaxation.F90
)
force/force_w.
f
90
→
force/force_w.
F
90
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
(
IN
OUT
),
ALLOCATABLE
::
positions
(:,:,:)
REAL
,
INTENT
(
IN
OUT
),
ALLOCATABLE
::
forces
(:,:,:)
REAL
,
INTENT
(
IN
OUT
),
ALLOCATABLE
::
energies
(:)
REAL
,
ALLOCATABLE
::
rtmp
(:,:,:)
INTEGER
::
no_steps
INTEGER
::
ntype
,
step
,
n
CHARACTER
(
len
=
5
0
)::
path
,
p
,
str
CHARACTER
(
len
=
10
0
)::
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
),
"/pos
force
["
,
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