Branch data Line data Source code
1 : : !!****m* ABINIT/m_xieee
2 : : !! NAME
3 : : !! m_xieee
4 : : !!
5 : : !! FUNCTION
6 : : !! Debugging tools and helper functions providing access to IEEE exceptions
7 : : !!
8 : : !! COPYRIGHT
9 : : !! Copyright (C) 2014-2026 ABINIT group (MG)
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 : : !! NOTES
15 : : !! See F2003 standard and http://www.nag.com/nagware/np/r51_doc/ieee_exceptions.html
16 : : !!
17 : : !! SOURCE
18 : :
19 : : #if defined HAVE_CONFIG_H
20 : : #include "config.h"
21 : : #endif
22 : :
23 : : #include "abi_common.h"
24 : :
25 : : module m_xieee
26 : :
27 : : #ifdef HAVE_FC_IEEE_EXCEPTIONS
28 : : !use, intrinsic :: ieee_exceptions
29 : : use ieee_exceptions
30 : : #endif
31 : :
32 : : implicit none
33 : :
34 : : private
35 : :
36 : : public :: xieee_halt_ifexc ! Halt the code if one of the *usual* IEEE exceptions is raised.
37 : : public :: xieee_signal_ifexc ! Signal if any IEEE exception is raised.
38 : :
39 : : integer,private,parameter :: std_out = 6
40 : :
41 : : contains
42 : : !!***
43 : :
44 : : !!****f* m_xieee/xieee_halt_ifexc
45 : : !! NAME
46 : : !! xieee_halt_ifexc
47 : : !!
48 : : !! FUNCTION
49 : : !! Halt the code if one of the *usual* IEEE exceptions is raised.
50 : : !!
51 : : !! INPUTS
52 : : !! halt= If the value is true, the exceptions will cause halting; otherwise, execution will continue after this exception.
53 : : !!
54 : : !! SOURCE
55 : :
56 : 0 : subroutine xieee_halt_ifexc(halt)
57 : :
58 : : !Arguments ------------------------------------
59 : : !scalars
60 : : logical,intent(in) :: halt
61 : : ! *************************************************************************
62 : :
63 : : #ifdef HAVE_FC_IEEE_EXCEPTIONS
64 : : ! Possible Flags: ieee_invalid, ieee_overflow, ieee_divide_by_zero, ieee_inexact, and ieee_underflow
65 [ # # ]: 0 : if (ieee_support_halting(ieee_invalid)) then
66 : 0 : call ieee_set_halting_mode(ieee_invalid, halt)
67 : : end if
68 [ # # ]: 0 : if (ieee_support_halting(ieee_overflow)) then
69 : 0 : call ieee_set_halting_mode(ieee_overflow, halt)
70 : : end if
71 [ # # ]: 0 : if (ieee_support_halting(ieee_divide_by_zero)) then
72 : 0 : call ieee_set_halting_mode(ieee_divide_by_zero, halt)
73 : : end if
74 : : !if (ieee_support_halting(ieee_inexact)) then
75 : : ! call ieee_set_halting_mode(ieee_inexact, halt)
76 : : !end if
77 : : !if (ieee_support_halting(ieee_underflow)) then
78 : : ! call ieee_set_halting_mode(ieee_underflow, halt)
79 : : !end if
80 : : #else
81 : : write(std_out,*)"Cannot set halting mode to: ",halt
82 : : #endif
83 : :
84 : 0 : end subroutine xieee_halt_ifexc
85 : : !!***
86 : :
87 : : !----------------------------------------------------------------------
88 : :
89 : : !!****f* m_xieee/xieee_signal_ifexc
90 : : !! NAME
91 : : !! xieee_signal_ifexc
92 : : !!
93 : : !! FUNCTION
94 : : !! Signal if one of the *usual* IEEE exceptions is raised.
95 : :
96 : : !! INPUTS
97 : : !! flag= If the value is true, the exceptions will be signalled
98 : : !!
99 : : !! SOURCE
100 : :
101 : 0 : subroutine xieee_signal_ifexc(flag)
102 : :
103 : : !Arguments ------------------------------------
104 : : !scalars
105 : : logical,intent(in) :: flag
106 : : ! *************************************************************************
107 : :
108 : : #ifdef HAVE_FC_IEEE_EXCEPTIONS
109 : : ! Possible Flags: ieee_invalid, ieee_overflow, ieee_divide_by_zero, ieee_inexact, and ieee_underflow
110 : 0 : call ieee_set_flag(ieee_invalid, flag)
111 : 0 : call ieee_set_flag(ieee_overflow, flag)
112 : 0 : call ieee_set_flag(ieee_divide_by_zero, flag)
113 : 0 : call ieee_set_flag(ieee_inexact, flag)
114 : 0 : call ieee_set_flag(ieee_underflow, flag)
115 : : #else
116 : : write(std_out,*)"Cannot set signal flag to: ",flag
117 : : #endif
118 : :
119 : 0 : end subroutine xieee_signal_ifexc
120 : : !!***
121 : :
122 : : end module m_xieee
123 : : !!***
|
