int
gsl_linalg_PTLQ_decomp (gsl_matrix * A, gsl_vector * tau, gsl_permutation * p, int *signum, gsl_vector * norm)
{
const size_t N = A->size1;
const size_t M = A->size2;
if (tau->size != GSL_MIN (M, N))
{
GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN);
}
else if (p->size != N)
{
GSL_ERROR ("permutation size must be N", GSL_EBADLEN);
}
else if (norm->size != N)
{
GSL_ERROR ("norm size must be N", GSL_EBADLEN);
}
else
{
size_t i;
*signum = 1;
gsl_permutation_init (p); /* set to identity */
/* Compute column norms and store in workspace */
for (i = 0; i < N; i++)
{
gsl_vector_view c = gsl_matrix_row (A, i);
double x = gsl_blas_dnrm2 (&c.vector);
gsl_vector_set (norm, i, x);
}
for (i = 0; i < GSL_MIN (M, N); i++)
{
/* Bring the column of largest norm into the pivot position */
double max_norm = gsl_vector_get(norm, i);
size_t j, kmax = i;
for (j = i + 1; j < N; j++)
{
double x = gsl_vector_get (norm, j);
if (x > max_norm)
{
max_norm = x;
kmax = j;
}
}
if (kmax != i)
{
gsl_matrix_swap_rows (A, i, kmax);
gsl_permutation_swap (p, i, kmax);
gsl_vector_swap_elements(norm,i,kmax);
(*signum) = -(*signum);
}
/* Compute the Householder transformation to reduce the j-th
column of the matrix to a multiple of the j-th unit vector */
{
gsl_vector_view c_full = gsl_matrix_row (A, i);
gsl_vector_view c = gsl_vector_subvector (&c_full.vector,
i, M - i);
double tau_i = gsl_linalg_householder_transform (&c.vector);
gsl_vector_set (tau, i, tau_i);
/* Apply the transformation to the remaining columns */
if (i + 1 < N)
{
gsl_matrix_view m = gsl_matrix_submatrix (A, i +1, i, N - (i+1), M - i);
gsl_linalg_householder_mh (tau_i, &c.vector, &m.matrix);
}
}
/* Update the norms of the remaining columns too */
if (i + 1 < M)
{
for (j = i + 1; j < N; j++)
{
double x = gsl_vector_get (norm, j);
if (x > 0.0)
{
double y = 0;
double temp= gsl_matrix_get (A, j, i) / x;
if (fabs (temp) >= 1)
y = 0.0;
else
y = x * sqrt (1 - temp * temp);
/* recompute norm to prevent loss of accuracy */
if (fabs (y / x) < sqrt (20.0) * GSL_SQRT_DBL_EPSILON)
{
gsl_vector_view c_full = gsl_matrix_row (A, j);
gsl_vector_view c =
gsl_vector_subvector(&c_full.vector,
i+1, M - (i+1));
y = gsl_blas_dnrm2 (&c.vector);
}
gsl_vector_set (norm, j, y);
}
}
}
}
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;
}
int
gsl_eigen_genv_sort (gsl_vector_complex * alpha, gsl_vector * beta,
gsl_matrix_complex * evec, gsl_eigen_sort_t sort_type)
{
if (evec->size1 != evec->size2)
{
GSL_ERROR ("eigenvector matrix must be square", GSL_ENOTSQR);
}
else if (alpha->size != evec->size1 || beta->size != evec->size1)
{
GSL_ERROR ("eigenvalues must match eigenvector matrix", GSL_EBADLEN);
}
else
{
const size_t N = alpha->size;
size_t i;
for (i = 0; i < N - 1; i++)
{
size_t j;
size_t k = i;
gsl_complex ak = gsl_vector_complex_get (alpha, i);
double bk = gsl_vector_get(beta, i);
gsl_complex ek;
if (bk < GSL_DBL_EPSILON)
{
GSL_SET_COMPLEX(&ek,
GSL_SIGN(GSL_REAL(ak)) ? GSL_POSINF : GSL_NEGINF,
GSL_SIGN(GSL_IMAG(ak)) ? GSL_POSINF : GSL_NEGINF);
}
else
ek = gsl_complex_div_real(ak, bk);
/* search for something to swap */
for (j = i + 1; j < N; j++)
{
int test;
const gsl_complex aj = gsl_vector_complex_get (alpha, j);
double bj = gsl_vector_get(beta, j);
gsl_complex ej;
if (bj < GSL_DBL_EPSILON)
{
GSL_SET_COMPLEX(&ej,
GSL_SIGN(GSL_REAL(aj)) ? GSL_POSINF : GSL_NEGINF,
GSL_SIGN(GSL_IMAG(aj)) ? GSL_POSINF : GSL_NEGINF);
}
else
ej = gsl_complex_div_real(aj, bj);
switch (sort_type)
{
case GSL_EIGEN_SORT_ABS_ASC:
test = (gsl_complex_abs (ej) < gsl_complex_abs (ek));
break;
case GSL_EIGEN_SORT_ABS_DESC:
test = (gsl_complex_abs (ej) > gsl_complex_abs (ek));
break;
case GSL_EIGEN_SORT_VAL_ASC:
case GSL_EIGEN_SORT_VAL_DESC:
default:
GSL_ERROR ("invalid sort type", GSL_EINVAL);
}
if (test)
{
k = j;
ek = ej;
}
}
if (k != i)
{
/* swap eigenvalues */
gsl_vector_complex_swap_elements (alpha, i, k);
gsl_vector_swap_elements (beta, i, k);
/* swap eigenvectors */
gsl_matrix_complex_swap_columns (evec, i, k);
}
}
return GSL_SUCCESS;
}
}
int
gsl_eigen_symmv_sort (gsl_vector * eval, gsl_matrix * evec,
gsl_eigen_sort_t sort_type)
{
if (evec->size1 != evec->size2)
{
GSL_ERROR ("eigenvector matrix must be square", GSL_ENOTSQR);
}
else if (eval->size != evec->size1)
{
GSL_ERROR ("eigenvalues must match eigenvector matrix", GSL_EBADLEN);
}
else
{
const size_t N = eval->size;
size_t i;
for (i = 0; i < N - 1; i++)
{
size_t j;
size_t k = i;
double ek = gsl_vector_get (eval, i);
/* search for something to swap */
for (j = i + 1; j < N; j++)
{
int test;
const double ej = gsl_vector_get (eval, j);
switch (sort_type)
{
case GSL_EIGEN_SORT_VAL_ASC:
test = (ej < ek);
break;
case GSL_EIGEN_SORT_VAL_DESC:
test = (ej > ek);
break;
case GSL_EIGEN_SORT_ABS_ASC:
test = (fabs (ej) < fabs (ek));
break;
case GSL_EIGEN_SORT_ABS_DESC:
test = (fabs (ej) > fabs (ek));
break;
default:
GSL_ERROR ("unrecognized sort type", GSL_EINVAL);
}
if (test)
{
k = j;
ek = ej;
}
}
if (k != i)
{
/* swap eigenvalues */
gsl_vector_swap_elements (eval, i, k);
/* swap eigenvectors */
gsl_matrix_swap_columns (evec, i, k);
}
}
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;
}
