/* Complex argument. The angle made with the +ve real axis.
Range -pi-pi. */
GFC_REAL_4
cargf (GFC_COMPLEX_4 z)
{
GFC_REAL_4 arg;
return atan2f (IMAGPART (z), REALPART (z));
}
__complex128
ccoshq (__complex128 a)
{
__float128 r = REALPART (a), i = IMAGPART (a);
__complex128 v;
COMPLEX_ASSIGN (v, coshq (r) * cosq (i), sinhq (r) * sinq (i));
return v;
}
__complex128
ctanhq (__complex128 a)
{
__float128 rt = tanhq (REALPART (a)), it = tanq (IMAGPART (a));
__complex128 n, d;
COMPLEX_ASSIGN (n, rt, it);
COMPLEX_ASSIGN (d, 1, rt * it);
return C128_DIV(n,d);
}
float complex
ccoshf (float complex a)
{
float r, i;
float complex v;
r = REALPART (a);
i = IMAGPART (a);
COMPLEX_ASSIGN (v, coshf (r) * cosf (i), - (sinhf (r) * sinf (i)));
return v;
}
__complex128
cexpq (__complex128 z)
{
__float128 a, b;
__complex128 v;
a = REALPART (z);
b = IMAGPART (z);
COMPLEX_ASSIGN (v, cosq (b), sinq (b));
return expq (a) * v;
}
long double complex
cexpl (long double complex z)
{
long double a, b;
long double complex v;
a = REALPART (z);
b = IMAGPART (z);
COMPLEX_ASSIGN (v, cosl (b), sinl (b));
return expl (a) * v;
}
double complex
cexp (double complex z)
{
double a, b;
double complex v;
a = REALPART (z);
b = IMAGPART (z);
COMPLEX_ASSIGN (v, cos (b), sin (b));
return exp (a) * v;
}
float complex
cexpf (float complex z)
{
float a, b;
float complex v;
a = REALPART (z);
b = IMAGPART (z);
COMPLEX_ASSIGN (v, cosf (b), sinf (b));
return expf (a) * v;
}
long double complex
ccoshl (long double complex a)
{
long double r, i;
long double complex v;
r = REALPART (a);
i = IMAGPART (a);
COMPLEX_ASSIGN (v, coshl (r) * cosl (i), - (sinhl (r) * sinl (i)));
return v;
}
double complex
ccosh (double complex a)
{
double r, i;
double complex v;
r = REALPART (a);
i = IMAGPART (a);
COMPLEX_ASSIGN (v, cosh (r) * cos (i), - (sinh (r) * sin (i)));
return v;
}
/* exp(z) = exp(a)*(cos(b) + isin(b)) */
GFC_COMPLEX_4
cexpf (GFC_COMPLEX_4 z)
{
GFC_REAL_4 a;
GFC_REAL_4 b;
GFC_COMPLEX_4 v;
a = REALPART (z);
b = IMAGPART (z);
COMPLEX_ASSIGN (v, cosf (b), sinf (b));
return expf (a) * v;
}
/* cosh(z) = cosh(a)cos(b) - isinh(a)sin(b) */
GFC_COMPLEX_4
ccoshf (GFC_COMPLEX_4 a)
{
GFC_REAL_4 r;
GFC_REAL_4 i;
GFC_COMPLEX_4 v;
r = REALPART (a);
i = IMAGPART (a);
COMPLEX_ASSIGN (v, coshf (r) * cosf (i), - (sinhf (r) * sinf (i)));
return v;
}
long double complex
ctanl (long double complex a)
{
long double rt, it;
long double complex n, d;
rt = tanl (REALPART (a));
it = tanhl (IMAGPART (a));
COMPLEX_ASSIGN (n, rt, it);
COMPLEX_ASSIGN (d, 1, - (rt * it));
return n / d;
}
double complex
ctan (double complex a)
{
double rt, it;
double complex n, d;
rt = tan (REALPART (a));
it = tanh (IMAGPART (a));
COMPLEX_ASSIGN (n, rt, it);
COMPLEX_ASSIGN (d, 1, - (rt * it));
return n / d;
}
float complex
ctanf (float complex a)
{
float rt, it;
float complex n, d;
rt = tanf (REALPART (a));
it = tanhf (IMAGPART (a));
COMPLEX_ASSIGN (n, rt, it);
COMPLEX_ASSIGN (d, 1, - (rt * it));
return n / d;
}
/* sqrt(z). Algorithm pulled from glibc. */
GFC_COMPLEX_4
csqrtf (GFC_COMPLEX_4 z)
{
GFC_REAL_4 re;
GFC_REAL_4 im;
GFC_COMPLEX_4 v;
re = REALPART (z);
im = IMAGPART (z);
if (im == 0.0)
{
if (re < 0.0)
{
COMPLEX_ASSIGN (v, 0.0, copysignf (sqrtf (-re), im));
}
else
{
COMPLEX_ASSIGN (v, fabsf (sqrt (re)),
copysignf (0.0, im));
}
}
else if (re == 0.0)
{
GFC_REAL_4 r;
r = sqrtf (0.5 * fabs (im));
COMPLEX_ASSIGN (v, copysignf (r, im), r);
}
else
{
GFC_REAL_4 d, r, s;
d = hypotf (re, im);
/* Use the identity 2 Re res Im res = Im x
to avoid cancellation error in d +/- Re x. */
if (re > 0)
{
r = sqrtf (0.5 * d + 0.5 * re);
s = (0.5 * im) / r;
}
else
{
s = sqrtf (0.5 * d - 0.5 * re);
r = fabsf ((0.5 * im) / s);
}
COMPLEX_ASSIGN (v, r, copysignf (s, im));
}
return v;
}
void
elem_set(elem_ptr res, elem_srcptr src, const ring_t ring)
{
if (res != src)
{
switch (ring->type)
{
case TYPE_FMPZ:
fmpz_set(res, src);
break;
case TYPE_LIMB:
*((mp_ptr) res) = *((mp_srcptr) src);
break;
case TYPE_MOD:
elem_set(res, src, ring->parent);
break;
case TYPE_POLY:
elem_poly_set(res, src, ring);
break;
case TYPE_FRAC:
elem_set(NUMER(res, ring), NUMER(src, ring), RING_NUMER(ring));
elem_set(DENOM(res, ring), DENOM(src, ring), RING_DENOM(ring));
break;
case TYPE_COMPLEX:
elem_set(REALPART(res, ring), REALPART(src, ring), RING_PARENT(ring));
elem_set(IMAGPART(res, ring), IMAGPART(src, ring), RING_PARENT(ring));
break;
default:
NOT_IMPLEMENTED("set", ring);
}
}
}
void
elem_set_si(elem_ptr elem, long v, const ring_t ring)
{
switch (ring->type)
{
case TYPE_FMPZ:
fmpz_set_si(elem, v);
break;
case TYPE_LIMB:
*((mp_ptr) elem) = v;
break;
case TYPE_POLY:
elem_poly_set_si(elem, v, ring);
break;
case TYPE_MOD:
{
switch (RING_PARENT(ring)->type)
{
case TYPE_FMPZ:
fmpz_set_si(elem, v);
fmpz_mod(elem, elem, RING_MODULUS(ring));
break;
case TYPE_LIMB:
*((mp_ptr) elem) = nmod_set_si(v, ring->nmod);
break;
default:
NOT_IMPLEMENTED("set_si (mod)", ring);
}
}
break;
case TYPE_FRAC:
elem_set_si(NUMER(elem, ring), v, RING_NUMER(ring));
elem_one(DENOM(elem, ring), RING_DENOM(ring));
break;
case TYPE_COMPLEX:
elem_set_si(REALPART(elem, ring), v, ring->parent);
elem_zero(IMAGPART(elem, ring), ring->parent);
break;
default:
NOT_IMPLEMENTED("set_si", ring);
}
}
float complex
csqrtf (float complex z)
{
float re, im;
float complex v;
re = REALPART (z);
im = IMAGPART (z);
if (im == 0)
{
if (re < 0)
{
COMPLEX_ASSIGN (v, 0, copysignf (sqrtf (-re), im));
}
else
{
COMPLEX_ASSIGN (v, fabsf (sqrtf (re)), copysignf (0, im));
}
}
else if (re == 0)
{
float r;
r = sqrtf (0.5 * fabsf (im));
COMPLEX_ASSIGN (v, r, copysignf (r, im));
}
else
{
float d, r, s;
d = hypotf (re, im);
/* Use the identity 2 Re res Im res = Im x
to avoid cancellation error in d +/- Re x. */
if (re > 0)
{
r = sqrtf (0.5 * d + 0.5 * re);
s = (0.5 * im) / r;
}
else
{
s = sqrtf (0.5 * d - 0.5 * re);
r = fabsf ((0.5 * im) / s);
}
COMPLEX_ASSIGN (v, r, copysignf (s, im));
}
return v;
}
long double complex
csqrtl (long double complex z)
{
long double re, im;
long double complex v;
re = REALPART (z);
im = IMAGPART (z);
if (im == 0)
{
if (re < 0)
{
COMPLEX_ASSIGN (v, 0, copysignl (sqrtl (-re), im));
}
else
{
COMPLEX_ASSIGN (v, fabsl (sqrtl (re)), copysignl (0, im));
}
}
else if (re == 0)
{
long double r;
r = sqrtl (0.5 * fabsl (im));
COMPLEX_ASSIGN (v, copysignl (r, im), r);
}
else
{
long double d, r, s;
d = hypotl (re, im);
/* Use the identity 2 Re res Im res = Im x
to avoid cancellation error in d +/- Re x. */
if (re > 0)
{
r = sqrtl (0.5 * d + 0.5 * re);
s = (0.5 * im) / r;
}
else
{
s = sqrtl (0.5 * d - 0.5 * re);
r = fabsl ((0.5 * im) / s);
}
COMPLEX_ASSIGN (v, r, copysignl (s, im));
}
return v;
}
/* tanh(z) = (tanh(a) + itan(b)) / (1 - itanh(a)tan(b)) */
GFC_COMPLEX_4
ctanhf (GFC_COMPLEX_4 a)
{
GFC_REAL_4 rt;
GFC_REAL_4 it;
GFC_COMPLEX_4 n;
GFC_COMPLEX_4 d;
rt = tanhf (REALPART (a));
it = tanf (IMAGPART (a));
COMPLEX_ASSIGN (n, rt, it);
COMPLEX_ASSIGN (d, 1, - (rt * it));
return n / d;
}
/* Square root algorithm from glibc. */
__complex128
csqrtq (__complex128 z)
{
__float128 re = REALPART(z), im = IMAGPART(z);
__complex128 v;
if (im == 0)
{
if (re < 0)
{
COMPLEX_ASSIGN (v, 0, copysignq (sqrtq (-re), im));
}
else
{
COMPLEX_ASSIGN (v, fabsq (sqrtq (re)), copysignq (0, im));
}
}
else if (re == 0)
{
__float128 r = sqrtq (0.5 * fabsq (im));
COMPLEX_ASSIGN (v, r, copysignq (r, im));
}
else
{
__float128 d = hypotq (re, im);
__float128 r, s;
/* Use the identity 2 Re res Im res = Im x
to avoid cancellation error in d +/- Re x. */
if (re > 0)
r = sqrtq (0.5 * d + 0.5 * re), s = (0.5 * im) / r;
else
s = sqrtq (0.5 * d - 0.5 * re), r = fabsq ((0.5 * im) / s);
COMPLEX_ASSIGN (v, r, copysignq (s, im));
}
return v;
}
/* Both parameters will already have been converted to the result type. */
GFC_COMPLEX_4
__dot_product_c4 (gfc_array_c4 * a, gfc_array_c4 * b)
{
GFC_COMPLEX_4 *pa;
GFC_COMPLEX_4 *pb;
GFC_COMPLEX_4 res;
GFC_COMPLEX_4 conjga;
index_type count;
index_type astride;
index_type bstride;
assert (GFC_DESCRIPTOR_RANK (a) == 1
&& GFC_DESCRIPTOR_RANK (b) == 1);
if (a->dim[0].stride == 0)
a->dim[0].stride = 1;
if (b->dim[0].stride == 0)
b->dim[0].stride = 1;
astride = a->dim[0].stride;
bstride = b->dim[0].stride;
count = a->dim[0].ubound + 1 - a->dim[0].lbound;
res = 0;
pa = a->data;
pb = b->data;
while (count--)
{
COMPLEX_ASSIGN(conjga, REALPART (*pa), -IMAGPART (*pa));
res += conjga * *pb;
pa += astride;
pb += bstride;
}
return res;
}
long double
cabsl (long double complex z)
{
return hypotl (REALPART (z), IMAGPART (z));
}
float
cargf (float complex z)
{
return atan2f (IMAGPART (z), REALPART (z));
}
double
carg (double complex z)
{
return atan2 (IMAGPART (z), REALPART (z));
}
long double
cargl (long double complex z)
{
return atan2l (IMAGPART (z), REALPART (z));
}
/* Absolute value. */
GFC_REAL_4
cabsf (GFC_COMPLEX_4 z)
{
return hypotf (REALPART (z), IMAGPART (z));
}
__float128
cargq (__complex128 z)
{
return atan2q (IMAGPART (z), REALPART (z));
}
__float128
cabsq (__complex128 z)
{
return hypotq (REALPART (z), IMAGPART (z));
}
