static double cod_householder_transform(double *alpha, gsl_vector * v) { double beta, tau; double xnorm = gsl_blas_dnrm2(v); if (xnorm == 0) { return 0.0; /* tau = 0 */ } beta = - (*alpha >= 0.0 ? +1.0 : -1.0) * gsl_hypot(*alpha, xnorm); tau = (beta - *alpha) / beta; { double s = (*alpha - beta); if (fabs(s) > GSL_DBL_MIN) { gsl_blas_dscal (1.0 / s, v); } else { gsl_blas_dscal (GSL_DBL_EPSILON / s, v); gsl_blas_dscal (1.0 / GSL_DBL_EPSILON, v); } *alpha = beta; } return tau; }
static VALUE rb_gsl_blas_dscal(int argc, VALUE *argv, VALUE obj) { double a; gsl_vector *x = NULL; switch (TYPE(obj)) { case T_MODULE: case T_CLASS: case T_OBJECT: if (argc != 2) rb_raise(rb_eArgError, "wrong number of arguments (%d for 2)", argc); Need_Float(argv[0]); CHECK_VECTOR(argv[1]); // a = RFLOAT(argv[0])->value; a = NUM2DBL(argv[0]); Data_Get_Struct(argv[1], gsl_vector, x); gsl_blas_dscal(a, x); return argv[1]; break; default: if (argc != 1) rb_raise(rb_eArgError, "wrong number of arguments (%d for 1)", argc); Need_Float(argv[0]); // a = RFLOAT(argv[0])->value; a = NUM2DBL(argv[0]); Data_Get_Struct(obj, gsl_vector, x); gsl_blas_dscal(a, x); return obj; break; } return Qnil; /* never reach here */ }
void pca_whiten( gsl_matrix *input,// NOBS x NVOX size_t const NCOMP, // gsl_matrix *x_white, // NCOMP x NVOX gsl_matrix *white, // NCOMP x NSUB gsl_matrix *dewhite, //NSUB x NCOMP int demean){ // get input reference size_t NSUB = input->size1; // demean input matrix if (demean){ matrix_demean(input); } // Convariance Matrix gsl_matrix *cov = gsl_matrix_alloc(NSUB, NSUB); matrix_cov(input, cov); // Set up eigen decomposition gsl_vector *eval = gsl_vector_alloc(NCOMP); //eigen values gsl_matrix *evec = gsl_matrix_alloc(NSUB, NCOMP); rr_eig(cov, eval, evec, NCOMP ); //Computing whitening matrix gsl_matrix_transpose_memcpy(white, evec); gsl_vector_view v; double e; size_t i; // white = eval^{-1/2} evec^T #pragma omp parallel for private(i,e,v) for (i = 0; i < NCOMP; i++) { e = gsl_vector_get(eval,i); v = gsl_matrix_row(white,i); gsl_blas_dscal(1/sqrt(e), &v.vector); } // Computing dewhitening matrix gsl_matrix_memcpy(dewhite, evec); // dewhite = evec eval^{1/2} #pragma omp parallel for private(i,e,v) for (i = 0; i < NCOMP; i++) { e = gsl_vector_get(eval,i); v = gsl_matrix_column(dewhite,i); gsl_blas_dscal(sqrt(e), &v.vector); } // whitening data (white x Input) gsl_blas_dgemm(CblasNoTrans,CblasNoTrans,1.0, white, input, 0.0, x_white); gsl_matrix_free(cov); gsl_matrix_free(evec); gsl_vector_free(eval); }
double gsl_linalg_householder_transform (gsl_vector * v) { /* replace v[0:n-1] with a householder vector (v[0:n-1]) and coefficient tau that annihilate v[1:n-1] */ const size_t n = v->size ; if (n == 1) { return 0.0; /* tau = 0 */ } else { double alpha, beta, tau ; gsl_vector_view x = gsl_vector_subvector (v, 1, n - 1) ; double xnorm = gsl_blas_dnrm2 (&x.vector); if (xnorm == 0) { return 0.0; /* tau = 0 */ } alpha = gsl_vector_get (v, 0) ; beta = - (alpha >= 0.0 ? +1.0 : -1.0) * hypot(alpha, xnorm) ; tau = (beta - alpha) / beta ; { double s = (alpha - beta); if (fabs(s) > GSL_DBL_MIN) { gsl_blas_dscal (1.0 / s, &x.vector); gsl_vector_set (v, 0, beta) ; } else { gsl_blas_dscal (GSL_DBL_EPSILON / s, &x.vector); gsl_blas_dscal (1.0 / GSL_DBL_EPSILON, &x.vector); gsl_vector_set (v, 0, beta) ; } } return tau; } }
int gsl_linalg_balance_accum(gsl_matrix *A, gsl_vector *D) { const size_t N = A->size1; if (N != D->size) { GSL_ERROR ("vector must match matrix size", GSL_EBADLEN); } else { size_t i; double s; gsl_vector_view r; for (i = 0; i < N; ++i) { s = gsl_vector_get(D, i); r = gsl_matrix_row(A, i); gsl_blas_dscal(s, &r.vector); } return GSL_SUCCESS; } } /* gsl_linalg_balance_accum() */
static VALUE rb_gsl_blas_dscal2(int argc, VALUE *argv, VALUE obj) { double a; gsl_vector *x = NULL, *xnew = NULL; switch (TYPE(obj)) { case T_MODULE: case T_CLASS: case T_OBJECT: if (argc != 2) rb_raise(rb_eArgError, "wrong number of arguments (%d for 2)", argc); Need_Float(argv[0]); CHECK_VECTOR(argv[1]); a = NUM2DBL(argv[0]); Data_Get_Struct(argv[1], gsl_vector, x); break; default: Data_Get_Struct(obj, gsl_vector, x); if (argc != 1) rb_raise(rb_eArgError, "wrong number of arguments (%d for 1)", argc); Need_Float(argv[0]); a = NUM2DBL(argv[0]); break; } xnew = gsl_vector_alloc(x->size); gsl_vector_memcpy(xnew, x); gsl_blas_dscal(a, xnew); return Data_Wrap_Struct(cgsl_vector, 0, gsl_vector_free, xnew); }
tnn_error tnn_loss_bprop_euclidean(tnn_loss *l){ //Routine check if(l->t != TNN_LOSS_TYPE_EUCLIDEAN){ return TNN_ERROR_LOSS_MISTYPE; } if(l->input1->valid != true || l->input2->valid != true || l->output->valid != true){ return TNN_ERROR_STATE_INVALID; } //bprop to input1 and input2 dx = dl 2 (x-y); dy = dl 2 (y-x) TNN_MACRO_GSLTEST(gsl_blas_dcopy(&l->input1->x, &l->input1->dx)); TNN_MACRO_GSLTEST(gsl_blas_daxpy(-1.0, &l->input2->x, &l->input1->dx)); gsl_blas_dscal(2.0*gsl_vector_get(&l->output->dx, 0), &l->input1->dx); TNN_MACRO_GSLTEST(gsl_blas_dcopy(&l->input1->dx, &l->input2->dx)); gsl_blas_dscal(-1.0, &l->input2->dx); return TNN_ERROR_SUCCESS; }
int gsl_linalg_cholesky_invert(gsl_matrix * LLT) { if (LLT->size1 != LLT->size2) { GSL_ERROR ("cholesky matrix must be square", GSL_ENOTSQR); } else { const size_t N = LLT->size1; size_t i; gsl_vector_view v1, v2; /* invert the lower triangle of LLT */ gsl_linalg_tri_lower_invert(LLT); /* * The lower triangle of LLT now contains L^{-1}. Now compute * A^{-1} = L^{-T} L^{-1} */ for (i = 0; i < N; ++i) { double aii = gsl_matrix_get(LLT, i, i); if (i < N - 1) { double tmp; v1 = gsl_matrix_subcolumn(LLT, i, i, N - i); gsl_blas_ddot(&v1.vector, &v1.vector, &tmp); gsl_matrix_set(LLT, i, i, tmp); if (i > 0) { gsl_matrix_view m = gsl_matrix_submatrix(LLT, i + 1, 0, N - i - 1, i); v1 = gsl_matrix_subcolumn(LLT, i, i + 1, N - i - 1); v2 = gsl_matrix_subrow(LLT, i, 0, i); gsl_blas_dgemv(CblasTrans, 1.0, &m.matrix, &v1.vector, aii, &v2.vector); } } else { v1 = gsl_matrix_row(LLT, N - 1); gsl_blas_dscal(aii, &v1.vector); } } /* copy lower triangle to upper */ gsl_matrix_transpose_tricpy('L', 0, LLT, LLT); return GSL_SUCCESS; } } /* gsl_linalg_cholesky_invert() */
void test_eigen_gensymm_results (const gsl_matrix * A, const gsl_matrix * B, const gsl_vector * eval, const gsl_matrix * evec, size_t count, const char * desc, const char * desc2) { const size_t N = A->size1; size_t i, j; gsl_vector * x = gsl_vector_alloc(N); gsl_vector * y = gsl_vector_alloc(N); gsl_vector * z = gsl_vector_alloc(N); /* check A v = lambda B v */ for (i = 0; i < N; i++) { double ei = gsl_vector_get (eval, i); gsl_vector_const_view vi = gsl_matrix_const_column(evec, i); double norm = gsl_blas_dnrm2(&vi.vector); /* check that eigenvector is normalized */ gsl_test_rel(norm, 1.0, N * GSL_DBL_EPSILON, "gensymm(N=%u,cnt=%u), %s, normalized(%d), %s", N, count, desc, i, desc2); gsl_vector_memcpy(z, &vi.vector); /* compute y = A z */ gsl_blas_dgemv (CblasNoTrans, 1.0, A, z, 0.0, y); /* compute x = B z */ gsl_blas_dgemv (CblasNoTrans, 1.0, B, z, 0.0, x); /* compute x = lambda B z */ gsl_blas_dscal(ei, x); /* now test if y = x */ for (j = 0; j < N; j++) { double xj = gsl_vector_get (x, j); double yj = gsl_vector_get (y, j); gsl_test_rel(yj, xj, 1e9 * GSL_DBL_EPSILON, "gensymm(N=%u,cnt=%u), %s, eigenvalue(%d,%d), real, %s", N, count, desc, i, j, desc2); } } gsl_vector_free(x); gsl_vector_free(y); gsl_vector_free(z); }
int gsl_linalg_balance_columns (gsl_matrix * A, gsl_vector * D) { const size_t N = A->size2; size_t j; if (D->size != A->size2) { GSL_ERROR("length of D must match second dimension of A", GSL_EINVAL); } gsl_vector_set_all (D, 1.0); for (j = 0; j < N; j++) { gsl_vector_view A_j = gsl_matrix_column (A, j); double s = gsl_blas_dasum(&A_j.vector); double f = 1.0; if (s == 0.0 || !gsl_finite(s)) { gsl_vector_set (D, j, f); continue; } /* FIXME: we could use frexp() here */ while (s > 1.0) { s /= 2.0; f *= 2.0; } while (s < 0.5) { s *= 2.0; f /= 2.0; } gsl_vector_set (D, j, f); if (f != 1.0) { gsl_blas_dscal(1.0/f, &A_j.vector); } } return GSL_SUCCESS; }
static void gensymmv_normalize_eigenvectors(gsl_matrix *evec) { const size_t N = evec->size1; size_t i; /* looping */ for (i = 0; i < N; ++i) { gsl_vector_view vi = gsl_matrix_column(evec, i); double scale = 1.0 / gsl_blas_dnrm2(&vi.vector); gsl_blas_dscal(scale, &vi.vector); } } /* gensymmv_normalize_eigenvectors() */
double normal_null_maximum(gsl_vector *means,gsl_vector *s) { assert(means->size == s->size); // Baskara coefs. double a,b,c; gsl_vector *s2=gsl_vector_alloc(means->size); gsl_blas_dcopy(s,s2); gsl_vector_mul(s2,s2); gsl_vector *B=gsl_vector_alloc(means->size); gsl_blas_dcopy(means,B); gsl_blas_dscal(-2.0,B); //printf("B=%lg %lg\n",ELTd(B,0),ELTd(B,1)); gsl_vector *C=gsl_vector_alloc(means->size); gsl_blas_dcopy(means,C); gsl_vector_mul(C,C); gsl_vector *prods=gsl_vector_alloc(means->size); mutual_prod(s2,prods); a=gsl_blas_dasum(prods); gsl_blas_ddot(B,prods,&b); gsl_blas_ddot(C,prods,&c); printf("null max: a=%lf b=%lf c=%lf\n",a,b,c); double delta=b*b-4*a*c; double x0=-b/(2.0*a); printf("null max: delta=%lg\n",delta); if (fabs(delta) < 1e-5) { return x0; } else { if (delta > 0) { double x1=(-b-sqrt(delta))/(2.0*a); double x2=(-b-sqrt(delta))/(2.0*a); printf("null max: x1=%lg x2=%lg\n",x1,x2); return x1; } else { printf("WARNING: Null max not found!\n"); return x0; } } }
int gsl_eigen_gensymm_standardize(gsl_matrix *A, const gsl_matrix *B) { const size_t N = A->size1; size_t i; double a, b, c; for (i = 0; i < N; ++i) { /* update lower triangle of A(i:n, i:n) */ a = gsl_matrix_get(A, i, i); b = gsl_matrix_get(B, i, i); a /= b * b; gsl_matrix_set(A, i, i, a); if (i < N - 1) { gsl_vector_view ai = gsl_matrix_subcolumn(A, i, i + 1, N - i - 1); gsl_matrix_view ma = gsl_matrix_submatrix(A, i + 1, i + 1, N - i - 1, N - i - 1); gsl_vector_const_view bi = gsl_matrix_const_subcolumn(B, i, i + 1, N - i - 1); gsl_matrix_const_view mb = gsl_matrix_const_submatrix(B, i + 1, i + 1, N - i - 1, N - i - 1); gsl_blas_dscal(1.0 / b, &ai.vector); c = -0.5 * a; gsl_blas_daxpy(c, &bi.vector, &ai.vector); gsl_blas_dsyr2(CblasLower, -1.0, &ai.vector, &bi.vector, &ma.matrix); gsl_blas_daxpy(c, &bi.vector, &ai.vector); gsl_blas_dtrsv(CblasLower, CblasNoTrans, CblasNonUnit, &mb.matrix, &ai.vector); } } return GSL_SUCCESS; } /* gsl_eigen_gensymm_standardize() */
static int vector_bfgs3_set(void *vstate, gsl_multimin_function_fdf * fdf, const gsl_vector * x, double *f, gsl_vector * gradient, double step_size, double tol) { vector_bfgs3_state_t *state = (vector_bfgs3_state_t *) vstate; state->iter = 0; state->step = step_size; state->delta_f = 0; GSL_MULTIMIN_FN_EVAL_F_DF(fdf, x, f, gradient); /* * Use the gradient as the initial direction */ gsl_vector_memcpy(state->x0, x); gsl_vector_memcpy(state->g0, gradient); state->g0norm = gsl_blas_dnrm2(state->g0); gsl_vector_memcpy(state->p, gradient); gsl_blas_dscal(-1 / state->g0norm, state->p); state->pnorm = gsl_blas_dnrm2(state->p); /* should be 1 */ state->fp0 = -state->g0norm; /* * Prepare the wrapper */ prepare_wrapper(&state->wrap, fdf, state->x0, *f, state->g0, state->p, state->x_alpha, state->g_alpha); /* * Prepare 1d minimisation parameters */ state->rho = 0.01; state->sigma = tol; state->tau1 = 9; state->tau2 = 0.05; state->tau3 = 0.5; state->order = 3; /* use cubic interpolation where possible */ return GSL_SUCCESS; }
tnn_error tnn_module_fprop_sum(tnn_module *m){ tnn_state **t; //Routine check if(m->t != TNN_MODULE_TYPE_SUM){ return TNN_ERROR_MODULE_MISTYPE; } if(m->input->valid != true || m->output->valid != true){ return TNN_ERROR_STATE_INVALID; } //fprop to output TNN_MACRO_GSLTEST(gsl_blas_dscal(0.0, &m->output->x)); for(t = (tnn_state **)utarray_front(((tnn_module_sum*)m->c)->sarray); t != NULL; t = (tnn_state **)utarray_next(((tnn_module_sum*)m->c)->sarray, t)){ TNN_MACRO_GSLTEST(gsl_blas_daxpy(1.0, &(*t)->x, &m->output->x)); } return TNN_ERROR_SUCCESS; }
static void nonsymmv_normalize_eigenvectors(gsl_vector_complex *eval, gsl_matrix_complex *evec) { const size_t N = evec->size1; size_t i; /* looping */ gsl_complex ei; gsl_vector_complex_view vi; gsl_vector_view re, im; double scale; /* scaling factor */ for (i = 0; i < N; ++i) { ei = gsl_vector_complex_get(eval, i); vi = gsl_matrix_complex_column(evec, i); re = gsl_vector_complex_real(&vi.vector); if (GSL_IMAG(ei) == 0.0) { scale = 1.0 / gsl_blas_dnrm2(&re.vector); gsl_blas_dscal(scale, &re.vector); } else if (GSL_IMAG(ei) > 0.0) { im = gsl_vector_complex_imag(&vi.vector); scale = 1.0 / gsl_hypot(gsl_blas_dnrm2(&re.vector), gsl_blas_dnrm2(&im.vector)); gsl_blas_zdscal(scale, &vi.vector); vi = gsl_matrix_complex_column(evec, i + 1); gsl_blas_zdscal(scale, &vi.vector); } } } /* nonsymmv_normalize_eigenvectors() */
double Vector::scale ( const double scalar ) { gsl_blas_dscal( scalar, &vector ); }
static int vector_bfgs3_iterate(void *vstate, gsl_multimin_function_fdf * fdf, gsl_vector * x, double *f, gsl_vector * gradient, gsl_vector * dx) { vector_bfgs3_state_t *state = (vector_bfgs3_state_t *) vstate; double alpha = 0.0, alpha1; gsl_vector *x0 = state->x0; gsl_vector *g0 = state->g0; gsl_vector *p = state->p; double g0norm = state->g0norm; double pnorm = state->pnorm; double delta_f = state->delta_f; double pg, dir; int status; double f0 = *f; if (pnorm == 0.0 || g0norm == 0.0 || state->fp0 == 0) { gsl_vector_set_zero(dx); return GSL_ENOPROG; } if (delta_f < 0) { double del = GSL_MAX_DBL(-delta_f, 10 * GSL_DBL_EPSILON * fabs(f0)); alpha1 = GSL_MIN_DBL(1.0, 2.0 * del / (-state->fp0)); } else { alpha1 = fabs(state->step); } /* * line minimisation, with cubic interpolation (order = 3) */ if (debug) printf("...call minimize()\n"); status = minimize(&state->wrap.fdf_linear, state->rho, state->sigma, state->tau1, state->tau2, state->tau3, state->order, alpha1, &alpha); if (debug) printf("...end minimize()\n"); if (status != GSL_SUCCESS) { update_position(&(state->wrap), alpha, x, f, gradient); /* YES! hrue */ return status; } update_position(&(state->wrap), alpha, x, f, gradient); state->delta_f = *f - f0; /* * Choose a new direction for the next step */ { /* * This is the BFGS update: */ /* * p' = g1 - A dx - B dg */ /* * A = - (1+ dg.dg/dx.dg) B + dg.g/dx.dg */ /* * B = dx.g/dx.dg */ gsl_vector *dx0 = state->dx0; gsl_vector *dg0 = state->dg0; double dxg, dgg, dxdg, dgnorm, A, B; /* * dx0 = x - x0 */ gsl_vector_memcpy(dx0, x); gsl_blas_daxpy(-1.0, x0, dx0); gsl_vector_memcpy(dx, dx0); /* keep a copy */ /* * dg0 = g - g0 */ gsl_vector_memcpy(dg0, gradient); gsl_blas_daxpy(-1.0, g0, dg0); gsl_blas_ddot(dx0, gradient, &dxg); gsl_blas_ddot(dg0, gradient, &dgg); gsl_blas_ddot(dx0, dg0, &dxdg); dgnorm = gsl_blas_dnrm2(dg0); if (dxdg != 0) { B = dxg / dxdg; A = -(1.0 + dgnorm * dgnorm / dxdg) * B + dgg / dxdg; } else { B = 0; A = 0; } gsl_vector_memcpy(p, gradient); gsl_blas_daxpy(-A, dx0, p); gsl_blas_daxpy(-B, dg0, p); } gsl_vector_memcpy(g0, gradient); gsl_vector_memcpy(x0, x); state->g0norm = gsl_blas_dnrm2(g0); state->pnorm = gsl_blas_dnrm2(p); /* * update direction and fp0 */ gsl_blas_ddot(p, gradient, &pg); dir = (pg >= 0.0) ? -1.0 : +1.0; gsl_blas_dscal(dir / state->pnorm, p); state->pnorm = gsl_blas_dnrm2(p); gsl_blas_ddot(p, g0, &state->fp0); change_direction(&state->wrap); return GSL_SUCCESS; }
static void nonsymmv_get_right_eigenvectors(gsl_matrix *T, gsl_matrix *Z, gsl_vector_complex *eval, gsl_matrix_complex *evec, gsl_eigen_nonsymmv_workspace *w) { const size_t N = T->size1; const double smlnum = GSL_DBL_MIN * N / GSL_DBL_EPSILON; const double bignum = (1.0 - GSL_DBL_EPSILON) / smlnum; int i; /* looping */ size_t iu, /* looping */ ju, ii; gsl_complex lambda; /* current eigenvalue */ double lambda_re, /* Re(lambda) */ lambda_im; /* Im(lambda) */ gsl_matrix_view Tv, /* temporary views */ Zv; gsl_vector_view y, /* temporary views */ y2, ev, ev2; double dat[4], /* scratch arrays */ dat_X[4]; double scale; /* scale factor */ double xnorm; /* |X| */ gsl_vector_complex_view ecol, /* column of evec */ ecol2; int complex_pair; /* complex eigenvalue pair? */ double smin; /* * Compute 1-norm of each column of upper triangular part of T * to control overflow in triangular solver */ gsl_vector_set(w->work3, 0, 0.0); for (ju = 1; ju < N; ++ju) { gsl_vector_set(w->work3, ju, 0.0); for (iu = 0; iu < ju; ++iu) { gsl_vector_set(w->work3, ju, gsl_vector_get(w->work3, ju) + fabs(gsl_matrix_get(T, iu, ju))); } } for (i = (int) N - 1; i >= 0; --i) { iu = (size_t) i; /* get current eigenvalue and store it in lambda */ lambda_re = gsl_matrix_get(T, iu, iu); if (iu != 0 && gsl_matrix_get(T, iu, iu - 1) != 0.0) { lambda_im = sqrt(fabs(gsl_matrix_get(T, iu, iu - 1))) * sqrt(fabs(gsl_matrix_get(T, iu - 1, iu))); } else { lambda_im = 0.0; } GSL_SET_COMPLEX(&lambda, lambda_re, lambda_im); smin = GSL_MAX(GSL_DBL_EPSILON * (fabs(lambda_re) + fabs(lambda_im)), smlnum); smin = GSL_MAX(smin, GSL_NONSYMMV_SMLNUM); if (lambda_im == 0.0) { int k, l; gsl_vector_view bv, xv; /* real eigenvector */ /* * The ordering of eigenvalues in 'eval' is arbitrary and * does not necessarily follow the Schur form T, so store * lambda in the right slot in eval to ensure it corresponds * to the eigenvector we are about to compute */ gsl_vector_complex_set(eval, iu, lambda); /* * We need to solve the system: * * (T(1:iu-1, 1:iu-1) - lambda*I)*X = -T(1:iu-1,iu) */ /* construct right hand side */ for (k = 0; k < i; ++k) { gsl_vector_set(w->work, (size_t) k, -gsl_matrix_get(T, (size_t) k, iu)); } gsl_vector_set(w->work, iu, 1.0); for (l = i - 1; l >= 0; --l) { size_t lu = (size_t) l; if (lu == 0) complex_pair = 0; else complex_pair = gsl_matrix_get(T, lu, lu - 1) != 0.0; if (!complex_pair) { double x; /* * 1-by-1 diagonal block - solve the system: * * (T_{ll} - lambda)*x = -T_{l(iu)} */ Tv = gsl_matrix_submatrix(T, lu, lu, 1, 1); bv = gsl_vector_view_array(dat, 1); gsl_vector_set(&bv.vector, 0, gsl_vector_get(w->work, lu)); xv = gsl_vector_view_array(dat_X, 1); gsl_schur_solve_equation(1.0, &Tv.matrix, lambda_re, 1.0, 1.0, &bv.vector, &xv.vector, &scale, &xnorm, smin); /* scale x to avoid overflow */ x = gsl_vector_get(&xv.vector, 0); if (xnorm > 1.0) { if (gsl_vector_get(w->work3, lu) > bignum / xnorm) { x /= xnorm; scale /= xnorm; } } if (scale != 1.0) { gsl_vector_view wv; wv = gsl_vector_subvector(w->work, 0, iu + 1); gsl_blas_dscal(scale, &wv.vector); } gsl_vector_set(w->work, lu, x); if (lu > 0) { gsl_vector_view v1, v2; /* update right hand side */ v1 = gsl_matrix_subcolumn(T, lu, 0, lu); v2 = gsl_vector_subvector(w->work, 0, lu); gsl_blas_daxpy(-x, &v1.vector, &v2.vector); } /* if (l > 0) */ } /* if (!complex_pair) */ else { double x11, x21; /* * 2-by-2 diagonal block */ Tv = gsl_matrix_submatrix(T, lu - 1, lu - 1, 2, 2); bv = gsl_vector_view_array(dat, 2); gsl_vector_set(&bv.vector, 0, gsl_vector_get(w->work, lu - 1)); gsl_vector_set(&bv.vector, 1, gsl_vector_get(w->work, lu)); xv = gsl_vector_view_array(dat_X, 2); gsl_schur_solve_equation(1.0, &Tv.matrix, lambda_re, 1.0, 1.0, &bv.vector, &xv.vector, &scale, &xnorm, smin); /* scale X(1,1) and X(2,1) to avoid overflow */ x11 = gsl_vector_get(&xv.vector, 0); x21 = gsl_vector_get(&xv.vector, 1); if (xnorm > 1.0) { double beta; beta = GSL_MAX(gsl_vector_get(w->work3, lu - 1), gsl_vector_get(w->work3, lu)); if (beta > bignum / xnorm) { x11 /= xnorm; x21 /= xnorm; scale /= xnorm; } } /* scale if necessary */ if (scale != 1.0) { gsl_vector_view wv; wv = gsl_vector_subvector(w->work, 0, iu + 1); gsl_blas_dscal(scale, &wv.vector); } gsl_vector_set(w->work, lu - 1, x11); gsl_vector_set(w->work, lu, x21); /* update right hand side */ if (lu > 1) { gsl_vector_view v1, v2; v1 = gsl_matrix_subcolumn(T, lu - 1, 0, lu - 1); v2 = gsl_vector_subvector(w->work, 0, lu - 1); gsl_blas_daxpy(-x11, &v1.vector, &v2.vector); v1 = gsl_matrix_subcolumn(T, lu, 0, lu - 1); gsl_blas_daxpy(-x21, &v1.vector, &v2.vector); } --l; } /* if (complex_pair) */ } /* for (l = i - 1; l >= 0; --l) */ /* * At this point, w->work is an eigenvector of the * Schur form T. To get an eigenvector of the original * matrix, we multiply on the left by Z, the matrix of * Schur vectors */ ecol = gsl_matrix_complex_column(evec, iu); y = gsl_matrix_column(Z, iu); if (iu > 0) { gsl_vector_view x; Zv = gsl_matrix_submatrix(Z, 0, 0, N, iu); x = gsl_vector_subvector(w->work, 0, iu); /* compute Z * w->work and store it in Z(:,iu) */ gsl_blas_dgemv(CblasNoTrans, 1.0, &Zv.matrix, &x.vector, gsl_vector_get(w->work, iu), &y.vector); } /* if (iu > 0) */ /* store eigenvector into evec */ ev = gsl_vector_complex_real(&ecol.vector); ev2 = gsl_vector_complex_imag(&ecol.vector); scale = 0.0; for (ii = 0; ii < N; ++ii) { double a = gsl_vector_get(&y.vector, ii); /* store real part of eigenvector */ gsl_vector_set(&ev.vector, ii, a); /* set imaginary part to 0 */ gsl_vector_set(&ev2.vector, ii, 0.0); if (fabs(a) > scale) scale = fabs(a); } if (scale != 0.0) scale = 1.0 / scale; /* scale by magnitude of largest element */ gsl_blas_dscal(scale, &ev.vector); } /* if (GSL_IMAG(lambda) == 0.0) */ else { gsl_vector_complex_view bv, xv; size_t k; int l; gsl_complex lambda2; /* complex eigenvector */ /* * Store the complex conjugate eigenvalues in the right * slots in eval */ GSL_SET_REAL(&lambda2, GSL_REAL(lambda)); GSL_SET_IMAG(&lambda2, -GSL_IMAG(lambda)); gsl_vector_complex_set(eval, iu - 1, lambda); gsl_vector_complex_set(eval, iu, lambda2); /* * First solve: * * [ T(i:i+1,i:i+1) - lambda*I ] * X = 0 */ if (fabs(gsl_matrix_get(T, iu - 1, iu)) >= fabs(gsl_matrix_get(T, iu, iu - 1))) { gsl_vector_set(w->work, iu - 1, 1.0); gsl_vector_set(w->work2, iu, lambda_im / gsl_matrix_get(T, iu - 1, iu)); } else { gsl_vector_set(w->work, iu - 1, -lambda_im / gsl_matrix_get(T, iu, iu - 1)); gsl_vector_set(w->work2, iu, 1.0); } gsl_vector_set(w->work, iu, 0.0); gsl_vector_set(w->work2, iu - 1, 0.0); /* construct right hand side */ for (k = 0; k < iu - 1; ++k) { gsl_vector_set(w->work, k, -gsl_vector_get(w->work, iu - 1) * gsl_matrix_get(T, k, iu - 1)); gsl_vector_set(w->work2, k, -gsl_vector_get(w->work2, iu) * gsl_matrix_get(T, k, iu)); } /* * We must solve the upper quasi-triangular system: * * [ T(1:i-2,1:i-2) - lambda*I ] * X = s*(work + i*work2) */ for (l = i - 2; l >= 0; --l) { size_t lu = (size_t) l; if (lu == 0) complex_pair = 0; else complex_pair = gsl_matrix_get(T, lu, lu - 1) != 0.0; if (!complex_pair) { gsl_complex bval; gsl_complex x; /* * 1-by-1 diagonal block - solve the system: * * (T_{ll} - lambda)*x = work + i*work2 */ Tv = gsl_matrix_submatrix(T, lu, lu, 1, 1); bv = gsl_vector_complex_view_array(dat, 1); xv = gsl_vector_complex_view_array(dat_X, 1); GSL_SET_COMPLEX(&bval, gsl_vector_get(w->work, lu), gsl_vector_get(w->work2, lu)); gsl_vector_complex_set(&bv.vector, 0, bval); gsl_schur_solve_equation_z(1.0, &Tv.matrix, &lambda, 1.0, 1.0, &bv.vector, &xv.vector, &scale, &xnorm, smin); if (xnorm > 1.0) { if (gsl_vector_get(w->work3, lu) > bignum / xnorm) { gsl_blas_zdscal(1.0/xnorm, &xv.vector); scale /= xnorm; } } /* scale if necessary */ if (scale != 1.0) { gsl_vector_view wv; wv = gsl_vector_subvector(w->work, 0, iu + 1); gsl_blas_dscal(scale, &wv.vector); wv = gsl_vector_subvector(w->work2, 0, iu + 1); gsl_blas_dscal(scale, &wv.vector); } x = gsl_vector_complex_get(&xv.vector, 0); gsl_vector_set(w->work, lu, GSL_REAL(x)); gsl_vector_set(w->work2, lu, GSL_IMAG(x)); /* update the right hand side */ if (lu > 0) { gsl_vector_view v1, v2; v1 = gsl_matrix_subcolumn(T, lu, 0, lu); v2 = gsl_vector_subvector(w->work, 0, lu); gsl_blas_daxpy(-GSL_REAL(x), &v1.vector, &v2.vector); v2 = gsl_vector_subvector(w->work2, 0, lu); gsl_blas_daxpy(-GSL_IMAG(x), &v1.vector, &v2.vector); } /* if (lu > 0) */ } /* if (!complex_pair) */ else { gsl_complex b1, b2, x1, x2; /* * 2-by-2 diagonal block - solve the system */ Tv = gsl_matrix_submatrix(T, lu - 1, lu - 1, 2, 2); bv = gsl_vector_complex_view_array(dat, 2); xv = gsl_vector_complex_view_array(dat_X, 2); GSL_SET_COMPLEX(&b1, gsl_vector_get(w->work, lu - 1), gsl_vector_get(w->work2, lu - 1)); GSL_SET_COMPLEX(&b2, gsl_vector_get(w->work, lu), gsl_vector_get(w->work2, lu)); gsl_vector_complex_set(&bv.vector, 0, b1); gsl_vector_complex_set(&bv.vector, 1, b2); gsl_schur_solve_equation_z(1.0, &Tv.matrix, &lambda, 1.0, 1.0, &bv.vector, &xv.vector, &scale, &xnorm, smin); x1 = gsl_vector_complex_get(&xv.vector, 0); x2 = gsl_vector_complex_get(&xv.vector, 1); if (xnorm > 1.0) { double beta; beta = GSL_MAX(gsl_vector_get(w->work3, lu - 1), gsl_vector_get(w->work3, lu)); if (beta > bignum / xnorm) { gsl_blas_zdscal(1.0/xnorm, &xv.vector); scale /= xnorm; } } /* scale if necessary */ if (scale != 1.0) { gsl_vector_view wv; wv = gsl_vector_subvector(w->work, 0, iu + 1); gsl_blas_dscal(scale, &wv.vector); wv = gsl_vector_subvector(w->work2, 0, iu + 1); gsl_blas_dscal(scale, &wv.vector); } gsl_vector_set(w->work, lu - 1, GSL_REAL(x1)); gsl_vector_set(w->work, lu, GSL_REAL(x2)); gsl_vector_set(w->work2, lu - 1, GSL_IMAG(x1)); gsl_vector_set(w->work2, lu, GSL_IMAG(x2)); /* update right hand side */ if (lu > 1) { gsl_vector_view v1, v2, v3, v4; v1 = gsl_matrix_subcolumn(T, lu - 1, 0, lu - 1); v4 = gsl_matrix_subcolumn(T, lu, 0, lu - 1); v2 = gsl_vector_subvector(w->work, 0, lu - 1); v3 = gsl_vector_subvector(w->work2, 0, lu - 1); gsl_blas_daxpy(-GSL_REAL(x1), &v1.vector, &v2.vector); gsl_blas_daxpy(-GSL_REAL(x2), &v4.vector, &v2.vector); gsl_blas_daxpy(-GSL_IMAG(x1), &v1.vector, &v3.vector); gsl_blas_daxpy(-GSL_IMAG(x2), &v4.vector, &v3.vector); } /* if (lu > 1) */ --l; } /* if (complex_pair) */ } /* for (l = i - 2; l >= 0; --l) */ /* * At this point, work + i*work2 is an eigenvector * of T - backtransform to get an eigenvector of the * original matrix */ y = gsl_matrix_column(Z, iu - 1); y2 = gsl_matrix_column(Z, iu); if (iu > 1) { gsl_vector_view x; /* compute real part of eigenvectors */ Zv = gsl_matrix_submatrix(Z, 0, 0, N, iu - 1); x = gsl_vector_subvector(w->work, 0, iu - 1); gsl_blas_dgemv(CblasNoTrans, 1.0, &Zv.matrix, &x.vector, gsl_vector_get(w->work, iu - 1), &y.vector); /* now compute the imaginary part */ x = gsl_vector_subvector(w->work2, 0, iu - 1); gsl_blas_dgemv(CblasNoTrans, 1.0, &Zv.matrix, &x.vector, gsl_vector_get(w->work2, iu), &y2.vector); } else { gsl_blas_dscal(gsl_vector_get(w->work, iu - 1), &y.vector); gsl_blas_dscal(gsl_vector_get(w->work2, iu), &y2.vector); } /* * Now store the eigenvectors into evec - the real parts * are Z(:,iu - 1) and the imaginary parts are * +/- Z(:,iu) */ /* get views of the two eigenvector slots */ ecol = gsl_matrix_complex_column(evec, iu - 1); ecol2 = gsl_matrix_complex_column(evec, iu); /* * save imaginary part first as it may get overwritten * when copying the real part due to our storage scheme * in Z/evec */ ev = gsl_vector_complex_imag(&ecol.vector); ev2 = gsl_vector_complex_imag(&ecol2.vector); scale = 0.0; for (ii = 0; ii < N; ++ii) { double a = gsl_vector_get(&y2.vector, ii); scale = GSL_MAX(scale, fabs(a) + fabs(gsl_vector_get(&y.vector, ii))); gsl_vector_set(&ev.vector, ii, a); gsl_vector_set(&ev2.vector, ii, -a); } /* now save the real part */ ev = gsl_vector_complex_real(&ecol.vector); ev2 = gsl_vector_complex_real(&ecol2.vector); for (ii = 0; ii < N; ++ii) { double a = gsl_vector_get(&y.vector, ii); gsl_vector_set(&ev.vector, ii, a); gsl_vector_set(&ev2.vector, ii, a); } if (scale != 0.0) scale = 1.0 / scale; /* scale by largest element magnitude */ gsl_blas_zdscal(scale, &ecol.vector); gsl_blas_zdscal(scale, &ecol2.vector); /* * decrement i since we took care of two eigenvalues at * the same time */ --i; } /* if (GSL_IMAG(lambda) != 0.0) */ } /* for (i = (int) N - 1; i >= 0; --i) */ } /* nonsymmv_get_right_eigenvectors() */
/** * C++ version of gsl_blas_dscal(). * @param alpha A constant * @param X A vector */ void dscal( double alpha, vector& X ){ gsl_blas_dscal( alpha, X.get() ); }
int gsl_linalg_householder_hm1 (double tau, gsl_matrix * A) { /* applies a householder transformation v,tau to a matrix being build up from the identity matrix, using the first column of A as a householder vector */ if (tau == 0) { size_t i,j; gsl_matrix_set (A, 0, 0, 1.0); for (j = 1; j < A->size2; j++) { gsl_matrix_set (A, 0, j, 0.0); } for (i = 1; i < A->size1; i++) { gsl_matrix_set (A, i, 0, 0.0); } return GSL_SUCCESS; } /* w = A' v */ #ifdef USE_BLAS { gsl_matrix_view A1 = gsl_matrix_submatrix (A, 1, 0, A->size1 - 1, A->size2); gsl_vector_view v1 = gsl_matrix_column (&A1.matrix, 0); size_t j; for (j = 1; j < A->size2; j++) { double wj = 0.0; /* A0j * v0 */ gsl_vector_view A1j = gsl_matrix_column(&A1.matrix, j); gsl_blas_ddot (&A1j.vector, &v1.vector, &wj); /* A = A - tau v w' */ gsl_matrix_set (A, 0, j, - tau * wj); gsl_blas_daxpy(-tau*wj, &v1.vector, &A1j.vector); } gsl_blas_dscal(-tau, &v1.vector); gsl_matrix_set (A, 0, 0, 1.0 - tau); } #else { size_t i, j; for (j = 1; j < A->size2; j++) { double wj = 0.0; /* A0j * v0 */ for (i = 1; i < A->size1; i++) { double vi = gsl_matrix_get(A, i, 0); wj += gsl_matrix_get(A,i,j) * vi; } /* A = A - tau v w' */ gsl_matrix_set (A, 0, j, - tau * wj); for (i = 1; i < A->size1; i++) { double vi = gsl_matrix_get (A, i, 0); double Aij = gsl_matrix_get (A, i, j); gsl_matrix_set (A, i, j, Aij - tau * vi * wj); } } for (i = 1; i < A->size1; i++) { double vi = gsl_matrix_get(A, i, 0); gsl_matrix_set(A, i, 0, -tau * vi); } gsl_matrix_set (A, 0, 0, 1.0 - tau); } #endif return GSL_SUCCESS; }
int gsl_linalg_pcholesky_invert(const gsl_matrix * LDLT, const gsl_permutation * p, gsl_matrix * Ainv) { const size_t M = LDLT->size1; const size_t N = LDLT->size2; if (M != N) { GSL_ERROR ("LDLT matrix must be square", GSL_ENOTSQR); } else if (LDLT->size1 != p->size) { GSL_ERROR ("matrix size must match permutation size", GSL_EBADLEN); } else if (Ainv->size1 != Ainv->size2) { GSL_ERROR ("Ainv matrix must be square", GSL_ENOTSQR); } else if (Ainv->size1 != M) { GSL_ERROR ("Ainv matrix has wrong dimensions", GSL_EBADLEN); } else { size_t i, j; gsl_vector_view v1, v2; /* invert the lower triangle of LDLT */ gsl_matrix_memcpy(Ainv, LDLT); gsl_linalg_tri_lower_unit_invert(Ainv); /* compute sqrt(D^{-1}) L^{-1} in the lower triangle of Ainv */ for (i = 0; i < N; ++i) { double di = gsl_matrix_get(LDLT, i, i); double sqrt_di = sqrt(di); for (j = 0; j < i; ++j) { double *Lij = gsl_matrix_ptr(Ainv, i, j); *Lij /= sqrt_di; } gsl_matrix_set(Ainv, i, i, 1.0 / sqrt_di); } /* * The lower triangle of Ainv now contains D^{-1/2} L^{-1}. Now compute * A^{-1} = L^{-T} D^{-1} L^{-1} */ for (i = 0; i < N; ++i) { double aii = gsl_matrix_get(Ainv, i, i); if (i < N - 1) { double tmp; v1 = gsl_matrix_subcolumn(Ainv, i, i, N - i); gsl_blas_ddot(&v1.vector, &v1.vector, &tmp); gsl_matrix_set(Ainv, i, i, tmp); if (i > 0) { gsl_matrix_view m = gsl_matrix_submatrix(Ainv, i + 1, 0, N - i - 1, i); v1 = gsl_matrix_subcolumn(Ainv, i, i + 1, N - i - 1); v2 = gsl_matrix_subrow(Ainv, i, 0, i); gsl_blas_dgemv(CblasTrans, 1.0, &m.matrix, &v1.vector, aii, &v2.vector); } } else { v1 = gsl_matrix_row(Ainv, N - 1); gsl_blas_dscal(aii, &v1.vector); } } /* copy lower triangle to upper */ gsl_matrix_transpose_tricpy('L', 0, Ainv, Ainv); /* now apply permutation p to the matrix */ /* compute L^{-T} D^{-1} L^{-1} P^T */ for (i = 0; i < N; ++i) { v1 = gsl_matrix_row(Ainv, i); gsl_permute_vector_inverse(p, &v1.vector); } /* compute P L^{-T} D^{-1} L^{-1} P^T */ for (i = 0; i < N; ++i) { v1 = gsl_matrix_column(Ainv, i); gsl_permute_vector_inverse(p, &v1.vector); } return GSL_SUCCESS; } }
double normalize(gsl_vector* v) { double sum = gsl_blas_dsum(v); gsl_blas_dscal(1 / sum, v); return sum; }
static int conjugate_fr_iterate (void *vstate, gsl_multimin_function_fdf * fdf, gsl_vector * x, double *f, gsl_vector * gradient, gsl_vector * dx) { conjugate_fr_state_t *state = (conjugate_fr_state_t *) vstate; gsl_vector *x1 = state->x1; gsl_vector *dx1 = state->dx1; gsl_vector *x2 = state->x2; gsl_vector *p = state->p; gsl_vector *g0 = state->g0; double pnorm = state->pnorm; double g0norm = state->g0norm; double fa = *f, fb, fc; double dir; double stepa = 0.0, stepb, stepc = state->step, tol = state->tol; double g1norm; double pg; if (pnorm == 0.0 || g0norm == 0.0) { gsl_vector_set_zero (dx); return GSL_ENOPROG; } /* Determine which direction is downhill, +p or -p */ gsl_blas_ddot (p, gradient, &pg); dir = (pg >= 0.0) ? +1.0 : -1.0; /* Compute new trial point at x_c= x - step * p, where p is the current direction */ take_step (x, p, stepc, dir / pnorm, x1, dx); /* Evaluate function and gradient at new point xc */ fc = GSL_MULTIMIN_FN_EVAL_F (fdf, x1); if (fc < fa) { /* Success, reduced the function value */ state->step = stepc * 2.0; *f = fc; gsl_vector_memcpy (x, x1); GSL_MULTIMIN_FN_EVAL_DF (fdf, x1, gradient); return GSL_SUCCESS; } #ifdef DEBUG printf ("got stepc = %g fc = %g\n", stepc, fc); #endif /* Do a line minimisation in the region (xa,fa) (xc,fc) to find an intermediate (xb,fb) satisifying fa > fb < fc. Choose an initial xb based on parabolic interpolation */ intermediate_point (fdf, x, p, dir / pnorm, pg, stepa, stepc, fa, fc, x1, dx1, gradient, &stepb, &fb); if (stepb == 0.0) { return GSL_ENOPROG; } minimize (fdf, x, p, dir / pnorm, stepa, stepb, stepc, fa, fb, fc, tol, x1, dx1, x2, dx, gradient, &(state->step), f, &g1norm); gsl_vector_memcpy (x, x2); /* Choose a new conjugate direction for the next step */ state->iter = (state->iter + 1) % x->size; if (state->iter == 0) { gsl_vector_memcpy (p, gradient); state->pnorm = g1norm; } else { /* p' = g1 - beta * p */ double beta = -pow (g1norm / g0norm, 2.0); gsl_blas_dscal (-beta, p); gsl_blas_daxpy (1.0, gradient, p); state->pnorm = gsl_blas_dnrm2 (p); } state->g0norm = g1norm; gsl_vector_memcpy (g0, gradient); #ifdef DEBUG printf ("updated conjugate directions\n"); printf ("p: "); gsl_vector_fprintf (stdout, p, "%g"); printf ("g: "); gsl_vector_fprintf (stdout, gradient, "%g"); #endif return GSL_SUCCESS; }
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; }
int gsl_linalg_SV_decomp (gsl_matrix * A, gsl_matrix * V, gsl_vector * S, gsl_vector * work) { size_t a, b, i, j, iter; const size_t M = A->size1; const size_t N = A->size2; const size_t K = GSL_MIN (M, N); 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 (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); } /* Handle the case of N = 1 (SVD of a column vector) */ 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; } { gsl_vector_view f = gsl_vector_subvector (work, 0, K - 1); /* bidiagonalize matrix A, unpack A into U S V */ gsl_linalg_bidiag_decomp (A, S, &f.vector); gsl_linalg_bidiag_unpack2 (A, S, &f.vector, V); /* apply reduction steps to B=(S,Sd) */ chop_small_elements (S, &f.vector); /* Progressively reduce the matrix until it is diagonal */ b = N - 1; iter = 0; while (b > 0) { double fbm1 = gsl_vector_get (&f.vector, b - 1); if (fbm1 == 0.0 || gsl_isnan (fbm1)) { b--; continue; } /* Find the largest unreduced block (a,b) starting from b and working backwards */ a = b - 1; while (a > 0) { double fam1 = gsl_vector_get (&f.vector, a - 1); if (fam1 == 0.0 || gsl_isnan (fam1)) { break; } a--; } iter++; if (iter > 100 * N) { GSL_ERROR("SVD decomposition failed to converge", GSL_EMAXITER); } { const size_t n_block = b - a + 1; gsl_vector_view S_block = gsl_vector_subvector (S, a, n_block); gsl_vector_view f_block = gsl_vector_subvector (&f.vector, a, n_block - 1); gsl_matrix_view U_block = gsl_matrix_submatrix (A, 0, a, A->size1, n_block); gsl_matrix_view V_block = gsl_matrix_submatrix (V, 0, a, V->size1, n_block); qrstep (&S_block.vector, &f_block.vector, &U_block.matrix, &V_block.matrix); /* remove any small off-diagonal elements */ chop_small_elements (&S_block.vector, &f_block.vector); } } } /* Make singular values positive by reflections if necessary */ for (j = 0; j < K; j++) { double Sj = gsl_vector_get (S, j); if (Sj < 0.0) { for (i = 0; i < N; i++) { double Vij = gsl_matrix_get (V, i, j); gsl_matrix_set (V, i, j, -Vij); } gsl_vector_set (S, j, -Sj); } } /* Sort singular values into decreasing order */ for (i = 0; i < K; i++) { double S_max = gsl_vector_get (S, i); size_t i_max = i; for (j = i + 1; j < K; j++) { double Sj = gsl_vector_get (S, j); if (Sj > S_max) { S_max = Sj; i_max = j; } } if (i_max != i) { /* swap eigenvalues */ gsl_vector_swap_elements (S, i, i_max); /* swap eigenvectors */ gsl_matrix_swap_columns (A, i, i_max); gsl_matrix_swap_columns (V, i, i_max); } } return GSL_SUCCESS; }
int gsl_linalg_balance_matrix(gsl_matrix * A, gsl_vector * D) { const size_t N = A->size1; if (N != D->size) { GSL_ERROR ("vector must match matrix size", GSL_EBADLEN); } else { double row_norm, col_norm; int not_converged; gsl_vector_view v; /* initialize D to the identity matrix */ gsl_vector_set_all(D, 1.0); not_converged = 1; while (not_converged) { size_t i, j; double g, f, s; not_converged = 0; for (i = 0; i < N; ++i) { row_norm = 0.0; col_norm = 0.0; for (j = 0; j < N; ++j) { if (j != i) { col_norm += fabs(gsl_matrix_get(A, j, i)); row_norm += fabs(gsl_matrix_get(A, i, j)); } } if ((col_norm == 0.0) || (row_norm == 0.0)) { continue; } g = row_norm / FLOAT_RADIX; f = 1.0; s = col_norm + row_norm; /* * find the integer power of the machine radix which * comes closest to balancing the matrix */ while (col_norm < g) { f *= FLOAT_RADIX; col_norm *= FLOAT_RADIX_SQ; } g = row_norm * FLOAT_RADIX; while (col_norm > g) { f /= FLOAT_RADIX; col_norm /= FLOAT_RADIX_SQ; } if ((row_norm + col_norm) < 0.95 * s * f) { not_converged = 1; g = 1.0 / f; /* * apply similarity transformation D, where * D_{ij} = f_i * delta_{ij} */ /* multiply by D^{-1} on the left */ v = gsl_matrix_row(A, i); gsl_blas_dscal(g, &v.vector); /* multiply by D on the right */ v = gsl_matrix_column(A, i); gsl_blas_dscal(f, &v.vector); /* keep track of transformation */ gsl_vector_set(D, i, gsl_vector_get(D, i) * f); } } } return GSL_SUCCESS; } } /* gsl_linalg_balance_matrix() */
static int bundle_method_iterate (void *vstate, gsl_multimin_function_fsdf * fsdf, gsl_vector * x, double * f, gsl_vector * subgradient, gsl_vector * dx, double * eps) { bundle_method_state_t *state = (bundle_method_state_t *) vstate; bundle_element *item; size_t i, debug=0; int status; double tmp_d, t_old, t_int_l; /* local variables */ gsl_vector *y; /* a trial point (the next iteration point by the serios step) */ gsl_vector *sgr_y; /* subgradient at y */ double f_y; /* the function value at y */ gsl_vector *p; /* the aggregate subgradient */ double p_norm, lin_error_p; /* norm of p, the aggregate linear. error */ gsl_vector *tmp_v; /* data for the convex quadratic problem (for the dual problem) */ gsl_vector *q; /* elements of the array are the linearization errors */ gsl_matrix *Q; /* Q=G^T*G (G is matrix which collumns are subgradients) */ gsl_vector *lambda; /* the convex combination coefficients of the subgradients (solution of the dual problem) */ lambda = gsl_vector_alloc(state->bundle_size); if(lambda == 0) { GSL_ERROR_VAL ("failed to allocate workspace", GSL_ENOMEM, 0); } q = gsl_vector_alloc(lambda->size); if(q == 0) { gsl_vector_free(lambda); GSL_ERROR_VAL ("failed to allocate workspace", GSL_ENOMEM, 0); } y = gsl_vector_calloc(x->size); if(y == 0) { gsl_vector_free(q); gsl_vector_free(lambda); GSL_ERROR_VAL ("failed to allocate workspace", GSL_ENOMEM, 0); } sgr_y = gsl_vector_calloc(x->size); if(sgr_y == 0) { gsl_vector_free(y); gsl_vector_free(q); gsl_vector_free(lambda); GSL_ERROR_VAL ("failed to allocate workspace", GSL_ENOMEM, 0); } Q = gsl_matrix_alloc(state->bundle_size, state->bundle_size); if(Q == 0) { gsl_vector_free(sgr_y); gsl_vector_free(y); gsl_vector_free(q); gsl_vector_free(lambda); GSL_ERROR_VAL ("failed to allocate workspace", GSL_ENOMEM, 0); } p = gsl_vector_calloc(x->size); if(p == 0) { gsl_matrix_free(Q); gsl_vector_free(sgr_y); gsl_vector_free(y); gsl_vector_free(q); gsl_vector_free(lambda); GSL_ERROR_VAL ("failed to allocate workspace", GSL_ENOMEM, 0); } tmp_v = gsl_vector_calloc(x->size); if(tmp_v == 0) { gsl_vector_free(p); gsl_matrix_free(Q); gsl_vector_free(sgr_y); gsl_vector_free(y); gsl_vector_free(q); gsl_vector_free(lambda); GSL_ERROR_VAL ("failed to allocate workspace", GSL_ENOMEM, 0); } /* solve the dual problem */ status = build_cqp_data(state, Q, q); status = solve_qp_pdip(Q, q, lambda); gsl_matrix_free(Q); gsl_vector_free(q); /* compute the aggregate subgradient (it is called p in the documantation)*/ /* and the appropriated linearization error */ lin_error_p = 0.0; item = state->head; for(i=0; i<lambda->size; i++) { status = gsl_blas_daxpy(gsl_vector_get(lambda,i), item->sgr, p); lin_error_p += gsl_vector_get(lambda,i)*(item->lin_error); item = item->next; } if(debug) { printf("the dual problem solution:\n"); for(i=0;i<lambda->size;i++) printf("%7.6e ",gsl_vector_get(lambda,i)); printf("\n\n"); printf("the aggregate subgradient: \n"); for(i=0;i<p->size;i++) printf("%.6e ",gsl_vector_get(p,i)); printf("\n"); printf("lin. error for aggr subgradient = %e\n",lin_error_p); } /* the norm of the aggr subgradient */ p_norm = gsl_blas_dnrm2(p); /* search direction dx=-t*p (t is the length of step) */ status = gsl_vector_memcpy(dx,p); status = gsl_vector_scale(dx,-1.0*state->t); /* v =-t*norm(p)^2-alpha_p */ state->v = -gsl_pow_2(p_norm)*(state->t)-lin_error_p; /* the subgradient is the aggegate sungradient */ status = gsl_blas_dcopy(p,subgradient); /* iteration step */ /* y=x+dx */ status = gsl_blas_dcopy(dx,y); status = gsl_blas_daxpy(1.0,x,y); /* function value at y */ f_y = GSL_MULTIMIN_FN_EVAL_F(fsdf, y); state->f_eval++; /* for t-update */ if(!state->fixed_step_length) { t_old = state->t; if(fabs(state->v-(f_y-*f)) < state->rg || state->v-(f_y-*f) > state->rg) t_int_l = state->t_max; else t_int_l = 0.5*t_old*(state->v)/(state->v-(f_y-*f)); } else { t_old = state->t; t_int_l = state->t; } if( f_y-*f <= state->m_ss*state->v ) /* Serious-Step */ { if(debug) printf("\nSerious-Step\n"); /* the relaxation step */ if(state->relaxation) { if(f_y-*f <= state->v*state->m_rel) { double f_z; gsl_vector * z = gsl_vector_alloc(y->size); /* z = y+dx = x+2*dx */ status = gsl_blas_dcopy(x,z); status = gsl_blas_daxpy(2.0,dx,z); f_z = GSL_MULTIMIN_FN_EVAL_F(fsdf, z); state->f_eval++; if(0.5*f_z-f_y+0.5*(*f) > state->rg) state->rel_parameter = GSL_MIN_DBL(-0.5*(-0.5*f_z+2.0*f_y-1.5*(*f))/(0.5*f_z-f_y+0.5*(*f)),1.999); else if (fabs(0.5*f_z-f_y+0.5*(*f)) > state->rg) state->rel_parameter = 1.999; else /* something is wrong */ state->rel_parameter = 1.0; /* save the old iteration point */ status = gsl_blas_dcopy(y,z); /* y = (1-rel_parameter)*x+rel_parameter*y */ gsl_blas_dscal(state->rel_parameter,y); status = gsl_blas_daxpy(1.0-state->rel_parameter,x,y); /* f(y) und sgr_f(y) */ tmp_d = GSL_MULTIMIN_FN_EVAL_F(fsdf, y); state->f_eval++; if(tmp_d > f_y) { /* keep y as the current point */ status = gsl_blas_dcopy(z,y); state->rel_counter++; } else { f_y = tmp_d; /* dx = y-x */ status = gsl_blas_dcopy(y,dx); status = gsl_blas_daxpy(-1.0,x,dx); /* if iteration points bevor and after the rel. step are closly, the rel_step counte will be increased */ /* |1-rel_parameter| <= 0.1*/ if( fabs(1.0-state->rel_parameter) < 0.1) state->rel_counter++; } GSL_MULTIMIN_FN_EVAL_SDF(fsdf, y, sgr_y); state->sgr_eval++; if(state->rel_counter > state->rel_counter_max) state->relaxation = 0; /* */ status = gsl_blas_daxpy(-1.0,y,z); status = gsl_blas_ddot(p, z, &tmp_d); *eps = f_y-*f-(state->v)+tmp_d; gsl_vector_free(z); } else { *eps = f_y-(state->v)-*f; GSL_MULTIMIN_FN_EVAL_SDF(fsdf, y, sgr_y); state->sgr_eval++; } } else { *eps = f_y-(state->v)-*f; GSL_MULTIMIN_FN_EVAL_SDF(fsdf, y, sgr_y); state->sgr_eval++; } /* calculate linearization errors at new iteration point */ item = state->head; for(i=0; i<state->bundle_size; i++) { status = gsl_blas_ddot(item->sgr, dx, &tmp_d); item->lin_error += f_y-*f-tmp_d; item = item->next; } /* linearization error at new iteration point */ status = gsl_blas_ddot(p, dx, &tmp_d); lin_error_p += f_y-*f-tmp_d; /* update the bundle */ status = update_bundle(state, sgr_y, 0.0, lambda, p, lin_error_p, 1); /* adapt the step length */ if(!state->fixed_step_length) { if(f_y-*f <= state->v*state->m_t && state->step_counter > 0) state->t = t_int_l; else if(state->step_counter>3) state->t=2.0*t_old; state->t = GSL_MIN_DBL(GSL_MIN_DBL(state->t,10.0*t_old),state->t_max); /*state->eps_v = GSL_MAX_DBL(state->eps_v,-2.0*state->v);*/ state->step_counter = GSL_MAX_INT(state->step_counter+1,1); if(fabs(state->t-t_old) > state->rg) state->step_counter=1; } /* x=y, f=f(y) */ status = gsl_blas_dcopy(y,x); *f = f_y; } else /* Null-Step */ { if(debug) printf("\nNull-Step\n"); GSL_MULTIMIN_FN_EVAL_SDF(fsdf, y, sgr_y); state->sgr_eval++; /* eps for the eps_subdifferential */ *eps = lin_error_p; /*calculate the liniarization error at y */ status = gsl_blas_ddot(sgr_y,dx,&tmp_d); tmp_d += *f-f_y; /* Bundle update */ status = update_bundle(state, sgr_y, tmp_d, lambda, p, lin_error_p, 0); /* adapt the step length */ if(!state->fixed_step_length) { /*state->eps_v = GSL_MIN_DBL(state->eps_v,lin_error_p);*/ if(tmp_d > GSL_MAX_DBL(p_norm,lin_error_p) && state->step_counter < -1) state->t = t_int_l; else if(state->step_counter < -3) state->t = 0.5*t_old; state->t = GSL_MAX_DBL(GSL_MAX_DBL(0.1*t_old,state->t),state->t_min); state->step_counter = GSL_MIN_INT(state->step_counter-1,-1); if(fabs(state->t-t_old) > state->rg) state->step_counter = -1; } } state->lambda_min = p_norm * state->lm_accuracy; if(debug) { printf("\nthe new bundle:\n"); bundle_out_liste(state); printf("\n\n"); printf("the curent itarationspoint (1 x %d)\n",x->size); for(i=0;i<x->size;i++) printf("%12.6f ",gsl_vector_get(x,i)); printf("\n\n"); printf("functions value at current point: f=%.8f\n",*f); printf("\nstep length t=%.5e\n",state->t); printf("\nstep_counter sc=%d\n",state->step_counter); printf("\naccuracy: v=%.5e\n",state->v); printf("\nlambda_min=%e\n",state->lambda_min); printf("\n"); } gsl_vector_free(lambda); gsl_vector_free(y); gsl_vector_free(sgr_y); gsl_vector_free(p); return GSL_SUCCESS; }
int gsl_linalg_SV_decomp (gsl_matrix * A, gsl_matrix * V, gsl_vector * S, gsl_vector * work) { size_t a, b, i, j, iter; const size_t M=A->size1; const size_t N=A->size2; size_t K; if (M<N) K=M; else K=N; 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 (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); } /* Handle the case of N=1 (SVD of a column vector) */ 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; } { gsl_vector_view f=gsl_vector_subvector (work, 0, K - 1); /* bidiagonalize matrix A, unpack A into U S V */ gsl_linalg_bidiag_decomp (A, S, &f.vector); //std::cout << "A: " << gsl_matrix_get(A,0,0) << " " //<< gsl_matrix_get(A,M-1,N-1) << std::endl; //std::cout << "S: " << S->data[0] << " " //<< S->data[S->size-1] //<< std::endl; gsl_linalg_bidiag_unpack2 (A, S, &f.vector, V); //std::cout << "S2: " << S->data[0] << " " //<< S->data[S->size-1] //<< std::endl; /* apply reduction steps to B=(S,Sd) */ chop_small_elements (S, &f.vector); //std::cout << "S3: " << S->data[0] << " " //<< S->data[S->size-1] //<< std::endl; /* Progressively reduce the matrix until it is diagonal */ b=N - 1; iter=0; while (b > 0) { double fbm1=gsl_vector_get (&f.vector, b - 1); if (fbm1 == 0.0 || gsl_isnan (fbm1)) { b--; continue; } //std::cout << "b,fbm1: " << b << " " << fbm1 << std::endl; /* Find the largest unreduced block (a,b) starting from b and working backwards */ a=b - 1; while (a > 0) { double fam1=gsl_vector_get (&f.vector, a - 1); if (fam1 == 0.0 || gsl_isnan (fam1)) { break; } a--; //std::cout << "a,fam1: " << a << " " << fam1 << std::endl; } iter++; if (iter > 100 * N) { GSL_ERROR("SVD decomposition failed to converge", GSL_EMAXITER); } { const size_t n_block=b - a + 1; gsl_vector_view S_block=gsl_vector_subvector (S, a, n_block); gsl_vector_view f_block=gsl_vector_subvector (&f.vector, a, n_block - 1); gsl_matrix_view U_block = gsl_matrix_submatrix (A, 0, a, A->size1, n_block); gsl_matrix_view V_block = gsl_matrix_submatrix (V, 0, a, V->size1, n_block); int rescale=0; double scale=1; double norm=0; /* Find the maximum absolute values of the diagonal and subdiagonal */ for (i=0; i < n_block; i++) { double s_i=gsl_vector_get (&S_block.vector, i); double a=fabs(s_i); if (a > norm) norm=a; //std::cout << "aa: " << a << std::endl; } for (i=0; i < n_block - 1; i++) { double f_i=gsl_vector_get (&f_block.vector, i); double a=fabs(f_i); if (a > norm) norm=a; //std::cout << "aa2: " << a << std::endl; } /* Temporarily scale the submatrix if necessary */ if (norm > GSL_SQRT_DBL_MAX) { scale=(norm / GSL_SQRT_DBL_MAX); rescale=1; } else if (norm < GSL_SQRT_DBL_MIN && norm > 0) { scale=(norm / GSL_SQRT_DBL_MIN); rescale=1; } //std::cout << "rescale: " << rescale << std::endl; if (rescale) { gsl_blas_dscal(1.0 / scale, &S_block.vector); gsl_blas_dscal(1.0 / scale, &f_block.vector); } /* Perform the implicit QR step */ /* for(size_t ii=0;ii<M;ii++) { for(size_t jj=0;jj<N;jj++) { std::cout << ii << "." << jj << "." << gsl_matrix_get(A,ii,jj) << std::endl; } } for(size_t ii=0;ii<N;ii++) { for(size_t jj=0;jj<N;jj++) { std::cout << "V: " << ii << "." << jj << "." << gsl_matrix_get(V,ii,jj) << std::endl; } } */ qrstep (&S_block.vector, &f_block.vector, &U_block.matrix, &V_block.matrix); /* for(size_t ii=0;ii<M;ii++) { for(size_t jj=0;jj<N;jj++) { std::cout << ii << " " << jj << " " << gsl_matrix_get(A,ii,jj) << std::endl; } } for(size_t ii=0;ii<N;ii++) { for(size_t jj=0;jj<N;jj++) { std::cout << "V: " << ii << " " << jj << " " << gsl_matrix_get(V,ii,jj) << std::endl; } } */ /* remove any small off-diagonal elements */ chop_small_elements (&S_block.vector, &f_block.vector); /* Undo the scaling if needed */ if (rescale) { gsl_blas_dscal(scale, &S_block.vector); gsl_blas_dscal(scale, &f_block.vector); } } } } /* Make singular values positive by reflections if necessary */ for (j=0; j < K; j++) { double Sj=gsl_vector_get (S, j); if (Sj < 0.0) { for (i=0; i < N; i++) { double Vij=gsl_matrix_get (V, i, j); gsl_matrix_set (V, i, j, -Vij); } gsl_vector_set (S, j, -Sj); } } /* Sort singular values into decreasing order */ for (i=0; i < K; i++) { double S_max=gsl_vector_get (S, i); size_t i_max=i; for (j=i + 1; j < K; j++) { double Sj=gsl_vector_get (S, j); if (Sj > S_max) { S_max=Sj; i_max=j; } } if (i_max != i) { /* swap eigenvalues */ gsl_vector_swap_elements (S, i, i_max); /* swap eigenvectors */ gsl_matrix_swap_columns (A, i, i_max); gsl_matrix_swap_columns (V, i, i_max); } } return GSL_SUCCESS; }
static int triangular_inverse(CBLAS_UPLO_t Uplo, CBLAS_DIAG_t Diag, gsl_matrix * T) { const size_t N = T->size1; if (N != T->size2) { GSL_ERROR ("matrix must be square", GSL_ENOTSQR); } else { gsl_matrix_view m; gsl_vector_view v; size_t i; if (Uplo == CblasUpper) { for (i = 0; i < N; ++i) { double aii; if (Diag == CblasNonUnit) { double *Tii = gsl_matrix_ptr(T, i, i); *Tii = 1.0 / *Tii; aii = -(*Tii); } else { aii = -1.0; } if (i > 0) { m = gsl_matrix_submatrix(T, 0, 0, i, i); v = gsl_matrix_subcolumn(T, i, 0, i); gsl_blas_dtrmv(CblasUpper, CblasNoTrans, Diag, &m.matrix, &v.vector); gsl_blas_dscal(aii, &v.vector); } } /* for (i = 0; i < N; ++i) */ } else { for (i = 0; i < N; ++i) { double ajj; size_t j = N - i - 1; if (Diag == CblasNonUnit) { double *Tjj = gsl_matrix_ptr(T, j, j); *Tjj = 1.0 / *Tjj; ajj = -(*Tjj); } else { ajj = -1.0; } if (j < N - 1) { m = gsl_matrix_submatrix(T, j + 1, j + 1, N - j - 1, N - j - 1); v = gsl_matrix_subcolumn(T, j, j + 1, N - j - 1); gsl_blas_dtrmv(CblasLower, CblasNoTrans, Diag, &m.matrix, &v.vector); gsl_blas_dscal(ajj, &v.vector); } } /* for (i = 0; i < N; ++i) */ } return GSL_SUCCESS; } }