static int
pcholesky_decomp (const int copy_uplo, gsl_matrix * A, gsl_permutation * p)
{
const size_t N = A->size1;
if (N != A->size2)
{
GSL_ERROR("LDLT decomposition requires square matrix", GSL_ENOTSQR);
}
else if (p->size != N)
{
GSL_ERROR ("permutation length must match matrix size", GSL_EBADLEN);
}
else
{
gsl_vector_view diag = gsl_matrix_diagonal(A);
size_t k;
if (copy_uplo)
{
/* save a copy of A in upper triangle (for later rcond calculation) */
gsl_matrix_transpose_tricpy('L', 0, A, A);
}
gsl_permutation_init(p);
for (k = 0; k < N; ++k)
{
gsl_vector_view w;
size_t j;
/* compute j = max_idx { A_kk, ..., A_nn } */
w = gsl_vector_subvector(&diag.vector, k, N - k);
j = gsl_vector_max_index(&w.vector) + k;
gsl_permutation_swap(p, k, j);
cholesky_swap_rowcol(A, k, j);
if (k < N - 1)
{
double alpha = gsl_matrix_get(A, k, k);
double alphainv = 1.0 / alpha;
/* v = A(k+1:n, k) */
gsl_vector_view v = gsl_matrix_subcolumn(A, k, k + 1, N - k - 1);
/* m = A(k+1:n, k+1:n) */
gsl_matrix_view m = gsl_matrix_submatrix(A, k + 1, k + 1, N - k - 1, N - k - 1);
/* m = m - v v^T / alpha */
gsl_blas_dsyr(CblasLower, -alphainv, &v.vector, &m.matrix);
/* v = v / alpha */
gsl_vector_scale(&v.vector, alphainv);
}
}
return GSL_SUCCESS;
}
}
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() */
int
gsl_linalg_cholesky_decomp (gsl_matrix * A)
{
int status;
status = gsl_linalg_cholesky_decomp1(A);
if (status == GSL_SUCCESS)
{
gsl_matrix_transpose_tricpy('L', 0, A, A);
}
return status;
}
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_pcholesky_decomp2(gsl_matrix * A, gsl_permutation * p,
gsl_vector * S)
{
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 if (N != p->size)
{
GSL_ERROR ("matrix size must match permutation size", GSL_EBADLEN);
}
else if (N != S->size)
{
GSL_ERROR("S must have length N", GSL_EBADLEN);
}
else
{
int status;
/* save a copy of A in upper triangle (for later rcond calculation) */
gsl_matrix_transpose_tricpy('L', 0, A, A);
/* compute scaling factors to reduce cond(A) */
status = gsl_linalg_cholesky_scale(A, S);
if (status)
return status;
/* apply scaling factors */
status = gsl_linalg_cholesky_scale_apply(A, S);
if (status)
return status;
/* compute Cholesky decomposition of diag(S) A diag(S) */
status = pcholesky_decomp(0, A, p);
if (status)
return status;
return GSL_SUCCESS;
}
}
int
gsl_multifit_linear_Lsobolev(const size_t p, const size_t kmax,
const gsl_vector *alpha, gsl_matrix *L,
gsl_multifit_linear_workspace *work)
{
if (p > work->pmax)
{
GSL_ERROR("p is larger than workspace", GSL_EBADLEN);
}
else if (p <= kmax)
{
GSL_ERROR("p must be larger than derivative order", GSL_EBADLEN);
}
else if (kmax + 1 != alpha->size)
{
GSL_ERROR("alpha must be size kmax + 1", GSL_EBADLEN);
}
else if (p != L->size1)
{
GSL_ERROR("L matrix is wrong size", GSL_EBADLEN);
}
else if (L->size1 != L->size2)
{
GSL_ERROR("L matrix is not square", GSL_ENOTSQR);
}
else
{
int s;
size_t j, k;
gsl_vector_view d = gsl_matrix_diagonal(L);
const double alpha0 = gsl_vector_get(alpha, 0);
/* initialize L to alpha0^2 I */
gsl_matrix_set_zero(L);
gsl_vector_add_constant(&d.vector, alpha0 * alpha0);
for (k = 1; k <= kmax; ++k)
{
gsl_matrix_view Lk = gsl_matrix_submatrix(work->Q, 0, 0, p - k, p);
double ak = gsl_vector_get(alpha, k);
/* compute a_k L_k */
s = gsl_multifit_linear_Lk(p, k, &Lk.matrix);
if (s)
return s;
gsl_matrix_scale(&Lk.matrix, ak);
/* LTL += L_k^T L_k */
gsl_blas_dsyrk(CblasLower, CblasTrans, 1.0, &Lk.matrix, 1.0, L);
}
s = gsl_linalg_cholesky_decomp(L);
if (s)
return s;
/* copy Cholesky factor to upper triangle and zero out bottom */
gsl_matrix_transpose_tricpy('L', 1, L, L);
for (j = 0; j < p; ++j)
{
for (k = 0; k < j; ++k)
gsl_matrix_set(L, j, k, 0.0);
}
return GSL_SUCCESS;
}
}
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;
}
}
