CAMLprim value ml_gsl_linalg_bidiag_unpack2(value A, value TAU_U, value TAU_V, value V)
{
_DECLARE_MATRIX2(A, V);
_DECLARE_VECTOR2(TAU_U, TAU_V);
_CONVERT_MATRIX2(A, V);
_CONVERT_VECTOR2(TAU_U, TAU_V);
gsl_linalg_bidiag_unpack2(&m_A, &v_TAU_U, &v_TAU_V, &m_V);
return Val_unit;
}
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;
}
/**
* C++ version of gsl_linalg_bidiag_unpack2().
* @param A A matrix
* @param tau_U A vector
* @param tau_V A vector
* @param V AN orthogonal matrix
* @return Error code on failure
*/
inline int bidiag_unpack2( matrix& A, vector& tau_U, vector& tau_V, matrix& V ){
return gsl_linalg_bidiag_unpack2( A.get(), tau_U.get(), tau_V.get(), V.get() ); }
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;
}
