int
gsl_linalg_cholesky_invert(gsl_matrix * LLT)
{
if (LLT->size1 != LLT->size2)
{
GSL_ERROR ("cholesky matrix must be square", GSL_ENOTSQR);
}
else
{
const size_t N = LLT->size1;
size_t i;
gsl_vector_view v1, v2;
/* invert the lower triangle of LLT */
gsl_linalg_tri_lower_invert(LLT);
/*
* The lower triangle of LLT now contains L^{-1}. Now compute
* A^{-1} = L^{-T} L^{-1}
*/
for (i = 0; i < N; ++i)
{
double aii = gsl_matrix_get(LLT, i, i);
if (i < N - 1)
{
double tmp;
v1 = gsl_matrix_subcolumn(LLT, i, i, N - i);
gsl_blas_ddot(&v1.vector, &v1.vector, &tmp);
gsl_matrix_set(LLT, i, i, tmp);
if (i > 0)
{
gsl_matrix_view m = gsl_matrix_submatrix(LLT, i + 1, 0, N - i - 1, i);
v1 = gsl_matrix_subcolumn(LLT, i, i + 1, N - i - 1);
v2 = gsl_matrix_subrow(LLT, i, 0, i);
gsl_blas_dgemv(CblasTrans, 1.0, &m.matrix, &v1.vector, aii, &v2.vector);
}
}
else
{
v1 = gsl_matrix_row(LLT, N - 1);
gsl_blas_dscal(aii, &v1.vector);
}
}
/* copy lower triangle to upper */
gsl_matrix_transpose_tricpy('L', 0, LLT, LLT);
return GSL_SUCCESS;
}
} /* gsl_linalg_cholesky_invert() */
static int
cod_RZ(gsl_matrix * A, gsl_vector * tau)
{
const size_t M = A->size1;
const size_t N = A->size2;
if (tau->size != M)
{
GSL_ERROR("tau has wrong size", GSL_EBADLEN);
}
else if (N < M)
{
GSL_ERROR("N must be >= M", GSL_EINVAL);
}
else if (M == N)
{
/* quick return */
gsl_vector_set_all(tau, 0.0);
return GSL_SUCCESS;
}
else
{
size_t k;
for (k = M; k > 0 && k--; )
{
double *alpha = gsl_matrix_ptr(A, k, k);
gsl_vector_view z = gsl_matrix_subrow(A, k, M, N - M);
double tauk;
/* compute Householder reflection to zero [ A(k,k) A(k,M+1:N) ] */
tauk = cod_householder_transform(alpha, &z.vector);
gsl_vector_set(tau, k, tauk);
if ((tauk != 0) && (k > 0))
{
gsl_vector_view w = gsl_vector_subvector(tau, 0, k);
gsl_matrix_view B = gsl_matrix_submatrix(A, 0, k, k, N - k);
cod_householder_mh(tauk, &z.vector, &B.matrix, &w.vector);
}
}
return GSL_SUCCESS;
}
}
int
gsl_linalg_cholesky_decomp1 (gsl_matrix * A)
{
const size_t M = A->size1;
const size_t N = A->size2;
if (M != N)
{
GSL_ERROR("cholesky decomposition requires square matrix", GSL_ENOTSQR);
}
else
{
size_t j;
/* save original matrix in upper triangle for later rcond calculation */
gsl_matrix_transpose_tricpy('L', 0, A, A);
for (j = 0; j < N; ++j)
{
double ajj;
gsl_vector_view v = gsl_matrix_subcolumn(A, j, j, N - j); /* A(j:n,j) */
if (j > 0)
{
gsl_vector_view w = gsl_matrix_subrow(A, j, 0, j); /* A(j,1:j-1)^T */
gsl_matrix_view m = gsl_matrix_submatrix(A, j, 0, N - j, j); /* A(j:n,1:j-1) */
gsl_blas_dgemv(CblasNoTrans, -1.0, &m.matrix, &w.vector, 1.0, &v.vector);
}
ajj = gsl_matrix_get(A, j, j);
if (ajj <= 0.0)
{
GSL_ERROR("matrix is not positive definite", GSL_EDOM);
}
ajj = sqrt(ajj);
gsl_vector_scale(&v.vector, 1.0 / ajj);
}
return GSL_SUCCESS;
}
}
int
gsl_linalg_PTLQ_decomp (gsl_matrix * A, gsl_vector * tau, gsl_permutation * p, int *signum, gsl_vector * norm)
{
const size_t N = A->size1;
const size_t M = A->size2;
if (tau->size != GSL_MIN (M, N))
{
GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN);
}
else if (p->size != N)
{
GSL_ERROR ("permutation size must be N", GSL_EBADLEN);
}
else if (norm->size != N)
{
GSL_ERROR ("norm size must be N", GSL_EBADLEN);
}
else
{
size_t i;
*signum = 1;
gsl_permutation_init (p); /* set to identity */
/* Compute column norms and store in workspace */
for (i = 0; i < N; i++)
{
gsl_vector_view c = gsl_matrix_row (A, i);
double x = gsl_blas_dnrm2 (&c.vector);
gsl_vector_set (norm, i, x);
}
for (i = 0; i < GSL_MIN (M, N); i++)
{
/* Bring the column of largest norm into the pivot position */
double max_norm = gsl_vector_get(norm, i);
size_t j, kmax = i;
for (j = i + 1; j < N; j++)
{
double x = gsl_vector_get (norm, j);
if (x > max_norm)
{
max_norm = x;
kmax = j;
}
}
if (kmax != i)
{
gsl_matrix_swap_rows (A, i, kmax);
gsl_permutation_swap (p, i, kmax);
gsl_vector_swap_elements(norm,i,kmax);
(*signum) = -(*signum);
}
/* Compute the Householder transformation to reduce the j-th
column of the matrix to a multiple of the j-th unit vector */
{
gsl_vector_view c = gsl_matrix_subrow (A, i, i, M - i);
double tau_i = gsl_linalg_householder_transform (&c.vector);
gsl_vector_set (tau, i, tau_i);
/* Apply the transformation to the remaining columns */
if (i + 1 < N)
{
gsl_matrix_view m = gsl_matrix_submatrix (A, i +1, i, N - (i+1), M - i);
gsl_linalg_householder_mh (tau_i, &c.vector, &m.matrix);
}
}
/* Update the norms of the remaining columns too */
if (i + 1 < M)
{
for (j = i + 1; j < N; j++)
{
double x = gsl_vector_get (norm, j);
if (x > 0.0)
{
double y = 0;
double temp= gsl_matrix_get (A, j, i) / x;
if (fabs (temp) >= 1)
y = 0.0;
else
y = x * sqrt (1 - temp * temp);
/* recompute norm to prevent loss of accuracy */
if (fabs (y / x) < sqrt (20.0) * GSL_SQRT_DBL_EPSILON)
{
gsl_vector_view c = gsl_matrix_subrow (A, j, i + 1, M - (i + 1));
y = gsl_blas_dnrm2 (&c.vector);
}
gsl_vector_set (norm, j, y);
}
}
}
}
return GSL_SUCCESS;
}
}
int
lls(const gsl_matrix *A, const gsl_vector *c, gsl_vector *x)
{
int m = (int) A->size1;
int n = (int) A->size2;
int nrhs = 1;
int info;
int lwork;
gsl_matrix *aa, *bb;
gsl_vector *s;
gsl_vector *work;
double q[1];
int ldb = GSL_MAX(m, n);
int lda = m;
double rcond = 1.0e-12;
int rank;
int *iwork = 0;
gsl_vector_view v;
gsl_vector *rhs;
rhs = gsl_vector_alloc(c->size);
aa = gsl_matrix_alloc(A->size2, A->size1);
bb = gsl_matrix_alloc(nrhs, GSL_MAX(m, n));
s = gsl_vector_alloc(GSL_MIN(m, n));
gsl_matrix_transpose_memcpy(aa, A);
gsl_vector_memcpy(rhs, c);
v = gsl_matrix_subrow(bb, 0, 0, m);
gsl_vector_memcpy(&v.vector, rhs);
lwork = -1;
dgelsd_(&m,
&n,
&nrhs,
aa->data,
&lda,
bb->data,
&ldb,
s->data,
&rcond,
&rank,
q,
&lwork,
iwork,
&info);
lwork = (int) q[0];
work = gsl_vector_alloc((size_t) lwork);
iwork = malloc(sizeof(int) * m);
dgelsd_(&m,
&n,
&nrhs,
aa->data,
&lda,
bb->data,
&ldb,
s->data,
&rcond,
&rank,
work->data,
&lwork,
iwork,
&info);
v = gsl_matrix_subrow(bb, 0, 0, n);
gsl_vector_memcpy(x, &v.vector);
gsl_matrix_free(aa);
gsl_matrix_free(bb);
gsl_vector_free(s);
gsl_vector_free(rhs);
gsl_vector_free(work);
free(iwork);
if (info)
fprintf(stderr, "ERROR: lls: info = %d\n", info);
return (info);
} /* lls() */
int
gsl_linalg_hesstri_decomp(gsl_matrix * A, gsl_matrix * B, gsl_matrix * U,
gsl_matrix * V, gsl_vector * work)
{
const size_t N = A->size1;
if ((N != A->size2) || (N != B->size1) || (N != B->size2))
{
GSL_ERROR ("Hessenberg-triangular reduction requires square matrices",
GSL_ENOTSQR);
}
else if (N != work->size)
{
GSL_ERROR ("length of workspace must match matrix dimension",
GSL_EBADLEN);
}
else
{
double cs, sn; /* rotation parameters */
size_t i, j; /* looping */
gsl_vector_view xv, yv; /* temporary views */
/* B -> Q^T B = R (upper triangular) */
gsl_linalg_QR_decomp(B, work);
/* A -> Q^T A */
gsl_linalg_QR_QTmat(B, work, A);
/* initialize U and V if desired */
if (U)
{
gsl_linalg_QR_unpack(B, work, U, B);
}
else
{
/* zero out lower triangle of B */
for (j = 0; j < N - 1; ++j)
{
for (i = j + 1; i < N; ++i)
gsl_matrix_set(B, i, j, 0.0);
}
}
if (V)
gsl_matrix_set_identity(V);
if (N < 3)
return GSL_SUCCESS; /* nothing more to do */
/* reduce A and B */
for (j = 0; j < N - 2; ++j)
{
for (i = N - 1; i >= (j + 2); --i)
{
/* step 1: rotate rows i - 1, i to kill A(i,j) */
/*
* compute G = [ CS SN ] so that G^t [ A(i-1,j) ] = [ * ]
* [-SN CS ] [ A(i, j) ] [ 0 ]
*/
gsl_linalg_givens(gsl_matrix_get(A, i - 1, j),
gsl_matrix_get(A, i, j),
&cs,
&sn);
/* invert so drot() works correctly (G -> G^t) */
sn = -sn;
/* compute G^t A(i-1:i, j:n) */
xv = gsl_matrix_subrow(A, i - 1, j, N - j);
yv = gsl_matrix_subrow(A, i, j, N - j);
gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
/* compute G^t B(i-1:i, i-1:n) */
xv = gsl_matrix_subrow(B, i - 1, i - 1, N - i + 1);
yv = gsl_matrix_subrow(B, i, i - 1, N - i + 1);
gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
if (U)
{
/* accumulate U: U -> U G */
xv = gsl_matrix_column(U, i - 1);
yv = gsl_matrix_column(U, i);
gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
}
/* step 2: rotate columns i, i - 1 to kill B(i, i - 1) */
gsl_linalg_givens(-gsl_matrix_get(B, i, i),
gsl_matrix_get(B, i, i - 1),
&cs,
&sn);
/* invert so drot() works correctly (G -> G^t) */
sn = -sn;
/* compute B(1:i, i-1:i) G */
xv = gsl_matrix_subcolumn(B, i - 1, 0, i + 1);
yv = gsl_matrix_subcolumn(B, i, 0, i + 1);
gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
/* apply to A(1:n, i-1:i) */
xv = gsl_matrix_column(A, i - 1);
yv = gsl_matrix_column(A, i);
gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
if (V)
{
/* accumulate V: V -> V G */
xv = gsl_matrix_column(V, i - 1);
yv = gsl_matrix_column(V, i);
gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
}
}
}
return GSL_SUCCESS;
}
} /* gsl_linalg_hesstri_decomp() */
int
gsl_linalg_pcholesky_invert(const gsl_matrix * LDLT, const gsl_permutation * p,
gsl_matrix * Ainv)
{
const size_t M = LDLT->size1;
const size_t N = LDLT->size2;
if (M != N)
{
GSL_ERROR ("LDLT matrix must be square", GSL_ENOTSQR);
}
else if (LDLT->size1 != p->size)
{
GSL_ERROR ("matrix size must match permutation size", GSL_EBADLEN);
}
else if (Ainv->size1 != Ainv->size2)
{
GSL_ERROR ("Ainv matrix must be square", GSL_ENOTSQR);
}
else if (Ainv->size1 != M)
{
GSL_ERROR ("Ainv matrix has wrong dimensions", GSL_EBADLEN);
}
else
{
size_t i, j;
gsl_vector_view v1, v2;
/* invert the lower triangle of LDLT */
gsl_matrix_memcpy(Ainv, LDLT);
gsl_linalg_tri_lower_unit_invert(Ainv);
/* compute sqrt(D^{-1}) L^{-1} in the lower triangle of Ainv */
for (i = 0; i < N; ++i)
{
double di = gsl_matrix_get(LDLT, i, i);
double sqrt_di = sqrt(di);
for (j = 0; j < i; ++j)
{
double *Lij = gsl_matrix_ptr(Ainv, i, j);
*Lij /= sqrt_di;
}
gsl_matrix_set(Ainv, i, i, 1.0 / sqrt_di);
}
/*
* The lower triangle of Ainv now contains D^{-1/2} L^{-1}. Now compute
* A^{-1} = L^{-T} D^{-1} L^{-1}
*/
for (i = 0; i < N; ++i)
{
double aii = gsl_matrix_get(Ainv, i, i);
if (i < N - 1)
{
double tmp;
v1 = gsl_matrix_subcolumn(Ainv, i, i, N - i);
gsl_blas_ddot(&v1.vector, &v1.vector, &tmp);
gsl_matrix_set(Ainv, i, i, tmp);
if (i > 0)
{
gsl_matrix_view m = gsl_matrix_submatrix(Ainv, i + 1, 0, N - i - 1, i);
v1 = gsl_matrix_subcolumn(Ainv, i, i + 1, N - i - 1);
v2 = gsl_matrix_subrow(Ainv, i, 0, i);
gsl_blas_dgemv(CblasTrans, 1.0, &m.matrix, &v1.vector, aii, &v2.vector);
}
}
else
{
v1 = gsl_matrix_row(Ainv, N - 1);
gsl_blas_dscal(aii, &v1.vector);
}
}
/* copy lower triangle to upper */
gsl_matrix_transpose_tricpy('L', 0, Ainv, Ainv);
/* now apply permutation p to the matrix */
/* compute L^{-T} D^{-1} L^{-1} P^T */
for (i = 0; i < N; ++i)
{
v1 = gsl_matrix_row(Ainv, i);
gsl_permute_vector_inverse(p, &v1.vector);
}
/* compute P L^{-T} D^{-1} L^{-1} P^T */
for (i = 0; i < N; ++i)
{
v1 = gsl_matrix_column(Ainv, i);
gsl_permute_vector_inverse(p, &v1.vector);
}
return GSL_SUCCESS;
}
}
