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; }
CAMLprim value ml_gsl_linalg_QR_lssolve(value QR, value TAU, value B, value X, value RES) { _DECLARE_MATRIX(QR); _DECLARE_VECTOR4(TAU, RES, B, X); _CONVERT_MATRIX(QR); _CONVERT_VECTOR4(TAU, RES, B, X); gsl_linalg_QR_lssolve(&m_QR, &v_TAU, &v_B, &v_X, &v_RES); return Val_unit; }
int gslutils_solve_leastsquares(gsl_matrix* A, gsl_vector** B, gsl_vector** X, gsl_vector** resids, int NB) { int i; gsl_vector *tau, *resid = NULL; Unused int ret; int M, N; M = A->size1; N = A->size2; for (i=0; i<NB; i++) { assert(B[i]); assert(B[i]->size == M); } tau = gsl_vector_alloc(MIN(M, N)); assert(tau); ret = gsl_linalg_QR_decomp(A, tau); assert(ret == 0); // A,tau now contains a packed version of Q,R. for (i=0; i<NB; i++) { if (!resid) { resid = gsl_vector_alloc(M); assert(resid); } X[i] = gsl_vector_alloc(N); assert(X[i]); ret = gsl_linalg_QR_lssolve(A, tau, B[i], X[i], resid); assert(ret == 0); if (resids) { resids[i] = resid; resid = NULL; } } gsl_vector_free(tau); if (resid) gsl_vector_free(resid); return 0; }
/** * C++ version of gsl_linalg_QR_lssolve(). * @param QR A QR decomposition * @param tau A vector * @param b A vector * @param x A vector * @param residual A residual vector * @return Error code on failure */ inline int QR_lssolve( matrix const& QR, vector const& tau, vector const& b, vector& x, vector& residual ){ return gsl_linalg_QR_lssolve( QR.get(), tau.get(), b.get(), x.get(), residual.get() ); }
/** * \brief A variant of the Savitzky-Golay algorithm able to handle non-uniformly distributed data. * * In comparison to smoothSavGol(), this method trades proper handling of the X coordinates for * runtime efficiency by abandoning a central idea of Savitzky-Golay algorithm, namely that * polynomial smoothing can be expressed as a convolution. * * TODO: integrate this option into the GUI. */ void SmoothFilter::smoothModifiedSavGol(double *x_in, double *y_inout) { // total number of points in smoothing window int points = d_left_points + d_right_points + 1; if (points < d_polynom_order+1) { QMessageBox::critical((ApplicationWindow *)parent(), tr("SciDAVis") + " - " + tr("Error"), tr("The polynomial order must be lower than the number of left points plus the number of right points!")); return; } // allocate memory for the result QVector<double> result(d_n); // allocate memory for the linear algegra computations // Vandermonde matrix for x values of points in the current smoothing window gsl_matrix *vandermonde = gsl_matrix_alloc(points, d_polynom_order+1); // stores part of the QR decomposition of vandermonde gsl_vector *tau = gsl_vector_alloc(qMin(points, d_polynom_order+1)); // coefficients of polynomial approximation computed for each smoothing window gsl_vector *poly = gsl_vector_alloc(d_polynom_order+1); // residual of the (least-squares) approximation (by-product of GSL's algorithm) gsl_vector *residual = gsl_vector_alloc(points); for (int target_index = 0; target_index < d_n; target_index++) { int offset = target_index - d_left_points; // use a fixed number of points; near left/right borders, use offset to change // effective number of left/right points considered if (target_index < d_left_points) offset += d_left_points - target_index; else if (target_index + d_right_points >= d_n) offset += d_n - 1 - (target_index + d_right_points); // fill Vandermonde matrix for (int i = 0; i < points; ++i) { gsl_matrix_set(vandermonde, i, 0, 1.0); for (int j = 1; j <= d_polynom_order; ++j) gsl_matrix_set(vandermonde, i, j, gsl_matrix_get(vandermonde,i,j-1) * x_in[offset + i]); } // Y values within current smoothing window gsl_vector_view y_slice = gsl_vector_view_array(y_inout+offset, points); // compute QR decomposition of Vandermonde matrix if (int error=gsl_linalg_QR_decomp(vandermonde, tau)) QMessageBox::critical((ApplicationWindow *)parent(), tr("SciDAVis") + " - " + tr("Error"), tr("Internal error in Savitzky-Golay algorithm: QR decomposition failed.\n") + gsl_strerror(error)); // least-squares-solve vandermonde*poly=y_slice using the QR decomposition now stored in // vandermonde and tau else if (int error=gsl_linalg_QR_lssolve(vandermonde, tau, &y_slice.vector, poly, residual)) QMessageBox::critical((ApplicationWindow *)parent(), tr("SciDAVis") + " - " + tr("Error"), tr("Internal error in Savitzky-Golay algorithm: least-squares solution failed.\n") + gsl_strerror(error)); else result[target_index] = gsl_poly_eval(poly->data, d_polynom_order+1, x_in[target_index]); } // deallocate memory gsl_vector_free(residual); gsl_vector_free(poly); gsl_vector_free(tau); gsl_matrix_free(vandermonde); // write result into *y_inout qCopy(result.begin(), result.end(), y_inout); }
int gsl_bspline_knots_greville (const gsl_vector *abscissae, gsl_bspline_workspace *w, double *abserr) { int s; /* Check incoming arguments satisfy mandatory algorithmic assumptions */ if (w->k < 2) GSL_ERROR ("w->k must be at least 2", GSL_EINVAL); else if (abscissae->size < 2) GSL_ERROR ("abscissae->size must be at least 2", GSL_EINVAL); else if (w->nbreak != abscissae->size - w->k + 2) GSL_ERROR ("w->nbreak must equal abscissae->size - w->k + 2", GSL_EINVAL); if (w->nbreak == 2) { /* No flexibility in abscissae values possible in this degenerate case */ s = gsl_bspline_knots_uniform ( gsl_vector_get (abscissae, 0), gsl_vector_get (abscissae, abscissae->size - 1), w); } else { double * storage; gsl_matrix_view A; gsl_vector_view tau, b, x, r; size_t i, j; /* Constants derived from the B-spline workspace and abscissae details */ const size_t km2 = w->k - 2; const size_t M = abscissae->size - 2; const size_t N = w->nbreak - 2; const double invkm1 = 1.0 / w->km1; /* Allocate working storage and prepare multiple, zero-filled views */ storage = (double *) calloc (M*N + 2*N + 2*M, sizeof (double)); if (storage == 0) GSL_ERROR ("failed to allocate working storage", GSL_ENOMEM); A = gsl_matrix_view_array (storage, M, N); tau = gsl_vector_view_array (storage + M*N, N); b = gsl_vector_view_array (storage + M*N + N, M); x = gsl_vector_view_array (storage + M*N + N + M, N); r = gsl_vector_view_array (storage + M*N + N + M + N, M); /* Build matrix from interior breakpoints to interior Greville abscissae. * For example, when w->k = 4 and w->nbreak = 7 the matrix is * [ 1, 0, 0, 0, 0; * 2/3, 1/3, 0, 0, 0; * 1/3, 1/3, 1/3, 0, 0; * 0, 1/3, 1/3, 1/3, 0; * 0, 0, 1/3, 1/3, 1/3; * 0, 0, 0, 1/3, 2/3; * 0, 0, 0, 0, 1 ] * but only center formed as first/last breakpoint is known. */ for (j = 0; j < N; ++j) for (i = 0; i <= km2; ++i) gsl_matrix_set (&A.matrix, i+j, j, invkm1); /* Copy interior collocation points from abscissae into b */ for (i = 0; i < M; ++i) gsl_vector_set (&b.vector, i, gsl_vector_get (abscissae, i+1)); /* Adjust b to account for constraint columns not stored in A */ for (i = 0; i < km2; ++i) { double * const v = gsl_vector_ptr (&b.vector, i); *v -= (1 - (i+1)*invkm1) * gsl_vector_get (abscissae, 0); } for (i = 0; i < km2; ++i) { double * const v = gsl_vector_ptr (&b.vector, M - km2 + i); *v -= (i+1)*invkm1 * gsl_vector_get (abscissae, abscissae->size - 1); } /* Perform linear least squares to determine interior breakpoints */ s = gsl_linalg_QR_decomp (&A.matrix, &tau.vector) || gsl_linalg_QR_lssolve (&A.matrix, &tau.vector, &b.vector, &x.vector, &r.vector); if (s) { free (storage); return s; } /* "Expand" solution x by adding known first and last breakpoints. */ x = gsl_vector_view_array_with_stride ( gsl_vector_ptr (&x.vector, 0) - x.vector.stride, x.vector.stride, x.vector.size + 2); gsl_vector_set (&x.vector, 0, gsl_vector_get (abscissae, 0)); gsl_vector_set (&x.vector, x.vector.size - 1, gsl_vector_get (abscissae, abscissae->size - 1)); /* Finally, initialize workspace knots using the now-known breakpoints */ s = gsl_bspline_knots (&x.vector, w); free (storage); } /* Sum absolute errors in the resulting vs requested interior abscissae */ /* Provided as a fit quality metric which may be monitored by callers */ if (!s && abserr) { size_t i; *abserr = 0; for (i = 1; i < abscissae->size - 1; ++i) *abserr += fabs ( gsl_bspline_greville_abscissa (i, w) - gsl_vector_get (abscissae, i) ); } return s; }
double integral_generalized_sing(gsl_function f, double a, double b, double y, int n, int m, double *x_gauss, double *w_gauss, double*x, double *w) { gsl_vector *rhs,*soln,*tau,*res; gsl_matrix *A; double *w1,*w2,*w3,*x1,*x2,*x3,*x_t; gsl_function f_temp; pl_params p; double y_scaled,x_mid,x_halflength,integral; int i,j; x_mid = (b+a)/2.0; x_halflength = (b-a)/2.0; /*scale y to -1 to 1*/ y_scaled = (1/x_halflength)*y - (x_mid/x_halflength); /*allocate memory for aux. quadrature weight calculations*/ w1 = (double *)malloc((n+1)*sizeof(double)); w2 = (double *)malloc((n+1)*sizeof(double)); w3 = (double *)malloc((n+1)*sizeof(double)); x1 = (double *)malloc((n+1)*sizeof(double)); x2 = (double *)malloc((n+1)*sizeof(double)); x3 = (double *)malloc((n+1)*sizeof(double)); x_t = (double *)malloc((n+1)*sizeof(double)); /*allocate memory for system matrix rhs vector and solution vector along with vector of householder coeffs*/ rhs = gsl_vector_calloc(4*m); res = gsl_vector_calloc(4*m); soln = gsl_vector_calloc(n); /*Note that here we assume that 4*m > n*/ tau = gsl_vector_calloc(n); A = gsl_matrix_calloc(4*m,n); /*fill in the entries of the matrix*/ for(i=0;i<n;i++) { for(j=0;j<m;j++) { gsl_matrix_set(A,j,i,legendre_poly(j,x_gauss[i+1])); gsl_matrix_set(A,j+m,i,legendre_poly(j,x_gauss[i+1])*log(fabs(y_scaled - x_gauss[i+1]))); gsl_matrix_set(A,j+(2*m),i,legendre_poly(j,x_gauss[i+1])*(1/(y_scaled - x_gauss[i+1]))); gsl_matrix_set(A,j+(3*m),i,legendre_poly(j,x_gauss[i+1])*(1/((y_scaled - x_gauss[i+1])*(y_scaled - x_gauss[i+1])))); } } /*calculate quadrature points for the exact evaluation of the integrals of the various phi functions */ quad_log_singularity_half(y_scaled, n, x_gauss, w_gauss, x1, w1); quad_x_singularity(y_scaled, n, x_gauss, w_gauss, x2, w2); quad_x2_singularity(y_scaled, n, x_gauss, w_gauss, x3, w3); /*fill in the rhs vector*/ for(i=0;i<m;i++) { p.deg = i; f_temp.function = &func_legendre_pl; f_temp.params = &p; gsl_vector_set(rhs,i,integral_gaussleg(f_temp,-1.0,1.0,n,x_gauss,w_gauss)); gsl_vector_set(rhs,i+m,integral_gauss_log_sing(f_temp,-1.0,1.0,y_scaled,n,x_gauss,w_gauss,x1,w1)); gsl_vector_set(rhs,i+(2*m),integral_gauss_x_sing(f_temp,-1.0,1.0,y_scaled,n,x_gauss,w_gauss,x2,w2)); gsl_vector_set(rhs,i+(3*m),integral_gauss_x2_sing(f_temp,-1.0,1.0,y_scaled,n,x_gauss,w_gauss,x3,w3)); } /*solve the linear system in the least squares sense*/ gsl_linalg_QR_decomp(A,tau); gsl_linalg_QR_lssolve(A,tau,rhs,soln,res); for(i=0;i<n;i++) { w[i+1] = gsl_vector_get(soln,i); x[i+1] = x_gauss[i+1]; } /*integrate*/ for(i=1;i<=n;i++) { x_t[i] = x_halflength*x[i] + x_mid; } integral = 0; for(i=1;i<=n;i++) { integral = integral + (w[i]*(*(f.function))(x_t[i],f.params)); } integral = x_halflength*integral; /*free allocated memory*/ free(x1); free(x2); free(x3); free(w1); free(w2); free(w3); free(x_t); gsl_vector_free(rhs); gsl_vector_free(soln); gsl_vector_free(tau); gsl_vector_free(res); gsl_matrix_free(A); return integral; }