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