
/*
  Defines functions for controling the floating point exception flags under linux
*/
#include "fpreproc/f77name.h"
#include <cstdlib>

#ifdef _GNU_SOURCE
#  if defined(__GLIBC_PREREQ)
#    if __GLIBC_PREREQ(2,2)
#      define HAVE_FP_FUNCTIONS
#    endif
#  endif
#endif

#ifdef HAVE_FP_FUNCTIONS
#  include <fenv.h>
#endif

#include <iostream>

static int transp_store_fp_flags=-1 ;  // store floating point flags

//
// ---------------- transp_ftrap ----------------
// trapping of floating point errors
//
// transp_ftrap(0) -> setup trapping before entering a routine
// transp_ftrap(1) -> restore previous trapping after exit
//
extern "C" void F77NAME(transp_ftrap)(int* inout_arg) {
  int inout = *inout_arg ;
#ifdef HAVE_FP_FUNCTIONS
  using namespace std ;
  if (inout==0) {
    transp_store_fp_flags = fegetexcept() ;
    //cout << "got old flags = " << transp_store_fp_flags << endl ;
    //feclearexcept (FE_ALL_EXCEPT);
    if (transp_store_fp_flags!=-1) {
      feenableexcept (FE_DIVBYZERO|FE_UNDERFLOW|FE_OVERFLOW|FE_INVALID) ;
    } ;
  }
  else {
    if (transp_store_fp_flags!=-1) {
      fedisableexcept (FE_ALL_EXCEPT) ;
      //feclearexcept (FE_ALL_EXCEPT);
      feenableexcept (transp_store_fp_flags) ;
    } ;
    transp_store_fp_flags=-1 ;
  } ;
#endif
} ;

//
// ------------------ transp_ftrace -------------------
// tracing of floating point errors
//
// iflag=0 ; transp_ftrace(iflag) -> setup tracing before entering a routine by clearing the flags
// iflag=1 ; transp_ftrace(iflag) -> signals an exit and iflag will be set to the errors encountered as,
//     iflag = 1 bit -> divide by zero
//     iflag = 2 bit -> underflow
//     iflag = 4 bit -> overflow
//     iflag = 8 bit -> invalid number
//
extern "C" void F77NAME(transp_ftrace)(int* iflag_arg) {
  int iflag = *iflag_arg ;
  *iflag_arg = 0 ;       // in case _GNU_SOURCE is not defined
#ifdef HAVE_FP_FUNCTIONS
  using namespace std ;
  if (iflag==0) {
    transp_store_fp_flags = fegetexcept() ;
    if (transp_store_fp_flags!=-1) {
      fedisableexcept (FE_ALL_EXCEPT) ;
      feclearexcept (FE_ALL_EXCEPT);
    } ;
  }
  else {
    if (transp_store_fp_flags!=-1) {
      int raised = fetestexcept (FE_DIVBYZERO|FE_UNDERFLOW|FE_OVERFLOW|FE_INVALID) ;
      iflag = 0 ;
      if (raised & FE_DIVBYZERO) iflag += 1 ;
      if (raised & FE_UNDERFLOW) iflag += 2 ;
      if (raised & FE_OVERFLOW)  iflag += 4 ;
      if (raised & FE_INVALID)   iflag += 8 ;
      *iflag_arg = iflag ;
      feclearexcept (FE_ALL_EXCEPT);
      fedisableexcept (FE_ALL_EXCEPT) ;
      feenableexcept (transp_store_fp_flags) ;
    } ;
    transp_store_fp_flags=-1 ;   
  } ;
#endif
} ;
