/*
* complex(kind=8) raised to a real(kind=8) = _CTOR
*
* x = a+b*i
*
* if ((x == 0+0*i) && (y == 0)) then return(NAN)
* if (x == 0+0*i) then return(0+0*i)
* if (y == 0) then return(1+0*i)
*/
void
_CTOR(c_complex_t *ret_val,
c_complex_t x,
_f_real8 *r)
{
_f_real8 __atan2(_f_real8 x, _f_real8 y);
_f_real8 __cos(_f_real8 x);
_f_real8 __exp(_f_real8 x);
_f_real8 __log(_f_real8 x);
_f_real8 __sin(_f_real8 x);
_f_real8 _CABS(c_complex_t z);
_f_real8 y = *r;
_f_real8 one;
_f_real8 two;
if (x.real == (_f_real8) 0.0 && x.imag == (_f_real8) 0.0) {
if (y == (_f_real8) 0.0) {
ret_val->real = _SGL_NaN;
ret_val->imag = _SGL_NaN;
}
else {
ret_val->real = (_f_real8) 0.0;
ret_val->imag = (_f_real8) 0.0;
}
return;
}
one = y * __atan2(x.imag, x.real);
two = y * __log(_CABS(x));
ret_val->real = __exp(two) * __cos(one);
ret_val->imag = __exp(two) * __sin(one);
}
void
_CHEXP(h_complex_t *ret_val,
h_complex_t z )
{
_f_real8 __exp(_f_real8 x);
_f_real8 __cos(_f_real8 x);
_f_real8 __sin(_f_real8 x);
_f_real8 real = (_f_real8) z.real;
_f_real8 imag = (_f_real8) z.imag;
_f_real8 realtmp = __exp(real);
ret_val->real = (_f_real4) (realtmp * __cos(imag));
ret_val->imag = (_f_real4) (realtmp * __sin(imag));
}
__declspec ( naked ) void nseel_asm_exp(void)
{
FUNC1_ENTER
*__nextBlock = __exp(*parm_a);
FUNC_LEAVE
}
/*
* EXP: real(kind=8) - pass by address
*/
_f_real8
_EXP_( _f_real8 *x )
{
_f_real8 __exp(_f_real8 x);
return ((_f_real8) __exp((_f_real8) *x));
}
double
__erfc( double arg )
{
double argsq;
double z;
double zsq;
double s, f, f1;
double n, d;
double result;
#ifdef _CALL_MATHERR
struct exception exstruct;
#endif
if( arg != arg )
{
/* arg is a NaN */
#ifdef _CALL_MATHERR
exstruct.type = DOMAIN;
exstruct.name = "erfc";
exstruct.arg1 = arg;
exstruct.retval = Qnan.d;
if ( matherr( &exstruct ) == 0 )
{
fprintf(stderr, "domain error in erfc\n");
SETERRNO(EDOM);
}
return ( exstruct.retval );
#else
NAN_SETERRNO(EDOM);
return ( Qnan.d );
#endif
}
if ( arg < Llimit2.d )
return ( 2.0 );
if ( arg <= -2.0 )
return ( 2.0 - __erfc(-arg) );
if ( arg < 0.25 )
return( 1.0 - __erf(arg) );
result = 0.0; /* default */
if ( arg < 0.75 )
{
argsq = arg*arg;
n = (((((p1[6].d*argsq + p1[5].d)*argsq + p1[4].d)*argsq +
p1[3].d)*argsq + p1[2].d)*argsq + p1[1].d)*
argsq + p1[0].d;
d = ((((q1[5].d*argsq + q1[4].d)*argsq + q1[3].d)*argsq +
q1[2].d)*argsq + q1[1].d)*argsq + q1[0].d;
return ( 0.5 + ((0.5 - arg) - arg*n/d) );
}
else if ( arg < 1.25 )
{
z = arg - 1.0;
n = ((((((p2[8].d*z + p2[7].d)*z + p2[6].d)*z + p2[5].d)*z +
p2[4].d)*z + p2[3].d)*z + p2[2].d)*z;
d = ((((((q2[7].d*z + q2[6].d)*z + q2[5].d)*z + q2[4].d)*z +
q2[3].d)*z + q2[2].d)*z + q2[1].d)*z + q2[0].d;
return ( p2[0].d - n/d );
}
else if ( arg < 1.75 )
{
z = arg - 1.5;
n = (((((p3[7].d*z + p3[6].d)*z +
p3[5].d)*z + p3[4].d)*z + p3[3].d)*z + p3[2].d)*z;
d = (((((q3[6].d*z + q3[5].d)*z + q3[4].d)*z +
q3[3].d)*z + q3[2].d)*z + q3[1].d)*z + q3[0].d;
return ( p3[0].d - n/d );
}
else if ( arg < 2.0 )
{
z = arg - 1.875;
n = ((((p4[6].d*z + p4[5].d)*z +
p4[4].d)*z + p4[3].d)*z + p4[2].d)*z;
d = ((((q4[5].d*z + q4[4].d)*z + q4[3].d)*z +
q4[2].d)*z + q4[1].d)*z + q4[0].d;
return ( p4[0].d - n/d );
}
else if ( arg <= Ulimit2.d )
{
zsq = 1.0/(arg*arg);
n = (((((((p5[7].d*zsq + p5[6].d)*zsq + p5[5].d)*zsq +
p5[4].d)*zsq + p5[3].d)*zsq + p5[2].d)*zsq + p5[1].d)*zsq +
p5[0].d)*zsq;
d = (((((((q5[8].d*zsq + q5[7].d)*zsq + q5[6].d)*zsq + q5[5].d)*zsq +
q5[4].d)*zsq + q5[3].d)*zsq + q5[2].d)*zsq + q5[1].d)*zsq +
q5[0].d;
s = (float)arg;
/* Now the result is exp(-arg*arg)*(1.0 + n/d)/(arg*sqrt(pi)) */
if ( arg <= 26.0 )
{
/* To avoid loss of precision in computing exp(-arg*arg),
* rewrite -arg*arg as -s*s + s*(s-arg) + arg*(s-arg)
* Note that -s*s is exact.
*/
/* Compute the second exp in the expression locally,
* since the argument is small.
*/
f1 = __exp(-s*s);
f = f1 + f1*poly(s*(s-arg) + arg*(s-arg));
return ( Rsqrtpi.d*(f + f*n/d)/arg );
}
else
{
/* Beyond 26.0, we have to worry about underflow in
* computing exp(-arg*arg); instead we'll compute
* exp(-arg*arg/2.0) and multiply by it twice.
* The result here may underflow, depending on
* whether the processor supports denormals or not.
*/
s = (float)arg;
f1 = __exp(-0.5*s*s);
f = f1 + f1*poly(0.5*s*(s-arg) + 0.5*arg*(s-arg));
result = Rsqrtpi.d*(f + f*n/d)/arg*f;
}
}
if ( result == 0.0 )
#ifdef _CALL_MATHERR
{
exstruct.type = UNDERFLOW;
exstruct.name = "erfc";
exstruct.arg1 = arg;
exstruct.retval = 0.0;
if ( matherr( &exstruct ) == 0 )
{
fprintf(stderr, "underflow error in erfc\n");
SETERRNO(ERANGE);
}
return ( exstruct.retval );
}
#else
{
SETERRNO(ERANGE);
return ( 0.0 );
}
#endif
return ( result );
}
/*
* HEXP: real(kind=4) - pass by value
*/
_f_real4
_HEXP( _f_real4 x )
{
_f_real8 __exp(_f_real8 x);
return ( (_f_real4) __exp((_f_real8) x) );
}