Branch data Line data Source code
1 : : !!****m* ABINIT/m_errors
2 : : !! NAME
3 : : !! m_errors
4 : : !!
5 : : !! FUNCTION
6 : : !! This module contains low-level procedures to check assertions and handle errors.
7 : : !!
8 : : !! COPYRIGHT
9 : : !! Copyright (C) 2008-2026 ABINIT group (MG,YP,NCJ,MT)
10 : : !! This file is distributed under the terms of the
11 : : !! GNU General Public License, see ~abinit/COPYING
12 : : !! or http://www.gnu.org/copyleft/gpl.txt .
13 : : !!
14 : : !! SOURCE
15 : :
16 : : #if defined HAVE_CONFIG_H
17 : : #include "config.h"
18 : : #endif
19 : :
20 : : #include "abi_common.h"
21 : :
22 : : MODULE m_errors
23 : :
24 : : use defs_basis
25 : : use m_profiling_abi
26 : : use m_xmpi
27 : : use m_specialmsg, only : wrtout
28 : : USE_MPI
29 : : use netcdf
30 : : #ifdef FC_NAG
31 : : use f90_unix_proc
32 : : #endif
33 : : #ifdef FC_INTEL
34 : : use ifcore
35 : : #endif
36 : :
37 : : use iso_c_binding, only : c_ptr, c_size_t, c_associated
38 : :
39 : : use m_io_tools, only : flush_unit, lock_and_write, file_exists, num_opened_units, show_units, open_file, is_open
40 : : use m_fstrings, only : toupper, basename, indent, lstrip, atoi, strcat, itoa
41 : : use m_build_info, only : dump_config, abinit_version
42 : : use m_cppopts_dumper, only : dump_cpp_options
43 : : use m_optim_dumper, only : dump_optim
44 : :
45 : : implicit none
46 : :
47 : : #if defined HAVE_MPI1
48 : : include 'mpif.h'
49 : : #endif
50 : :
51 : : #ifdef FC_IBM
52 : : include "fexcp.h"
53 : : #endif
54 : :
55 : : private
56 : : !!***
57 : :
58 : : !Public procedures
59 : : public :: assert_eq ! Report and die gracefully if integers not all equal (used for size checking).
60 : : public :: assert ! Report and die if any logical is false (used for argument range checking).
61 : : public :: sentinel ! Announce the entering or the exiting from a procedure.
62 : : public :: die ! Stop execution in case of unexpected events.
63 : : public :: msg_hndl ! Basic Error handlers.
64 : : public :: netcdf_check ! Stop execution after a NetCDF I/O error
65 : : public :: check_mpi_ierr ! Error handler for MPI routines.
66 : : public :: set_backtrace_onerr ! Activate show_backtrace call in msg_hndl. 0 to disable it.
67 : : !public :: show_backtrace ! Shows a backtrace at an arbitrary place in user code. (Gfortran/Ifort extension)
68 : : public :: unused_var ! Helper function used to silence compiler warnings due to unused variables.
69 : : public :: bigdft_lib_error
70 : : public :: xlf_set_sighandler
71 : : public :: abinit_doctor ! Perform checks on memory leaks and leaking file descriptors
72 : : ! at the end of the run.
73 : : public :: abi_abort ! Abort the code
74 : : public :: abi_cabort ! C-interoperable version.
75 : :
76 : : ! This flag activate the output of the backtrace in msg_hndl
77 : : integer, save, private :: m_errors_show_backtrace = 1
78 : :
79 : : interface assert_eq
80 : : module procedure assert_eq2
81 : : module procedure assert_eq3
82 : : module procedure assert_eq4
83 : : module procedure assert_eqn
84 : : end interface assert_eq
85 : :
86 : : interface assert
87 : : module procedure assert1
88 : : module procedure assert2
89 : : module procedure assert3
90 : : module procedure assert4
91 : : module procedure assert_v
92 : : end interface assert
93 : :
94 : : interface unused_var
95 : : module procedure unused_int
96 : : module procedure unused_real_dp
97 : : module procedure unused_real_sp
98 : : module procedure unused_cplx_dpc
99 : : module procedure unused_cplx_spc
100 : : module procedure unused_logical
101 : : module procedure unused_logical1B
102 : : module procedure unused_ch
103 : : module procedure unused_c_ptr
104 : : module procedure unused_c_size_t
105 : : end interface unused_var
106 : :
107 : : CONTAINS !===========================================================
108 : : !!***
109 : :
110 : : !----------------------------------------------------------------------
111 : :
112 : : !!****f* m_errors/assert_eq2
113 : : !! NAME
114 : : !! assert_eq2
115 : : !!
116 : : !! FUNCTION
117 : : !! Report and die gracefully if integers not all equal (used for size checking).
118 : : !!
119 : : !! INPUTS
120 : : !! l1,l2,.. Integers to be checked (array version is also provided)
121 : : !! message(len=*)=tag with additional information
122 : : !!
123 : : !! SOURCE
124 : :
125 : 121022 : function assert_eq2(l1,l2,message,file,line)
126 : :
127 : : !Arguments ------------------------------------
128 : : integer,intent(in) :: l1,l2
129 : : integer,optional,intent(in) :: line
130 : : integer :: assert_eq2
131 : : character(len=*),intent(in) :: message
132 : : character(len=*),optional,intent(in) :: file
133 : :
134 : : !Local variables-------------------------------
135 : : integer :: f90line=0
136 : : character(len=500) :: f90name='Subroutine Unknown'
137 : : ! *************************************************************************
138 : :
139 [ - + ]: 121022 : if (l1==l2) then
140 : : assert_eq2=l1
141 : : else
142 [ # # ]: 0 : if (PRESENT(line)) f90line=line
143 [ # # # # ]: 0 : if (PRESENT(file)) f90name= basename(file)
144 : 0 : call msg_hndl(message,'ERROR','PERS',f90name,line)
145 : : end if
146 : :
147 : 121022 : end function assert_eq2
148 : : !!***
149 : :
150 : : !----------------------------------------------------------------------
151 : :
152 : : !!****f* m_errors/assert_eq3
153 : : !! NAME
154 : : !! assert_eq3
155 : : !!
156 : : !! FUNCTION
157 : : !! Report and die gracefully if integers not all equal (used for size checking).
158 : : !!
159 : : !! INPUTS
160 : : !! l1,l2,.. Integers to be checked (array version is also provided)
161 : : !! message(len=*)=tag with additional information
162 : : !!
163 : : !! SOURCE
164 : :
165 : 0 : function assert_eq3(l1,l2,l3,message,file,line)
166 : :
167 : : !Arguments ------------------------------------
168 : : integer,intent(in) :: l1,l2,l3
169 : : integer,optional,intent(in) :: line
170 : : integer :: assert_eq3
171 : : character(len=*),intent(in) :: message
172 : : character(len=*),optional,intent(in) :: file
173 : :
174 : : !Local variables-------------------------------
175 : : integer :: f90line=0
176 : : character(len=500) :: f90name='Subroutine Unknown'
177 : : ! *************************************************************************
178 : :
179 [ # # # # ]: 0 : if (l1==l2.and.l2==l3) then
180 : : assert_eq3=l1
181 : : else
182 [ # # ]: 0 : if (PRESENT(line)) f90line=line
183 [ # # # # ]: 0 : if (PRESENT(file)) f90name= basename(file)
184 : 0 : call msg_hndl(message,'ERROR','PERS',f90name,line)
185 : : end if
186 : :
187 : 0 : end function assert_eq3
188 : : !!***
189 : :
190 : : !----------------------------------------------------------------------
191 : :
192 : : !!****f* m_errors/assert_eq4
193 : : !! NAME
194 : : !! assert_eq4
195 : : !!
196 : : !! FUNCTION
197 : : !! Report and die gracefully if integers not all equal (used for size checking).
198 : : !!
199 : : !! INPUTS
200 : : !! l1,l2,.. Integers to be checked (array version is also provided)
201 : : !! message(len=*)=tag with additional information
202 : : !!
203 : : !! SOURCE
204 : :
205 : 0 : function assert_eq4(l1,l2,l3,l4,message,file,line)
206 : :
207 : : !Arguments ------------------------------------
208 : : !scalars
209 : : integer,intent(in) :: l1,l2,l3,l4
210 : : integer,optional,intent(in) :: line
211 : : integer :: assert_eq4
212 : : character(len=*),intent(in) :: message
213 : : character(len=*),optional,intent(in) :: file
214 : :
215 : : !Local variables-------------------------------
216 : : integer :: f90line=0
217 : : character(len=500) :: f90name='Subroutine Unknown'
218 : : ! *************************************************************************
219 : :
220 [ # # # # : 0 : if (l1==l2.and.l2==l3.and.l3==l4) then
# # ]
221 : : assert_eq4=l1
222 : : else
223 [ # # ]: 0 : if (PRESENT(line)) f90line=line
224 [ # # # # ]: 0 : if (PRESENT(file)) f90name= basename(file)
225 : 0 : call msg_hndl(message,'ERROR','PERS',f90name,line)
226 : : end if
227 : :
228 : 0 : end function assert_eq4
229 : : !!***
230 : :
231 : : !----------------------------------------------------------------------
232 : :
233 : : !!****f* m_errors/assert_eqn
234 : : !! NAME
235 : : !! assert_eqn
236 : : !!
237 : : !! FUNCTION
238 : : !! Report and die gracefully if integers not all equal (used for size checking).
239 : : !!
240 : : !! SOURCE
241 : :
242 [ - + ]: 33 : function assert_eqn(nn,message,file,line)
243 : :
244 : : !Arguments ------------------------------------
245 : : !scalars
246 : : integer,optional,intent(in) :: line
247 : : integer :: assert_eqn
248 : : character(len=*),intent(in) :: message
249 : : character(len=*),optional,intent(in) :: file
250 : : !arrays
251 : : integer,intent(in) :: nn(:)
252 : :
253 : : !Local variables-------------------------------
254 : : integer :: f90line=0
255 : : character(len=500) :: f90name='Subroutine Unknown'
256 : : ! *************************************************************************
257 : :
258 [ + + + - : 88 : if (ALL(nn(2:)==nn(1))) then
- + ]
259 : : assert_eqn=nn(1)
260 : : else
261 [ # # ]: 0 : if (PRESENT(line)) f90line=line
262 [ # # # # ]: 0 : if (PRESENT(file)) f90name= basename(file)
263 : 0 : call msg_hndl(message,'ERROR','PERS',f90name,line)
264 : : end if
265 : :
266 : 33 : end function assert_eqn
267 : : !!***
268 : :
269 : : !----------------------------------------------------------------------
270 : :
271 : : !!****f* m_errors/assert1
272 : : !! NAME
273 : : !! assert1
274 : : !!
275 : : !! FUNCTION
276 : : !! Routines for argument checking and error handling. Report and die if
277 : : !! any logical is false (used for arg range checking).
278 : : !!
279 : : !! INPUTS
280 : : !! l1,l2,.. logical values to be checked (array version is also provided)
281 : : !! message(len=*)=tag with additional information.
282 : : !!
283 : : !! SOURCE
284 : :
285 : 0 : subroutine assert1(l1,message,file,line)
286 : :
287 : : !Arguments ------------------------------------
288 : : integer,optional,intent(in) :: line
289 : : character(len=*),intent(in) :: message
290 : : character(len=*),optional,intent(in) :: file
291 : : logical,intent(in) :: l1
292 : :
293 : : !Local variables-------------------------------
294 : : integer :: f90line=0
295 : : character(len=500) :: f90name='Subroutine Unknown'
296 : : ! *************************************************************************
297 : :
298 [ # # ]: 0 : if (.not.l1) then
299 [ # # ]: 0 : if (PRESENT(line)) f90line=line
300 [ # # # # ]: 0 : if (PRESENT(file)) f90name= basename(file)
301 : 0 : call msg_hndl(message,'ERROR','PERS',f90name,f90line)
302 : : end if
303 : :
304 : 0 : end subroutine assert1
305 : : !!***
306 : :
307 : : !----------------------------------------------------------------------
308 : :
309 : : !!****f* m_errors/assert2
310 : : !! NAME
311 : : !! assert2
312 : : !!
313 : : !! FUNCTION
314 : : !! Routines for argument checking and error handling. Report and die if
315 : : ! any logical is false (used for arg range checking).
316 : : !!
317 : : !! INPUTS
318 : : !! l1,l2,.. logical values to be checked (array version is also provided)
319 : : !! message(len=*)=tag with additional information
320 : : !!
321 : : !! SOURCE
322 : :
323 : 0 : subroutine assert2(l1,l2,message,file,line)
324 : :
325 : : !Arguments ------------------------------------
326 : : integer,optional,intent(in) :: line
327 : : character(len=*),intent(in) :: message
328 : : character(len=*),optional,intent(in) :: file
329 : : logical,intent(in) :: l1,l2
330 : :
331 : : !Local variables-------------------------------
332 : : integer :: f90line=0
333 : : character(len=500) :: f90name='Subroutine Unknown'
334 : : ! *************************************************************************
335 : :
336 [ # # # # ]: 0 : if (.not.(l1.and.l2)) then
337 [ # # ]: 0 : if (PRESENT(line)) f90line=line
338 [ # # # # ]: 0 : if (PRESENT(file)) f90name= basename(file)
339 : 0 : call msg_hndl(message,'ERROR','PERS',f90name,f90line)
340 : : end if
341 : :
342 : 0 : end subroutine assert2
343 : : !!***
344 : :
345 : : !----------------------------------------------------------------------
346 : :
347 : : !!****f* m_errors/assert3
348 : : !! NAME
349 : : !! assert3
350 : : !!
351 : : !! FUNCTION
352 : : !! Routines for argument checking and error handling. Report and die if
353 : : !! any logical is false (used for arg range checking).
354 : : !!
355 : : !! INPUTS
356 : : !! l1,l2,.. logical values to be checked (array version is also provided)
357 : : !! message(len=*)=tag with additional information
358 : : !!
359 : : !! SOURCE
360 : :
361 : 0 : subroutine assert3(l1,l2,l3,message,file,line)
362 : :
363 : : !Arguments ------------------------------------
364 : : integer,optional,intent(in) :: line
365 : : character(len=*),intent(in) :: message
366 : : character(len=*),optional,intent(in) :: file
367 : : logical,intent(in) :: l1,l2,l3
368 : :
369 : : !Local variables-------------------------------
370 : : integer :: f90line=0
371 : : character(len=500) :: f90name='Subroutine Unknown'
372 : : ! *************************************************************************
373 : :
374 [ # # # # : 0 : if (.not.(l1.and.l2.and.l3)) then
# # ]
375 [ # # ]: 0 : if (PRESENT(line)) f90line=line
376 [ # # # # ]: 0 : if (PRESENT(file)) f90name= basename(file)
377 : 0 : call msg_hndl(message,'ERROR','PERS',f90name,f90line)
378 : : end if
379 : :
380 : 0 : end subroutine assert3
381 : : !!***
382 : :
383 : : !----------------------------------------------------------------------
384 : :
385 : : !!****f* m_errors/assert4
386 : : !! NAME
387 : : !! assert4
388 : : !!
389 : : !! FUNCTION
390 : : !! Routines for argument checking and error handling. Report and die if
391 : : !! any logical is false (used for arg range checking).
392 : : !!
393 : : !! INPUTS
394 : : !! l1,l2,.. logical values to be checked (array version is also provided)
395 : : !! message(len=*)=tag with additional information
396 : : !!
397 : : !! SOURCE
398 : :
399 : 0 : subroutine assert4(l1,l2,l3,l4,message,file,line)
400 : :
401 : : !Arguments ------------------------------------
402 : : integer,optional,intent(in) :: line
403 : : character(len=*),intent(in) :: message
404 : : character(len=*),optional,intent(in) :: file
405 : : logical,intent(in) :: l1,l2,l3,l4
406 : :
407 : : !Local variables-------------------------------
408 : : integer :: f90line=0
409 : : character(len=500) :: f90name='Subroutine Unknown'
410 : : ! *************************************************************************
411 : :
412 [ # # # # : 0 : if (.not.(l1.and.l2.and.l3.and.l4)) then
# # # # ]
413 [ # # ]: 0 : if (PRESENT(line)) f90line=line
414 [ # # # # ]: 0 : if (PRESENT(file)) f90name= basename(file)
415 : 0 : call msg_hndl(message,'ERROR','PERS',f90name,f90line)
416 : : end if
417 : :
418 : 0 : end subroutine assert4
419 : : !!***
420 : :
421 : : !----------------------------------------------------------------------
422 : :
423 : : !!****f* m_errors/assert_v
424 : : !! NAME
425 : : !! assert_v
426 : : !!
427 : : !! FUNCTION
428 : : !! Routines for argument checking and error handling. Report and die if
429 : : !! any logical is false (used for arg range checking).
430 : : !!
431 : : !! SOURCE
432 : :
433 [ # # ]: 0 : subroutine assert_v(n,message,file,line)
434 : :
435 : : !Arguments ------------------------------------
436 : : integer,optional,intent(in) :: line
437 : : character(len=*),intent(in) :: message
438 : : character(len=*),optional,intent(in) :: file
439 : : logical,intent(in) :: n(:)
440 : :
441 : : !Local variables-------------------------------
442 : : integer :: f90line=0
443 : : character(len=500) :: f90name='Subroutine Unknown'
444 : : ! *************************************************************************
445 : :
446 [ # # # # : 0 : if (.not.ALL(n)) then
# # ]
447 [ # # ]: 0 : if (PRESENT(line)) f90line=line
448 [ # # # # ]: 0 : if (PRESENT(file)) f90name= basename(file)
449 : 0 : call msg_hndl(message,'ERROR','PERS',f90name,f90line)
450 : : end if
451 : :
452 : 0 : end subroutine assert_v
453 : : !!***
454 : :
455 : : !----------------------------------------------------------------------
456 : :
457 : : !!****f* m_errors/netcdf_check
458 : : !! NAME
459 : : !! netcdf_check
460 : : !!
461 : : !! FUNCTION
462 : : !! Error handler for Netcdf calls.
463 : : !!
464 : : !! INPUTS
465 : : !! ncerr=Status error returned by the Netcdf library.
466 : : !! msg=User-defined string with info on the action that was performed
467 : : !! file= name of the file.
468 : : !! line= line number.
469 : : !!
470 : : !! NOTES
471 : : !! This routine is usually interfaced with the macros defined in abi_common.h
472 : : !!
473 : : !! SOURCE
474 : :
475 : 18 : subroutine netcdf_check(ncerr, msg, file, line)
476 : :
477 : : !Arguments ------------------------------------
478 : : integer,intent(in) :: ncerr
479 : : character(len=*),intent(in) :: msg
480 : : character(len=*),optional,intent(in) :: file
481 : : integer,optional,intent(in) :: line
482 : :
483 : : !Local variables-------------------------------
484 : : integer :: f90line
485 : : character(len=500) :: f90name
486 : : character(len=1024) :: nc_msg
487 : : character(len=2048) :: my_msg
488 : : ! *************************************************************************
489 : :
490 [ - + ]: 18 : if (ncerr /= NF90_NOERR) then
491 : :
492 [ # # ]: 0 : f90line = 0; if (present(line)) f90line = line
493 [ # # # # ]: 0 : f90name = 'Subroutine Unknown'; if (present(file)) f90name = basename(file)
494 : :
495 : : ! Append netcdf string to user-defined message.
496 [ # # ]: 0 : write(nc_msg,'(3a)')' - NetCDF library returned: `', trim(nf90_strerror(ncerr)),"`"
497 [ # # ]: 0 : my_msg = trim(msg) // trim(nc_msg)
498 : :
499 : 0 : call msg_hndl(my_msg, "ERROR", "PERS", f90name, f90line)
500 : : end if
501 : :
502 : 18 : end subroutine netcdf_check
503 : : !!***
504 : :
505 : : !----------------------------------------------------------------------
506 : :
507 : : !!****f* m_errors/sentinel
508 : : !! NAME
509 : : !! sentinel
510 : : !!
511 : : !! FUNCTION
512 : : !! Announce the entering and the exiting from a function. Useful for poor-man debugging.
513 : : !!
514 : : !! INPUTS
515 : : !! level=1 when entering, 2 for exit.
516 : : !! mode_paral= ['COLL'|'PERS'|'COLL_SILENT|PERS_SILENT']
517 : : !! 'COLL' and 'PERS' refer to the output mode used in wrtout to report the message.
518 : : !! 'COLL_SILENT' and 'PERS_SILENT' can be used if the procedure is called several times inside a loop.
519 : : !! In this case sentinel will report only the first entry and the first exit using either 'COLL' or 'PERS' mode.
520 : : !! file=File name
521 : : !! func=Name of the procedure to be tested (passed through ABI_FUNC macro)
522 : : !! [line]=Line number. Defaults to 0.
523 : : !!
524 : : !! NOTES
525 : : !! This routine is usually interfaced with the macros defined in abi_common.h
526 : : !!
527 : : !! SOURCE
528 : :
529 : 0 : subroutine sentinel(level,mode_paral,file,func,line)
530 : :
531 : : !Arguments ------------------------------------
532 : : integer,intent(in) :: level
533 : : integer,optional,intent(in) :: line
534 : : character(len=*),intent(in) :: mode_paral
535 : : character(len=*),optional,intent(in) :: func
536 : : character(len=*),optional,intent(in) :: file
537 : :
538 : : !Local variables-------------------------------
539 : : integer,save :: level_save=0
540 : : integer :: ii
541 : : integer :: f90line
542 : : character(len=500),save :: func_save
543 : : character(len=4) :: my_mode
544 : : character(len=10) :: lnum
545 : : character(len=500) :: my_func, my_file
546 : : character(len=500) :: msg
547 : : ! *********************************************************************
548 : :
549 : : ! initialize the variable
550 [ # # ]: 0 : my_func = 'Function Unknown'; if (PRESENT(func)) my_func = basename(func)
551 [ # # # # ]: 0 : my_file = "File Unknown"; if (PRESENT(file)) my_file = basename(file)
552 : :
553 : 0 : level_save=level; func_save=my_func
554 : :
555 [ # # ]: 0 : f90line=0; if (PRESENT(line)) f90line=line
556 : :
557 [ # # # # : 0 : if (toupper(mode_paral)=='COLL_SILENT'.or.toupper(mode_paral)=='PERS_SILENT') then
# # ]
558 : : ! * Silent mode, check if we are inside a loop.
559 [ # # # # ]: 0 : if (level==level_save .and. my_func==func_save) RETURN
560 : 0 : ii = index( toupper(mode_paral), '_SILENT')
561 [ # # ]: 0 : my_mode=toupper(mode_paral(1:ii-1))
562 : : else ! * Normal mode.
563 [ # # ]: 0 : my_mode=mode_paral
564 : : end if
565 : :
566 [ # # # # ]: 0 : if (my_mode/='COLL'.or.my_mode/='PERS') my_mode='COLL'
567 : :
568 : 0 : write(lnum,"(i0)")f90line
569 [ # # ]: 0 : my_func= TRIM(my_func)//"@"//TRIM(my_file)//":"//TRIM(lnum)
570 : :
571 [ # # ]: 0 : if (level==1) then
572 [ # # ]: 0 : msg = ' '//TRIM(my_func)//' >>>>> ENTER'//ch10
573 [ # # ]: 0 : else if (level==2) then
574 [ # # ]: 0 : msg = ' '//TRIM(my_func)//' >>>>> EXIT '//ch10
575 : : else
576 : : call die('Wrong level', &
577 : : & __FILE__,&
578 : 0 : & __LINE__)
579 : : end if
580 : :
581 : 0 : call wrtout(std_out,msg,my_mode)
582 : 0 : call flush_unit(std_out)
583 : :
584 [ # # ]: 0 : end subroutine sentinel
585 : : !!***
586 : :
587 : : !----------------------------------------------------------------------
588 : :
589 : : !!****f* m_errors/die
590 : : !! NAME
591 : : !! die
592 : : !!
593 : : !! FUNCTION
594 : : !! Stop smoothly the execution in case of unexpected events reporting the
595 : : !! line number and the file name where the error occurred as well as the
596 : : !! MPI rank of the processor. This routine is usually interfaced through
597 : : !! some macro defined in abi_common.h
598 : : !!
599 : : !! INPUTS
600 : : !! message=String containing additional information on the nature of the problem
601 : : !! line=Line number of the file where problem occurred
602 : : !! f90name=Name of the f90 file containing the caller
603 : : !!
604 : : !! SOURCE
605 : :
606 : 0 : subroutine die(message,file,line)
607 : :
608 : : !Arguments ------------------------------------
609 : : integer,optional,intent(in) :: line
610 : : character(len=*),intent(in) :: message
611 : : character(len=*),optional,intent(in) :: file
612 : :
613 : : !Local variables-------------------------------
614 : : integer :: rank
615 : : integer :: f90line=0
616 : : character(len=10) :: lnum,strank
617 : : character(len=500) :: f90name='Subroutine Unknown'
618 : : character(len=500) :: msg
619 : : ! *********************************************************************
620 : :
621 [ # # ]: 0 : if (PRESENT(line)) f90line=line
622 : 0 : write(lnum,"(i0)")f90line
623 : :
624 : : ! === Determine my rank inside MPI_COMM_WORLD ===
625 : 0 : rank = xmpi_comm_rank(xmpi_world)
626 : 0 : write(strank,"(i0)")rank
627 : :
628 [ # # # # ]: 0 : if (PRESENT(file)) f90name= basename(file)
629 [ # # ]: 0 : msg=TRIM(f90name)//':'//TRIM(lnum)//' P'//TRIM(strank)
630 : :
631 : 0 : write(msg,'(a,2x,2a,2x,a)')ch10,TRIM(msg),ch10,TRIM(message)
632 : :
633 : 0 : call wrtout(std_out,msg,'PERS')
634 : : !if is_connected(ab_out)) call wrtout(ab_out,msg,'PERS')
635 : 0 : call abi_abort('PERS')
636 : :
637 : 0 : end subroutine die
638 : : !!***
639 : :
640 : : !----------------------------------------------------------------------
641 : :
642 : : !!****f* m_errors/msg_hndl
643 : : !! NAME
644 : : !! msg_hndl
645 : : !!
646 : : !! FUNCTION
647 : : !! Basic error handler for abinit. This routine is usually interfaced through some macro defined in abi_common.h
648 : : !!
649 : : !! INPUTS
650 : : !! message=string containing additional information on the nature of the problem
651 : : !! level=string defining the type of problem. Possible values are
652 : : !! COMMENT
653 : : !! WARNING
654 : : !! ERROR
655 : : !! STOP
656 : : !! BUG
657 : : !! mode_paral=Either "COLL" or "PERS".
658 : : !! [line] = line number of the file where problem occurred
659 : : !! [file] = name of the f90 file containing the caller
660 : : !! [NODUMP]= if present dump config before stopping
661 : : !! [NOSTOP]= if present don't stop even in the case of an error or a bug
662 : : !! [unit]= Unit number (defaults to std_out)
663 : : !!
664 : : !! OUTPUT
665 : : !!
666 : : !! SOURCE
667 : :
668 : 231799 : subroutine msg_hndl(message, level, mode_paral, file, line, NODUMP, NOSTOP, unit)
669 : :
670 : : !Arguments ------------------------------------
671 : : integer,optional,intent(in) :: line, unit
672 : : logical,optional,intent(in) :: NODUMP,NOSTOP
673 : : character(len=*),intent(in) :: level,message
674 : : character(len=*),optional,intent(in) :: file
675 : : character(len=*),intent(in) :: mode_paral
676 : :
677 : : !Local variables-------------------------------
678 : : integer :: f90line,ierr,unit_
679 : : character(len=10) :: lnum
680 : : character(len=500) :: f90name
681 : 231799 : character(len=LEN(message)) :: my_msg
682 : 231799 : character(len=MAX(4*LEN(message),2000)) :: sbuf ! Increase size and keep fingers crossed!
683 : : ! *********************************************************************
684 : :
685 [ + + ]: 231799 : unit_ = std_out; if (present(unit)) unit_ = unit
686 : :
687 [ + - ]: 231799 : if (PRESENT(line)) then
688 : 231799 : f90line=line
689 : : else
690 : 0 : f90line=0
691 : : end if
692 : : ! TODO: fldiff.py should ignore f90line when comparing files (we don't want to
693 : : ! update ref files if a new line is added to F90 source file!
694 [ + + ]: 231799 : if (unit_ == ab_out) f90line = 0
695 : 231799 : write(lnum,"(i0)")f90line
696 : :
697 [ + - ]: 231799 : if (PRESENT(file)) then
698 [ + - ]: 231799 : f90name = basename(file)
699 : : else
700 : 0 : f90name='Subroutine Unknown'
701 : : end if
702 : :
703 [ + - ]: 231799 : my_msg = lstrip(message)
704 : :
705 : 695395 : select case (toupper(level))
706 : :
707 : : case ('COMMENT', 'WARNING')
708 : :
709 : 231797 : write(sbuf,'(8a,i0,7a)')ch10,&
710 : 231797 : "--- !",TRIM(level),ch10,&
711 : 231797 : "src_file: ",TRIM(f90name),ch10,&
712 : 231797 : "src_line: ",f90line,ch10,&
713 [ + - ]: 231797 : "message: |",ch10,TRIM(indent(my_msg)),ch10,&
714 : 463594 : "...",ch10
715 : 231797 : call wrtout(unit_, sbuf, mode_paral)
716 : :
717 : : case ('STOP')
718 : :
719 : 0 : write(sbuf,'(9a)')ch10,&
720 : 0 : "--- !",TRIM(level),ch10,&
721 [ # # ]: 0 : "message: |",ch10,TRIM(indent(my_msg)),ch10,"..."
722 : 0 : call wrtout(unit_, sbuf, mode_paral, do_flush=.True.)
723 : :
724 : : ! Write error message to ab_out as well, provided this proc is connected to ab_out
725 : : !if (unit_ /= ab_out .and. is_open(ab_out)) call wrtout(ab_out, sbuf, mode_paral="PERS", do_flush=.True.)
726 : :
727 [ # # ]: 0 : if (.not.present(NOSTOP)) call abi_abort(mode_paral, print_config=.FALSE.)
728 : :
729 : : case default
730 : : ! ERROR' or 'BUG'
731 [ + - ]: 2 : if ((.not.present(NOSTOP)).and.(.not.present(NODUMP))) then
732 : : ! Dump the backtrace if the compiler supports it.
733 [ + - ]: 2 : if (m_errors_show_backtrace == 1) call show_backtrace()
734 : : end if
735 : :
736 : 2 : write(sbuf,'(8a,i0,2a,i0,7a)')ch10,&
737 : 2 : "--- !",TRIM(level),ch10,&
738 : 2 : "src_file: ",TRIM(f90name),ch10,&
739 : 2 : "src_line: ",f90line,ch10,&
740 : 2 : "mpi_rank: ",xmpi_comm_rank(xmpi_world),ch10,&
741 [ + - ]: 2 : "message: |",ch10,TRIM(indent(my_msg)),ch10,&
742 : 4 : "...",ch10
743 : 2 : call wrtout(unit_, sbuf, mode_paral=mode_paral, do_flush=.True.)
744 : :
745 : : ! Write error message to ab_out as well, provided this proc is connected to ab_out
746 [ + - ]: 2 : if (is_open(ab_out)) then
747 : 2 : call wrtout(ab_out, sbuf, mode_paral="PERS", do_flush=.True.)
748 : : end if
749 : :
750 [ + - + + : 231801 : if (.not.present(NOSTOP)) then
- ]
751 : : ! The first MPI proc that gets here, writes the ABI_MPIABORTFILE with the message!
752 : : ! The file is written only if nprocs > 1. Do not change this behaviour!
753 [ + - - + ]: 2 : if (.not. file_exists(ABI_MPIABORTFILE) .and. xmpi_comm_size(xmpi_world) > 1) then
754 : 0 : call lock_and_write(ABI_MPIABORTFILE, sbuf, ierr)
755 : : end if
756 : : ! And now we're gonna die!
757 : 2 : call abi_abort(mode_paral, print_config=.FALSE.)
758 : : end if
759 : :
760 : : end select
761 : :
762 : 231797 : end subroutine msg_hndl
763 : : !!***
764 : :
765 : : !----------------------------------------------------------------------
766 : :
767 : : !!****f* m_errors/set_backtrace_onerr
768 : : !! NAME
769 : : !! set_backtrace_onerr
770 : : !!
771 : : !! FUNCTION
772 : : !! 1 to activate show_backtrace call in msg_hndl. 0 to disable it
773 : : !!
774 : : !! SOURCE
775 : :
776 : 0 : subroutine set_backtrace_onerr(iflag)
777 : :
778 : : !Arguments ------------------------------------
779 : : integer,intent(in) :: iflag
780 : : ! *********************************************************************
781 : :
782 : 0 : m_errors_show_backtrace = iflag
783 : :
784 : 0 : end subroutine set_backtrace_onerr
785 : : !!***
786 : :
787 : : !----------------------------------------------------------------------
788 : :
789 : : !!****f* m_errors/show_backtrace
790 : : !! NAME
791 : : !! show_backtrace
792 : : !!
793 : : !! FUNCTION
794 : : !! shows a backtrace at an arbitrary place in user code.
795 : : !! Program execution continues normally afterwards.
796 : : !! The backtrace information is printed to the unit corresponding to ERROR_UNIT in ISO_FORTRAN_ENV.
797 : : !! This is a (Gfortran extension| Ifort Extension)
798 : : !!
799 : : !! SOURCE
800 : :
801 : 2 : subroutine show_backtrace()
802 : :
803 : : #if defined FC_GNU && defined HAVE_FC_BACKTRACE
804 : 2 : call backtrace() ! Gfortran extension
805 : :
806 : : #elif defined FC_INTEL
807 : : call TRACEBACKQQ(USER_EXIT_CODE=-1) ! Ifort extension
808 : : #endif
809 : :
810 : 2 : end subroutine show_backtrace
811 : : !!***
812 : :
813 : : !----------------------------------------------------------------------
814 : :
815 : : !!****f* m_errors/check_mpi_ierr
816 : : !! NAME
817 : : !! check_mpi_ierr
818 : : !!
819 : : !! FUNCTION
820 : : !! Basic error handler for MPI calls. This routine is usually interfaced through some macro defined in abi_common.h
821 : : !!
822 : : !! INPUTS
823 : : !! ierr=Exit status reported by an MPI call.
824 : : !! line=line number of the file where problem occurred
825 : : !! file=name of the f90 file containing the caller
826 : : !!
827 : : !! OUTPUT
828 : : !! Write error message thep stop execution.
829 : : !!
830 : : !! SOURCE
831 : :
832 : 1187 : subroutine check_mpi_ierr(ierr, msg, file, line)
833 : :
834 : : !Arguments ------------------------------------
835 : : integer,intent(in) :: ierr
836 : : integer,optional,intent(in) :: line
837 : : character(len=*),intent(in) :: msg
838 : : character(len=*),optional,intent(in) :: file
839 : :
840 : : !Local variables-------------------------------
841 : : integer,parameter :: mpi_msg_len=1000
842 : : integer :: f90line,ilen,ierr2
843 : : character(len=500) :: f90name='Subroutine Unknown'
844 : : character(len=mpi_msg_len) :: mpi_msg_error
845 : : character(len=mpi_msg_len+500) :: my_msg
846 : : ! *********************************************************************
847 : :
848 : : #ifdef HAVE_MPI
849 [ + - ]: 1187 : if (ierr==MPI_SUCCESS) RETURN
850 : 0 : call MPI_ERROR_STRING(ierr, mpi_msg_error, ilen, ierr2)
851 : : #else
852 : : ilen=0; ierr2=0
853 : : mpi_msg_error = " Check_mpi_ierr should not be called in non-MPI mode!"
854 : : if (ierr==0) RETURN
855 : : #endif
856 : :
857 [ # # ]: 0 : if (ilen>mpi_msg_len) write(std_out,*)" Warning_ MPI message has been truncated!"
858 [ # # ]: 0 : if (ierr2/=0) write(std_out,*)" Warning: MPI_ERROR_STRING returned ierr2= ",ierr2
859 : :
860 [ # # ]: 0 : f90line=0; if (PRESENT(line)) f90line=line
861 [ # # # # ]: 0 : if (PRESENT(file)) f90name = basename(file)
862 [ # # ]: 0 : my_msg = TRIM(msg)//ch10//TRIM(mpi_msg_error)
863 : :
864 : 0 : call msg_hndl(my_msg,"ERROR","PERS",file=f90name,line=f90line)
865 : :
866 : : end subroutine check_mpi_ierr
867 : : !!***
868 : :
869 : : !----------------------------------------------------------------------
870 : :
871 : : !!****f* m_errors/unused_int
872 : : !! NAME
873 : : !! unused_int
874 : : !!
875 : : !! FUNCTION
876 : : !! Helper function used to silence compiler warnings due to unused variables.
877 : : !! Interfaced via the ABI_UNUSED macro.
878 : : !!
879 : : !! INPUTS
880 : : !! var=Scalar integer value
881 : : !!
882 : : !! OUTPUT
883 : : !! None
884 : : !!
885 : : !! SOURCE
886 : :
887 : 0 : elemental subroutine unused_int(var)
888 : :
889 : : !Arguments ------------------------------------
890 : : integer,intent(in) :: var
891 : :
892 : : !Local variables-------------------------------
893 : : integer :: dummy
894 : : ! *********************************************************************
895 : :
896 : 0 : dummy = var
897 : :
898 : 0 : end subroutine unused_int
899 : : !!***
900 : :
901 : : !----------------------------------------------------------------------
902 : :
903 : : !!****f* m_errors/unused_real_dp
904 : : !! NAME
905 : : !! unused_real_dp
906 : : !!
907 : : !! FUNCTION
908 : : !! Helper function used to silence warning messages due to unused variables.
909 : : !! Interfaced via the ABI_UNUSED macro.
910 : : !!
911 : : !! INPUTS
912 : : !! var=Scalar real value.
913 : : !!
914 : : !! OUTPUT
915 : : !! None
916 : : !!
917 : : !! SOURCE
918 : :
919 : 0 : elemental subroutine unused_real_dp(var)
920 : :
921 : : !Arguments ------------------------------------
922 : : real(dp),intent(in) :: var
923 : :
924 : : !Local variables-------------------------------
925 : : real(dp) :: dummy
926 : : ! *********************************************************************
927 : :
928 : 0 : dummy = var
929 : :
930 : 0 : end subroutine unused_real_dp
931 : : !!***
932 : :
933 : : !----------------------------------------------------------------------
934 : :
935 : : !!****f* m_errors/unused_real_sp
936 : : !! NAME
937 : : !! unused_real_sp
938 : : !!
939 : : !! FUNCTION
940 : : !! Helper function used to silence compiler warnings due to unused variables.
941 : : !! Interfaced via the ABI_UNUSED macro. Target: one-dimensional real(dp) vector.
942 : : !!
943 : : !! SOURCE
944 : :
945 : 0 : elemental subroutine unused_real_sp(var)
946 : :
947 : : !Arguments ------------------------------------
948 : : real(sp),intent(in) :: var
949 : :
950 : : !Local variables-------------------------------
951 : : real(sp) :: dummy
952 : : ! *********************************************************************
953 : :
954 : 0 : dummy = var
955 : :
956 : 0 : end subroutine unused_real_sp
957 : : !!***
958 : :
959 : : !----------------------------------------------------------------------
960 : :
961 : : !!****f* m_errors/unused_cplx_spc
962 : : !! NAME
963 : : !! unused_cplx_spc
964 : : !!
965 : : !! FUNCTION
966 : : !! Helper function used to silence compiler warnings due to unused variables.
967 : : !! Interfaced via the ABI_UNUSED macro.
968 : : !!
969 : : !! INPUTS
970 : : !! var=Scalar complex value
971 : : !!
972 : : !! OUTPUT
973 : : !! None
974 : : !!
975 : : !! SOURCE
976 : :
977 : 0 : elemental subroutine unused_cplx_spc(var)
978 : :
979 : : !Arguments ------------------------------------
980 : : complex(sp),intent(in) :: var
981 : :
982 : : !Local variables-------------------------------
983 : : complex(sp) :: dummy
984 : : ! *********************************************************************
985 : :
986 : 0 : dummy = var
987 : :
988 : 0 : end subroutine unused_cplx_spc
989 : : !!***
990 : :
991 : : !----------------------------------------------------------------------
992 : :
993 : : !!****f* m_errors/unused_cplx_dpc
994 : : !! NAME
995 : : !! unused_cplx_dpc
996 : : !!
997 : : !! FUNCTION
998 : : !! Helper function used to silence compiler warnings due to unused variables.
999 : : !! Interfaced via the ABI_UNUSED macro.
1000 : : !!
1001 : : !! INPUTS
1002 : : !! var=Scalar complex value
1003 : : !!
1004 : : !! OUTPUT
1005 : : !! None
1006 : : !!
1007 : : !! SOURCE
1008 : :
1009 : 0 : elemental subroutine unused_cplx_dpc(var)
1010 : :
1011 : : !Arguments ------------------------------------
1012 : : complex(dp),intent(in) :: var
1013 : :
1014 : : !Local variables-------------------------------
1015 : : complex(dp) :: dummy
1016 : : ! *********************************************************************
1017 : :
1018 : 0 : dummy = var
1019 : :
1020 : 0 : end subroutine unused_cplx_dpc
1021 : : !!***
1022 : :
1023 : : !----------------------------------------------------------------------
1024 : :
1025 : : !!****f* m_errors/unused_logical
1026 : : !! NAME
1027 : : !! unused_logical
1028 : : !!
1029 : : !! FUNCTION
1030 : : !! Helper function used to silence compiler warnings due to unused variables.
1031 : : !! Interfaced via the ABI_UNUSED macro.
1032 : : !!
1033 : : !! INPUTS
1034 : : !! var=Scalar logical value
1035 : : !!
1036 : : !! OUTPUT
1037 : : !! None
1038 : : !!
1039 : : !! SOURCE
1040 : :
1041 : 0 : elemental subroutine unused_logical(var)
1042 : :
1043 : : !Arguments ------------------------------------
1044 : : logical,intent(in) :: var
1045 : :
1046 : : !Local variables-------------------------------
1047 : : logical :: dummy
1048 : : ! *********************************************************************
1049 : :
1050 : 0 : dummy = var
1051 : :
1052 : 0 : end subroutine unused_logical
1053 : : !!***
1054 : :
1055 : : !!****f* m_errors/unused_logical1B
1056 : : !! NAME
1057 : : !! unused_logical1B
1058 : : !!
1059 : : !! FUNCTION
1060 : : !! Helper function used to silence compiler warnings due to unused variables.
1061 : : !! Interfaced via the ABI_UNUSED macro.
1062 : : !!
1063 : : !! INPUTS
1064 : : !! var= 1 Byte Scalar logical value
1065 : : !!
1066 : : !! OUTPUT
1067 : : !! None
1068 : : !!
1069 : : !! SOURCE
1070 : :
1071 : 0 : elemental subroutine unused_logical1B(var)
1072 : :
1073 : : !Arguments ------------------------------------
1074 : : logical*1,intent(in) :: var
1075 : :
1076 : : !Local variables-------------------------------
1077 : : logical :: dummy
1078 : : ! *********************************************************************
1079 : :
1080 : 0 : dummy = var
1081 : :
1082 : 0 : end subroutine unused_logical1B
1083 : : !!***
1084 : :
1085 : : !----------------------------------------------------------------------
1086 : :
1087 : : !!****f* m_errors/unused_ch
1088 : : !! NAME
1089 : : !! unused_ch
1090 : : !!
1091 : : !! FUNCTION
1092 : : !! Helper function used to silence compiler warnings due to unused variables.
1093 : : !! Interfaced via the ABI_UNUSED macro.
1094 : : !!
1095 : : !! INPUTS
1096 : : !! var=Scalar character value
1097 : : !!
1098 : : !! OUTPUT
1099 : : !! None
1100 : : !!
1101 : : !! SOURCE
1102 : :
1103 : 0 : elemental subroutine unused_ch(var)
1104 : :
1105 : : !Arguments ------------------------------------
1106 : : character(len=*),intent(in) :: var
1107 : :
1108 : : !Local variables-------------------------------
1109 : 0 : character(len=LEN(var)) :: dummy
1110 : : ! *********************************************************************
1111 : :
1112 : : dummy = var
1113 : :
1114 : 0 : end subroutine unused_ch
1115 : : !!***
1116 : :
1117 : : !----------------------------------------------------------------------
1118 : :
1119 : : !!****f* m_errors/unused_c_ptr
1120 : : !! NAME
1121 : : !! unused_c_ptr
1122 : : !!
1123 : : !! FUNCTION
1124 : : !! Helper function used to silence compiler warnings due to unused variables.
1125 : : !! Interfaced via the ABI_UNUSED macro.
1126 : : !!
1127 : : !! INPUTS
1128 : : !! var=type(c_ptr) value
1129 : : !!
1130 : : !! OUTPUT
1131 : : !! None
1132 : : !!
1133 : : !! SOURCE
1134 : :
1135 : 0 : elemental subroutine unused_c_ptr(var)
1136 : :
1137 : : !Arguments ------------------------------------
1138 : : type(c_ptr), intent(IN) :: var
1139 : :
1140 : : !Local variables-------------------------------
1141 : : #ifdef FC_NAG
1142 : : logical :: dummy
1143 : : #else
1144 : : type(c_ptr) :: dummy
1145 : : #endif
1146 : : ! *********************************************************************
1147 : :
1148 : : #ifdef FC_NAG
1149 : : if (.false.) dummy = c_associated(var)
1150 : : #else
1151 : 0 : dummy = var
1152 : : #endif
1153 : :
1154 : 0 : end subroutine unused_c_ptr
1155 : : !!***
1156 : :
1157 : :
1158 : : !----------------------------------------------------------------------
1159 : :
1160 : : !!****f* m_errors/unused_c_size_t
1161 : : !! NAME
1162 : : !! unused_c_size_t
1163 : : !!
1164 : : !! FUNCTION
1165 : : !! Helper function used to silence compiler warnings due to unused variables.
1166 : : !! Interfaced via the ABI_UNUSED macro.
1167 : : !!
1168 : : !! INPUTS
1169 : : !! var=type(c_size_t) value
1170 : : !!
1171 : : !! OUTPUT
1172 : : !! None
1173 : : !!
1174 : : !! SOURCE
1175 : :
1176 : 0 : elemental subroutine unused_c_size_t(var)
1177 : :
1178 : : !Arguments ------------------------------------
1179 : : integer(kind=c_size_t), intent(IN) :: var
1180 : :
1181 : : !Local variables-------------------------------
1182 : : integer(kind=c_size_t) :: dummy
1183 : : ! *********************************************************************
1184 : :
1185 : 0 : dummy = var
1186 : :
1187 : 0 : end subroutine unused_c_size_t
1188 : : !!***
1189 : :
1190 : : !----------------------------------------------------------------------
1191 : :
1192 : : !!****f* m_errors/bigdft_lib_error
1193 : : !! NAME
1194 : : !! bigdft_lib_error
1195 : : !!
1196 : : !! FUNCTION
1197 : : !! Stop the code if bigdft library has not been enabled.
1198 : : !! Interfaced with the CPP macro BIGDFT_NOTENABLED_ERROR
1199 : : !!
1200 : : !! INPUTS
1201 : : !! line=line number of the file where problem occurred
1202 : : !! file=name of the f90 file containing the caller
1203 : : !!
1204 : : !! SOURCE
1205 : :
1206 : : subroutine bigdft_lib_error(file,line)
1207 : 0 :
1208 : : !Arguments ------------------------------------
1209 : : integer,optional,intent(in) :: line
1210 : : character(len=*),optional,intent(in) :: file
1211 : :
1212 : : !Local variables-------------------------------
1213 : : character(len=500) :: message
1214 : : ! *********************************************************************
1215 : :
1216 : : write(message,'(4a)') ch10,&
1217 : 0 : & ' BigDFT support has not been enabled.', ch10, &
1218 : 0 : & ' Action, used the flag --enable-bigdft when configuring.'
1219 : 0 :
1220 : : if (PRESENT(file) .and. PRESENT(line)) then
1221 [ # # ]: 0 : call msg_hndl(message,"ERROR","PERS",file=file,line=line)
1222 : 0 : else
1223 : : call msg_hndl(message,"ERROR", "PERS")
1224 : 0 : end if
1225 : :
1226 : : end subroutine bigdft_lib_error
1227 : 0 : !!***
1228 : :
1229 : : !----------------------------------------------------------------------
1230 : :
1231 : : !!****f* m_errors/xlf_set_sighandler
1232 : : !! NAME
1233 : : !! xlf_set_sighandler
1234 : : !!
1235 : : !! FUNCTION
1236 : : !! Set the signal handler for IBM XLF
1237 : : !!
1238 : : !! NOTES
1239 : : !! See http://publib.boulder.ibm.com/infocenter/compbgpl/v9v111/index.jsp?topic=/com.ibm.xlf111.bg.doc/xlfopg/fptrap.htm
1240 : : !! The XL Fortran exception handlers and related routines are:
1241 : : !! xl__ieee
1242 : : !! Produces a traceback and an explanation of the signal and continues execution by supplying the default IEEE result
1243 : : !! for the failed computation. This handler allows the program to produce the same results as if exception detection was not turned on.
1244 : : !! xl__trce
1245 : : !! Produces a traceback and stops the program.
1246 : : !! xl__trcedump
1247 : : !! Produces a traceback and a core file and stops the program.
1248 : : !! xl__sigdump
1249 : : !! Provides a traceback that starts from the point at which it is called and provides information about the signal.
1250 : : !! You can only call it from inside a user-written signal handler.
1251 : : !! It does not stop the program. To successfully continue, the signal handler must perform some cleanup after calling this subprogram.
1252 : : !! xl__trbk
1253 : : !! Provides a traceback that starts from the point at which it is called.
1254 : : !! You call it as a subroutine from your code, rather than specifying it with the -qsigtrap option. It requires no parameters. It does not stop the program.
1255 : : !!
1256 : : !! SOURCE
1257 : :
1258 : : subroutine xlf_set_sighandler()
1259 : 0 :
1260 : : #ifdef FC_IBM
1261 : : call SIGNAL(SIGTRAP, xl__trcedump)
1262 : : call SIGNAL(SIGFPE, xl__trcedump)
1263 : : #endif
1264 : :
1265 : : end subroutine xlf_set_sighandler
1266 : 0 : !!***
1267 : :
1268 : : !----------------------------------------------------------------------
1269 : :
1270 : : !!****f* m_errors/abinit_doctor
1271 : : !! NAME
1272 : : !! abinit_doctor
1273 : : !!
1274 : : !! FUNCTION
1275 : : !! Perform checks on memory leaks and leaking file descriptors at the end of the run.
1276 : : !!
1277 : : !! INPUTS
1278 : : !! prefix=Prefix for output file (usually "__nameofprogram" e.g. __cut3d)
1279 : : !! [print_mem_report]=0 to disable the test on memory leaks (used in Abinit if bigdft is activated).
1280 : : !! Default: 1, i.e. memory check is always activated.
1281 : : !!
1282 : : !! SOURCE
1283 : :
1284 : : subroutine abinit_doctor(prefix, print_mem_report)
1285 : 1781 :
1286 : : !Arguments ------------------------------------
1287 : : integer,optional,intent(in) :: print_mem_report
1288 : : character(len=*),intent(in) :: prefix
1289 : :
1290 : : !Local variables-------------------------------
1291 : : !scalars
1292 : : integer,parameter :: master=0
1293 : : integer :: do_mem_report, my_rank
1294 : : character(len=5000) :: msg
1295 : : #ifdef HAVE_MEM_PROFILING
1296 : : integer :: ii,ierr,unt
1297 : : integer(i8b) :: memtot, nalloc, nfree, nalloc_c, nfree_c
1298 : : character(len=fnlen) :: path
1299 : : character(len=5000) :: errmsg
1300 : : #endif
1301 : : ! *************************************************************************
1302 : :
1303 : : do_mem_report = 1; if (present(print_mem_report)) do_mem_report = print_mem_report
1304 : 1781 : my_rank = xmpi_comm_rank(xmpi_world)
1305 : 1781 :
1306 : : if (allocated(INPUT_STRING)) then
1307 [ + + ]: 1781 : ABI_FREE_SCALAR(INPUT_STRING)
1308 : 1597 : end if
1309 : :
1310 : : #ifdef HAVE_MEM_PROFILING
1311 : : errmsg = ""; ierr = 0
1312 : :
1313 : : ! Test on memory leaks.
1314 : : call abimem_get_info(nalloc, nfree, memtot, nalloc_c, nfree_c)
1315 : : call abimem_shutdown()
1316 : :
1317 : : if (do_mem_report == 1) then
1318 : :
1319 : : ! Check memory allocated in C.
1320 : : if (nalloc_c == nfree_c) then
1321 : : write(msg,'(2a, 2(a,i0), a)') &
1322 : : '- [ALL OK] MEMORY CONSUMPTION REPORT FOR C CODE:',ch10, &
1323 : : '- There were ',nalloc_c,' allocations and ',nfree_c,' deallocations in C code'
1324 : : else
1325 : : ! This msg will make the test fail if the memory leak occurs on master (no dash in the first column)
1326 : : write(msg,'(2a,2(a,i0),3a)') &
1327 : : 'MEMORY CONSUMPTION REPORT FOR C CODE:',ch10, &
1328 : : ' There were ',nalloc_c,' allocations and ',nfree_c,' deallocations in C code',ch10, &
1329 : : " Check your C code for memory leaks. Note that the abimem.py script does not support allocations in C"
1330 : : ! And this will make the code call mpi_abort if the leak occurs on my_rank != master
1331 : : ierr = ierr + 1
1332 : : errmsg = strcat(errmsg, ch10, msg)
1333 : : end if
1334 : : if (my_rank == master) call wrtout(ab_out, msg)
1335 : : call wrtout(std_out, msg)
1336 : :
1337 : : ! Check memory allocated in Fortran.
1338 : : if (nalloc == nfree .and. memtot == 0) then
1339 : : write(msg,'(3a,i0,a,i0,3a,i0)') &
1340 : : '- [ALL OK] MEMORY CONSUMPTION REPORT FOR FORTRAN CODE:',ch10, &
1341 : : '- There were ',nalloc,' allocations and ',nfree,' deallocations in Fortran',ch10, &
1342 : : '- Remaining memory at the end of the calculation is ',memtot
1343 : : else
1344 : : ! This msg will make the test fail if the memory leak occurs on master (no dash in the first column)
1345 : : write(msg,'(2a,2(a,i0),3a,f12.4,1x,11a)') &
1346 : : 'MEMORY CONSUMPTION REPORT FOR FORTRAN CODE:',ch10, &
1347 : : ' There were ',nalloc,' allocations and ',nfree,' deallocations in Fortran',ch10, &
1348 : : ' Remaining memory at the end of the calculation: ',memtot * b2Mb, " (Mb)", ch10, &
1349 : : ' As a help for debugging, you might set call abimem_init(2) in the main program,', ch10, &
1350 : : ' or use the command line option `abinit run.abi --abimem-level 2`', ch10, &
1351 : : ' then use tests/Scripts/abimem.py to analyse the file abimem_rank[num].mocc that has been created,',ch10, &
1352 : : ' e.g. from tests/Scripts issue the command: ./abimem.py leaks ../<dir>/<subdir>/abimem_rank0.mocc',ch10, &
1353 : : ' Note that abimem files can easily be multiple GB in size so do not use this option normally!'
1354 : : ! And this will make the code call mpi_abort if the leak occurs on my_rank != master
1355 : : ierr = ierr + 1
1356 : : errmsg = strcat(errmsg, ch10, msg)
1357 : : end if
1358 : :
1359 : : else
1360 : : write(msg,'(3a)') &
1361 : : '- MEMORY CONSUMPTION REPORT:',ch10, &
1362 : : '- Memory profiling is activated but not yet usable when bigdft is used'
1363 : : end if
1364 : : if (my_rank == master) call wrtout(ab_out, msg)
1365 : : call wrtout(std_out, msg)
1366 : :
1367 : : ! Test whether all logical units have been closed.
1368 : : ! If you wonder why I'm doing this, remember that there's a per-user
1369 : : ! limit on the maximum number of open file descriptors. Hence descriptors
1370 : : ! represent a precious resource and we should close them as soon as possible.
1371 : : ii = num_opened_units(ignore=[std_err, std_in, std_out, ab_out])
1372 : : if (ii > 0) then
1373 : : path = strcat(prefix, "_lunits_rank", itoa(my_rank), ".flun")
1374 : : if (open_file(path, msg, newunit=unt) /= 0) then
1375 : : ABI_ERROR(msg)
1376 : : end if
1377 : : call show_units(unt)
1378 : : close(unt)
1379 : : write(msg, "(a,i0,2a)")"Leaking ",ii," Fortran logical units. See: ",trim(path)
1380 : : errmsg = strcat(errmsg, ch10, msg)
1381 : : ierr = ierr + 1
1382 : : if (my_rank == master) call wrtout(ab_out, msg)
1383 : : call wrtout(std_out, msg)
1384 : : end if
1385 : :
1386 : : call xmpi_barrier(xmpi_world)
1387 : : if (ierr /= 0) then
1388 : : ABI_ERROR(errmsg)
1389 : : end if
1390 : :
1391 : : #else
1392 : : ABI_UNUSED(prefix)
1393 : : #endif
1394 : :
1395 : : ! Check for pending requests.
1396 [ - + ]: 1781 : if (xmpi_count_requests /= 0) then
1397 : 0 : write(msg, "(a,i0,a)")"Leaking ", xmpi_count_requests, " MPI requests at the end of the run"
1398 : 0 : ABI_WARNING(msg)
1399 : : #ifdef HAVE_MEM_PROFILING
1400 : : ABI_ERROR(msg)
1401 : : #endif
1402 : : end if
1403 : :
1404 : : ! Check for MPI windows.
1405 [ - + ]: 1781 : if (xmpi_count_wins /= 0) then
1406 : 0 : write(msg, "(a,i0,a)")"Leaking ", xmpi_count_wins, " MPI windows at the end of the run"
1407 : 0 : ABI_WARNING(msg)
1408 : : #ifdef HAVE_MEM_PROFILING
1409 : : ABI_ERROR(msg)
1410 : : #endif
1411 : : end if
1412 : :
1413 : 1781 : end subroutine abinit_doctor
1414 : : !!***
1415 : :
1416 : : !!****f* m_errors/abi_abort
1417 : : !! NAME
1418 : : !! abi_abort
1419 : : !!
1420 : : !! FUNCTION
1421 : : !! Routine for clean exit of f90 code, taking into account possible parallelization.
1422 : : !!
1423 : : !! Note the this routine is private and should never be called explicitly.
1424 : : !! Please, use the macros:
1425 : : !! MSG_ERROR, MSG_BUG
1426 : : !! defined in abi_common.h to abort the execution.
1427 : : !! XG : this is not true, in very rare cases, ABINIT has to exit without giving an error (e.g. for non-zero prtkpt )
1428 : : !!
1429 : : !! INPUTS
1430 : : !! exit_status=(optional, default=1 or -1, see below) the return code of the routine
1431 : : !! mode_paral=
1432 : : !! 'COLL' if all procs are calling the routine with the same message to be
1433 : : !! written once only or
1434 : : !! 'PERS' if the procs are calling the routine with different mesgs
1435 : : !! each to be written, or if one proc is calling the routine
1436 : : !! print_config=(optional, default=true)
1437 : : !! if true print out several information before leaving
1438 : : !!
1439 : : !! OUTPUT
1440 : : !! (only writing, then stop)
1441 : : !!
1442 : : !! NOTES
1443 : : !! By default, it uses "call exit(1)", that is not completely portable.
1444 : : !!
1445 : : !! SOURCE
1446 : :
1447 : 16 : subroutine abi_abort(mode_paral,exit_status,print_config)
1448 : :
1449 : : !Arguments ------------------------------------
1450 : : character(len=4),intent(in) :: mode_paral
1451 : : integer,intent(in),optional :: exit_status
1452 : : logical,intent(in),optional :: print_config
1453 : :
1454 : : !Local variables-------------------------------
1455 : : logical :: print_config_
1456 : : ! **********************************************************************
1457 : :
1458 : 16 : call wrtout(std_out, ch10//' abinit_abort: decision taken to exit. Check above messages for more info', 'PERS')
1459 : :
1460 : : ! Caveat: Do not use MPI collective calls!
1461 [ - + ]: 16 : if (mode_paral == "COLL") then
1462 : 0 : call wrtout(std_out,"Why are you using COLL? Are you sure that ALL the processors are calling abi_abort?")
1463 : : end if
1464 : :
1465 : : ! Dump configuration before exiting
1466 [ + - ]: 16 : print_config_=.False.; if (present(print_config)) print_config_=print_config
1467 [ - + ]: 16 : if (print_config_) then
1468 : 0 : call print_kinds()
1469 : 0 : call xmpi_show_info()
1470 : 0 : call dump_config(std_out)
1471 : : end if
1472 : :
1473 [ + + ]: 16 : if (present(exit_status)) then
1474 : 14 : call xmpi_abort(exit_status=exit_status)
1475 : : else
1476 : 2 : call xmpi_abort()
1477 : : end if
1478 : :
1479 : 0 : end subroutine abi_abort
1480 : : !!***
1481 : :
1482 : : !!****f* m_errors/abi_cabort
1483 : : !! NAME
1484 : : !! abi_cabort
1485 : : !!
1486 : : !! FUNCTION
1487 : : !! C-interoperable version of abi_abort
1488 : :
1489 : 0 : subroutine abi_cabort() bind(C, name='abi_cabort')
1490 : :
1491 : 0 : call abi_abort("COLL", exit_status=1, print_config=.False.)
1492 : :
1493 : 0 : end subroutine abi_cabort
1494 : : !!***
1495 : :
1496 : : END MODULE m_errors
1497 : : !!***
|
