FLA_Error FLA_Tevd_eigval_v_opt_var1( FLA_Obj G, FLA_Obj d, FLA_Obj e, FLA_Obj k )
{
FLA_Datatype datatype;
int m_A, n_G;
int rs_G, cs_G;
int inc_d;
int inc_e;
datatype = FLA_Obj_datatype( d );
m_A = FLA_Obj_vector_dim( d );
n_G = FLA_Obj_width( G );
rs_G = FLA_Obj_row_stride( G );
cs_G = FLA_Obj_col_stride( G );
inc_d = FLA_Obj_vector_inc( d );
inc_e = FLA_Obj_vector_inc( e );
switch ( datatype )
{
case FLA_FLOAT:
{
scomplex* buff_G = FLA_COMPLEX_PTR( G );
float* buff_d = FLA_FLOAT_PTR( d );
float* buff_e = FLA_FLOAT_PTR( e );
int* buff_k = FLA_INT_PTR( k );
FLA_Tevd_eigval_v_ops_var1( m_A,
n_G,
buff_G, rs_G, cs_G,
buff_d, inc_d,
buff_e, inc_e,
buff_k );
break;
}
case FLA_DOUBLE:
{
dcomplex* buff_G = FLA_DOUBLE_COMPLEX_PTR( G );
double* buff_d = FLA_DOUBLE_PTR( d );
double* buff_e = FLA_DOUBLE_PTR( e );
int* buff_k = FLA_INT_PTR( k );
FLA_Tevd_eigval_v_opd_var1( m_A,
n_G,
buff_G, rs_G, cs_G,
buff_d, inc_d,
buff_e, inc_e,
buff_k );
break;
}
}
return FLA_SUCCESS;
}
FLA_Error FLA_Obj_create_complex_constant( double const_real, double const_imag, FLA_Obj *obj )
{
int* temp_i;
float* temp_s;
double* temp_d;
scomplex* temp_c;
dcomplex* temp_z;
if ( FLA_Check_error_level() >= FLA_MIN_ERROR_CHECKING )
FLA_Obj_create_complex_constant_check( const_real, const_imag, obj );
FLA_Obj_create( FLA_CONSTANT, 1, 1, 0, 0, obj );
#ifdef FLA_ENABLE_SCC
if ( !FLA_is_owner() )
return FLA_SUCCESS;
#endif
temp_i = FLA_INT_PTR( *obj );
temp_s = FLA_FLOAT_PTR( *obj );
temp_d = FLA_DOUBLE_PTR( *obj );
temp_c = FLA_COMPLEX_PTR( *obj );
temp_z = FLA_DOUBLE_COMPLEX_PTR( *obj );
*temp_i = ( int ) const_real;
*temp_s = ( float ) const_real;
*temp_d = const_real;
temp_c->real = ( float ) const_real;
temp_c->imag = ( float ) const_imag;
temp_z->real = const_real;
temp_z->imag = const_imag;
return FLA_SUCCESS;
}
FLA_Bool FLA_Obj_le( FLA_Obj A, FLA_Obj B )
{
FLA_Datatype datatype_A;
FLA_Datatype datatype_B;
FLA_Datatype datatype;
if ( FLA_Check_error_level() >= FLA_MIN_ERROR_CHECKING )
FLA_Obj_le_check( A, B );
datatype_A = FLA_Obj_datatype( A );
datatype_B = FLA_Obj_datatype( B );
if ( datatype_A != FLA_CONSTANT ) datatype = datatype_A;
else datatype = datatype_B;
switch ( datatype )
{
case FLA_CONSTANT:
{
// We require ALL floating-point fields to be the same.
float* buffs_A = ( float * ) FLA_FLOAT_PTR( A );
float* buffs_B = ( float * ) FLA_FLOAT_PTR( B );
double* buffd_A = ( double * ) FLA_DOUBLE_PTR( A );
double* buffd_B = ( double * ) FLA_DOUBLE_PTR( B );
scomplex* buffc_A = ( scomplex * ) FLA_COMPLEX_PTR( A );
scomplex* buffc_B = ( scomplex * ) FLA_COMPLEX_PTR( B );
dcomplex* buffz_A = ( dcomplex * ) FLA_DOUBLE_COMPLEX_PTR( A );
dcomplex* buffz_B = ( dcomplex * ) FLA_DOUBLE_COMPLEX_PTR( B );
if ( !( *buffs_A <= *buffs_B &&
*buffd_A <= *buffd_B &&
buffc_A->real <= buffc_B->real &&
buffc_A->imag <= buffc_B->imag &&
buffz_A->real <= buffz_B->real &&
buffz_A->imag <= buffz_B->imag ) )
{
return FALSE;
}
break;
}
case FLA_INT:
{
int *buff_A = ( int * ) FLA_INT_PTR( A );
int *buff_B = ( int * ) FLA_INT_PTR( B );
if ( !( *buff_A <= *buff_B ) ) return FALSE;
break;
}
case FLA_FLOAT:
{
float *buff_A = ( float * ) FLA_FLOAT_PTR( A );
float *buff_B = ( float * ) FLA_FLOAT_PTR( B );
if ( !( *buff_A <= *buff_B ) ) return FALSE;
break;
}
case FLA_DOUBLE:
{
double *buff_A = ( double * ) FLA_DOUBLE_PTR( A );
double *buff_B = ( double * ) FLA_DOUBLE_PTR( B );
if ( !( *buff_A <= *buff_B ) ) return FALSE;
break;
}
}
return TRUE;
}
FLA_Bool FLA_Obj_equals( FLA_Obj A, FLA_Obj B )
{
FLA_Datatype datatype_A;
FLA_Datatype datatype_B;
FLA_Datatype datatype;
dim_t m, n;
dim_t rs_A, cs_A;
dim_t rs_B, cs_B;
dim_t i, j;
if ( FLA_Check_error_level() >= FLA_MIN_ERROR_CHECKING )
FLA_Obj_equals_check( A, B );
m = FLA_Obj_length( A );
n = FLA_Obj_width( A );
rs_A = FLA_Obj_row_stride( A );
cs_A = FLA_Obj_col_stride( A );
rs_B = FLA_Obj_row_stride( B );
cs_B = FLA_Obj_col_stride( B );
datatype_A = FLA_Obj_datatype( A );
datatype_B = FLA_Obj_datatype( B );
// If A is a non-FLA_CONSTANT object, then we should proceed based on the
// value of datatype_A. In such a situation, either datatype_B is an exact
// match and we're fine, or datatype_B is FLA_CONSTANT, in which case we're
// also covered since FLA_CONSTANT encompassas all numerical types.
// If A is an FLA_CONSTANT object, then we should proceed based on the value
// of datatype_B. In this case, datatype_B is either a non-FLA_CONSTANT type,
// which mirrors the second sub-case above, or datatype_B is FLA_CONSTANT,
// in which case both types are FLA_CONSTANT and therefore we have to handle
// that case. Only if both are FLA_CONSTANTs does the FLA_CONSTANT case
// statement below execute.
if ( datatype_A != FLA_CONSTANT )
datatype = datatype_A;
else
datatype = datatype_B;
switch ( datatype )
{
case FLA_CONSTANT:
{
// We require ALL floating-point fields to be the same.
float* buffs_A = ( float * ) FLA_FLOAT_PTR( A );
float* buffs_B = ( float * ) FLA_FLOAT_PTR( B );
double* buffd_A = ( double * ) FLA_DOUBLE_PTR( A );
double* buffd_B = ( double * ) FLA_DOUBLE_PTR( B );
scomplex* buffc_A = ( scomplex * ) FLA_COMPLEX_PTR( A );
scomplex* buffc_B = ( scomplex * ) FLA_COMPLEX_PTR( B );
dcomplex* buffz_A = ( dcomplex * ) FLA_DOUBLE_COMPLEX_PTR( A );
dcomplex* buffz_B = ( dcomplex * ) FLA_DOUBLE_COMPLEX_PTR( B );
if ( *buffs_A != *buffs_B ||
*buffd_A != *buffd_B ||
buffc_A->real != buffc_B->real ||
buffc_A->imag != buffc_B->imag ||
buffz_A->real != buffz_B->real ||
buffz_A->imag != buffz_B->imag )
{
return FALSE;
}
break;
}
case FLA_INT:
{
int *buff_A = ( int * ) FLA_INT_PTR( A );
int *buff_B = ( int * ) FLA_INT_PTR( B );
for ( j = 0; j < n; j++ )
for ( i = 0; i < m; i++ )
if ( buff_A[ j * cs_A + i * rs_A ] !=
buff_B[ j * cs_B + i * rs_B ] )
{
return FALSE;
}
break;
}
case FLA_FLOAT:
{
float *buff_A = ( float * ) FLA_FLOAT_PTR( A );
float *buff_B = ( float * ) FLA_FLOAT_PTR( B );
for ( j = 0; j < n; j++ )
for ( i = 0; i < m; i++ )
if ( buff_A[ j * cs_A + i * rs_A ] !=
buff_B[ j * cs_B + i * rs_B ] )
{
return FALSE;
}
break;
}
case FLA_DOUBLE:
{
double *buff_A = ( double * ) FLA_DOUBLE_PTR( A );
double *buff_B = ( double * ) FLA_DOUBLE_PTR( B );
for ( j = 0; j < n; j++ )
for ( i = 0; i < m; i++ )
if ( buff_A[ j * cs_A + i * rs_A ] !=
buff_B[ j * cs_B + i * rs_B ] )
{
return FALSE;
}
break;
}
case FLA_COMPLEX:
{
scomplex *buff_A = ( scomplex * ) FLA_COMPLEX_PTR( A );
scomplex *buff_B = ( scomplex * ) FLA_COMPLEX_PTR( B );
for ( j = 0; j < n; j++ )
for ( i = 0; i < m; i++ )
if ( buff_A[ j * cs_A + i * rs_A ].real != buff_B[ j * cs_B + i * rs_B ].real ||
buff_A[ j * cs_A + i * rs_A ].imag != buff_B[ j * cs_B + i * rs_B ].imag )
{
return FALSE;
}
break;
}
case FLA_DOUBLE_COMPLEX:
{
dcomplex *buff_A = ( dcomplex * ) FLA_DOUBLE_COMPLEX_PTR( A );
dcomplex *buff_B = ( dcomplex * ) FLA_DOUBLE_COMPLEX_PTR( B );
for ( j = 0; j < n; j++ )
for ( i = 0; i < m; i++ )
if ( buff_A[ j * cs_A + i * rs_A ].real != buff_B[ j * cs_B + i * rs_B ].real ||
buff_A[ j * cs_A + i * rs_A ].imag != buff_B[ j * cs_B + i * rs_B ].imag )
{
return FALSE;
}
break;
}
}
return TRUE;
}
FLA_Error FLA_LU_piv_opt_var5( FLA_Obj A, FLA_Obj p )
{
FLA_Error r_val = FLA_SUCCESS;
FLA_Datatype datatype;
int m_A, n_A;
int rs_A, cs_A;
int inc_p;
datatype = FLA_Obj_datatype( A );
m_A = FLA_Obj_length( A );
n_A = FLA_Obj_width( A );
rs_A = FLA_Obj_row_stride( A );
cs_A = FLA_Obj_col_stride( A );
inc_p = FLA_Obj_vector_inc( p );
switch ( datatype )
{
case FLA_FLOAT:
{
float* buff_A = FLA_FLOAT_PTR( A );
int* buff_p = FLA_INT_PTR( p );
r_val = FLA_LU_piv_ops_var5( m_A,
n_A,
buff_A, rs_A, cs_A,
buff_p, inc_p );
break;
}
case FLA_DOUBLE:
{
double* buff_A = FLA_DOUBLE_PTR( A );
int* buff_p = FLA_INT_PTR( p );
r_val = FLA_LU_piv_opd_var5( m_A,
n_A,
buff_A, rs_A, cs_A,
buff_p, inc_p );
break;
}
case FLA_COMPLEX:
{
scomplex* buff_A = FLA_COMPLEX_PTR( A );
int* buff_p = FLA_INT_PTR( p );
r_val = FLA_LU_piv_opc_var5( m_A,
n_A,
buff_A, rs_A, cs_A,
buff_p, inc_p );
break;
}
case FLA_DOUBLE_COMPLEX:
{
dcomplex* buff_A = FLA_DOUBLE_COMPLEX_PTR( A );
int* buff_p = FLA_INT_PTR( p );
r_val = FLA_LU_piv_opz_var5( m_A,
n_A,
buff_A, rs_A, cs_A,
buff_p, inc_p );
break;
}
}
return r_val;
}
FLA_Error FLA_Copy_external( FLA_Obj A, FLA_Obj B )
{
FLA_Datatype dt_A;
FLA_Datatype dt_B;
int m_B, n_B;
int rs_A, cs_A;
int rs_B, cs_B;
trans_t blis_trans;
if ( FLA_Check_error_level() == FLA_FULL_ERROR_CHECKING )
FLA_Copy_check( A, B );
if ( FLA_Obj_has_zero_dim( A ) ) return FLA_SUCCESS;
dt_A = FLA_Obj_datatype( A );
dt_B = FLA_Obj_datatype( B );
rs_A = FLA_Obj_row_stride( A );
cs_A = FLA_Obj_col_stride( A );
m_B = FLA_Obj_length( B );
n_B = FLA_Obj_width( B );
rs_B = FLA_Obj_row_stride( B );
cs_B = FLA_Obj_col_stride( B );
if ( FLA_Obj_is_conformal_to( FLA_NO_TRANSPOSE, A, B ) )
FLA_Param_map_flame_to_blis_trans( FLA_NO_TRANSPOSE, &blis_trans );
else // if ( FLA_Obj_is_conformal_to( FLA_TRANSPOSE, A, B ) )
FLA_Param_map_flame_to_blis_trans( FLA_TRANSPOSE, &blis_trans );
// If A is of type FLA_CONSTANT, then we have to proceed based on the
// datatype of B.
if ( dt_A == FLA_CONSTANT )
{
if ( dt_B == FLA_FLOAT )
{
float *buff_A = ( float * ) FLA_FLOAT_PTR( A );
float *buff_B = ( float * ) FLA_FLOAT_PTR( B );
bli_scopymt( blis_trans,
m_B,
n_B,
buff_A, rs_A, cs_A,
buff_B, rs_B, cs_B );
}
else if ( dt_B == FLA_DOUBLE )
{
double *buff_A = ( double * ) FLA_DOUBLE_PTR( A );
double *buff_B = ( double * ) FLA_DOUBLE_PTR( B );
bli_dcopymt( blis_trans,
m_B,
n_B,
buff_A, rs_A, cs_A,
buff_B, rs_B, cs_B );
}
else if ( dt_B == FLA_COMPLEX )
{
scomplex *buff_A = ( scomplex * ) FLA_COMPLEX_PTR( A );
scomplex *buff_B = ( scomplex * ) FLA_COMPLEX_PTR( B );
bli_ccopymt( blis_trans,
m_B,
n_B,
buff_A, rs_A, cs_A,
buff_B, rs_B, cs_B );
}
else if ( dt_B == FLA_DOUBLE_COMPLEX )
{
dcomplex *buff_A = ( dcomplex * ) FLA_DOUBLE_COMPLEX_PTR( A );
dcomplex *buff_B = ( dcomplex * ) FLA_DOUBLE_COMPLEX_PTR( B );
bli_zcopymt( blis_trans,
m_B,
n_B,
buff_A, rs_A, cs_A,
buff_B, rs_B, cs_B );
}
}
else if ( dt_A == FLA_INT )
{
int* buff_A = ( int * ) FLA_INT_PTR( A );
int* buff_B = ( int * ) FLA_INT_PTR( B );
bli_icopymt( blis_trans,
m_B,
n_B,
buff_A, rs_A, cs_A,
buff_B, rs_B, cs_B );
}
else if ( dt_A == FLA_FLOAT )
{
float *buff_A = ( float * ) FLA_FLOAT_PTR( A );
if ( dt_B == FLA_FLOAT )
{
float *buff_B = ( float * ) FLA_FLOAT_PTR( B );
bli_scopymt( blis_trans,
m_B,
n_B,
buff_A, rs_A, cs_A,
buff_B, rs_B, cs_B );
}
else if ( dt_B == FLA_DOUBLE )
{
double *buff_B = ( double * ) FLA_DOUBLE_PTR( B );
bli_sdcopymt( blis_trans,
m_B,
n_B,
buff_A, rs_A, cs_A,
buff_B, rs_B, cs_B );
}
else if ( dt_B == FLA_COMPLEX )
{
scomplex *buff_B = ( scomplex * ) FLA_COMPLEX_PTR( B );
bli_sccopymt( blis_trans,
m_B,
n_B,
buff_A, rs_A, cs_A,
buff_B, rs_B, cs_B );
}
else if ( dt_B == FLA_DOUBLE_COMPLEX )
{
dcomplex *buff_B = ( dcomplex * ) FLA_DOUBLE_COMPLEX_PTR( B );
bli_szcopymt( blis_trans,
m_B,
n_B,
buff_A, rs_A, cs_A,
buff_B, rs_B, cs_B );
}
}
else if ( dt_A == FLA_DOUBLE )
{
double *buff_A = ( double * ) FLA_DOUBLE_PTR( A );
if ( dt_B == FLA_FLOAT )
{
float *buff_B = ( float * ) FLA_FLOAT_PTR( B );
bli_dscopymt( blis_trans,
m_B,
n_B,
buff_A, rs_A, cs_A,
buff_B, rs_B, cs_B );
}
else if ( dt_B == FLA_DOUBLE )
{
double *buff_B = ( double * ) FLA_DOUBLE_PTR( B );
bli_dcopymt( blis_trans,
m_B,
n_B,
buff_A, rs_A, cs_A,
buff_B, rs_B, cs_B );
}
else if ( dt_B == FLA_COMPLEX )
{
scomplex *buff_B = ( scomplex * ) FLA_COMPLEX_PTR( B );
bli_dccopymt( blis_trans,
m_B,
n_B,
buff_A, rs_A, cs_A,
buff_B, rs_B, cs_B );
}
else if ( dt_B == FLA_DOUBLE_COMPLEX )
{
dcomplex *buff_B = ( dcomplex * ) FLA_DOUBLE_COMPLEX_PTR( B );
bli_dzcopymt( blis_trans,
m_B,
n_B,
buff_A, rs_A, cs_A,
buff_B, rs_B, cs_B );
}
}
else if ( dt_A == FLA_COMPLEX )
{
scomplex *buff_A = ( scomplex * ) FLA_COMPLEX_PTR( A );
if ( dt_B == FLA_FLOAT )
{
float *buff_B = ( float * ) FLA_FLOAT_PTR( B );
bli_cscopymt( blis_trans,
m_B,
n_B,
buff_A, rs_A, cs_A,
buff_B, rs_B, cs_B );
}
else if ( dt_B == FLA_DOUBLE )
{
double *buff_B = ( double * ) FLA_DOUBLE_PTR( B );
bli_cdcopymt( blis_trans,
m_B,
n_B,
buff_A, rs_A, cs_A,
buff_B, rs_B, cs_B );
}
else if ( dt_B == FLA_COMPLEX )
{
scomplex *buff_B = ( scomplex * ) FLA_COMPLEX_PTR( B );
bli_ccopymt( blis_trans,
m_B,
n_B,
buff_A, rs_A, cs_A,
buff_B, rs_B, cs_B );
}
else if ( dt_B == FLA_DOUBLE_COMPLEX )
{
dcomplex *buff_B = ( dcomplex * ) FLA_DOUBLE_COMPLEX_PTR( B );
bli_czcopymt( blis_trans,
m_B,
n_B,
buff_A, rs_A, cs_A,
buff_B, rs_B, cs_B );
}
}
else if ( dt_A == FLA_DOUBLE_COMPLEX )
{
dcomplex *buff_A = ( dcomplex * ) FLA_DOUBLE_COMPLEX_PTR( A );
if ( dt_B == FLA_FLOAT )
{
float *buff_B = ( float * ) FLA_FLOAT_PTR( B );
bli_zscopymt( blis_trans,
m_B,
n_B,
buff_A, rs_A, cs_A,
buff_B, rs_B, cs_B );
}
else if ( dt_B == FLA_DOUBLE )
{
double *buff_B = ( double * ) FLA_DOUBLE_PTR( B );
bli_zdcopymt( blis_trans,
m_B,
n_B,
buff_A, rs_A, cs_A,
buff_B, rs_B, cs_B );
}
else if ( dt_B == FLA_COMPLEX )
{
scomplex *buff_B = ( scomplex * ) FLA_COMPLEX_PTR( B );
bli_zccopymt( blis_trans,
m_B,
n_B,
buff_A, rs_A, cs_A,
buff_B, rs_B, cs_B );
}
else if ( dt_B == FLA_DOUBLE_COMPLEX )
{
dcomplex *buff_B = ( dcomplex * ) FLA_DOUBLE_COMPLEX_PTR( B );
bli_zcopymt( blis_trans,
m_B,
n_B,
buff_A, rs_A, cs_A,
buff_B, rs_B, cs_B );
}
}
return FLA_SUCCESS;
}
FLA_Error FLA_Apply_pivots_rt_opt_var1( FLA_Obj p, FLA_Obj A )
{
FLA_Datatype datatype;
int m_A;
int rs_A, cs_A;
int inc_p;
int k1_0, k2_0;
datatype = FLA_Obj_datatype( A );
m_A = FLA_Obj_length( A );
// Swap the stride; FLA_Apply_pivots_ln_ops_var1 already consider the memory access pattern.
cs_A = FLA_Obj_row_stride( A );
rs_A = FLA_Obj_col_stride( A );
// Use minus increment of the ln version.
inc_p = FLA_Obj_vector_inc( p );
// Use zero-based indices.
k1_0 = 0;
k2_0 = ( int ) FLA_Obj_vector_dim( p ) - 1;
switch ( datatype )
{
case FLA_INT:
{
int* buff_A = FLA_INT_PTR( A );
int* buff_p = FLA_INT_PTR( p );
FLA_Apply_pivots_ln_opi_var1( m_A,
buff_A, rs_A, cs_A,
k1_0,
k2_0,
buff_p, inc_p );
break;
}
case FLA_FLOAT:
{
float* buff_A = FLA_FLOAT_PTR( A );
int* buff_p = FLA_INT_PTR( p );
FLA_Apply_pivots_ln_ops_var1( m_A,
buff_A, rs_A, cs_A,
k1_0,
k2_0,
buff_p, inc_p );
break;
}
case FLA_DOUBLE:
{
double* buff_A = FLA_DOUBLE_PTR( A );
int* buff_p = FLA_INT_PTR( p );
FLA_Apply_pivots_ln_opd_var1( m_A,
buff_A, rs_A, cs_A,
k1_0,
k2_0,
buff_p, inc_p );
break;
}
case FLA_COMPLEX:
{
scomplex* buff_A = FLA_COMPLEX_PTR( A );
int* buff_p = FLA_INT_PTR( p );
FLA_Apply_pivots_ln_opc_var1( m_A,
buff_A, rs_A, cs_A,
k1_0,
k2_0,
buff_p, inc_p );
break;
}
case FLA_DOUBLE_COMPLEX:
{
dcomplex* buff_A = FLA_DOUBLE_COMPLEX_PTR( A );
int* buff_p = FLA_INT_PTR( p );
FLA_Apply_pivots_ln_opz_var1( m_A,
buff_A, rs_A, cs_A,
k1_0,
k2_0,
buff_p, inc_p );
break;
}
}
return FLA_SUCCESS;
}
FLA_Error FLA_Set_diag( FLA_Obj alpha, FLA_Obj A )
{
FLA_Datatype datatype;
int m_A, n_A;
int rs_A, cs_A;
if ( FLA_Check_error_level() >= FLA_MIN_ERROR_CHECKING )
FLA_Set_diag_check( alpha, A );
datatype = FLA_Obj_datatype( A );
m_A = FLA_Obj_length( A );
n_A = FLA_Obj_width( A );
rs_A = FLA_Obj_row_stride( A );
cs_A = FLA_Obj_col_stride( A );
switch ( datatype ){
case FLA_INT:
{
int *buff_A = ( int * ) FLA_INT_PTR( A );
int *buff_alpha = ( int * ) FLA_INT_PTR( alpha );
bli_isetdiag( 0,
m_A,
n_A,
buff_alpha,
buff_A, rs_A, cs_A );
break;
}
case FLA_FLOAT:
{
float *buff_A = ( float * ) FLA_FLOAT_PTR( A );
float *buff_alpha = ( float * ) FLA_FLOAT_PTR( alpha );
bli_ssetdiag( 0,
m_A,
n_A,
buff_alpha,
buff_A, rs_A, cs_A );
break;
}
case FLA_DOUBLE:
{
double *buff_A = ( double * ) FLA_DOUBLE_PTR( A );
double *buff_alpha = ( double * ) FLA_DOUBLE_PTR( alpha );
bli_dsetdiag( 0,
m_A,
n_A,
buff_alpha,
buff_A, rs_A, cs_A );
break;
}
case FLA_COMPLEX:
{
scomplex *buff_A = ( scomplex * ) FLA_COMPLEX_PTR( A );
scomplex *buff_alpha = ( scomplex * ) FLA_COMPLEX_PTR( alpha );
bli_csetdiag( 0,
m_A,
n_A,
buff_alpha,
buff_A, rs_A, cs_A );
break;
}
case FLA_DOUBLE_COMPLEX:
{
dcomplex *buff_A = ( dcomplex * ) FLA_DOUBLE_COMPLEX_PTR( A );
dcomplex *buff_alpha = ( dcomplex * ) FLA_DOUBLE_COMPLEX_PTR( alpha );
bli_zsetdiag( 0,
m_A,
n_A,
buff_alpha,
buff_A, rs_A, cs_A );
break;
}
}
return FLA_SUCCESS;
}
FLA_Error FLA_Sylv_nh_opt_var1( FLA_Obj isgn, FLA_Obj A, FLA_Obj B, FLA_Obj C, FLA_Obj scale )
{
FLA_Datatype datatype;
int m_C, n_C;
int rs_A, cs_A;
int rs_B, cs_B;
int rs_C, cs_C;
int info;
datatype = FLA_Obj_datatype( A );
rs_A = FLA_Obj_row_stride( A );
cs_A = FLA_Obj_col_stride( A );
rs_B = FLA_Obj_row_stride( B );
cs_B = FLA_Obj_col_stride( B );
m_C = FLA_Obj_length( C );
n_C = FLA_Obj_width( C );
rs_C = FLA_Obj_row_stride( C );
cs_C = FLA_Obj_col_stride( C );
switch ( datatype )
{
case FLA_FLOAT:
{
int* buff_isgn = FLA_INT_PTR( isgn );
float* buff_A = FLA_FLOAT_PTR( A );
float* buff_B = FLA_FLOAT_PTR( B );
float* buff_C = FLA_FLOAT_PTR( C );
float* buff_scale = FLA_FLOAT_PTR( scale );
float sgn = ( float ) *buff_isgn;
FLA_Sylv_nh_ops_var1( sgn,
m_C,
n_C,
buff_A, rs_A, cs_A,
buff_B, rs_B, cs_B,
buff_C, rs_C, cs_C,
buff_scale,
&info );
break;
}
case FLA_DOUBLE:
{
int* buff_isgn = FLA_INT_PTR( isgn );
double* buff_A = FLA_DOUBLE_PTR( A );
double* buff_B = FLA_DOUBLE_PTR( B );
double* buff_C = FLA_DOUBLE_PTR( C );
double* buff_scale = FLA_DOUBLE_PTR( scale );
double sgn = ( double ) *buff_isgn;
FLA_Sylv_nh_opd_var1( sgn,
m_C,
n_C,
buff_A, rs_A, cs_A,
buff_B, rs_B, cs_B,
buff_C, rs_C, cs_C,
buff_scale,
&info );
break;
}
case FLA_COMPLEX:
{
int* buff_isgn = FLA_INT_PTR( isgn );
scomplex* buff_A = FLA_COMPLEX_PTR( A );
scomplex* buff_B = FLA_COMPLEX_PTR( B );
scomplex* buff_C = FLA_COMPLEX_PTR( C );
scomplex* buff_scale = FLA_COMPLEX_PTR( scale );
float sgn = ( float ) *buff_isgn;
FLA_Sylv_nh_opc_var1( sgn,
m_C,
n_C,
buff_A, rs_A, cs_A,
buff_B, rs_B, cs_B,
buff_C, rs_C, cs_C,
buff_scale,
&info );
break;
}
case FLA_DOUBLE_COMPLEX:
{
int* buff_isgn = FLA_INT_PTR( isgn );
dcomplex* buff_A = FLA_DOUBLE_COMPLEX_PTR( A );
dcomplex* buff_B = FLA_DOUBLE_COMPLEX_PTR( B );
dcomplex* buff_C = FLA_DOUBLE_COMPLEX_PTR( C );
dcomplex* buff_scale = FLA_DOUBLE_COMPLEX_PTR( scale );
double sgn = ( double ) *buff_isgn;
FLA_Sylv_nh_opz_var1( sgn,
m_C,
n_C,
buff_A, rs_A, cs_A,
buff_B, rs_B, cs_B,
buff_C, rs_C, cs_C,
buff_scale,
&info );
break;
}
}
return FLA_SUCCESS;
}
FLA_Error FLA_Tevdr_external( FLA_Evd_type jobz, FLA_Obj d, FLA_Obj e, FLA_Obj l, FLA_Obj A )
{
int info = 0;
#ifdef FLA_ENABLE_EXTERNAL_LAPACK_INTERFACES
FLA_Datatype datatype;
FLA_Datatype dt_real;
int n_A, cs_A;
int lisuppz, lwork, liwork;
FLA_Obj isuppz, work, iwork;
char blas_jobz;
char blas_range;
int i;
int vl, vu;
int il, iu;
int nzc;
int try_rac;
int n_eig_found;
//if ( FLA_Check_error_level() == FLA_FULL_ERROR_CHECKING )
// FLA_Tevdd_check( jobz, d, e, A );
if ( FLA_Obj_has_zero_dim( A ) ) return FLA_SUCCESS;
datatype = FLA_Obj_datatype( A );
dt_real = FLA_Obj_datatype_proj_to_real( A );
n_A = FLA_Obj_width( A );
cs_A = FLA_Obj_col_stride( A );
FLA_Param_map_flame_to_netlib_evd_type( jobz, &blas_jobz );
// Hard-code some parameters.
blas_range = 'A';
nzc = n_A;
try_rac = TRUE;
// Allocate space for the isuppz array.
lisuppz = 2 * n_A;
FLA_Obj_create( FLA_INT, lisuppz, 1, 0, 0, &isuppz );
// Make a workspace query the first time through. This will provide us with
// and ideal workspace size.
lwork = -1;
liwork = -1;
FLA_Obj_create( dt_real, 1, 1, 0, 0, &work );
FLA_Obj_create( FLA_INT, 1, 1, 0, 0, &iwork );
for ( i = 0; i < 2; ++i )
{
if ( i == 1 )
{
// Grab the queried ideal workspace size from the work arrays, free the
// work object, and then re-allocate the workspace with the ideal size.
if ( datatype == FLA_FLOAT || datatype == FLA_COMPLEX )
{
lwork = ( int ) *FLA_FLOAT_PTR( work );
liwork = ( int ) *FLA_INT_PTR( iwork );
}
else if ( datatype == FLA_DOUBLE || datatype == FLA_DOUBLE_COMPLEX )
{
lwork = ( int ) *FLA_DOUBLE_PTR( work );
liwork = ( int ) *FLA_INT_PTR( iwork );
}
//printf( "ideal workspace for n = %d\n", n_A );
//printf( " lwork = %d\n", lwork );
//printf( " liwork = %d\n", liwork );
FLA_Obj_free( &work );
FLA_Obj_free( &iwork );
FLA_Obj_create( dt_real, lwork, 1, 0, 0, &work );
FLA_Obj_create( FLA_INT, liwork, 1, 0, 0, &iwork );
}
switch( datatype ) {
case FLA_FLOAT:
{
float* buff_d = ( float* ) FLA_FLOAT_PTR( d );
float* buff_e = ( float* ) FLA_FLOAT_PTR( e );
float* buff_l = ( float* ) FLA_FLOAT_PTR( l );
float* buff_A = ( float* ) FLA_FLOAT_PTR( A );
int* buff_isuppz = ( int* ) FLA_INT_PTR( isuppz );
float* buff_work = ( float* ) FLA_FLOAT_PTR( work );
int* buff_iwork = ( int* ) FLA_INT_PTR( iwork );
F77_sstemr( &blas_jobz,
&blas_range,
&n_A,
buff_d,
buff_e,
&vl, &vu,
&il, &iu,
&n_eig_found,
buff_l,
buff_A, &cs_A,
&nzc,
buff_isuppz,
&try_rac,
buff_work, &lwork,
buff_iwork, &liwork,
&info );
break;
}
case FLA_DOUBLE:
{
double* buff_d = ( double* ) FLA_DOUBLE_PTR( d );
double* buff_e = ( double* ) FLA_DOUBLE_PTR( e );
double* buff_l = ( double* ) FLA_DOUBLE_PTR( l );
double* buff_A = ( double* ) FLA_DOUBLE_PTR( A );
int* buff_isuppz = ( int* ) FLA_INT_PTR( isuppz );
double* buff_work = ( double* ) FLA_DOUBLE_PTR( work );
int* buff_iwork = ( int* ) FLA_INT_PTR( iwork );
F77_dstemr( &blas_jobz,
&blas_range,
&n_A,
buff_d,
buff_e,
&vl, &vu,
&il, &iu,
&n_eig_found,
buff_l,
buff_A, &cs_A,
&nzc,
buff_isuppz,
&try_rac,
buff_work, &lwork,
buff_iwork, &liwork,
&info );
break;
}
case FLA_COMPLEX:
{
float* buff_d = ( float* ) FLA_FLOAT_PTR( d );
float* buff_e = ( float* ) FLA_FLOAT_PTR( e );
float* buff_l = ( float* ) FLA_FLOAT_PTR( l );
scomplex* buff_A = ( scomplex* ) FLA_COMPLEX_PTR( A );
int* buff_isuppz = ( int* ) FLA_INT_PTR( isuppz );
float* buff_work = ( float* ) FLA_FLOAT_PTR( work );
int* buff_iwork = ( int* ) FLA_INT_PTR( iwork );
F77_cstemr( &blas_jobz,
&blas_range,
&n_A,
buff_d,
buff_e,
&vl, &vu,
&il, &iu,
&n_eig_found,
buff_l,
buff_A, &cs_A,
&nzc,
buff_isuppz,
&try_rac,
buff_work, &lwork,
buff_iwork, &liwork,
&info );
break;
}
case FLA_DOUBLE_COMPLEX:
{
double* buff_d = ( double* ) FLA_DOUBLE_PTR( d );
double* buff_e = ( double* ) FLA_DOUBLE_PTR( e );
double* buff_l = ( double* ) FLA_DOUBLE_PTR( l );
dcomplex* buff_A = ( dcomplex* ) FLA_DOUBLE_COMPLEX_PTR( A );
int* buff_isuppz = ( int* ) FLA_INT_PTR( isuppz );
double* buff_work = ( double* ) FLA_DOUBLE_PTR( work );
int* buff_iwork = ( int* ) FLA_INT_PTR( iwork );
F77_zstemr( &blas_jobz,
&blas_range,
&n_A,
buff_d,
buff_e,
&vl, &vu,
&il, &iu,
&n_eig_found,
buff_l,
buff_A, &cs_A,
&nzc,
buff_isuppz,
&try_rac,
buff_work, &lwork,
buff_iwork, &liwork,
&info );
break;
}
}
}
FLA_Obj_free( &isuppz );
FLA_Obj_free( &work );
FLA_Obj_free( &iwork );
#else
FLA_Check_error_code( FLA_EXTERNAL_LAPACK_NOT_IMPLEMENTED );
#endif
return info;
}
FLA_Error FLA_Bsvd_sinval_v_opt_var1( FLA_Obj tol, FLA_Obj thresh,
FLA_Obj G, FLA_Obj H,
FLA_Obj d, FLA_Obj e,
FLA_Obj k )
{
FLA_Datatype datatype;
int m_A, n_GH;
int rs_G, cs_G;
int rs_H, cs_H;
int inc_d;
int inc_e;
datatype = FLA_Obj_datatype( d );
m_A = FLA_Obj_vector_dim( d );
n_GH = FLA_Obj_width( G );
rs_G = FLA_Obj_row_stride( G );
cs_G = FLA_Obj_col_stride( G );
rs_H = FLA_Obj_row_stride( H );
cs_H = FLA_Obj_col_stride( H );
inc_d = FLA_Obj_vector_inc( d );
inc_e = FLA_Obj_vector_inc( e );
switch ( datatype )
{
case FLA_FLOAT:
{
float* buff_tol = FLA_FLOAT_PTR( tol );
float* buff_thresh = FLA_FLOAT_PTR( thresh );
scomplex* buff_G = FLA_COMPLEX_PTR( G );
scomplex* buff_H = FLA_COMPLEX_PTR( H );
float* buff_d = FLA_FLOAT_PTR( d );
float* buff_e = FLA_FLOAT_PTR( e );
int* buff_k = FLA_INT_PTR( k );
FLA_Bsvd_sinval_v_ops_var1( m_A,
n_GH,
9,
*buff_tol,
*buff_thresh,
buff_G, rs_G, cs_G,
buff_H, rs_H, cs_H,
buff_d, inc_d,
buff_e, inc_e,
buff_k );
break;
}
case FLA_DOUBLE:
{
double* buff_tol = FLA_DOUBLE_PTR( tol );
double* buff_thresh = FLA_DOUBLE_PTR( thresh );
dcomplex* buff_G = FLA_DOUBLE_COMPLEX_PTR( G );
dcomplex* buff_H = FLA_DOUBLE_COMPLEX_PTR( H );
double* buff_d = FLA_DOUBLE_PTR( d );
double* buff_e = FLA_DOUBLE_PTR( e );
int* buff_k = FLA_INT_PTR( k );
FLA_Bsvd_sinval_v_opd_var1( m_A,
n_GH,
9,
*buff_tol,
*buff_thresh,
buff_G, rs_G, cs_G,
buff_H, rs_H, cs_H,
buff_d, inc_d,
buff_e, inc_e,
buff_k );
break;
}
}
return FLA_SUCCESS;
}
FLA_Error FLA_Svdd_external( FLA_Svd_type jobz, FLA_Obj A, FLA_Obj s, FLA_Obj U, FLA_Obj V )
{
int info = 0;
#ifdef FLA_ENABLE_EXTERNAL_LAPACK_INTERFACES
FLA_Datatype datatype;
FLA_Datatype dt_real;
FLA_Datatype dt_int;
int m_A, n_A, cs_A;
int cs_U;
int cs_V;
int min_m_n;
int lwork, lrwork, liwork;
FLA_Obj work, rwork, iwork;
char blas_jobz;
int i;
if ( FLA_Check_error_level() == FLA_FULL_ERROR_CHECKING )
FLA_Svdd_check( jobz, A, s, U, V );
if ( FLA_Obj_has_zero_dim( A ) ) return FLA_SUCCESS;
datatype = FLA_Obj_datatype( A );
dt_real = FLA_Obj_datatype_proj_to_real( A );
dt_int = FLA_INT;
m_A = FLA_Obj_length( A );
n_A = FLA_Obj_width( A );
cs_A = FLA_Obj_col_stride( A );
cs_U = FLA_Obj_col_stride( U );
cs_V = FLA_Obj_col_stride( V );
min_m_n = min( m_A, n_A );
// Allocate the rwork and iwork arrays up front.
if ( jobz == FLA_SVD_VECTORS_NONE ) lrwork = 5 * min_m_n;
else lrwork = 5 * min_m_n * min_m_n +
7 * min_m_n;
liwork = 8 * min_m_n;
FLA_Obj_create( dt_int, liwork, 1, 0, 0, &iwork );
if ( FLA_Obj_is_complex( A ) )
FLA_Obj_create( dt_real, lrwork, 1, 0, 0, &rwork );
FLA_Param_map_flame_to_netlib_svd_type( jobz, &blas_jobz );
// Make a workspace query the first time through. This will provide us with
// and ideal workspace size based on an internal block size.
lwork = -1;
FLA_Obj_create( datatype, 1, 1, 0, 0, &work );
for ( i = 0; i < 2; ++i )
{
if ( i == 1 )
{
// Grab the queried ideal workspace size from the work array, free the
// work object, and then re-allocate the workspace with the ideal size.
if ( datatype == FLA_FLOAT || datatype == FLA_COMPLEX )
lwork = ( int ) *FLA_FLOAT_PTR( work );
else if ( datatype == FLA_DOUBLE || datatype == FLA_DOUBLE_COMPLEX )
lwork = ( int ) *FLA_DOUBLE_PTR( work );
FLA_Obj_free( &work );
FLA_Obj_create( datatype, lwork, 1, 0, 0, &work );
}
switch( datatype ) {
case FLA_FLOAT:
{
float* buff_A = ( float* ) FLA_FLOAT_PTR( A );
float* buff_s = ( float* ) FLA_FLOAT_PTR( s );
float* buff_U = ( float* ) FLA_FLOAT_PTR( U );
float* buff_V = ( float* ) FLA_FLOAT_PTR( V );
float* buff_work = ( float* ) FLA_FLOAT_PTR( work );
int* buff_iwork = ( int* ) FLA_INT_PTR( iwork );
F77_sgesdd( &blas_jobz,
&m_A,
&n_A,
buff_A, &cs_A,
buff_s,
buff_U, &cs_U,
buff_V, &cs_V,
buff_work, &lwork,
buff_iwork,
&info );
break;
}
case FLA_DOUBLE:
{
double* buff_A = ( double* ) FLA_DOUBLE_PTR( A );
double* buff_s = ( double* ) FLA_DOUBLE_PTR( s );
double* buff_U = ( double* ) FLA_DOUBLE_PTR( U );
double* buff_V = ( double* ) FLA_DOUBLE_PTR( V );
double* buff_work = ( double* ) FLA_DOUBLE_PTR( work );
int* buff_iwork = ( int* ) FLA_INT_PTR( iwork );
F77_dgesdd( &blas_jobz,
&m_A,
&n_A,
buff_A, &cs_A,
buff_s,
buff_U, &cs_U,
buff_V, &cs_V,
buff_work, &lwork,
buff_iwork,
&info );
break;
}
case FLA_COMPLEX:
{
scomplex* buff_A = ( scomplex* ) FLA_COMPLEX_PTR( A );
float* buff_s = ( float* ) FLA_FLOAT_PTR( s );
scomplex* buff_U = ( scomplex* ) FLA_COMPLEX_PTR( U );
scomplex* buff_V = ( scomplex* ) FLA_COMPLEX_PTR( V );
scomplex* buff_work = ( scomplex* ) FLA_COMPLEX_PTR( work );
float* buff_rwork = ( float* ) FLA_FLOAT_PTR( rwork );
int* buff_iwork = ( int* ) FLA_INT_PTR( iwork );
F77_cgesdd( &blas_jobz,
&m_A,
&n_A,
buff_A, &cs_A,
buff_s,
buff_U, &cs_U,
buff_V, &cs_V,
buff_work, &lwork,
buff_rwork,
buff_iwork,
&info );
break;
}
case FLA_DOUBLE_COMPLEX:
{
dcomplex* buff_A = ( dcomplex* ) FLA_DOUBLE_COMPLEX_PTR( A );
double* buff_s = ( double* ) FLA_DOUBLE_PTR( s );
dcomplex* buff_U = ( dcomplex* ) FLA_DOUBLE_COMPLEX_PTR( U );
dcomplex* buff_V = ( dcomplex* ) FLA_DOUBLE_COMPLEX_PTR( V );
dcomplex* buff_work = ( dcomplex* ) FLA_DOUBLE_COMPLEX_PTR( work );
double* buff_rwork = ( double* ) FLA_DOUBLE_PTR( rwork );
int* buff_iwork = ( int* ) FLA_INT_PTR( iwork );
F77_zgesdd( &blas_jobz,
&m_A,
&n_A,
buff_A, &cs_A,
buff_s,
buff_U, &cs_U,
buff_V, &cs_V,
buff_work, &lwork,
buff_rwork,
buff_iwork,
&info );
break;
}
}
}
FLA_Obj_free( &work );
FLA_Obj_free( &iwork );
if ( FLA_Obj_is_complex( A ) )
FLA_Obj_free( &rwork );
#else
FLA_Check_error_code( FLA_EXTERNAL_LAPACK_NOT_IMPLEMENTED );
#endif
return info;
}
FLA_Error FLA_SA_LU_unb( FLA_Obj U, FLA_Obj D, FLA_Obj p, FLA_Obj L )
{
FLA_Datatype datatype;
int m_U, cs_U;
int m_D, cs_D;
int cs_L;
// int rs_U;
int rs_D;
// int rs_L;
int m_U_min_j, m_U_min_j_min_1;
int j, ipiv;
int* buff_p;
if ( FLA_Obj_has_zero_dim( U ) ) return FLA_SUCCESS;
datatype = FLA_Obj_datatype( U );
m_U = FLA_Obj_length( U );
// rs_U = FLA_Obj_row_stride( U );
cs_U = FLA_Obj_col_stride( U );
m_D = FLA_Obj_length( D );
rs_D = FLA_Obj_row_stride( D );
cs_D = FLA_Obj_col_stride( D );
// rs_L = FLA_Obj_row_stride( L );
cs_L = FLA_Obj_col_stride( L );
FLA_Copy_external( U, L );
FLA_Triangularize( FLA_UPPER_TRIANGULAR, FLA_NONUNIT_DIAG, L );
buff_p = ( int * ) FLA_INT_PTR( p );
switch ( datatype ){
case FLA_FLOAT:
{
float* buff_U = ( float * ) FLA_FLOAT_PTR( U );
float* buff_D = ( float * ) FLA_FLOAT_PTR( D );
float* buff_L = ( float * ) FLA_FLOAT_PTR( L );
float* buff_minus1 = ( float * ) FLA_FLOAT_PTR( FLA_MINUS_ONE );
float L_tmp;
float D_tmp;
float d_inv_Ljj;
for ( j = 0; j < m_U; ++j )
{
bl1_samax( m_D,
buff_D + j*cs_D + 0*rs_D,
rs_D,
&ipiv );
L_tmp = buff_L[ j*cs_L + j ];
D_tmp = buff_D[ j*cs_D + ipiv ];
if ( fabsf( L_tmp ) < fabsf( D_tmp ) )
{
bl1_sswap( m_U,
buff_L + 0*cs_L + j, cs_L,
buff_D + 0*cs_D + ipiv, cs_D );
buff_p[ j ] = ipiv + m_U - j;
}
else
{
buff_p[ j ] = 0;
}
d_inv_Ljj = 1.0F / buff_L[ j*cs_L + j ];
bl1_sscal( m_D,
&d_inv_Ljj,
buff_D + j*cs_D + 0, rs_D );
m_U_min_j_min_1 = m_U - j - 1;
if ( m_U_min_j_min_1 > 0 )
{
bl1_sger( BLIS1_NO_CONJUGATE,
BLIS1_NO_CONJUGATE,
m_D,
m_U_min_j_min_1,
buff_minus1,
buff_D + (j+0)*cs_D + 0, rs_D,
buff_L + (j+1)*cs_L + j, cs_L,
buff_D + (j+1)*cs_D + 0, rs_D, cs_D );
}
m_U_min_j = m_U - j;
if ( m_U_min_j > 0 )
{
bl1_scopy( m_U_min_j,
buff_L + j*cs_L + j, cs_L,
buff_U + j*cs_U + j, cs_U );
}
}
break;
}
case FLA_DOUBLE:
{
double* buff_U = ( double * ) FLA_DOUBLE_PTR( U );
double* buff_D = ( double * ) FLA_DOUBLE_PTR( D );
double* buff_L = ( double * ) FLA_DOUBLE_PTR( L );
double* buff_minus1 = ( double * ) FLA_DOUBLE_PTR( FLA_MINUS_ONE );
double L_tmp;
double D_tmp;
double d_inv_Ljj;
for ( j = 0; j < m_U; ++j )
{
bl1_damax( m_D,
buff_D + j*cs_D + 0*rs_D,
rs_D,
&ipiv );
L_tmp = buff_L[ j*cs_L + j ];
D_tmp = buff_D[ j*cs_D + ipiv ];
if ( fabs( L_tmp ) < fabs( D_tmp ) )
{
bl1_dswap( m_U,
buff_L + 0*cs_L + j, cs_L,
buff_D + 0*cs_D + ipiv, cs_D );
buff_p[ j ] = ipiv + m_U - j;
}
else
{
buff_p[ j ] = 0;
}
d_inv_Ljj = 1.0 / buff_L[ j*cs_L + j ];
bl1_dscal( m_D,
&d_inv_Ljj,
buff_D + j*cs_D + 0, rs_D );
m_U_min_j_min_1 = m_U - j - 1;
if ( m_U_min_j_min_1 > 0 )
{
bl1_dger( BLIS1_NO_CONJUGATE,
BLIS1_NO_CONJUGATE,
m_D,
m_U_min_j_min_1,
buff_minus1,
buff_D + (j+0)*cs_D + 0, rs_D,
buff_L + (j+1)*cs_L + j, cs_L,
buff_D + (j+1)*cs_D + 0, rs_D, cs_D );
}
m_U_min_j = m_U - j;
if ( m_U_min_j > 0 )
{
bl1_dcopy( m_U_min_j,
buff_L + j*cs_L + j, cs_L,
buff_U + j*cs_U + j, cs_U );
}
}
break;
}
case FLA_COMPLEX:
{
scomplex* buff_U = ( scomplex * ) FLA_COMPLEX_PTR( U );
scomplex* buff_D = ( scomplex * ) FLA_COMPLEX_PTR( D );
scomplex* buff_L = ( scomplex * ) FLA_COMPLEX_PTR( L );
scomplex* buff_minus1 = ( scomplex * ) FLA_COMPLEX_PTR( FLA_MINUS_ONE );
scomplex L_tmp;
scomplex D_tmp;
scomplex d_inv_Ljj;
scomplex Ljj;
float temp;
for ( j = 0; j < m_U; ++j )
{
bl1_camax( m_D,
buff_D + j*cs_D + 0*rs_D,
rs_D,
&ipiv );
L_tmp = buff_L[ j*cs_L + j ];
D_tmp = buff_D[ j*cs_D + ipiv ];
if ( fabsf( L_tmp.real + L_tmp.imag ) < fabsf( D_tmp.real + D_tmp.imag ) )
{
bl1_cswap( m_U,
buff_L + 0*cs_L + j, cs_L,
buff_D + 0*cs_D + ipiv, cs_D );
buff_p[ j ] = ipiv + m_U - j;
}
else
{
buff_p[ j ] = 0;
}
Ljj = buff_L[ j*cs_L + j ];
// d_inv_Ljj = 1.0 / Ljj
temp = 1.0F / ( Ljj.real * Ljj.real +
Ljj.imag * Ljj.imag );
d_inv_Ljj.real = Ljj.real * temp;
d_inv_Ljj.imag = Ljj.imag * -temp;
bl1_cscal( m_D,
&d_inv_Ljj,
buff_D + j*cs_D + 0, rs_D );
m_U_min_j_min_1 = m_U - j - 1;
if ( m_U_min_j_min_1 > 0 )
{
bl1_cger( BLIS1_NO_CONJUGATE,
BLIS1_NO_CONJUGATE,
m_D,
m_U_min_j_min_1,
buff_minus1,
buff_D + (j+0)*cs_D + 0, rs_D,
buff_L + (j+1)*cs_L + j, cs_L,
buff_D + (j+1)*cs_D + 0, rs_D, cs_D );
}
m_U_min_j = m_U - j;
if ( m_U_min_j > 0 )
{
bl1_ccopy( m_U_min_j,
buff_L + j*cs_L + j, cs_L,
buff_U + j*cs_U + j, cs_U );
}
}
break;
}
case FLA_DOUBLE_COMPLEX:
{
dcomplex* buff_U = ( dcomplex * ) FLA_DOUBLE_COMPLEX_PTR( U );
dcomplex* buff_D = ( dcomplex * ) FLA_DOUBLE_COMPLEX_PTR( D );
dcomplex* buff_L = ( dcomplex * ) FLA_DOUBLE_COMPLEX_PTR( L );
dcomplex* buff_minus1 = ( dcomplex * ) FLA_DOUBLE_COMPLEX_PTR( FLA_MINUS_ONE );
dcomplex L_tmp;
dcomplex D_tmp;
dcomplex d_inv_Ljj;
dcomplex Ljj;
double temp;
for ( j = 0; j < m_U; ++j )
{
bl1_zamax( m_D,
buff_D + j*cs_D + 0*rs_D,
rs_D,
&ipiv );
L_tmp = buff_L[ j*cs_L + j ];
D_tmp = buff_D[ j*cs_D + ipiv ];
if ( fabs( L_tmp.real + L_tmp.imag ) < fabs( D_tmp.real + D_tmp.imag ) )
{
bl1_zswap( m_U,
buff_L + 0*cs_L + j, cs_L,
buff_D + 0*cs_D + ipiv, cs_D );
buff_p[ j ] = ipiv + m_U - j;
}
else
{
buff_p[ j ] = 0;
}
Ljj = buff_L[ j*cs_L + j ];
// d_inv_Ljj = 1.0 / Ljj
temp = 1.0 / ( Ljj.real * Ljj.real +
Ljj.imag * Ljj.imag );
d_inv_Ljj.real = Ljj.real * temp;
d_inv_Ljj.imag = Ljj.imag * -temp;
bl1_zscal( m_D,
&d_inv_Ljj,
buff_D + j*cs_D + 0, rs_D );
m_U_min_j_min_1 = m_U - j - 1;
if ( m_U_min_j_min_1 > 0 )
{
bl1_zger( BLIS1_NO_CONJUGATE,
BLIS1_NO_CONJUGATE,
m_D,
m_U_min_j_min_1,
buff_minus1,
buff_D + (j+0)*cs_D + 0, rs_D,
buff_L + (j+1)*cs_L + j, cs_L,
buff_D + (j+1)*cs_D + 0, rs_D, cs_D );
}
m_U_min_j = m_U - j;
if ( m_U_min_j > 0 )
{
bl1_zcopy( m_U_min_j,
buff_L + j*cs_L + j, cs_L,
buff_U + j*cs_U + j, cs_U );
}
}
break;
}
}
return FLA_SUCCESS;
}
