int
gsl_linalg_QRPT_update (gsl_matrix * Q, gsl_matrix * R,
const gsl_permutation * p,
gsl_vector * w, const gsl_vector * v)
{
const size_t M = R->size1;
const size_t N = R->size2;
if (Q->size1 != M || Q->size2 != M)
{
GSL_ERROR ("Q matrix must be M x M if R is M x N", GSL_ENOTSQR);
}
else if (w->size != M)
{
GSL_ERROR ("w must be length M if R is M x N", GSL_EBADLEN);
}
else if (v->size != N)
{
GSL_ERROR ("v must be length N if R is M x N", GSL_EBADLEN);
}
else
{
size_t j, k;
double w0;
/* Apply Given's rotations to reduce w to (|w|, 0, 0, ... , 0)
J_1^T .... J_(n-1)^T w = +/- |w| e_1
simultaneously applied to R, H = J_1^T ... J^T_(n-1) R
so that H is upper Hessenberg. (12.5.2) */
for (k = M - 1; k > 0; k--)
{
double c, s;
double wk = gsl_vector_get (w, k);
double wkm1 = gsl_vector_get (w, k - 1);
gsl_linalg_givens (wkm1, wk, &c, &s);
gsl_linalg_givens_gv (w, k - 1, k, c, s);
apply_givens_qr (M, N, Q, R, k - 1, k, c, s);
}
w0 = gsl_vector_get (w, 0);
/* Add in w v^T (Equation 12.5.3) */
for (j = 0; j < N; j++)
{
double r0j = gsl_matrix_get (R, 0, j);
size_t p_j = gsl_permutation_get (p, j);
double vj = gsl_vector_get (v, p_j);
gsl_matrix_set (R, 0, j, r0j + w0 * vj);
}
/* Apply Givens transformations R' = G_(n-1)^T ... G_1^T H
Equation 12.5.4 */
for (k = 1; k < GSL_MIN(M,N+1); k++)
{
double c, s;
double diag = gsl_matrix_get (R, k - 1, k - 1);
double offdiag = gsl_matrix_get (R, k, k - 1);
gsl_linalg_givens (diag, offdiag, &c, &s);
apply_givens_qr (M, N, Q, R, k - 1, k, c, s);
gsl_matrix_set (R, k, k - 1, 0.0); /* exact zero of G^T */
}
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() */
int
gsl_linalg_PTLQ_update (gsl_matrix * Q, gsl_matrix * L,
const gsl_permutation * p,
const gsl_vector * v, gsl_vector * w)
{
if (Q->size1 != Q->size2 || L->size1 != L->size2)
{
return GSL_ENOTSQR;
}
else if (L->size1 != Q->size2 || v->size != Q->size2 || w->size != Q->size2)
{
return GSL_EBADLEN;
}
else
{
size_t j, k;
const size_t N = Q->size1;
const size_t M = Q->size2;
double w0;
/* Apply Given's rotations to reduce w to (|w|, 0, 0, ... , 0)
J_1^T .... J_(n-1)^T w = +/- |w| e_1
simultaneously applied to L, H = J_1^T ... J^T_(n-1) L
so that H is upper Hessenberg. (12.5.2) */
for (k = M - 1; k > 0; k--)
{
double c, s;
double wk = gsl_vector_get (w, k);
double wkm1 = gsl_vector_get (w, k - 1);
gsl_linalg_givens (wkm1, wk, &c, &s);
gsl_linalg_givens_gv (w, k - 1, k, c, s);
apply_givens_lq (M, N, Q, L, k - 1, k, c, s);
}
w0 = gsl_vector_get (w, 0);
/* Add in v w^T (Equation 12.5.3) */
for (j = 0; j < N; j++)
{
double lj0 = gsl_matrix_get (L, j, 0);
size_t p_j = gsl_permutation_get (p, j);
double vj = gsl_vector_get (v, p_j);
gsl_matrix_set (L, j, 0, lj0 + w0 * vj);
}
/* Apply Givens transformations L' = G_(n-1)^T ... G_1^T H
Equation 12.5.4 */
for (k = 1; k < N; k++)
{
double c, s;
double diag = gsl_matrix_get (L, k - 1, k - 1);
double offdiag = gsl_matrix_get (L, k - 1, k );
gsl_linalg_givens (diag, offdiag, &c, &s);
apply_givens_lq (M, N, Q, L, k - 1, k, c, s);
}
return GSL_SUCCESS;
}
}
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() */
