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              : !!***