home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Shareware BBS: 30 fixes_v
/
30-fixes_v.zip
/
f16_b.zip
/
GD44.B
< prev
next >
Wrap
Text File
|
1994-01-11
|
5KB
|
154 lines
!
! _MATHERR.FOR : math error handler
!
c$pragma aux __imath2err "*_" parm( value, reference, reference )
c$pragma aux __amath1err "*_" parm( value, reference )
c$pragma aux __amath2err "*_" parm( value, reference, reference )
c$pragma aux __math1err "*_" parm( value, reference )
c$pragma aux __math2err "*_" parm( value, reference, reference )
c$pragma aux __zmath2err "*_" parm( value, reference, reference )
c$pragma aux __qmath2err "*_" parm( value, reference, reference )
integer function __imath2err( err_info, arg1, arg2 )
integer err_info
integer arg1, arg2
include 'mathcode.fi'
arg1 = arg1 ! to avoid unreferenced warning message
arg2 = arg2 ! to avoid unreferenced warning message
if( ( err_info .and. M_DOMAIN ) .ne. 0 )then
select( err_info .and. FUNC_MASK )
case( FUNC_POW )
print *, 'arg2 cannot be <= 0'
case( FUNC_MOD )
print *, 'arg2 cannot be 0'
end select
end if
__imath2err = 0
end
real function __amath1err( err_info, arg1 )
integer err_info
real arg1
include 'mathcode.fi'
arg1 = arg1 ! to avoid unreferenced warning message
if( ( err_info .and. M_DOMAIN ) .ne. 0 )then
select( err_info .and. FUNC_MASK )
case( FUNC_COTAN )
print *, 'overflow'
end select
end if
__amath1err = 0.0
end
real function __amath2err( err_info, arg1, arg2 )
integer err_info
real arg1, arg2
include 'mathcode.fi'
arg1 = arg1 ! to avoid unreferenced warning message
arg2 = arg2 ! to avoid unreferenced warning message
if( ( err_info .and. M_DOMAIN ) .ne. 0 )then
select( err_info .and. FUNC_MASK )
case( FUNC_MOD )
print *, 'arg2 cannot be 0'
end select
end if
__amath2err = 0.0
end
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'
arg1 = arg1 ! to avoid unreferenced warning message
arg2 = arg2 ! to avoid unreferenced warning message
if( ( err_info .and. M_DOMAIN ) .ne. 0 )then
select( err_info .and. FUNC_MASK )
case( FUNC_SQRT )
print *, 'argument cannot be negative'
case( FUNC_ASIN, FUNC_ACOS )
print *, 'argument must be less than or equal to one'
case( FUNC_ATAN2 )
print *, 'both arguments must not be zero'
case( FUNC_POW )
if( arg1 .eq. 0.0 )then
print *, 'a zero base cannot be raised to a ',
+ 'negative power'
else ! base < 0 and non-integer power
print *, 'a negative base cannot be raised to a ',
+ 'non-integral power'
endif
case( FUNC_LOG, FUNC_LOG10 )
print *, 'argument must not be negative'
end select
else if( ( err_info .and. M_SING ) .ne. 0 )then
if( ( ( err_info .and. FUNC_MASK ) .eq. FUNC_LOG ) .or.
& ( ( err_info .and. FUNC_MASK ) .eq. FUNC_LOG10 ) )then
print *, 'argument must not be zero'
endif
else if( ( err_info .and. M_OVERFLOW ) .ne. 0 )then
print *, 'value of argument will cause overflow condition'
else if( ( err_info .and. M_UNDERFLOW ) .ne. 0 )then
print *, 'value of argument will cause underflow ',
+ 'condition - return zero'
end if
__math2err = 0
end
complex function __zmath2err( err_info, arg1, arg2 )
integer err_info
complex arg1, arg2
include 'mathcode.fi'
arg1 = arg1 ! to avoid unreferenced warning message
arg2 = arg2 ! to avoid unreferenced warning message
if( ( err_info .and. M_DOMAIN ) .ne. 0 )then
select( err_info .and. FUNC_MASK )
case( FUNC_POW )
! arg1 is (0,0)
if( imag( arg2 ) .ne. 0 )then
print *, 'a zero base cannot be raised to a',
+ ' complex power with non-zero imaginary part'
else
print *, 'a zero base cannot be raised to a',
+ ' complex power with non-positive real part'
endif
end select
end if
__zmath2err = (0,0)
end
double complex function __qmath2err( err_info, arg1, arg2 )
integer err_info
double complex arg1, arg2
include 'mathcode.fi'
arg1 = arg1 ! to avoid unreferenced warning message
arg2 = arg2 ! to avoid unreferenced warning message
if( ( err_info .and. M_DOMAIN ) .ne. 0 )then
select( err_info .and. FUNC_MASK )
case( FUNC_POW )
! arg1 is (0,0)
if( imag( arg2 ) .ne. 0 )then
print *, 'a zero base cannot be raised to a',
+ ' complex power with non-zero imaginary part'
else
print *, 'a zero base cannot be raised to a',
+ ' complex power with non-positive real part'
endif
end select
end if
__qmath2err = (0,0)
end