inline static INTEGER f( INTEGER m, double * A,
INTEGER * IPIV, double * WORK,
INTEGER LWORK)
{
INTEGER M = m;
INTEGER N = m;
INTEGER LDA = m;
INTEGER INFO;
DGETRF (&M, &N, A, &LDA, IPIV, &INFO);
if (INFO != 0)
{
printf("Warning: LAPACK routine DGETRF returned non-zero exit status %d.\n",(int)INFO);
}
//SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO );
DGETRI(&M, A, &LDA, IPIV, WORK, &LWORK, &INFO);
if (INFO != 0)
{
printf("Warning: LAPACK routine DGETRI returned non-zero exit status %d.\n",(int)INFO);
}
return INFO;
}
/* Main program */
int main() {
/* Locals */
int n = N, lda = LDA, info;
/* Local arrays */
int ipiv[N];
double a[LDA*N] = {
6.80, -2.11, 5.66, 5.97, 8.23,
-6.05, -3.30, 5.36, -4.44, 1.08,
-0.45, 2.58, -2.70, 0.27, 9.04,
8.32, 2.71, 4.35, -7.17, 2.14,
-9.67, -5.14, -7.26, 6.08, -6.87
};
double b[LDA*N];
cblas_dcopy (LDA*N, a, 1, b, 1);
/* Executable statements */
printf( "LAPACKE_dgetr (column-major, high-level) Example Program Results\n" );
/* Solve the equations A*X = B */
DGETRF(n, n, a, lda, ipiv, &info );
if( info > 0 ) {
printf( "DGETRF failed.\n" );
exit( 1 );
}
DGETRI(n, a, lda, ipiv, &info );
if( info > 0 ) {
printf( "DGETRI failed.\n" );
exit( 1 );
}
double tol = 1e-9;
double c[LDA*N];
cblas_dgemm(CblasColMajor, CblasNoTrans,CblasNoTrans, N, N, N, 1.0, a, N, b, N, 0.0, c, N);
for(int i=0;i<N;++i)
for(int j = 0; j<N; ++j)
if(i==j)
{if (fabs(c[i+N*j]-1.0)>tol) exit(1);}
else
{if (fabs(c[i+N*j]) > tol) exit(1);}
print_matrix("Id?", N,N,b,N);
exit( 0 );
}
void GETRI(const int n , double* A , const int ld,
const int* ipiv, double* work, int lwork, int& info)
{
DGETRI(&n, A, &ld, ipiv, work, &lwork, &info);
}
int extractLCP(NumericsMatrix* MGlobal, double *z , int *indic, int *indicop, double *submatlcp , double *submatlcpop,
int *ipiv , int *sizesublcp , int *sizesublcpop)
{
if (MGlobal == NULL || z == NULL)
numerics_error("extractLCP", "Null input for one arg (problem, z, ...)");
int info;
/* double epsdiag = DBL_EPSILON;*/
/* Extract data from problem */
if (MGlobal->storageType == 1)
numerics_error("extractLCP", "Not yet implemented for sparse storage");
double * M = MGlobal->matrix0;
int sizelcp = MGlobal->size0;
if (M == NULL)
numerics_error("extractLCP", "Null input matrix M");
/* workspace = (double*)malloc(sizelcp * sizeof(double)); */
/* printf("recalcul_submat\n");*/
/* indic = set of indices for which z[i] is positive */
/* indicop = set of indices for which z[i] is null */
/* test z[i] sign */
int i, j = 0, k = 0;
for (i = 0; i < sizelcp; i++)
{
if (z[i] > w[i]) /* if (z[i] >= epsdiag)*/
{
indic[j] = i;
j++;
}
else
{
indicop[k] = i;
k++;
}
}
/* size of the sub-matrix that corresponds to indic */
*sizesublcp = j;
/* size of the sub-matrix that corresponds to indicop */
*sizesublcpop = k;
/* If indic is non-empty, copy corresponding M sub-matrix into submatlcp */
if (*sizesublcp != 0)
{
for (j = 0; j < *sizesublcp; j++)
{
for (i = 0; i < *sizesublcp; i++)
submatlcp[(j * (*sizesublcp)) + i] = M[(indic[j] * sizelcp) + indic[i]];
}
/* LU factorization and inverse in place for submatlcp */
DGETRF(*sizesublcp, *sizesublcp, submatlcp, *sizesublcp, ipiv, info);
if (info != 0)
{
numerics_warning("extractLCP", "LU factorization failed") ;
return 1;
}
DGETRI(*sizesublcp, submatlcp, *sizesublcp, ipiv , info);
if (info != 0)
{
numerics_warning("extractLCP", "LU inversion failed");
return 1;
}
/* if indicop is not empty, copy corresponding M sub-matrix into submatlcpop */
if (*sizesublcpop != 0)
{
for (j = 0; j < *sizesublcp; j++)
{
for (i = 0; i < *sizesublcpop; i++)
submatlcpop[(j * (*sizesublcpop)) + i] = vec[(indic[j] * sizelcp) + indicop[i]];
}
}
}
return 0;
}
int
Matrix::Invert(Matrix &theInverse) const
{
int n = numRows;
#ifdef _G3DEBUG
if (numRows != numCols) {
opserr << "Matrix::Solve(B,X) - the matrix of dimensions [" << numRows << "," << numCols << "] is not square\n";
return -1;
}
if (n != theInverse.numRows) {
opserr << "Matrix::Solve(B,X) - #rows of X, " << numRows<< ", is not same as matrix " << theInverse.numRows << endln;
return -2;
}
#endif
// check work area can hold all the data
if (dataSize > sizeDoubleWork) {
if (matrixWork != 0) {
delete [] matrixWork;
}
matrixWork = new double[dataSize];
sizeDoubleWork = dataSize;
if (matrixWork == 0) {
opserr << "WARNING: Matrix::Solve() - out of memory creating work area's\n";
sizeDoubleWork = 0;
return -3;
}
}
// check work area can hold all the data
if (n > sizeIntWork) {
if (intWork != 0) {
delete [] intWork;
}
intWork = new int[n];
sizeIntWork = n;
if (intWork == 0) {
opserr << "WARNING: Matrix::Solve() - out of memory creating work area's\n";
sizeIntWork = 0;
return -3;
}
}
// copy the data
theInverse = *this;
for (int i=0; i<dataSize; i++)
matrixWork[i] = data[i];
int ldA = n;
int info;
double *Wptr = matrixWork;
double *Aptr = theInverse.data;
int workSize = sizeDoubleWork;
int *iPIV = intWork;
#ifdef _WIN32
#ifndef _DLL
DGETRF(&n,&n,Aptr,&ldA,iPIV,&info);
#endif
#ifdef _DLL
opserr << "Matrix::Solve - not implemented in dll\n";
return -1;
#endif
if (info != 0)
return info;
#ifndef _DLL
DGETRI(&n,Aptr,&ldA,iPIV,Wptr,&workSize,&info);
#endif
#ifdef _DLL
opserr << "Matrix::Solve - not implemented in dll\n";
return -1;
#endif
#else
dgetrf_(&n,&n,Aptr,&ldA,iPIV,&info);
if (info != 0)
return info;
dgetri_(&n,Aptr,&ldA,iPIV,Wptr,&workSize,&info);
#endif
return info;
}
