/*
* _CHABS: complex(kind=4) absolute value, returns real(kind=4) value
* - pass by value
*/
_f_real4
#ifdef _CRAYMPP
_CHABS(_f_comp4 z)
{
union hl_complx4 {
_f_comp4 cpx4;
struct {
_f_real4 real;
_f_real4 imag;
} rlim4;
} f;
_f_real4 ret_val;
_f_real8 _SQRT(_f_real8 x);
_f_real8 real, imag;
f.cpx4 = z;
real = fabs((_f_real8) f.rlim4.real);
imag = fabs((_f_real8) f.rlim4.imag);
if (real == 0.0 && imag == 0.0) return((_f_real4) 0.0);
if (real > imag)
ret_val =
(_f_real4) (real * _SQRT((_f_real8) 1.0 +
(imag/real) * (imag/real)));
else
ret_val =
(_f_real4) (imag * _SQRT((_f_real8) 1.0 +
(real/imag) * (real/imag)));
#else
_CHABS(h_complex_t z)
{
_f_real8 __fabs(_f_real8 x);
_f_real8 __sqrt(_f_real8 x);
_f_real8 real = __fabs((_f_real8) z.real);
_f_real8 imag = __fabs((_f_real8) z.imag);
_f_real4 ret_val;
if (real == 0.0 && imag == 0.0) return((_f_real4) 0.0);
if (real > imag)
ret_val =
(_f_real4) (real * __sqrt((_f_real8) 1.0 +
(imag/real) * (imag/real)));
else
ret_val =
(_f_real4) (imag * __sqrt((_f_real8) 1.0 +
(real/imag) * (real/imag)));
#endif
return (ret_val);
}
/*
* SQRT: real(kind=8) - pass by address
*/
_f_real8
_SQRT_( _f_real8 *x )
{
_f_real8 __sqrt(_f_real8 x);
return ((_f_real8) __sqrt((_f_real8) *x));
}
REAL inverse_cholesky(const REAL in[N][N], REAL out[N][N])
{
/* extract upper triangle from the [symmetric] input matrix */
for (int j = 0; j < N; j++)
for (int i = j; i < N; i++)
out[j][i] = out[i][j] = in[j][i];
/* Cholesky factorization, stored in the lower triangle */
for (int k = 0; k < N; k++)
{
if (out[k][k] <= 0) return REAL(0.0); /* matrix is not positive definite, return 0 */
out[k][k] = __sqrt(out[k][k]);
const REAL ainv = REAL(1.0)/out[k][k];
for (int i = k+1; i < N; i++)
out[i][k] *= ainv;
for (int j = k+1; j < N; j++)
for (int i = j; i < N; i++)
out[i][j] -= out[i][k]*out[j][k];
}
for (int j = 0; j < N; j++)
for (int i = j+1; i < N; i++)
out[j][i] = 0.0;
/* determinant */
REAL det = 1.0;
for (int i = 0; i < N; i++)
det *= out[i][i];
det *= det;
assert(det > 0.0);
/* invert lower triangular matrix */
for (int k = 0; k < N; k++)
out[k][k] = REAL(1.0)/out[k][k];
for (int i = 1; i < N; i++)
for (int j = 0; j < i; j++)
{
REAL sum = 0.0;
for (int k = j; k < i; k++)
sum += out[i][k] * out[k][j];
out[i][j] = -out[i][i]*sum;
}
/* compute inverse by multiplying inverse of L and its transpose */
for (int j = 0; j < N; j++)
for (int i = j; i < N; i++)
{
REAL sum = 0;
for (int k = i; k < N; k++)
sum += out[k][j]*out[k][i];
out[j][i] = sum;
}
for (int j = 0; j < N; j++)
for (int i = j+1; i < N; i++)
out[i][j] = out[j][i];
return det;
}
/*
* HSQRT: real(kind=4) - pass by address
*/
_f_real4
_HSQRT_( _f_real4 *x )
{
_f_real8 __sqrt(_f_real8 x);
return ((_f_real4) __sqrt((_f_real8) *x));
}
double _sqrt(double x) {
return __sqrt(x);
}
