void bli_obj_create_const_copy_of( obj_t* a, obj_t* b )
{
gint_t* temp_i;
float* temp_s;
double* temp_d;
scomplex* temp_c;
dcomplex* temp_z;
void* buf_a;
dcomplex value;
if ( bli_error_checking_is_enabled() )
bli_obj_create_const_copy_of_check( a, b );
bli_obj_create( BLIS_CONSTANT, 1, 1, 1, 1, b );
temp_s = bli_obj_buffer_for_const( BLIS_FLOAT, *b );
temp_d = bli_obj_buffer_for_const( BLIS_DOUBLE, *b );
temp_c = bli_obj_buffer_for_const( BLIS_SCOMPLEX, *b );
temp_z = bli_obj_buffer_for_const( BLIS_DCOMPLEX, *b );
temp_i = bli_obj_buffer_for_const( BLIS_INT, *b );
buf_a = bli_obj_buffer_at_off( *a );
bli_zzsets( 0.0, 0.0, value );
if ( bli_obj_is_float( *a ) )
{
bli_szcopys( *(( float* )buf_a), value );
}
else if ( bli_obj_is_double( *a ) )
{
bli_dzcopys( *(( double* )buf_a), value );
}
else if ( bli_obj_is_scomplex( *a ) )
{
bli_czcopys( *(( scomplex* )buf_a), value );
}
else if ( bli_obj_is_dcomplex( *a ) )
{
bli_zzcopys( *(( dcomplex* )buf_a), value );
}
else
{
bli_check_error_code( BLIS_NOT_YET_IMPLEMENTED );
}
bli_zscopys( value, *temp_s );
bli_zdcopys( value, *temp_d );
bli_zccopys( value, *temp_c );
bli_zzcopys( value, *temp_z );
*temp_i = ( gint_t ) bli_zreal( value );
}
//
// Define object-based interface.
//
void bli_trsm( side_t side,
obj_t* alpha,
obj_t* a,
obj_t* b )
{
if (
#ifdef BLIS_ENABLE_SCOMPLEX_VIA_4M
bli_obj_is_scomplex( *b ) ||
#endif
#ifdef BLIS_ENABLE_DCOMPLEX_VIA_4M
bli_obj_is_dcomplex( *b ) ||
#endif
FALSE
)
return bli_trsm4m( side, alpha, a, b );
bli_trsm_front( side, alpha, a, b,
trsm_l_cntl,
trsm_r_cntl );
}
void libblis_test_gemm_md_check
(
test_params_t* params,
obj_t* alpha,
obj_t* a,
obj_t* b,
obj_t* beta,
obj_t* c,
obj_t* c_orig,
double* resid
)
{
num_t dt_real = bli_obj_dt_proj_to_real( c );
num_t dt_comp = bli_obj_dt_proj_to_complex( c );
num_t dt;
dim_t m = bli_obj_length( c );
dim_t n = bli_obj_width( c );
dim_t k = bli_obj_width_after_trans( a );
obj_t norm;
obj_t t, v, w, z;
double junk;
// Compute our reference checksum in the real domain if all operands
// are real, and in the complex domain otherwise. Also implicit in this
// is that we use the storage precision of C to determine the precision
// in which we perform the reference checksum.
if ( bli_obj_is_real( a ) &&
bli_obj_is_real( b ) &&
bli_obj_is_real( c ) ) dt = dt_real;
else dt = dt_comp;
// This function works in a manner similar to that of the function
// libblis_test_gemm_check(), except that we project a, b, and c into
// the complex domain (regardless of their storage datatype), and then
// proceed with the checking accordingly.
obj_t a2, b2, c2, c0;
bli_obj_scalar_init_detached( dt_real, &norm );
bli_obj_create( dt, n, 1, 0, 0, &t );
bli_obj_create( dt, m, 1, 0, 0, &v );
bli_obj_create( dt, k, 1, 0, 0, &w );
bli_obj_create( dt, m, 1, 0, 0, &z );
libblis_test_vobj_randomize( params, TRUE, &t );
// We need to zero out the imaginary part of t in order for our
// checks to work in all cases. Otherwise, the imaginary parts
// could affect intermediate products, depending on the order that
// they are executed.
bli_setiv( &BLIS_ZERO, &t );
// Create complex equivalents of a, b, c_orig, and c.
bli_obj_create( dt, m, k, 0, 0, &a2 );
bli_obj_create( dt, k, n, 0, 0, &b2 );
bli_obj_create( dt, m, n, 0, 0, &c2 );
bli_obj_create( dt, m, n, 0, 0, &c0 );
// Cast a, b, c_orig, and c into the datatype of our temporary objects.
bli_castm( a, &a2 );
bli_castm( b, &b2 );
bli_castm( c_orig, &c2 );
bli_castm( c, &c0 );
bli_gemv( &BLIS_ONE, &c0, &t, &BLIS_ZERO, &v );
#if 0
if ( bli_obj_is_scomplex( c ) &&
bli_obj_is_float( a ) &&
bli_obj_is_float( b ) )
{
bli_printm( "test_gemm.c: a", a, "%7.3f", "" );
bli_printm( "test_gemm.c: b", b, "%7.3f", "" );
bli_printm( "test_gemm.c: c orig", c_orig, "%7.3f", "" );
bli_printm( "test_gemm.c: c computed", c, "%7.3f", "" );
}
#endif
#if 0
bli_gemm( alpha, &a2, &b2, beta, &c2 );
bli_gemv( &BLIS_ONE, &c2, &t, &BLIS_ZERO, &z );
if ( bli_obj_is_real( c ) ) bli_setiv( &BLIS_ZERO, &z );
#else
bli_gemv( &BLIS_ONE, &b2, &t, &BLIS_ZERO, &w );
bli_gemv( alpha, &a2, &w, &BLIS_ZERO, &z );
bli_gemv( beta, &c2, &t, &BLIS_ONE, &z );
if ( bli_obj_is_real( c ) ) bli_setiv( &BLIS_ZERO, &z );
#endif
bli_subv( &z, &v );
bli_normfv( &v, &norm );
bli_getsc( &norm, resid, &junk );
bli_obj_free( &t );
bli_obj_free( &v );
bli_obj_free( &w );
bli_obj_free( &z );
bli_obj_free( &a2 );
bli_obj_free( &b2 );
bli_obj_free( &c2 );
bli_obj_free( &c0 );
}
void libblis_test_setv_check( obj_t* beta,
obj_t* x,
double* resid )
{
num_t dt_x = bli_obj_datatype( *x );
dim_t m_x = bli_obj_vector_dim( *x );
inc_t inc_x = bli_obj_vector_inc( *x );
void* buf_x = bli_obj_buffer_at_off( *x );
void* buf_beta = bli_obj_buffer_for_1x1( dt_x, *beta );
dim_t i;
*resid = 0.0;
//
// The easiest way to check that setv was successful is to confirm
// that each element of x is equal to beta.
//
if ( bli_obj_is_float( *x ) )
{
float* chi1 = buf_x;
float* beta_cast = buf_beta;
for ( i = 0; i < m_x; ++i )
{
if ( !bli_seq( *chi1, *beta_cast ) ) { *resid = 1.0; return; }
chi1 += inc_x;
}
}
else if ( bli_obj_is_double( *x ) )
{
double* chi1 = buf_x;
double* beta_cast = buf_beta;
for ( i = 0; i < m_x; ++i )
{
if ( !bli_deq( *chi1, *beta_cast ) ) { *resid = 1.0; return; }
chi1 += inc_x;
}
}
else if ( bli_obj_is_scomplex( *x ) )
{
scomplex* chi1 = buf_x;
scomplex* beta_cast = buf_beta;
for ( i = 0; i < m_x; ++i )
{
if ( !bli_ceq( *chi1, *beta_cast ) ) { *resid = 1.0; return; }
chi1 += inc_x;
}
}
else // if ( bli_obj_is_dcomplex( *x ) )
{
dcomplex* chi1 = buf_x;
dcomplex* beta_cast = buf_beta;
for ( i = 0; i < m_x; ++i )
{
if ( !bli_zeq( *chi1, *beta_cast ) ) { *resid = 1.0; return; }
chi1 += inc_x;
}
}
}
void libblis_test_randm_check( obj_t* x,
double* resid )
{
doff_t diagoffx = bli_obj_diag_offset( *x );
uplo_t uplox = bli_obj_uplo( *x );
dim_t m_x = bli_obj_length( *x );
dim_t n_x = bli_obj_width( *x );
inc_t rs_x = bli_obj_row_stride( *x );
inc_t cs_x = bli_obj_col_stride( *x );
void* buf_x = bli_obj_buffer_at_off( *x );
*resid = 0.0;
//
// The two most likely ways that randm would fail is if all elements
// were zero, or if all elements were greater than or equal to one.
// We check both of these conditions by computing the sum of the
// absolute values of the elements of x.
//
if ( bli_obj_is_float( *x ) )
{
float sum_x;
bli_sabsumm( diagoffx,
uplox,
m_x,
n_x,
buf_x, rs_x, cs_x,
&sum_x );
if ( sum_x == *bli_s0 ) *resid = 1.0;
else if ( sum_x >= 1.0 * m_x * n_x ) *resid = 2.0;
}
else if ( bli_obj_is_double( *x ) )
{
double sum_x;
bli_dabsumm( diagoffx,
uplox,
m_x,
n_x,
buf_x, rs_x, cs_x,
&sum_x );
if ( sum_x == *bli_d0 ) *resid = 1.0;
else if ( sum_x >= 1.0 * m_x * n_x ) *resid = 2.0;
}
else if ( bli_obj_is_scomplex( *x ) )
{
float sum_x;
bli_cabsumm( diagoffx,
uplox,
m_x,
n_x,
buf_x, rs_x, cs_x,
&sum_x );
if ( sum_x == *bli_s0 ) *resid = 1.0;
else if ( sum_x >= 2.0 * m_x * n_x ) *resid = 2.0;
}
else // if ( bli_obj_is_dcomplex( *x ) )
{
double sum_x;
bli_zabsumm( diagoffx,
uplox,
m_x,
n_x,
buf_x, rs_x, cs_x,
&sum_x );
if ( sum_x == *bli_d0 ) *resid = 1.0;
else if ( sum_x >= 2.0 * m_x * n_x ) *resid = 2.0;
}
}
void libblis_test_randv_check( obj_t* x,
double* resid )
{
dim_t m_x = bli_obj_vector_dim( *x );
inc_t inc_x = bli_obj_vector_inc( *x );
void* buf_x = bli_obj_buffer_at_off( *x );
*resid = 0.0;
//
// The two most likely ways that randv would fail is if all elements
// were zero, or if all elements were greater than or equal to one.
// We check both of these conditions by computing the sum of the
// absolute values of the elements of x.
//
if ( bli_obj_is_float( *x ) )
{
float sum_x;
bli_sabsumv( m_x,
buf_x, inc_x,
&sum_x );
if ( sum_x == *bli_s0 ) *resid = 1.0;
else if ( sum_x >= 1.0 * m_x ) *resid = 2.0;
}
else if ( bli_obj_is_double( *x ) )
{
double sum_x;
bli_dabsumv( m_x,
buf_x, inc_x,
&sum_x );
if ( sum_x == *bli_d0 ) *resid = 1.0;
else if ( sum_x >= 1.0 * m_x ) *resid = 2.0;
}
else if ( bli_obj_is_scomplex( *x ) )
{
float sum_x;
bli_cabsumv( m_x,
buf_x, inc_x,
&sum_x );
if ( sum_x == *bli_s0 ) *resid = 1.0;
else if ( sum_x >= 2.0 * m_x ) *resid = 2.0;
}
else // if ( bli_obj_is_dcomplex( *x ) )
{
double sum_x;
bli_zabsumv( m_x,
buf_x, inc_x,
&sum_x );
if ( sum_x == *bli_d0 ) *resid = 1.0;
else if ( sum_x >= 2.0 * m_x ) *resid = 2.0;
}
}
void libblis_test_setm_check
(
test_params_t* params,
obj_t* beta,
obj_t* x,
double* resid
)
{
num_t dt_x = bli_obj_datatype( *x );
dim_t m_x = bli_obj_length( *x );
dim_t n_x = bli_obj_width( *x );
inc_t rs_x = bli_obj_row_stride( *x );
inc_t cs_x = bli_obj_col_stride( *x );
void* buf_x = bli_obj_buffer_at_off( *x );
void* buf_beta = bli_obj_buffer_for_1x1( dt_x, *beta );
dim_t i, j;
*resid = 0.0;
//
// The easiest way to check that setm was successful is to confirm
// that each element of x is equal to beta.
//
if ( bli_obj_is_float( *x ) )
{
float* beta_cast = buf_beta;
float* buf_x_cast = buf_x;
float* chi1;
for ( j = 0; j < n_x; ++j )
{
for ( i = 0; i < m_x; ++i )
{
chi1 = buf_x_cast + (i )*rs_x + (j )*cs_x;
if ( !bli_seq( *chi1, *beta_cast ) ) { *resid = 1.0; return; }
}
}
}
else if ( bli_obj_is_double( *x ) )
{
double* beta_cast = buf_beta;
double* buf_x_cast = buf_x;
double* chi1;
for ( j = 0; j < n_x; ++j )
{
for ( i = 0; i < m_x; ++i )
{
chi1 = buf_x_cast + (i )*rs_x + (j )*cs_x;
if ( !bli_deq( *chi1, *beta_cast ) ) { *resid = 1.0; return; }
}
}
}
else if ( bli_obj_is_scomplex( *x ) )
{
scomplex* beta_cast = buf_beta;
scomplex* buf_x_cast = buf_x;
scomplex* chi1;
for ( j = 0; j < n_x; ++j )
{
for ( i = 0; i < m_x; ++i )
{
chi1 = buf_x_cast + (i )*rs_x + (j )*cs_x;
if ( !bli_ceq( *chi1, *beta_cast ) ) { *resid = 1.0; return; }
}
}
}
else // if ( bli_obj_is_dcomplex( *x ) )
{
dcomplex* beta_cast = buf_beta;
dcomplex* buf_x_cast = buf_x;
dcomplex* chi1;
for ( j = 0; j < n_x; ++j )
{
for ( i = 0; i < m_x; ++i )
{
chi1 = buf_x_cast + (i )*rs_x + (j )*cs_x;
if ( !bli_zeq( *chi1, *beta_cast ) ) { *resid = 1.0; return; }
}
}
}
}
