stop.F90 6.93 KB
Newer Older
1
2
3
4
5
6
!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
      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
      CONTAINS


      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
#else
      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
          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

126
      SUBROUTINE juDFT_END(message, irank)
127
128
      ! If irank is present every mpi process has to call this routine.
      ! Otherwise only a single mpi process is allowed to call the routine.
129
      USE m_xmlOutput
130
131
132
133
134
      IMPLICIT NONE
#ifdef CPP_MPI
      INCLUDE 'mpif.h'
      INTEGER :: ierr
#endif
135
136
      CHARACTER*(*), INTENT(IN)      :: message
      INTEGER, OPTIONAL, INTENT(IN)  :: irank
137

138
139
140
141
142
143
      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
144
145
146
147
148
149

      WRITE(0,*) "*****************************************"
      WRITE(0,*) "Run finished successfully"
      WRITE(0,*) "Stop message:"
      WRITE(0,*) "  ",message
      WRITE(0,*) "*****************************************"
150
151
      CALL writetimes()
      CALL priv_memory_info()
152
#ifdef CPP_MPI
153
154
155
156
      IF(PRESENT(irank)) THEN
         CALL MPI_BARRIER(MPI_COMM_WORLD,ierr)
         CALL MPI_FINALIZE(ierr)
      END IF
157
#endif
158
      CALL juDFT_STOP(0)
159
160
161
162
163
      STOP 'OK'
      END SUBROUTINE juDFT_END

      !this is a private subroutine that stops the calculations
      !different compilers might have to be added here
164
      SUBROUTINE juDFT_stop(errorCode)
165
166
167
168
169
170
#ifdef __INTEL_COMPILER
      USE ifcore
#endif
#ifdef CPP_MPI
      INCLUDE 'mpif.h'
#endif
171
172
      INTEGER, OPTIONAL, INTENT(IN)  :: errorCode
      INTEGER :: error
173
      LOGICAL :: calltrace
174
175
176
177
178
179
180
181
#ifdef CPP_MPI
      INTEGER :: ierr
#endif
      error = 1

      IF(PRESENT(errorCode)) THEN
         error = errorCode
      END IF
182
183
184
185
186
187
188
189
190
191
192
193
194
      !try to print times
      !call writelocation()
      !CALL writetimes(.true.)
      INQUIRE(FILE="JUDFT_TRACE",EXIST=calltrace)
      IF (calltrace) THEN
#ifdef __INTEL_COMPILER
         CALL tracebackqq(USER_EXIT_CODE=-1) !return after traceback
#elif (defined(CPP_AIX)&&!defined(__PGI))
         CALL xl__trbk()
#endif
      ENDIF

#if defined(CPP_MPI)
195
196
197
198
199
200
201
202
      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)
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
#endif
      STOP 'juDFT-STOPPED'
      END SUBROUTINE juDFT_stop

      SUBROUTINE priv_memory_info()
      IMPLICIT NONE

      CHARACTER(LEN=1024):: line
      INTEGER            :: err
      OPEN(99,FILE="/proc/self/status",ERR=999)
      DO
         READ(99,"(a)",ERR=999,END=999) line
         WRITE(6,*) trim(line)
      ENDDO
 999  CLOSE(99,IOSTAT=err)
      END SUBROUTINE priv_memory_info


      END MODULE m_juDFT_stop