static void
ICSolve(const VECTOR_int &pntr, const VECTOR_int &indx,
const VECTOR_double &val, VECTOR_double &dest)
{
int M = dest.size();
VECTOR_double work(M);
int descra[9];
descra[0] = 0;
// lower diag
descra[1] = 1;
descra[2] = 0;
F77NAME(dcscsm) (0, M, 1, 1, NULL, 1.0,
descra, &val(0), &indx(0), &pntr(0),
&dest(0), M, 0.0, &dest(1), M,
&work(0), M);
// lower diag transpose
F77NAME(dcscsm) (1, M, 1, 1, NULL, 1.0,
descra, &val(0), &indx(0), &pntr(0),
&dest(0), M, 0.0, &dest(1), M,
&work(0), M);
}
bool fullMatrix<double>::invert(fullMatrix<double> &result) const
{
int M = size1(), N = size2(), lda = size1(), info;
int *ipiv = new int[std::min(M, N)];
if (result.size2() != M || result.size1() != N) {
if (result._own_data || !result._data)
result.resize(M,N,false);
else
Msg::Fatal("FullMatrix: Bad dimension, I cannot write in proxy");
}
result.setAll(*this);
F77NAME(dgetrf)(&M, &N, result._data, &lda, ipiv, &info);
if(info == 0){
int lwork = M * 4;
double *work = new double[lwork];
F77NAME(dgetri)(&M, result._data, &lda, ipiv, work, &lwork, &info);
delete [] work;
}
delete [] ipiv;
if(info == 0) return true;
else if(info > 0)
Msg::Error("U(%d,%d)=0 in matrix inversion", info, info);
else
Msg::Error("Wrong %d-th argument in matrix inversion", -info);
return false;
}
float dot(const CMRVecs& X,const CMRVecs& Y)
{
int dim(X.dim()),xstride(X.stride()),ystride(Y.stride());
const float *x(X.castToConstArray()),*y(Y.castToConstArray());
#ifndef CRAYCC
return F77NAME(sdot)(&dim, x, &xstride, y, &ystride);
#else
return F77NAME(SDOT)(&dim, x, &xstride, y, &ystride);
#endif
}
void scal(const float& ALPHA, CMRVecs& X)
{
int dim(X.dim()),xstride(X.stride());
float *x(X.castToArray()),alpha(ALPHA);
#ifndef CRAYCC
F77NAME(sscal)(&dim, &alpha, x, &xstride);
#else
F77NAME(SSCAL)(&dim, &alpha, x, &xstride);
#endif
}
void swap(CMRVecs& X, CMRVecs& Y)
{
int dim(X.dim()),xstride(X.stride()),ystride(Y.stride());
float *x(X.castToArray()),*y(Y.castToArray());
#ifndef CRAYCC
F77NAME(sswap)(&dim,x, &xstride,y,&ystride);
#else
F77NAME(SSWAP)(&dim,x, &xstride,y,&ystride);
#endif
}
void rot(CMRVecs& X, CMRVecs& Y, float& C, float& S)
{
int dim(X.dim()),xstride(X.stride()),ystride(Y.stride());
float *x(X.castToArray()),*y(Y.castToArray());
#ifndef CRAYCC
F77NAME(srot)(&dim,x,&xstride,y,&ystride,&C,&S);
#else
F77NAME(SROT)(&dim,x,&xstride,y,&ystride,&C,&S);
#endif
}
int imax(const CMRVecs& X)
{
int dim(X.dim()),xstride(X.stride());
const float *x(X.castToConstArray());
#ifndef CRAYCC
return F77NAME(isamax)(&dim, x, &xstride) - 1 - X.base();
#else
return F77NAME(ISAMAX)(&dim, x, &xstride) - 1 - X.base();
#endif
}
float sum(const CMRVecs& X)
{
int dim(X.dim()),xstride(X.stride());
const float *x(X.castToConstArray());
#ifndef CRAYCC
return F77NAME(sasum)(&dim, x, &xstride);
#else
return F77NAME(SASUM)(&dim, x, &xstride);
#endif
}
float nrm2(const CMRVecs& X)
{
int dim(X.dim()),xstride(X.stride());
const float *x(X.castToConstArray());
#ifndef CRAYCC
return F77NAME(snrm2)(&dim,x,&xstride);
#else
return F77NAME(SNRM2)(&dim,x,&xstride);
#endif
}
void axpy(const float& ALPHA, const CMRVecs& X, CMRVecs& Y)
{
int dim(X.dim()),xstride(X.stride()),ystride(Y.stride());
const float *x(X.castToConstArray()),alpha(ALPHA);
float *y(Y.castToArray());
#ifndef CRAYCC
F77NAME(saxpy)(&dim, &alpha, x, &xstride, y, &ystride);
#else
F77NAME(SAXPY)(&dim, &alpha, x, &xstride, y, &ystride);
#endif
}
void copy(const CMRVecs& X, CMRVecs& Y)
{
int dim(X.dim()),xstride(X.stride()),ystride(Y.stride());
const float *x(X.castToConstArray());
float *y(Y.castToArray());
#ifndef CRAYCC
F77NAME(scopy)(&dim,x, &xstride,y, &ystride);
#else
F77NAME(SCOPY)(&dim,x, &xstride,y, &ystride);
#endif
}
void fullMatrix<double>::multAddy(const fullVector<double> &x, fullVector<double> &y) const
{
int M = _r, N = _c, LDA = _r, INCX = 1, INCY = 1;
double alpha = 1., beta = 1.;
F77NAME(dgemv)("N", &M, &N, &alpha, _data, &LDA, x._data, &INCX,
&beta, y._data, &INCY);
}
void fullMatrix<double>::multWithATranspose(const fullVector<double> &x, double alpha, double beta,fullVector<double> &y) const
{
int M = _r, N = _c, LDA = _r, INCX = 1, INCY = 1;
F77NAME(dgemv)("T", &M, &N, &alpha, _data, &LDA, x._data, &INCX,
&beta, y._data, &INCY);
}
void fullMatrix<std::complex<double> >::scale(const double s)
{
int N = _r * _c;
int stride = 1;
std::complex<double> ss(s, 0.);
F77NAME(zscal)(&N, &ss,_data, &stride);
}
void
AccpmLALinSolve(const RealMatrix &A, bool cholesky, RealMatrix &X, const RealMatrix &B)
{
if (!cholesky) {
AccpmLALinearSolve(A, X, B);
return;
}
char uplo = 'L';
long int n = A.size(0);
long int lda = A.inc(0) * A.gdim(0);
long int nrhs = B.size(1);
long int ldb = B.inc(0) * B.gdim(0);
long int info;
RealMatrix L(A);
X.inject(B);
//double alpha = 1;
//F77NAME(dtrsm)("L","U","T","N",&n,&nrhs,&alpha,&A(0,0),&n,&X(0,0),&n);
//F77NAME(dtrsm)("L","U","N","N",&n,&nrhs,&alpha,&A(0,0),&n,&X(0,0),&n);
//F77NAME(dpotrs)(&uplo, &n, &nrhs, (doublereal *)&L(0,0), &lda, &X(0,0), &ldb, &info);
F77NAME(dpotrs)(&uplo, &n, &nrhs, &L(0,0), &lda, &X(0,0), &ldb, &info);
if (info < 0) {
std::cerr << "AccpmLALinSolve: argument " << -info << " is invalid"
<< std::endl;
}
}
/// \brief BLAS level 1: y = alpha \a x plus \a y
static inline void Daxpy (const int& n, const double& alpha, const Nektar::Array <Nektar::OneD,const double> &x, const int& incx, Nektar::Array<Nektar::OneD,double> &y, const int& incy)
{
ASSERTL1(static_cast<unsigned int>(n*incx) <= x.num_elements()+x.GetOffset(),"Array out of bounds");
ASSERTL1(static_cast<unsigned int>(n*incy) <= y.num_elements()+y.GetOffset(),"Array out of bounds");
F77NAME(daxpy)(n,alpha,&x[0],incx,&y[0],incy);
}
/// \brief Solve a real, Positive definite banded symmetric matrix
/// problem using Cholesky factorization.
static inline void Dpbtrs (const char& uplo, const int& n,
const int& kd, const int& nrhs,
const double *ab, const int& ldab,
double *b, const int& ldb, int& info)
{
F77NAME(dpbtrs) (uplo,n,kd,nrhs,ab,ldab,b,ldb,info);
}
/// \brief Solve packed-banded real matrix eigenproblem.
static inline void Dsbev (const char& jobz, const char& uplo, const int& kl,
const int& ku, double* ap, const int& lda,
double* w, double* z, const int& ldz,
double* work, int& info)
{
F77NAME(dsbev) (jobz, uplo, kl, ku, ap, lda, w, z, ldz, work, info);
}
/// \brief Solve general banded matrix using LU factorisation
static inline void Dgbtrs (const char& trans, const int& n, const int& kl,
const int &ku, const int& nrhs, const double* a,
const int& lda, const int* ipiv, double* b,
const int& ldb, int& info)
{
F77NAME(dgbtrs)(trans,n,kl,ku,nrhs,a,lda,ipiv,b,ldb,info);
}
void fullMatrix<double>::scale(const double s)
{
int N = _r * _c;
int stride = 1;
double ss = s;
F77NAME(dscal)(&N, &ss,_data, &stride);
}
void fullMatrix<std::complex<double> >::mult(const fullVector<std::complex<double> > &x,
fullVector<std::complex<double> > &y) const
{
int M = _r, N = _c, LDA = _r, INCX = 1, INCY = 1;
std::complex<double> alpha = 1., beta = 0.;
F77NAME(zgemv)("N", &M, &N, &alpha, _data, &LDA, x._data, &INCX,
&beta, y._data, &INCY);
}
void fullMatrix<double>::multOnBlock(const fullMatrix<double> &b, const int ncol, const int fcol, const int alpha_, const int beta_, fullVector<double> &c) const
{
int M = 1, N = ncol, K = b.size1() ;
int LDA = _r, LDB = b.size1(), LDC = 1;
double alpha = alpha_, beta = beta_;
F77NAME(dgemm)("N", "N", &M, &N, &K, &alpha, _data, &LDA, &(b._data[fcol*K]), &LDB,
&beta, &(c._data[fcol]), &LDC);
}
void fullMatrix<std::complex<double> >::setAll(const fullMatrix<std::complex<double > > &m)
{
if (_r != m._r || _c != m._c )
Msg::Fatal("fullMatrix size does not match");
int N = _r * _c;
int stride = 1;
F77NAME(zcopy)(&N, m._data, &stride, _data, &stride);
}
void fullMatrix<double>::mult(const fullMatrix<double> &b, fullMatrix<double> &c) const
{
int M = c.size1(), N = c.size2(), K = _c;
int LDA = _r, LDB = b.size1(), LDC = c.size1();
double alpha = 1., beta = 0.;
F77NAME(dgemm)("N", "N", &M, &N, &K, &alpha, _data, &LDA, b._data, &LDB,
&beta, c._data, &LDC);
}
bool fullMatrix<double>::luFactor(fullVector<int> &ipiv)
{
int M = size1(), N = size2(), lda = size1(), info;
ipiv.resize(std::min(M, N));
F77NAME(dgetrf)(&M, &N, _data, &lda, &ipiv(0), &info);
if(info == 0) return true;
return false;
}
void fullMatrix<double>::gemm(const fullMatrix<double> &a, const fullMatrix<double> &b,
double alpha, double beta, bool transposeA, bool transposeB)
{
int M = size1(), N = size2(), K = transposeA ? a.size1() : a.size2();
int LDA = a.size1(), LDB = b.size1(), LDC = size1();
F77NAME(dgemm)(transposeA ? "T" : "N", transposeB ? "T" :"N", &M, &N, &K, &alpha, a._data, &LDA, b._data, &LDB,
&beta, _data, &LDC);
}
void
AccpmGenMatrix::scale(double scale)
{
integer n = size(0)*size(1);
integer inc = 1;
F77NAME(dscal)(&n, &scale, addr(), &inc);
}
void
AccpmGenMatrix::addMult(double scale, const AccpmGenMatrix &b)
{
assert(size(0) == b.size(0));
assert(size(1) == b.size(1));
integer n = size(0)*size(1);
integer inc = 1;
F77NAME(daxpy)(&n, &scale, b.addr(), &inc, addr(), &inc);
}
/// \brief Solve general real matrix eigenproblem.
static inline void Dgeev (const char& uplo, const char& lrev, const int& n,
const double* a, const int& lda, double* wr, double* wi,
double* rev, const int& ldr,
double* lev, const int& ldv,
double* work, const int& lwork, int& info)
{
F77NAME(dgeev) (uplo, lrev, n, a, lda, wr, wi, rev,
ldr, lev, ldv, work, lwork, info);
}
bool fullMatrix<double>::luSubstitute(const fullVector<double> &rhs, fullVector<int> &ipiv, fullVector<double> &result)
{
int N = size1(), nrhs=1, lda = N, ldb = N, info;
char trans = 'N';
for(int i = 0; i < N; i++) result(i) = rhs(i);
F77NAME(dgetrs)(&trans, &N, &nrhs, _data, &lda, &ipiv(0), result._data, &ldb, &info);
if(info == 0) return true;
return false;
}
