OS/2 Shareware BBS: 30 fixes_v/30-fixes_v.zip/c32_b.zip/GD44.B

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