int lsQRPT(gsl_matrix * A, gsl_vector * b, gsl_vector * x, double * sigma)
{
int i;
gsl_vector *tau, *res;
gsl_permutation *p;
gsl_vector_view norm;
if (A->size1 < A->size2) return -1;
if (A->size1 != b->size) return -1;
if (A->size2 != x->size) return -1;
tau = gsl_vector_alloc(x->size);
res = gsl_vector_alloc(b->size);
p = gsl_permutation_alloc(x->size);
norm = gsl_vector_subvector(res, 0, x->size);
gsl_linalg_QRPT_decomp(A, tau, p, &i, &norm.vector);
gsl_linalg_QR_lssolve(A, tau, b, x, res);
gsl_permute_vector_inverse(p, x);
*sigma = gsl_blas_dnrm2(res);
gsl_vector_free(tau);
gsl_vector_free(res);
gsl_permutation_free(p);
return 0;
}
int
gsl_linalg_COD_decomp_e(gsl_matrix * A, gsl_vector * tau_Q, gsl_vector * tau_Z,
gsl_permutation * p, double tol, size_t * rank, gsl_vector * work)
{
const size_t M = A->size1;
const size_t N = A->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 (p->size != N)
{
GSL_ERROR ("permutation size must be N", GSL_EBADLEN);
}
else if (work->size != N)
{
GSL_ERROR ("work size must be N", GSL_EBADLEN);
}
else
{
int status, signum;
size_t r;
/* decompose: A P = Q R */
status = gsl_linalg_QRPT_decomp(A, tau_Q, p, &signum, work);
if (status)
return status;
/* estimate rank of A */
r = gsl_linalg_QRPT_rank(A, tol);
if (r < N)
{
/*
* matrix is rank-deficient, so that the R factor is
*
* R = [ R11 R12 ] =~ [ R11 R12 ]
* [ 0 R22 ] [ 0 0 ]
*
* compute RZ decomposition of upper trapezoidal matrix
* [ R11 R12 ] = [ R11~ 0 ] Z
*/
gsl_matrix_view R_upper = gsl_matrix_submatrix(A, 0, 0, r, N);
gsl_vector_view t = gsl_vector_subvector(tau_Z, 0, r);
cod_RZ(&R_upper.matrix, &t.vector);
}
*rank = r;
return GSL_SUCCESS;
}
}
/* QR Decomposition with Column Pivoting */
CAMLprim value ml_gsl_linalg_QRPT_decomp(value A, value TAU, value P, value NORM)
{
int signum;
GSL_PERMUT_OF_BIGARRAY(P);
_DECLARE_MATRIX(A);
_DECLARE_VECTOR2(TAU, NORM);
_CONVERT_MATRIX(A);
_CONVERT_VECTOR2(TAU, NORM);
gsl_linalg_QRPT_decomp(&m_A, &v_TAU, &perm_P, &signum, &v_NORM);
return Val_int(signum);
}
int
gsl_multifit_nlinear_covar (const gsl_matrix * J, const double epsrel,
gsl_matrix * covar)
{
int status;
gsl_matrix * r;
gsl_vector * tau;
gsl_vector * norm;
gsl_permutation * perm;
const size_t m = J->size1;
const size_t n = J->size2;
if (m < n)
{
GSL_ERROR ("Jacobian be rectangular M x N with M >= N", GSL_EBADLEN);
}
if (covar->size1 != covar->size2 || covar->size1 != n)
{
GSL_ERROR ("covariance matrix must be square and match second dimension of jacobian", GSL_EBADLEN);
}
r = gsl_matrix_alloc (m, n);
tau = gsl_vector_alloc (n);
perm = gsl_permutation_alloc (n) ;
norm = gsl_vector_alloc (n) ;
{
int signum = 0;
gsl_matrix_memcpy (r, J);
gsl_linalg_QRPT_decomp (r, tau, perm, &signum, norm);
}
status = covar_QRPT(r, perm, epsrel, covar);
gsl_matrix_free (r);
gsl_permutation_free (perm);
gsl_vector_free (tau);
gsl_vector_free (norm);
return status;
}
int
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)
{
const size_t M = A->size1;
const size_t N = A->size2;
if (q->size1 != M || q->size2 !=M)
{
GSL_ERROR ("q must be M x M", GSL_EBADLEN);
}
else if (r->size1 != M || r->size2 !=N)
{
GSL_ERROR ("r must be M x N", GSL_EBADLEN);
}
else 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);
}
gsl_matrix_memcpy (r, A);
gsl_linalg_QRPT_decomp (r, tau, p, signum, norm);
/* FIXME: aliased arguments depends on behavior of unpack routine! */
gsl_linalg_QR_unpack (r, tau, q, r);
return GSL_SUCCESS;
}
static int
iterate (void *vstate, gsl_multifit_function_fdf * fdf, gsl_vector * x, gsl_vector * f, gsl_matrix * J, gsl_vector * dx, int scale)
{
lmder_state_t *state = (lmder_state_t *) vstate;
gsl_matrix *r = state->r;
gsl_vector *tau = state->tau;
gsl_vector *diag = state->diag;
gsl_vector *qtf = state->qtf;
gsl_vector *x_trial = state->x_trial;
gsl_vector *f_trial = state->f_trial;
gsl_vector *rptdx = state->rptdx;
gsl_vector *newton = state->newton;
gsl_vector *gradient = state->gradient;
gsl_vector *sdiag = state->sdiag;
gsl_vector *w = state->w;
gsl_vector *work1 = state->work1;
gsl_permutation *perm = state->perm;
double prered, actred;
double pnorm, fnorm1, fnorm1p, gnorm;
double ratio;
double dirder;
int iter = 0;
double p1 = 0.1, p25 = 0.25, p5 = 0.5, p75 = 0.75, p0001 = 0.0001;
if (state->fnorm == 0.0)
{
return GSL_SUCCESS;
}
/* Compute qtf = Q^T f */
gsl_vector_memcpy (qtf, f);
gsl_linalg_QR_QTvec (r, tau, qtf);
/* Compute norm of scaled gradient */
compute_gradient_direction (r, perm, qtf, diag, gradient);
{
size_t iamax = gsl_blas_idamax (gradient);
gnorm = fabs(gsl_vector_get (gradient, iamax) / state->fnorm);
}
/* Determine the Levenberg-Marquardt parameter */
lm_iteration:
iter++ ;
{
int status = lmpar (r, perm, qtf, diag, state->delta, &(state->par), newton, gradient, sdiag, dx, w);
if (status)
return status;
}
/* Take a trial step */
gsl_vector_scale (dx, -1.0); /* reverse the step to go downhill */
compute_trial_step (x, dx, state->x_trial);
pnorm = scaled_enorm (diag, dx);
if (state->iter == 1)
{
if (pnorm < state->delta)
{
#ifdef DEBUG
printf("set delta = pnorm = %g\n" , pnorm);
#endif
state->delta = pnorm;
}
}
/* Evaluate function at x + p */
/* return immediately if evaluation raised error */
{
int status = GSL_MULTIFIT_FN_EVAL_F (fdf, x_trial, f_trial);
if (status)
return status;
}
fnorm1 = enorm (f_trial);
/* Compute the scaled actual reduction */
actred = compute_actual_reduction (state->fnorm, fnorm1);
#ifdef DEBUG
printf("lmiterate: fnorm = %g fnorm1 = %g actred = %g\n", state->fnorm, fnorm1, actred);
printf("r = "); gsl_matrix_fprintf(stdout, r, "%g");
printf("perm = "); gsl_permutation_fprintf(stdout, perm, "%d");
printf("dx = "); gsl_vector_fprintf(stdout, dx, "%g");
#endif
/* Compute rptdx = R P^T dx, noting that |J dx| = |R P^T dx| */
compute_rptdx (r, perm, dx, rptdx);
#ifdef DEBUG
printf("rptdx = "); gsl_vector_fprintf(stdout, rptdx, "%g");
#endif
fnorm1p = enorm (rptdx);
/* Compute the scaled predicted reduction = |J dx|^2 + 2 par |D dx|^2 */
{
double t1 = fnorm1p / state->fnorm;
double t2 = (sqrt(state->par) * pnorm) / state->fnorm;
prered = t1 * t1 + t2 * t2 / p5;
dirder = -(t1 * t1 + t2 * t2);
}
/* compute the ratio of the actual to predicted reduction */
if (prered > 0)
{
ratio = actred / prered;
}
else
{
ratio = 0;
}
#ifdef DEBUG
printf("lmiterate: prered = %g dirder = %g ratio = %g\n", prered, dirder,ratio);
#endif
/* update the step bound */
if (ratio > p25)
{
#ifdef DEBUG
printf("ratio > p25\n");
#endif
if (state->par == 0 || ratio >= p75)
{
state->delta = pnorm / p5;
state->par *= p5;
#ifdef DEBUG
printf("updated step bounds: delta = %g, par = %g\n", state->delta, state->par);
#endif
}
}
else
{
double temp = (actred >= 0) ? p5 : p5*dirder / (dirder + p5 * actred);
#ifdef DEBUG
printf("ratio < p25\n");
#endif
if (p1 * fnorm1 >= state->fnorm || temp < p1 )
{
temp = p1;
}
state->delta = temp * GSL_MIN_DBL (state->delta, pnorm/p1);
state->par /= temp;
#ifdef DEBUG
printf("updated step bounds: delta = %g, par = %g\n", state->delta, state->par);
#endif
}
/* test for successful iteration, termination and stringent tolerances */
if (ratio >= p0001)
{
gsl_vector_memcpy (x, x_trial);
gsl_vector_memcpy (f, f_trial);
/* return immediately if evaluation raised error */
{
int status;
if (fdf->df)
status = GSL_MULTIFIT_FN_EVAL_DF (fdf, x_trial, J);
else
status = gsl_multifit_fdfsolver_dif_df(x_trial, fdf, f_trial, J);
if (status)
return status;
}
/* wa2_j = diag_j * x_j */
state->xnorm = scaled_enorm(diag, x);
state->fnorm = fnorm1;
state->iter++;
/* Rescale if necessary */
if (scale)
{
update_diag (J, diag);
}
{
int signum;
gsl_matrix_memcpy (r, J);
gsl_linalg_QRPT_decomp (r, tau, perm, &signum, work1);
}
return GSL_SUCCESS;
}
else if (fabs(actred) <= GSL_DBL_EPSILON && prered <= GSL_DBL_EPSILON
&& p5 * ratio <= 1.0)
{
return GSL_ETOLF ;
}
else if (state->delta <= GSL_DBL_EPSILON * state->xnorm)
{
return GSL_ETOLX;
}
else if (gnorm <= GSL_DBL_EPSILON)
{
return GSL_ETOLG;
}
else if (iter < 10)
{
/* Repeat inner loop if unsuccessful */
goto lm_iteration;
}
return GSL_ENOPROG;
}
/**
* C++ version of gsl_linalg_QRPT_decomp().
* @param A A matrix
* @param tau A vector
* @param p A permutation
* @param signum The sign of the permutation
* @param norm A vector used for column pivoting
* @return Error code on failure
*/
inline int QRPT_decomp( matrix& A, vector& tau, permutation& p, int* signum, vector& norm ){
return gsl_linalg_QRPT_decomp( A.get(), tau.get(), p.get(), signum, norm.get() ); }
int
gsl_multifit_covar (const gsl_matrix * J, double epsrel, gsl_matrix * covar)
{
double tolr;
size_t i, j, k;
size_t kmax = 0;
gsl_matrix * r;
gsl_vector * tau;
gsl_vector * norm;
gsl_permutation * perm;
size_t m = J->size1, n = J->size2 ;
if (m < n)
{
GSL_ERROR ("Jacobian be rectangular M x N with M >= N", GSL_EBADLEN);
}
if (covar->size1 != covar->size2 || covar->size1 != n)
{
GSL_ERROR ("covariance matrix must be square and match second dimension of jacobian", GSL_EBADLEN);
}
r = gsl_matrix_alloc (m, n);
tau = gsl_vector_alloc (n);
perm = gsl_permutation_alloc (n) ;
norm = gsl_vector_alloc (n) ;
{
int signum = 0;
gsl_matrix_memcpy (r, J);
gsl_linalg_QRPT_decomp (r, tau, perm, &signum, norm);
}
/* Form the inverse of R in the full upper triangle of R */
tolr = epsrel * fabs(gsl_matrix_get(r, 0, 0));
for (k = 0 ; k < n ; k++)
{
double rkk = gsl_matrix_get(r, k, k);
if (fabs(rkk) <= tolr)
{
break;
}
gsl_matrix_set(r, k, k, 1.0/rkk);
for (j = 0; j < k ; j++)
{
double t = gsl_matrix_get(r, j, k) / rkk;
gsl_matrix_set (r, j, k, 0.0);
for (i = 0; i <= j; i++)
{
double rik = gsl_matrix_get (r, i, k);
double rij = gsl_matrix_get (r, i, j);
gsl_matrix_set (r, i, k, rik - t * rij);
}
}
kmax = k;
}
/* Form the full upper triangle of the inverse of R^T R in the full
upper triangle of R */
for (k = 0; k <= kmax ; k++)
{
for (j = 0; j < k; j++)
{
double rjk = gsl_matrix_get (r, j, k);
for (i = 0; i <= j ; i++)
{
double rij = gsl_matrix_get (r, i, j);
double rik = gsl_matrix_get (r, i, k);
gsl_matrix_set (r, i, j, rij + rjk * rik);
}
}
{
double t = gsl_matrix_get (r, k, k);
for (i = 0; i <= k; i++)
{
double rik = gsl_matrix_get (r, i, k);
gsl_matrix_set (r, i, k, t * rik);
};
}
}
/* Form the full lower triangle of the covariance matrix in the
strict lower triangle of R and in w */
for (j = 0 ; j < n ; j++)
{
size_t pj = gsl_permutation_get (perm, j);
for (i = 0; i <= j; i++)
{
size_t pi = gsl_permutation_get (perm, i);
double rij;
if (j > kmax)
{
gsl_matrix_set (r, i, j, 0.0);
rij = 0.0 ;
}
else
{
rij = gsl_matrix_get (r, i, j);
}
if (pi > pj)
{
gsl_matrix_set (r, pi, pj, rij);
}
else if (pi < pj)
{
gsl_matrix_set (r, pj, pi, rij);
}
}
{
double rjj = gsl_matrix_get (r, j, j);
gsl_matrix_set (covar, pj, pj, rjj);
}
}
/* symmetrize the covariance matrix */
for (j = 0 ; j < n ; j++)
{
for (i = 0; i < j ; i++)
{
double rji = gsl_matrix_get (r, j, i);
gsl_matrix_set (covar, j, i, rji);
gsl_matrix_set (covar, i, j, rji);
}
}
gsl_matrix_free (r);
gsl_permutation_free (perm);
gsl_vector_free (tau);
gsl_vector_free (norm);
return GSL_SUCCESS;
}
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;
}
void Matrix::factorizeQRP ( Vector& tau, Permutation& permutation ) {
int sign;
AutoVector workspace( countColumns() );
gsl_linalg_QRPT_decomp( &matrix, &tau.vector, &permutation, &sign, &workspace.vector );
}
static int
set (void *vstate, gsl_multifit_function_fdf * fdf, gsl_vector * x, gsl_vector * f, gsl_matrix * J, gsl_vector * dx, int scale)
{
lmder_state_t *state = (lmder_state_t *) vstate;
gsl_matrix *r = state->r;
gsl_vector *tau = state->tau;
gsl_vector *diag = state->diag;
gsl_vector *work1 = state->work1;
gsl_permutation *perm = state->perm;
int signum;
/* Evaluate function at x */
/* return immediately if evaluation raised error */
{
int status = GSL_MULTIFIT_FN_EVAL_F_DF (fdf, x, f, J);
if (status)
return status;
}
state->par = 0;
state->iter = 1;
state->fnorm = enorm (f);
gsl_vector_set_all (dx, 0.0);
/* store column norms in diag */
if (scale)
{
compute_diag (J, diag);
}
else
{
gsl_vector_set_all (diag, 1.0);
}
/* set delta to 100 |D x| or to 100 if |D x| is zero */
state->xnorm = scaled_enorm (diag, x);
state->delta = compute_delta (diag, x);
/* Factorize J into QR decomposition */
gsl_matrix_memcpy (r, J);
gsl_linalg_QRPT_decomp (r, tau, perm, &signum, work1);
gsl_vector_set_zero (state->rptdx);
gsl_vector_set_zero (state->w);
/* Zero the trial vector, as in the alloc function */
gsl_vector_set_zero (state->f_trial);
#ifdef DEBUG
printf("r = "); gsl_matrix_fprintf(stdout, r, "%g");
printf("perm = "); gsl_permutation_fprintf(stdout, perm, "%d");
printf("tau = "); gsl_vector_fprintf(stdout, tau, "%g");
#endif
return GSL_SUCCESS;
}
/* solve: min ||b - A x||^2 + lambda^2 ||x||^2 */
static int
test_COD_lssolve2_eps(const double lambda, const gsl_matrix * A, const gsl_vector * b, const double eps, const char *desc)
{
int s = 0;
size_t i, M = A->size1, N = A->size2;
gsl_vector * lhs = gsl_vector_alloc(M);
gsl_matrix * QRZT = gsl_matrix_alloc(M, N);
gsl_vector * tau_Q = gsl_vector_alloc(GSL_MIN(M, N));
gsl_vector * tau_Z = gsl_vector_alloc(GSL_MIN(M, N));
gsl_vector * work = gsl_vector_alloc(N);
gsl_vector * x = gsl_vector_alloc(N);
gsl_vector * x_aug = gsl_vector_alloc(N);
gsl_vector * r = gsl_vector_alloc(M);
gsl_vector * res = gsl_vector_alloc(M);
gsl_permutation * perm = gsl_permutation_alloc(N);
size_t rank;
/* form full rank augmented system B = [ A ; lambda*I_N ], f = [ rhs ; 0 ] and solve with QRPT */
{
gsl_vector_view v;
gsl_matrix_view m;
gsl_permutation *p = gsl_permutation_alloc(N);
gsl_matrix * B = gsl_matrix_calloc(M + N, N);
gsl_vector * f = gsl_vector_calloc(M + N);
gsl_vector * tau = gsl_vector_alloc(N);
gsl_vector * residual = gsl_vector_alloc(M + N);
int signum;
m = gsl_matrix_submatrix(B, 0, 0, M, N);
gsl_matrix_memcpy(&m.matrix, A);
m = gsl_matrix_submatrix(B, M, 0, N, N);
v = gsl_matrix_diagonal(&m.matrix);
gsl_vector_set_all(&v.vector, lambda);
v = gsl_vector_subvector(f, 0, M);
gsl_vector_memcpy(&v.vector, b);
/* solve: [ A ; lambda*I ] x_aug = [ b ; 0 ] */
gsl_linalg_QRPT_decomp(B, tau, p, &signum, work);
gsl_linalg_QRPT_lssolve(B, tau, p, f, x_aug, residual);
gsl_permutation_free(p);
gsl_matrix_free(B);
gsl_vector_free(f);
gsl_vector_free(tau);
gsl_vector_free(residual);
}
gsl_matrix_memcpy(QRZT, A);
s += gsl_linalg_COD_decomp(QRZT, tau_Q, tau_Z, perm, &rank, work);
{
gsl_matrix *S = gsl_matrix_alloc(rank, rank);
gsl_vector *workr = gsl_vector_alloc(rank);
s += gsl_linalg_COD_lssolve2(lambda, QRZT, tau_Q, tau_Z, perm, rank, b, x, res, S, workr);
gsl_matrix_free(S);
gsl_vector_free(workr);
}
for (i = 0; i < N; i++)
{
double xi = gsl_vector_get(x, i);
double yi = gsl_vector_get(x_aug, i);
gsl_test_rel(xi, yi, eps,
"%s (%3lu,%3lu)[%lu]: %22.18g %22.18g\n",
desc, M, N, i, xi, yi);
}
/* compute residual r = b - A x */
if (M == N)
{
gsl_vector_set_zero(r);
}
else
{
gsl_vector_memcpy(r, b);
gsl_blas_dgemv(CblasNoTrans, -1.0, A, x, 1.0, r);
}
for (i = 0; i < N; i++)
{
double xi = gsl_vector_get(res, i);
double yi = gsl_vector_get(r, i);
gsl_test_rel(xi, yi, sqrt(eps),
"%s res (%3lu,%3lu)[%lu]: %22.18g %22.18g\n",
desc, M, N, i, xi, yi);
}
gsl_vector_free(r);
gsl_vector_free(res);
gsl_vector_free(x);
gsl_vector_free(x_aug);
gsl_vector_free(tau_Q);
gsl_vector_free(tau_Z);
gsl_matrix_free(QRZT);
gsl_vector_free(lhs);
gsl_vector_free(work);
gsl_permutation_free(perm);
return s;
}
