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
52
Issues
52
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
5870ffa6
Commit
5870ffa6
authored
Sep 22, 2017
by
Daniel Wortmann
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Added functionality to measure memory footprint for -debugtime option
parent
16e1f8aa
Changes
4
Hide whitespace changes
Inline
Side-by-side
Showing
4 changed files
with
341 additions
and
298 deletions
+341
-298
diagonalization/chani.F90
diagonalization/chani.F90
+60
-58
juDFT/stop.F90
juDFT/stop.F90
+204
-216
juDFT/sysinfo.F90
juDFT/sysinfo.F90
+74
-22
juDFT/time.F90
juDFT/time.F90
+3
-2
No files found.
diagonalization/chani.F90
View file @
5870ffa6
...
...
@@ -30,7 +30,7 @@ CONTAINS
!
!----------------------------------------------------
!
!#include"cpp_arch.h"
!#include"cpp_arch.h"
#include"cpp_double.h"
USE
m_juDFT
USE
m_types
...
...
@@ -45,7 +45,7 @@ CONTAINS
REAL
,
INTENT
(
OUT
)
::
eig
(
neigd
)
TYPE
(
t_hamOvlp
),
INTENT
(
INOUT
)
::
hamOvlp
TYPE
(
t_zMat
),
INTENT
(
INOUT
)
::
zMat
!... Local variables
!
INTEGER
nc
,
ic
,
ir
,
n_sym
,
jsym
,
num_j
,
icm
,
n_bound
...
...
@@ -79,7 +79,7 @@ CONTAINS
EXTERNAL
CPP_LAPACK_slamch
,
descinit
EXTERNAL
blacs_pinfo
,
blacs_gridinit
EXTERNAL
MPI_COMM_DUP
!
! determine actual number of columns of input matrices A and B
! nc is number of columns the local processor will get, must be <=n
...
...
@@ -293,52 +293,52 @@ CONTAINS
! Compute size of workspace
!
if
(
hamovlp
%
l_real
)
THEN
uplo
=
'U'
CALL
CPP_LAPACK_pdsygvx
(
1
,
'V'
,
'I'
,
'U'
,
m
,
asca_r
,
1
,
1
,
desca
,
bsca_r
,
1
,
1
,
desca
,&
0.0
,
1.0
,
1
,
num
,
abstol
,
num1
,
num2
,
eig2
,
orfac
,
eigvec_r
,
1
,
1
,&
desceigv
,
work2_r
,
-1
,
iwork
,
-1
,
ifail
,
iclustr
,
gap
,
ierr
)
IF
(
work2_r
(
1
)
.GT.
lwork2
)
THEN
lwork2
=
work2_r
(
1
)
DEALLOCATE
(
work2_r
)
ALLOCATE
(
work2_r
(
lwork2
+20
*
m
),
stat
=
err
)
! Allocate even more in case of clusters
IF
(
err
.NE.
0
)
THEN
WRITE
(
*
,
*
)
'work2 :'
,
err
,
lwork2
CALL
juDFT_error
(
'Failed to allocated "work2"'
,
calledby
=
'chani'
)
ENDIF
ENDIF
else
lrwork
=
4
*
m
+
MAX
(
5
*
nn
,
np0
*
mq0
)
+
iceil
(
neigd
,
nprow
*
npcol
)
*
nn
! Allocate more in case of clusters
ALLOCATE
(
rwork
(
lrwork
+10
*
m
),
stat
=
ierr
)
IF
(
err
/
=
0
)
THEN
WRITE
(
*
,
*
)
'ERROR: chani.F: Allocating rwork failed'
CALL
juDFT_error
(
'Failed to allocated "rwork"'
,
calledby
=
'chani'
)
ENDIF
CALL
CPP_LAPACK_pzhegvx
(
1
,
'V'
,
'I'
,
'U'
,
m
,
asca_c
,
1
,
1
,
desca
,
bsca_c
,
1
,
1
,
desca
,&
0.0
,
1.0
,
1
,
num
,
abstol
,
num1
,
num2
,
eig2
,
orfac
,
eigvec_c
,
1
,
1
,&
desceigv
,
work2_c
,
-1
,
rwork
,
-1
,
iwork
,
-1
,
ifail
,
iclustr
,&
gap
,
ierr
)
IF
(
ABS
(
work2_c
(
1
))
.GT.
lwork2
)
THEN
lwork2
=
work2_c
(
1
)
DEALLOCATE
(
work2_c
)
ALLOCATE
(
work2_c
(
lwork2
),
stat
=
err
)
IF
(
err
/
=
0
)
THEN
WRITE
(
*
,
*
)
'ERROR: chani.F: Allocating rwork failed:'
,
lwork2
CALL
juDFT_error
(
'Failed to allocated "work2"'
,
calledby
=
'chani'
)
uplo
=
'U'
CALL
CPP_LAPACK_pdsygvx
(
1
,
'V'
,
'I'
,
'U'
,
m
,
asca_r
,
1
,
1
,
desca
,
bsca_r
,
1
,
1
,
desca
,&
0.0
,
1.0
,
1
,
num
,
abstol
,
num1
,
num2
,
eig2
,
orfac
,
eigvec_r
,
1
,
1
,&
desceigv
,
work2_r
,
-1
,
iwork
,
-1
,
ifail
,
iclustr
,
gap
,
ierr
)
IF
(
work2_r
(
1
)
.GT.
lwork2
)
THEN
lwork2
=
work2_r
(
1
)
DEALLOCATE
(
work2_r
)
ALLOCATE
(
work2_r
(
lwork2
+20
*
m
),
stat
=
err
)
! Allocate even more in case of clusters
IF
(
err
.NE.
0
)
THEN
WRITE
(
*
,
*
)
'work2 :'
,
err
,
lwork2
CALL
juDFT_error
(
'Failed to allocated "work2"'
,
calledby
=
'chani'
)
ENDIF
ENDIF
ENDIF
IF
(
rwork
(
1
)
.GT.
lrwork
)
THEN
lrwork
=
rwork
(
1
)
DEALLOCATE
(
rwork
)
! Allocate even more in case of clusters
ALLOCATE
(
rwork
(
lrwork
+20
*
m
),
stat
=
err
)
else
lrwork
=
4
*
m
+
MAX
(
5
*
nn
,
np0
*
mq0
)
+
iceil
(
neigd
,
nprow
*
npcol
)
*
nn
! Allocate more in case of clusters
ALLOCATE
(
rwork
(
lrwork
+10
*
m
),
stat
=
ierr
)
IF
(
err
/
=
0
)
THEN
WRITE
(
*
,
*
)
'ERROR: chani.F: Allocating rwork failed
: '
,
lrwork
+20
*
m
WRITE
(
*
,
*
)
'ERROR: chani.F: Allocating rwork failed
'
CALL
juDFT_error
(
'Failed to allocated "rwork"'
,
calledby
=
'chani'
)
ENDIF
ENDIF
endif
CALL
CPP_LAPACK_pzhegvx
(
1
,
'V'
,
'I'
,
'U'
,
m
,
asca_c
,
1
,
1
,
desca
,
bsca_c
,
1
,
1
,
desca
,&
0.0
,
1.0
,
1
,
num
,
abstol
,
num1
,
num2
,
eig2
,
orfac
,
eigvec_c
,
1
,
1
,&
desceigv
,
work2_c
,
-1
,
rwork
,
-1
,
iwork
,
-1
,
ifail
,
iclustr
,&
gap
,
ierr
)
IF
(
ABS
(
work2_c
(
1
))
.GT.
lwork2
)
THEN
lwork2
=
work2_c
(
1
)
DEALLOCATE
(
work2_c
)
ALLOCATE
(
work2_c
(
lwork2
),
stat
=
err
)
IF
(
err
/
=
0
)
THEN
WRITE
(
*
,
*
)
'ERROR: chani.F: Allocating rwork failed:'
,
lwork2
CALL
juDFT_error
(
'Failed to allocated "work2"'
,
calledby
=
'chani'
)
ENDIF
ENDIF
IF
(
rwork
(
1
)
.GT.
lrwork
)
THEN
lrwork
=
rwork
(
1
)
DEALLOCATE
(
rwork
)
! Allocate even more in case of clusters
ALLOCATE
(
rwork
(
lrwork
+20
*
m
),
stat
=
err
)
IF
(
err
/
=
0
)
THEN
WRITE
(
*
,
*
)
'ERROR: chani.F: Allocating rwork failed: '
,
lrwork
+20
*
m
CALL
juDFT_error
(
'Failed to allocated "rwork"'
,
calledby
=
'chani'
)
ENDIF
ENDIF
endif
IF
(
iwork
(
1
)
.GT.
liwork
)
THEN
liwork
=
iwork
(
1
)
DEALLOCATE
(
iwork
)
...
...
@@ -351,18 +351,20 @@ endif
!
! Now solve generalized eigenvalue problem
!
if
(
hamovlp
%
l_real
)
THEN
CALL
CPP_LAPACK_pdsygvx
(
1
,
'V'
,
'I'
,
'U'
,
m
,
asca_r
,
1
,
1
,
desca
,
bsca_r
,
1
,
1
,
desca
,&
1.0
,
1.0
,
1
,
num
,
abstol
,
num1
,
num2
,
eig2
,
orfac
,
eigvec_r
,
1
,
1
,&
desceigv
,
work2_r
,
lwork2
,
iwork
,
liwork
,
ifail
,
iclustr
,&
gap
,
ierr
)
else
CALL
CPP_LAPACK_pzhegvx
(
1
,
'V'
,
'I'
,
'U'
,
m
,
asca_c
,
1
,
1
,
desca
,
bsca_c
,
1
,
1
,
desca
,&
1.0
,
1.0
,
1
,
num
,
abstol
,
num1
,
num2
,
eig2
,
orfac
,
eigvec_c
,
1
,
1
,&
desceigv
,
work2_c
,
lwork2
,
rwork
,
lrwork
,
iwork
,
liwork
,&
ifail
,
iclustr
,
gap
,
ierr
)
DEALLOCATE
(
rwork
)
endif
CALL
timestart
(
"SCALAPACK call"
)
if
(
hamovlp
%
l_real
)
THEN
CALL
CPP_LAPACK_pdsygvx
(
1
,
'V'
,
'I'
,
'U'
,
m
,
asca_r
,
1
,
1
,
desca
,
bsca_r
,
1
,
1
,
desca
,&
1.0
,
1.0
,
1
,
num
,
abstol
,
num1
,
num2
,
eig2
,
orfac
,
eigvec_r
,
1
,
1
,&
desceigv
,
work2_r
,
lwork2
,
iwork
,
liwork
,
ifail
,
iclustr
,&
gap
,
ierr
)
else
CALL
CPP_LAPACK_pzhegvx
(
1
,
'V'
,
'I'
,
'U'
,
m
,
asca_c
,
1
,
1
,
desca
,
bsca_c
,
1
,
1
,
desca
,&
1.0
,
1.0
,
1
,
num
,
abstol
,
num1
,
num2
,
eig2
,
orfac
,
eigvec_c
,
1
,
1
,&
desceigv
,
work2_c
,
lwork2
,
rwork
,
lrwork
,
iwork
,
liwork
,&
ifail
,
iclustr
,
gap
,
ierr
)
DEALLOCATE
(
rwork
)
endif
CALL
timestop
(
"SCALAPACK call"
)
IF
(
ierr
.NE.
0
)
THEN
IF
(
ierr
/
=
2
)
WRITE
(
6
,
*
)
myid
,
' error in pzhegvx/pdsygvx, ierr='
,
ierr
IF
(
ierr
<=
0
)
WRITE
(
6
,
*
)
myid
,
' illegal input argument'
...
...
@@ -426,7 +428,7 @@ endif
!
if
(
hamovlp
%
l_real
)
THEN
CALL
subredist2
(
m
,
num2
,
myrowssca
,
SUB_COMM
,
nprow
,
npcol
,
myid
,
ierr
,
nb
,
zmat
%
z_r
,
eigvec_r
)
ELSE
ELSE
CALL
subredist2
(
m
,
num2
,
myrowssca
,
SUB_COMM
,
nprow
,
npcol
,
myid
,
ierr
,
nb
,
achi_c
=
zmat
%
z_c
,
asca_c
=
eigvec_c
)
end
if
!
...
...
juDFT/stop.F90
View file @
5870ffa6
...
...
@@ -4,244 +4,232 @@
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------
MODULE
m_juDFT_stop
!-----------------------------------------------
! module to terminate Calculation, should be used instead
! of a simple STOP
!
! error(message,calledby,hint,no,warning)
! message : message string
! calledby : subroutine in which error occurs(optional)
! hint : string with more information (optional)
! no : error number (optional)
! warning : logical indicating a warning message (optional)
!
! warn(message,calledby,hint,no)
! shortcut for calling error with warning=.true.
!
! juDFT_end(message)
! call this to terminate without error
!
! IF the file "JUDFT_WARN_ONLY" is not present, warnings will lead to errors.
!
! If the file "JUDFT_TRACE" is present, a stacktrace will be generated
! on some compilers
!
!
! Daniel Wortmann (2010)
!-----------------------------------------------
USE
m_judft_time
IMPLICIT
NONE
PRIVATE
PUBLIC
juDFT_error
,
juDFT_warn
,
juDFT_end
,
judft_file_readable
,
print_memory_info
CONTAINS
SUBROUTINE
judfT_file_readable
(
filename
,
warning
)
IMPLICIT
NONE
CHARACTER
(
len
=*
),
INTENT
(
IN
)::
filename
LOGICAL
,
INTENT
(
IN
),
OPTIONAL
::
warning
LOGICAL
::
l_exist
INQUIRE
(
file
=
filename
,
exist
=
l_exist
)
IF
(
.not.
l_exist
)
CALL
judft_error
(
"File not readable:"
//
filename
,
hint
=
"FLEUR wants to read a file that is not present"
,
warning
=
warning
)
END
SUBROUTINE
judfT_file_readable
SUBROUTINE
juDFT_error
(
message
,
calledby
,
hint
,
no
,
warning
,
file
,
line
)
IMPLICIT
NONE
CHARACTER
*
(
*
),
INTENT
(
IN
)
::
message
CHARACTER
*
(
*
),
OPTIONAL
,
INTENT
(
IN
)
::
calledby
,
hint
INTEGER
,
OPTIONAL
,
INTENT
(
IN
)
::
no
LOGICAL
,
OPTIONAL
,
INTENT
(
IN
)
::
warning
CHARACTER
*
(
*
),
OPTIONAL
,
INTENT
(
IN
)
::
file
INTEGER
,
INTENT
(
IN
),
OPTIONAL
::
line
LOGICAL
::
callstop
,
warn
CHARACTER
(
LEN
=
4
)::
PE
!store all output in variable for single call to write in MPI case
CHARACTER
(
len
=
300
)::
text
(
10
)
INTEGER
::
linenr
,
n
MODULE
m_juDFT_stop
!-----------------------------------------------
! module to terminate Calculation, should be used instead
! of a simple STOP
!
! error(message,calledby,hint,no,warning)
! message : message string
! calledby : subroutine in which error occurs(optional)
! hint : string with more information (optional)
! no : error number (optional)
! warning : logical indicating a warning message (optional)
!
! warn(message,calledby,hint,no)
! shortcut for calling error with warning=.true.
!
! juDFT_end(message)
! call this to terminate without error
!
! IF the file "JUDFT_WARN_ONLY" is not present, warnings will lead to errors.
!
! If the file "JUDFT_TRACE" is present, a stacktrace will be generated
! on some compilers
!
!
! Daniel Wortmann (2010)
!-----------------------------------------------
USE
m_judft_time
USE
m_judft_sysinfo
IMPLICIT
NONE
PRIVATE
PUBLIC
juDFT_error
,
juDFT_warn
,
juDFT_end
,
judft_file_readable
CONTAINS
SUBROUTINE
judfT_file_readable
(
filename
,
warning
)
IMPLICIT
NONE
CHARACTER
(
len
=*
),
INTENT
(
IN
)::
filename
LOGICAL
,
INTENT
(
IN
),
OPTIONAL
::
warning
LOGICAL
::
l_exist
INQUIRE
(
file
=
filename
,
exist
=
l_exist
)
IF
(
.not.
l_exist
)
CALL
judft_error
(
"File not readable:"
//
filename
,
hint
=
"FLEUR wants to read a file that is not present"
,
warning
=
warning
)
END
SUBROUTINE
judfT_file_readable
SUBROUTINE
juDFT_error
(
message
,
calledby
,
hint
,
no
,
warning
,
file
,
line
)
IMPLICIT
NONE
CHARACTER
*
(
*
),
INTENT
(
IN
)
::
message
CHARACTER
*
(
*
),
OPTIONAL
,
INTENT
(
IN
)
::
calledby
,
hint
INTEGER
,
OPTIONAL
,
INTENT
(
IN
)
::
no
LOGICAL
,
OPTIONAL
,
INTENT
(
IN
)
::
warning
CHARACTER
*
(
*
),
OPTIONAL
,
INTENT
(
IN
)
::
file
INTEGER
,
INTENT
(
IN
),
OPTIONAL
::
line
LOGICAL
::
callstop
,
warn
CHARACTER
(
LEN
=
4
)::
PE
!store all output in variable for single call to write in MPI case
CHARACTER
(
len
=
300
)::
text
(
10
)
INTEGER
::
linenr
,
n
#ifdef CPP_MPI
include
'mpif.h'
INTEGER
::
irank
,
e
CALL
MPI_COMM_RANK
(
MPI_COMM_WORLD
,
irank
,
e
)
WRITE
(
PE
,
"(i4)"
)
irank
include
'mpif.h'
INTEGER
::
irank
,
e
CALL
MPI_COMM_RANK
(
MPI_COMM_WORLD
,
irank
,
e
)
WRITE
(
PE
,
"(i4)"
)
irank
#else
PE
=
"****"
PE
=
"****"
#endif
warn
=
.FALSE.
IF
(
PRESENT
(
warning
))
warn
=
warning
IF
(
warn
)
THEN
!check if we stop nevertheless
INQUIRE
(
FILE
=
"JUDFT_WARN_ONLY"
,
EXIST
=
callstop
)
callstop
=
.NOT.
callstop
ELSE
callstop
=
.TRUE.
ENDIF
IF
(
.NOT.
warn
)
THEN
WRITE
(
text
(
1
),
*
)
PE
,
"**************juDFT-Error*****************"
ELSE
WRITE
(
text
(
1
),
*
)
PE
,
"************juDFT-Warning*****************"
ENDIF
WRITE
(
text
(
2
),
"(3a)"
)
PE
,
"Error message:"
,
message
linenr
=
3
IF
(
PRESENT
(
calledby
))
THEN
WRITE
(
text
(
3
),
"(3a)"
)
PE
,
"Error occurred in subroutine:"
,
calledby
linenr
=
4
ENDIF
IF
(
PRESENT
(
hint
))
THEN
WRITE
(
text
(
linenr
),
"(3a)"
)
PE
,
"Hint:"
,
hint
linenr
=
linenr
+1
ENDIF
IF
(
PRESENT
(
no
))
THEN
WRITE
(
text
(
linenr
),
"(2a,i0)"
)
PE
,
"Error number:"
,
no
linenr
=
linenr
+1
ENDIF
IF
(
present
(
file
))
THEN
if
(
present
(
line
))
THEN
write
(
text
(
linenr
),
"(4a,i0)"
)
PE
,
"Source:"
,
file
,
":"
,
line
ELSE
write
(
text
(
linenr
),
"(3a)"
)
PE
,
"Source:"
,
file
ENDIF
warn
=
.FALSE.
IF
(
PRESENT
(
warning
))
warn
=
warning
IF
(
warn
)
THEN
!check if we stop nevertheless
INQUIRE
(
FILE
=
"JUDFT_WARN_ONLY"
,
EXIST
=
callstop
)
callstop
=
.NOT.
callstop
ELSE
callstop
=
.TRUE.
ENDIF
IF
(
.NOT.
warn
)
THEN
WRITE
(
text
(
1
),
*
)
PE
,
"**************juDFT-Error*****************"
ELSE
WRITE
(
text
(
1
),
*
)
PE
,
"************juDFT-Warning*****************"
ENDIF
WRITE
(
text
(
2
),
"(3a)"
)
PE
,
"Error message:"
,
message
linenr
=
3
IF
(
PRESENT
(
calledby
))
THEN
WRITE
(
text
(
3
),
"(3a)"
)
PE
,
"Error occurred in subroutine:"
,
calledby
linenr
=
4
ENDIF
IF
(
PRESENT
(
hint
))
THEN
WRITE
(
text
(
linenr
),
"(3a)"
)
PE
,
"Hint:"
,
hint
linenr
=
linenr
+1
ENDIF
IF
(
PRESENT
(
no
))
THEN
WRITE
(
text
(
linenr
),
"(2a,i0)"
)
PE
,
"Error number:"
,
no
linenr
=
linenr
+1
ENDIF
IF
(
present
(
file
))
THEN
if
(
present
(
line
))
THEN
write
(
text
(
linenr
),
"(4a,i0)"
)
PE
,
"Source:"
,
file
,
":"
,
line
ELSE
write
(
text
(
linenr
),
"(3a)"
)
PE
,
"Source:"
,
file
ENDIF
linenr
=
linenr
+1
ENDIF
WRITE
(
text
(
linenr
),
*
)
PE
,
"*****************************************"
if
(
.not.
warn
)
CALL
juDFT_time_lastlocation
(
PE
)
IF
(
callstop
)
THEN
IF
(
warn
)
THEN
linenr
=
linenr
+1
ENDIF
WRITE
(
text
(
linenr
),
*
)
PE
,
"*****************************************"
if
(
.not.
warn
)
CALL
juDFT_time_lastlocation
(
PE
)
IF
(
callstop
)
THEN
IF
(
warn
)
THEN
linenr
=
linenr
+1
WRITE
(
text
(
linenr
),
'(a)'
)
"Warnings not ignored. Touch 'JUDFT_WARN_ONLY' to make the warning nonfatal"
ENDIF
write
(
0
,
"(10(a,/))"
)
(
trim
(
text
(
n
)),
n
=
1
,
linenr
)
CALL
juDFT_STOP
()
ENDIF
write
(
0
,
"(10(a,/))"
)
(
trim
(
text
(
n
)),
n
=
1
,
linenr
)
END
SUBROUTINE
juDFT_error
SUBROUTINE
juDFT_warn
(
message
,
calledby
,
hint
,
no
,
file
,
line
)
IMPLICIT
NONE
CHARACTER
*
(
*
),
INTENT
(
IN
)
::
message
CHARACTER
*
(
*
),
OPTIONAL
,
INTENT
(
IN
)
::
calledby
,
hint
INTEGER
,
OPTIONAL
,
INTENT
(
IN
)
::
no
CHARACTER
*
(
*
),
OPTIONAL
,
INTENT
(
IN
)
::
file
INTEGER
,
INTENT
(
IN
),
OPTIONAL
::
line
CALL
juDFT_error
(
message
,
calledby
,
hint
,
no
,
warning
=
.TRUE.
,
file
=
file
,
line
=
line
)
END
SUBROUTINE
juDFT_warn
SUBROUTINE
juDFT_END
(
message
,
irank
,
l_endXML
)
! If irank is present every mpi process has to call this routine.
! Otherwise only a single mpi process is allowed to call the routine.
USE
m_xmlOutput
IMPLICIT
NONE
WRITE
(
text
(
linenr
),
'(a)'
)
"Warnings not ignored. Touch 'JUDFT_WARN_ONLY' to make the warning nonfatal"
ENDIF
write
(
0
,
"(10(a,/))"
)
(
trim
(
text
(
n
)),
n
=
1
,
linenr
)
CALL
juDFT_STOP
()
ENDIF
write
(
0
,
"(10(a,/))"
)
(
trim
(
text
(
n
)),
n
=
1
,
linenr
)
END
SUBROUTINE
juDFT_error
SUBROUTINE
juDFT_warn
(
message
,
calledby
,
hint
,
no
,
file
,
line
)
IMPLICIT
NONE
CHARACTER
*
(
*
),
INTENT
(
IN
)
::
message
CHARACTER
*
(
*
),
OPTIONAL
,
INTENT
(
IN
)
::
calledby
,
hint
INTEGER
,
OPTIONAL
,
INTENT
(
IN
)
::
no
CHARACTER
*
(
*
),
OPTIONAL
,
INTENT
(
IN
)
::
file
INTEGER
,
INTENT
(
IN
),
OPTIONAL
::
line
CALL
juDFT_error
(
message
,
calledby
,
hint
,
no
,
warning
=
.TRUE.
,
file
=
file
,
line
=
line
)
END
SUBROUTINE
juDFT_warn
SUBROUTINE
juDFT_END
(
message
,
irank
,
l_endXML
)
! If irank is present every mpi process has to call this routine.
! Otherwise only a single mpi process is allowed to call the routine.
USE
m_xmlOutput
IMPLICIT
NONE
#ifdef CPP_MPI
INCLUDE
'mpif.h'
INTEGER
::
ierr
INCLUDE
'mpif.h'
INTEGER
::
ierr
#endif
CHARACTER
*
(
*
),
INTENT
(
IN
)
::
message
INTEGER
,
OPTIONAL
,
INTENT
(
IN
)
::
irank
LOGICAL
,
OPTIONAL
,
INTENT
(
IN
)
::
l_endXML
LOGICAL
l_endXML_local
l_endXML_local
=
.TRUE.
IF
(
PRESENT
(
l_endXML
))
THEN
l_endXML_local
=
l_endXML
END
IF
IF
(
l_endXML_local
)
THEN
IF
(
PRESENT
(
irank
))
THEN
IF
(
irank
.EQ.
0
)
CALL
endXMLOutput
()
ELSE
! It is assumed that this is the only mpi process calling this routine.
CALL
endXMLOutput
()
END
IF
END
IF
WRITE
(
0
,
*
)
"*****************************************"
WRITE
(
0
,
*
)
"Run finished successfully"
WRITE
(
0
,
*
)
"Stop message:"
WRITE
(
0
,
*
)
" "
,
message
WRITE
(
0
,
*
)
"*****************************************"
CALL
writetimes
()
CALL
print_memory_info
()
CHARACTER
*
(
*
),
INTENT
(
IN
)
::
message
INTEGER
,
OPTIONAL
,
INTENT
(
IN
)
::
irank
LOGICAL
,
OPTIONAL
,
INTENT
(
IN
)
::
l_endXML
LOGICAL
l_endXML_local
l_endXML_local
=
.TRUE.
IF
(
PRESENT
(
l_endXML
))
THEN
l_endXML_local
=
l_endXML
END
IF
IF
(
l_endXML_local
)
THEN
IF
(
PRESENT
(
irank
))
THEN
IF
(
irank
.EQ.
0
)
CALL
endXMLOutput
()
ELSE
! It is assumed that this is the only mpi process calling this routine.
CALL
endXMLOutput
()
END
IF
END
IF
WRITE
(
0
,
*
)
"*****************************************"
WRITE
(
0
,
*
)
"Run finished successfully"
WRITE
(
0
,
*
)
"Stop message:"
WRITE
(
0
,
*
)
" "
,
message
WRITE
(
0
,
*
)
"*****************************************"
CALL
writetimes
()
CALL
print_memory_info
()
#ifdef CPP_MPI
IF
(
PRESENT
(
irank
))
THEN
CALL
MPI_BARRIER
(
MPI_COMM_WORLD
,
ierr
)
CALL
MPI_FINALIZE
(
ierr
)
ELSE
CALL
juDFT_STOP
(
0
)
END
IF
IF
(
PRESENT
(
irank
))
THEN
CALL
MPI_BARRIER
(
MPI_COMM_WORLD
,
ierr
)
CALL
MPI_FINALIZE
(
ierr
)
ELSE
CALL
juDFT_STOP
(
0
)
END
IF
#endif
STOP
'OK'
END
SUBROUTINE
juDFT_END
STOP
'OK'
END
SUBROUTINE
juDFT_END
!this is a private subroutine that stops the calculations
!different compilers might have to be added here
SUBROUTINE
juDFT_stop
(
errorCode
)
!this is a private subroutine that stops the calculations
!different compilers might have to be added here
SUBROUTINE
juDFT_stop
(
errorCode
)
#ifdef __INTEL_COMPILER
USE
ifcore
USE
ifcore
#endif
#ifdef CPP_MPI
INCLUDE
'mpif.h'
INCLUDE
'mpif.h'
#endif
INTEGER
,
OPTIONAL
,
INTENT
(
IN
)
::
errorCode
INTEGER
::
error
LOGICAL
::
calltrace
LOGICAL
,
ALLOCATABLE
::
a
(:)
INTEGER
,
OPTIONAL
,
INTENT
(
IN
)
::
errorCode
INTEGER
::
error
LOGICAL
::
calltrace
LOGICAL
,
ALLOCATABLE
::
a
(:)
#ifdef CPP_MPI
INTEGER
::
ierr
INTEGER
::
ierr
#endif
error
=
0
IF
(
PRESENT
(
errorCode
))
THEN
error
=
errorCode
END
IF
!try to print times
call
writelocation
()
CALL
writetimes
(
.TRUE.
)
CALL
print_memory_info
()
INQUIRE
(
FILE
=
"JUDFT_TRACE"
,
EXIST
=
calltrace
)
IF
(
error
.EQ.
1
)
calltrace
=
.TRUE.
IF
(
calltrace
)
THEN
error
=
0
IF
(
PRESENT
(
errorCode
))
THEN
error
=
errorCode
END
IF
!try to print times
call
writelocation
()
CALL
writetimes
(
.TRUE.
)
CALL
print_memory_info
()
INQUIRE
(
FILE
=
"JUDFT_TRACE"
,
EXIST
=
calltrace
)
IF
(
error
.EQ.
1
)
calltrace
=
.TRUE.
IF
(
calltrace
)
THEN
#ifdef __INTEL_COMPILER
CALL
tracebackqq
(
USER_EXIT_CODE
=
-1
)
!return after traceback
CALL
tracebackqq
(
USER_EXIT_CODE
=
-1
)
!return after traceback
#elif (defined(CPP_AIX)&&!defined(__PGI))
CALL
xl__trbk
()
CALL
xl__trbk
()
#endif
DEALLOCATE
(
a
)
!will generate an error that can be found by the compiler
ENDIF
DEALLOCATE
(
a
)
!will generate an error that can be found by the compiler
ENDIF
#if defined(CPP_MPI)
IF
(
error
.EQ.
0
)
THEN
WRITE
(
0
,
*
)
""
WRITE
(
0
,
*
)
"Terminating all MPI processes."
WRITE
(
0
,
*
)
"Note: This is a normal procedure."
WRITE
(
0
,
*
)
" Error messages in the following lines can be ignored."
WRITE
(
0
,
*
)
""
END
IF
CALL
MPI_ABORT
(
MPI_COMM_WORLD
,
error
,
ierr
)
IF
(
error
.EQ.
0
)
THEN
WRITE
(
0
,
*
)
""
WRITE
(
0
,
*
)
"Terminating all MPI processes."
WRITE
(
0
,
*
)
"Note: This is a normal procedure."
WRITE
(
0
,
*
)
" Error messages in the following lines can be ignored."
WRITE
(
0
,
*
)
""
END
IF
CALL
MPI_ABORT
(
MPI_COMM_WORLD
,
error
,
ierr
)
#endif
STOP
'juDFT-STOPPED'
END
SUBROUTINE
juDFT_stop
STOP
'juDFT-STOPPED'
END
SUBROUTINE
juDFT_stop
SUBROUTINE
print_memory_info
()
IMPLICIT
NONE
CHARACTER
(
LEN
=
1024
)::
line