int
gsl_linalg_cholesky_svx2 (const gsl_matrix * LLT,
const gsl_vector * S,
gsl_vector * x)
{
if (LLT->size1 != LLT->size2)
{
GSL_ERROR ("cholesky matrix must be square", GSL_ENOTSQR);
}
else if (LLT->size2 != S->size)
{
GSL_ERROR ("matrix size must match S", GSL_EBADLEN);
}
else if (LLT->size2 != x->size)
{
GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN);
}
else
{
/* b~ = diag(S) b */
gsl_vector_mul(x, S);
/* Solve for c using forward-substitution, L c = b~ */
gsl_blas_dtrsv (CblasLower, CblasNoTrans, CblasNonUnit, LLT, x);
/* Perform back-substitution, L^T x~ = c */
gsl_blas_dtrsv (CblasLower, CblasTrans, CblasNonUnit, LLT, x);
/* compute original solution vector x = S x~ */
gsl_vector_mul(x, S);
return GSL_SUCCESS;
}
}
int
gsl_linalg_QRPT_svx (const gsl_matrix * QR,
const gsl_vector * tau,
const gsl_permutation * p,
gsl_vector * x)
{
if (QR->size1 != QR->size2)
{
GSL_ERROR ("QR matrix must be square", GSL_ENOTSQR);
}
else if (QR->size1 != p->size)
{
GSL_ERROR ("matrix size must match permutation size", GSL_EBADLEN);
}
else if (QR->size2 != x->size)
{
GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN);
}
else
{
/* compute sol = Q^T b */
gsl_linalg_QR_QTvec (QR, tau, x);
/* Solve R x = sol, storing x inplace in sol */
gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, QR, x);
gsl_permute_vector_inverse (p, x);
return GSL_SUCCESS;
}
}
int
gsl_linalg_QRPT_QRsolve (const gsl_matrix * Q, const gsl_matrix * R,
const gsl_permutation * p,
const gsl_vector * b,
gsl_vector * x)
{
if (Q->size1 != Q->size2 || R->size1 != R->size2)
{
return GSL_ENOTSQR;
}
else if (Q->size1 != p->size || Q->size1 != R->size1
|| Q->size1 != b->size)
{
return GSL_EBADLEN;
}
else
{
/* compute b' = Q^T b */
gsl_blas_dgemv (CblasTrans, 1.0, Q, b, 0.0, x);
/* Solve R x = b', storing x inplace */
gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, R, x);
/* Apply permutation to solution in place */
gsl_permute_vector_inverse (p, x);
return GSL_SUCCESS;
}
}
int
gsl_linalg_QR_QRsolve (gsl_matrix * Q, gsl_matrix * R, const gsl_vector * b, gsl_vector * x)
{
const size_t M = R->size1;
const size_t N = R->size2;
if (M != N)
{
return GSL_ENOTSQR;
}
else if (Q->size1 != M || b->size != M || x->size != M)
{
return GSL_EBADLEN;
}
else
{
/* compute sol = Q^T b */
gsl_blas_dgemv (CblasTrans, 1.0, Q, b, 0.0, x);
/* Solve R x = sol, storing x in-place */
gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, R, x);
return GSL_SUCCESS;
}
}
int
gsl_linalg_QRPT_Rsvx (const gsl_matrix * QR,
const gsl_permutation * p,
gsl_vector * x)
{
if (QR->size1 != QR->size2)
{
GSL_ERROR ("QR matrix must be square", GSL_ENOTSQR);
}
else if (QR->size2 != x->size)
{
GSL_ERROR ("matrix size must match x size", GSL_EBADLEN);
}
else if (p->size != x->size)
{
GSL_ERROR ("permutation size must match x size", GSL_EBADLEN);
}
else
{
/* Solve R x = b, storing x inplace */
gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, QR, x);
gsl_permute_vector_inverse (p, x);
return GSL_SUCCESS;
}
}
int
gsl_linalg_QR_Rsolve (const gsl_matrix * QR, const gsl_vector * b, gsl_vector * x)
{
if (QR->size1 != QR->size2)
{
GSL_ERROR ("QR matrix must be square", GSL_ENOTSQR);
}
else if (QR->size1 != b->size)
{
GSL_ERROR ("matrix size must match b size", GSL_EBADLEN);
}
else if (QR->size2 != x->size)
{
GSL_ERROR ("matrix size must match x size", GSL_EBADLEN);
}
else
{
/* Copy x <- b */
gsl_vector_memcpy (x, b);
/* Solve R x = b, storing x in-place */
gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, QR, x);
return GSL_SUCCESS;
}
}
int
gsl_linalg_LQ_svx_T (const gsl_matrix * LQ, const gsl_vector * tau, gsl_vector * x)
{
if (LQ->size1 != LQ->size2)
{
GSL_ERROR ("LQ matrix must be square", GSL_ENOTSQR);
}
else if (LQ->size1 != x->size)
{
GSL_ERROR ("matrix size must match x/rhs size", GSL_EBADLEN);
}
else
{
/* compute rhs = Q^T b */
gsl_linalg_LQ_vecQT (LQ, tau, x);
/* Solve R x = rhs, storing x in-place */
gsl_blas_dtrsv (CblasLower, CblasTrans, CblasNonUnit, LQ, x);
return GSL_SUCCESS;
}
}
int
gsl_linalg_QR_svx (const gsl_matrix * QR, const gsl_vector * tau, gsl_vector * x)
{
if (QR->size1 != QR->size2)
{
GSL_ERROR ("QR matrix must be square", GSL_ENOTSQR);
}
else if (QR->size1 != x->size)
{
GSL_ERROR ("matrix size must match x/rhs size", GSL_EBADLEN);
}
else
{
/* compute rhs = Q^T b */
gsl_linalg_QR_QTvec (QR, tau, x);
/* Solve R x = rhs, storing x in-place */
gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, QR, x);
return GSL_SUCCESS;
}
}
int
gsl_linalg_L_solve_T (const gsl_matrix * L, const gsl_vector * b, gsl_vector * x)
{
if (L->size1 != L->size2)
{
GSL_ERROR ("R matrix must be square", GSL_ENOTSQR);
}
else if (L->size2 != b->size)
{
GSL_ERROR ("matrix size must match b size", GSL_EBADLEN);
}
else if (L->size1 != x->size)
{
GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN);
}
else
{
/* Copy x <- b */
gsl_vector_memcpy (x, b);
/* Solve R x = b, storing x inplace in b */
gsl_blas_dtrsv (CblasLower, CblasTrans, CblasNonUnit, L, x);
return GSL_SUCCESS;
}
}
int
gsl_linalg_LQ_LQsolve (gsl_matrix * Q, gsl_matrix * L, const gsl_vector * b, gsl_vector * x)
{
const size_t N = L->size1;
const size_t M = L->size2;
if (M != N)
{
return GSL_ENOTSQR;
}
else if (Q->size1 != M || b->size != M || x->size != M)
{
return GSL_EBADLEN;
}
else
{
/* compute sol = b^T Q^T */
gsl_blas_dgemv (CblasNoTrans, 1.0, Q, b, 0.0, x);
/* Solve x^T L = sol, storing x in-place */
gsl_blas_dtrsv (CblasLower, CblasTrans, CblasNonUnit, L, x);
return GSL_SUCCESS;
}
}
int
gsl_linalg_PTLQ_svx_T (const gsl_matrix * LQ,
const gsl_vector * tau,
const gsl_permutation * p,
gsl_vector * x)
{
if (LQ->size1 != LQ->size2)
{
GSL_ERROR ("LQ matrix must be square", GSL_ENOTSQR);
}
else if (LQ->size2 != p->size)
{
GSL_ERROR ("matrix size must match permutation size", GSL_EBADLEN);
}
else if (LQ->size1 != x->size)
{
GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN);
}
else
{
/* compute sol = b^T Q^T */
gsl_linalg_LQ_vecQT (LQ, tau, x);
/* Solve L^T x = sol, storing x inplace in sol */
gsl_blas_dtrsv (CblasLower, CblasTrans, CblasNonUnit, LQ, x);
gsl_permute_vector_inverse (p, x);
return GSL_SUCCESS;
}
}
int
gsl_linalg_PTLQ_LQsolve_T (const gsl_matrix * Q, const gsl_matrix * L,
const gsl_permutation * p,
const gsl_vector * b,
gsl_vector * x)
{
if (Q->size1 != Q->size2 || L->size1 != L->size2)
{
return GSL_ENOTSQR;
}
else if (Q->size1 != p->size || Q->size1 != L->size1
|| Q->size1 != b->size)
{
return GSL_EBADLEN;
}
else
{
/* compute b' = Q b */
gsl_blas_dgemv (CblasNoTrans, 1.0, Q, b, 0.0, x);
/* Solve L^T x = b', storing x inplace */
gsl_blas_dtrsv (CblasLower, CblasTrans, CblasNonUnit, L, x);
/* Apply permutation to solution in place */
gsl_permute_vector_inverse (p, x);
return GSL_SUCCESS;
}
}
static void
_ncm_data_gauss_cov_leastsquares_f (NcmData *data, NcmMSet *mset, NcmVector *v)
{
NcmDataGaussCov *gauss = NCM_DATA_GAUSS_COV (data);
NcmDataGaussCovClass *gauss_cov_class = NCM_DATA_GAUSS_COV_GET_CLASS (gauss);
gboolean cov_update = FALSE;
gint ret;
if (ncm_data_bootstrap_enabled (data))
g_error ("NcmDataGaussCov: does not support bootstrap with least squares");
gauss_cov_class->mean_func (gauss, mset, v);
ncm_vector_sub (v, gauss->y);
if (gauss_cov_class->cov_func != NULL)
cov_update = gauss_cov_class->cov_func (gauss, mset, gauss->cov);
if (cov_update || !gauss->prepared_LLT)
_ncm_data_gauss_cov_prepare_LLT (data);
/* CblasLower, CblasNoTrans => CblasUpper, CblasTrans */
ret = gsl_blas_dtrsv (CblasUpper, CblasTrans, CblasNonUnit,
ncm_matrix_gsl (gauss->LLT), ncm_vector_gsl (v));
NCM_TEST_GSL_RESULT ("_ncm_data_gauss_cov_leastsquares_f", ret);
}
int
gsl_linalg_PTLQ_Lsvx_T (const gsl_matrix * LQ,
const gsl_permutation * p,
gsl_vector * x)
{
if (LQ->size1 != LQ->size2)
{
GSL_ERROR ("LQ matrix must be square", GSL_ENOTSQR);
}
else if (LQ->size2 != x->size)
{
GSL_ERROR ("matrix size must match x size", GSL_EBADLEN);
}
else if (p->size != x->size)
{
GSL_ERROR ("permutation size must match x size", GSL_EBADLEN);
}
else
{
/* Solve L^T x = b, storing x inplace */
gsl_blas_dtrsv (CblasLower, CblasTrans, CblasNonUnit, LQ, x);
gsl_permute_vector_inverse (p, x);
return GSL_SUCCESS;
}
}
static void
_ncm_data_gauss_cov_m2lnL_val (NcmData *data, NcmMSet *mset, gdouble *m2lnL)
{
NcmDataGaussCov *gauss = NCM_DATA_GAUSS_COV (data);
NcmDataGaussCovClass *gauss_cov_class = NCM_DATA_GAUSS_COV_GET_CLASS (gauss);
gboolean cov_update = FALSE;
gint ret;
*m2lnL = 0.0;
gauss_cov_class->mean_func (gauss, mset, gauss->v);
ncm_vector_sub (gauss->v, gauss->y);
if (gauss_cov_class->cov_func != NULL)
cov_update = gauss_cov_class->cov_func (gauss, mset, gauss->cov);
if (cov_update || !gauss->prepared_LLT)
_ncm_data_gauss_cov_prepare_LLT (data);
if (!gauss->prepared_LLT) /* that means that the Cholesky decomposition has not worked */
{
*m2lnL = GSL_POSINF;
return;
}
/* CblasLower, CblasNoTrans => CblasUpper, CblasTrans */
ret = gsl_blas_dtrsv (CblasUpper, CblasTrans, CblasNonUnit,
ncm_matrix_gsl (gauss->LLT), ncm_vector_gsl (gauss->v));
NCM_TEST_GSL_RESULT ("_ncm_data_gauss_cov_m2lnL_val", ret);
if (!ncm_data_bootstrap_enabled (data))
{
ret = gsl_blas_ddot (ncm_vector_gsl (gauss->v),
ncm_vector_gsl (gauss->v),
m2lnL);
NCM_TEST_GSL_RESULT ("_ncm_data_gauss_cov_m2lnL_val", ret);
if (gauss->use_norma)
{
gauss_cov_class->lnNorma2 (gauss, mset, m2lnL);
}
}
else
{
const guint bsize = ncm_bootstrap_get_bsize (data->bstrap);
guint i;
g_assert (ncm_bootstrap_is_init (data->bstrap));
for (i = 0; i < bsize; i++)
{
guint k = ncm_bootstrap_get (data->bstrap, i);
const gdouble u_i = ncm_vector_get (gauss->v, k);
*m2lnL += u_i * u_i;
}
if (gauss->use_norma)
gauss_cov_class->lnNorma2_bs (gauss, mset, data->bstrap, m2lnL);
}
}
/* Compute the log of the probability density function at a given quantile
* vector for a multivariate Gaussian distribution using the Cholesky
* decomposition of the variance-covariance matrix.
*
* x vector of quantiles (dimension d)
* mu mean vector (dimension d)
* L matrix resulting from the Cholesky decomposition of
* variance-covariance matrix Sigma = L L^T (dimension d x d)
* result output of the density (dimension 1)
* work vector used for intermediate computations (dimension d)
*/
int
gsl_ran_multivariate_gaussian_log_pdf (const gsl_vector * x,
const gsl_vector * mu,
const gsl_matrix * L,
double * result,
gsl_vector * work)
{
const size_t M = L->size1;
const size_t N = L->size2;
if (M != N)
{
GSL_ERROR("requires square matrix", GSL_ENOTSQR);
}
else if (mu->size != M)
{
GSL_ERROR("incompatible dimension of mean vector with variance-covariance matrix", GSL_EBADLEN);
}
else if (x->size != M)
{
GSL_ERROR("incompatible dimension of quantile vector", GSL_EBADLEN);
}
else if (work->size != M)
{
GSL_ERROR("incompatible dimension of work vector", GSL_EBADLEN);
}
else
{
size_t i;
double quadForm; /* (x - mu)' Sigma^{-1} (x - mu) */
double logSqrtDetSigma; /* log [ sqrt(|Sigma|) ] */
/* compute: work = x - mu */
for (i = 0; i < M; ++i)
{
double xi = gsl_vector_get(x, i);
double mui = gsl_vector_get(mu, i);
gsl_vector_set(work, i, xi - mui);
}
/* compute: work = L^{-1} * (x - mu) */
gsl_blas_dtrsv(CblasLower, CblasNoTrans, CblasNonUnit, L, work);
/* compute: quadForm = (x - mu)' Sigma^{-1} (x - mu) */
gsl_blas_ddot(work, work, &quadForm);
/* compute: log [ sqrt(|Sigma|) ] = sum_i log L_{ii} */
logSqrtDetSigma = 0.0;
for (i = 0; i < M; ++i)
{
double Lii = gsl_matrix_get(L, i, i);
logSqrtDetSigma += log(Lii);
}
*result = -0.5*quadForm - logSqrtDetSigma - 0.5*M*log(2.0*M_PI);
return GSL_SUCCESS;
}
}
int
gsl_linalg_COD_lssolve (const gsl_matrix * QRZ, const gsl_vector * tau_Q, const gsl_vector * tau_Z,
const gsl_permutation * perm, const size_t rank, const gsl_vector * b,
gsl_vector * x, gsl_vector * residual)
{
const size_t M = QRZ->size1;
const size_t N = QRZ->size2;
if (M < N)
{
GSL_ERROR ("QRZ matrix must have M>=N", GSL_EBADLEN);
}
else if (M != b->size)
{
GSL_ERROR ("matrix size must match b size", GSL_EBADLEN);
}
else if (rank > GSL_MIN (M, N))
{
GSL_ERROR ("rank must be <= MIN(M,N)", GSL_EBADLEN);
}
else if (N != x->size)
{
GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN);
}
else if (M != residual->size)
{
GSL_ERROR ("matrix size must match residual size", GSL_EBADLEN);
}
else
{
gsl_matrix_const_view R11 = gsl_matrix_const_submatrix (QRZ, 0, 0, rank, rank);
gsl_vector_view QTb1 = gsl_vector_subvector(residual, 0, rank);
gsl_vector_view x1 = gsl_vector_subvector(x, 0, rank);
gsl_vector_set_zero(x);
/* compute residual = Q^T b */
gsl_vector_memcpy(residual, b);
gsl_linalg_QR_QTvec (QRZ, tau_Q, residual);
/* solve x1 := R11^{-1} (Q^T b)(1:r) */
gsl_vector_memcpy(&(x1.vector), &(QTb1.vector));
gsl_blas_dtrsv(CblasUpper, CblasNoTrans, CblasNonUnit, &(R11.matrix), &(x1.vector));
/* compute Z^T ( R11^{-1} x1; 0 ) */
cod_householder_ZTvec(QRZ, tau_Z, rank, x);
/* compute x = P Z^T ( R11^{-1} x1; 0 ) */
gsl_permute_vector_inverse(perm, x);
/* compute residual = b - A x = Q (Q^T b - R [ R11^{-1} x1; 0 ]) */
gsl_vector_set_zero(&(QTb1.vector));
gsl_linalg_QR_Qvec(QRZ, tau_Q, residual);
return GSL_SUCCESS;
}
}
int
gsl_linalg_QRPT_lssolve2 (const gsl_matrix * QR, const gsl_vector * tau, const gsl_permutation * p,
const gsl_vector * b, const size_t rank, gsl_vector * x, gsl_vector * residual)
{
const size_t M = QR->size1;
const size_t N = QR->size2;
if (M < N)
{
GSL_ERROR ("QR matrix must have M>=N", GSL_EBADLEN);
}
else if (M != b->size)
{
GSL_ERROR ("matrix size must match b size", GSL_EBADLEN);
}
else if (rank == 0 || rank > N)
{
GSL_ERROR ("rank must have 0 < rank <= N", GSL_EBADLEN);
}
else if (N != x->size)
{
GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN);
}
else if (M != residual->size)
{
GSL_ERROR ("matrix size must match residual size", GSL_EBADLEN);
}
else
{
gsl_matrix_const_view R11 = gsl_matrix_const_submatrix (QR, 0, 0, rank, rank);
gsl_vector_view QTb1 = gsl_vector_subvector(residual, 0, rank);
gsl_vector_view x1 = gsl_vector_subvector(x, 0, rank);
size_t i;
/* compute work = Q^T b */
gsl_vector_memcpy(residual, b);
gsl_linalg_QR_QTvec (QR, tau, residual);
/* solve R_{11} x(1:r) = [Q^T b](1:r) */
gsl_vector_memcpy(&(x1.vector), &(QTb1.vector));
gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, &(R11.matrix), &(x1.vector));
/* x(r+1:N) = 0 */
for (i = rank; i < N; ++i)
gsl_vector_set(x, i, 0.0);
/* compute x = P y */
gsl_permute_vector_inverse (p, x);
/* compute residual = b - A x = Q (Q^T b - R x) */
gsl_vector_set_zero(&(QTb1.vector));
gsl_linalg_QR_Qvec(QR, tau, residual);
return GSL_SUCCESS;
}
}
/* x := A^{-1} x = A^{-t} x, A = L L^T */
static int
cholesky_Ainv(CBLAS_TRANSPOSE_t TransA, gsl_vector * x, void * params)
{
int status;
gsl_matrix * A = (gsl_matrix * ) params;
(void) TransA; /* unused parameter warning */
/* compute L^{-1} x */
status = gsl_blas_dtrsv(CblasLower, CblasNoTrans, CblasNonUnit, A, x);
if (status)
return status;
/* compute L^{-t} x */
status = gsl_blas_dtrsv(CblasLower, CblasTrans, CblasNonUnit, A, x);
if (status)
return status;
return GSL_SUCCESS;
}
int
gsl_linalg_pcholesky_svx(const gsl_matrix * LDLT,
const gsl_permutation * p,
gsl_vector * x)
{
if (LDLT->size1 != LDLT->size2)
{
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 (LDLT->size2 != x->size)
{
GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN);
}
else
{
gsl_vector_const_view D = gsl_matrix_const_diagonal(LDLT);
/* x := P b */
gsl_permute_vector(p, x);
/* solve: L w = P b */
gsl_blas_dtrsv(CblasLower, CblasNoTrans, CblasUnit, LDLT, x);
/* solve: D y = w */
gsl_vector_div(x, &D.vector);
/* solve: L^T z = y */
gsl_blas_dtrsv(CblasLower, CblasTrans, CblasUnit, LDLT, x);
/* compute: x = P^T z */
gsl_permute_vector_inverse(p, x);
return GSL_SUCCESS;
}
}
int
gsl_linalg_cholesky_svx (const gsl_matrix * LLT,
gsl_vector * x)
{
if (LLT->size1 != LLT->size2)
{
GSL_ERROR ("cholesky matrix must be square", GSL_ENOTSQR);
}
else if (LLT->size2 != x->size)
{
GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN);
}
else
{
/* solve for c using forward-substitution, L c = b */
gsl_blas_dtrsv (CblasLower, CblasNoTrans, CblasNonUnit, LLT, x);
/* perform back-substitution, L^T x = c */
gsl_blas_dtrsv (CblasLower, CblasTrans, CblasNonUnit, LLT, x);
return GSL_SUCCESS;
}
}
int
gsl_linalg_LQ_lssolve_T (const gsl_matrix * LQ, const gsl_vector * tau, const gsl_vector * b, gsl_vector * x, gsl_vector * residual)
{
const size_t N = LQ->size1;
const size_t M = LQ->size2;
if (M < N)
{
GSL_ERROR ("LQ matrix must have M>=N", GSL_EBADLEN);
}
else if (M != b->size)
{
GSL_ERROR ("matrix size must match b size", GSL_EBADLEN);
}
else if (N != x->size)
{
GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN);
}
else if (M != residual->size)
{
GSL_ERROR ("matrix size must match residual size", GSL_EBADLEN);
}
else
{
gsl_matrix_const_view L = gsl_matrix_const_submatrix (LQ, 0, 0, N, N);
gsl_vector_view c = gsl_vector_subvector(residual, 0, N);
gsl_vector_memcpy(residual, b);
/* compute rhs = b^T Q^T */
gsl_linalg_LQ_vecQT (LQ, tau, residual);
/* Solve x^T L = rhs */
gsl_vector_memcpy(x, &(c.vector));
gsl_blas_dtrsv (CblasLower, CblasTrans, CblasNonUnit, &(L.matrix), x);
/* Compute residual = b^T - x^T A = (b^T Q^T - x^T L) Q */
gsl_vector_set_zero(&(c.vector));
gsl_linalg_LQ_vecQ(LQ, tau, residual);
return GSL_SUCCESS;
}
}
int
gsl_linalg_QR_lssolve (const gsl_matrix * QR, const gsl_vector * tau, const gsl_vector * b, gsl_vector * x, gsl_vector * residual)
{
const size_t M = QR->size1;
const size_t N = QR->size2;
if (M < N)
{
GSL_ERROR ("QR matrix must have M>=N", GSL_EBADLEN);
}
else if (M != b->size)
{
GSL_ERROR ("matrix size must match b size", GSL_EBADLEN);
}
else if (N != x->size)
{
GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN);
}
else if (M != residual->size)
{
GSL_ERROR ("matrix size must match residual size", GSL_EBADLEN);
}
else
{
gsl_matrix_const_view R = gsl_matrix_const_submatrix (QR, 0, 0, N, N);
gsl_vector_view c = gsl_vector_subvector(residual, 0, N);
gsl_vector_memcpy(residual, b);
/* compute rhs = Q^T b */
gsl_linalg_QR_QTvec (QR, tau, residual);
/* Solve R x = rhs */
gsl_vector_memcpy(x, &(c.vector));
gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, &(R.matrix), x);
/* Compute residual = b - A x = Q (Q^T b - R x) */
gsl_vector_set_zero(&(c.vector));
gsl_linalg_QR_Qvec(QR, tau, residual);
return GSL_SUCCESS;
}
}
int
gsl_eigen_gensymm_standardize(gsl_matrix *A, const gsl_matrix *B)
{
const size_t N = A->size1;
size_t i;
double a, b, c;
for (i = 0; i < N; ++i)
{
/* update lower triangle of A(i:n, i:n) */
a = gsl_matrix_get(A, i, i);
b = gsl_matrix_get(B, i, i);
a /= b * b;
gsl_matrix_set(A, i, i, a);
if (i < N - 1)
{
gsl_vector_view ai = gsl_matrix_subcolumn(A, i, i + 1, N - i - 1);
gsl_matrix_view ma =
gsl_matrix_submatrix(A, i + 1, i + 1, N - i - 1, N - i - 1);
gsl_vector_const_view bi =
gsl_matrix_const_subcolumn(B, i, i + 1, N - i - 1);
gsl_matrix_const_view mb =
gsl_matrix_const_submatrix(B, i + 1, i + 1, N - i - 1, N - i - 1);
gsl_blas_dscal(1.0 / b, &ai.vector);
c = -0.5 * a;
gsl_blas_daxpy(c, &bi.vector, &ai.vector);
gsl_blas_dsyr2(CblasLower, -1.0, &ai.vector, &bi.vector, &ma.matrix);
gsl_blas_daxpy(c, &bi.vector, &ai.vector);
gsl_blas_dtrsv(CblasLower,
CblasNoTrans,
CblasNonUnit,
&mb.matrix,
&ai.vector);
}
}
return GSL_SUCCESS;
} /* gsl_eigen_gensymm_standardize() */
int
gsl_linalg_LQ_Lsvx_T (const gsl_matrix * LQ, gsl_vector * x)
{
if (LQ->size1 != LQ->size2)
{
GSL_ERROR ("LQ matrix must be square", GSL_ENOTSQR);
}
else if (LQ->size2 != x->size)
{
GSL_ERROR ("matrix size must match rhs size", GSL_EBADLEN);
}
else
{
/* Solve x^T L = b^T, storing x in-place */
gsl_blas_dtrsv (CblasLower, CblasTrans, CblasNonUnit, LQ, x);
return GSL_SUCCESS;
}
}
int
gsl_linalg_R_svx (const gsl_matrix * R, gsl_vector * x)
{
if (R->size1 != R->size2)
{
GSL_ERROR ("R matrix must be square", GSL_ENOTSQR);
}
else if (R->size2 != x->size)
{
GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN);
}
else
{
/* Solve R x = b, storing x inplace in b */
gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, R, x);
return GSL_SUCCESS;
}
}
int
gsl_multifit_linear_wgenform2 (const gsl_matrix * LQR,
const gsl_vector * Ltau,
const gsl_matrix * X,
const gsl_vector * w,
const gsl_vector * y,
const gsl_vector * cs,
const gsl_matrix * M,
gsl_vector * c,
gsl_multifit_linear_workspace * work)
{
const size_t m = LQR->size1;
const size_t n = X->size1;
const size_t p = X->size2;
if (n > work->nmax || p > work->pmax)
{
GSL_ERROR("X matrix does not match workspace", GSL_EBADLEN);
}
else if (p != LQR->size2)
{
GSL_ERROR("LQR matrix does not match X", GSL_EBADLEN);
}
else if (p != c->size)
{
GSL_ERROR("c vector does not match X", GSL_EBADLEN);
}
else if (w != NULL && n != w->size)
{
GSL_ERROR("w vector does not match X", GSL_EBADLEN);
}
else if (n != y->size)
{
GSL_ERROR("y vector does not match X", GSL_EBADLEN);
}
else if (m >= p) /* square or tall L matrix */
{
if (p != cs->size)
{
GSL_ERROR("cs vector must be length p", GSL_EBADLEN);
}
else
{
int s;
gsl_matrix_const_view R = gsl_matrix_const_submatrix(LQR, 0, 0, p, p); /* R factor of L */
/* solve R c = cs for true solution c, using QR decomposition of L */
gsl_vector_memcpy(c, cs);
s = gsl_blas_dtrsv(CblasUpper, CblasNoTrans, CblasNonUnit, &R.matrix, c);
return s;
}
}
else /* rectangular L matrix with m < p */
{
if (m != cs->size)
{
GSL_ERROR("cs vector must be length m", GSL_EBADLEN);
}
else if (n != M->size1 || p != M->size2)
{
GSL_ERROR("M matrix must be size n-by-p", GSL_EBADLEN);
}
else
{
int status;
const size_t pm = p - m;
gsl_matrix_view A = gsl_matrix_submatrix(work->A, 0, 0, n, p);
gsl_vector_view b = gsl_vector_subvector(work->t, 0, n);
gsl_matrix_view Rp = gsl_matrix_view_array(LQR->data, m, m); /* R_p */
gsl_matrix_view LTQR = gsl_matrix_view_array(LQR->data, p, m);
gsl_vector_const_view LTtau = gsl_vector_const_subvector(Ltau, 0, m);
gsl_matrix_const_view MQR = gsl_matrix_const_submatrix(M, 0, 0, n, pm);
gsl_vector_const_view Mtau = gsl_matrix_const_subcolumn(M, p - 1, 0, GSL_MIN(n, pm));
gsl_matrix_const_view To = gsl_matrix_const_submatrix(&MQR.matrix, 0, 0, pm, pm);
gsl_vector_view workp = gsl_vector_subvector(work->xt, 0, p);
gsl_vector_view v1, v2;
/* compute A = sqrt(W) X and b = sqrt(W) y */
status = gsl_multifit_linear_applyW(X, w, y, &A.matrix, &b.vector);
if (status)
return status;
/* initialize c to zero */
gsl_vector_set_zero(c);
/* compute c = L_inv cs = K_p R_p^{-T} cs */
/* set c(1:m) = R_p^{-T} cs */
v1 = gsl_vector_subvector(c, 0, m);
gsl_vector_memcpy(&v1.vector, cs);
gsl_blas_dtrsv(CblasUpper, CblasTrans, CblasNonUnit, &Rp.matrix, &v1.vector);
/* c <- K R_p^{-T} cs = [ K_p R_p^{_T} cs ; 0 ] */
gsl_linalg_QR_Qvec(<QR.matrix, <tau.vector, c);
/* compute: b1 = b - A L_inv cs */
gsl_blas_dgemv(CblasNoTrans, -1.0, &A.matrix, c, 1.0, &b.vector);
/* compute: b2 = H^T b1 */
gsl_linalg_QR_QTvec(&MQR.matrix, &Mtau.vector, &b.vector);
/* compute: b3 = T_o^{-1} b2 */
v1 = gsl_vector_subvector(&b.vector, 0, pm);
gsl_blas_dtrsv(CblasUpper, CblasNoTrans, CblasNonUnit, &To.matrix, &v1.vector);
/* compute: b4 = K_o b3 */
gsl_vector_set_zero(&workp.vector);
v2 = gsl_vector_subvector(&workp.vector, m, pm);
gsl_vector_memcpy(&v2.vector, &v1.vector);
gsl_linalg_QR_Qvec(<QR.matrix, <tau.vector, &workp.vector);
/* final solution vector */
gsl_vector_add(c, &workp.vector);
return GSL_SUCCESS;
}
}
}
static int
gmres_iterate(const gsl_spmatrix *A, const gsl_vector *b,
const double tol, gsl_vector *x,
void *vstate)
{
const size_t N = A->size1;
gmres_state_t *state = (gmres_state_t *) vstate;
if (N != A->size2)
{
GSL_ERROR("matrix must be square", GSL_ENOTSQR);
}
else if (N != b->size)
{
GSL_ERROR("matrix does not match right hand side", GSL_EBADLEN);
}
else if (N != x->size)
{
GSL_ERROR("matrix does not match solution vector", GSL_EBADLEN);
}
else if (N != state->n)
{
GSL_ERROR("matrix does not match workspace", GSL_EBADLEN);
}
else
{
int status = GSL_SUCCESS;
const size_t maxit = state->m;
const double normb = gsl_blas_dnrm2(b); /* ||b|| */
const double reltol = tol * normb; /* tol*||b|| */
double normr; /* ||r|| */
size_t m, k;
double tau; /* householder scalar */
gsl_matrix *H = state->H; /* Hessenberg matrix */
gsl_vector *r = state->r; /* residual vector */
gsl_vector *w = state->y; /* least squares RHS */
gsl_matrix_view Rm; /* R_m = H(1:m,2:m+1) */
gsl_vector_view ym; /* y(1:m) */
gsl_vector_view h0 = gsl_matrix_column(H, 0);
/*
* The Hessenberg matrix will have the following structure:
*
* H = [ ||r_0|| | v_1 v_2 ... v_m ]
* [ u_1 | u_2 u_3 ... u_{m+1} ]
*
* where v_j are the orthonormal vectors spanning the Krylov
* subpsace of length j + 1 and u_{j+1} are the householder
* vectors of length n - j - 1.
* In fact, u_{j+1} has length n - j since u_{j+1}[0] = 1,
* but this 1 is not stored.
*/
gsl_matrix_set_zero(H);
/* Step 1a: compute r = b - A*x_0 */
gsl_vector_memcpy(r, b);
gsl_spblas_dgemv(CblasNoTrans, -1.0, A, x, 1.0, r);
/* Step 1b */
gsl_vector_memcpy(&h0.vector, r);
tau = gsl_linalg_householder_transform(&h0.vector);
/* store tau_1 */
gsl_vector_set(state->tau, 0, tau);
/* initialize w (stored in state->y) */
gsl_vector_set_zero(w);
gsl_vector_set(w, 0, gsl_vector_get(&h0.vector, 0));
for (m = 1; m <= maxit; ++m)
{
size_t j = m - 1; /* C indexing */
double c, s; /* Givens rotation */
/* v_m */
gsl_vector_view vm = gsl_matrix_column(H, m);
/* v_m(m:end) */
gsl_vector_view vv = gsl_vector_subvector(&vm.vector, j, N - j);
/* householder vector u_m for projection P_m */
gsl_vector_view um = gsl_matrix_subcolumn(H, j, j, N - j);
/* Step 2a: form v_m = P_m e_m = e_m - tau_m w_m */
gsl_vector_set_zero(&vm.vector);
gsl_vector_memcpy(&vv.vector, &um.vector);
tau = gsl_vector_get(state->tau, j); /* tau_m */
gsl_vector_scale(&vv.vector, -tau);
gsl_vector_set(&vv.vector, 0, 1.0 - tau);
/* Step 2a: v_m <- P_1 P_2 ... P_{m-1} v_m */
for (k = j; k > 0 && k--; )
{
gsl_vector_view uk =
gsl_matrix_subcolumn(H, k, k, N - k);
gsl_vector_view vk =
gsl_vector_subvector(&vm.vector, k, N - k);
tau = gsl_vector_get(state->tau, k);
gsl_linalg_householder_hv(tau, &uk.vector, &vk.vector);
}
/* Step 2a: v_m <- A*v_m */
gsl_spblas_dgemv(CblasNoTrans, 1.0, A, &vm.vector, 0.0, r);
gsl_vector_memcpy(&vm.vector, r);
/* Step 2a: v_m <- P_m ... P_1 v_m */
for (k = 0; k <= j; ++k)
{
gsl_vector_view uk = gsl_matrix_subcolumn(H, k, k, N - k);
gsl_vector_view vk = gsl_vector_subvector(&vm.vector, k, N - k);
tau = gsl_vector_get(state->tau, k);
gsl_linalg_householder_hv(tau, &uk.vector, &vk.vector);
}
/* Steps 2c,2d: find P_{m+1} and set v_m <- P_{m+1} v_m */
if (m < N)
{
/* householder vector u_{m+1} for projection P_{m+1} */
gsl_vector_view ump1 = gsl_matrix_subcolumn(H, m, m, N - m);
tau = gsl_linalg_householder_transform(&ump1.vector);
gsl_vector_set(state->tau, j + 1, tau);
}
/* Step 2e: v_m <- J_{m-1} ... J_1 v_m */
for (k = 0; k < j; ++k)
{
gsl_linalg_givens_gv(&vm.vector, k, k + 1,
state->c[k], state->s[k]);
}
if (m < N)
{
/* Step 2g: find givens rotation J_m for v_m(m:m+1) */
gsl_linalg_givens(gsl_vector_get(&vm.vector, j),
gsl_vector_get(&vm.vector, j + 1),
&c, &s);
/* store givens rotation for later use */
state->c[j] = c;
state->s[j] = s;
/* Step 2h: v_m <- J_m v_m */
gsl_linalg_givens_gv(&vm.vector, j, j + 1, c, s);
/* Step 2h: w <- J_m w */
gsl_linalg_givens_gv(w, j, j + 1, c, s);
}
/*
* Step 2i: R_m = [ R_{m-1}, v_m ] - already taken care
* of due to our memory storage scheme
*/
/* Step 2j: check residual w_{m+1} for convergence */
normr = fabs(gsl_vector_get(w, j + 1));
if (normr <= reltol)
{
/*
* method has converged, break out of loop to compute
* update to solution vector x
*/
break;
}
}
/*
* At this point, we have either converged to a solution or
* completed all maxit iterations. In either case, compute
* an update to the solution vector x and test again for
* convergence.
*/
/* rewind m if we exceeded maxit iterations */
if (m > maxit)
m--;
/* Step 3a: solve triangular system R_m y_m = w, in place */
Rm = gsl_matrix_submatrix(H, 0, 1, m, m);
ym = gsl_vector_subvector(w, 0, m);
gsl_blas_dtrsv(CblasUpper, CblasNoTrans, CblasNonUnit,
&Rm.matrix, &ym.vector);
/*
* Step 3b: update solution vector x; the loop below
* uses a different but equivalent formulation from
* Saad, algorithm 6.10, step 14; store Krylov projection
* V_m y_m in 'r'
*/
gsl_vector_set_zero(r);
for (k = m; k > 0 && k--; )
{
double ymk = gsl_vector_get(&ym.vector, k);
gsl_vector_view uk = gsl_matrix_subcolumn(H, k, k, N - k);
gsl_vector_view rk = gsl_vector_subvector(r, k, N - k);
/* r <- n_k e_k + r */
gsl_vector_set(r, k, gsl_vector_get(r, k) + ymk);
/* r <- P_k r */
tau = gsl_vector_get(state->tau, k);
gsl_linalg_householder_hv(tau, &uk.vector, &rk.vector);
}
/* x <- x + V_m y_m */
gsl_vector_add(x, r);
/* compute new residual r = b - A*x */
gsl_vector_memcpy(r, b);
gsl_spblas_dgemv(CblasNoTrans, -1.0, A, x, 1.0, r);
normr = gsl_blas_dnrm2(r);
if (normr <= reltol)
status = GSL_SUCCESS; /* converged */
else
status = GSL_CONTINUE; /* not yet converged */
/* store residual norm */
state->normr = normr;
return status;
}
} /* gmres_iterate() */
/**
* C++ version of gsl_blas_dtrsv().
* @param Uplo Upper or lower triangular
* @param TransA Transpose type
* @param Diag Diagonal type
* @param A A matrix
* @param X A vector
* @return Error code on failure
*/
int dtrsv( CBLAS_UPLO_t Uplo, CBLAS_TRANSPOSE_t TransA, CBLAS_DIAG_t Diag,
matrix const& A, vector& X ){
return gsl_blas_dtrsv( Uplo, TransA, Diag, A.get(), X.get() ); }
int lseShurComplement(gsl_matrix * A, gsl_matrix * C,
gsl_vector * b, gsl_vector * d,
gsl_vector * x, gsl_vector * lambda, double * sigma)
{
int i;
double xi;
gsl_vector *c0, *S, *tau;
gsl_matrix *CT, *U;
gsl_permutation *perm;
gsl_vector_view row, cp;
gsl_matrix_view R;
if (A->size2 != C->size2) return -1;
if (A->size2 != x->size) return -1;
if (A->size1 < A->size2) return -1;
if (b != NULL && A->size1 != b->size) return -1;
if (C->size1 != d->size) return -1;
if (C->size1 != lambda->size) return -1;
c0 = gsl_vector_alloc(x->size);
gsl_matrix_get_row(c0, C, 0);
/* Cholesky factorization of A^T A = R^T R via QRPT decomposition */
perm = gsl_permutation_alloc(x->size);
tau = gsl_vector_alloc(x->size);
gsl_linalg_QRPT_decomp(A, tau, perm, &i, x);
/* cp = R^{-T} P A^T b = Q^T b */
if (b != NULL) {
gsl_linalg_QR_QTvec(A, tau, b);
cp = gsl_vector_subvector(b, 0, x->size);
}
gsl_vector_free(tau);
/* C P -> C */
R = gsl_matrix_submatrix(A, 0, 0, A->size2, A->size2);
for (i = 0; i < C->size1; ++i) {
row = gsl_matrix_row(C, i);
gsl_permute_vector(perm, &row.vector);
}
/* Compute C inv(R) -> C */
gsl_blas_dtrsm(CblasRight, CblasUpper, CblasNoTrans, CblasNonUnit, 1.0,
&R.matrix, C);
/* The Schur complement D = C C^T,
Compute SVD of D = U S^2 U^T by SVD of C^T = V S U^T */
CT = gsl_matrix_alloc(C->size2, C->size1);
gsl_matrix_transpose_memcpy(CT, C);
U = gsl_matrix_alloc(CT->size2, CT->size2);
S = gsl_vector_alloc(CT->size2);
gsl_linalg_SV_decomp(CT, U, S, lambda);
/* Right hand side of the Shur complement system
d - C (A^T A)^-1 A^T b = d - C cp -> d
(with C P R^-1 -> C and R^-T P^T A^T b -> cp) */
if (b != NULL) {
gsl_blas_dgemv(CblasNoTrans, -1.0, C, &cp.vector, 1.0, d);
}
/* Calculate S U^T lambda, where -lambda is the Lagrange multiplier */
gsl_blas_dgemv(CblasTrans, 1.0, U, d, 0.0, lambda);
gsl_vector_div(lambda, S);
/* Calculate sigma = || A x ||_2 = || x ||_2 (before inv(R) x -> x) */
*sigma = gsl_blas_dnrm2(lambda);
/* Compute inv(R)^T C^T lambda = C^T lambda (with C inv(R) ->C) */
gsl_blas_dgemv(CblasNoTrans, 1.0, CT, lambda, 0.0, x);
/* x = inv(A^T A) C^T lambda = inv(R) [inv(R)^T C^T lambda] */
if (R.matrix.data[R.matrix.size1 * R.matrix.size2 - 1] != 0.0) {
gsl_blas_dtrsv(CblasUpper, CblasNoTrans, CblasNonUnit, &R.matrix, x);
}
else { /* Special case when A is singular */
gsl_vector_set_basis(x, x->size - 1);
*sigma = 0.0;
}
/* Permute back, 1-step iterative refinement on first constraint */
gsl_permute_vector_inverse(perm, x);
gsl_blas_ddot(x, c0, &xi);
gsl_vector_scale(x, d->data[0] / xi);
/* get the real lambda from S U^T lambda previously stored in lambda */
gsl_vector_div(lambda, S);
gsl_vector_memcpy(S, lambda);
gsl_blas_dgemv(CblasNoTrans, 1.0, U, S, 0.0, lambda);
gsl_vector_free(c0);
gsl_vector_free(S);
gsl_matrix_free(U);
gsl_matrix_free(CT);
gsl_permutation_free(perm);
return 0;
}