1!
2! Copyright (C) Quantum ESPRESSO group
3!
4! This file is distributed under the terms of the
5! GNU General Public License. See the file `License'
6! in the root directory of the present distribution,
7! or http://www.gnu.org/copyleft/gpl.txt .
8!
9!----------------------------------------------------------------------------
10SUBROUTINE errore( calling_routine, message, ierr )
11  !----------------------------------------------------------------------------
12  !
13  ! ... This is a simple routine which writes an error message to output:
14  ! ... if ierr <= 0 it does nothing,
15  ! ... if ierr  > 0 it stops.
16  !
17  ! ...          **** Important note for parallel execution ***
18  !
19  ! ... in parallel execution unit 6 is written only by the first node;
20  ! ... all other nodes have unit 6 redirected to nothing (/dev/null).
21  ! ... As a consequence an error not occurring on the first node
22  ! ... will be invisible. For T3E and ORIGIN machines, this problem
23  ! ... is solved by writing an error message to unit * instead of 6.
24  ! ... Whenever possible (IBM SP machines), we write to the standard
25  ! ... error, unit 0 (the message will appear in the error files
26  ! ... produced by loadleveler).
27  !
28  USE util_param
29#if defined(__PTRACE) && defined(__INTEL_COMPILER)
30  USE ifcore,    ONLY : tracebackqq
31#endif
32  USE mp,        ONLY : mp_abort, mp_rank
33  IMPLICIT NONE
34  !
35  CHARACTER(LEN=*), INTENT(IN) :: calling_routine, message
36    ! the name of the calling calling_routine
37    ! the output message
38  INTEGER,          INTENT(IN) :: ierr
39    ! the error flag
40  INTEGER :: crashunit, mpime
41  INTEGER, EXTERNAL :: find_free_unit
42  CHARACTER(LEN=6) :: cerr
43  !
44  IF( ierr <= 0 ) RETURN
45  !
46  ! ... the error message is written un the "*" unit
47  !
48  WRITE( cerr, FMT = '(I6)' ) ierr
49  WRITE( UNIT = *, FMT = '(/,1X,78("%"))' )
50  WRITE( UNIT = *, FMT = '(5X,"Error in routine ",A," (",A,"):")' ) &
51        TRIM(calling_routine), TRIM(ADJUSTL(cerr))
52  WRITE( UNIT = *, FMT = '(5X,A)' ) TRIM(message)
53  WRITE( UNIT = *, FMT = '(1X,78("%"),/)' )
54  !
55#if defined (__MPI) && defined (__AIX)
56  !
57  ! ... in the case of ibm machines it is also written on the "0" unit
58  ! ... which is automatically connected to stderr
59  !
60  WRITE( UNIT = 0, FMT = '(/,1X,78("%"))')
61  WRITE( UNIT = 0, FMT = '(5X,"Error in routine ",A," (",A,"):")' ) &
62        TRIM(calling_routine), TRIM(ADJUSTL(cerr))
63  WRITE( UNIT = 0, FMT = '(5X,A)' ) TRIM(message)
64  WRITE( UNIT = 0, FMT = '(1X,78("%"),/)' )
65  !
66#endif
67  !
68  WRITE( *, '("     stopping ...")' )
69  !
70  FLUSH( stdout )
71  !
72#if defined(__PTRACE)
73#if defined(__INTEL_COMPILER)
74    call tracebackqq(user_exit_code=-1)
75#elif __GFORTRAN__
76#if (__GNUC__>4) || ((__GNUC__==4) && (__GNUC_MINOR__>=8))
77    call backtrace
78#endif
79#else
80    WRITE( UNIT = 0, FMT = '(5X,A)' ) "Printing strace..."
81    CALL ptrace()
82#endif
83#endif
84!
85#if defined(__MPI)
86  !
87  mpime = mp_rank(MPI_COMM_WORLD)
88  !
89  !  .. write the message to a file and close it before exiting
90  !  .. this will prevent loss of information on systems that
91  !  .. do not flush the open streams
92  !  .. added by C.C.
93  !
94  crashunit = find_free_unit ()
95  OPEN( UNIT = crashunit, FILE = crash_file, &
96        POSITION = 'APPEND', STATUS = 'UNKNOWN' )
97  !
98  WRITE( UNIT = crashunit, FMT = '(/,1X,78("%"))' )
99  WRITE( UNIT = crashunit, FMT = '(5X,"task #",I10)' ) mpime
100  WRITE( UNIT = crashunit, &
101         FMT = '(5X,"from ",A," : error #",I10)' ) calling_routine, ierr
102  WRITE( UNIT = crashunit, FMT = '(5X,A)' ) message
103  WRITE( UNIT = crashunit, FMT = '(1X,78("%"),/)' )
104  !
105  CLOSE( UNIT = crashunit )
106  !
107  ! ... try to exit in a smooth way
108  !
109  CALL mp_abort(1,MPI_COMM_WORLD)
110  !
111#endif
112  !
113  STOP 1
114  !
115  RETURN
116  !
117END SUBROUTINE errore
118!
119!----------------------------------------------------------------------
120SUBROUTINE infomsg( routine, message )
121  !----------------------------------------------------------------------
122  !
123  ! ... This is a simple routine which writes an info message
124  ! ... from a given routine to output.
125  !
126  USE util_param
127  !
128  IMPLICIT NONE
129  !
130  CHARACTER (LEN=*) :: routine, message
131  ! the name of the calling routine
132  ! the output message
133  !
134!  IF ( ionode ) THEN   !if not ionode it is redirected to /dev/null anyway
135     !
136     WRITE( stdout , '(5X,"Message from routine ",A,":")' ) routine
137     WRITE( stdout , '(5X,A)' ) message
138     !
139!  END IF
140  !
141  RETURN
142  !
143END SUBROUTINE infomsg
144!
145module error_handler
146  implicit none
147  private
148
149  public :: init_error, add_name, chop_name, error_mem, warning
150
151  type chain
152   character (len=35)   :: routine_name
153   type(chain), pointer :: previous_link
154  end type chain
155
156  type(chain), pointer :: routine_chain
157
158contains
159
160  subroutine init_error(routine_name)
161    implicit none
162    character (len=*), intent(in) :: routine_name
163
164    allocate(routine_chain)
165
166    routine_chain%routine_name  =  routine_name
167    nullify(routine_chain%previous_link)
168
169    return
170  end subroutine init_error
171
172  subroutine add_name(routine_name)
173    implicit none
174    character (len=*), intent(in) :: routine_name
175    type(chain), pointer          :: new_link
176
177    allocate(new_link)
178    new_link%routine_name  =  routine_name
179    new_link%previous_link => routine_chain
180    routine_chain          => new_link
181
182    return
183  end subroutine add_name
184
185  subroutine chop_name
186    implicit none
187    type(chain), pointer :: chopped_chain
188
189    chopped_chain => routine_chain%previous_link
190    deallocate(routine_chain)
191    routine_chain => chopped_chain
192
193    return
194  end subroutine chop_name
195
196  recursive subroutine trace_back(error_code)
197
198    implicit none
199    integer :: error_code
200
201    write(unit=*,fmt=*) "   Called by ", routine_chain%routine_name
202    if (.not.associated(routine_chain%previous_link)) then
203       write(unit=*,fmt=*) &
204            " +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++"
205       write(unit=*,fmt=*) " "
206       if( error_code > 0 ) then
207          stop
208       else
209          return
210       end if
211    end if
212
213    routine_chain => routine_chain%previous_link
214    call trace_back(error_code)
215
216  end subroutine trace_back
217
218  subroutine error_mem(message,error_code)
219    character (len=*), intent(in) :: message
220    integer, intent(in), optional :: error_code
221    integer                       :: action_code
222    type(chain), pointer          :: save_chain
223
224    if (present(error_code)) then
225       action_code = error_code
226    else
227       action_code = 1
228    end if
229
230    if( action_code /= 0 ) then
231       write(unit=*,fmt=*) " "
232       write(unit=*,fmt=*) &
233            " +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++"
234
235       if( action_code > 0 ) then
236          write(unit=*,fmt=*) "   Fatal error in routine `", &
237               trim(routine_chain%routine_name),"': ",message
238       else
239          write(unit=*,fmt=*) "   Warning from routine `", &
240               trim(routine_chain%routine_name),"': ",message
241          save_chain => routine_chain
242       end if
243       write(unit=*,fmt=*) &
244            " +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++"
245       routine_chain => routine_chain%previous_link
246       call trace_back(action_code)
247       routine_chain => save_chain
248    end if
249
250    return
251  end subroutine error_mem
252
253  subroutine warning(message)
254    character (len=*), intent(in) :: message
255    call error_mem(message,-1)
256    return
257  end subroutine warning
258
259end module error_handler
260