3 * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2007 Gerard Jungman, Brian Gough
5 * This program is free software; you can redistribute it and/or modify
6 * it under the terms of the GNU General Public License as published by
7 * the Free Software Foundation; either version 3 of the License, or (at
8 * your option) any later version.
10 * This program is distributed in the hope that it will be useful, but
11 * WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 * General Public License for more details.
15 * You should have received a copy of the GNU General Public License
16 * along with this program; if not, write to the Free Software
17 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
23 #include <gsl/gsl_math.h>
24 #include <gsl/gsl_vector.h>
25 #include <gsl/gsl_matrix.h>
26 #include <gsl/gsl_permute_vector.h>
27 #include <gsl/gsl_blas.h>
29 #include <gsl/gsl_linalg.h>
34 #include "apply_givens.c"
36 /* Factorise a general M x N matrix A into
40 * where Q is orthogonal (M x M) and R is upper triangular (M x N).
41 * When A is rank deficient, r = rank(A) < n, then the permutation is
42 * used to ensure that the lower n - r rows of R are zero and the first
43 * r columns of Q form an orthonormal basis for A.
45 * Q is stored as a packed set of Householder transformations in the
46 * strict lower triangular part of the input matrix.
48 * R is stored in the diagonal and upper triangle of the input matrix.
50 * P: column j of P is column k of the identity matrix, where k =
51 * permutation->data[j]
53 * The full matrix for Q can be obtained as the product
57 * where k = MIN(M,N) and
59 * Q_i = (I - tau_i * v_i * v_i')
61 * and where v_i is a Householder vector
63 * v_i = [1, m(i+1,i), m(i+2,i), ... , m(M,i)]
65 * This storage scheme is the same as in LAPACK. See LAPACK's
66 * dgeqpf.f for details.
71 gsl_linalg_QRPT_decomp (gsl_matrix * A, gsl_vector * tau, gsl_permutation * p, int *signum, gsl_vector * norm)
73 const size_t M = A->size1;
74 const size_t N = A->size2;
76 if (tau->size != GSL_MIN (M, N))
78 GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN);
80 else if (p->size != N)
82 GSL_ERROR ("permutation size must be N", GSL_EBADLEN);
84 else if (norm->size != N)
86 GSL_ERROR ("norm size must be N", GSL_EBADLEN);
94 gsl_permutation_init (p); /* set to identity */
96 /* Compute column norms and store in workspace */
98 for (i = 0; i < N; i++)
100 gsl_vector_view c = gsl_matrix_column (A, i);
101 double x = gsl_blas_dnrm2 (&c.vector);
102 gsl_vector_set (norm, i, x);
105 for (i = 0; i < GSL_MIN (M, N); i++)
107 /* Bring the column of largest norm into the pivot position */
109 double max_norm = gsl_vector_get(norm, i);
112 for (j = i + 1; j < N; j++)
114 double x = gsl_vector_get (norm, j);
125 gsl_matrix_swap_columns (A, i, kmax);
126 gsl_permutation_swap (p, i, kmax);
127 gsl_vector_swap_elements(norm,i,kmax);
129 (*signum) = -(*signum);
132 /* Compute the Householder transformation to reduce the j-th
133 column of the matrix to a multiple of the j-th unit vector */
136 gsl_vector_view c_full = gsl_matrix_column (A, i);
137 gsl_vector_view c = gsl_vector_subvector (&c_full.vector,
139 double tau_i = gsl_linalg_householder_transform (&c.vector);
141 gsl_vector_set (tau, i, tau_i);
143 /* Apply the transformation to the remaining columns */
147 gsl_matrix_view m = gsl_matrix_submatrix (A, i, i + 1, M - i, N - (i+1));
149 gsl_linalg_householder_hm (tau_i, &c.vector, &m.matrix);
153 /* Update the norms of the remaining columns too */
157 for (j = i + 1; j < N; j++)
159 double x = gsl_vector_get (norm, j);
164 double temp= gsl_matrix_get (A, i, j) / x;
166 if (fabs (temp) >= 1)
169 y = x * sqrt (1 - temp * temp);
171 /* recompute norm to prevent loss of accuracy */
173 if (fabs (y / x) < sqrt (20.0) * GSL_SQRT_DBL_EPSILON)
175 gsl_vector_view c_full = gsl_matrix_column (A, j);
177 gsl_vector_subvector(&c_full.vector,
179 y = gsl_blas_dnrm2 (&c.vector);
182 gsl_vector_set (norm, j, y);
193 gsl_linalg_QRPT_decomp2 (const gsl_matrix * A, gsl_matrix * q, gsl_matrix * r, gsl_vector * tau, gsl_permutation * p, int *signum, gsl_vector * norm)
195 const size_t M = A->size1;
196 const size_t N = A->size2;
198 if (q->size1 != M || q->size2 !=M)
200 GSL_ERROR ("q must be M x M", GSL_EBADLEN);
202 else if (r->size1 != M || r->size2 !=N)
204 GSL_ERROR ("r must be M x N", GSL_EBADLEN);
206 else if (tau->size != GSL_MIN (M, N))
208 GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN);
210 else if (p->size != N)
212 GSL_ERROR ("permutation size must be N", GSL_EBADLEN);
214 else if (norm->size != N)
216 GSL_ERROR ("norm size must be N", GSL_EBADLEN);
219 gsl_matrix_memcpy (r, A);
221 gsl_linalg_QRPT_decomp (r, tau, p, signum, norm);
223 /* FIXME: aliased arguments depends on behavior of unpack routine! */
225 gsl_linalg_QR_unpack (r, tau, q, r);
231 /* Solves the system A x = b using the Q R P^T factorisation,
237 to obtain x. Based on SLATEC code. */
240 gsl_linalg_QRPT_solve (const gsl_matrix * QR,
241 const gsl_vector * tau,
242 const gsl_permutation * p,
243 const gsl_vector * b,
246 if (QR->size1 != QR->size2)
248 GSL_ERROR ("QR matrix must be square", GSL_ENOTSQR);
250 else if (QR->size1 != p->size)
252 GSL_ERROR ("matrix size must match permutation size", GSL_EBADLEN);
254 else if (QR->size1 != b->size)
256 GSL_ERROR ("matrix size must match b size", GSL_EBADLEN);
258 else if (QR->size2 != x->size)
260 GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN);
264 gsl_vector_memcpy (x, b);
266 gsl_linalg_QRPT_svx (QR, tau, p, x);
273 gsl_linalg_QRPT_svx (const gsl_matrix * QR,
274 const gsl_vector * tau,
275 const gsl_permutation * p,
278 if (QR->size1 != QR->size2)
280 GSL_ERROR ("QR matrix must be square", GSL_ENOTSQR);
282 else if (QR->size1 != p->size)
284 GSL_ERROR ("matrix size must match permutation size", GSL_EBADLEN);
286 else if (QR->size2 != x->size)
288 GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN);
292 /* compute sol = Q^T b */
294 gsl_linalg_QR_QTvec (QR, tau, x);
296 /* Solve R x = sol, storing x inplace in sol */
298 gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, QR, x);
300 gsl_permute_vector_inverse (p, x);
308 gsl_linalg_QRPT_QRsolve (const gsl_matrix * Q, const gsl_matrix * R,
309 const gsl_permutation * p,
310 const gsl_vector * b,
313 if (Q->size1 != Q->size2 || R->size1 != R->size2)
317 else if (Q->size1 != p->size || Q->size1 != R->size1
318 || Q->size1 != b->size)
324 /* compute b' = Q^T b */
326 gsl_blas_dgemv (CblasTrans, 1.0, Q, b, 0.0, x);
328 /* Solve R x = b', storing x inplace */
330 gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, R, x);
332 /* Apply permutation to solution in place */
334 gsl_permute_vector_inverse (p, x);
341 gsl_linalg_QRPT_Rsolve (const gsl_matrix * QR,
342 const gsl_permutation * p,
343 const gsl_vector * b,
346 if (QR->size1 != QR->size2)
348 GSL_ERROR ("QR matrix must be square", GSL_ENOTSQR);
350 else if (QR->size1 != b->size)
352 GSL_ERROR ("matrix size must match b size", GSL_EBADLEN);
354 else if (QR->size2 != x->size)
356 GSL_ERROR ("matrix size must match x size", GSL_EBADLEN);
358 else if (p->size != x->size)
360 GSL_ERROR ("permutation size must match x size", GSL_EBADLEN);
366 gsl_vector_memcpy (x, b);
368 /* Solve R x = b, storing x inplace */
370 gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, QR, x);
372 gsl_permute_vector_inverse (p, x);
380 gsl_linalg_QRPT_Rsvx (const gsl_matrix * QR,
381 const gsl_permutation * p,
384 if (QR->size1 != QR->size2)
386 GSL_ERROR ("QR matrix must be square", GSL_ENOTSQR);
388 else if (QR->size2 != x->size)
390 GSL_ERROR ("matrix size must match x size", GSL_EBADLEN);
392 else if (p->size != x->size)
394 GSL_ERROR ("permutation size must match x size", GSL_EBADLEN);
398 /* Solve R x = b, storing x inplace */
400 gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, QR, x);
402 gsl_permute_vector_inverse (p, x);
410 /* Update a Q R P^T factorisation for A P= Q R , A' = A + u v^T,
412 Q' R' P^-1 = QR P^-1 + u v^T
413 = Q (R + Q^T u v^T P ) P^-1
414 = Q (R + w v^T P) P^-1
418 Algorithm from Golub and Van Loan, "Matrix Computations", Section
419 12.5 (Updating Matrix Factorizations, Rank-One Changes) */
422 gsl_linalg_QRPT_update (gsl_matrix * Q, gsl_matrix * R,
423 const gsl_permutation * p,
424 gsl_vector * w, const gsl_vector * v)
426 if (Q->size1 != Q->size2 || R->size1 != R->size2)
430 else if (R->size1 != Q->size2 || v->size != Q->size2 || w->size != Q->size2)
437 const size_t M = Q->size1;
438 const size_t N = Q->size2;
441 /* Apply Given's rotations to reduce w to (|w|, 0, 0, ... , 0)
443 J_1^T .... J_(n-1)^T w = +/- |w| e_1
445 simultaneously applied to R, H = J_1^T ... J^T_(n-1) R
446 so that H is upper Hessenberg. (12.5.2) */
448 for (k = N - 1; k > 0; k--)
451 double wk = gsl_vector_get (w, k);
452 double wkm1 = gsl_vector_get (w, k - 1);
454 create_givens (wkm1, wk, &c, &s);
455 apply_givens_vec (w, k - 1, k, c, s);
456 apply_givens_qr (M, N, Q, R, k - 1, k, c, s);
459 w0 = gsl_vector_get (w, 0);
461 /* Add in w v^T (Equation 12.5.3) */
463 for (j = 0; j < N; j++)
465 double r0j = gsl_matrix_get (R, 0, j);
466 size_t p_j = gsl_permutation_get (p, j);
467 double vj = gsl_vector_get (v, p_j);
468 gsl_matrix_set (R, 0, j, r0j + w0 * vj);
471 /* Apply Givens transformations R' = G_(n-1)^T ... G_1^T H
474 for (k = 1; k < N; k++)
477 double diag = gsl_matrix_get (R, k - 1, k - 1);
478 double offdiag = gsl_matrix_get (R, k, k - 1);
480 create_givens (diag, offdiag, &c, &s);
481 apply_givens_qr (M, N, Q, R, k - 1, k, c, s);