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() */
