FLA_Error FLA_Hevd_lv_var4_components( dim_t n_iter_max, FLA_Obj A, FLA_Obj l, dim_t k_accum, dim_t b_alg,
double* dtime_tred, double* dtime_tevd, double* dtime_appq )
{
FLA_Error r_val = FLA_SUCCESS;
FLA_Uplo uplo = FLA_LOWER_TRIANGULAR;
FLA_Datatype dt;
FLA_Datatype dt_real;
FLA_Datatype dt_comp;
FLA_Obj T, r, d, e, G, R, W;
FLA_Obj d0, e0, ls, pu;
dim_t mn_A;
dim_t n_G = k_accum;
double dtime_temp;
mn_A = FLA_Obj_length( A );
dt = FLA_Obj_datatype( A );
dt_real = FLA_Obj_datatype_proj_to_real( A );
dt_comp = FLA_Obj_datatype_proj_to_complex( A );
*dtime_tred = 1;
*dtime_tevd = 1;
*dtime_appq = 1;
// If the matrix is a scalar, then the EVD is easy.
if ( mn_A == 1 )
{
FLA_Copy( A, l );
FLA_Set( FLA_ONE, A );
return FLA_SUCCESS;
}
// Create a matrix to hold block Householder transformations.
FLA_Tridiag_UT_create_T( A, &T );
// Create a vector to hold the realifying scalars.
FLA_Obj_create( dt, mn_A, 1, 0, 0, &r );
// Create vectors to hold the diagonal and sub-diagonal.
FLA_Obj_create( dt_real, mn_A, 1, 0, 0, &d );
FLA_Obj_create( dt_real, mn_A-1, 1, 0, 0, &e );
FLA_Obj_create( dt_real, mn_A, 1, 0, 0, &d0 );
FLA_Obj_create( dt_real, mn_A-1, 1, 0, 0, &e0 );
FLA_Obj_create( dt_real, mn_A, 1, 0, 0, &pu );
FLA_Obj_create( FLA_INT, mn_A, 1, 0, 0, &ls );
FLA_Obj_create( dt_comp, mn_A-1, n_G, 0, 0, &G );
FLA_Obj_create( dt_real, mn_A, mn_A, 0, 0, &R );
FLA_Obj_create( dt, mn_A, mn_A, 0, 0, &W );
dtime_temp = FLA_Clock();
{
// Reduce the matrix to tridiagonal form.
FLA_Tridiag_UT( uplo, A, T );
}
*dtime_tred = FLA_Clock() - dtime_temp;
// Apply scalars to rotate elements on the sub-diagonal to the real domain.
FLA_Tridiag_UT_realify( uplo, A, r );
// Extract the diagonal and sub-diagonal from A.
FLA_Tridiag_UT_extract_diagonals( uplo, A, d, e );
dtime_temp = FLA_Clock();
{
// Form Q, overwriting A.
FLA_Tridiag_UT_form_Q( uplo, A, T );
}
*dtime_appq = FLA_Clock() - dtime_temp;
// Apply the scalars in r to Q.
FLA_Apply_diag_matrix( FLA_RIGHT, FLA_CONJUGATE, r, A );
// Find the eigenvalues only.
FLA_Copy( d, d0 ); FLA_Copy( e, e0 );
//r_val = FLA_Tevd_n_opt_var1( n_iter_max, d0, e0, G, A );
{
int info;
double* buff_d = FLA_DOUBLE_PTR( d0 );
double* buff_e = FLA_DOUBLE_PTR( e0 );
dsterf_( &mn_A, buff_d, buff_e, &info );
}
FLA_Sort( FLA_FORWARD, d0 );
FLA_Set( FLA_ZERO, ls );
FLA_Set( FLA_ZERO, pu );
dtime_temp = FLA_Clock();
{
// Perform an eigenvalue decomposition on the tridiagonal matrix.
r_val = FLA_Tevd_v_opt_var4( n_iter_max, d, e, d0, ls, pu, G, R, W, A, b_alg );
}
*dtime_tevd = FLA_Clock() - dtime_temp;
// Copy the converged eigenvalues to the output vector.
FLA_Copy( d, l );
// Sort the eigenvalues and eigenvectors in ascending order.
FLA_Sort_evd( FLA_FORWARD, l, A );
FLA_Obj_free( &T );
FLA_Obj_free( &r );
FLA_Obj_free( &d );
FLA_Obj_free( &e );
FLA_Obj_free( &d0 );
FLA_Obj_free( &pu );
FLA_Obj_free( &e0 );
FLA_Obj_free( &ls );
FLA_Obj_free( &G );
FLA_Obj_free( &R );
FLA_Obj_free( &W );
return r_val;
}
// According to the sorted order of a given vector s,
// U and V are reordered in columns while C is reordered
// in rows when they need to be applied.
FLA_Error FLA_Sort_bsvd_ext( FLA_Direct direct, FLA_Obj s,
FLA_Bool apply_U, FLA_Obj U,
FLA_Bool apply_V, FLA_Obj V,
FLA_Bool apply_C, FLA_Obj C )
{
FLA_Datatype datatype;
dim_t m_U, rs_U, cs_U;
dim_t m_V, rs_V, cs_V;
dim_t n_C, rs_C, cs_C;
dim_t m_s, inc_s;
//if ( FLA_Check_error_level() >= FLA_MIN_ERROR_CHECKING )
// FLA_Sort_bsvd_check( direct, s,
// apply_U, U,
// apply_V, V,
// apply_C, C );
// Sort singular values only; quick sort
if ( apply_U == FALSE && apply_V == FALSE )
return FLA_Sort( direct, s );
// s dimensions must be provided.
m_s = FLA_Obj_vector_dim( s );
inc_s = FLA_Obj_vector_inc( s );
// Datatype of U, V and C must be consistent and must be defined from one of them.
FLA_SORT_BSVD_EXT_DEFINE_OBJ_VARIABLES( U, apply_U, datatype, m_U, FLA_Obj_length, rs_U, cs_U );
FLA_SORT_BSVD_EXT_DEFINE_OBJ_VARIABLES( V, apply_V, datatype, m_V, FLA_Obj_length, rs_V, cs_V );
FLA_SORT_BSVD_EXT_DEFINE_OBJ_VARIABLES( C, apply_C, datatype, n_C, FLA_Obj_width, rs_C, cs_C );
switch ( datatype )
{
case FLA_FLOAT:
{
float* s_p = ( float* ) FLA_FLOAT_PTR( s );
float* U_p = ( apply_U == TRUE ? ( float* ) FLA_FLOAT_PTR( U ) : NULL );
float* V_p = ( apply_V == TRUE ? ( float* ) FLA_FLOAT_PTR( V ) : NULL );
float* C_p = ( apply_C == TRUE ? ( float* ) FLA_FLOAT_PTR( C ) : NULL );
if ( direct == FLA_FORWARD )
FLA_Sort_bsvd_ext_f_ops( m_s, s_p, inc_s,
m_U, U_p, rs_U, cs_U,
m_V, V_p, rs_V, cs_V,
n_C, C_p, rs_C, cs_C );
else // if ( direct == FLA_BACKWARD )
FLA_Sort_bsvd_ext_b_ops( m_s, s_p, inc_s,
m_U, U_p, rs_U, cs_U,
m_V, V_p, rs_V, cs_V,
n_C, C_p, rs_C, cs_C );
break;
}
case FLA_DOUBLE:
{
double* s_p = ( double* ) FLA_DOUBLE_PTR( s );
double* U_p = ( apply_U == TRUE ? ( double* ) FLA_DOUBLE_PTR( U ) : NULL );
double* V_p = ( apply_V == TRUE ? ( double* ) FLA_DOUBLE_PTR( V ) : NULL );
double* C_p = ( apply_C == TRUE ? ( double* ) FLA_DOUBLE_PTR( C ) : NULL );
if ( direct == FLA_FORWARD )
FLA_Sort_bsvd_ext_f_opd( m_s, s_p, inc_s,
m_U, U_p, rs_U, cs_U,
m_V, V_p, rs_V, cs_V,
n_C, C_p, rs_C, cs_C );
else // if ( direct == FLA_BACKWARD )
FLA_Sort_bsvd_ext_b_opd( m_s, s_p, inc_s,
m_U, U_p, rs_U, cs_U,
m_V, V_p, rs_V, cs_V,
n_C, C_p, rs_C, cs_C );
break;
}
case FLA_COMPLEX:
{
float* s_p = ( float* ) FLA_FLOAT_PTR( s );
scomplex* U_p = ( apply_U == TRUE ? ( scomplex* ) FLA_COMPLEX_PTR( U ) : NULL );
scomplex* V_p = ( apply_V == TRUE ? ( scomplex* ) FLA_COMPLEX_PTR( V ) : NULL );
scomplex* C_p = ( apply_C == TRUE ? ( scomplex* ) FLA_COMPLEX_PTR( C ) : NULL );
if ( direct == FLA_FORWARD )
FLA_Sort_bsvd_ext_f_opc( m_s, s_p, inc_s,
m_U, U_p, rs_U, cs_U,
m_V, V_p, rs_V, cs_V,
n_C, C_p, rs_C, cs_C );
else // if ( direct == FLA_BACKWARD )
FLA_Sort_bsvd_ext_b_opc( m_s, s_p, inc_s,
m_U, U_p, rs_U, cs_U,
m_V, V_p, rs_V, cs_V,
n_C, C_p, rs_C, cs_C );
break;
}
case FLA_DOUBLE_COMPLEX:
{
double* s_p = ( double* ) FLA_DOUBLE_PTR( s );
dcomplex* U_p = ( apply_U == TRUE ? ( dcomplex* ) FLA_DOUBLE_COMPLEX_PTR( U ) : NULL );
dcomplex* V_p = ( apply_V == TRUE ? ( dcomplex* ) FLA_DOUBLE_COMPLEX_PTR( V ) : NULL );
dcomplex* C_p = ( apply_C == TRUE ? ( dcomplex* ) FLA_DOUBLE_COMPLEX_PTR( C ) : NULL );
if ( direct == FLA_FORWARD )
FLA_Sort_bsvd_ext_f_opz( m_s, s_p, inc_s,
m_U, U_p, rs_U, cs_U,
m_V, V_p, rs_V, cs_V,
n_C, C_p, rs_C, cs_C );
else // if ( direct == FLA_BACKWARD )
FLA_Sort_bsvd_ext_b_opz( m_s, s_p, inc_s,
m_U, U_p, rs_U, cs_U,
m_V, V_p, rs_V, cs_V,
n_C, C_p, rs_C, cs_C );
break;
}
}
return FLA_SUCCESS;
}
