///////////////////////////////////////////////////////////////////////////////
/// Entrance of calculating diffusion equation
///
///\param para Pointer to FFD parameters
///\param var Pointer to FFD simulation variables
///\param var_type Type of variable
///\param index Index of trace substance or species
///\param psi Pointer to the variable at current time step
///\param psi0 Pointer to the variable at previous time step
///\param BINDEX Pointer to boundary index
///
///\return 0 if no error occurred
///////////////////////////////////////////////////////////////////////////////
int diffusion(PARA_DATA *para, REAL **var, int var_type, int index,
REAL *psi, REAL *psi0, int **BINDEX) {
int flag = 0;
/****************************************************************************
| Define the coeffcients for diffusion euqation
****************************************************************************/
flag = coef_diff(para, var, psi, psi0, var_type, index, BINDEX);
if(flag!=0) {
ffd_log("diffsuion(): Could not calculate coefficents for "
"diffusion equation.", FFD_ERROR);
return flag;
}
// Solve the equations
equ_solver(para, var, var_type, psi);
// Define B.C.
set_bnd(para, var, var_type, index, psi, BINDEX);
// Check residual
if(para->solv->check_residual==1) {
switch(var_type) {
case VX:
sprintf(msg, "diffusion(): Residual of VX is %f",
check_residual(para, var, psi));
ffd_log(msg, FFD_NORMAL);
break;
case VY:
sprintf(msg, "diffusion(): Residual of VY is %f",
check_residual(para, var, psi));
ffd_log(msg, FFD_NORMAL);
break;
case VZ:
sprintf(msg, "diffusion(): Residual of VZ is %f",
check_residual(para, var, psi));
ffd_log(msg, FFD_NORMAL);
break;
case TEMP:
sprintf(msg, "diffusion(): Residual of T is %f",
check_residual(para, var, psi));
ffd_log(msg, FFD_NORMAL);
break;
case TRACE:
sprintf(msg, "diffusion(): Residual of Trace %d is %f",
index, check_residual(para, var, psi));
ffd_log(msg, FFD_NORMAL);
break;
default:
sprintf(msg, "diffusion(): No sovler for varibale type %d",
var_type);
ffd_log(msg, FFD_ERROR);
flag = 1;
}
}
return flag;
} // End of diffusion( )
int do_memory_uplo(int n, W& workspace ) {
typedef typename bindings::remove_imaginary<T>::type real_type ;
typedef ublas::matrix<T, ublas::column_major> matrix_type ;
typedef ublas::vector<real_type> vector_type ;
typedef ublas::hermitian_adaptor<matrix_type, UPLO> hermitian_type;
// Set matrix
matrix_type a( n, n ); a.clear();
vector_type e1( n );
vector_type e2( n );
fill( a );
matrix_type a2( a );
matrix_type z( a );
// Compute Schur decomposition.
fortran_int_t m;
ublas::vector<fortran_int_t> ifail(n);
hermitian_type h_a( a );
lapack::heevx( 'V', 'A', h_a, real_type(0.0), real_type(1.0), 2, n-1, real_type(1e-28), m,
e1, z, ifail, workspace ) ;
if (check_residual( a2, e1, z )) return 255 ;
hermitian_type h_a2( a2 );
lapack::heevx( 'N', 'A', h_a2, real_type(0.0), real_type(1.0), 2, n-1, real_type(1e-28), m,
e2, z, ifail, workspace ) ;
if (norm_2( e1 - e2 ) > n * norm_2( e1 ) * std::numeric_limits< real_type >::epsilon()) return 255 ;
// Test for a matrix range
fill( a ); a2.assign( a );
typedef ublas::matrix_range< matrix_type > matrix_range ;
typedef ublas::hermitian_adaptor<matrix_range, UPLO> hermitian_range_type;
ublas::range r(1,n-1) ;
matrix_range a_r( a, r, r );
matrix_range z_r( z, r, r );
ublas::vector_range< vector_type> e_r( e1, r );
ublas::vector<fortran_int_t> ifail_r(n-2);
hermitian_range_type h_a_r( a_r );
lapack::heevx( 'V', 'A', h_a_r, real_type(0.0), real_type(1.0), 2, n-1, real_type(1e-28), m,
e_r, z_r, ifail_r, workspace );
matrix_range a2_r( a2, r, r );
if (check_residual( a2_r, e_r, z_r )) return 255 ;
return 0 ;
} // do_memory_uplo()
int do_memory_uplo(int n, W& workspace ) {
typedef typename bindings::remove_imaginary<T>::type real_type ;
typedef ublas::matrix<T, ublas::column_major> matrix_type ;
typedef ublas::symmetric_adaptor<matrix_type, UPLO> symmetric_type ;
typedef ublas::vector<real_type> vector_type ;
// Set matrix
matrix_type a( n, n ); a.clear();
vector_type e1( n );
vector_type e2( n );
fill( a );
matrix_type a2( a );
// Compute eigen decomposition.
symmetric_type s_a( a );
lapack::syev( 'V', bindings::noop(s_a), e1, workspace ) ;
if (check_residual( a2, e1, a )) return 255 ;
symmetric_type s_a2( a2 );
lapack::syev( 'N', s_a2, e2, workspace ) ;
if (norm_2( e1 - e2 ) > n * norm_2( e1 ) * std::numeric_limits< real_type >::epsilon()) return 255 ;
// Test for a matrix range
fill( a ); a2.assign( a );
typedef ublas::matrix_range< matrix_type > matrix_range ;
typedef ublas::symmetric_adaptor<matrix_range, UPLO> symmetric_range_type;
ublas::range r(1,n-1) ;
matrix_range a_r( a, r, r );
ublas::vector_range< vector_type> e_r( e1, r );
symmetric_range_type s_a_r( a_r );
lapack::syev('V', s_a_r, e_r, workspace );
matrix_range a2_r( a2, r, r );
if (check_residual( a2_r, e_r, a_r )) return 255 ;
// Test for symmetric_adaptor
fill( a ); a2.assign( a );
ublas::symmetric_adaptor< matrix_type, UPLO> a_uplo( a ) ;
lapack::syev( 'V', a_uplo, e1, workspace ) ;
if (check_residual( a2, e1, a )) return 255 ;
return 0 ;
} // do_memory_uplo()
int main (int argc, char **argv)
{
cholmod_common Common, *cc ;
cholmod_sparse *A ;
cholmod_dense *X, *B ;
int mtype ;
Long m, n ;
// start CHOLMOD
cc = &Common ;
cholmod_l_start (cc) ;
// A = mread (stdin) ; read in the sparse matrix A
A = (cholmod_sparse *) cholmod_l_read_matrix (stdin, 1, &mtype, cc) ;
if (mtype != CHOLMOD_SPARSE)
{
printf ("input matrix must be sparse\n") ;
exit (1) ;
}
// [m n] = size (A) ;
m = A->nrow ;
n = A->ncol ;
printf ("Matrix %6ld-by-%-6ld nnz: %6ld\n", m, n, cholmod_l_nnz (A, cc)) ;
// B = ones (m,1), a dense right-hand-side of the same type as A
B = cholmod_l_ones (m, 1, A->xtype, cc) ;
// X = A\B ; with default ordering and default column 2-norm tolerance
if (A->xtype == CHOLMOD_REAL)
{
// A, X, and B are all real
X = SuiteSparseQR <double>
(SPQR_ORDERING_DEFAULT, SPQR_DEFAULT_TOL, A, B, cc) ;
}
else
{
// A, X, and B are all complex
X = SuiteSparseQR < std::complex<double> >
(SPQR_ORDERING_DEFAULT, SPQR_DEFAULT_TOL, A, B, cc) ;
}
check_residual (A, X, B, cc) ;
cholmod_l_free_dense (&X, cc) ;
// -------------------------------------------------------------------------
// factorizing once then solving twice with different right-hand-sides
// -------------------------------------------------------------------------
// Just the real case. Complex case is essentially identical
if (A->xtype == CHOLMOD_REAL)
{
SuiteSparseQR_factorization <double> *QR ;
cholmod_dense *Y ;
Long i ;
double *Bx ;
// factorize once
QR = SuiteSparseQR_factorize <double>
(SPQR_ORDERING_DEFAULT, SPQR_DEFAULT_TOL, A, cc) ;
// solve Ax=b, using the same B as before
// Y = Q'*B
Y = SuiteSparseQR_qmult (SPQR_QTX, QR, B, cc) ;
// X = R\(E*Y)
X = SuiteSparseQR_solve (SPQR_RETX_EQUALS_B, QR, Y, cc) ;
// check the results
check_residual (A, X, B, cc) ;
// free X and Y
cholmod_l_free_dense (&Y, cc) ;
cholmod_l_free_dense (&X, cc) ;
// repeat with a different B
Bx = (double *) (B->x) ;
for (i = 0 ; i < m ; i++)
{
Bx [i] = i ;
}
// Y = Q'*B
Y = SuiteSparseQR_qmult (SPQR_QTX, QR, B, cc) ;
// X = R\(E*Y)
X = SuiteSparseQR_solve (SPQR_RETX_EQUALS_B, QR, Y, cc) ;
// check the results
check_residual (A, X, B, cc) ;
// free X and Y
cholmod_l_free_dense (&Y, cc) ;
cholmod_l_free_dense (&X, cc) ;
// free QR
SuiteSparseQR_free (&QR, cc) ;
}
// -------------------------------------------------------------------------
// free everything that remains
// -------------------------------------------------------------------------
cholmod_l_free_sparse (&A, cc) ;
cholmod_l_free_dense (&B, cc) ;
cholmod_l_finish (cc) ;
return (0) ;
}
