int
gsl_linalg_QR_QTmat (const gsl_matrix * QR, const gsl_vector * tau, gsl_matrix * A)
{
const size_t M = QR->size1;
const size_t N = QR->size2;
if (tau->size != GSL_MIN (M, N))
{
GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN);
}
else if (A->size1 != M)
{
GSL_ERROR ("matrix must have M rows", GSL_EBADLEN);
}
else
{
size_t i;
/* compute Q^T A */
for (i = 0; i < GSL_MIN (M, N); i++)
{
gsl_vector_const_view c = gsl_matrix_const_column (QR, i);
gsl_vector_const_view h = gsl_vector_const_subvector (&(c.vector), i, M - i);
gsl_matrix_view m = gsl_matrix_submatrix(A, i, 0, M - i, A->size2);
double ti = gsl_vector_get (tau, i);
gsl_linalg_householder_hm (ti, &(h.vector), &(m.matrix));
}
return GSL_SUCCESS;
}
}
int
gsl_linalg_QR_unpack (const gsl_matrix * QR, const gsl_vector * tau, gsl_matrix * Q, gsl_matrix * R)
{
const size_t M = QR->size1;
const size_t N = QR->size2;
if (Q->size1 != M || Q->size2 != M)
{
GSL_ERROR ("Q matrix must be M x M", GSL_ENOTSQR);
}
else if (R->size1 != M || R->size2 != N)
{
GSL_ERROR ("R matrix must be M x N", GSL_ENOTSQR);
}
else if (tau->size != GSL_MIN (M, N))
{
GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN);
}
else
{
size_t i, j;
/* Initialize Q to the identity */
gsl_matrix_set_identity (Q);
for (i = GSL_MIN (M, N); i-- > 0;)
{
gsl_vector_const_view c = gsl_matrix_const_column (QR, i);
gsl_vector_const_view h = gsl_vector_const_subvector (&c.vector,
i, M - i);
gsl_matrix_view m = gsl_matrix_submatrix (Q, i, i, M - i, M - i);
double ti = gsl_vector_get (tau, i);
gsl_linalg_householder_hm (ti, &h.vector, &m.matrix);
}
/* Form the right triangular matrix R from a packed QR matrix */
for (i = 0; i < M; i++)
{
for (j = 0; j < i && j < N; j++)
gsl_matrix_set (R, i, j, 0.0);
for (j = i; j < N; j++)
gsl_matrix_set (R, i, j, gsl_matrix_get (QR, i, j));
}
return GSL_SUCCESS;
}
}
int
gsl_linalg_QR_decomp (gsl_matrix * A, gsl_vector * tau)
{
const size_t M = A->size1;
const size_t N = A->size2;
if (tau->size != GSL_MIN (M, N))
{
GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN);
}
else
{
size_t i;
for (i = 0; i < GSL_MIN (M, N); i++)
{
/* 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_full = gsl_matrix_column (A, i);
gsl_vector_view c = gsl_vector_subvector (&(c_full.vector), 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 and
update the norms */
if (i + 1 < N)
{
gsl_matrix_view m = gsl_matrix_submatrix (A, i, i + 1, M - i, N - (i + 1));
gsl_linalg_householder_hm (tau_i, &(c.vector), &(m.matrix));
}
}
return GSL_SUCCESS;
}
}
/**
* C++ version of gsl_linalg_householder_hm().
* @param tau A scalar
* @param v A vector
* @param A A matrix
* @return Error code on failure
*/
inline int householder_hm( double tau, vector const& v, matrix& A ){
return gsl_linalg_householder_hm( tau, v.get(), A.get() ); }
int
gsl_linalg_symmtd_unpack (const gsl_matrix * A,
const gsl_vector * tau,
gsl_matrix * Q,
gsl_vector * diag,
gsl_vector * sdiag)
{
if (A->size1 != A->size2)
{
GSL_ERROR ("matrix A must be square", GSL_ENOTSQR);
}
else if (tau->size + 1 != A->size1)
{
GSL_ERROR ("size of tau must be (matrix size - 1)", GSL_EBADLEN);
}
else if (Q->size1 != A->size1 || Q->size2 != A->size1)
{
GSL_ERROR ("size of Q must match size of A", GSL_EBADLEN);
}
else if (diag->size != A->size1)
{
GSL_ERROR ("size of diagonal must match size of A", GSL_EBADLEN);
}
else if (sdiag->size + 1 != A->size1)
{
GSL_ERROR ("size of subdiagonal must be (matrix size - 1)", GSL_EBADLEN);
}
else
{
const size_t N = A->size1;
size_t i;
/* Initialize Q to the identity */
gsl_matrix_set_identity (Q);
for (i = N - 2; i-- > 0;)
{
gsl_vector_const_view c = gsl_matrix_const_column (A, i);
gsl_vector_const_view h = gsl_vector_const_subvector (&c.vector, i + 1, N - (i+1));
double ti = gsl_vector_get (tau, i);
gsl_matrix_view m = gsl_matrix_submatrix (Q, i + 1, i + 1, N-(i+1), N-(i+1));
gsl_linalg_householder_hm (ti, &h.vector, &m.matrix);
}
/* Copy diagonal into diag */
for (i = 0; i < N; i++)
{
double Aii = gsl_matrix_get (A, i, i);
gsl_vector_set (diag, i, Aii);
}
/* Copy subdiagonal into sd */
for (i = 0; i < N - 1; i++)
{
double Aji = gsl_matrix_get (A, i+1, i);
gsl_vector_set (sdiag, i, Aji);
}
return GSL_SUCCESS;
}
}
int
gsl_linalg_QRPT_decomp (gsl_matrix * A, gsl_vector * tau, gsl_permutation * p, int *signum, gsl_vector * norm)
{
const size_t M = A->size1;
const size_t N = 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_column (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_columns (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_full = gsl_matrix_column (A, i);
gsl_vector_view c = gsl_vector_subvector (&c_full.vector,
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, i + 1, M - i, N - (i+1));
gsl_linalg_householder_hm (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, i, j) / 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_full = gsl_matrix_column (A, j);
gsl_vector_view c =
gsl_vector_subvector(&c_full.vector,
i+1, M - (i+1));
y = gsl_blas_dnrm2 (&c.vector);
}
gsl_vector_set (norm, j, y);
}
}
}
}
return GSL_SUCCESS;
}
}
int
gsl_linalg_hessenberg_decomp(gsl_matrix *A, gsl_vector *tau)
{
const size_t N = A->size1;
if (N != A->size2)
{
GSL_ERROR ("Hessenberg reduction requires square matrix",
GSL_ENOTSQR);
}
else if (N != tau->size)
{
GSL_ERROR ("tau vector must match matrix size", GSL_EBADLEN);
}
else if (N < 3)
{
/* nothing to do */
return GSL_SUCCESS;
}
else
{
size_t i; /* looping */
gsl_vector_view c, /* matrix column */
hv; /* householder vector */
gsl_matrix_view m;
double tau_i; /* beta in algorithm 7.4.2 */
for (i = 0; i < N - 2; ++i)
{
/*
* make a copy of A(i + 1:n, i) and store it in the section
* of 'tau' that we haven't stored coefficients in yet
*/
c = gsl_matrix_subcolumn(A, i, i + 1, N - i - 1);
hv = gsl_vector_subvector(tau, i + 1, N - (i + 1));
gsl_vector_memcpy(&hv.vector, &c.vector);
/* compute householder transformation of A(i+1:n,i) */
tau_i = gsl_linalg_householder_transform(&hv.vector);
/* apply left householder matrix (I - tau_i v v') to A */
m = gsl_matrix_submatrix(A, i + 1, i, N - (i + 1), N - i);
gsl_linalg_householder_hm(tau_i, &hv.vector, &m.matrix);
/* apply right householder matrix (I - tau_i v v') to A */
m = gsl_matrix_submatrix(A, 0, i + 1, N, N - (i + 1));
gsl_linalg_householder_mh(tau_i, &hv.vector, &m.matrix);
/* save Householder coefficient */
gsl_vector_set(tau, i, tau_i);
/*
* store Householder vector below the subdiagonal in column
* i of the matrix. hv(1) does not need to be stored since
* it is always 1.
*/
c = gsl_vector_subvector(&c.vector, 1, c.vector.size - 1);
hv = gsl_vector_subvector(&hv.vector, 1, hv.vector.size - 1);
gsl_vector_memcpy(&c.vector, &hv.vector);
}
return GSL_SUCCESS;
}
} /* gsl_linalg_hessenberg_decomp() */
int
gsl_linalg_SV_decomp_mod (gsl_matrix * A,
gsl_matrix * X,
gsl_matrix * V, gsl_vector * S, gsl_vector * work)
{
size_t i, j;
const size_t M = A->size1;
const size_t N = A->size2;
if (M < N)
{
GSL_ERROR ("svd of MxN matrix, M<N, is not implemented", GSL_EUNIMPL);
}
else if (V->size1 != N)
{
GSL_ERROR ("square matrix V must match second dimension of matrix A",
GSL_EBADLEN);
}
else if (V->size1 != V->size2)
{
GSL_ERROR ("matrix V must be square", GSL_ENOTSQR);
}
else if (X->size1 != N)
{
GSL_ERROR ("square matrix X must match second dimension of matrix A",
GSL_EBADLEN);
}
else if (X->size1 != X->size2)
{
GSL_ERROR ("matrix X must be square", GSL_ENOTSQR);
}
else if (S->size != N)
{
GSL_ERROR ("length of vector S must match second dimension of matrix A",
GSL_EBADLEN);
}
else if (work->size != N)
{
GSL_ERROR ("length of workspace must match second dimension of matrix A",
GSL_EBADLEN);
}
if (N == 1)
{
gsl_vector_view column = gsl_matrix_column (A, 0);
double norm = gsl_blas_dnrm2 (&column.vector);
gsl_vector_set (S, 0, norm);
gsl_matrix_set (V, 0, 0, 1.0);
if (norm != 0.0)
{
gsl_blas_dscal (1.0/norm, &column.vector);
}
return GSL_SUCCESS;
}
/* Convert A into an upper triangular matrix R */
for (i = 0; i < N; i++)
{
gsl_vector_view c = gsl_matrix_column (A, i);
gsl_vector_view v = gsl_vector_subvector (&c.vector, i, M - i);
double tau_i = gsl_linalg_householder_transform (&v.vector);
/* Apply the transformation to the remaining columns */
if (i + 1 < N)
{
gsl_matrix_view m =
gsl_matrix_submatrix (A, i, i + 1, M - i, N - (i + 1));
gsl_linalg_householder_hm (tau_i, &v.vector, &m.matrix);
}
gsl_vector_set (S, i, tau_i);
}
/* Copy the upper triangular part of A into X */
for (i = 0; i < N; i++)
{
for (j = 0; j < i; j++)
{
gsl_matrix_set (X, i, j, 0.0);
}
{
double Aii = gsl_matrix_get (A, i, i);
gsl_matrix_set (X, i, i, Aii);
}
for (j = i + 1; j < N; j++)
{
double Aij = gsl_matrix_get (A, i, j);
gsl_matrix_set (X, i, j, Aij);
}
}
/* Convert A into an orthogonal matrix L */
for (j = N; j-- > 0;)
{
/* Householder column transformation to accumulate L */
double tj = gsl_vector_get (S, j);
gsl_matrix_view m = gsl_matrix_submatrix (A, j, j, M - j, N - j);
gsl_linalg_householder_hm1 (tj, &m.matrix);
}
/* unpack R into X V S */
gsl_linalg_SV_decomp (X, V, S, work);
/* Multiply L by X, to obtain U = L X, stored in U */
{
gsl_vector_view sum = gsl_vector_subvector (work, 0, N);
for (i = 0; i < M; i++)
{
gsl_vector_view L_i = gsl_matrix_row (A, i);
gsl_vector_set_zero (&sum.vector);
for (j = 0; j < N; j++)
{
double Lij = gsl_vector_get (&L_i.vector, j);
gsl_vector_view X_j = gsl_matrix_row (X, j);
gsl_blas_daxpy (Lij, &X_j.vector, &sum.vector);
}
gsl_vector_memcpy (&L_i.vector, &sum.vector);
}
}
return GSL_SUCCESS;
}
void Matrix::householderTransform ( const double tau, const Vector& householder ) {
gsl_linalg_householder_hm( tau, &householder.vector, &matrix );
}
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;
}
}
