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;
}
}
