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 231456 : 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 231456 : character(len=LEN(message)) :: my_msg
682 231456 : character(len=MAX(4*LEN(message),2000)) :: sbuf ! Increase size and keep fingers crossed!
683 : ! *********************************************************************
684 :
685 231456 : unit_ = std_out; if (present(unit)) unit_ = unit
686 :
687 231456 : if (PRESENT(line)) then
688 231456 : 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 231456 : if (unit_ == ab_out) f90line = 0
695 231456 : write(lnum,"(i0)")f90line
696 :
697 231456 : if (PRESENT(file)) then
698 231456 : f90name = basename(file)
699 : else
700 0 : f90name='Subroutine Unknown'
701 : end if
702 :
703 231456 : my_msg = lstrip(message)
704 :
705 694366 : select case (toupper(level))
706 :
707 : case ('COMMENT', 'WARNING')
708 :
709 231454 : write(sbuf,'(8a,i0,7a)')ch10,&
710 231454 : "--- !",TRIM(level),ch10,&
711 231454 : "src_file: ",TRIM(f90name),ch10,&
712 231454 : "src_line: ",f90line,ch10,&
713 231454 : "message: |",ch10,TRIM(indent(my_msg)),ch10,&
714 462908 : "...",ch10
715 231454 : 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 231458 : 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 231454 : 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 1762 :
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 1762 : my_rank = xmpi_comm_rank(xmpi_world)
1305 1762 :
1306 : if (allocated(INPUT_STRING)) then
1307 1762 : ABI_FREE_SCALAR(INPUT_STRING)
1308 1580 : 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 1762 : 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 1762 : 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 1762 : 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 : !!***
|
