* _MATHERR.FOR - This function is part of a program that
*		 demonstrates how to customize the math
*		 error handling procedures.

* Compile: wfc[386] _matherr

*$pragma aux RTErr "*_" parm (value) []
*$pragma aux __math1err "*_" parm( value,reference )
*$pragma aux __math2err "*_" parm(value,reference,reference)
*$pragma aux FPTrapInit "*_"
*$pragma aux FPTrapFini "*_"
*$pragma aux signal "*_" parm( value, reference )
*$pragma aux FPEHandler parm( value, value )

      double precision function __math1err(err_info, arg1)
      integer err_info
      double precision arg1, __math2err
      __math1err = __math2err(err_info, arg1, arg1)
      end

      double precision function __math2err(err_info,
     &					   arg1, arg2 )
      integer err_info
      double precision arg1, arg2

      include 'mathcode.fi'

      if( ( err_info .and. M_DOMAIN ) .ne. 0 )then
	  select( err_info .and. FUNC_MASK )
	  case( FUNC_SQRT )
	      call MyRTErr( LI_ARG_NEG )
	  case( FUNC_ASIN )
	      call MyRTErr( LI_ARG_LE_ONE )
	  case( FUNC_ACOS )
	      call MyRTErr( LI_ARG_LE_ONE )
	  case( FUNC_ATAN2 )
	      call MyRTErr( LI_ARG_ZERO )
	  case( FUNC_POW )
	      if( arg1 .eq. 0.0 )then ! 0.0**y, y < 0
		  call MyRTErr( EX_Z_2_NOT_POS )
	      else ! base < 0 and non-integer power
		  call MyRTErr( EX_NOT_INT_ARG )
	      endif
	  case( FUNC_LOG )
	      call MyRTErr( LI_ARG_NEG )
	  end select
      else if( ( err_info .and. M_SING ) .ne. 0 )then
	  if((err_info .and. FUNC_MASK) .eq. FUNC_LOG)then
	      call MyRTErr( LI_ARG_ZERO )
	  endif
      else if( ( err_info .and. M_OVERFLOW ) .ne. 0 )then
	  call MyRTErr( KO_FOVERFLOW )
      else if( ( err_info .and. M_UNDERFLOW ) .ne. 0 )then
	  __math2err = 0d0
      end if
      end

      subroutine FPEHandler( sig_num, fpe_type )
      integer sig_num, fpe_type
      include 'mathcode.fi'
      if( fpe_type .eq. FPE_OVERFLOW )then
	  call MyRTErr( KO_FOVERFLOW )
      else if( fpe_type .eq. FPE_UNDERFLOW )then
	  call MyRTErr( KO_FUNDERFLOW )
      else if( fpe_type .eq. FPE_ZERODIVIDE )then
	  call MyRTErr( KO_FDIV_ZERO )
      else if( fpe_type .eq. FPE_SQRTNEG )then
	  call MyRTErr( LI_ARG_NEG )
      endif
      end

      subroutine FPTrapInit()
      include 'mathcode.fi'
      external FPEHandler
      call signal( SIGFPE, FPEHandler )
      end

      subroutine FPTrapFini()
      end

      subroutine MyRTErr( errcode )
      integer errcode
      integer error_stat
      common /error/ error_stat

      error_stat = errcode
      end
