inline static void apply_givens_lq (size_t M, size_t N, gsl_matrix * Q, gsl_matrix * L, size_t i, size_t j, double c, double s) { size_t k; /* Apply rotation to matrix Q, Q' = G Q */ #if USE_BLAS { gsl_matrix_view Q0M = gsl_matrix_submatrix(Q,0,0,j+1,M); gsl_vector_view Qi = gsl_matrix_row(&Q0M.matrix,i); gsl_vector_view Qj = gsl_matrix_row(&Q0M.matrix,j); gsl_blas_drot(&Qi.vector, &Qj.vector, c, -s); } #else for (k = 0; k < M; k++) { double qik = gsl_matrix_get (Q, i, k); double qjk = gsl_matrix_get (Q, j, k); gsl_matrix_set (Q, i, k, qik * c - qjk * s); gsl_matrix_set (Q, j, k, qik * s + qjk * c); } #endif /* Apply rotation to matrix L, L' = L G^T (note: lower triangular so zero for column > row) */ #if USE_BLAS { k = GSL_MIN(i,j); gsl_matrix_view L0 = gsl_matrix_submatrix(L, k, 0, N-k, j+1); gsl_vector_view Li = gsl_matrix_column(&L0.matrix,i); gsl_vector_view Lj = gsl_matrix_column(&L0.matrix,j); gsl_blas_drot(&Li.vector, &Lj.vector, c, -s); } #else for (k = GSL_MIN (i, j); k < N; k++) { double lki = gsl_matrix_get (L, k, i); double lkj = gsl_matrix_get (L, k, j); gsl_matrix_set (L, k, i, c * lki - s * lkj); gsl_matrix_set (L, k, j, s * lki + c * lkj); } #endif }
inline static void apply_givens_qr (size_t M, size_t N, gsl_matrix * Q, gsl_matrix * R, size_t i, size_t j, double c, double s) { size_t k; /* Apply rotation to matrix Q, Q' = Q G */ #if USE_BLAS { gsl_matrix_view Q0M = gsl_matrix_submatrix(Q,0,0,M,j+1); gsl_vector_view Qi = gsl_matrix_column(&Q0M.matrix,i); gsl_vector_view Qj = gsl_matrix_column(&Q0M.matrix,j); gsl_blas_drot(&Qi.vector, &Qj.vector, c, -s); } #else for (k = 0; k < M; k++) { double qki = gsl_matrix_get (Q, k, i); double qkj = gsl_matrix_get (Q, k, j); gsl_matrix_set (Q, k, i, qki * c - qkj * s); gsl_matrix_set (Q, k, j, qki * s + qkj * c); } #endif /* Apply rotation to matrix R, R' = G^T R (note: upper triangular so zero for column < row) */ #if USE_BLAS { k = GSL_MIN(i,j); gsl_matrix_view R0 = gsl_matrix_submatrix(R, 0, k, j+1, N-k); gsl_vector_view Ri = gsl_matrix_row(&R0.matrix,i); gsl_vector_view Rj = gsl_matrix_row(&R0.matrix,j); gsl_blas_drot(&Ri.vector, &Rj.vector, c, -s); } #else for (k = GSL_MIN (i, j); k < N; k++) { double rik = gsl_matrix_get (R, i, k); double rjk = gsl_matrix_get (R, j, k); gsl_matrix_set (R, i, k, c * rik - s * rjk); gsl_matrix_set (R, j, k, s * rik + c * rjk); } #endif }
static VALUE rb_gsl_blas_drot(VALUE obj, VALUE xx, VALUE yy, VALUE cc, VALUE ss) { gsl_vector *x = NULL, *y = NULL; double c, s; CHECK_VECTOR(xx); CHECK_VECTOR(yy); Need_Float(cc); Need_Float(ss); Data_Get_Struct(xx, gsl_vector, x); Data_Get_Struct(yy, gsl_vector, y); c = NUM2DBL(cc); s = NUM2DBL(ss); gsl_blas_drot(x, y, c, s); return rb_ary_new3(2, xx, yy); }
static VALUE rb_gsl_blas_drot2(VALUE obj, VALUE xx, VALUE yy, VALUE cc, VALUE ss) { gsl_vector *x = NULL, *y = NULL, *xnew = NULL, *ynew = NULL; double c, s; CHECK_VECTOR(xx); CHECK_VECTOR(yy); Need_Float(cc); Need_Float(ss); Data_Get_Struct(xx, gsl_vector, x); Data_Get_Struct(yy, gsl_vector, y); c = NUM2DBL(cc); s = NUM2DBL(ss); xnew = gsl_vector_alloc(x->size); ynew = gsl_vector_alloc(y->size); gsl_vector_memcpy(xnew, x); gsl_vector_memcpy(ynew, y); gsl_blas_drot(xnew, ynew, c, s); return rb_ary_new3(2, Data_Wrap_Struct(cgsl_vector, 0, gsl_vector_free, xnew), Data_Wrap_Struct(cgsl_vector, 0, gsl_vector_free, ynew)); }
/** * C++ version of gsl_blas_drot(). * @param X A vector * @param Y A vector * @param c A constant * @param s A constant * @return Error code on failure */ int drot( vector& X, vector& Y, double const c, double const s ){ return gsl_blas_drot( X.get(), Y.get(), c, s ); }
int gsl_linalg_hesstri_decomp(gsl_matrix * A, gsl_matrix * B, gsl_matrix * U, gsl_matrix * V, gsl_vector * work) { const size_t N = A->size1; if ((N != A->size2) || (N != B->size1) || (N != B->size2)) { GSL_ERROR ("Hessenberg-triangular reduction requires square matrices", GSL_ENOTSQR); } else if (N != work->size) { GSL_ERROR ("length of workspace must match matrix dimension", GSL_EBADLEN); } else { double cs, sn; /* rotation parameters */ size_t i, j; /* looping */ gsl_vector_view xv, yv; /* temporary views */ /* B -> Q^T B = R (upper triangular) */ gsl_linalg_QR_decomp(B, work); /* A -> Q^T A */ gsl_linalg_QR_QTmat(B, work, A); /* initialize U and V if desired */ if (U) { gsl_linalg_QR_unpack(B, work, U, B); } else { /* zero out lower triangle of B */ for (j = 0; j < N - 1; ++j) { for (i = j + 1; i < N; ++i) gsl_matrix_set(B, i, j, 0.0); } } if (V) gsl_matrix_set_identity(V); if (N < 3) return GSL_SUCCESS; /* nothing more to do */ /* reduce A and B */ for (j = 0; j < N - 2; ++j) { for (i = N - 1; i >= (j + 2); --i) { /* step 1: rotate rows i - 1, i to kill A(i,j) */ /* * compute G = [ CS SN ] so that G^t [ A(i-1,j) ] = [ * ] * [-SN CS ] [ A(i, j) ] [ 0 ] */ gsl_linalg_givens(gsl_matrix_get(A, i - 1, j), gsl_matrix_get(A, i, j), &cs, &sn); /* invert so drot() works correctly (G -> G^t) */ sn = -sn; /* compute G^t A(i-1:i, j:n) */ xv = gsl_matrix_subrow(A, i - 1, j, N - j); yv = gsl_matrix_subrow(A, i, j, N - j); gsl_blas_drot(&xv.vector, &yv.vector, cs, sn); /* compute G^t B(i-1:i, i-1:n) */ xv = gsl_matrix_subrow(B, i - 1, i - 1, N - i + 1); yv = gsl_matrix_subrow(B, i, i - 1, N - i + 1); gsl_blas_drot(&xv.vector, &yv.vector, cs, sn); if (U) { /* accumulate U: U -> U G */ xv = gsl_matrix_column(U, i - 1); yv = gsl_matrix_column(U, i); gsl_blas_drot(&xv.vector, &yv.vector, cs, sn); } /* step 2: rotate columns i, i - 1 to kill B(i, i - 1) */ gsl_linalg_givens(-gsl_matrix_get(B, i, i), gsl_matrix_get(B, i, i - 1), &cs, &sn); /* invert so drot() works correctly (G -> G^t) */ sn = -sn; /* compute B(1:i, i-1:i) G */ xv = gsl_matrix_subcolumn(B, i - 1, 0, i + 1); yv = gsl_matrix_subcolumn(B, i, 0, i + 1); gsl_blas_drot(&xv.vector, &yv.vector, cs, sn); /* apply to A(1:n, i-1:i) */ xv = gsl_matrix_column(A, i - 1); yv = gsl_matrix_column(A, i); gsl_blas_drot(&xv.vector, &yv.vector, cs, sn); if (V) { /* accumulate V: V -> V G */ xv = gsl_matrix_column(V, i - 1); yv = gsl_matrix_column(V, i); gsl_blas_drot(&xv.vector, &yv.vector, cs, sn); } } } return GSL_SUCCESS; } } /* gsl_linalg_hesstri_decomp() */