TABLE OF CONTENTS

ABINIT/m_errors [ Modules ]

[ Top ] [ Modules ]

NAME

  m_errors

FUNCTION

  This module contains low-level procedures to check assertions and handle errors.

COPYRIGHT

 Copyright (C) 2008-2024 ABINIT group (MG,YP,NCJ,MT)
 This file is distributed under the terms of the
 GNU General Public License, see ~abinit/COPYING
 or http://www.gnu.org/copyleft/gpl.txt .

SOURCE

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 #ifdef HAVE_NETCDF
29  use netcdf
30 #endif
31 #ifdef HAVE_MPI2
32  use mpi
33 #endif
34 #ifdef FC_NAG
35  use f90_unix_proc
36 #endif
37 #ifdef FC_INTEL
38  use ifcore
39 #endif
40 
41  use iso_c_binding,     only : c_ptr, c_size_t, c_associated
42 
43  use m_io_tools,        only : flush_unit, lock_and_write, file_exists, num_opened_units, show_units, open_file
44  use m_fstrings,        only : toupper, basename, indent, lstrip, atoi, strcat, itoa
45  use m_build_info,      only : dump_config, abinit_version
46  use m_cppopts_dumper,  only : dump_cpp_options
47  use m_optim_dumper,    only : dump_optim
48 
49  implicit none
50 
51 #if defined HAVE_MPI1
52 include 'mpif.h'
53 #endif
54 
55 #ifdef FC_IBM
56 include "fexcp.h"
57 #endif
58 
59  private

m_errors/abi_abort [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  abi_abort

FUNCTION

  Routine for clean exit of f90 code, taking into account possible parallelization.

  Note the this routine is private and should never be called explicitly.
  Please, use the macros:
    MSG_ERROR, MSG_BUG
  defined in abi_common.h to abort the execution.
  XG : this is not true, in very rare cases, ABINIT has to exit without giving an error (e.g. for non-zero prtkpt )

INPUTS

  exit_status=(optional, default=1 or -1, see below) the return code of the routine
  mode_paral=
   'COLL' if all procs are calling the routine with the same message to be
     written once only or
   'PERS' if the procs are calling the routine with different mesgs
     each to be written, or if one proc is calling the routine
  print_config=(optional, default=true)
       if true print out several information before leaving

OUTPUT

  (only writing, then stop)

NOTES

  By default, it uses "call exit(1)", that is not completely portable.

SOURCE

1446 subroutine abi_abort(mode_paral,exit_status,print_config)
1447 
1448 !Arguments ------------------------------------
1449  character(len=4),intent(in) :: mode_paral
1450  integer,intent(in),optional :: exit_status
1451  logical,intent(in),optional :: print_config
1452 
1453 !Local variables-------------------------------
1454  logical :: print_config_
1455 
1456 ! **********************************************************************
1457 
1458  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  if (mode_paral == "COLL") then
1462    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  print_config_=.False.; if (present(print_config)) print_config_=print_config
1467  if (print_config_) then
1468    call print_kinds()
1469    call xmpi_show_info()
1470    call dump_config(std_out)
1471  end if
1472 
1473  if (present(exit_status)) then
1474    call xmpi_abort(exit_status=exit_status)
1475  else
1476    call xmpi_abort()
1477  end if
1478 
1479 end subroutine abi_abort

m_errors/abi_cabort [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  abi_cabort

FUNCTION

  C-interoperable version of abi_abort

m_errors/abinit_doctor [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  abinit_doctor

FUNCTION

 Perform checks on memory leaks and leaking file descriptors at the end of the run.

INPUTS

  prefix=Prefix for output file  (usually "__nameofprogram" e.g. __cut3d)
  [print_mem_report]=0 to disable the test on memory leaks (used in Abinit if bigdft is activated).
    Default: 1, i.e. memory check is always activated.

SOURCE

1295 subroutine abinit_doctor(prefix, print_mem_report)
1296 
1297 !Arguments ------------------------------------
1298  integer,optional,intent(in) :: print_mem_report
1299  character(len=*),intent(in) :: prefix
1300 
1301 !Local variables-------------------------------
1302 !scalars
1303  integer,parameter :: master=0
1304  integer :: do_mem_report, my_rank
1305  character(len=5000) :: msg
1306 #ifdef HAVE_MEM_PROFILING
1307  integer :: ii,ierr,unt
1308  integer(i8b) :: memtot, nalloc, nfree, nalloc_c, nfree_c
1309  character(len=fnlen) :: path
1310  character(len=5000) :: errmsg
1311 #endif
1312 
1313 ! *************************************************************************
1314 
1315  do_mem_report = 1; if (present(print_mem_report)) do_mem_report = print_mem_report
1316  my_rank = xmpi_comm_rank(xmpi_world)
1317 
1318 #ifdef HAVE_MEM_PROFILING
1319  errmsg = ""; ierr = 0
1320 
1321  ! Test on memory leaks.
1322  call abimem_get_info(nalloc, nfree, memtot, nalloc_c, nfree_c)
1323  call abimem_shutdown()
1324 
1325  if (do_mem_report == 1) then
1326 
1327    ! Check memory allocated in C.
1328    if (nalloc_c == nfree_c) then
1329      write(msg,'(2a, 2(a,i0), a)') &
1330        '- [ALL OK] MEMORY CONSUMPTION REPORT FOR C CODE:',ch10, &
1331        '-   There were ',nalloc_c,' allocations and ',nfree_c,' deallocations in C code'
1332    else
1333      ! This msg will make the test fail if the memory leak occurs on master (no dash in the first column)
1334      write(msg,'(2a,2(a,i0),3a)') &
1335        'MEMORY CONSUMPTION REPORT FOR C CODE:',ch10, &
1336        '   There were ',nalloc_c,' allocations and ',nfree_c,' deallocations in C code',ch10, &
1337        "   Check your C code for memory leaks. Note that the abimem.py script does not support allocations in C"
1338      ! And this will make the code call mpi_abort if the leak occurs on my_rank != master
1339      ierr = ierr + 1
1340      errmsg = strcat(errmsg, ch10, msg)
1341    end if
1342    if (my_rank == master) call wrtout(ab_out, msg)
1343    call wrtout(std_out, msg)
1344 
1345    ! Check memory allocated in Fortran.
1346    if (nalloc == nfree .and. memtot == 0) then
1347      write(msg,'(3a,i0,a,i0,3a,i0)') &
1348        '- [ALL OK] MEMORY CONSUMPTION REPORT FOR FORTRAN CODE:',ch10, &
1349        '-   There were ',nalloc,' allocations and ',nfree,' deallocations in Fortran',ch10, &
1350        '-   Remaining memory at the end of the calculation is ',memtot
1351    else
1352      ! This msg will make the test fail if the memory leak occurs on master (no dash in the first column)
1353      write(msg,'(2a,2(a,i0),3a,f12.4,1x,11a)') &
1354        'MEMORY CONSUMPTION REPORT FOR FORTRAN CODE:',ch10, &
1355        '   There were ',nalloc,' allocations and ',nfree,' deallocations in Fortran',ch10, &
1356        '   Remaining memory at the end of the calculation: ',memtot * b2Mb, " (Mb)", ch10, &
1357        '   As a help for debugging, you might set call abimem_init(2) in the main program,', ch10, &
1358        '   or use the command line option `abinit run.abi --abimem-level 2`', ch10, &
1359        '   then use tests/Scripts/abimem.py to analyse the file abimem_rank[num].mocc that has been created,',ch10, &
1360        '   e.g. from tests/Scripts issue the command: ./abimem.py leaks ../<dir>/<subdir>/abimem_rank0.mocc',ch10, &
1361        '   Note that abimem files can easily be multiple GB in size so do not use this option normally!'
1362      ! And this will make the code call mpi_abort if the leak occurs on my_rank != master
1363      ierr = ierr + 1
1364      errmsg = strcat(errmsg, ch10, msg)
1365    end if
1366 
1367  else
1368    write(msg,'(3a)') &
1369      '- MEMORY CONSUMPTION REPORT:',ch10, &
1370      '- Memory profiling is activated but not yet usable when bigdft is used'
1371  end if
1372  if (my_rank == master) call wrtout(ab_out, msg)
1373  call wrtout(std_out, msg)
1374 
1375  ! Test whether all logical units have been closed.
1376  ! If you wonder why I'm doing this, remember that there's a per-user
1377  ! limit on the maximum number of open file descriptors. Hence descriptors
1378  ! represent a precious resource and we should close them as soon as possible.
1379  ii = num_opened_units(ignore=[std_err, std_in, std_out, ab_out])
1380  if (ii > 0) then
1381    path = strcat(prefix, "_lunits_rank", itoa(my_rank), ".flun")
1382    if (open_file(path, msg, newunit=unt) /= 0) then
1383      ABI_ERROR(msg)
1384    end if
1385    call show_units(unt)
1386    close(unt)
1387    write(msg, "(a,i0,2a)")"Leaking ",ii," Fortran logical units. See: ",trim(path)
1388    errmsg = strcat(errmsg, ch10, msg)
1389    ierr = ierr + 1
1390    if (my_rank == master) call wrtout(ab_out, msg)
1391    call wrtout(std_out, msg)
1392  end if
1393 
1394  call xmpi_barrier(xmpi_world)
1395  if (ierr /= 0) then
1396    ABI_ERROR(errmsg)
1397  end if
1398 
1399 #else
1400  ABI_UNUSED(prefix)
1401 #endif
1402 
1403  ! Check for pending requests.
1404  if (xmpi_count_requests /= 0) then
1405    write(msg, "(a,i0,a)")"Leaking ", xmpi_count_requests, " MPI requests at the end of the run"
1406    ABI_WARNING(msg)
1407 #ifdef HAVE_MEM_PROFILING
1408    ABI_ERROR(msg)
1409 #endif
1410  end if
1411 
1412 end subroutine abinit_doctor

m_errors/assert1 [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  assert1

FUNCTION

  Routines for argument checking and error handling. Report and die if
  any logical is false (used for arg range checking).

INPUTS

  l1,l2,.. logical values to be checked (array version is also provided)
  message(len=*)=tag with additiona information

SOURCE

292 subroutine assert1(l1,message,file,line)
293 
294 !Arguments ------------------------------------
295  integer,optional,intent(in) :: line
296  character(len=*),intent(in) :: message
297  character(len=*),optional,intent(in) :: file
298  logical,intent(in) :: l1
299 
300 !Local variables-------------------------------
301  integer :: f90line=0
302  character(len=500) :: f90name='Subroutine Unknown'
303 ! *************************************************************************
304 
305  if (.not.l1) then
306    if (PRESENT(line)) f90line=line
307    if (PRESENT(file)) f90name= basename(file)
308    call msg_hndl(message,'ERROR','PERS',f90name,f90line)
309  end if
310 
311 end subroutine assert1

m_errors/assert2 [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  assert2

FUNCTION

  Routines for argument checking and error handling. Report and die if

INPUTS

  l1,l2,.. logical values to be checked (array version is also provided)
  message(len=*)=tag with additional information

SOURCE

330 subroutine assert2(l1,l2,message,file,line)
331 
332 !Arguments ------------------------------------
333  integer,optional,intent(in) :: line
334  character(len=*),intent(in) :: message
335  character(len=*),optional,intent(in) :: file
336  logical,intent(in) :: l1,l2
337 
338 !Local variables-------------------------------
339  integer :: f90line=0
340  character(len=500) :: f90name='Subroutine Unknown'
341 ! *************************************************************************
342 
343  if (.not.(l1.and.l2)) then
344   if (PRESENT(line)) f90line=line
345   if (PRESENT(file)) f90name= basename(file)
346   call msg_hndl(message,'ERROR','PERS',f90name,f90line)
347  end if
348 
349 end subroutine assert2

m_errors/assert3 [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  assert3

FUNCTION

  Routines for argument checking and error handling. Report and die if
  any logical is false (used for arg range checking).

INPUTS

  l1,l2,.. logical values to be checked (array version is also provided)
  message(len=*)=tag with additional information

SOURCE

368 subroutine assert3(l1,l2,l3,message,file,line)
369 
370 !Arguments ------------------------------------
371  integer,optional,intent(in) :: line
372  character(len=*),intent(in) :: message
373  character(len=*),optional,intent(in) :: file
374  logical,intent(in) :: l1,l2,l3
375 
376 !Local variables-------------------------------
377  integer :: f90line=0
378  character(len=500) :: f90name='Subroutine Unknown'
379 ! *************************************************************************
380 
381  if (.not.(l1.and.l2.and.l3)) then
382   if (PRESENT(line)) f90line=line
383   if (PRESENT(file)) f90name= basename(file)
384   call msg_hndl(message,'ERROR','PERS',f90name,f90line)
385  end if
386 
387 end subroutine assert3

m_errors/assert4 [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  assert4

FUNCTION

  Routines for argument checking and error handling. Report and die if
  any logical is false (used for arg range checking).

INPUTS

  l1,l2,.. logical values to be checked (array version is also provided)
  message(len=*)=tag with additional information

SOURCE

406 subroutine assert4(l1,l2,l3,l4,message,file,line)
407 
408 !Arguments ------------------------------------
409  integer,optional,intent(in) :: line
410  character(len=*),intent(in) :: message
411  character(len=*),optional,intent(in) :: file
412  logical,intent(in) :: l1,l2,l3,l4
413 
414 !Local variables-------------------------------
415  integer :: f90line=0
416  character(len=500) :: f90name='Subroutine Unknown'
417 ! *************************************************************************
418 
419  if (.not.(l1.and.l2.and.l3.and.l4)) then
420   if (PRESENT(line)) f90line=line
421   if (PRESENT(file)) f90name= basename(file)
422   call msg_hndl(message,'ERROR','PERS',f90name,f90line)
423  end if
424 
425 end subroutine assert4

m_errors/assert_eq2 [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  assert_eq2

FUNCTION

  Report and die gracefully if integers not all equal (used for size checking).

INPUTS

  l1,l2,.. Integers to be checked (array version is also provided)
  message(len=*)=tag with additional information

SOURCE

131 function assert_eq2(l1,l2,message,file,line)
132 
133 !Arguments ------------------------------------
134  integer,intent(in) :: l1,l2
135  integer,optional,intent(in) :: line
136  integer :: assert_eq2
137  character(len=*),intent(in) :: message
138  character(len=*),optional,intent(in) :: file
139 
140 !Local variables-------------------------------
141  integer :: f90line=0
142  character(len=500) :: f90name='Subroutine Unknown'
143 
144 ! *************************************************************************
145 
146  if (l1==l2) then
147   assert_eq2=l1
148  else
149   if (PRESENT(line)) f90line=line
150   if (PRESENT(file)) f90name= basename(file)
151   call msg_hndl(message,'ERROR','PERS',f90name,line)
152  end if
153 
154 end function assert_eq2

m_errors/assert_eq3 [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  assert_eq3

FUNCTION

  Report and die gracefully if integers not all equal (used for size checking).

INPUTS

  l1,l2,.. Integers to be checked (array version is also provided)
  message(len=*)=tag with additional information

SOURCE

172 function assert_eq3(l1,l2,l3,message,file,line)
173 
174 !Arguments ------------------------------------
175  integer,intent(in) :: l1,l2,l3
176  integer,optional,intent(in) :: line
177  integer :: assert_eq3
178  character(len=*),intent(in) :: message
179  character(len=*),optional,intent(in) :: file
180 
181 !Local variables-------------------------------
182  integer :: f90line=0
183  character(len=500) :: f90name='Subroutine Unknown'
184 ! *************************************************************************
185 
186  if (l1==l2.and.l2==l3) then
187   assert_eq3=l1
188  else
189   if (PRESENT(line)) f90line=line
190   if (PRESENT(file)) f90name= basename(file)
191   call msg_hndl(message,'ERROR','PERS',f90name,line)
192  end if
193 
194 end function assert_eq3

m_errors/assert_eq4 [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  assert_eq4

FUNCTION

  Report and die gracefully if integers not all equal (used for size checking).

INPUTS

  l1,l2,.. Integers to be checked (array version is also provided)
  message(len=*)=tag with additional information

SOURCE

212 function assert_eq4(l1,l2,l3,l4,message,file,line)
213 
214 !Arguments ------------------------------------
215 !scalars
216  integer,intent(in) :: l1,l2,l3,l4
217  integer,optional,intent(in) :: line
218  integer :: assert_eq4
219  character(len=*),intent(in) :: message
220  character(len=*),optional,intent(in) :: file
221 
222 !Local variables-------------------------------
223  integer :: f90line=0
224  character(len=500) :: f90name='Subroutine Unknown'
225 ! *************************************************************************
226 
227  if (l1==l2.and.l2==l3.and.l3==l4) then
228   assert_eq4=l1
229  else
230   if (PRESENT(line)) f90line=line
231   if (PRESENT(file)) f90name= basename(file)
232   call msg_hndl(message,'ERROR','PERS',f90name,line)
233  end if
234 
235 end function assert_eq4

m_errors/assert_eqn [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  assert_eqn

FUNCTION

  Report and die gracefully if integers not all equal (used for size checking).

SOURCE

249 function assert_eqn(nn,message,file,line)
250 
251 !Arguments ------------------------------------
252 !scalars
253  integer,optional,intent(in) :: line
254  integer :: assert_eqn
255  character(len=*),intent(in) :: message
256  character(len=*),optional,intent(in) :: file
257 !arrays
258  integer,intent(in) :: nn(:)
259 
260 !Local variables-------------------------------
261  integer :: f90line=0
262  character(len=500) :: f90name='Subroutine Unknown'
263 ! *************************************************************************
264 
265  if (ALL(nn(2:)==nn(1))) then
266   assert_eqn=nn(1)
267  else
268   if (PRESENT(line)) f90line=line
269   if (PRESENT(file)) f90name= basename(file)
270   call msg_hndl(message,'ERROR','PERS',f90name,line)
271  end if
272 
273 end function assert_eqn

m_errors/assert_v [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  assert_v

FUNCTION

  Routines for argument checking and error handling. Report and die if
  any logical is false (used for arg range checking).

SOURCE

440 subroutine assert_v(n,message,file,line)
441 
442 !Arguments ------------------------------------
443  integer,optional,intent(in) :: line
444  character(len=*),intent(in) :: message
445  character(len=*),optional,intent(in) :: file
446  logical,intent(in) :: n(:)
447 
448 !Local variables-------------------------------
449  integer :: f90line=0
450  character(len=500) :: f90name='Subroutine Unknown'
451 ! *************************************************************************
452 
453  if (.not.ALL(n)) then
454   if (PRESENT(line)) f90line=line
455   if (PRESENT(file)) f90name= basename(file)
456   call msg_hndl(message,'ERROR','PERS',f90name,f90line)
457  end if
458 
459 end subroutine assert_v

m_errors/bigdft_lib_error [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  bigdft_lib_error

FUNCTION

  Stop the code if bigdft library has not been enabled.
  Interfaced with the CPP macro BIGDFT_NOTENABLED_ERROR

INPUTS

  line=line number of the file where problem occurred
  file=name of the f90 file containing the caller

SOURCE

1214 subroutine bigdft_lib_error(file,line)
1215 
1216 !Arguments ------------------------------------
1217  integer,optional,intent(in) :: line
1218  character(len=*),optional,intent(in) :: file
1219 
1220 !Local variables-------------------------------
1221  character(len=500) :: message
1222 
1223 ! *********************************************************************
1224 
1225   write(message,'(4a)') ch10,&
1226 &  ' BigDFT support has not been enabled.', ch10, &
1227 &  ' Action, used the flag --enable-bigdft when configuring.'
1228 
1229  if (PRESENT(file) .and. PRESENT(line)) then
1230    call msg_hndl(message,"ERROR","PERS",file=file,line=line)
1231  else
1232    call msg_hndl(message,"ERROR", "PERS")
1233  end if
1234 
1235 end subroutine bigdft_lib_error

m_errors/check_mpi_ierr [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  check_mpi_ierr

FUNCTION

  Basic error handler for MPI calls. This routine is usually interfaced through some macro defined in abi_common.h

INPUTS

  ierr=Exit status reported by an MPI call.
  line=line number of the file where problem occurred
  file=name of the f90 file containing the caller

OUTPUT

  Write error message thep stop execution.

SOURCE

840 subroutine check_mpi_ierr(ierr, msg, file, line)
841 
842 !Arguments ------------------------------------
843  integer,intent(in) :: ierr
844  integer,optional,intent(in) :: line
845  character(len=*),intent(in) :: msg
846  character(len=*),optional,intent(in) :: file
847 
848 !Local variables-------------------------------
849  integer,parameter :: mpi_msg_len=1000
850  integer :: f90line,ilen,ierr2
851  character(len=500) :: f90name='Subroutine Unknown'
852  character(len=mpi_msg_len) :: mpi_msg_error
853  character(len=mpi_msg_len+500) :: my_msg
854 ! *********************************************************************
855 
856 #ifdef HAVE_MPI
857  if (ierr==MPI_SUCCESS) RETURN
858  call MPI_ERROR_STRING(ierr, mpi_msg_error, ilen, ierr2)
859 #else
860  ilen=0; ierr2=0
861  mpi_msg_error = " Check_mpi_ierr should not be called in non-MPI mode!"
862  if (ierr==0) RETURN
863 #endif
864 
865  if (ilen>mpi_msg_len) write(std_out,*)" Warning_ MPI message has been truncated!"
866  if (ierr2/=0) write(std_out,*)" Warning: MPI_ERROR_STRING returned ierr2= ",ierr2
867 
868  f90line=0; if (PRESENT(line)) f90line=line
869  if (PRESENT(file)) f90name = basename(file)
870  my_msg = TRIM(msg)//ch10//TRIM(mpi_msg_error)
871 
872  call msg_hndl(my_msg,"ERROR","PERS",file=f90name,line=f90line)
873 
874 end subroutine check_mpi_ierr

m_errors/die [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  die

FUNCTION

  Stop smoothly the execution in case of unexpected events reporting the
  line number and the file name where the error occurred as well as the
  MPI rank of the processor. This routine is usually interfaced through
  some macro defined in abi_common.h

INPUTS

  message=String containing additional information on the nature of the problem
  line=Line number of the file where problem occurred
  f90name=Name of the f90 file containing the caller

SOURCE

617 subroutine die(message,file,line)
618 
619 !Arguments ------------------------------------
620  integer,optional,intent(in) :: line
621  character(len=*),intent(in) :: message
622  character(len=*),optional,intent(in) :: file
623 
624 !Local variables-------------------------------
625  integer :: rank
626  integer :: f90line=0
627  character(len=10) :: lnum,strank
628  character(len=500) :: f90name='Subroutine Unknown'
629  character(len=500) :: msg
630 
631 ! *********************************************************************
632 
633  if (PRESENT(line)) f90line=line
634  write(lnum,"(i0)")f90line
635 
636  ! === Determine my rank inside MPI_COMM_WORLD ===
637  rank = xmpi_comm_rank(xmpi_world)
638  write(strank,"(i0)")rank
639 
640  if (PRESENT(file)) f90name= basename(file)
641  msg=TRIM(f90name)//':'//TRIM(lnum)//' P'//TRIM(strank)
642 
643  write(msg,'(a,2x,2a,2x,a)')ch10,TRIM(msg),ch10,TRIM(message)
644 
645  call wrtout(std_out,msg,'PERS')
646  !if is_connected(ab_out)) call wrtout(ab_out,msg,'PERS')
647  call abi_abort('PERS')
648 
649 end subroutine die

m_errors/msg_hndl [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  msg_hndl

FUNCTION

  Basic error handler for abinit. This routine is usually interfaced through some macro defined in abi_common.h

INPUTS

  message=string containing additional information on the nature of the problem
  level=string defining the type of problem. Possible values are
   COMMENT
   WARNING
   ERROR
   STOP
   BUG
  mode_paral=Either "COLL" or "PERS".
  [line] = line number of the file where problem occurred
  [file] = name of the f90 file containing the caller
  [NODUMP]= if present dump config before stopping
  [NOSTOP]= if present don't stop even in the case of an error or a bug
  [unit]= Unit number (defaults to std_out)

OUTPUT

SOURCE

680 subroutine msg_hndl(message, level, mode_paral, file, line, NODUMP, NOSTOP, unit)
681 
682 !Arguments ------------------------------------
683  integer,optional,intent(in) :: line, unit
684  logical,optional,intent(in) :: NODUMP,NOSTOP
685  character(len=*),intent(in) :: level,message
686  character(len=*),optional,intent(in) :: file
687  character(len=*),intent(in) :: mode_paral
688 
689 !Local variables-------------------------------
690  integer :: f90line,ierr,unit_
691  logical :: is_open_unit
692  character(len=10) :: lnum
693  character(len=500) :: f90name
694  character(len=LEN(message)) :: my_msg
695  character(len=MAX(4*LEN(message),2000)) :: sbuf ! Increase size and keep fingers crossed!
696 
697 ! *********************************************************************
698  unit_ = std_out; if (present(unit)) unit_ = unit
699 
700  if (PRESENT(line)) then
701    f90line=line
702  else
703    f90line=0
704  end if
705  ! TODO: fldiff.py should ignore f90line when comparing files (we don't want to
706  ! update ref files if a new line is added to F90 source file!
707  if (unit_ == ab_out) f90line = 0
708  write(lnum,"(i0)")f90line
709 
710  if (PRESENT(file)) then
711    f90name = basename(file)
712  else
713    f90name='Subroutine Unknown'
714  end if
715 
716  my_msg = lstrip(message)
717 
718  select case (toupper(level))
719 
720  case ('COMMENT', 'WARNING')
721 
722    write(sbuf,'(8a,i0,7a)')ch10,&
723      "--- !",TRIM(level),ch10,&
724      "src_file: ",TRIM(f90name),ch10,&
725      "src_line: ",f90line,ch10,&
726      "message: |",ch10,TRIM(indent(my_msg)),ch10,&
727      "...",ch10
728    call wrtout(unit_, sbuf, mode_paral)
729 
730  case ('STOP')
731 
732    write(sbuf,'(9a)')ch10,&
733      "--- !",TRIM(level),ch10,&
734      "message: |",ch10,TRIM(indent(my_msg)),ch10,"..."
735    call wrtout(unit_, sbuf, mode_paral, do_flush=.True.)
736    if (.not.present(NOSTOP)) call abi_abort(mode_paral, print_config=.FALSE.)
737 
738  case default
739    ! ERROR' or 'BUG'
740    if ((.not.present(NOSTOP)).and.(.not.present(NODUMP))) then
741      ! Dump the backtrace if the compiler supports it.
742      if (m_errors_show_backtrace == 1) call show_backtrace()
743    end if
744 
745    write(sbuf,'(8a,i0,2a,i0,7a)')ch10,&
746      "--- !",TRIM(level),ch10,&
747      "src_file: ",TRIM(f90name),ch10,&
748      "src_line: ",f90line,ch10,&
749      "mpi_rank: ",xmpi_comm_rank(xmpi_world),ch10,&
750      "message: |",ch10,TRIM(indent(my_msg)),ch10,&
751      "...",ch10
752    call wrtout(unit_, sbuf, mode_paral)
753 
754    ! Write error message to ab_out is unit is connected.
755    inquire(unit=ab_out, opened=is_open_unit)
756    if (is_open_unit) call wrtout(ab_out, sbuf) !, mode_paral="PERS")
757 
758    if (.not.present(NOSTOP)) then
759      ! The first MPI proc that gets here, writes the ABI_MPIABORTFILE with the message!
760      ! The file is written only if nprocs > 1. Do not change this behaviour!
761      if (.not. file_exists(ABI_MPIABORTFILE) .and. xmpi_comm_size(xmpi_world) > 1) then
762         call lock_and_write(ABI_MPIABORTFILE, sbuf, ierr)
763      end if
764      ! And now we die!
765      call abi_abort(mode_paral, print_config=.FALSE.)
766    end if
767 
768  end select
769 
770 end subroutine msg_hndl

m_errors/netcdf_check [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  netcdf_check

FUNCTION

  Error handler for Netcdf calls.

INPUTS

  ncerr=Status error returned by the Netcdf library.
  msg=User-defined string with info on the action that was performed
  file= name of the file.
  line= line number.

NOTES

  This routine is usually interfaced with the macros defined in abi_common.h

SOURCE

482 subroutine netcdf_check(ncerr, msg, file, line)
483 
484 !Arguments ------------------------------------
485  integer,intent(in) :: ncerr
486  character(len=*),intent(in) :: msg
487  character(len=*),optional,intent(in) :: file
488  integer,optional,intent(in) :: line
489 
490 !Local variables-------------------------------
491  integer :: f90line
492  character(len=500) :: f90name
493  character(len=1024) :: nc_msg
494  character(len=2048) :: my_msg
495 
496 ! *************************************************************************
497 
498 #ifdef HAVE_NETCDF
499  if (ncerr /= NF90_NOERR) then
500 
501    f90line = 0; if (present(line)) f90line = line
502    f90name = 'Subroutine Unknown'; if (present(file)) f90name = basename(file)
503 
504    ! Append netcdf string to user-defined message.
505    write(nc_msg,'(3a)')' - NetCDF library returned: `', trim(nf90_strerror(ncerr)),"`"
506    my_msg = trim(msg) // trim(nc_msg)
507 
508    call msg_hndl(my_msg, "ERROR", "PERS", f90name, f90line)
509  end if
510 #endif
511 
512 end subroutine netcdf_check

m_errors/sentinel [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  sentinel

FUNCTION

  Announce the entering and the exiting from a function. Useful for poor-man debugging.

INPUTS

  level=1 when entering, 2 for exit.
  mode_paral= ['COLL'|'PERS'|'COLL_SILENT|PERS_SILENT']
   'COLL' and 'PERS' refer to the output mode used in wrtout to report the message.
   'COLL_SILENT' and 'PERS_SILENT' can be used if the procedure is called several times inside a loop.
   In this case sentinel will report only the first entry and the first exit using either 'COLL' or 'PERS' mode.
  file=File name
  func=Name of the procedure to be tested (passed through ABI_FUNC macro)
  [line]=Line number. Defaults to 0.

NOTES

  This routine is usually interfaced with the macros defined in abi_common.h

SOURCE

539 subroutine sentinel(level,mode_paral,file,func,line)
540 
541 !Arguments ------------------------------------
542  integer,intent(in) :: level
543  integer,optional,intent(in) :: line
544  character(len=*),intent(in) :: mode_paral
545  character(len=*),optional,intent(in) :: func
546  character(len=*),optional,intent(in) :: file
547 
548 !Local variables-------------------------------
549  integer,save :: level_save=0
550  integer :: ii
551  integer :: f90line
552  character(len=500),save :: func_save
553  character(len=4) :: my_mode
554  character(len=10) :: lnum
555  character(len=500) :: my_func, my_file
556  character(len=500) :: msg
557 
558 ! *********************************************************************
559 
560  ! initialize the variable
561  my_func = 'Function Unknown'; if (PRESENT(func)) my_func = basename(func)
562  my_file = "File Unknown"; if (PRESENT(file)) my_file = basename(file)
563 
564  level_save=level; func_save=my_func
565 
566  f90line=0; if (PRESENT(line)) f90line=line
567 
568  if (toupper(mode_paral)=='COLL_SILENT'.or.toupper(mode_paral)=='PERS_SILENT') then
569     ! * Silent mode, check if we are inside a loop.
570     if (level==level_save .and. my_func==func_save) RETURN
571     ii = index( toupper(mode_paral), '_SILENT')
572     my_mode=toupper(mode_paral(1:ii-1))
573  else ! * Normal mode.
574     my_mode=mode_paral
575  end if
576 
577  if (my_mode/='COLL'.or.my_mode/='PERS') my_mode='COLL'
578 
579  write(lnum,"(i0)")f90line
580  my_func= TRIM(my_func)//"@"//TRIM(my_file)//":"//TRIM(lnum)
581 
582  if (level==1) then
583     msg = ' '//TRIM(my_func)//' >>>>> ENTER'//ch10
584  else if (level==2) then
585     msg = ' '//TRIM(my_func)//' >>>>> EXIT '//ch10
586  else
587     call die('Wrong level', &
588 &   __FILE__,&
589 &   __LINE__)
590  end if
591 
592  call wrtout(std_out,msg,my_mode)
593  call flush_unit(std_out)
594 
595 end subroutine sentinel

m_errors/set_backtrace_onerr [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

 set_backtrace_onerr

FUNCTION

  1 to activate show_backtrace call in msg_hndl. 0 to disable it

SOURCE

784 subroutine set_backtrace_onerr(iflag)
785 
786 !Arguments ------------------------------------
787  integer,intent(in) :: iflag
788 ! *********************************************************************
789 
790   m_errors_show_backtrace = iflag
791 
792 end subroutine set_backtrace_onerr

m_errors/show_backtrace [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

 show_backtrace

FUNCTION

  shows a backtrace at an arbitrary place in user code.
  Program execution continues normally afterwards.
  The backtrace information is printed to the unit corresponding to ERROR_UNIT in ISO_FORTRAN_ENV.
  This is a (Gfortran extension| Ifort Extension)

SOURCE

809 subroutine show_backtrace()
810 
811 #if defined FC_GNU && defined HAVE_FC_BACKTRACE
812   call backtrace()  ! Gfortran extension
813 
814 #elif defined FC_INTEL
815   call TRACEBACKQQ(USER_EXIT_CODE=-1)  ! Ifort extension
816 #endif
817 
818 end subroutine show_backtrace

m_errors/unused_c_ptr [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  unused_c_ptr

FUNCTION

  Helper function used to silence compiler warnings due to unused variables.
  Interfaced via the ABI_UNUSED macro.

INPUTS

  var=type(c_ptr) value

OUTPUT

  None

SOURCE

1143 elemental subroutine unused_c_ptr(var)
1144 
1145 !Arguments ------------------------------------
1146 type(c_ptr), intent(IN) :: var
1147 
1148 !Local variables-------------------------------
1149 #ifdef FC_NAG
1150 logical :: dummy
1151 #else
1152 type(c_ptr) :: dummy
1153 #endif
1154 ! *********************************************************************
1155 
1156 #ifdef FC_NAG
1157 if (.false.) dummy = c_associated(var)
1158 #else
1159 dummy = var
1160 #endif
1161 
1162 end subroutine unused_c_ptr

m_errors/unused_c_size_t [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  unused_c_size_t

FUNCTION

  Helper function used to silence compiler warnings due to unused variables.
  Interfaced via the ABI_UNUSED macro.

INPUTS

  var=type(c_size_t) value

OUTPUT

  None

SOURCE

1184 elemental subroutine unused_c_size_t(var)
1185 
1186 !Arguments ------------------------------------
1187 integer(kind=c_size_t), intent(IN) :: var
1188 
1189 !Local variables-------------------------------
1190 integer(kind=c_size_t) :: dummy
1191 ! *********************************************************************
1192 
1193  dummy = var
1194 
1195 end subroutine unused_c_size_t

m_errors/unused_ch [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  unused_ch

FUNCTION

  Helper function used to silence compiler warnings due to unused variables.
  Interfaced via the ABI_UNUSED macro.

INPUTS

  var=Scalar character value

OUTPUT

  None

SOURCE

1111 elemental subroutine unused_ch(var)
1112 
1113 !Arguments ------------------------------------
1114  character(len=*),intent(in) :: var
1115 
1116 !Local variables-------------------------------
1117  character(len=LEN(var)) :: dummy
1118 ! *********************************************************************
1119 
1120  dummy = var
1121 
1122 end subroutine unused_ch

m_errors/unused_cplx_dpc [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  unused_cplx_dpc

FUNCTION

  Helper function used to silence compiler warnings due to unused variables.
  Interfaced via the ABI_UNUSED macro.

INPUTS

  var=Scalar complex value

OUTPUT

  None

SOURCE

1017 elemental subroutine unused_cplx_dpc(var)
1018 
1019 !Arguments ------------------------------------
1020  complex(dpc),intent(in) :: var
1021 
1022 !Local variables-------------------------------
1023  complex(dpc) :: dummy
1024 ! *********************************************************************
1025 
1026  dummy = var
1027 
1028 end subroutine unused_cplx_dpc

m_errors/unused_cplx_spc [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  unused_cplx_spc

FUNCTION

  Helper function used to silence compiler warnings due to unused variables.
  Interfaced via the ABI_UNUSED macro.

INPUTS

  var=Scalar complex value

OUTPUT

  None

SOURCE

985 elemental subroutine unused_cplx_spc(var)
986 
987 !Arguments ------------------------------------
988  complex(spc),intent(in) :: var
989 
990 !Local variables-------------------------------
991  complex(spc) :: dummy
992 ! *********************************************************************
993 
994  dummy = var
995 
996 end subroutine unused_cplx_spc

m_errors/unused_int [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  unused_int

FUNCTION

  Helper function used to silence compiler warnings due to unused variables.
  Interfaced via the ABI_UNUSED macro.

INPUTS

  var=Scalar integer value

OUTPUT

  None

SOURCE

895 elemental subroutine unused_int(var)
896 
897 !Arguments ------------------------------------
898  integer,intent(in) :: var
899 
900 !Local variables-------------------------------
901  integer :: dummy
902 ! *********************************************************************
903 
904  dummy = var
905 
906 end subroutine unused_int

m_errors/unused_logical [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  unused_logical

FUNCTION

  Helper function used to silence compiler warnings due to unused variables.
  Interfaced via the ABI_UNUSED macro.

INPUTS

  var=Scalar logical value

OUTPUT

  None

SOURCE

1049 elemental subroutine unused_logical(var)
1050 
1051 !Arguments ------------------------------------
1052  logical,intent(in) :: var
1053 
1054 !Local variables-------------------------------
1055  logical :: dummy
1056 ! *********************************************************************
1057 
1058  dummy = var
1059 
1060 end subroutine unused_logical

m_errors/unused_logical1B [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  unused_logical1B

FUNCTION

  Helper function used to silence compiler warnings due to unused variables.
  Interfaced via the ABI_UNUSED macro.

INPUTS

  var= 1 Byte Scalar logical value

OUTPUT

  None

SOURCE

1079 elemental subroutine unused_logical1B(var)
1080 
1081 !Arguments ------------------------------------
1082  logical*1,intent(in) :: var
1083 
1084 !Local variables-------------------------------
1085  logical :: dummy
1086 ! *********************************************************************
1087 
1088  dummy = var
1089 
1090 end subroutine unused_logical1B

m_errors/unused_real_dp [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  unused_real_dp

FUNCTION

  Helper function used to silence warning messages due to unused variables.
  Interfaced via the ABI_UNUSED macro.

INPUTS

  var=Scalar real value.

OUTPUT

  None

SOURCE

927 elemental subroutine unused_real_dp(var)
928 
929 !Arguments ------------------------------------
930  real(dp),intent(in) :: var
931 
932 !Local variables-------------------------------
933  real(dp) :: dummy
934 ! *********************************************************************
935 
936  dummy = var
937 
938 end subroutine unused_real_dp

m_errors/unused_real_sp [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  unused_real_sp

FUNCTION

  Helper function used to silence compiler warnings due to unused variables.
  Interfaced via the ABI_UNUSED macro. Target: one-dimensional real(dp) vector.

SOURCE

953 elemental subroutine unused_real_sp(var)
954 
955 !Arguments ------------------------------------
956  real(sp),intent(in) :: var
957 
958 !Local variables-------------------------------
959  real(sp) :: dummy
960 ! *********************************************************************
961 
962  dummy = var
963 
964 end subroutine unused_real_sp

m_errors/xlf_set_sighandler [ Functions ]

[ Top ] [ m_errors ] [ Functions ]

NAME

  xlf_set_sighandler

FUNCTION

   Set the signal handler for IBM XLF

NOTES

   See http://publib.boulder.ibm.com/infocenter/compbgpl/v9v111/index.jsp?topic=/com.ibm.xlf111.bg.doc/xlfopg/fptrap.htm
   The XL Fortran exception handlers and related routines are:
   xl__ieee
   Produces a traceback and an explanation of the signal and continues execution by supplying the default IEEE result
   for the failed computation. This handler allows the program to produce the same results as if exception detection was not turned on.
   xl__trce
   Produces a traceback and stops the program.
   xl__trcedump
   Produces a traceback and a core file and stops the program.
   xl__sigdump
   Provides a traceback that starts from the point at which it is called and provides information about the signal.
   You can only call it from inside a user-written signal handler.
   It does not stop the program. To successfully continue, the signal handler must perform some cleanup after calling this subprogram.
   xl__trbk
   Provides a traceback that starts from the point at which it is called.
   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.

SOURCE

1267 subroutine xlf_set_sighandler()
1268 
1269 ! *************************************************************************
1270 
1271 #ifdef FC_IBM
1272  call SIGNAL(SIGTRAP, xl__trcedump)
1273  call SIGNAL(SIGFPE, xl__trcedump)
1274 #endif
1275 
1276 end subroutine xlf_set_sighandler