int InvertMatrix ( double * A, int n){
int INFO;
int N;
static int * IPIV=NULL;
static int LWORK=0;
static double * WORK=NULL;
static int last_n=0;
N = n;
if ( n>last_n){
if (NULL==IPIV){
WORK = malloc(sizeof(double));
} else {
free(IPIV);
}
LWORK = -1;
dgetri_ (&N,A,&N,IPIV,WORK,&LWORK,&INFO);
LWORK=(int)WORK[0];
free(WORK);
WORK = malloc(LWORK*sizeof(double));
IPIV = malloc(n*sizeof(int));
last_n = n;
}
dgetrf_ (&N,&N,A,&N,IPIV,&INFO);
if ( INFO==0){
dgetri_ (&N,A,&N,IPIV,WORK,&LWORK,&INFO);
}
if (INFO!=0)
return -1;
return 0;
}
/* Currently only used as 'support' function for the matrix_det function. */
static void matrix_dgetrf__( matrix_type * A, int * ipiv, int * info) {
int lda = matrix_get_column_stride( A );
int m = matrix_get_rows( A );
int n = matrix_get_columns( A );
dgetrf_( &m , &n , matrix_get_data( A ) , &lda , ipiv , info);
}
//--- Calculation of determinamt ---
double det(const dmatrix &_a)
{
assert( _a.cols() == _a.rows() );
typedef dmatrix mlapack;
mlapack a = _a; // <-
int info;
int n = (int)a.cols();
int lda = n;
std::vector<int> ipiv(n);
#ifdef USE_CLAPACK_INTERFACE
info = clapack_dgetrf(CblasColMajor,
n, n, &(a(0,0)), lda, &(ipiv[0]));
#else
dgetrf_(&n, &n, &a(0,0), &lda, &(ipiv[0]), &info);
#endif
double det=1.0;
for(int i=0; i < n-1; i++)
if(ipiv[i] != i+1) det = -det;
for(int i=0; i < n; i++) det *= a(i,i);
assert(info == 0);
return det;
}
/* on output, A is replaced by A^{-1} */
int
lapack_inverse(gsl_matrix *A)
{
int s = 0;
int M = A->size1;
int N = A->size2;
int lda = N;
int *ipiv;
int lwork;
double *work;
double q[1];
ipiv = malloc(N * sizeof(int));
dgetrf_(&M, &N, A->data, &lda, ipiv, &s);
if (s != 0)
{
fprintf(stderr, "lapack_inverse: error: %d\n", s);
return s;
}
lwork = -1;
dgetri_(&N, A->data, &lda, ipiv, q, &lwork, &s);
lwork = (int) q[0];
work = malloc(lwork * sizeof(double));
/* compute inverse */
dgetri_(&N, A->data, &lda, ipiv, work, &lwork, &s);
free(ipiv);
free(work);
return s;
}
long benchmark(int size) {
int m = sqrt(size);
long requestStart, requestEnd;
// random matrices are full rank (and can always be inverted if square)
// http://www.sciencedirect.com/science/article/pii/S0096300306009040
double* a = random_array(m * m);
int bSize = m * m;
double* b = calloc(bSize, sizeof(double));
int* p = calloc(m, sizeof(int));
int info = 0;
requestStart = currentTimeNanos();
// calling raw fortran because OS X doesn't have LAPACKE
dgetrf_( &m, &m, a, &m, p, &info );
dgetri_( &m, a, &m, p, b, &bSize, &info );
requestEnd = currentTimeNanos();
free(a);
free(b);
free(p);
return (requestEnd - requestStart);
}
void Peer::ros2(double * y, double& tstart, double tend, IContinuous *continuousSystem, ITime *timeSystem) {
double *T=new double[_dimSys*_dimSys];
double *D=new double[_dimSys];
double *k1=new double[_dimSys];
double *k2=new double[_dimSys];
long int *P=new long int[_dimSys];
long int info;
long int dim=1;
double t=tstart;
const double gamma=1.-sqrt(2.)/2.;
char trans='N';
double hu=(tend-tstart)/10.;
for(int count=0; count<10; ++count) {
evalJ(t,y,T,continuousSystem, timeSystem,-hu*gamma);
for(int i=0; i<_dimSys;++ i) T[i*_dimSys+i]+=1.;
dgetrf_(&_dimSys, &_dimSys, T, &_dimSys, P, &info);
evalF(t,y,k1,continuousSystem, timeSystem);
evalD(t,y,D,continuousSystem, timeSystem);
for(int i=0; i<_dimSys;++ i) k1[i]+=gamma*hu*D[i];
dgetrs_(&trans, &_dimSys, &dim, T, &_dimSys, P, k1, &_dimSys, &info);
for(int i=0; i<_dimSys;++ i) y[i]+=hu*k1[i];
evalF(t,y,k2,continuousSystem, timeSystem);
for(int i=0; i<_dimSys;++ i) k2[i]+= hu*gamma*D[i]-2.*k1[i];
dgetrs_(&trans, &_dimSys, &dim, T, &_dimSys, P, k2, &_dimSys, &info);
for(int i=0; i<_dimSys;++ i) y[i]+=0.5*hu*(k1[i]+k2[i]);
}
}
/* returns determinant
Matrix m wil NOT change!
*/
double utr_mat_det(const double *m, int n,char store, double * det)
{
int aux=n,i=0;
int * pivots = malloc(n*sizeof(int));
double * M=malloc(n*n*sizeof(double));
*det=1.0;
if(M!=NULL && pivots != NULL) {
if(store == 'R' || store == 'r') {
int j=0;
for(i=0;i<n;++i) {
for(j=0;j<n;++j) {
M[n*j+i]=m[n*i+j];
}
}
}
else { // 'c' or 'C' column store schema
memcpy(M,m,n*n*sizeof(double));
}
dgetrf_(&n,&n,M,&n,pivots,&aux);
for(i=0; i < n; ++i) {
*det *= M[n*i+i] * (pivots[i]!=(i+1)? -1.0 : 1.0);
}
free(M);
free(pivots);
}
return(*det);
}
void LapackLuDense::prepare() {
double time_start=0;
if (CasadiOptions::profiling && CasadiOptions::profilingBinary) {
time_start = getRealTime(); // Start timer
profileWriteEntry(CasadiOptions::profilingLog, this);
}
prepared_ = false;
// Get the elements of the matrix, dense format
input(0).get(mat_);
if (equilibriate_) {
// Calculate the col and row scaling factors
double colcnd, rowcnd; // ratio of the smallest to the largest col/row scaling factor
double amax; // absolute value of the largest matrix element
int info = -100;
dgeequ_(&ncol_, &nrow_, getPtr(mat_), &ncol_, getPtr(r_),
getPtr(c_), &colcnd, &rowcnd, &amax, &info);
if (info < 0)
throw CasadiException("LapackQrDense::prepare: "
"dgeequ_ failed to calculate the scaling factors");
if (info>0) {
stringstream ss;
ss << "LapackLuDense::prepare: ";
if (info<=ncol_) ss << (info-1) << "-th row (zero-based) is exactly zero";
else ss << (info-1-ncol_) << "-th col (zero-based) is exactly zero";
userOut() << "Warning: " << ss.str() << endl;
if (allow_equilibration_failure_) userOut() << "Warning: " << ss.str() << endl;
else casadi_error(ss.str());
}
// Equilibrate the matrix if scaling was successful
if (info!=0)
dlaqge_(&ncol_, &nrow_, getPtr(mat_), &ncol_, getPtr(r_), getPtr(c_),
&colcnd, &rowcnd, &amax, &equed_);
else
equed_ = 'N';
}
// Factorize the matrix
int info = -100;
dgetrf_(&ncol_, &ncol_, getPtr(mat_), &ncol_, getPtr(ipiv_), &info);
if (info != 0) throw CasadiException("LapackLuDense::prepare: "
"dgetrf_ failed to factorize the Jacobian");
// Success if reached this point
prepared_ = true;
if (CasadiOptions::profiling && CasadiOptions::profilingBinary) {
double time_stop = getRealTime(); // Stop timer
profileWriteTime(CasadiOptions::profilingLog, this, 0, time_stop-time_start,
time_stop-time_start);
profileWriteExit(CasadiOptions::profilingLog, this, time_stop-time_start);
}
}
/* Main function to be called */
void errbars (int numparams, double *p, struct kslice *ks, double **covar)
{
int ii, ij, ik;
lapack_int n, lda, info, worksize;
char c;
double *fish, *work, *rscale, *cscale;
double row, col, amax;
int *piv;
c = 'U';
fish = malloc(numparams*numparams*sizeof(double));
piv = malloc(numparams*numparams*sizeof(int));
rscale = malloc(numparams*sizeof(double));
cscale = malloc(numparams*sizeof(double));
/* compute fisher information matrix */
fisher(numparams, p, ks, fish);
n = numparams;
lda = numparams;
dgeequ_(&n, &n, fish, &lda, rscale, cscale, &row, &col, &amax, &info);
/*
for (ii=0; ii<numparams; ii++)
for (ij=0; ij<numparams; ij++)
fish[ii*numparams+ij] *= rscale[ii]*cscale[ij];
*/
n = numparams;
lda = numparams;
dgetrf_(&n, &n, fish, &lda, piv, &info);
// printf("\tLU decomp status: %d\n", info);
worksize = 32*n;
work = malloc(worksize*sizeof(double));
dgetri_(&n, fish, &lda, piv, work, &worksize, &info);
// printf("\tInversion status: %d\n", info);
/*
for (ii=0; ii<numparams; ii++)
for (ij=0; ij<numparams; ij++)
fish[ii*numparams+ij] *= rscale[ij]*cscale[ii];
*/
/* compute inverse of fisher information matrix */
/*
for (ii=0; ii<numparams; ii++)
{
for (ij=0; ij<numparams; ij++)
printf("%d\t%d\t%e\n", ii, ij, (fish[ii*numparams+ij]));
printf("\n");
}
*/
/* return */
*covar = fish;
/* free local memory */
free(work);
free(piv);
free(rscale);
free(cscale);
}
static long
dgetrf(long M, long N, double *A, long LDA, long *IPIV)
{
extern void dgetrf_(const long *M,const long *N, double *A,const long *LDA,
long *IPIV, long *infop);
long info;
dgetrf_(&M, &N, A, &LDA, IPIV, &info);
return info;
}
void QuasiNewton<double>::symmNonHerDiag(int NTrial, ostream &output){
char JOBVL = 'N';
char JOBVR = 'V';
int TwoNTrial = 2*NTrial;
int *IPIV = new int[TwoNTrial];
int INFO;
RealCMMap SSuper(this->SSuperMem, TwoNTrial,TwoNTrial);
RealCMMap ASuper(this->ASuperMem, TwoNTrial,TwoNTrial);
RealCMMap SCPY(this->SCPYMem, TwoNTrial,TwoNTrial);
RealCMMap NHrProd(this->NHrProdMem,TwoNTrial,TwoNTrial);
SCPY = SSuper; // Copy of original matrix to use for re-orthogonalization
// Invert the metric (maybe not needed?)
dgetrf_(&TwoNTrial,&TwoNTrial,this->SSuperMem,&TwoNTrial,IPIV,&INFO);
dgetri_(&TwoNTrial,this->SSuperMem,&TwoNTrial,IPIV,this->WORK,&this->LWORK,&INFO);
delete [] IPIV;
NHrProd = SSuper * ASuper;
//cout << endl << "PROD" << endl << NHrProd << endl;
dgeev_(&JOBVL,&JOBVR,&TwoNTrial,NHrProd.data(),&TwoNTrial,this->ERMem,this->EIMem,
this->SSuperMem,&TwoNTrial,this->SSuperMem,&TwoNTrial,this->WORK,&this->LWORK,
&INFO);
// Sort eigensystem using Bubble Sort
RealVecMap ER(this->ERMem,TwoNTrial);
RealVecMap EI(this->EIMem,TwoNTrial);
RealCMMap VR(this->SSuperMem,TwoNTrial,TwoNTrial);
// cout << endl << ER << endl;
this->eigSrt(VR,ER);
// cout << endl << ER << endl;
// Grab the "positive paired" roots (throw away other element of the pair)
this->ERMem += NTrial;
new (&ER ) RealVecMap(this->ERMem,NTrial);
new (&SSuper) RealCMMap(this->SSuperMem+2*NTrial*NTrial,2*NTrial,NTrial);
/*
* Re-orthogonalize the eigenvectors with respect to the metric S(R)
* because DSYGV orthogonalzies the vectors with respect to E(R)
* because we solve the opposite problem.
*
* Gramm-Schmidt
*/
this->metBiOrth(SSuper,SCPY);
// Separate the eigenvectors into gerade and ungerade parts
RealCMMap XTSigmaR(this->XTSigmaRMem,NTrial,NTrial);
RealCMMap XTSigmaL(this->XTSigmaLMem,NTrial,NTrial);
XTSigmaR = SSuper.block(0, 0,NTrial,NTrial);
XTSigmaL = SSuper.block(NTrial,0,NTrial,NTrial);
//cout << endl << "ER" << endl << ER << endl << endl;
//cout << endl << "CR" << endl << XTSigmaR << endl << endl;
//cout << endl << "CR" << endl << XTSigmaL << endl << endl;
// CErr();
}
DLLEXPORT MKL_INT d_lu_factor(MKL_INT m, double a[], MKL_INT ipiv[])
{
MKL_INT info = 0;
dgetrf_(&m,&m,a,&m,ipiv,&info);
for(MKL_INT i = 0; i < m; ++i ){
ipiv[i] -= 1;
}
return info;
}
//! build and factorize "real" matrix
//! \param fac1 : we add fac1*I to the Jacobian.
//! \param Jac the jacobian.
inline void decomr(double fac1,MatrixReal& Jac)
{
E1.equal_minus(Jac);
E1.addDiag(fac1);
int nn=n,info;
dgetrf_(&nn,&nn,&E1,&nn,&(ipivr[0]),&info);
if(info!=0)
throw OdesException("odes::Matrices::decomr dgetrf,info=",info);
}
DLLEXPORT int d_lu_factor(int m, double a[], int ipiv[])
{
int info = 0;
dgetrf_(&m,&m,a,&m,ipiv,&info);
for(int i = 0; i < m; ++i ){
ipiv[i] -= 1;
}
return info;
}
/*******************************************************************
Subroutine to compute the Determinant of Matrix
by using CLAPACK subroutine - dgetrf_() ( PLU decomposition:
where P is a permutation matrix, L is lower triangular with unit
diagonal elements (lower trapezoidal if m > n), and U is upper
triangular (upper trapezoidal if m < n))
matrix *A: the pointer to the matrix
return value: the determinant of matrix
*******************************************************************/
double det(matrix *A)
{
integer m, n, lda, info;
int i, j, size;
double *AT;
integer *ipiv;
double detU=1;
int num_permut=0;
m = A->m;
n = A->n;
if (m != n) {
printf(" Warning: det() is failed since the matrix is not square matrix. \n");
return 0;
}
lda = m;
size = m*n;
AT = new double[size];
ipiv = new integer[n];
// to call a Fortran routine from C we have to transform the matrix
for (i=0; i<m; i++) {
for (j=0; j<n; j++) {
AT[n*i+j] = *(A->pr+m*j+i);
}
}
dgetrf_(&m, &n, AT, &lda, ipiv, &info);
if (info < 0) {
printf(" Warning: det() is failed. \n");
}
// the determinant of U
for (i=0; i<n; i++) {
detU *= AT[n*i+i];
}
// the determinant of P is either +1 or -1
// depending of whether the number of row permutations is even or odd.
for (i=0; i<n; i++) {
if (ipiv[i] != i+1) {
num_permut++;
}
}
if (num_permut%2 == 0) {
return detU;
} else {
return -detU;
}
}
int32_t invert_matrix(__CLPK_integer dim, double* matrix, MATRIX_INVERT_BUF1_TYPE* int_1d_buf, double* dbl_2d_buf) {
// dgetrf_/dgetri_ is more efficient than dpotrf_/dpotri_ on OS X.
__CLPK_integer lwork = dim * dim;
__CLPK_integer info;
dgetrf_(&dim, &dim, matrix, &dim, int_1d_buf, &info);
dgetri_(&dim, matrix, &dim, int_1d_buf, dbl_2d_buf, &lwork, &info);
if (info) {
return 1;
}
return 0;
}
LU::LU(const Matrix &mat)
: dcmp(mat),
pivots(std::min(mat.nrow(), mat.ncol())),
sing_(false)
{
int m = mat.nrow();
int n = mat.ncol();
int info;
dgetrf_(&m, &n, dcmp.data(), &m, &pivots[0], &info);
if(info!=0) sing_ = true;
}
template <typename fptype> static inline int
lapack_LU(fptype* a, size_t a_step, int m, fptype* b, size_t b_step, int n, int* info)
{
int lda = a_step / sizeof(fptype), sign = 0;
int* piv = new int[m];
transpose_square_inplace(a, lda, m);
if(b)
{
if(n == 1 && b_step == sizeof(fptype))
{
if(typeid(fptype) == typeid(float))
sgesv_(&m, &n, (float*)a, &lda, piv, (float*)b, &m, info);
else if(typeid(fptype) == typeid(double))
dgesv_(&m, &n, (double*)a, &lda, piv, (double*)b, &m, info);
}
else
{
int ldb = b_step / sizeof(fptype);
fptype* tmpB = new fptype[m*n];
transpose(b, ldb, tmpB, m, m, n);
if(typeid(fptype) == typeid(float))
sgesv_(&m, &n, (float*)a, &lda, piv, (float*)tmpB, &m, info);
else if(typeid(fptype) == typeid(double))
dgesv_(&m, &n, (double*)a, &lda, piv, (double*)tmpB, &m, info);
transpose(tmpB, m, b, ldb, n, m);
delete[] tmpB;
}
}
else
{
if(typeid(fptype) == typeid(float))
sgetrf_(&m, &m, (float*)a, &lda, piv, info);
else if(typeid(fptype) == typeid(double))
dgetrf_(&m, &m, (double*)a, &lda, piv, info);
}
if(*info == 0)
{
for(int i = 0; i < m; i++)
sign ^= piv[i] != i + 1;
*info = sign ? -1 : 1;
}
else
*info = 0; //in opencv LU function zero means error
delete[] piv;
return CV_HAL_ERROR_OK;
}
/* LU decomposition */
void THLapack_(getrf)(int m, int n, real *a, int lda, int *ipiv, int *info)
{
#ifdef USE_LAPACK
#if defined(TH_REAL_IS_DOUBLE)
dgetrf_(&m, &n, a, &lda, ipiv, info);
#else
sgetrf_(&m, &n, a, &lda, ipiv, info);
#endif
#else
THError("getrf : Lapack library not found in compile time\n");
#endif
}
/* solve linear equation -------------------------------------------------------
* solve linear equation (X=A\Y or X=A'\Y)
* args : char *tr I transpose flag ("N":normal,"T":transpose)
* double *A I input matrix A (n x n)
* double *Y I input matrix Y (n x m)
* int n,m I size of matrix A,Y
* double *X O X=A\Y or X=A'\Y (n x m)
* return : status (0:ok,0>:error)
* notes : matirix stored by column-major order (fortran convention)
* X can be same as Y
*-----------------------------------------------------------------------------*/
static int solve(const char *tr, const double *A, const double *Y, integer n,
integer m, double *X)
{
double B[n*n];
integer info;
integer ipiv[n];
memcpy(B, A, sizeof(double)*n*n);
memcpy(X, Y, sizeof(double)*n*m);
dgetrf_(&n,&n,B,&n,ipiv,&info);
if (!info) dgetrs_((char *)tr,&n,&m,B,&n,ipiv,X,&n,&info);
return info;
}
int main(int argc, char** argv) {
char* filename;
FILE *fp;
int m, n, i, info;
double **a;
double det;
int *ipiv;
if (argc < 2) {
fprintf(stderr, "Usage: %s inputfile\n", argv[0]);
exit(1);
}
filename = argv[1];
/* read matrix A from a file */
fp = fopen(filename, "r");
if (fp == NULL) {
fprintf(stderr, "Error: file can not open\n");
exit(1);
}
read_dmatrix(fp, &m, &n, &a);
if (m != n) {
fprintf(stderr, "Error: non-square matrix\n");
exit(1);
}
printf("Matrix A:\n");
fprint_dmatrix(stdout, n, n, a);
/* perform LU decomposition */
ipiv = alloc_ivector(n);
dgetrf_(&n, &n, mat_ptr(a), &n, vec_ptr(ipiv), &info);
if (info != 0) {
fprintf(stderr, "Error: LAPACK::dgetrf failed\n");
exit(1);
}
printf("Result of LU decomposition:\n");
fprint_dmatrix(stdout, n, n, a);
printf("Pivot for LU decomposition:\n");
fprint_ivector(stdout, n, ipiv);
/* calculate determinant */
det = 1.0;
for (i = 0; i < n; ++i) {
det *= mat_elem(a, i, i);
if (ipiv[i] != i+1) det = -det;
}
printf("Determinant of A = %lf\n", det);
free_dmatrix(a);
free_ivector(ipiv);
}
// lapack_square_inverse inverts a square matrix.
// Return codes:
// 0 : no problems
// 1 : make_int failed
// 2 : LU factorization failed
// 3 : inversion failed
int lapack_square_inverse(double *Ai, long m_long, double *A) {
// matrix size
int m;
int info = make_int(&m, m_long);
if (info != 0) return 1;
// copy A into Ai
int i = 0;
for (i=0; i<m*m; ++i) Ai[i] = A[i];
// auxiliary variable
int * ipiv = (int*)malloc(m * sizeof(int));
// factorization
dgetrf_(&m, // M
&m, // N
Ai, // double * A
&m, // LDA
ipiv, // Pivot indices
&info); // INFO
// clean-up and check
if (info != 0) {
free(ipiv);
return 2;
}
// auxiliary variables
int NB = 8; // Optimal blocksize ?
int lwork = m*NB; // Dimension of work >= max(1,m), optimal=m*NB
double * work = (double*)malloc(lwork * sizeof(double)); // Work
// inversion
dgetri_(&m, // N
Ai, // double * A
&m, // LDA
ipiv, // Pivot indices
work, // work
&lwork, // dimension of work
&info); // INFO
// clean up
free(ipiv);
free(work);
// check
if (info != 0) return 3;
return 0;
}
// Interface to lapack routine dgetrf
// mm: nrow of A
// nn: ncol of A
void lapack_dgetrf(int mm, int nn, dreal *AA, int *ipiv)
{
int lda, info;
lda = (1 > mm) ? 1 : mm;
dgetrf_(&mm, &nn, AA, &lda, ipiv, &info);
check(info == 0, "Failed dgetrf, info = %d", info);
return;
error:
abort();
}
/*******************************************************************
Subroutine to compute the Inverse Matrix
by using CLAPACK subroutine - dgetri_() and dgetrf_()
matrix *A: the pointer to the matrix
matrix *InvA: the pointer to the inverse matrix
return value: '1' - successfully exit
'0' - inverse matrix does not exist
*******************************************************************/
int inv(matrix *A, matrix *InvA)
{
integer m, n, lda, lwork, info1, info2, i, j, size;
double *AT;
double *work;
integer *ipiv;
m = A->m;
n = A->n;
if (m != n) {
printf(" Warning: inv() is failed since the matrix is not square matrix. \n");
return 0;
}
lda = m;
lwork = 5*n;
size = m*n;
AT = new double[size];
work = new double[5*n];
ipiv = new integer[n];
// to call a Fortran routine from C we have to transform the matrix
for (i=0; i<m; i++) {
for (j=0; j<n; j++) {
AT[n*i+j] = *(A->pr+m*j+i);
}
}
dgetrf_(&m, &n, AT, &lda, ipiv, &info1);
dgetri_(&n, AT, &lda, ipiv, work, &lwork, &info2);
if ((info1 != 0) || (info2 != 0)) {
printf(" Warning: Inv() is failed. \n");
return 0;
}
// to output a Fortran matrix to C we have to transform the matrix
for (i=0; i<m; i++) {
for (j=0; j<n; j++) {
*(InvA->pr+n*i+j) = AT[m*j+i];
}
}
return 1;
}
DLLEXPORT MKL_INT d_lu_inverse(MKL_INT n, double a[], double work[], MKL_INT lwork)
{
MKL_INT* ipiv = new MKL_INT[n];
MKL_INT info = 0;
dgetrf_(&n,&n,a,&n,ipiv,&info);
if (info != 0){
delete[] ipiv;
return info;
}
dgetri_(&n,a,&n,ipiv,work,&lwork,&info);
delete[] ipiv;
return info;
}
void matrix_invert_inplace(int n, double *A) {
int m = n;
int lda = n;
int info;
int *ipiv = malloc(sizeof(int) * n);
int lwork = n * 512;
double *work = malloc(sizeof(double) * lwork);
/* Make calls to FORTRAN routines */
dgetrf_(&m, &n, A, &lda, ipiv, &info);
dgetri_(&n, A, &lda, ipiv, work, &lwork, &info);
free(ipiv);
free(work);
}
DLLEXPORT int d_lu_inverse(int n, double a[], double work[], int lwork)
{
int* ipiv = new int[n];
int info = 0;
dgetrf_(&n,&n,a,&n,ipiv,&info);
if (info != 0){
delete[] ipiv;
return info;
}
dgetri_(&n,a,&n,ipiv,work,&lwork,&info);
delete[] ipiv;
return info;
}
void
linalg_invert (double *A, int m)
{
int N = m;
int lwork = N * N;
int *ipiv = (int *) malloc (sizeof (int) * (N + 1));
double *work = (double *) malloc (sizeof (double) * lwork);
int info;
dgetrf_ (&N, &N, A, &N, ipiv, &info);
dgetri_ (&N, A, &N, ipiv, work, &lwork, &info);
free (ipiv);
free (work);
}
/* Invert square, real, nonsymmetric matrix. Uses LU decomposition
(LAPACK routines dgetrf and dgetri). Returns 0 on success, 1 on
failure. */
int mat_invert(Matrix *M_inv, Matrix *M) {
#ifdef SKIP_LAPACK
die("ERROR: LAPACK required for matrix inversion.\n");
#else
int i, j;
LAPACK_INT info, n = (LAPACK_INT)M->nrows, ipiv[n], lwork=(LAPACK_INT)n;
LAPACK_DOUBLE tmp[n][n], work[lwork];
if (!(M->nrows == M->ncols && M_inv->nrows == M_inv->ncols &&
M->nrows == M_inv->nrows))
die("ERROR mat_invert: bad dimensions\n");
for (i = 0; i < n; i++)
for (j = 0; j < n; j++)
tmp[i][j] = (LAPACK_DOUBLE)mat_get(M, j, i);
#ifdef R_LAPACK
F77_CALL(dgetrf)(&n, &n, (LAPACK_DOUBLE*)tmp, &n, ipiv, &info);
#else
dgetrf_(&n, &n, (LAPACK_DOUBLE*)tmp, &n, ipiv, &info);
#endif
if (info != 0) {
fprintf(stderr, "ERROR: unable to compute LU factorization of matrix (for matrix inversion); dgetrf returned value of %d.\n", (int)info);
return 1;
}
#ifdef R_LAPACK
F77_CALL(dgetri)(&n, (LAPACK_DOUBLE*)tmp, &n, ipiv, work, &lwork, &info);
#else
dgetri_(&n, (LAPACK_DOUBLE*)tmp, &n, ipiv, work, &lwork, &info);
#endif
if (info != 0) {
if (info > 0)
fprintf(stderr, "ERROR: matrix is singular -- cannot invert.\n");
else
fprintf(stderr, "ERROR: unable to invert matrix. Element %d had an illegal value (according to dgetri).\n", (int)info);
return 1;
}
for (i = 0; i < M->nrows; i++)
for (j = 0; j < M->nrows; j++)
mat_set(M_inv, i, j, (double)tmp[j][i]);
#endif
return 0;
}
void LRTRSR1::HessianEta(Vector *Eta, Vector *result)
{
integer idx;
double *v = new double[Currentlength];
if (ischangedSandY)
{
for (integer i = 0; i < Currentlength; i++)
{
idx = (i + beginidx) % LengthSY;
Mani->ScalerVectorAddVector(x1, -gamma, S[idx], Y[idx], YMGS[i]);
}
for (integer i = 0; i < Currentlength; i++)
{
for (integer j = 0; j < Currentlength; j++)
{
PMGQ[i + j * Currentlength] = SY[i + j * LengthSY] - gamma * SS[i + j * LengthSY];
}
}
if (Currentlength > 0)
{
// compute LU
integer info, CurLen = Currentlength;
dgetrf_(&CurLen, &CurLen, PMGQ, &CurLen, P, &info);
ischangedSandY = false;
}
}
for (integer i = 0; i < Currentlength; i++)
v[i] = Mani->Metric(x1, YMGS[i], Eta);
if (Currentlength > 0)
{
char *trans = const_cast<char *> ("n");
integer info, one = 1, CurLen = Currentlength;
dgetrs_(trans, &CurLen, &one, PMGQ, &CurLen, P, v, &CurLen, &info);
}
Mani->ScaleTimesVector(x1, gamma, Eta, result);
for (integer i = 0; i < Currentlength; i++)
{
Mani->ScalerVectorAddVector(x1, v[i], YMGS[i], result, result);
}
delete[] v;
};
