Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2026 CP2K developers group <https://cp2k.org> !
4 : ! !
5 : ! SPDX-License-Identifier: GPL-2.0-or-later !
6 : !--------------------------------------------------------------------------------------------------!
7 :
8 : ! **************************************************************************************************
9 : !> \brief Module that contains the routines for error handling
10 : !> \author Ole Schuett
11 : ! **************************************************************************************************
12 : MODULE cp_error_handling
13 : USE base_hooks, ONLY: cp_abort_hook,&
14 : cp_hint_hook,&
15 : cp_warn_hook
16 : USE cp_log_handling, ONLY: cp_logger_get_default_io_unit
17 : USE kinds, ONLY: dp
18 : USE machine, ONLY: default_output_unit,&
19 : m_flush,&
20 : m_walltime
21 : USE message_passing, ONLY: mp_abort
22 : USE print_messages, ONLY: print_message
23 : USE timings, ONLY: print_stack
24 :
25 : !$ USE OMP_LIB, ONLY: omp_get_thread_num
26 :
27 : IMPLICIT NONE
28 : PRIVATE
29 :
30 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'cp_error_handling'
31 :
32 : !API public routines
33 : PUBLIC :: cp_error_handling_setup
34 :
35 : !API (via pointer assignment to hook, PR67982, not meant to be called directly)
36 : PUBLIC :: cp_abort_handler, cp_warn_handler, cp_hint_handler
37 :
38 : INTEGER, PUBLIC, SAVE :: warning_counter = 0
39 :
40 : CONTAINS
41 :
42 : ! **************************************************************************************************
43 : !> \brief Registers handlers with base_hooks.F
44 : !> \author Ole Schuett
45 : ! **************************************************************************************************
46 10486 : SUBROUTINE cp_error_handling_setup()
47 10486 : cp_abort_hook => cp_abort_handler
48 10486 : cp_warn_hook => cp_warn_handler
49 10486 : cp_hint_hook => cp_hint_handler
50 10486 : END SUBROUTINE cp_error_handling_setup
51 :
52 : ! **************************************************************************************************
53 : !> \brief Abort program with error message
54 : !> \param location ...
55 : !> \param message ...
56 : !> \author Ole Schuett
57 : ! **************************************************************************************************
58 0 : SUBROUTINE cp_abort_handler(location, message)
59 : CHARACTER(len=*), INTENT(in) :: location, message
60 :
61 : INTEGER :: unit_nr
62 :
63 0 : CALL delay_non_master() ! cleaner output if all ranks abort simultaneously
64 :
65 0 : unit_nr = cp_logger_get_default_io_unit()
66 0 : IF (unit_nr <= 0) THEN
67 0 : unit_nr = default_output_unit
68 : END IF ! fall back to stdout
69 :
70 0 : CALL print_abort_message(message, location, unit_nr)
71 0 : CALL print_stack(unit_nr)
72 0 : FLUSH (unit_nr) ! ignore &GLOBAL / FLUSH_SHOULD_FLUSH
73 :
74 0 : CALL mp_abort()
75 0 : END SUBROUTINE cp_abort_handler
76 :
77 : ! **************************************************************************************************
78 : !> \brief Signal a warning
79 : !> \param location ...
80 : !> \param message ...
81 : !> \author Ole Schuett
82 : ! **************************************************************************************************
83 27853 : SUBROUTINE cp_warn_handler(location, message)
84 : CHARACTER(len=*), INTENT(in) :: location, message
85 :
86 : INTEGER :: unit_nr
87 :
88 27853 : !$OMP MASTER
89 27853 : warning_counter = warning_counter + 1
90 : !$OMP END MASTER
91 :
92 27853 : unit_nr = cp_logger_get_default_io_unit()
93 27853 : IF (unit_nr > 0) THEN
94 18913 : CALL print_message("WARNING in "//TRIM(location)//' :: '//TRIM(ADJUSTL(message)), unit_nr, 1, 1, 1)
95 18913 : CALL m_flush(unit_nr)
96 : END IF
97 27853 : END SUBROUTINE cp_warn_handler
98 :
99 : ! **************************************************************************************************
100 : !> \brief Signal a hint
101 : !> \param location ...
102 : !> \param message ...
103 : !> \author Ole Schuett
104 : ! **************************************************************************************************
105 59 : SUBROUTINE cp_hint_handler(location, message)
106 : CHARACTER(len=*), INTENT(in) :: location, message
107 :
108 : INTEGER :: unit_nr
109 :
110 118 : unit_nr = cp_logger_get_default_io_unit()
111 59 : IF (unit_nr > 0) THEN
112 31 : CALL print_message("HINT in "//TRIM(location)//' :: '//TRIM(ADJUSTL(message)), unit_nr, 1, 1, 1)
113 31 : CALL m_flush(unit_nr)
114 : END IF
115 59 : END SUBROUTINE cp_hint_handler
116 :
117 : ! **************************************************************************************************
118 : !> \brief Delay non-master ranks/threads, used by cp_abort_handler()
119 : !> \author Ole Schuett
120 : ! **************************************************************************************************
121 0 : SUBROUTINE delay_non_master()
122 : INTEGER :: unit_nr
123 : REAL(KIND=dp) :: t1, wait_time
124 :
125 0 : wait_time = 0.0_dp
126 :
127 : ! we (ab)use the logger to determine the first MPI rank
128 0 : unit_nr = cp_logger_get_default_io_unit()
129 0 : IF (unit_nr <= 0) THEN
130 0 : wait_time = wait_time + 1.0_dp
131 : END IF ! rank-0 gets a head start of one second.
132 :
133 0 : !$ IF (omp_get_thread_num() /= 0) &
134 0 : !$ wait_time = wait_time + 1.0_dp ! master threads gets another second
135 :
136 : ! sleep
137 0 : IF (wait_time > 0.0_dp) THEN
138 0 : t1 = m_walltime()
139 : DO
140 0 : IF (m_walltime() - t1 > wait_time .OR. t1 < 0) EXIT
141 : END DO
142 : END IF
143 :
144 0 : END SUBROUTINE delay_non_master
145 :
146 : ! **************************************************************************************************
147 : !> \brief Prints a nicely formatted abort message box
148 : !> \param message ...
149 : !> \param location ...
150 : !> \param output_unit ...
151 : !> \author Ole Schuett
152 : ! **************************************************************************************************
153 0 : SUBROUTINE print_abort_message(message, location, output_unit)
154 : CHARACTER(LEN=*), INTENT(IN) :: message, location
155 : INTEGER, INTENT(IN) :: output_unit
156 :
157 : INTEGER, PARAMETER :: img_height = 8, img_width = 9, screen_width = 80, &
158 : txt_width = screen_width - img_width - 5
159 : CHARACTER(LEN=img_width), DIMENSION(img_height), PARAMETER :: img = [" ___ ", " / \ "&
160 : , " [ABORT] ", " \___/ ", " | ", " O/| ", " /| | ", " / \ "]
161 :
162 : CHARACTER(LEN=screen_width) :: msg_line
163 : INTEGER :: a, b, c, fill, i, img_start, indent, &
164 : msg_height, msg_start
165 :
166 : ! count message lines
167 :
168 0 : a = 1; b = -1; msg_height = 0
169 0 : DO WHILE (b < LEN_TRIM(message))
170 0 : b = next_linebreak(message, a, txt_width)
171 0 : a = b + 1
172 0 : msg_height = msg_height + 1
173 : END DO
174 :
175 : ! calculate message and image starting lines
176 0 : IF (img_height > msg_height) THEN
177 0 : msg_start = (img_height - msg_height)/2 + 1
178 0 : img_start = 1
179 : ELSE
180 0 : msg_start = 1
181 0 : img_start = msg_height - img_height + 2
182 : END IF
183 :
184 : ! print empty line
185 0 : WRITE (UNIT=output_unit, FMT="(A)") ""
186 :
187 : ! print opening line
188 0 : WRITE (UNIT=output_unit, FMT="(T2,A)") REPEAT("*", screen_width - 1)
189 :
190 : ! print body
191 0 : a = 1; b = -1; c = 1
192 0 : DO i = 1, MAX(img_height - 1, msg_height)
193 0 : WRITE (UNIT=output_unit, FMT="(A)", advance='no') " *"
194 0 : IF (i < img_start) THEN
195 0 : WRITE (UNIT=output_unit, FMT="(A)", advance='no') REPEAT(" ", img_width)
196 : ELSE
197 0 : WRITE (UNIT=output_unit, FMT="(A)", advance='no') img(c)
198 0 : c = c + 1
199 : END IF
200 0 : IF (i < msg_start) THEN
201 0 : WRITE (UNIT=output_unit, FMT="(A)", advance='no') REPEAT(" ", txt_width + 2)
202 : ELSE
203 0 : b = next_linebreak(message, a, txt_width)
204 0 : msg_line = message(a:b)
205 0 : a = b + 1
206 0 : fill = (txt_width - LEN_TRIM(msg_line))/2 + 1
207 0 : indent = txt_width - LEN_TRIM(msg_line) - fill + 2
208 0 : WRITE (UNIT=output_unit, FMT="(A)", advance='no') REPEAT(" ", indent)
209 0 : WRITE (UNIT=output_unit, FMT="(A)", advance='no') TRIM(msg_line)
210 0 : WRITE (UNIT=output_unit, FMT="(A)", advance='no') REPEAT(" ", fill)
211 : END IF
212 0 : WRITE (UNIT=output_unit, FMT="(A)", advance='yes') "*"
213 : END DO
214 :
215 : ! print location line
216 0 : WRITE (UNIT=output_unit, FMT="(A)", advance='no') " *"
217 0 : WRITE (UNIT=output_unit, FMT="(A)", advance='no') img(c)
218 0 : indent = txt_width - LEN_TRIM(location) + 1
219 0 : WRITE (UNIT=output_unit, FMT="(A)", advance='no') REPEAT(" ", indent)
220 0 : WRITE (UNIT=output_unit, FMT="(A)", advance='no') TRIM(location)
221 0 : WRITE (UNIT=output_unit, FMT="(A)", advance='yes') " *"
222 :
223 : ! print closing line
224 0 : WRITE (UNIT=output_unit, FMT="(T2,A)") REPEAT("*", screen_width - 1)
225 :
226 : ! print empty line
227 0 : WRITE (UNIT=output_unit, FMT="(A)") ""
228 :
229 0 : END SUBROUTINE print_abort_message
230 :
231 : ! **************************************************************************************************
232 : !> \brief Helper routine for print_abort_message()
233 : !> \param message ...
234 : !> \param pos ...
235 : !> \param rowlen ...
236 : !> \return ...
237 : !> \author Ole Schuett
238 : ! **************************************************************************************************
239 0 : FUNCTION next_linebreak(message, pos, rowlen) RESULT(ibreak)
240 : CHARACTER(LEN=*), INTENT(IN) :: message
241 : INTEGER, INTENT(IN) :: pos, rowlen
242 : INTEGER :: ibreak
243 :
244 : INTEGER :: i, n
245 :
246 0 : n = LEN_TRIM(message)
247 0 : IF (n - pos <= rowlen) THEN
248 : ibreak = n ! remaining message shorter than line
249 : ELSE
250 0 : i = INDEX(message(pos + 1:pos + 1 + rowlen), " ", BACK=.TRUE.)
251 0 : IF (i == 0) THEN
252 0 : ibreak = pos + rowlen - 1 ! no space found, break mid-word
253 : ELSE
254 0 : ibreak = pos + i ! break at space closest to rowlen
255 : END IF
256 : END IF
257 0 : END FUNCTION next_linebreak
258 :
259 : END MODULE cp_error_handling
|
