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;
}
int scatter_junction::compute_scattering (double const *norms)
{
int na = 0, nt = 0;
const short *matrix = incidence_matrix(na, nt);
double system[max_dim][max_dim];
int n = na + nt;
for (unsigned i = 0; i < n; ++i) {
for (unsigned j = 0; j < na; ++j)
scatter[i][j] = -(system[i][j] = matrix[j * n + i] * norms[i]);
for (unsigned j = na; j < n; ++j)
scatter[i][j] = +(system[i][j] = matrix[j * n + i] / norms[i]);
}
int info = 0;
#ifdef HAVE_LAPACK
int pivot[max_dim];
dgesv_(n, n, &system[0][0], max_dim, &pivot[0], &scatter[0][0], max_dim, info);
#else
for (unsigned k = 0; k < n - 1; ++k) {
double max = 0;
int p = k;
for (unsigned i = k; i < n; ++i)
if (std::abs(system[k][i]) > max) {
max = std::abs(system[k][i]);
p = i;
}
if (max == 0) { // singular matrix
info = k + 1;
break;
}
for (unsigned i = 0; i < n; ++i) {
std::swap(system[i][k], system[i][p]);
std::swap(scatter[i][k], scatter[i][p]);
}
for (unsigned i = k + 1; i < n; ++i) {
system[k][i] /= system[k][k];
for (unsigned j = k + 1; j < n; ++j)
system[j][i] -= system[k][i] * system[j][k];
}
}
if (!info) {
for (unsigned k = 0; k < n; ++k) {
for (unsigned i = 0; i < n; ++i) {
for (unsigned j = 0; j < i; ++j)
scatter[k][i] -= system[j][i] * scatter[k][j];
}
for (unsigned i = n - 1; i < n; --i) {
for (unsigned j = i + 1; j < n; ++j)
scatter[k][i] -= system[j][i] * scatter[k][j];
scatter[k][i] /= system[i][i];
}
}
}
#endif
if (info < 0) {
std::cerr << "Error in scatter junction: invalid argument " << -info << std::endl;
} else if (info > 0) {
std::cerr << "Error in scatter junction: singularity detected!" << std::endl;
} else return n;
return 0;
}
/*! solve A*X=Y using dgesv\n
The argument is dgematrix Y. Y is overwritten and become the solution X.
A is also overwritten and become P*L*U.
*/
inline long dgematrix::dgesv(dgematrix& mat)
{
#ifdef CPPL_VERBOSE
std::cerr << "# [MARK] dgematrix::dgesv(dgematrix&)"
<< std::endl;
#endif//CPPL_VERBOSE
#ifdef CPPL_DEBUG
if(M!=N || M!=mat.M){
std::cerr << "[ERROR] dgematrix::dgesv(dgematrix&) " << std::endl
<< "These two matrices cannot be solved." << std::endl
<< "Your input was (" << M << "x" << N << ") and ("
<< mat.M << "x" << mat.N << ")." << std::endl;
exit(1);
}
#endif//CPPL_DEBUG
long NRHS(mat.N), LDA(N), *IPIV(new long[N]), LDB(mat.M), INFO(1);
dgesv_(N, NRHS, Array, LDA, IPIV, mat.Array, LDB, INFO);
delete [] IPIV;
if(INFO!=0){
std::cerr << "[WARNING] dgematrix::dgesv(dgematrix&) "
<< "Serious trouble happend. INFO = " << INFO << "."
<< std::endl;
}
return INFO;
}
/* Solve an n x n system */
void dgesv_driver(int n, double *A, double *b, double *x) {
double *Atmp = malloc(sizeof(double) * n * n);
double *btmp = malloc(sizeof(double) * n);
int nrhs = 1;
int lda = n;
int ldb = n;
int *ipiv = calloc(sizeof(int), n);
int info;
int i, j;
/* Go from row- to column-major */
for (i = 0; i < n; i++)
for (j = 0; j < n; j++)
Atmp[j * n + i] = A[i * n + j];
for (i = 0; i < n; i++)
btmp[i] = b[i];
/* Make the FORTRAN call */
dgesv_(&n, &nrhs, Atmp, &lda, ipiv, btmp, &ldb, &info);
if (info != 0)
printf("Error [%d] in call to dgesv\n", info);
/* Go from column- to row-major */
for (i = 0; i < n; i++)
x[i] = btmp[i];
free(Atmp);
free(btmp);
free(ipiv);
}
/// @brief Computes saturation from surface volume
void computeSaturation(const BlackoilPropertiesInterface& props,
BlackoilState& state)
{
const int np = props.numPhases();
const int nc = props.numCells();
std::vector<double> allA(nc*np*np);
std::vector<int> allcells(nc);
for (int c = 0; c < nc; ++c) {
allcells[c] = c;
}
//std::vector<double> res_vol(np);
const std::vector<double>& z = state.surfacevol();
props.matrix(nc, &state.pressure()[0], &z[0], &allcells[0], &allA[0], 0);
// Linear solver.
MAT_SIZE_T n = np;
MAT_SIZE_T nrhs = 1;
MAT_SIZE_T lda = np;
std::vector<MAT_SIZE_T> piv(np);
MAT_SIZE_T ldb = np;
MAT_SIZE_T info = 0;
//double res_vol;
double tot_sat;
const double epsilon = std::sqrt(std::numeric_limits<double>::epsilon());
for (int c = 0; c < nc; ++c) {
double* A = &allA[c*np*np];
const double* z_loc = &z[c*np];
double* s = &state.saturation()[c*np];
for (int p = 0; p < np; ++p){
s[p] = z_loc[p];
}
dgesv_(&n, &nrhs, &A[0], &lda, &piv[0], &s[0], &ldb, &info);
tot_sat = 0;
for (int p = 0; p < np; ++p){
if (s[p] < epsilon) // saturation may be less then zero due to round of errors
s[p] = 0;
tot_sat += s[p];
}
for (int p = 0; p < np; ++p){
s[p] = s[p]/tot_sat;
}
}
}
int
mad_mat_div (const num_t x[], const num_t y[], num_t r[], ssz_t m, ssz_t n, ssz_t p, num_t rcond)
{
CHKXYR;
int info=0;
const int nm=m, nn=n, np=p;
mad_alloc_tmp(num_t, a, n*p);
mad_vec_copy(y, a, n*p);
// square system (y is square, n == p), use LU decomposition
if (n == p) {
int ipiv[n];
mad_vec_copy(x, r, m*p);
dgesv_(&np, &nm, a, &np, ipiv, r, &np, &info);
if (!info) return mad_free_tmp(a), n;
}
// non-square system or singular square system, use QR or LQ factorization
num_t sz;
int rank, ldb=MAX(nn,np), lwork=-1; // query for optimal size
int JPVT[nn]; memset(JPVT, 0, sizeof JPVT);
mad_alloc_tmp(num_t, rr, ldb*nm);
mad_mat_copy(x, rr, m, p, p, ldb); // input strided copy [M x NRHS]
dgelsy_(&np, &nn, &nm, a, &np, rr, &ldb, JPVT, &rcond, &rank, &sz, &lwork, &info); // query
mad_alloc_tmp(num_t, wk, lwork=sz);
dgelsy_(&np, &nn, &nm, a, &np, rr, &ldb, JPVT, &rcond, &rank, wk, &lwork, &info); // compute
mad_mat_copy(rr, r, m, n, ldb, n); // output strided copy [N x NRHS]
mad_free_tmp(wk); mad_free_tmp(rr); mad_free_tmp(a);
if (info < 0) error("invalid input argument");
if (info > 0) error("unexpect lapack error");
return rank;
}
int dgesv (int n, double *a, int *piv, double *b)
{
int info, one = 1;
dgesv_(&n, &one, a, &n, piv, b, &n, &info);
assert(info >= 0);
return info;
}
void
SolverUnconstrained<Data,Problem>::lambda_LS( vector_type & _x, vector_type & _lambda_l, vector_type & _lambda_u )
{
//symmetric_matrix_type __A ( _E_nL, _E_nL );
matrix_type __A ( _E_nL, _E_nL );
vector_type __b ( _E_nL );
// At = [ -I (l-x) 0; I 0 (x-u) ] --> AtA = [ I+(l-x)^2 -I; -I I+(x-u)^2 ]
__A = zero_matrix<double>( _E_nL, _E_nL );
for ( int __i = 0; __i < _E_n; ++__i )
{
__A( __i, __i ) = 1.0 + ( M_prob.x_l( __i )-_x ( __i ) )*( M_prob.x_l( __i )-_x ( __i ) );
__A( __i, _E_n+__i ) = -1.0;
__A( _E_n+__i,__i ) = -1.0;
__A( ( _E_n+__i ), _E_n+__i ) = 1.0+( _x ( __i )-M_prob.x_u( __i ) )*( _x ( __i )-M_prob.x_u( __i ) );
}
// b = [ \nabla f; 0; 0 ] --> Atb = [ -\nabla f; \nabla f ]
f_type __f_x;
M_prob.evaluate( _x, __f_x, diff_order<1>() );
for ( int i = 0; i < _E_n; i++ )
{
value_type val = __f_x.gradient( 0, i );
__b ( i ) = val;
__b ( _E_n+i ) = -val;
}
// after solve __b = [ _lambda_l; _lambda_] = A\b
//char __uplo = 'U';
int __info = 0;
int __nrhs = 1;
int __N = _E_nL;
//dppsv_ ( &__uplo, &__N, &__nrhs, __A.data(), __b.data(), &__ldb, &__info );
//dppsv_ ( &__uplo, &__N, &__nrhs, __A.data().begin(), __b.data().begin(), &__N, &__info );
ublas::vector<int> __itype( __N );
//dspsv_( &__uplo, &__N, &__nrhs, __A.data().begin(), __itype.data().begin(), __b.data().begin(), &__N, &__info );
dgesv_( &__N,&__nrhs,__A.data().begin(),&__N,__itype.data().begin(),__b.data().begin(),&__N,&__info );
if ( __info!= 0 )
{
std::ostringstream __err;
__err << "[" << __PRETTY_FUNCTION__ << "] dppsv failed: " << __info << "\n"
<< "A = " << __A << "\n"
<< "B = " << __b << "\n";
throw std::out_of_range( __err.str() );
}
for ( int i = 0; i < _E_n; i++ )
{
_lambda_l ( i ) = __b ( i );
_lambda_u ( i ) = __b ( _E_n+i );
}
}
/// Solve system of linear equations A X = B using CLAPACK routines.
void quantfin::interfaceCLAPACK::SolveLinear(const Array<double,2>& A,Array<double,2>& X,const Array<double,2>& B)
{
int i,j;
long int n = A.rows();
if (n!=A.columns()) throw(std::logic_error("Array must be square"));
long int nrhs = B.columns();
double* ap = new double[n*n];
double* pos = ap;
for (i=0;i<n;i++) {
for (j=0;j<n;j++) *pos++ = A(j,i); }
double* bp = new double[nrhs*n];
pos = bp;
for (i=0;i<nrhs;i++) {
for (j=0;j<n;j++) *pos++ = B(j,i); }
long int* ipiv = new long int[n];
long int info = 0;
dgesv_(&n,&nrhs,ap,&n,ipiv,bp,&n,&info);
if (!info) {
pos = bp;
for (i=0;i<nrhs;i++) {
for (j=0;j<n;j++) X(j,i) = *pos++; }}
delete[] ap;
delete[] bp;
delete[] ipiv;
if (info) throw(std::logic_error("Linear equation solve failed"));
}
void MatInvF(double **mat, int n, double **mati, int *pcode){
double *APTF, *BPTF;
int *pivot, code, i, j;
APTF = (double *) calloc(n*n, sizeof(double));
BPTF = (double *) calloc(n*n, sizeof(double));
pivot = (int *)calloc(n , sizeof(int));
for(i=0;i<n;i++)
for(j=0;j<n;j++){
APTF[j*n + i] = mat[i][j];
if(i == j) BPTF[j*n + i] = 1.0;
}
dgesv_(&n,&n,APTF,&n,pivot,BPTF,&n,&code);
//for(i=0;i<n;i++) Rprintf("%d ", pivot[i]);
for(i=0;i<n;i++)
for(j=0;j<n;j++){
mati[i][j] = BPTF[j*n + i];
}
//if(code != 0) Rprintf(" INVERSION PROBLEM ",code);
pcode[0] = code;
free(APTF);
free(BPTF);
free(pivot);
}
void LaLinearSolveRHS(int hn, double * A, double * F)
{
// Solve linear system A x = F for 1 rhs
// A on exit LU factorization
// F is overwritten by solution x
integer n = hn;
integer nrhs = 1;
integer *ipiv;
ipiv = new integer[n];
integer info;
dgesv_(&n, &nrhs, A, &n, ipiv, F, &n, &info );
if(info!=0)
cout << " ***** Error in LapackGEP.cpp LaLinearSolveComplex : info = " << info << endl;
delete[] ipiv;
return;
}
// This routine modifies the contents both of the "host" matrix
// and the passed-in rhs.
int SmallMatrix::solve(SmallMatrix &rhs) {
int info;
if(nrows==ncols) {
if(nrows==rhs.nrows) {
int *ipiv = new int[nrows];
dgesv_(&nrows, &rhs.ncols, data, &nrows,
ipiv, rhs.data, &rhs.nrows, &info);
delete[] ipiv;
return info; // Result is encoded in the rhs.
}
else {
throw ErrProgrammingError("Cannot solve SmallMatrix, matrix is " +
intstring(nrows) + "x" + intstring(ncols) +
", RHS is of size " +
intstring(rhs.nrows) + ".",
__FILE__, __LINE__);
}
}
else {
throw ErrProgrammingError("Cannot solve non-square " +
intstring(nrows) + " by " +
intstring(ncols) + " SmallMatrix.",
__FILE__, __LINE__);
}
}
int solveLinearEquationLU(dmatrix a, const dmatrix &b, dmatrix &out_x)
{
assert(a.rows() == a.cols() && a.cols() == b.rows() );
out_x = b;
const int n = (int)a.rows();
const int nrhs = (int)b.cols();
int info;
std::vector<int> ipiv(n);
#ifndef USE_CLAPACK_INTERFACE
int lda = n;
int ldb = n;
dgesv_(&n, &nrhs, &(a(0,0)), &lda, &(ipiv[0]), &(out_x(0,0)), &ldb, &info);
#else
info = clapack_dgesv(CblasColMajor,
n, nrhs, &(a(0,0)), n,
&(ipiv[0]),
&(out_x(0,0)),
n);
#endif
assert(info == 0);
return info;
}
int efp_dgesv(int n, int nrhs, double *a, int lda, int *ipiv, double *b, int ldb)
{
int info;
dgesv_(&n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
return (info);
}
void la_dgesv(int Arow, int Bcol, double **A, double **B)
{
int info;
int *ip = new_ivec(Arow); /* pivot indices which define P;
row i was interchanged with row ip[i]*/
dgesv_(&Arow, &Bcol, *A, &Arow, ip, *B, &Arow, &info);
assert(info==0); // if info = -i, i'th arg is wrong. if info > 0, A is not pos-def.
}
void calcstep(int m, int n, double *A, double *B, double *s, double *y,
double *r1, double *r2, double r3, double *r4, double *dx,
double *ds, double *dt, double *dy) {
char Transpose = 'T';
char Normal = 'N';
int n1 = n + 1;
int oneI = 1;
double none = -1.0;
double one = 1.0;
int info;
int i;
int *myworkI;
double *dxdt;
double *tmp;
double *tmpB;
tmp = pswarm_malloc(m * sizeof(double));
dxdt = pswarm_malloc(n1 * sizeof(double));
memset(dxdt, 0, n1 * sizeof(double));
dxdt[n] = 0.0;
for (i = 0; i < m; i++) {
tmp[i] = (r1[i] * y[i] - r4[i]) / s[i];
dxdt[n] += tmp[i];
}
memcpy(dxdt, r2, n * sizeof(double));
dgemv_(&Transpose, &m, &n, &one, A, &m, tmp, &oneI, &one, dxdt, &oneI);
/* dpotrs_(&Upper, &n1, &oneI, B, &n1, dxdt, &n1, &info); */
free(tmp);
tmpB = pswarm_malloc(n1 * n1 * sizeof(double));
myworkI = pswarm_malloc(n1 * sizeof(int));
memcpy(tmpB, B, n1 * n1 * sizeof(double));
dgesv_(&n1, &oneI, tmpB, &n1, myworkI, dxdt, &n1, &info);
memcpy(dx, dxdt, n * sizeof(double));
*dt = dxdt[n];
memcpy(ds, r1, m * sizeof(double));
dgemv_(&Normal, &m, &n, &none, A, &m, dx, &oneI, &one, ds, &oneI);
for (i = 0; i < m; i++) {
ds[i] -= (*dt);
dy[i] = (r4[i] - y[i] * ds[i]) / s[i];
}
free(myworkI);
free(dxdt);
free(tmpB);
}
void solve_(int B, int C, double*& D, int E, int* F, double* G, int H, int I){
double* tD = new double[B * B];
for(int i = 0; i < B; i++){
for(int j = 0; j < B; j++){
tD[j * B + i] = D[j * B + i];
}
}
dgesv_(&B, &C, tD, &E, F, G, &H, &I);
delete [] tD;
}
void THLapack_(gesv)(int n, int nrhs, real *a, int lda, int *ipiv, real *b, int ldb, int* info)
{
#ifdef USE_LAPACK
#if defined(TH_REAL_IS_DOUBLE)
dgesv_(&n, &nrhs, a, &lda, ipiv, b, &ldb, info);
#else
sgesv_(&n, &nrhs, a, &lda, ipiv, b, &ldb, info);
#endif
#else
THError("gesv : Lapack library not found in compile time\n");
#endif
return;
}
int main (){
int i, j, info2;
int N, NRHS, LDA, LDB;
double *A;
double *B;
static int IPIV[NDIM], INFO;
A = (double*) malloc(NDIM*NDIM*sizeof(double));
B = (double*) malloc(NDIM*sizeof(double));
N=NDIM; NRHS=1; LDA=NDIM; LDB=NDIM;
A[0] = 1.0;
A[4] = -1.0;
A[8] = 2.0;
A[12] = -1.0;
A[1] = 2.0;
A[5] = -2.0;
A[9] = 3.0;
A[13] = -3.0;
A[2] = 1.0;
A[6] = 1.0;
A[10] = 1.0;
A[14] = 0.0;
A[3] = 1.0;
A[7] = -1.0;
A[11] = 4.0;
A[15] = 3.0;
for (i=0;i<N;i++){
for (j=0;j<N;j++) {
printf(" %f \n",A[i+N*j]);
}
}
B[0] = -8.0;
B[1] = -20.0;
B[2] = -2.0;
B[3] = 4.0;
dgesv_(&N, &NRHS, A, &LDA, IPIV, B, &LDB, &INFO);
printf("info %d \n",INFO);
for (i=0;i<N;i++)
printf(" %lf \n",B[i]);
}
static PyObject *solve_(PyObject *self, PyObject *args)
{
PyArrayObject *A, *B, *pivots;
int n, nrhs, lda, ldb, info = 0;
extern void dgesv_(int* n, int* nrhs, double * A,
int* lda, int* ipiv, double *B,
int *ldb, int* info);
if (!PyArg_ParseTuple(args, "O!O!O!",
&PyArray_Type, &A,
&PyArray_Type, &B,
&PyArray_Type, &pivots)) return NULL;
if ( (NULL == A) || (NULL == B) || (NULL == pivots) ) return NULL;
if ( (A->descr->type_num != NPY_DOUBLE) ||
(B->descr->type_num != NPY_DOUBLE) ||
(pivots->descr->type_num != NPY_INT) ||
!PyArray_CHKFLAGS(A,NPY_F_CONTIGUOUS|NPY_ALIGNED|NPY_WRITEABLE) ||
!PyArray_CHKFLAGS(B,NPY_F_CONTIGUOUS|NPY_ALIGNED|NPY_WRITEABLE) ||
!PyArray_CHKFLAGS(pivots,NPY_F_CONTIGUOUS|NPY_ALIGNED|NPY_WRITEABLE) ) {
PyErr_SetString(PyExc_ValueError,
"In solve: some arguments are of invalid type");
return NULL;
}
n = A->dimensions[0];
nrhs = B->dimensions[1];
lda = n;
ldb = B->dimensions[0];
dgesv_(&n, &nrhs, (double *) A->data, &lda, (int *) pivots->data,
(double *) B->data, &ldb, &info);
if ( info < 0 )
{
/* Argument "-info" has illegal value */
PyErr_SetString(PyExc_ValueError,
"In solve: dgesv error, one of the arguments has illegal value");
return NULL;
}
else if (info > 0 )
{
PyErr_SetString(PyExc_ValueError,
"In solve: dgesv error, solution could not be computed for value of A");
return NULL;
}
Py_RETURN_NONE;
}
inline void
xgesv_call( xgesv_params< double >& p )
{
dgesv_(
&p.n,
&p.nrhs,
p.a,
&p.lda,
p.ipiv,
p.b,
&p.ldb,
&p.info
);
}
int main(void)
{
static int i;
static long int n=N,inc=1,info,piv[N];
A[0]=1.; A[1]=3.; A[2]=1.;
A[3]=1.; A[4]=1.;A[5]=-2.;
A[6]=1.; A[7]=-3.;A[8]=-5.;
x[0]=3.; x[1]=1.; x[2]=-6.;
printf("N = %d\n",N);
dgesv_(&n,&inc,A,&n,piv,x,&n,&info);
for(i=0; i<N; ++i) printf("%lf\n", x[i]);
return(0);
}
void THLapack_(gesv)(int n, int nrhs, real *a, int lda, int *ipiv, real *b, int ldb, int* info)
{
#ifdef USE_LAPACK
#if defined(TH_REAL_IS_DOUBLE)
extern void dgesv_(int *n, int *nrhs, double *a, int *lda, int *ipiv, double *b, int *ldb, int *info);
dgesv_(&n, &nrhs, a, &lda, ipiv, b, &ldb, info);
#else
extern void sgesv_(int *n, int *nrhs, float *a, int *lda, int *ipiv, float *b, int *ldb, int *info);
sgesv_(&n, &nrhs, a, &lda, ipiv, b, &ldb, info);
#endif
#else
THError("gesv : Lapack library not found in compile time\n");
#endif
return;
}
int main()
{
FILE *fp;
int i,info,lda=5,ldb=5,N=5,NRHS=1,ipiv[5];
double A[25],b[5];
fp=fopen("matrix.txt","r");
for (i=0;i<25;i++)
fscanf(fp,"%lf",&A[i]);
for (i=0;i<5;i++)
fscanf(fp,"%lf",&b[i]);
dgesv_(&N,&NRHS,A,&lda,ipiv,b,&ldb,&info);
printf("Return status: %d\n",info);
for (i=0;i<N;i++)
printf("%f\n",b[i]);
return(0);
}
//************************************************
Arr Arr::operator/(const Arr& obj){
//---------------------------------------------//
// Matrix solution to Y=M*X
//---------------------------------------------//
int NRHS = obj.N;
int NLHS = obj.M;
int *IPIV = new int[N+1];
int INFO;
//Create temporary variables so the fortran code doesn't change
//input variables
double A_tmp[M*N];for(int ii =0;ii<M*N;ii++){A_tmp[ii]=val[ii];}
double B_rtn[obj.N*obj.M];for(int ii =0;ii<obj.N*obj.M;ii++){B_rtn[ii]=obj.val[ii];}
dgesv_(&NLHS,&NRHS,A_tmp,&NLHS,IPIV,B_rtn,&N,&INFO);
delete [] IPIV;
return Arr (B_rtn,obj.M,obj.N);
}
void matrix_dgesv(matrix_type * A , matrix_type * B) {
matrix_lapack_assert_square( A );
matrix_lapack_assert_fortran_layout( B );
{
int n = matrix_get_rows( A );
int lda = matrix_get_column_stride( A );
int ldb = matrix_get_column_stride( B );
int nrhs = matrix_get_columns( B );
long int * ipivot = util_calloc( n , sizeof * ipivot );
int info;
dgesv_(&n , &nrhs , matrix_get_data( A ) , &lda , ipivot , matrix_get_data( B ), &ldb , &info);
if (info != 0)
util_abort("%s: low level lapack routine: dgesv() failed with info:%d \n",__func__ , info);
free(ipivot);
}
}
void solve_matrix(){
//double A[9] = {76, 27, 18, 25, 89, 60, 11, 51, 32};
//double b[3] = {10, 7, 43};
int N = n;
int nrhs = 1;
int lda = n;
int ipiv[n];
int ldb = n;
int info;
dgesv_(&N, &nrhs, C, &lda, ipiv, V, &ldb, &info);
if(info!=0) {
fprintf(stderr, "dgesv_ fails %d\n", info);
exit(5);
}
/* solution is in V */
}
double bilinear_interpolation(double x1, double x2, double x3, double x4, double y1, double y2,
double y3, double y4, double f1, double f2, double f3, double f4, double xin, double yin) {
// P=a0+a1*x+a2*y+a3*x*y
// Ab=x
// [1,x0,y0,x0y0][a0] [phi0]
// [1,x1,y1,x1y1][a1] [phi1]
// [1,x2,y2,x2y2][a2]=[phi2]
// [1,x3,y3,x3y3][a3] [phi3]
int dim = 4, one = 1, info, ipiv[dim];
double A[dim * dim], x[] = { x1, x2, x3, x4 }, y[] = { y1, y2, y3, y4 }, coef[] =
{ f1, f2, f3, f4 };
if (f1 == 0. && f2 == 0. && f3 == 0. && f4 == 0.)
return 0.;
else {
for (int i = 0; i < dim; ++i) {
A[i] = 1;
A[i + 4] = x[i];
A[i + 8] = y[i];
A[i + 12] = x[i] * y[i];
}
// cout << "Matrix A and vector phi" << endl;
// for (int i = 0; i < dim; ++i) {
// cout << "[ " << A[i] << " , " << A[i + 4] << " , " << A[i + 8] << " , " << A[i + 12] << " ]";
// cout << "[ " << phi[i] << " ]" << endl;
// }
dgesv_(&dim, &one, A, &dim, ipiv, coef, &dim, &info);
if (info != 0)
cout << "solution is not correct " << info << endl;
return coef[0] + coef[1] * xin + coef[2] * yin + coef[3] * xin * yin;
}
// cout << "Solution" << endl;
// for (int i = 0; i < dim; ++i)
// cout << "[ " << phi[i] << " ]" << endl;
}
static int solve_SE()
{
int ierr=0, i;
#ifdef LAPACK
int N = nMem+2, NRHS=1, LDA=nMem+2, LDB=nMem+2, INFO;
int dgesv_(int *n, int *nrhs, double *a, int *lda,
int *ipiv, double *b, int *ldb, int *info);
#else
int GaussJ(double **, int, double *, int);
#endif
#ifdef LAPACK
ierr = dgesv_(&N, &NRHS, H1, &LDA, IPIV, rhs, &LDB, &INFO);
if (INFO != 0) {
fprintf(stderr, "%s: Internal error %d in dgesv_()\n", PKGNAME, INFO);
return INFO;
}
#else
ierr = GaussJ(H, nMem+2, rhs, 0);
if (ierr != 0) {
fprintf(stderr, "%s: Internal error %d in GaussJ()\n", PKGNAME, ierr);
return ierr;
}
#endif
s_df_old = s_df;
s_df = 0.0;
for (i=0; i<nMem+2; i++) {
f_old[i] = f[i];
if (f[i] != 0.0) s_df += fabs(rhs[i]/f[i]);
if (i < nMem && f[i] + rhs[i] <= 0.0) {
f[i] /= 10.0;
} else {
f[i] += rhs[i];
}
}
s_df /= (double)(nMem + 2);
return ierr;
}
int
dgesv (const int N, const int NRHS, double *A, const int lda,
double *B, const int ldb)
{
int result = 0;
#ifdef HAVE_ATLAS
int *ipiv = g_new (int, N);
result = clapack_dgesv (CblasColMajor, N, NRHS, A, lda, ipiv, B, ldb);
g_free (ipiv);
#else
integer i_N = N, i_NHRS = NRHS, i_lda = lda, i_ldb = ldb, info;
integer *ipiv = g_new (integer, N);
dgesv_ (&i_N, &i_NHRS, A, &i_lda, ipiv, B, &i_ldb, &info);
g_free (ipiv);
result = info;
#endif
return (result);
}
