C++ FLA_Check_error_level函数代码示例

FLA_Error FLASH_LU_piv( FLA_Obj A, FLA_Obj p )
{
  FLA_Error r_val = FLA_SUCCESS;

  // Check parameters.
  if ( FLA_Check_error_level() >= FLA_MIN_ERROR_CHECKING )
    FLA_LU_piv_check( A, p );

  // *** The current LU_piv algorithm implemented assumes that
  // the matrix has a hierarchical depth of 1. We check for that here, because
  // we anticipate that we'll use a more general algorithm in the future, and
  // we don't want to forget to remove the constraint. ***
  if ( FLASH_Obj_depth( A ) != 1 )
  {
    FLA_Print_message( "FLASH_LU_piv() currently only supports matrices of depth 1",
                       __FILE__, __LINE__ );
    FLA_Abort();
  }

  // Begin a parallel region.
  FLASH_Queue_begin();

  // Invoke FLA_LU_piv_internal() with large control tree.
  FLA_LU_piv_internal( A, p, flash_lu_piv_cntl );

  // End the parallel region.
  FLASH_Queue_end();

  // Check for singularity.
  if ( FLA_Check_error_level() >= FLA_MIN_ERROR_CHECKING )
    r_val = FLASH_LU_find_zero_on_diagonal( A );

  return r_val;
}

FLA_Error FLASH_Apply_CAQ_UT_inc( dim_t p,
                                  FLA_Side side, FLA_Trans trans, FLA_Direct direct, FLA_Store storev,
                                  FLA_Obj A, FLA_Obj ATW, FLA_Obj R, FLA_Obj RTW, FLA_Obj W, FLA_Obj B )
{
  FLA_Error r_val;
  dim_t     nb_part;
  FLA_Obj   WT, WB;

  // Check parameters.
  if ( FLA_Check_error_level() >= FLA_MIN_ERROR_CHECKING )
    FLA_Apply_CAQ_UT_inc_check( side, trans, direct, storev, A, ATW, R, RTW, W, B );

  // Compute the partition length from the number of partitions.
  nb_part = FLA_CAQR_UT_inc_compute_blocks_per_part( p, R );

  // Begin a parallel region.
  FLASH_Queue_begin();

  // Apply the individual Q's from the incremental QR factorizations.
  FLA_Apply_CAQ_UT_inc_apply_panels( nb_part, A, ATW, W, B );

  FLA_Part_2x1( W,   &WT,
                     &WB,    1, FLA_TOP );

  // Apply the Q from the factorization of the upper triangular R's.
  r_val = FLA_Apply_CAQ_UT_inc_internal( side, trans, direct, storev,
                                         R, RTW, WT, B, flash_apcaqutinc_cntl );


  // End the parallel region.
  FLASH_Queue_end();

  return r_val;
}

FLA_Error FLASH_Chol_solve( FLA_Uplo uplo, FLA_Obj A, FLA_Obj B, FLA_Obj X )
{
  // Check parameters.
  if ( FLA_Check_error_level() >= FLA_MIN_ERROR_CHECKING )
    FLA_Chol_solve_check( uplo, A, B, X );

  FLASH_Copy( B, X );

  if ( uplo == FLA_LOWER_TRIANGULAR )
  {
      FLASH_Trsm( FLA_LEFT, FLA_LOWER_TRIANGULAR, FLA_NO_TRANSPOSE,
                  FLA_NONUNIT_DIAG, FLA_ONE, A, X );
      FLASH_Trsm( FLA_LEFT, FLA_LOWER_TRIANGULAR, FLA_CONJ_TRANSPOSE,
                  FLA_NONUNIT_DIAG, FLA_ONE, A, X );
  }
  else // if ( uplo == FLA_UPPER_TRIANGULAR )
  {
      FLASH_Trsm( FLA_LEFT, FLA_UPPER_TRIANGULAR, FLA_CONJ_TRANSPOSE,
                  FLA_NONUNIT_DIAG, FLA_ONE, A, X );
      FLASH_Trsm( FLA_LEFT, FLA_UPPER_TRIANGULAR, FLA_NO_TRANSPOSE,
                  FLA_NONUNIT_DIAG, FLA_ONE, A, X );
  }

  return FLA_SUCCESS;
}

FLA_Error FLA_LU_find_zero_on_diagonal( FLA_Obj A )
{
  FLA_Obj ATL,   ATR,      A00,  a01,     A02, 
          ABL,   ABR,      a10t, alpha11, a12t,
                           A20,  a21,     A22;

  if ( FLA_Check_error_level() >= FLA_MIN_ERROR_CHECKING )
    FLA_LU_find_zero_on_diagonal_check( A );

  FLA_Part_2x2( A,    &ATL, &ATR,
                      &ABL, &ABR,     0, 0, FLA_TL );

  while ( FLA_Obj_length( ATL ) < FLA_Obj_min_dim( A ) ){

    FLA_Repart_2x2_to_3x3( ATL, /**/ ATR,       &A00,  /**/ &a01,     &A02,
                        /* ************* */   /* ************************** */
                                                &a10t, /**/ &alpha11, &a12t,
                           ABL, /**/ ABR,       &A20,  /**/ &a21,     &A22,
                           1, 1, FLA_BR );

    /*------------------------------------------------------------*/

    if ( FLA_Obj_equals( alpha11, FLA_ZERO ) ) return FLA_Obj_length( A00 );

    /*------------------------------------------------------------*/

    FLA_Cont_with_3x3_to_2x2( &ATL, /**/ &ATR,       A00,  a01,     /**/ A02,
                                                     a10t, alpha11, /**/ a12t,
                            /* ************** */  /* ************************ */
                              &ABL, /**/ &ABR,       A20,  a21,     /**/ A22,
                              FLA_TL );
  }

  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_Error FLASH_CAQR_UT_inc_noopt( dim_t p, FLA_Obj A, FLA_Obj ATW, FLA_Obj R, FLA_Obj RTW )
{
  FLA_Error r_val = FLA_SUCCESS;
  dim_t     nb_part;

  // Check parameters.
  if ( FLA_Check_error_level() >= FLA_MIN_ERROR_CHECKING )
    FLA_CAQR_UT_inc_check( p, A, ATW, R, RTW );

  // Compute the partition length from the number of partitions.
  nb_part = FLA_CAQR_UT_inc_compute_blocks_per_part( p, A );

  // Begin a parallel region.
  FLASH_Queue_begin();

  // Perform incremental QR's on each of the p partitions.
  FLA_CAQR_UT_inc_factorize_panels( nb_part, A, ATW );

  // Copy the triangles of A into R.
  FLA_CAQR_UT_inc_copy_triangles( nb_part, A, R );

  // Perform an incremental CAQR on the resulting upper triangular R's in A.
  FLA_CAQR_UT_inc_blk_var1( R, RTW, flash_caqrutinc_cntl );

  // End the parallel region.
  FLASH_Queue_end();

  return r_val;
}

FLA_Error FLASH_Random_spd_matrix( FLA_Uplo uplo, FLA_Obj H )
{
	FLA_Obj   F;
	FLA_Error e_val;

	if ( FLA_Check_error_level() >= FLA_MIN_ERROR_CHECKING )
	{
		e_val = FLA_Check_valid_uplo( uplo );
		FLA_Check_error_code( e_val );
	}

	// Exit early if one dimension is zero.
	if ( FLA_Obj_has_zero_dim( H ) ) return FLA_SUCCESS;

	// Create a temporary flat copy of the hierarchical object.
	FLASH_Obj_create_flat_copy_of_hier( H, &F );

	// Randomize the flat matrix object to be SPD.
	FLA_Random_spd_matrix( uplo, F );

	// Copy the flat object's contents back to the hierarchical object.
	FLASH_Obj_hierarchify( F, H );

	// Free the temporary flat object.
	FLASH_Obj_free( &F );

	return FLA_SUCCESS;
}

FLA_Error FLASH_QR_UT_inc_opt1( FLA_Obj A, FLA_Obj TW )
{
  FLA_Error r_val;
  FLA_Obj   U;

  // Check parameters.
  if ( FLA_Check_error_level() >= FLA_MIN_ERROR_CHECKING )
    FLA_QR_UT_inc_check( A, TW );

  // Create a temporary matrix to hold copies of all of the blocks along the
  // diagonal of A.
  FLASH_Obj_create_diag_panel( A, &U );

  // Begin a parallel region.
  FLASH_Queue_begin();

  // Invoke FLA_QR_UT_inc_blk_var2() with the standard control tree.
  r_val = FLA_QR_UT_inc_blk_var2( A, TW, U, flash_qrutinc_cntl );

  // End the parallel region.
  FLASH_Queue_end();

  // Free the temporary matrix.
  FLASH_Obj_free( &U );

  return r_val;
}

FLA_Elemtype FLA_Obj_elemtype( FLA_Obj obj )
{
  if ( FLA_Check_error_level() >= FLA_MIN_ERROR_CHECKING )
    FLA_Obj_elemtype_check( obj );

  return obj.base->elemtype;
}

dim_t FLA_Obj_datatype_size( FLA_Datatype datatype )
{
  dim_t datatype_size = 0;

  if ( FLA_Check_error_level() >= FLA_MIN_ERROR_CHECKING )
    FLA_Obj_datatype_size_check( datatype );

  switch( datatype )
  {
    case FLA_INT: 
      datatype_size = sizeof( int );
      break;
    case FLA_FLOAT: 
      datatype_size = sizeof( float );
      break;
    case FLA_DOUBLE: 
      datatype_size = sizeof( double );
      break;
    case FLA_COMPLEX: 
      datatype_size = sizeof( scomplex );
      break;
    case FLA_DOUBLE_COMPLEX: 
      datatype_size = sizeof( dcomplex );
      break;
    case FLA_CONSTANT: 
      datatype_size = FLA_CONSTANT_SIZE;
      break;
  }

  return datatype_size;
}

void* FLA_Submatrix_at( FLA_Datatype datatype, void* buffer, dim_t i, dim_t j, dim_t rs, dim_t cs )
{
  void* r_val = buffer;

  if ( FLA_Check_error_level() >= FLA_MIN_ERROR_CHECKING )
    FLA_Submatrix_at_check( datatype, buffer, i, j, rs, cs );

  switch( datatype )
  {
    case FLA_INT:
      r_val = ( void* ) ( (      ( int* ) buffer ) + i * rs + j * cs );
      break;

    case FLA_FLOAT:
      r_val = ( void* ) ( (    ( float* ) buffer ) + i * rs + j * cs );
      break;

    case FLA_DOUBLE:
      r_val = ( void* ) ( (   ( double* ) buffer ) + i * rs + j * cs );
      break;

    case FLA_COMPLEX:
      r_val = ( void* ) ( ( ( scomplex* ) buffer ) + i * rs + j * cs );
      break;

    case FLA_DOUBLE_COMPLEX:
      r_val = ( void* ) ( ( ( dcomplex* ) buffer ) + i * rs + j * cs );
      break;
  }

  return r_val;
}

FLA_Error FLA_QR_UT_solve( FLA_Obj A, FLA_Obj T, FLA_Obj B, FLA_Obj X )
{
  FLA_Obj W, Y;
  FLA_Obj AT, AB;
  FLA_Obj YT, YB;

  // Check parameters.
  if ( FLA_Check_error_level() >= FLA_MIN_ERROR_CHECKING )
    FLA_QR_UT_solve_check( A, T, B, X );

  FLA_Apply_Q_UT_create_workspace( T, B, &W );

  FLA_Obj_create_copy_of( FLA_NO_TRANSPOSE, B, &Y );

  FLA_Apply_Q_UT( FLA_LEFT, FLA_CONJ_TRANSPOSE, FLA_FORWARD, FLA_COLUMNWISE,
                  A, T, W, Y );

  FLA_Part_2x1( A,   &AT,
                     &AB,    FLA_Obj_width( A ), FLA_TOP );
  FLA_Part_2x1( Y,   &YT,
                     &YB,    FLA_Obj_width( A ), FLA_TOP );

  FLA_Trsm_external( FLA_LEFT, FLA_UPPER_TRIANGULAR, FLA_NO_TRANSPOSE,
                     FLA_NONUNIT_DIAG, FLA_ONE, AT, YT );

  FLA_Copy_external( YT, X );

  FLA_Obj_free( &Y );
  FLA_Obj_free( &W );

  return FLA_SUCCESS;
}

FLA_Error FLASH_LQ_UT_solve( FLA_Obj A, FLA_Obj T, FLA_Obj B, FLA_Obj X )
{
    FLA_Obj W;
    FLA_Obj AL, AR;
    FLA_Obj XT, XB;

    // Check parameters.
    if ( FLA_Check_error_level() >= FLA_MIN_ERROR_CHECKING )
        FLA_LQ_UT_solve_check( A, T, B, X );

    FLASH_Apply_Q_UT_create_workspace( T, X, &W );

    FLA_Part_1x2( A,   &AL, &AR,    FLA_Obj_length( A ), FLA_LEFT );
    FLA_Part_2x1( X,   &XT,
                  &XB,    FLA_Obj_length( B ), FLA_TOP );

    FLASH_Copy( B, XT );

    FLASH_Trsm( FLA_LEFT, FLA_LOWER_TRIANGULAR, FLA_NO_TRANSPOSE,
                FLA_NONUNIT_DIAG, FLA_ONE, AL, XT );

    FLASH_Set( FLA_ZERO, XB );

    FLASH_Apply_Q_UT( FLA_LEFT, FLA_NO_TRANSPOSE, FLA_FORWARD, FLA_ROWWISE,
                      A, T, W, X );

    FLASH_Obj_free( &W );

    return FLA_SUCCESS;
}

FLA_Error FLA_LQ_UT_internal( FLA_Obj A, FLA_Obj T, fla_lqut_t* cntl )
{
	FLA_Error r_val = FLA_SUCCESS;
	
	if ( FLA_Check_error_level() == FLA_FULL_ERROR_CHECKING )
		FLA_LQ_UT_internal_check( A, T, cntl );

	if      ( FLA_Cntl_matrix_type( cntl ) == FLA_HIER &&
	          FLA_Cntl_variant( cntl ) == FLA_SUBPROBLEM )
	{
		if ( FLASH_Queue_get_enabled( ) )
		{
			// Enqueue
			ENQUEUE_FLASH_LQ_UT_macro( A, T, cntl );
		}
		else
		{
			// Execute
			r_val = FLA_LQ_UT_macro_task( A, T, cntl );
		}
	}
	else
	{
		if      ( FLA_Cntl_variant( cntl ) == FLA_UNBLOCKED_VARIANT1 )
		{
			r_val = FLA_LQ_UT_unb_var1( A, T );
		}
		else if ( FLA_Cntl_variant( cntl ) == FLA_UNB_OPT_VARIANT1 )
		{
			r_val = FLA_LQ_UT_opt_var1( A, T );
		}
		else if ( FLA_Cntl_variant( cntl ) == FLA_BLOCKED_VARIANT1 )
		{
			r_val = FLA_LQ_UT_blk_var1( A, T, cntl );
		}
		else if ( FLA_Cntl_variant( cntl ) == FLA_UNBLOCKED_VARIANT2 )
		{
			r_val = FLA_LQ_UT_unb_var2( A, T );
		}
		else if ( FLA_Cntl_variant( cntl ) == FLA_UNB_OPT_VARIANT2 )
		{
			r_val = FLA_LQ_UT_opt_var2( A, T );
		}
		else if ( FLA_Cntl_variant( cntl ) == FLA_BLOCKED_VARIANT2 )
		{
			r_val = FLA_LQ_UT_blk_var2( A, T, cntl );
		}
		else if ( FLA_Cntl_variant( cntl ) == FLA_BLOCKED_VARIANT3 )
		{
			r_val = FLA_LQ_UT_blk_var3( A, T, cntl );
		}
		else
		{
			FLA_Check_error_code( FLA_NOT_YET_IMPLEMENTED );
		}
	}

	return r_val;
}

FLA_Error FLA_LU_nopiv( FLA_Obj A )
{
  FLA_Error r_val;

  // Check parameters.
  if ( FLA_Check_error_level() >= FLA_MIN_ERROR_CHECKING )
    FLA_LU_nopiv_check( A );

  // Invoke FLA_LU_nopiv_internal() with large control tree.
  r_val = FLA_LU_nopiv_internal( A, fla_lu_nopiv_cntl2 );

  // Check for singularity.
  if ( FLA_Check_error_level() >= FLA_MIN_ERROR_CHECKING )
    r_val = FLA_LU_find_zero_on_diagonal( A );

  return r_val;
}