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_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;
}
}
}
int
gsl_linalg_COD_unpack(const gsl_matrix * QRZ, const gsl_vector * tau_Q,
const gsl_vector * tau_Z, const size_t rank, gsl_matrix * Q,
gsl_matrix * R, gsl_matrix * Z)
{
const size_t M = QRZ->size1;
const size_t N = QRZ->size2;
if (tau_Q->size != GSL_MIN (M, N))
{
GSL_ERROR ("size of tau_Q must be MIN(M,N)", GSL_EBADLEN);
}
else if (tau_Z->size != GSL_MIN (M, N))
{
GSL_ERROR ("size of tau_Z must be MIN(M,N)", GSL_EBADLEN);
}
else if (rank > GSL_MIN (M, N))
{
GSL_ERROR ("rank must be <= MIN(M,N)", GSL_EBADLEN);
}
else if (Q->size1 != M || Q->size2 != M)
{
GSL_ERROR ("Q must by M-by-M", GSL_EBADLEN);
}
else if (R->size1 != M || R->size2 != N)
{
GSL_ERROR ("R must by M-by-N", GSL_EBADLEN);
}
else if (Z->size1 != N || Z->size2 != N)
{
GSL_ERROR ("Z must by N-by-N", GSL_EBADLEN);
}
else
{
size_t i;
gsl_matrix_view R11 = gsl_matrix_submatrix(R, 0, 0, rank, rank);
gsl_matrix_const_view QRZ11 = gsl_matrix_const_submatrix(QRZ, 0, 0, rank, rank);
/* form Q matrix */
gsl_matrix_set_identity(Q);
for (i = GSL_MIN (M, N); i-- > 0;)
{
gsl_vector_const_view h = gsl_matrix_const_subcolumn (QRZ, i, i, M - i);
gsl_matrix_view m = gsl_matrix_submatrix (Q, i, i, M - i, M - i);
double ti = gsl_vector_get (tau_Q, i);
gsl_linalg_householder_hm (ti, &h.vector, &m.matrix);
}
/* form Z matrix */
gsl_matrix_set_identity(Z);
if (rank < N)
{
gsl_vector_view work = gsl_matrix_row(R, 0); /* temporary workspace, size N */
/* multiply I by Z from the right */
gsl_linalg_COD_matZ(QRZ, tau_Z, rank, Z, &work.vector);
}
/* copy rank-by-rank upper triangle of QRZ into R and zero the rest */
gsl_matrix_set_zero(R);
gsl_matrix_tricpy('U', 1, &R11.matrix, &QRZ11.matrix);
return GSL_SUCCESS;
}
}
