Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2025 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 9284 : SUBROUTINE cp_error_handling_setup()
47 9284 : cp_abort_hook => cp_abort_handler
48 9284 : cp_warn_hook => cp_warn_handler
49 9284 : cp_hint_hook => cp_hint_handler
50 9284 : 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) &
67 0 : unit_nr = default_output_unit ! fall back to stdout
68 :
69 0 : CALL print_abort_message(message, location, unit_nr)
70 0 : CALL print_stack(unit_nr)
71 0 : FLUSH (unit_nr) ! ignore &GLOBAL / FLUSH_SHOULD_FLUSH
72 :
73 0 : CALL mp_abort()
74 0 : END SUBROUTINE cp_abort_handler
75 :
76 : ! **************************************************************************************************
77 : !> \brief Signal a warning
78 : !> \param location ...
79 : !> \param message ...
80 : !> \author Ole Schuett
81 : ! **************************************************************************************************
82 25226 : SUBROUTINE cp_warn_handler(location, message)
83 : CHARACTER(len=*), INTENT(in) :: location, message
84 :
85 : INTEGER :: unit_nr
86 :
87 25226 : !$OMP MASTER
88 25226 : warning_counter = warning_counter + 1
89 : !$OMP END MASTER
90 :
91 25226 : unit_nr = cp_logger_get_default_io_unit()
92 25226 : IF (unit_nr > 0) THEN
93 17271 : CALL print_message("WARNING in "//TRIM(location)//' :: '//TRIM(ADJUSTL(message)), unit_nr, 1, 1, 1)
94 17271 : CALL m_flush(unit_nr)
95 : END IF
96 25226 : END SUBROUTINE cp_warn_handler
97 :
98 : ! **************************************************************************************************
99 : !> \brief Signal a hint
100 : !> \param location ...
101 : !> \param message ...
102 : !> \author Ole Schuett
103 : ! **************************************************************************************************
104 59 : SUBROUTINE cp_hint_handler(location, message)
105 : CHARACTER(len=*), INTENT(in) :: location, message
106 :
107 : INTEGER :: unit_nr
108 :
109 118 : unit_nr = cp_logger_get_default_io_unit()
110 59 : IF (unit_nr > 0) THEN
111 31 : CALL print_message("HINT in "//TRIM(location)//' :: '//TRIM(ADJUSTL(message)), unit_nr, 1, 1, 1)
112 31 : CALL m_flush(unit_nr)
113 : END IF
114 59 : END SUBROUTINE cp_hint_handler
115 :
116 : ! **************************************************************************************************
117 : !> \brief Delay non-master ranks/threads, used by cp_abort_handler()
118 : !> \author Ole Schuett
119 : ! **************************************************************************************************
120 0 : SUBROUTINE delay_non_master()
121 : INTEGER :: unit_nr
122 : REAL(KIND=dp) :: t1, wait_time
123 :
124 0 : wait_time = 0.0_dp
125 :
126 : ! we (ab)use the logger to determine the first MPI rank
127 0 : unit_nr = cp_logger_get_default_io_unit()
128 0 : IF (unit_nr <= 0) &
129 0 : wait_time = wait_time + 1.0_dp ! rank-0 gets a head start of one second.
130 :
131 0 : !$ IF (omp_get_thread_num() /= 0) &
132 0 : !$ wait_time = wait_time + 1.0_dp ! master threads gets another second
133 :
134 : ! sleep
135 0 : IF (wait_time > 0.0_dp) THEN
136 0 : t1 = m_walltime()
137 : DO
138 0 : IF (m_walltime() - t1 > wait_time .OR. t1 < 0) EXIT
139 : END DO
140 : END IF
141 :
142 0 : END SUBROUTINE delay_non_master
143 :
144 : ! **************************************************************************************************
145 : !> \brief Prints a nicely formatted abort message box
146 : !> \param message ...
147 : !> \param location ...
148 : !> \param output_unit ...
149 : !> \author Ole Schuett
150 : ! **************************************************************************************************
151 0 : SUBROUTINE print_abort_message(message, location, output_unit)
152 : CHARACTER(LEN=*), INTENT(IN) :: message, location
153 : INTEGER, INTENT(IN) :: output_unit
154 :
155 : INTEGER, PARAMETER :: img_height = 8, img_width = 9, screen_width = 80, &
156 : txt_width = screen_width - img_width - 5
157 : CHARACTER(LEN=img_width), DIMENSION(img_height), PARAMETER :: img = [" ___ ", " / \ "&
158 : , " [ABORT] ", " \___/ ", " | ", " O/| ", " /| | ", " / \ "]
159 :
160 : CHARACTER(LEN=screen_width) :: msg_line
161 : INTEGER :: a, b, c, fill, i, img_start, indent, &
162 : msg_height, msg_start
163 :
164 : ! count message lines
165 :
166 0 : a = 1; b = -1; msg_height = 0
167 0 : DO WHILE (b < LEN_TRIM(message))
168 0 : b = next_linebreak(message, a, txt_width)
169 0 : a = b + 1
170 0 : msg_height = msg_height + 1
171 : END DO
172 :
173 : ! calculate message and image starting lines
174 0 : IF (img_height > msg_height) THEN
175 0 : msg_start = (img_height - msg_height)/2 + 1
176 0 : img_start = 1
177 : ELSE
178 0 : msg_start = 1
179 0 : img_start = msg_height - img_height + 2
180 : END IF
181 :
182 : ! print empty line
183 0 : WRITE (UNIT=output_unit, FMT="(A)") ""
184 :
185 : ! print opening line
186 0 : WRITE (UNIT=output_unit, FMT="(T2,A)") REPEAT("*", screen_width - 1)
187 :
188 : ! print body
189 0 : a = 1; b = -1; c = 1
190 0 : DO i = 1, MAX(img_height - 1, msg_height)
191 0 : WRITE (UNIT=output_unit, FMT="(A)", advance='no') " *"
192 0 : IF (i < img_start) THEN
193 0 : WRITE (UNIT=output_unit, FMT="(A)", advance='no') REPEAT(" ", img_width)
194 : ELSE
195 0 : WRITE (UNIT=output_unit, FMT="(A)", advance='no') img(c)
196 0 : c = c + 1
197 : END IF
198 0 : IF (i < msg_start) THEN
199 0 : WRITE (UNIT=output_unit, FMT="(A)", advance='no') REPEAT(" ", txt_width + 2)
200 : ELSE
201 0 : b = next_linebreak(message, a, txt_width)
202 0 : msg_line = message(a:b)
203 0 : a = b + 1
204 0 : fill = (txt_width - LEN_TRIM(msg_line))/2 + 1
205 0 : indent = txt_width - LEN_TRIM(msg_line) - fill + 2
206 0 : WRITE (UNIT=output_unit, FMT="(A)", advance='no') REPEAT(" ", indent)
207 0 : WRITE (UNIT=output_unit, FMT="(A)", advance='no') TRIM(msg_line)
208 0 : WRITE (UNIT=output_unit, FMT="(A)", advance='no') REPEAT(" ", fill)
209 : END IF
210 0 : WRITE (UNIT=output_unit, FMT="(A)", advance='yes') "*"
211 : END DO
212 :
213 : ! print location line
214 0 : WRITE (UNIT=output_unit, FMT="(A)", advance='no') " *"
215 0 : WRITE (UNIT=output_unit, FMT="(A)", advance='no') img(c)
216 0 : indent = txt_width - LEN_TRIM(location) + 1
217 0 : WRITE (UNIT=output_unit, FMT="(A)", advance='no') REPEAT(" ", indent)
218 0 : WRITE (UNIT=output_unit, FMT="(A)", advance='no') TRIM(location)
219 0 : WRITE (UNIT=output_unit, FMT="(A)", advance='yes') " *"
220 :
221 : ! print closing line
222 0 : WRITE (UNIT=output_unit, FMT="(T2,A)") REPEAT("*", screen_width - 1)
223 :
224 : ! print empty line
225 0 : WRITE (UNIT=output_unit, FMT="(A)") ""
226 :
227 0 : END SUBROUTINE print_abort_message
228 :
229 : ! **************************************************************************************************
230 : !> \brief Helper routine for print_abort_message()
231 : !> \param message ...
232 : !> \param pos ...
233 : !> \param rowlen ...
234 : !> \return ...
235 : !> \author Ole Schuett
236 : ! **************************************************************************************************
237 0 : FUNCTION next_linebreak(message, pos, rowlen) RESULT(ibreak)
238 : CHARACTER(LEN=*), INTENT(IN) :: message
239 : INTEGER, INTENT(IN) :: pos, rowlen
240 : INTEGER :: ibreak
241 :
242 : INTEGER :: i, n
243 :
244 0 : n = LEN_TRIM(message)
245 0 : IF (n - pos <= rowlen) THEN
246 : ibreak = n ! remaining message shorter than line
247 : ELSE
248 0 : i = INDEX(message(pos + 1:pos + 1 + rowlen), " ", BACK=.TRUE.)
249 0 : IF (i == 0) THEN
250 0 : ibreak = pos + rowlen - 1 ! no space found, break mid-word
251 : ELSE
252 0 : ibreak = pos + i ! break at space closest to rowlen
253 : END IF
254 : END IF
255 0 : END FUNCTION next_linebreak
256 :
257 : END MODULE cp_error_handling
|
