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; }