/*! \fn solveLinearSystem
*
* function solves linear system J*(x_{n+1} - x_n) = f using lapack
*/
int solveLinearSystem(int* n, int* iwork, double* fvec, double *fjac, DATA_NEWTON* solverData)
{
int i, nrsh=1, lapackinfo;
char trans = 'N';
/* if no factorization is given, calculate it */
if (solverData->factorization == 0)
{
/* solve J*(x_{n+1} - x_n)=f */
dgetrf_(n, n, fjac, n, iwork, &lapackinfo);
solverData->factorization = 1;
dgetrs_(&trans, n, &nrsh, fjac, n, iwork, fvec, n, &lapackinfo);
}
else
{
dgetrs_(&trans, n, &nrsh, fjac, n, iwork, fvec, n, &lapackinfo);
}
if(lapackinfo > 0)
{
warningStreamPrint(LOG_NLS, 0, "Jacobian Matrix singular!");
return -1;
}
else if(lapackinfo < 0)
{
warningStreamPrint(LOG_NLS, 0, "illegal input in argument %d", (int)lapackinfo);
return -1;
}
else
{
/* save solution of J*(x_{n+1} - x_n)=f */
memcpy(solverData->x_increment, fvec, *n*sizeof(double));
}
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;
};
DLLEXPORT int d_lu_solve(int n, int nrhs, double a[], double b[])
{
double* clone = new double[n*n];
memcpy(clone, a, n*n*sizeof(double));
int* ipiv = new int[n];
int info = 0;
dgetrf_(&n, &n, clone, &n, ipiv, &info);
if (info != 0){
delete[] ipiv;
delete[] clone;
return info;
}
char trans ='N';
dgetrs_(&trans, &n, &nrhs, clone, &n, ipiv, b, &n, &info);
delete[] ipiv;
delete[] clone;
return info;
}
DLLEXPORT MKL_INT d_lu_solve(MKL_INT n, MKL_INT nrhs, double a[], double b[])
{
double* clone = new double[n*n];
std::memcpy(clone, a, n*n*sizeof(double));
MKL_INT* ipiv = new MKL_INT[n];
MKL_INT info = 0;
dgetrf_(&n, &n, clone, &n, ipiv, &info);
if (info != 0){
delete[] ipiv;
delete[] clone;
return info;
}
char trans ='N';
dgetrs_(&trans, &n, &nrhs, clone, &n, ipiv, b, &n, &info);
delete[] ipiv;
delete[] clone;
return info;
}
int CLapack::solvle(CFortranMatrix& a,CVector& rhs)
{
int info = 0;
int ndimm = a.GetNumberOfRows();
if( ndimm == 0 ){
ES_ERROR("no rows in rhs");
return(-1);
}
if( a.GetNumberOfRows() != a.GetNumberOfColumns() ){
ES_ERROR("matrix A must be a square matrix");
return(-1);
}
if( (int)a.GetNumberOfRows() != rhs.GetLength() ){
ES_ERROR("rhs is not compatible with A");
return(-1);
}
int* indx = new int[ndimm];
dgetrf_(&ndimm,&ndimm,a.GetRawDataField(),&ndimm,indx,&info);
if( info != 0 ){
delete[] indx;
ES_ERROR("unable to do LU decomposition");
return(info);
}
char trans = 'N';
int nrshs = 1;
dgetrs_(&trans,&ndimm,&nrshs,a.GetRawDataField(),&ndimm,indx,rhs.GetRawDataField(),&ndimm,&info);
if( info != 0 ){
delete[] indx;
ES_ERROR("unable to solve system of linear equations");
return(info);
}
delete[] indx;
return(info);
}
/* Solve a system of equations using a precomputed LU decomposition */
void matrix_solve_lu(int n, double *LU, int *ipiv, double *b, double *x)
{
double *btmp = malloc(sizeof(double) * n);
char trans = 'N';
int nrhs = 1;
int lda = n, ldb = n;
int i;
int info;
for (i = 0; i < n; i++)
btmp[i] = b[i];
dgetrs_(&trans, &n, &nrhs, LU, &lda, ipiv, btmp, &ldb, &info);
if (info != 0) {
printf("[matrix_solve_lu] dgetrs_ exited with error %d\n", info);
}
memcpy(x, btmp, sizeof(double) * n);
free(btmp);
}
int diis_step(double **err, double **v, int steps, int dim, double *v_res)
{
double *B;
double *rhs;
int info;
int i;
int j;
int B_dim;
double test = 0.0;
int nrhs = 1;
int *piv;
B_dim = steps + 1;
B = (double *)malloc (B_dim * B_dim * sizeof(double));
rhs = (double *)malloc (B_dim * sizeof(double));
piv = (int *)malloc (B_dim * sizeof(int));
memset (B, 0, B_dim * B_dim * sizeof(double));
memset (rhs, 0, B_dim * sizeof(double));
memset (piv, 0, B_dim * sizeof(int));
rhs[B_dim - 1] = 1.0;
for (i = 0; i < B_dim - 1; i++) {
for (j = 0; j < B_dim - 1; j++) {
B[i + (B_dim * j)] = cblas_ddot (dim, err[i], 1, err[j], 1);
}
}
for (i = 0; i < B_dim - 1; i++) {
B[i + B_dim * (B_dim - 1)] = 1.0;
B[B_dim - 1 + B_dim * i] = 1.0;
}
dgetrf_ (&B_dim, &B_dim, B, &B_dim, piv, &info);
if (info != 0) {
free (piv);
free (B);
free (rhs);
return -1;
}
dgetrs_ ("N", &B_dim, &nrhs, B, &B_dim, piv, rhs, &B_dim, &info);
if (info != 0) {
free (piv);
free (B);
free (rhs);
return -1;
}
/*Now perform the extrapolation*/
for (i = 0; i < steps; i++) {
test += rhs[i];
}
fprintf(stderr, "\n test: %lf", test);
for (i = 0; i < steps; i++) {
for (j = 0; j < dim; j++) {
v_res[j] += rhs[i] * v[i][j];
}
}
free (piv);
free (B);
free (rhs);
return 1;
/* free (piv); */
/* free (B); */
/* free (rhs); */
/* return 1; */
}
inline void getrs( const char& transa, const int& n, const int& nrhs, const double da[], const int& lda, int ipivot[], double db[], const int& ldb, int& info)
{
dgetrs_(transa,n,nrhs,da,lda,ipivot,db,ldb,info);
}
int dgetrs(char trans, int n, int nrhs, double * A, int lda, int * ipiv,
double * B, int ldb) {
int info;
dgetrs_(&trans, &n, &nrhs, A, &lda, ipiv, B, &ldb, &info);
return info;
}
doublereal dla_gercond__(char *trans, integer *n, doublereal *a, integer *lda,
doublereal *af, integer *ldaf, integer *ipiv, integer *cmode,
doublereal *c__, integer *info, doublereal *work, integer *iwork,
ftnlen trans_len)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2;
doublereal ret_val, d__1;
/* Local variables */
integer i__, j;
doublereal tmp;
integer kase;
extern logical lsame_(char *, char *);
integer isave[3];
extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *), xerbla_(char *,
integer *);
doublereal ainvnm;
extern /* Subroutine */ int dgetrs_(char *, integer *, integer *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *);
logical notrans;
/* -- LAPACK routine (version 3.2.1) -- */
/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/* -- Jason Riedy of Univ. of California Berkeley. -- */
/* -- April 2009 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley and NAG Ltd. -- */
/* .. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLA_GERCOND estimates the Skeel condition number of op(A) * op2(C) */
/* where op2 is determined by CMODE as follows */
/* CMODE = 1 op2(C) = C */
/* CMODE = 0 op2(C) = I */
/* CMODE = -1 op2(C) = inv(C) */
/* The Skeel condition number cond(A) = norminf( |inv(A)||A| ) */
/* is computed by computing scaling factors R such that */
/* diag(R)*A*op2(C) is row equilibrated and computing the standard */
/* infinity-norm condition number. */
/* Arguments */
/* ========== */
/* TRANS (input) CHARACTER*1 */
/* Specifies the form of the system of equations: */
/* = 'N': A * X = B (No transpose) */
/* = 'T': A**T * X = B (Transpose) */
/* = 'C': A**H * X = B (Conjugate Transpose = Transpose) */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the N-by-N matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */
/* The factors L and U from the factorization */
/* A = P*L*U as computed by DGETRF. */
/* LDAF (input) INTEGER */
/* The leading dimension of the array AF. LDAF >= max(1,N). */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices from the factorization A = P*L*U */
/* as computed by DGETRF; row i of the matrix was interchanged */
/* with row IPIV(i). */
/* CMODE (input) INTEGER */
/* Determines op2(C) in the formula op(A) * op2(C) as follows: */
/* CMODE = 1 op2(C) = C */
/* CMODE = 0 op2(C) = I */
/* CMODE = -1 op2(C) = inv(C) */
/* C (input) DOUBLE PRECISION array, dimension (N) */
/* The vector C in the formula op(A) * op2(C). */
/* INFO (output) INTEGER */
/* = 0: Successful exit. */
/* i > 0: The ith argument is invalid. */
/* WORK (input) DOUBLE PRECISION array, dimension (3*N). */
/* Workspace. */
/* IWORK (input) INTEGER array, dimension (N). */
/* Workspace. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--ipiv;
--c__;
--work;
--iwork;
/* Function Body */
ret_val = 0.;
*info = 0;
notrans = lsame_(trans, "N");
if (! notrans && ! lsame_(trans, "T") && ! lsame_(
trans, "C")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
} else if (*ldaf < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLA_GERCOND", &i__1);
return ret_val;
}
if (*n == 0) {
ret_val = 1.;
return ret_val;
}
/* Compute the equilibration matrix R such that */
/* inv(R)*A*C has unit 1-norm. */
if (notrans) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
tmp = 0.;
if (*cmode == 1) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
tmp += (d__1 = a[i__ + j * a_dim1] * c__[j], abs(d__1));
}
} else if (*cmode == 0) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
tmp += (d__1 = a[i__ + j * a_dim1], abs(d__1));
}
} else {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
tmp += (d__1 = a[i__ + j * a_dim1] / c__[j], abs(d__1));
}
}
work[(*n << 1) + i__] = tmp;
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
tmp = 0.;
if (*cmode == 1) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
tmp += (d__1 = a[j + i__ * a_dim1] * c__[j], abs(d__1));
}
} else if (*cmode == 0) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
tmp += (d__1 = a[j + i__ * a_dim1], abs(d__1));
}
} else {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
tmp += (d__1 = a[j + i__ * a_dim1] / c__[j], abs(d__1));
}
}
work[(*n << 1) + i__] = tmp;
}
}
/* Estimate the norm of inv(op(A)). */
ainvnm = 0.;
kase = 0;
L10:
dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
if (kase != 0) {
if (kase == 2) {
/* Multiply by R. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] *= work[(*n << 1) + i__];
}
if (notrans) {
dgetrs_("No transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[
1], &work[1], n, info);
} else {
dgetrs_("Transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[1],
&work[1], n, info);
}
/* Multiply by inv(C). */
if (*cmode == 1) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] /= c__[i__];
}
} else if (*cmode == -1) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] *= c__[i__];
}
}
} else {
/* Multiply by inv(C'). */
if (*cmode == 1) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] /= c__[i__];
}
} else if (*cmode == -1) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] *= c__[i__];
}
}
if (notrans) {
dgetrs_("Transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[1],
&work[1], n, info);
} else {
dgetrs_("No transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[
1], &work[1], n, info);
}
/* Multiply by R. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] *= work[(*n << 1) + i__];
}
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) {
ret_val = 1. / ainvnm;
}
return ret_val;
} /* dla_gercond__ */
CASADI_LINEARSOLVER_LAPACKLU_EXPORT void dgetrs_casadi(char* trans, int *n, int *nrhs, double *a,
int *lda, int *ipiv, double *b, int *ldb, int *info) {
dgetrs_(trans, n, nrhs, a, lda, ipiv, b, ldb, info);
}
/* Subroutine */ int dgerfs_(char *trans, integer *n, integer *nrhs,
doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer *
ipiv, doublereal *b, integer *ldb, doublereal *x, integer *ldx,
doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork,
integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DGERFS improves the computed solution to a system of linear
equations and provides error bounds and backward error estimates for
the solution.
Arguments
=========
TRANS (input) CHARACTER*1
Specifies the form of the system of equations:
= 'N': A * X = B (No transpose)
= 'T': A**T * X = B (Transpose)
= 'C': A**H * X = B (Conjugate transpose = Transpose)
N (input) INTEGER
The order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices B and X. NRHS >= 0.
A (input) DOUBLE PRECISION array, dimension (LDA,N)
The original N-by-N matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
AF (input) DOUBLE PRECISION array, dimension (LDAF,N)
The factors L and U from the factorization A = P*L*U
as computed by DGETRF.
LDAF (input) INTEGER
The leading dimension of the array AF. LDAF >= max(1,N).
IPIV (input) INTEGER array, dimension (N)
The pivot indices from DGETRF; for 1<=i<=N, row i of the
matrix was interchanged with row IPIV(i).
B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
The right hand side matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
On entry, the solution matrix X, as computed by DGETRS.
On exit, the improved solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
FERR (output) DOUBLE PRECISION array, dimension (NRHS)
The estimated forward error bound for each solution vector
X(j) (the j-th column of the solution matrix X).
If XTRUE is the true solution corresponding to X(j), FERR(j)
is an estimated upper bound for the magnitude of the largest
element in (X(j) - XTRUE) divided by the magnitude of the
largest element in X(j). The estimate is as reliable as
the estimate for RCOND, and is almost always a slight
overestimate of the true error.
BERR (output) DOUBLE PRECISION array, dimension (NRHS)
The componentwise relative backward error of each solution
vector X(j) (i.e., the smallest relative change in
any element of A or B that makes X(j) an exact solution).
WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
IWORK (workspace) INTEGER array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Internal Parameters
===================
ITMAX is the maximum number of steps of iterative refinement.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b15 = -1.;
static doublereal c_b17 = 1.;
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
x_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3;
/* Local variables */
static integer kase;
static doublereal safe1, safe2;
static integer i__, j, k;
static doublereal s;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dcopy_(integer *,
doublereal *, integer *, doublereal *, integer *), daxpy_(integer
*, doublereal *, doublereal *, integer *, doublereal *, integer *)
;
static integer count;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlacon_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static doublereal xk;
static integer nz;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *), dgetrs_(
char *, integer *, integer *, doublereal *, integer *, integer *,
doublereal *, integer *, integer *);
static logical notran;
static char transt[1];
static doublereal lstres, eps;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define x_ref(a_1,a_2) x[(a_2)*x_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1 * 1;
af -= af_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
--ferr;
--berr;
--work;
--iwork;
/* Function Body */
*info = 0;
notran = lsame_(trans, "N");
if (! notran && ! lsame_(trans, "T") && ! lsame_(
trans, "C")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldaf < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -10;
} else if (*ldx < max(1,*n)) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGERFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] = 0.;
berr[j] = 0.;
/* L10: */
}
return 0;
}
if (notran) {
*(unsigned char *)transt = 'T';
} else {
*(unsigned char *)transt = 'N';
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
eps = dlamch_("Epsilon");
safmin = dlamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
count = 1;
lstres = 3.;
L20:
/* Loop until stopping criterion is satisfied.
Compute residual R = B - op(A) * X,
where op(A) = A, A**T, or A**H, depending on TRANS. */
dcopy_(n, &b_ref(1, j), &c__1, &work[*n + 1], &c__1);
dgemv_(trans, n, n, &c_b15, &a[a_offset], lda, &x_ref(1, j), &c__1, &
c_b17, &work[*n + 1], &c__1);
/* Compute componentwise relative backward error from formula
max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
where abs(Z) is the componentwise absolute value of the matrix
or vector Z. If the i-th component of the denominator is less
than SAFE2, then SAFE1 is added to the i-th components of the
numerator and denominator before dividing. */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] = (d__1 = b_ref(i__, j), abs(d__1));
/* L30: */
}
/* Compute abs(op(A))*abs(X) + abs(B). */
if (notran) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
xk = (d__1 = x_ref(k, j), abs(d__1));
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
work[i__] += (d__1 = a_ref(i__, k), abs(d__1)) * xk;
/* L40: */
}
/* L50: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
s += (d__1 = a_ref(i__, k), abs(d__1)) * (d__2 = x_ref(
i__, j), abs(d__2));
/* L60: */
}
work[k] += s;
/* L70: */
}
}
s = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[i__] > safe2) {
/* Computing MAX */
d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[
i__];
s = max(d__2,d__3);
} else {
/* Computing MAX */
d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1)
/ (work[i__] + safe1);
s = max(d__2,d__3);
}
/* L80: */
}
berr[j] = s;
/* Test stopping criterion. Continue iterating if
1) The residual BERR(J) is larger than machine epsilon, and
2) BERR(J) decreased by at least a factor of 2 during the
last iteration, and
3) At most ITMAX iterations tried. */
if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
/* Update solution and try again. */
dgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[*n
+ 1], n, info);
daxpy_(n, &c_b17, &work[*n + 1], &c__1, &x_ref(1, j), &c__1);
lstres = berr[j];
++count;
goto L20;
}
/* Bound error from formula
norm(X - XTRUE) / norm(X) .le. FERR =
norm( abs(inv(op(A)))*
( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
where
norm(Z) is the magnitude of the largest component of Z
inv(op(A)) is the inverse of op(A)
abs(Z) is the componentwise absolute value of the matrix or
vector Z
NZ is the maximum number of nonzeros in any row of A, plus 1
EPS is machine epsilon
The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
is incremented by SAFE1 if the i-th component of
abs(op(A))*abs(X) + abs(B) is less than SAFE2.
Use DLACON to estimate the infinity-norm of the matrix
inv(op(A)) * diag(W),
where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[i__] > safe2) {
work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
work[i__];
} else {
work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
work[i__] + safe1;
}
/* L90: */
}
kase = 0;
L100:
dlacon_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)**T). */
dgetrs_(transt, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &
work[*n + 1], n, info);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = work[i__] * work[*n + i__];
/* L110: */
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = work[i__] * work[*n + i__];
/* L120: */
}
dgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &
work[*n + 1], n, info);
}
goto L100;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = lstres, d__3 = (d__1 = x_ref(i__, j), abs(d__1));
lstres = max(d__2,d__3);
/* L130: */
}
if (lstres != 0.) {
ferr[j] /= lstres;
}
/* L140: */
}
return 0;
/* End of DGERFS */
} /* dgerfs_ */
/* Subroutine */ int derrge_(char *path, integer *nunit)
{
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
doublereal a[16] /* was [4][4] */, b[4];
integer i__, j;
doublereal w[12], x[4];
char c2[2];
doublereal r1[4], r2[4], af[16] /* was [4][4] */;
integer ip[4], iw[4], info;
doublereal anrm, ccond, rcond;
extern /* Subroutine */ int dgbtf2_(integer *, integer *, integer *,
integer *, doublereal *, integer *, integer *, integer *),
dgetf2_(integer *, integer *, doublereal *, integer *, integer *,
integer *), dgbcon_(char *, integer *, integer *, integer *,
doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *), dgecon_(char *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *), alaesm_(char *,
logical *, integer *), dgbequ_(integer *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *)
, dgbrfs_(char *, integer *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, integer *, integer *),
dgbtrf_(integer *, integer *, integer *, integer *, doublereal *,
integer *, integer *, integer *), dgeequ_(integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *), dgerfs_(char *, integer *
, integer *, doublereal *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *, integer *), dgetrf_(integer *, integer *, doublereal *, integer *,
integer *, integer *), dgetri_(integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), dgbtrs_(char *, integer *, integer *,
integer *, integer *, doublereal *, integer *, integer *,
doublereal *, integer *, integer *), dgetrs_(char *,
integer *, integer *, doublereal *, integer *, integer *,
doublereal *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DERRGE tests the error exits for the DOUBLE PRECISION routines */
/* for general matrices. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
/* Set the variables to innocuous values. */
for (j = 1; j <= 4; ++j) {
for (i__ = 1; i__ <= 4; ++i__) {
a[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
af[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
/* L10: */
}
b[j - 1] = 0.;
r1[j - 1] = 0.;
r2[j - 1] = 0.;
w[j - 1] = 0.;
x[j - 1] = 0.;
ip[j - 1] = j;
iw[j - 1] = j;
/* L20: */
}
infoc_1.ok = TRUE_;
if (lsamen_(&c__2, c2, "GE")) {
/* Test error exits of the routines that use the LU decomposition */
/* of a general matrix. */
/* DGETRF */
s_copy(srnamc_1.srnamt, "DGETRF", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgetrf_(&c_n1, &c__0, a, &c__1, ip, &info);
chkxer_("DGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgetrf_(&c__0, &c_n1, a, &c__1, ip, &info);
chkxer_("DGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgetrf_(&c__2, &c__1, a, &c__1, ip, &info);
chkxer_("DGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGETF2 */
s_copy(srnamc_1.srnamt, "DGETF2", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgetf2_(&c_n1, &c__0, a, &c__1, ip, &info);
chkxer_("DGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgetf2_(&c__0, &c_n1, a, &c__1, ip, &info);
chkxer_("DGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgetf2_(&c__2, &c__1, a, &c__1, ip, &info);
chkxer_("DGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGETRI */
s_copy(srnamc_1.srnamt, "DGETRI", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgetri_(&c_n1, a, &c__1, ip, w, &c__12, &info);
chkxer_("DGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgetri_(&c__2, a, &c__1, ip, w, &c__12, &info);
chkxer_("DGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGETRS */
s_copy(srnamc_1.srnamt, "DGETRS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgetrs_("/", &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
chkxer_("DGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgetrs_("N", &c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
chkxer_("DGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgetrs_("N", &c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
chkxer_("DGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgetrs_("N", &c__2, &c__1, a, &c__1, ip, b, &c__2, &info);
chkxer_("DGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
dgetrs_("N", &c__2, &c__1, a, &c__2, ip, b, &c__1, &info);
chkxer_("DGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGERFS */
s_copy(srnamc_1.srnamt, "DGERFS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgerfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgerfs_("N", &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgerfs_("N", &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgerfs_("N", &c__2, &c__1, a, &c__1, af, &c__2, ip, b, &c__2, x, &
c__2, r1, r2, w, iw, &info);
chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__1, ip, b, &c__2, x, &
c__2, r1, r2, w, iw, &info);
chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
dgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__1, x, &
c__2, r1, r2, w, iw, &info);
chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
dgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__2, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGECON */
s_copy(srnamc_1.srnamt, "DGECON", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgecon_("/", &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("DGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgecon_("1", &c_n1, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("DGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgecon_("1", &c__2, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("DGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGEEQU */
s_copy(srnamc_1.srnamt, "DGEEQU", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgeequ_(&c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
chkxer_("DGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgeequ_(&c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
chkxer_("DGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgeequ_(&c__2, &c__2, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
chkxer_("DGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
} else if (lsamen_(&c__2, c2, "GB")) {
/* Test error exits of the routines that use the LU decomposition */
/* of a general band matrix. */
/* DGBTRF */
s_copy(srnamc_1.srnamt, "DGBTRF", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgbtrf_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, &info);
chkxer_("DGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgbtrf_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, ip, &info);
chkxer_("DGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgbtrf_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, ip, &info);
chkxer_("DGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgbtrf_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, ip, &info);
chkxer_("DGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
dgbtrf_(&c__2, &c__2, &c__1, &c__1, a, &c__3, ip, &info);
chkxer_("DGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGBTF2 */
s_copy(srnamc_1.srnamt, "DGBTF2", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgbtf2_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, &info);
chkxer_("DGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgbtf2_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, ip, &info);
chkxer_("DGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgbtf2_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, ip, &info);
chkxer_("DGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgbtf2_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, ip, &info);
chkxer_("DGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
dgbtf2_(&c__2, &c__2, &c__1, &c__1, a, &c__3, ip, &info);
chkxer_("DGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGBTRS */
s_copy(srnamc_1.srnamt, "DGBTRS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgbtrs_("/", &c__0, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
info);
chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgbtrs_("N", &c_n1, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
info);
chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgbtrs_("N", &c__1, &c_n1, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
info);
chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgbtrs_("N", &c__1, &c__0, &c_n1, &c__1, a, &c__1, ip, b, &c__1, &
info);
chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgbtrs_("N", &c__1, &c__0, &c__0, &c_n1, a, &c__1, ip, b, &c__1, &
info);
chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dgbtrs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__3, ip, b, &c__2, &
info);
chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
dgbtrs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
info);
chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGBRFS */
s_copy(srnamc_1.srnamt, "DGBRFS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgbrfs_("/", &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
c__1, x, &c__1, r1, r2, w, iw, &info);
chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgbrfs_("N", &c_n1, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
c__1, x, &c__1, r1, r2, w, iw, &info);
chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgbrfs_("N", &c__1, &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
c__1, x, &c__1, r1, r2, w, iw, &info);
chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgbrfs_("N", &c__1, &c__0, &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &
c__1, x, &c__1, r1, r2, w, iw, &info);
chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgbrfs_("N", &c__1, &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &
c__1, x, &c__1, r1, r2, w, iw, &info);
chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dgbrfs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__2, af, &c__4, ip, b, &
c__2, x, &c__2, r1, r2, w, iw, &info);
chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
dgbrfs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__3, af, &c__3, ip, b, &
c__2, x, &c__2, r1, r2, w, iw, &info);
chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
dgbrfs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, af, &c__1, ip, b, &
c__1, x, &c__2, r1, r2, w, iw, &info);
chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 14;
dgbrfs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, af, &c__1, ip, b, &
c__2, x, &c__1, r1, r2, w, iw, &info);
chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGBCON */
s_copy(srnamc_1.srnamt, "DGBCON", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgbcon_("/", &c__0, &c__0, &c__0, a, &c__1, ip, &anrm, &rcond, w, iw,
&info);
chkxer_("DGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgbcon_("1", &c_n1, &c__0, &c__0, a, &c__1, ip, &anrm, &rcond, w, iw,
&info);
chkxer_("DGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgbcon_("1", &c__1, &c_n1, &c__0, a, &c__1, ip, &anrm, &rcond, w, iw,
&info);
chkxer_("DGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgbcon_("1", &c__1, &c__0, &c_n1, a, &c__1, ip, &anrm, &rcond, w, iw,
&info);
chkxer_("DGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
dgbcon_("1", &c__2, &c__1, &c__1, a, &c__3, ip, &anrm, &rcond, w, iw,
&info);
chkxer_("DGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGBEQU */
s_copy(srnamc_1.srnamt, "DGBEQU", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgbequ_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
&anrm, &info);
chkxer_("DGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgbequ_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
&anrm, &info);
chkxer_("DGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgbequ_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
&anrm, &info);
chkxer_("DGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgbequ_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond,
&anrm, &info);
chkxer_("DGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
dgbequ_(&c__2, &c__2, &c__1, &c__1, a, &c__2, r1, r2, &rcond, &ccond,
&anrm, &info);
chkxer_("DGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
}
/* Print a summary line. */
alaesm_(path, &infoc_1.ok, &infoc_1.nout);
return 0;
/* End of DERRGE */
} /* derrge_ */
/* Subroutine */ int dsgesv_(integer *n, integer *nrhs, doublereal *a,
integer *lda, integer *ipiv, doublereal *b, integer *ldb, doublereal *
x, integer *ldx, doublereal *work, real *swork, integer *iter,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, work_dim1, work_offset,
x_dim1, x_offset, i__1;
doublereal d__1;
/* Local variables */
integer i__;
doublereal cte, eps, anrm;
integer ptsa;
doublereal rnrm, xnrm;
integer ptsx;
integer iiter;
/* -- LAPACK PROTOTYPE driver routine (version 3.2) -- */
/* February 2007 */
/* Purpose */
/* ======= */
/* DSGESV computes the solution to a real system of linear equations */
/* A * X = B, */
/* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. */
/* DSGESV first attempts to factorize the matrix in SINGLE PRECISION */
/* and use this factorization within an iterative refinement procedure */
/* to produce a solution with DOUBLE PRECISION normwise backward error */
/* quality (see below). If the approach fails the method switches to a */
/* DOUBLE PRECISION factorization and solve. */
/* The iterative refinement is not going to be a winning strategy if */
/* the ratio SINGLE PRECISION performance over DOUBLE PRECISION */
/* performance is too small. A reasonable strategy should take the */
/* number of right-hand sides and the size of the matrix into account. */
/* This might be done with a call to ILAENV in the future. Up to now, we */
/* always try iterative refinement. */
/* The iterative refinement process is stopped if */
/* ITER > ITERMAX */
/* or for all the RHS we have: */
/* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX */
/* where */
/* o ITER is the number of the current iteration in the iterative */
/* refinement process */
/* o RNRM is the infinity-norm of the residual */
/* o XNRM is the infinity-norm of the solution */
/* o ANRM is the infinity-operator-norm of the matrix A */
/* o EPS is the machine epsilon returned by DLAMCH('Epsilon') */
/* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00 */
/* respectively. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrix B. NRHS >= 0. */
/* A (input or input/ouptut) DOUBLE PRECISION array, */
/* dimension (LDA,N) */
/* On entry, the N-by-N coefficient matrix A. */
/* On exit, if iterative refinement has been successfully used */
/* (INFO.EQ.0 and ITER.GE.0, see description below), then A is */
/* unchanged, if double precision factorization has been used */
/* (INFO.EQ.0 and ITER.LT.0, see description below), then the */
/* array A contains the factors L and U from the factorization */
/* A = P*L*U; the unit diagonal elements of L are not stored. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* IPIV (output) INTEGER array, dimension (N) */
/* The pivot indices that define the permutation matrix P; */
/* row i of the matrix was interchanged with row IPIV(i). */
/* Corresponds either to the single precision factorization */
/* (if INFO.EQ.0 and ITER.GE.0) or the double precision */
/* factorization (if INFO.EQ.0 and ITER.LT.0). */
/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* The N-by-NRHS right hand side matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* If INFO = 0, the N-by-NRHS solution matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (N*NRHS) */
/* This array is used to hold the residual vectors. */
/* SWORK (workspace) REAL array, dimension (N*(N+NRHS)) */
/* This array is used to use the single precision matrix and the */
/* right-hand sides or solutions in single precision. */
/* ITER (output) INTEGER */
/* < 0: iterative refinement has failed, double precision */
/* factorization has been performed */
/* -1 : the routine fell back to full precision for */
/* implementation- or machine-specific reasons */
/* -2 : narrowing the precision induced an overflow, */
/* the routine fell back to full precision */
/* -3 : failure of SGETRF */
/* -31: stop the iterative refinement after the 30th */
/* iterations */
/* > 0: iterative refinement has been sucessfully used. */
/* Returns the number of iterations */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, U(i,i) computed in DOUBLE PRECISION is */
/* exactly zero. The factorization has been completed, */
/* but the factor U is exactly singular, so the solution */
/* could not be computed. */
/* ========= */
/* Parameter adjustments */
work_dim1 = *n;
work_offset = 1 + work_dim1;
work -= work_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--swork;
/* Function Body */
*info = 0;
*iter = 0;
/* Test the input parameters. */
if (*n < 0) {
*info = -1;
} else if (*nrhs < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
} else if (*ldb < max(1,*n)) {
*info = -7;
} else if (*ldx < max(1,*n)) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSGESV", &i__1);
return 0;
}
/* Quick return if (N.EQ.0). */
if (*n == 0) {
return 0;
}
/* Skip single precision iterative refinement if a priori slower */
/* than double precision factorization. */
if (FALSE_) {
*iter = -1;
goto L40;
}
/* Compute some constants. */
anrm = dlange_("I", n, n, &a[a_offset], lda, &work[work_offset]);
eps = dlamch_("Epsilon");
cte = anrm * eps * sqrt((doublereal) (*n)) * 1.;
/* Set the indices PTSA, PTSX for referencing SA and SX in SWORK. */
ptsa = 1;
ptsx = ptsa + *n * *n;
/* Convert B from double precision to single precision and store the */
/* result in SX. */
dlag2s_(n, nrhs, &b[b_offset], ldb, &swork[ptsx], n, info);
if (*info != 0) {
*iter = -2;
goto L40;
}
/* Convert A from double precision to single precision and store the */
/* result in SA. */
dlag2s_(n, n, &a[a_offset], lda, &swork[ptsa], n, info);
if (*info != 0) {
*iter = -2;
goto L40;
}
/* Compute the LU factorization of SA. */
sgetrf_(n, n, &swork[ptsa], n, &ipiv[1], info);
if (*info != 0) {
*iter = -3;
goto L40;
}
/* Solve the system SA*SX = SB. */
sgetrs_("No transpose", n, nrhs, &swork[ptsa], n, &ipiv[1], &swork[ptsx],
n, info);
/* Convert SX back to double precision */
slag2d_(n, nrhs, &swork[ptsx], n, &x[x_offset], ldx, info);
/* Compute R = B - AX (R is WORK). */
dlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n);
dgemm_("No Transpose", "No Transpose", n, nrhs, n, &c_b10, &a[a_offset],
lda, &x[x_offset], ldx, &c_b11, &work[work_offset], n);
/* Check whether the NRHS normwise backward errors satisfy the */
/* stopping criterion. If yes, set ITER=0 and return. */
i__1 = *nrhs;
for (i__ = 1; i__ <= i__1; ++i__) {
xnrm = (d__1 = x[idamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ *
x_dim1], abs(d__1));
rnrm = (d__1 = work[idamax_(n, &work[i__ * work_dim1 + 1], &c__1) +
i__ * work_dim1], abs(d__1));
if (rnrm > xnrm * cte) {
goto L10;
}
}
/* If we are here, the NRHS normwise backward errors satisfy the */
/* stopping criterion. We are good to exit. */
*iter = 0;
return 0;
L10:
for (iiter = 1; iiter <= 30; ++iiter) {
/* Convert R (in WORK) from double precision to single precision */
/* and store the result in SX. */
dlag2s_(n, nrhs, &work[work_offset], n, &swork[ptsx], n, info);
if (*info != 0) {
*iter = -2;
goto L40;
}
/* Solve the system SA*SX = SR. */
sgetrs_("No transpose", n, nrhs, &swork[ptsa], n, &ipiv[1], &swork[
ptsx], n, info);
/* Convert SX back to double precision and update the current */
/* iterate. */
slag2d_(n, nrhs, &swork[ptsx], n, &work[work_offset], n, info);
i__1 = *nrhs;
for (i__ = 1; i__ <= i__1; ++i__) {
daxpy_(n, &c_b11, &work[i__ * work_dim1 + 1], &c__1, &x[i__ *
x_dim1 + 1], &c__1);
}
/* Compute R = B - AX (R is WORK). */
dlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n);
dgemm_("No Transpose", "No Transpose", n, nrhs, n, &c_b10, &a[
a_offset], lda, &x[x_offset], ldx, &c_b11, &work[work_offset],
n);
/* Check whether the NRHS normwise backward errors satisfy the */
/* stopping criterion. If yes, set ITER=IITER>0 and return. */
i__1 = *nrhs;
for (i__ = 1; i__ <= i__1; ++i__) {
xnrm = (d__1 = x[idamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ *
x_dim1], abs(d__1));
rnrm = (d__1 = work[idamax_(n, &work[i__ * work_dim1 + 1], &c__1)
+ i__ * work_dim1], abs(d__1));
if (rnrm > xnrm * cte) {
goto L20;
}
}
/* If we are here, the NRHS normwise backward errors satisfy the */
/* stopping criterion, we are good to exit. */
*iter = iiter;
return 0;
L20:
;
}
/* If we are at this place of the code, this is because we have */
/* performed ITER=ITERMAX iterations and never satisified the */
/* stopping criterion, set up the ITER flag accordingly and follow up */
/* on double precision routine. */
*iter = -31;
L40:
/* Single-precision iterative refinement failed to converge to a */
/* satisfactory solution, so we resort to double precision. */
dgetrf_(n, n, &a[a_offset], lda, &ipiv[1], info);
if (*info != 0) {
return 0;
}
dlacpy_("All", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
dgetrs_("No transpose", n, nrhs, &a[a_offset], lda, &ipiv[1], &x[x_offset]
, ldx, info);
return 0;
/* End of DSGESV. */
} /* dsgesv_ */
int jmi_linear_solver_solve(jmi_block_residual_t * block){
int n_x = block->n;
int info;
int i;
/* int j; */
char trans;
jmi_linear_solver_t* solver = block->solver;
jmi_t * jmi = block->jmi;
/* If needed, reevaluate and factorize Jacobian */
if (solver->cached_jacobian != 1) {
/*printf("** Computing factorization in jmi_linear_solver_solve for block %d\n",block->index);*/
/*
TODO: this code should be merged with the code used in kinsol interface module.
A regularization strategy for simple cases singular jac should be introduced.
*/
info = block->F(jmi,NULL,solver->factorization,JMI_BLOCK_EVALUATE_JACOBIAN);
if(info) {
if(block->init) {
jmi_log_node(jmi->log, logError, "Error", "Failed in Jacobian calculation for <block: %d>",
block->index);
}
else {
jmi_log_node(jmi->log, logWarning, "Warning", "Failed in Jacobian calculation for <block: %d>",
block->index);
}
return -1;
}
if((n_x>1) && block->jmi->options.use_jacobian_equilibration_flag) {
double rowcnd, colcnd, amax;
dgeequ_(&n_x, &n_x, solver->factorization, &n_x, solver->rScale, solver->cScale,
&rowcnd, &colcnd, &amax, &info);
if(info == 0) {
dlaqge_(&n_x, &n_x, solver->factorization, &n_x, solver->rScale, solver->cScale,
&rowcnd, &colcnd, &amax, &solver->equed);
}
else
solver->equed = 'N';
}
/* printf("Jacobian: \n");
for (i=0;i<n_x;i++) {
for (j=0;j<n_x;j++) {
printf("%e, ", solver->factorization[i + j*n_x]);
}
printf("\n");
}*/
dgetrf_(&n_x, &n_x, solver->factorization, &n_x, solver->ipiv, &info);
if(info) {
if(block->init) {
jmi_log_node(jmi->log, logError, "Error", "Singular Jacobian detected for <block: %d>",
block->index);
}
else {
jmi_log_node(jmi->log, logWarning, "Warning", "Singular Jacobian detected for <block: %d>",
block->index);
}
return -1;
}
/*printf("Factorization: \n");
for (i=0;i<n_x;i++) {
for (j=0;j<n_x;j++) {
printf("%e, ", solver->factorization[i + j*n_x]);
}
printf("\n");
}*/
if (block->jacobian_variability == JMI_CONSTANT_VARIABILITY ||
block->jacobian_variability == JMI_PARAMETER_VARIABILITY) {
solver->cached_jacobian = 1;
}
}
/* Compute right hand side at initial x*/
/* TESTING ONLY! setting x to zero leads to invalid arguments to the function in case of bounds */
/*for (i=0;i<n_x;i++) {
block->x[i] = 0.;
} */
info = block->F(block->jmi,block->initial, block->res, JMI_BLOCK_EVALUATE);
if(info) {
if(block->init) {
jmi_log_node(jmi->log, logError, "Error", "Failed to evaluate equations in <block: %d>", block->index);
}
else {
jmi_log_node(jmi->log, logWarning, "Warning", "Failed to evaluate equations in <block: %d>", block->index);
}
return -1;
}
if((solver->equed == 'R') || (solver->equed == 'B')) {
for (i=0;i<n_x;i++) {
block->res[i] *= solver->rScale[i];
}
}
/* Do back-solve */
trans = 'N'; /* No transposition */
i = 1; /* One rhs to solve for */
dgetrs_(&trans, &n_x, &i, solver->factorization, &n_x, solver->ipiv, block->res, &n_x, &info);
if(info) {
/* can only be "bad param" -> internal error */
jmi_log_node(jmi->log, logError, "Error", "Internal error when solving <block: %d>", block->index);
return -1;
}
if((solver->equed == 'C') || (solver->equed == 'B')) {
for (i=0;i<n_x;i++) {
block->x[i] = block->initial[i] + block->res[i] * solver->cScale[i];
}
}
else {
for (i=0;i<n_x;i++) {
block->x[i] = block->initial[i] + block->res[i] ;
}
}
/* Write solution back to model */
block->F(block->jmi,block->x, NULL, JMI_BLOCK_WRITE_BACK);
return info==0? 0: -1;
}
/* ===================================================================== */
doublereal dla_gercond_(char *trans, integer *n, doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer *ipiv, integer *cmode, doublereal *c__, integer *info, doublereal *work, integer *iwork)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2;
doublereal ret_val, d__1;
/* Local variables */
integer i__, j;
doublereal tmp;
integer kase;
extern logical lsame_(char *, char *);
integer isave[3];
extern /* Subroutine */
int dlacn2_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, integer *), xerbla_(char *, integer *);
doublereal ainvnm;
extern /* Subroutine */
int dgetrs_(char *, integer *, integer *, doublereal *, integer *, integer *, doublereal *, integer *, integer *);
logical notrans;
/* -- LAPACK computational routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--ipiv;
--c__;
--work;
--iwork;
/* Function Body */
ret_val = 0.;
*info = 0;
notrans = lsame_(trans, "N");
if (! notrans && ! lsame_(trans, "T") && ! lsame_( trans, "C"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*lda < max(1,*n))
{
*info = -4;
}
else if (*ldaf < max(1,*n))
{
*info = -6;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("DLA_GERCOND", &i__1);
return ret_val;
}
if (*n == 0)
{
ret_val = 1.;
return ret_val;
}
/* Compute the equilibration matrix R such that */
/* inv(R)*A*C has unit 1-norm. */
if (notrans)
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
tmp = 0.;
if (*cmode == 1)
{
i__2 = *n;
for (j = 1;
j <= i__2;
++j)
{
tmp += (d__1 = a[i__ + j * a_dim1] * c__[j], abs(d__1));
}
}
else if (*cmode == 0)
{
i__2 = *n;
for (j = 1;
j <= i__2;
++j)
{
tmp += (d__1 = a[i__ + j * a_dim1], abs(d__1));
}
}
else
{
i__2 = *n;
for (j = 1;
j <= i__2;
++j)
{
tmp += (d__1 = a[i__ + j * a_dim1] / c__[j], abs(d__1));
}
}
work[(*n << 1) + i__] = tmp;
}
}
else
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
tmp = 0.;
if (*cmode == 1)
{
i__2 = *n;
for (j = 1;
j <= i__2;
++j)
{
tmp += (d__1 = a[j + i__ * a_dim1] * c__[j], abs(d__1));
}
}
else if (*cmode == 0)
{
i__2 = *n;
for (j = 1;
j <= i__2;
++j)
{
tmp += (d__1 = a[j + i__ * a_dim1], abs(d__1));
}
}
else
{
i__2 = *n;
for (j = 1;
j <= i__2;
++j)
{
tmp += (d__1 = a[j + i__ * a_dim1] / c__[j], abs(d__1));
}
}
work[(*n << 1) + i__] = tmp;
}
}
/* Estimate the norm of inv(op(A)). */
ainvnm = 0.;
kase = 0;
L10:
dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
if (kase != 0)
{
if (kase == 2)
{
/* Multiply by R. */
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] *= work[(*n << 1) + i__];
}
if (notrans)
{
dgetrs_("No transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[ 1], &work[1], n, info);
}
else
{
dgetrs_("Transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[1], n, info);
}
/* Multiply by inv(C). */
if (*cmode == 1)
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] /= c__[i__];
}
}
else if (*cmode == -1)
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] *= c__[i__];
}
}
}
else
{
/* Multiply by inv(C**T). */
if (*cmode == 1)
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] /= c__[i__];
}
}
else if (*cmode == -1)
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] *= c__[i__];
}
}
if (notrans)
{
dgetrs_("Transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[1], n, info);
}
else
{
dgetrs_("No transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[ 1], &work[1], n, info);
}
/* Multiply by R. */
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] *= work[(*n << 1) + i__];
}
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.)
{
ret_val = 1. / ainvnm;
}
return ret_val;
}
/// \brief Solve the det Ax^2+Bx+C = 0 problem using the Manocha and Canny method (1994)
///
/// matcoeffs is of length 54*3, for 3 matrices
static inline void solvedialyticpoly8qep(const IkReal* matcoeffs, IkReal* rawroots, int& numroots)
{
const IkReal tol = 128.0*std::numeric_limits<IkReal>::epsilon();
IkReal IKFAST_ALIGNED16(M[16*16]) = {0};
IkReal IKFAST_ALIGNED16(A[8*8]);
IkReal IKFAST_ALIGNED16(work[16*16*15]);
int ipiv[8];
int info, coeffindex;
const int worksize=16*16*15;
const int matrixdim = 8;
const int matrixdim2 = 16;
numroots = 0;
// first setup M = [0 I; -C -B] and A
coeffindex = 0;
for(int j = 0; j < 4; ++j) {
for(int k = 0; k < 6; ++k) {
M[matrixdim+(j+4)+2*matrixdim*k] = M[matrixdim+j+2*matrixdim*(k+2)] = -matcoeffs[coeffindex++];
}
}
for(int j = 0; j < 4; ++j) {
for(int k = 0; k < 6; ++k) {
M[matrixdim+(j+4)+2*matrixdim*k+matrixdim*2*matrixdim] = M[matrixdim+j+2*matrixdim*(k+2)+matrixdim*2*matrixdim] = -matcoeffs[coeffindex++];
}
}
for(int j = 0; j < 4; ++j) {
for(int k = 0; k < 6; ++k) {
A[(j+4)+matrixdim*k] = A[j+matrixdim*(k+2)] = matcoeffs[coeffindex++];
}
for(int k = 0; k < 2; ++k) {
A[j+matrixdim*k] = A[(j+4)+matrixdim*(k+6)] = 0;
}
}
const IkReal lfpossibilities[4][4] = {{1,-1,1,1},{1,0,-2,1},{1,1,2,0},{1,-1,4,1}};
int lfindex = -1;
bool bsingular = true;
do {
dgetrf_(&matrixdim,&matrixdim,A,&matrixdim,&ipiv[0],&info);
if( info == 0 ) {
bsingular = false;
for(int j = 0; j < matrixdim; ++j) {
if( IKabs(A[j*matrixdim+j]) < 100*tol ) {
bsingular = true;
break;
}
}
if( !bsingular ) {
break;
}
}
if( lfindex == 3 ) {
break;
}
// transform by the linear functional
lfindex++;
const IkReal* lf = lfpossibilities[lfindex];
// have to reinitialize A
coeffindex = 0;
for(int j = 0; j < 4; ++j) {
for(int k = 0; k < 6; ++k) {
IkReal a = matcoeffs[coeffindex+48], b = matcoeffs[coeffindex+24], c = matcoeffs[coeffindex];
A[(j+4)+matrixdim*k] = A[j+matrixdim*(k+2)] = lf[0]*lf[0]*a+lf[0]*lf[2]*b+lf[2]*lf[2]*c;
M[matrixdim+(j+4)+2*matrixdim*k] = M[matrixdim+j+2*matrixdim*(k+2)] = -(lf[1]*lf[1]*a + lf[1]*lf[3]*b + lf[3]*lf[3]*c);
M[matrixdim+(j+4)+2*matrixdim*k+matrixdim*2*matrixdim] = M[matrixdim+j+2*matrixdim*(k+2)+matrixdim*2*matrixdim] = -(2*lf[0]*lf[1]*a + (lf[0]*lf[3]+lf[1]*lf[2])*b + 2*lf[2]*lf[3]*c);
coeffindex++;
}
for(int k = 0; k < 2; ++k) {
A[j+matrixdim*k] = A[(j+4)+matrixdim*(k+6)] = 0;
}
}
} while(lfindex<4);
if( bsingular ) {
return;
}
dgetrs_("No transpose", &matrixdim, &matrixdim2, A, &matrixdim, &ipiv[0], &M[matrixdim], &matrixdim2, &info);
if( info != 0 ) {
return;
}
// set identity in upper corner
for(int j = 0; j < matrixdim; ++j) {
M[matrixdim*2*matrixdim+j+matrixdim*2*j] = 1;
}
IkReal IKFAST_ALIGNED16(wr[16]);
IkReal IKFAST_ALIGNED16(wi[16]);
IkReal IKFAST_ALIGNED16(vr[16*16]);
int one=1;
dgeev_("N", "V", &matrixdim2, M, &matrixdim2, wr, wi,NULL, &one, vr, &matrixdim2, work, &worksize, &info);
if( info != 0 ) {
return;
}
IkReal Breal[matrixdim-1];
for(int i = 0; i < matrixdim2; ++i) {
if( IKabs(wi[i]) < tol*100 ) {
IkReal* ev = vr+matrixdim2*i;
if( IKabs(wr[i]) > 1 ) {
ev += matrixdim;
}
// consistency has to be checked!!
if( IKabs(ev[0]) < tol ) {
continue;
}
IkReal iconst = 1/ev[0];
for(int j = 1; j < matrixdim; ++j) {
Breal[j-1] = ev[j]*iconst;
}
if( checkconsistency8(Breal) ) {
if( lfindex >= 0 ) {
const IkReal* lf = lfpossibilities[lfindex];
rawroots[numroots++] = (wr[i]*lf[0]+lf[1])/(wr[i]*lf[2]+lf[3]);
}
else {
rawroots[numroots++] = wr[i];
}
bool bsmall0=IKabs(ev[0]) > IKabs(ev[2]);
bool bsmall1=IKabs(ev[0]) > IKabs(ev[1]);
if( bsmall0 && bsmall1 ) {
rawroots[numroots++] = ev[2]/ev[0];
rawroots[numroots++] = ev[1]/ev[0];
}
else if( bsmall0 && !bsmall1 ) {
rawroots[numroots++] = ev[3]/ev[1];
rawroots[numroots++] = ev[1]/ev[0];
}
else if( !bsmall0 && bsmall1 ) {
rawroots[numroots++] = ev[6]/ev[4];
rawroots[numroots++] = ev[7]/ev[6];
}
else if( !bsmall0 && !bsmall1 ) {
rawroots[numroots++] = ev[7]/ev[5];
rawroots[numroots++] = ev[7]/ev[6];
}
}
}
}
}};
/* Subroutine */ int dgesv_(integer *n, integer *nrhs, doublereal *a, integer
*lda, integer *ipiv, doublereal *b, integer *ldb, integer *info)
{
/* -- LAPACK driver routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
DGESV computes the solution to a real system of linear equations
A * X = B,
where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
The LU decomposition with partial pivoting and row interchanges is
used to factor A as
A = P * L * U,
where P is a permutation matrix, L is unit lower triangular, and U is
upper triangular. The factored form of A is then used to solve the
system of equations A * X = B.
Arguments
=========
N (input) INTEGER
The number of linear equations, i.e., the order of the
matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrix B. NRHS >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the N-by-N coefficient matrix A.
On exit, the factors L and U from the factorization
A = P*L*U; the unit diagonal elements of L are not stored.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
IPIV (output) INTEGER array, dimension (N)
The pivot indices that define the permutation matrix P;
row i of the matrix was interchanged with row IPIV(i).
B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
On entry, the N-by-NRHS matrix of right hand side matrix B.
On exit, if INFO = 0, the N-by-NRHS solution matrix X.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, U(i,i) is exactly zero. The factorization
has been completed, but the factor U is exactly
singular, so the solution could not be computed.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1;
/* Local variables */
extern /* Subroutine */ int dgetrf_(integer *, integer *, doublereal *,
integer *, integer *, integer *), xerbla_(char *, integer *), dgetrs_(char *, integer *, integer *, doublereal *,
integer *, integer *, doublereal *, integer *, integer *);
#define IPIV(I) ipiv[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*nrhs < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGESV ", &i__1);
return 0;
}
/* Compute the LU factorization of A. */
dgetrf_(n, n, &A(1,1), lda, &IPIV(1), info);
if (*info == 0) {
/* Solve the system A*X = B, overwriting B with X. */
dgetrs_("No transpose", n, nrhs, &A(1,1), lda, &IPIV(1), &B(1,1), ldb, info);
}
return 0;
/* End of DGESV */
} /* dgesv_ */
/* Subroutine */ int dla_gerfsx_extended__(integer *prec_type__, integer *
trans_type__, integer *n, integer *nrhs, doublereal *a, integer *lda,
doublereal *af, integer *ldaf, integer *ipiv, logical *colequ,
doublereal *c__, doublereal *b, integer *ldb, doublereal *y, integer *
ldy, doublereal *berr_out__, integer *n_norms__, doublereal *errs_n__,
doublereal *errs_c__, doublereal *res, doublereal *ayb, doublereal *
dy, doublereal *y_tail__, doublereal *rcond, integer *ithresh,
doublereal *rthresh, doublereal *dz_ub__, logical *ignore_cwise__,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1,
y_offset, errs_n_dim1, errs_n_offset, errs_c_dim1, errs_c_offset,
i__1, i__2, i__3;
doublereal d__1, d__2;
char ch__1[1];
/* Local variables */
doublereal dxratmax, dzratmax;
integer i__, j;
extern /* Subroutine */ int dla_geamv__(integer *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
logical incr_prec__;
doublereal prev_dz_z__, yk, final_dx_x__;
extern /* Subroutine */ int dla_wwaddw__(integer *, doublereal *,
doublereal *, doublereal *);
doublereal final_dz_z__, prevnormdx;
integer cnt;
doublereal dyk, eps, incr_thresh__, dx_x__, dz_z__;
extern /* Subroutine */ int dla_lin_berr__(integer *, integer *, integer *
, doublereal *, doublereal *, doublereal *);
doublereal ymin;
extern /* Subroutine */ int blas_dgemv_x__(integer *, integer *, integer *
, doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *);
integer y_prec_state__;
extern /* Subroutine */ int blas_dgemv2_x__(integer *, integer *, integer
*, doublereal *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *), dgemv_(char *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *), dcopy_(integer *, doublereal *,
integer *, doublereal *, integer *);
doublereal dxrat, dzrat;
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
char trans[1];
doublereal normx, normy;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dgetrs_(char *, integer *, integer *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *);
doublereal normdx;
extern /* Character */ VOID chla_transtype__(char *, ftnlen, integer *);
doublereal hugeval;
integer x_state__, z_state__;
/* -- LAPACK routine (version 3.2.1) -- */
/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/* -- Jason Riedy of Univ. of California Berkeley. -- */
/* -- April 2009 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley and NAG Ltd. -- */
/* .. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLA_GERFSX_EXTENDED improves the computed solution to a system of */
/* linear equations by performing extra-precise iterative refinement */
/* and provides error bounds and backward error estimates for the solution. */
/* This subroutine is called by DGERFSX to perform iterative refinement. */
/* In addition to normwise error bound, the code provides maximum */
/* componentwise error bound if possible. See comments for ERR_BNDS_NORM */
/* and ERR_BNDS_COMP for details of the error bounds. Note that this */
/* subroutine is only resonsible for setting the second fields of */
/* ERR_BNDS_NORM and ERR_BNDS_COMP. */
/* Arguments */
/* ========= */
/* PREC_TYPE (input) INTEGER */
/* Specifies the intermediate precision to be used in refinement. */
/* The value is defined by ILAPREC(P) where P is a CHARACTER and */
/* P = 'S': Single */
/* = 'D': Double */
/* = 'I': Indigenous */
/* = 'X', 'E': Extra */
/* TRANS_TYPE (input) INTEGER */
/* Specifies the transposition operation on A. */
/* The value is defined by ILATRANS(T) where T is a CHARACTER and */
/* T = 'N': No transpose */
/* = 'T': Transpose */
/* = 'C': Conjugate transpose */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right-hand-sides, i.e., the number of columns of the */
/* matrix B. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the N-by-N matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */
/* The factors L and U from the factorization */
/* A = P*L*U as computed by DGETRF. */
/* LDAF (input) INTEGER */
/* The leading dimension of the array AF. LDAF >= max(1,N). */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices from the factorization A = P*L*U */
/* as computed by DGETRF; row i of the matrix was interchanged */
/* with row IPIV(i). */
/* COLEQU (input) LOGICAL */
/* If .TRUE. then column equilibration was done to A before calling */
/* this routine. This is needed to compute the solution and error */
/* bounds correctly. */
/* C (input) DOUBLE PRECISION array, dimension (N) */
/* The column scale factors for A. If COLEQU = .FALSE., C */
/* is not accessed. If C is input, each element of C should be a power */
/* of the radix to ensure a reliable solution and error estimates. */
/* Scaling by powers of the radix does not cause rounding errors unless */
/* the result underflows or overflows. Rounding errors during scaling */
/* lead to refining with a matrix that is not equivalent to the */
/* input matrix, producing error estimates that may not be */
/* reliable. */
/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* The right-hand-side matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* Y (input/output) DOUBLE PRECISION array, dimension */
/* (LDY,NRHS) */
/* On entry, the solution matrix X, as computed by DGETRS. */
/* On exit, the improved solution matrix Y. */
/* LDY (input) INTEGER */
/* The leading dimension of the array Y. LDY >= max(1,N). */
/* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS) */
/* On exit, BERR_OUT(j) contains the componentwise relative backward */
/* error for right-hand-side j from the formula */
/* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
/* where abs(Z) is the componentwise absolute value of the matrix */
/* or vector Z. This is computed by DLA_LIN_BERR. */
/* N_NORMS (input) INTEGER */
/* Determines which error bounds to return (see ERR_BNDS_NORM */
/* and ERR_BNDS_COMP). */
/* If N_NORMS >= 1 return normwise error bounds. */
/* If N_NORMS >= 2 return componentwise error bounds. */
/* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension */
/* (NRHS, N_ERR_BNDS) */
/* For each right-hand side, this array contains information about */
/* various error bounds and condition numbers corresponding to the */
/* normwise relative error, which is defined as follows: */
/* Normwise relative error in the ith solution vector: */
/* max_j (abs(XTRUE(j,i) - X(j,i))) */
/* ------------------------------ */
/* max_j abs(X(j,i)) */
/* The array is indexed by the type of error information as described */
/* below. There currently are up to three pieces of information */
/* returned. */
/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
/* right-hand side. */
/* The second index in ERR_BNDS_NORM(:,err) contains the following */
/* three fields: */
/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
/* reciprocal condition number is less than the threshold */
/* sqrt(n) * slamch('Epsilon'). */
/* err = 2 "Guaranteed" error bound: The estimated forward error, */
/* almost certainly within a factor of 10 of the true error */
/* so long as the next entry is greater than the threshold */
/* sqrt(n) * slamch('Epsilon'). This error bound should only */
/* be trusted if the previous boolean is true. */
/* err = 3 Reciprocal condition number: Estimated normwise */
/* reciprocal condition number. Compared with the threshold */
/* sqrt(n) * slamch('Epsilon') to determine if the error */
/* estimate is "guaranteed". These reciprocal condition */
/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
/* appropriately scaled matrix Z. */
/* Let Z = S*A, where S scales each row by a power of the */
/* radix so all absolute row sums of Z are approximately 1. */
/* This subroutine is only responsible for setting the second field */
/* above. */
/* See Lapack Working Note 165 for further details and extra */
/* cautions. */
/* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension */
/* (NRHS, N_ERR_BNDS) */
/* For each right-hand side, this array contains information about */
/* various error bounds and condition numbers corresponding to the */
/* componentwise relative error, which is defined as follows: */
/* Componentwise relative error in the ith solution vector: */
/* abs(XTRUE(j,i) - X(j,i)) */
/* max_j ---------------------- */
/* abs(X(j,i)) */
/* The array is indexed by the right-hand side i (on which the */
/* componentwise relative error depends), and the type of error */
/* information as described below. There currently are up to three */
/* pieces of information returned for each right-hand side. If */
/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
/* the first (:,N_ERR_BNDS) entries are returned. */
/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
/* right-hand side. */
/* The second index in ERR_BNDS_COMP(:,err) contains the following */
/* three fields: */
/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
/* reciprocal condition number is less than the threshold */
/* sqrt(n) * slamch('Epsilon'). */
/* err = 2 "Guaranteed" error bound: The estimated forward error, */
/* almost certainly within a factor of 10 of the true error */
/* so long as the next entry is greater than the threshold */
/* sqrt(n) * slamch('Epsilon'). This error bound should only */
/* be trusted if the previous boolean is true. */
/* err = 3 Reciprocal condition number: Estimated componentwise */
/* reciprocal condition number. Compared with the threshold */
/* sqrt(n) * slamch('Epsilon') to determine if the error */
/* estimate is "guaranteed". These reciprocal condition */
/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
/* appropriately scaled matrix Z. */
/* Let Z = S*(A*diag(x)), where x is the solution for the */
/* current right-hand side and S scales each row of */
/* A*diag(x) by a power of the radix so all absolute row */
/* sums of Z are approximately 1. */
/* This subroutine is only responsible for setting the second field */
/* above. */
/* See Lapack Working Note 165 for further details and extra */
/* cautions. */
/* RES (input) DOUBLE PRECISION array, dimension (N) */
/* Workspace to hold the intermediate residual. */
/* AYB (input) DOUBLE PRECISION array, dimension (N) */
/* Workspace. This can be the same workspace passed for Y_TAIL. */
/* DY (input) DOUBLE PRECISION array, dimension (N) */
/* Workspace to hold the intermediate solution. */
/* Y_TAIL (input) DOUBLE PRECISION array, dimension (N) */
/* Workspace to hold the trailing bits of the intermediate solution. */
/* RCOND (input) DOUBLE PRECISION */
/* Reciprocal scaled condition number. This is an estimate of the */
/* reciprocal Skeel condition number of the matrix A after */
/* equilibration (if done). If this is less than the machine */
/* precision (in particular, if it is zero), the matrix is singular */
/* to working precision. Note that the error may still be small even */
/* if this number is very small and the matrix appears ill- */
/* conditioned. */
/* ITHRESH (input) INTEGER */
/* The maximum number of residual computations allowed for */
/* refinement. The default is 10. For 'aggressive' set to 100 to */
/* permit convergence using approximate factorizations or */
/* factorizations other than LU. If the factorization uses a */
/* technique other than Gaussian elimination, the guarantees in */
/* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */
/* RTHRESH (input) DOUBLE PRECISION */
/* Determines when to stop refinement if the error estimate stops */
/* decreasing. Refinement will stop when the next solution no longer */
/* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */
/* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */
/* default value is 0.5. For 'aggressive' set to 0.9 to permit */
/* convergence on extremely ill-conditioned matrices. See LAWN 165 */
/* for more details. */
/* DZ_UB (input) DOUBLE PRECISION */
/* Determines when to start considering componentwise convergence. */
/* Componentwise convergence is only considered after each component */
/* of the solution Y is stable, which we definte as the relative */
/* change in each component being less than DZ_UB. The default value */
/* is 0.25, requiring the first bit to be stable. See LAWN 165 for */
/* more details. */
/* IGNORE_CWISE (input) LOGICAL */
/* If .TRUE. then ignore componentwise convergence. Default value */
/* is .FALSE.. */
/* INFO (output) INTEGER */
/* = 0: Successful exit. */
/* < 0: if INFO = -i, the ith argument to DGETRS had an illegal */
/* value */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. Parameters .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
errs_c_dim1 = *nrhs;
errs_c_offset = 1 + errs_c_dim1;
errs_c__ -= errs_c_offset;
errs_n_dim1 = *nrhs;
errs_n_offset = 1 + errs_n_dim1;
errs_n__ -= errs_n_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--ipiv;
--c__;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1;
y -= y_offset;
--berr_out__;
--res;
--ayb;
--dy;
--y_tail__;
/* Function Body */
if (*info != 0) {
return 0;
}
chla_transtype__(ch__1, (ftnlen)1, trans_type__);
*(unsigned char *)trans = *(unsigned char *)&ch__1[0];
eps = dlamch_("Epsilon");
hugeval = dlamch_("Overflow");
/* Force HUGEVAL to Inf */
hugeval *= hugeval;
/* Using HUGEVAL may lead to spurious underflows. */
incr_thresh__ = (doublereal) (*n) * eps;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
y_prec_state__ = 1;
if (y_prec_state__ == 2) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
y_tail__[i__] = 0.;
}
}
dxrat = 0.;
dxratmax = 0.;
dzrat = 0.;
dzratmax = 0.;
final_dx_x__ = hugeval;
final_dz_z__ = hugeval;
prevnormdx = hugeval;
prev_dz_z__ = hugeval;
dz_z__ = hugeval;
dx_x__ = hugeval;
x_state__ = 1;
z_state__ = 0;
incr_prec__ = FALSE_;
i__2 = *ithresh;
for (cnt = 1; cnt <= i__2; ++cnt) {
/* Compute residual RES = B_s - op(A_s) * Y, */
/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
dcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
if (y_prec_state__ == 0) {
dgemv_(trans, n, n, &c_b6, &a[a_offset], lda, &y[j * y_dim1 +
1], &c__1, &c_b8, &res[1], &c__1);
} else if (y_prec_state__ == 1) {
blas_dgemv_x__(trans_type__, n, n, &c_b6, &a[a_offset], lda, &
y[j * y_dim1 + 1], &c__1, &c_b8, &res[1], &c__1,
prec_type__);
} else {
blas_dgemv2_x__(trans_type__, n, n, &c_b6, &a[a_offset], lda,
&y[j * y_dim1 + 1], &y_tail__[1], &c__1, &c_b8, &res[
1], &c__1, prec_type__);
}
/* XXX: RES is no longer needed. */
dcopy_(n, &res[1], &c__1, &dy[1], &c__1);
dgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &dy[1],
n, info);
/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */
normx = 0.;
normy = 0.;
normdx = 0.;
dz_z__ = 0.;
ymin = hugeval;
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
yk = (d__1 = y[i__ + j * y_dim1], abs(d__1));
dyk = (d__1 = dy[i__], abs(d__1));
if (yk != 0.) {
/* Computing MAX */
d__1 = dz_z__, d__2 = dyk / yk;
dz_z__ = max(d__1,d__2);
} else if (dyk != 0.) {
dz_z__ = hugeval;
}
ymin = min(ymin,yk);
normy = max(normy,yk);
if (*colequ) {
/* Computing MAX */
d__1 = normx, d__2 = yk * c__[i__];
normx = max(d__1,d__2);
/* Computing MAX */
d__1 = normdx, d__2 = dyk * c__[i__];
normdx = max(d__1,d__2);
} else {
normx = normy;
normdx = max(normdx,dyk);
}
}
if (normx != 0.) {
dx_x__ = normdx / normx;
} else if (normdx == 0.) {
dx_x__ = 0.;
} else {
dx_x__ = hugeval;
}
dxrat = normdx / prevnormdx;
dzrat = dz_z__ / prev_dz_z__;
/* Check termination criteria */
if (! (*ignore_cwise__) && ymin * *rcond < incr_thresh__ * normy
&& y_prec_state__ < 2) {
incr_prec__ = TRUE_;
}
if (x_state__ == 3 && dxrat <= *rthresh) {
x_state__ = 1;
}
if (x_state__ == 1) {
if (dx_x__ <= eps) {
x_state__ = 2;
} else if (dxrat > *rthresh) {
if (y_prec_state__ != 2) {
incr_prec__ = TRUE_;
} else {
x_state__ = 3;
}
} else {
if (dxrat > dxratmax) {
dxratmax = dxrat;
}
}
if (x_state__ > 1) {
final_dx_x__ = dx_x__;
}
}
if (z_state__ == 0 && dz_z__ <= *dz_ub__) {
z_state__ = 1;
}
if (z_state__ == 3 && dzrat <= *rthresh) {
z_state__ = 1;
}
if (z_state__ == 1) {
if (dz_z__ <= eps) {
z_state__ = 2;
} else if (dz_z__ > *dz_ub__) {
z_state__ = 0;
dzratmax = 0.;
final_dz_z__ = hugeval;
} else if (dzrat > *rthresh) {
if (y_prec_state__ != 2) {
incr_prec__ = TRUE_;
} else {
z_state__ = 3;
}
} else {
if (dzrat > dzratmax) {
dzratmax = dzrat;
}
}
if (z_state__ > 1) {
final_dz_z__ = dz_z__;
}
}
/* Exit if both normwise and componentwise stopped working, */
/* but if componentwise is unstable, let it go at least two */
/* iterations. */
if (x_state__ != 1) {
if (*ignore_cwise__) {
goto L666;
}
if (z_state__ == 3 || z_state__ == 2) {
goto L666;
}
if (z_state__ == 0 && cnt > 1) {
goto L666;
}
}
if (incr_prec__) {
incr_prec__ = FALSE_;
++y_prec_state__;
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
y_tail__[i__] = 0.;
}
}
prevnormdx = normdx;
prev_dz_z__ = dz_z__;
/* Update soluton. */
if (y_prec_state__ < 2) {
daxpy_(n, &c_b8, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1);
} else {
dla_wwaddw__(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]);
}
}
/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. */
L666:
/* Set final_* when cnt hits ithresh. */
if (x_state__ == 1) {
final_dx_x__ = dx_x__;
}
if (z_state__ == 1) {
final_dz_z__ = dz_z__;
}
/* Compute error bounds */
if (*n_norms__ >= 1) {
errs_n__[j + (errs_n_dim1 << 1)] = final_dx_x__ / (1 - dxratmax);
}
if (*n_norms__ >= 2) {
errs_c__[j + (errs_c_dim1 << 1)] = final_dz_z__ / (1 - dzratmax);
}
/* Compute componentwise relative backward error from formula */
/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
/* where abs(Z) is the componentwise absolute value of the matrix */
/* or vector Z. */
/* Compute residual RES = B_s - op(A_s) * Y, */
/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
dcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
dgemv_(trans, n, n, &c_b6, &a[a_offset], lda, &y[j * y_dim1 + 1], &
c__1, &c_b8, &res[1], &c__1);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
ayb[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1));
}
/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */
dla_geamv__(trans_type__, n, n, &c_b8, &a[a_offset], lda, &y[j *
y_dim1 + 1], &c__1, &c_b8, &ayb[1], &c__1);
dla_lin_berr__(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]);
/* End of loop for each RHS. */
}
return 0;
} /* dla_gerfsx_extended__ */
void Peer::solve(const SOLVERCALL action)
{
if ((action & RECORDCALL) && (action & FIRST_CALL)) {
initialize();
return;
}
double t=_tCurrent;
// Initialization phase
_continuous_system[0]->evaluateAll(IContinuous::ALL);
SolverDefaultImplementation::writeToFile(0, t, _h);
#ifdef MPIPEER
std::copy(_y,_y+_dimSys,_Y1);
if (abs(_c[_rank]+1.)>1e-12)
{
ros2(_Y1,_tCurrent,_tCurrent+_h*(_c[_rank]+1.));
t=_tCurrent;
}
MPI_Barrier(MPI_COMM_WORLD);
if(_rank==0) {
MPI_Gather(MPI_IN_PLACE,_dimSys,MPI_DOUBLE,_Y1,_dimSys,MPI_DOUBLE,0,MPI_COMM_WORLD);
} else {
MPI_Gather(_Y1,_dimSys,MPI_DOUBLE,_Y1,_dimSys,MPI_DOUBLE,0,MPI_COMM_WORLD);
}
t+=_h;
#else
#pragma omp parallel for
for(int _rank=0; _rank<5; ++_rank) {
std::copy(_y,_y+_dimSys,&_Y1[_rank*_dimSys]);
if (abs(_c[_rank]+1.)>1e-12)
{
ros2(&_Y1[_rank*_dimSys],_tCurrent,_tCurrent+_h*(_c[_rank]+1.), _continuous_system[_rank], _time_system[_rank]);
t=_tCurrent;
}
}
t+=_h;
_time_system[0]->setTime(t);
_continuous_system[0]->setContinuousStates(&_Y1[2*_dimSys]);
_continuous_system[0]->evaluateAll(IContinuous::ALL);
SolverDefaultImplementation::writeToFile(0, t, _h);
#endif
// std::cerr << "Finished init at rank " << _rank<<std::endl;
// Solution phase
t+=_h;
char trans='N';
long int dim=1;
while(std::abs(t-_tEnd)>1e-8)
{
#ifdef MPIPEER
if(_rank==0)
{
for(int i=0; i<_rstages; ++i)
{
for(int j=0; j<_dimSys; ++j) {
_Y2[i*_dimSys+j]=0.;
for(int k=0; k<_rstages;++k) {
_Y2[i*_dimSys+j]+=_Y1[k*_dimSys+j]*_Theta[i*_rstages+k];
}
}
// Y2.vector(i)=Y1*mtl::vector::trans(Theta[i][iall]);
}
std::cout<<"_Y2 vals on rank "<<_rank<<": ";
for(int i=0; i<_rstages*_dimSys;++i) {
if(!(i%20)) std::cout<<std::endl;
std::cout<<_Y2[i]<<" ";
}
std::cout<<std::endl;
for(int i=0; i<_rstages; i++)
{
for(int j=0; j<_dimSys; ++j) {
_Y3[i*_dimSys+j]=0.;
for(int k=0; k<_rstages;++k) {
_Y3[i*_dimSys+j]+=_Y2[k*_dimSys+j]*_E[i*_rstages+k];
}
}
// Y3.vector(i)=Y2*mtl::vector::trans(E[i][iall]);
}
}
MPI_Barrier(MPI_COMM_WORLD);
// std::cerr << "Finished rank 0 calculation step at rank " << _rank<<std::endl;
if(_rank==0) {
MPI_Scatter( _Y2,_dimSys,MPI_DOUBLE,MPI_IN_PLACE,_dimSys,MPI_DOUBLE,0,MPI_COMM_WORLD);
MPI_Scatter( _Y3,_dimSys,MPI_DOUBLE,MPI_IN_PLACE,_dimSys,MPI_DOUBLE,0,MPI_COMM_WORLD);
} else {
MPI_Scatter(_Y2,_dimSys,MPI_DOUBLE,_Y2,_dimSys,MPI_DOUBLE,0,MPI_COMM_WORLD);
MPI_Scatter(_Y3,_dimSys,MPI_DOUBLE,_Y3,_dimSys,MPI_DOUBLE,0,MPI_COMM_WORLD);
}
evalF(t+_c[_rank]*_h,_Y2,_F);
evalJ(t+_c[_rank]*_h,_Y2,_T);
if(_rank==0) {
std::cout<<"Jac: ";
for(int i(0); i<_dimSys*_dimSys;++i) {
if(!(i%20)) std::cout<<std::endl;
std::cout<<_T[i]<<" ";
}
std::cout<<std::endl;
}
for(int i=0; i<_dimSys; ++i) {
for(int j=0; j<_dimSys; ++j) {
_T[i*_dimSys+j]*=-_h*_G[_rank];
}
_T[i*_dimSys+i]+=1.;
}
// std::cerr << "Finished iteration matrix calculation step at rank " << _rank<<std::endl;
dgetrf_(&_dimSys, &_dimSys, _T, &_dimSys, _P, &info);
for(int i=0; i<_dimSys; ++i) {
_F[i]*=_h;
_F[i]-=_Y3[i];
_F[i]*=_G[_rank];
}
dgetrs_(&trans, &_dimSys, &dim, _T, &_dimSys, _P, _F, &_dimSys, &info);
for(int i=0; i<_dimSys; ++i) {
_Y1[i]=_F[i]+_Y2[i];
}
MPI_Barrier(MPI_COMM_WORLD);
if(_rank==0) {
MPI_Gather(MPI_IN_PLACE,_dimSys,MPI_DOUBLE,_Y1,_dimSys,MPI_DOUBLE,0,MPI_COMM_WORLD);
} else {
MPI_Gather(_Y1,_dimSys,MPI_DOUBLE,_Y1,_dimSys,MPI_DOUBLE,0,MPI_COMM_WORLD);
}
if(t+_h>_tEnd) _h=_tEnd-t;
if(_rank==0) {
SolverDefaultImplementation::writeToFile(0, t, _h);
}
t+=_h;
#else
for(int i=0; i<_rstages; ++i)
{
for(int j=0; j<_dimSys; ++j) {
_Y2[i*_dimSys+j]=0.;
for(int k=0; k<_rstages;++k) {
_Y2[i*_dimSys+j]+=_Y1[k*_dimSys+j]*_Theta[i*_rstages+k];
}
}
// Y2.vector(i)=Y1*mtl::vector::trans(Theta[i][iall]);
}
for(int i=0; i<_rstages; i++)
{
for(int j=0; j<_dimSys; ++j) {
_Y3[i*_dimSys+j]=0.;
for(int k=0; k<_rstages;++k) {
_Y3[i*_dimSys+j]+=_Y2[k*_dimSys+j]*_E[i*_rstages+k];
}
}
// Y3.vector(i)=Y2*mtl::vector::trans(E[i][iall]);
}
#pragma omp parallel for
for(int _rank=0; _rank<5; ++_rank) {
long int info;
evalF(t+_c[_rank]*_h,&_Y2[_rank*_dimSys],&_F[_rank*_dimSys],_continuous_system[_rank], _time_system[_rank]);
evalJ(t+_c[_rank]*_h,&_Y2[_rank*_dimSys],&_T[_rank*_dimSys*_dimSys], _continuous_system[_rank], _time_system[_rank]);
for(int i=0; i<_dimSys; ++i) {
for(int j=0; j<_dimSys; ++j) {
_T[_rank*_dimSys*_dimSys+i*_dimSys+j]*=-_h*_G[_rank];
}
_T[_rank*_dimSys*_dimSys+i*_dimSys+i]+=1.;
}
// std::cerr << "Finished iteration matrix calculation step at rank " << _rank<<std::endl;
dgetrf_(&_dimSys, &_dimSys, &_T[_rank*_dimSys*_dimSys], &_dimSys, &_P[_rank*_dimSys], &info);
for(int i=0; i<_dimSys; ++i) {
_F[_rank*_dimSys+i]*=_h;
_F[_rank*_dimSys+i]-=_Y3[_rank*_dimSys+i];
_F[_rank*_dimSys+i]*=_G[_rank];
}
dgetrs_(&trans, &_dimSys, &dim, &_T[_rank*_dimSys*_dimSys], &_dimSys, &_P[_rank*_dimSys], &_F[_rank*_dimSys], &_dimSys, &info);
for(int i=0; i<_dimSys; ++i) {
_Y1[_rank*_dimSys+i]=_F[_rank*_dimSys+i]+_Y2[_rank*_dimSys+i];
}
}
if(t+_h>_tEnd) _h=_tEnd-t;
_time_system[0]->setTime(t);
_continuous_system[0]->setContinuousStates(&_Y1[2*_dimSys]);
_continuous_system[0]->evaluateAll(IContinuous::ALL);
SolverDefaultImplementation::writeToFile(0, t, _h);
t+=_h;
#endif
}
#ifdef MPIPEER
MPI_Barrier(MPI_COMM_WORLD);
if(_rank==0)
{
for(int i=0; i<_dimSys; i++) _y[i]=_Y1[(_rstages-1)*_dimSys+i];
}
MPI_Bcast(_y, _dimSys, MPI_DOUBLE, 0, MPI_COMM_WORLD);
#else
for(int i=0; i<_dimSys; i++) _y[i]=_Y1[(_rstages-1)*_dimSys+i];
#endif
_tCurrent=_tEnd;
_time_system[0]->setTime(_tCurrent);
_continuous_system[0]->setContinuousStates(&_Y1[4*_dimSys]);
_continuous_system[0]->evaluateAll(IContinuous::ALL);
SolverDefaultImplementation::writeToFile(0, t, _h);
_solverStatus = ISolver::DONE;
}
/* Subroutine */ int dgesvx_(char *fact, char *trans, integer *n, integer *
nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf,
integer *ipiv, char *equed, doublereal *r__, doublereal *c__,
doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *
rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer *
iwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
x_offset, i__1, i__2;
doublereal d__1, d__2;
/* Local variables */
integer i__, j;
doublereal amax;
char norm[1];
extern logical lsame_(char *, char *);
doublereal rcmin, rcmax, anorm;
logical equil;
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dlaqge_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, char *), dgecon_(char *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *);
doublereal colcnd;
logical nofact;
extern /* Subroutine */ int dgeequ_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *), dgerfs_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, integer *, integer *),
dgetrf_(integer *, integer *, doublereal *, integer *, integer *,
integer *), dlacpy_(char *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *), xerbla_(char *,
integer *);
doublereal bignum;
extern doublereal dlantr_(char *, char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *);
integer infequ;
logical colequ;
extern /* Subroutine */ int dgetrs_(char *, integer *, integer *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *);
doublereal rowcnd;
logical notran;
doublereal smlnum;
logical rowequ;
doublereal rpvgrw;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGESVX uses the LU factorization to compute the solution to a real */
/* system of linear equations */
/* A * X = B, */
/* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. */
/* Error bounds on the solution and a condition estimate are also */
/* provided. */
/* Description */
/* =========== */
/* The following steps are performed: */
/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
/* the system: */
/* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */
/* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */
/* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */
/* Whether or not the system will be equilibrated depends on the */
/* scaling of the matrix A, but if equilibration is used, A is */
/* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */
/* or diag(C)*B (if TRANS = 'T' or 'C'). */
/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the */
/* matrix A (after equilibration if FACT = 'E') as */
/* A = P * L * U, */
/* where P is a permutation matrix, L is a unit lower triangular */
/* matrix, and U is upper triangular. */
/* 3. If some U(i,i)=0, so that U is exactly singular, then the routine */
/* returns with INFO = i. Otherwise, the factored form of A is used */
/* to estimate the condition number of the matrix A. If the */
/* reciprocal of the condition number is less than machine precision, */
/* INFO = N+1 is returned as a warning, but the routine still goes on */
/* to solve for X and compute error bounds as described below. */
/* 4. The system of equations is solved for X using the factored form */
/* of A. */
/* 5. Iterative refinement is applied to improve the computed solution */
/* matrix and calculate error bounds and backward error estimates */
/* for it. */
/* 6. If equilibration was used, the matrix X is premultiplied by */
/* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */
/* that it solves the original system before equilibration. */
/* Arguments */
/* ========= */
/* FACT (input) CHARACTER*1 */
/* Specifies whether or not the factored form of the matrix A is */
/* supplied on entry, and if not, whether the matrix A should be */
/* equilibrated before it is factored. */
/* = 'F': On entry, AF and IPIV contain the factored form of A. */
/* If EQUED is not 'N', the matrix A has been */
/* equilibrated with scaling factors given by R and C. */
/* A, AF, and IPIV are not modified. */
/* = 'N': The matrix A will be copied to AF and factored. */
/* = 'E': The matrix A will be equilibrated if necessary, then */
/* copied to AF and factored. */
/* TRANS (input) CHARACTER*1 */
/* Specifies the form of the system of equations: */
/* = 'N': A * X = B (No transpose) */
/* = 'T': A**T * X = B (Transpose) */
/* = 'C': A**H * X = B (Transpose) */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is */
/* not 'N', then A must have been equilibrated by the scaling */
/* factors in R and/or C. A is not modified if FACT = 'F' or */
/* 'N', or if FACT = 'E' and EQUED = 'N' on exit. */
/* On exit, if EQUED .ne. 'N', A is scaled as follows: */
/* EQUED = 'R': A := diag(R) * A */
/* EQUED = 'C': A := A * diag(C) */
/* EQUED = 'B': A := diag(R) * A * diag(C). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N) */
/* If FACT = 'F', then AF is an input argument and on entry */
/* contains the factors L and U from the factorization */
/* A = P*L*U as computed by DGETRF. If EQUED .ne. 'N', then */
/* AF is the factored form of the equilibrated matrix A. */
/* If FACT = 'N', then AF is an output argument and on exit */
/* returns the factors L and U from the factorization A = P*L*U */
/* of the original matrix A. */
/* If FACT = 'E', then AF is an output argument and on exit */
/* returns the factors L and U from the factorization A = P*L*U */
/* of the equilibrated matrix A (see the description of A for */
/* the form of the equilibrated matrix). */
/* LDAF (input) INTEGER */
/* The leading dimension of the array AF. LDAF >= max(1,N). */
/* IPIV (input or output) INTEGER array, dimension (N) */
/* If FACT = 'F', then IPIV is an input argument and on entry */
/* contains the pivot indices from the factorization A = P*L*U */
/* as computed by DGETRF; row i of the matrix was interchanged */
/* with row IPIV(i). */
/* If FACT = 'N', then IPIV is an output argument and on exit */
/* contains the pivot indices from the factorization A = P*L*U */
/* of the original matrix A. */
/* If FACT = 'E', then IPIV is an output argument and on exit */
/* contains the pivot indices from the factorization A = P*L*U */
/* of the equilibrated matrix A. */
/* EQUED (input or output) CHARACTER*1 */
/* Specifies the form of equilibration that was done. */
/* = 'N': No equilibration (always true if FACT = 'N'). */
/* = 'R': Row equilibration, i.e., A has been premultiplied by */
/* diag(R). */
/* = 'C': Column equilibration, i.e., A has been postmultiplied */
/* by diag(C). */
/* = 'B': Both row and column equilibration, i.e., A has been */
/* replaced by diag(R) * A * diag(C). */
/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
/* output argument. */
/* R (input or output) DOUBLE PRECISION array, dimension (N) */
/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
/* is not accessed. R is an input argument if FACT = 'F'; */
/* otherwise, R is an output argument. If FACT = 'F' and */
/* EQUED = 'R' or 'B', each element of R must be positive. */
/* C (input or output) DOUBLE PRECISION array, dimension (N) */
/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
/* is not accessed. C is an input argument if FACT = 'F'; */
/* otherwise, C is an output argument. If FACT = 'F' and */
/* EQUED = 'C' or 'B', each element of C must be positive. */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* On entry, the N-by-NRHS right hand side matrix B. */
/* On exit, */
/* if EQUED = 'N', B is not modified; */
/* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */
/* diag(R)*B; */
/* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */
/* overwritten by diag(C)*B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X */
/* to the original system of equations. Note that A and B are */
/* modified on exit if EQUED .ne. 'N', and the solution to the */
/* equilibrated system is inv(diag(C))*X if TRANS = 'N' and */
/* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C' */
/* and EQUED = 'R' or 'B'. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* RCOND (output) DOUBLE PRECISION */
/* The estimate of the reciprocal condition number of the matrix */
/* A after equilibration (if done). If RCOND is less than the */
/* machine precision (in particular, if RCOND = 0), the matrix */
/* is singular to working precision. This condition is */
/* indicated by a return code of INFO > 0. */
/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
/* The estimated forward error bound for each solution vector */
/* X(j) (the j-th column of the solution matrix X). */
/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
/* is an estimated upper bound for the magnitude of the largest */
/* element in (X(j) - XTRUE) divided by the magnitude of the */
/* largest element in X(j). The estimate is as reliable as */
/* the estimate for RCOND, and is almost always a slight */
/* overestimate of the true error. */
/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector X(j) (i.e., the smallest relative change in */
/* any element of A or B that makes X(j) an exact solution). */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (4*N) */
/* On exit, WORK(1) contains the reciprocal pivot growth */
/* factor norm(A)/norm(U). The "max absolute element" norm is */
/* used. If WORK(1) is much less than 1, then the stability */
/* of the LU factorization of the (equilibrated) matrix A */
/* could be poor. This also means that the solution X, condition */
/* estimator RCOND, and forward error bound FERR could be */
/* unreliable. If factorization fails with 0<INFO<=N, then */
/* WORK(1) contains the reciprocal pivot growth factor for the */
/* leading INFO columns of A. */
/* IWORK (workspace) INTEGER array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, and i is */
/* <= N: U(i,i) is exactly zero. The factorization has */
/* been completed, but the factor U is exactly */
/* singular, so the solution and error bounds */
/* could not be computed. RCOND = 0 is returned. */
/* = N+1: U is nonsingular, but RCOND is less than machine */
/* precision, meaning that the matrix is singular */
/* to working precision. Nevertheless, the */
/* solution and error bounds are computed because */
/* there are a number of situations where the */
/* computed solution can be more accurate than the */
/* value of RCOND would suggest. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--ipiv;
--r__;
--c__;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--iwork;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
notran = lsame_(trans, "N");
if (nofact || equil) {
*(unsigned char *)equed = 'N';
rowequ = FALSE_;
colequ = FALSE_;
} else {
rowequ = lsame_(equed, "R") || lsame_(equed,
"B");
colequ = lsame_(equed, "C") || lsame_(equed,
"B");
smlnum = dlamch_("Safe minimum");
bignum = 1. / smlnum;
}
/* Test the input parameters. */
if (! nofact && ! equil && ! lsame_(fact, "F")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && !
lsame_(trans, "C")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldaf < max(1,*n)) {
*info = -8;
} else if (lsame_(fact, "F") && ! (rowequ || colequ
|| lsame_(equed, "N"))) {
*info = -10;
} else {
if (rowequ) {
rcmin = bignum;
rcmax = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
d__1 = rcmin, d__2 = r__[j];
rcmin = min(d__1,d__2);
/* Computing MAX */
d__1 = rcmax, d__2 = r__[j];
rcmax = max(d__1,d__2);
/* L10: */
}
if (rcmin <= 0.) {
*info = -11;
} else if (*n > 0) {
rowcnd = max(rcmin,smlnum) / min(rcmax,bignum);
} else {
rowcnd = 1.;
}
}
if (colequ && *info == 0) {
rcmin = bignum;
rcmax = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
d__1 = rcmin, d__2 = c__[j];
rcmin = min(d__1,d__2);
/* Computing MAX */
d__1 = rcmax, d__2 = c__[j];
rcmax = max(d__1,d__2);
/* L20: */
}
if (rcmin <= 0.) {
*info = -12;
} else if (*n > 0) {
colcnd = max(rcmin,smlnum) / min(rcmax,bignum);
} else {
colcnd = 1.;
}
}
if (*info == 0) {
if (*ldb < max(1,*n)) {
*info = -14;
} else if (*ldx < max(1,*n)) {
*info = -16;
}
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGESVX", &i__1);
return 0;
}
if (equil) {
/* Compute row and column scalings to equilibrate the matrix A. */
dgeequ_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, &colcnd, &
amax, &infequ);
if (infequ == 0) {
/* Equilibrate the matrix. */
dlaqge_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, &
colcnd, &amax, equed);
rowequ = lsame_(equed, "R") || lsame_(equed,
"B");
colequ = lsame_(equed, "C") || lsame_(equed,
"B");
}
}
/* Scale the right hand side. */
if (notran) {
if (rowequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
b[i__ + j * b_dim1] = r__[i__] * b[i__ + j * b_dim1];
/* L30: */
}
/* L40: */
}
}
} else if (colequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
b[i__ + j * b_dim1] = c__[i__] * b[i__ + j * b_dim1];
/* L50: */
}
/* L60: */
}
}
if (nofact || equil) {
/* Compute the LU factorization of A. */
dlacpy_("Full", n, n, &a[a_offset], lda, &af[af_offset], ldaf);
dgetrf_(n, n, &af[af_offset], ldaf, &ipiv[1], info);
/* Return if INFO is non-zero. */
if (*info > 0) {
/* Compute the reciprocal pivot growth factor of the */
/* leading rank-deficient INFO columns of A. */
rpvgrw = dlantr_("M", "U", "N", info, info, &af[af_offset], ldaf,
&work[1]);
if (rpvgrw == 0.) {
rpvgrw = 1.;
} else {
rpvgrw = dlange_("M", n, info, &a[a_offset], lda, &work[1]) / rpvgrw;
}
work[1] = rpvgrw;
*rcond = 0.;
return 0;
}
}
/* Compute the norm of the matrix A and the */
/* reciprocal pivot growth factor RPVGRW. */
if (notran) {
*(unsigned char *)norm = '1';
} else {
*(unsigned char *)norm = 'I';
}
anorm = dlange_(norm, n, n, &a[a_offset], lda, &work[1]);
rpvgrw = dlantr_("M", "U", "N", n, n, &af[af_offset], ldaf, &work[1]);
if (rpvgrw == 0.) {
rpvgrw = 1.;
} else {
rpvgrw = dlange_("M", n, n, &a[a_offset], lda, &work[1]) /
rpvgrw;
}
/* Compute the reciprocal of the condition number of A. */
dgecon_(norm, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &iwork[1],
info);
/* Compute the solution matrix X. */
dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
dgetrs_(trans, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx,
info);
/* Use iterative refinement to improve the computed solution and */
/* compute error bounds and backward error estimates for it. */
dgerfs_(trans, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &ipiv[1],
&b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[
1], &iwork[1], info);
/* Transform the solution matrix X to a solution of the original */
/* system. */
if (notran) {
if (colequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
x[i__ + j * x_dim1] = c__[i__] * x[i__ + j * x_dim1];
/* L70: */
}
/* L80: */
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] /= colcnd;
/* L90: */
}
}
} else if (rowequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
x[i__ + j * x_dim1] = r__[i__] * x[i__ + j * x_dim1];
/* L100: */
}
/* L110: */
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] /= rowcnd;
/* L120: */
}
}
work[1] = rpvgrw;
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < dlamch_("Epsilon")) {
*info = *n + 1;
}
return 0;
/* End of DGESVX */
} /* dgesvx_ */
/* Subroutine */ int dgesvxx_(char *fact, char *trans, integer *n, integer *
nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf,
integer *ipiv, char *equed, doublereal *r__, doublereal *c__,
doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *
rcond, doublereal *rpvgrw, doublereal *berr, integer *n_err_bnds__,
doublereal *err_bnds_norm__, doublereal *err_bnds_comp__, integer *
nparams, doublereal *params, doublereal *work, integer *iwork,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
doublereal d__1, d__2;
/* Local variables */
integer j;
doublereal amax;
doublereal rcmin, rcmax;
logical equil;
doublereal colcnd;
logical nofact;
doublereal bignum;
integer infequ;
logical colequ;
doublereal rowcnd;
logical notran;
doublereal smlnum;
logical rowequ;
/* -- LAPACK driver routine (version 3.2) -- */
/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/* -- Jason Riedy of Univ. of California Berkeley. -- */
/* -- November 2008 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley and NAG Ltd. -- */
/* Purpose */
/* ======= */
/* DGESVXX uses the LU factorization to compute the solution to a */
/* double precision system of linear equations A * X = B, where A is an */
/* N-by-N matrix and X and B are N-by-NRHS matrices. */
/* If requested, both normwise and maximum componentwise error bounds */
/* are returned. DGESVXX will return a solution with a tiny */
/* guaranteed error (O(eps) where eps is the working machine */
/* precision) unless the matrix is very ill-conditioned, in which */
/* case a warning is returned. Relevant condition numbers also are */
/* calculated and returned. */
/* DGESVXX accepts user-provided factorizations and equilibration */
/* factors; see the definitions of the FACT and EQUED options. */
/* Solving with refinement and using a factorization from a previous */
/* DGESVXX call will also produce a solution with either O(eps) */
/* errors or warnings, but we cannot make that claim for general */
/* user-provided factorizations and equilibration factors if they */
/* differ from what DGESVXX would itself produce. */
/* Description */
/* =========== */
/* The following steps are performed: */
/* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate */
/* the system: */
/* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */
/* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */
/* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */
/* Whether or not the system will be equilibrated depends on the */
/* scaling of the matrix A, but if equilibration is used, A is */
/* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */
/* or diag(C)*B (if TRANS = 'T' or 'C'). */
/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor */
/* the matrix A (after equilibration if FACT = 'E') as */
/* A = P * L * U, */
/* where P is a permutation matrix, L is a unit lower triangular */
/* matrix, and U is upper triangular. */
/* 3. If some U(i,i)=0, so that U is exactly singular, then the */
/* routine returns with INFO = i. Otherwise, the factored form of A */
/* is used to estimate the condition number of the matrix A (see */
/* argument RCOND). If the reciprocal of the condition number is less */
/* than machine precision, the routine still goes on to solve for X */
/* and compute error bounds as described below. */
/* 4. The system of equations is solved for X using the factored form */
/* of A. */
/* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */
/* the routine will use iterative refinement to try to get a small */
/* error and error bounds. Refinement calculates the residual to at */
/* least twice the working precision. */
/* 6. If equilibration was used, the matrix X is premultiplied by */
/* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */
/* that it solves the original system before equilibration. */
/* Arguments */
/* ========= */
/* Some optional parameters are bundled in the PARAMS array. These */
/* settings determine how refinement is performed, but often the */
/* defaults are acceptable. If the defaults are acceptable, users */
/* can pass NPARAMS = 0 which prevents the source code from accessing */
/* the PARAMS argument. */
/* FACT (input) CHARACTER*1 */
/* Specifies whether or not the factored form of the matrix A is */
/* supplied on entry, and if not, whether the matrix A should be */
/* equilibrated before it is factored. */
/* = 'F': On entry, AF and IPIV contain the factored form of A. */
/* If EQUED is not 'N', the matrix A has been */
/* equilibrated with scaling factors given by R and C. */
/* A, AF, and IPIV are not modified. */
/* = 'N': The matrix A will be copied to AF and factored. */
/* = 'E': The matrix A will be equilibrated if necessary, then */
/* copied to AF and factored. */
/* TRANS (input) CHARACTER*1 */
/* Specifies the form of the system of equations: */
/* = 'N': A * X = B (No transpose) */
/* = 'T': A**T * X = B (Transpose) */
/* = 'C': A**H * X = B (Conjugate Transpose = Transpose) */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is */
/* not 'N', then A must have been equilibrated by the scaling */
/* factors in R and/or C. A is not modified if FACT = 'F' or */
/* 'N', or if FACT = 'E' and EQUED = 'N' on exit. */
/* On exit, if EQUED .ne. 'N', A is scaled as follows: */
/* EQUED = 'R': A := diag(R) * A */
/* EQUED = 'C': A := A * diag(C) */
/* EQUED = 'B': A := diag(R) * A * diag(C). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N) */
/* If FACT = 'F', then AF is an input argument and on entry */
/* contains the factors L and U from the factorization */
/* A = P*L*U as computed by DGETRF. If EQUED .ne. 'N', then */
/* AF is the factored form of the equilibrated matrix A. */
/* If FACT = 'N', then AF is an output argument and on exit */
/* returns the factors L and U from the factorization A = P*L*U */
/* of the original matrix A. */
/* If FACT = 'E', then AF is an output argument and on exit */
/* returns the factors L and U from the factorization A = P*L*U */
/* of the equilibrated matrix A (see the description of A for */
/* the form of the equilibrated matrix). */
/* LDAF (input) INTEGER */
/* The leading dimension of the array AF. LDAF >= max(1,N). */
/* IPIV (input or output) INTEGER array, dimension (N) */
/* If FACT = 'F', then IPIV is an input argument and on entry */
/* contains the pivot indices from the factorization A = P*L*U */
/* as computed by DGETRF; row i of the matrix was interchanged */
/* with row IPIV(i). */
/* If FACT = 'N', then IPIV is an output argument and on exit */
/* contains the pivot indices from the factorization A = P*L*U */
/* of the original matrix A. */
/* If FACT = 'E', then IPIV is an output argument and on exit */
/* contains the pivot indices from the factorization A = P*L*U */
/* of the equilibrated matrix A. */
/* EQUED (input or output) CHARACTER*1 */
/* Specifies the form of equilibration that was done. */
/* = 'N': No equilibration (always true if FACT = 'N'). */
/* = 'R': Row equilibration, i.e., A has been premultiplied by */
/* diag(R). */
/* = 'C': Column equilibration, i.e., A has been postmultiplied */
/* by diag(C). */
/* = 'B': Both row and column equilibration, i.e., A has been */
/* replaced by diag(R) * A * diag(C). */
/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
/* output argument. */
/* R (input or output) DOUBLE PRECISION array, dimension (N) */
/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
/* is not accessed. R is an input argument if FACT = 'F'; */
/* otherwise, R is an output argument. If FACT = 'F' and */
/* EQUED = 'R' or 'B', each element of R must be positive. */
/* If R is output, each element of R is a power of the radix. */
/* If R is input, each element of R should be a power of the radix */
/* to ensure a reliable solution and error estimates. Scaling by */
/* powers of the radix does not cause rounding errors unless the */
/* result underflows or overflows. Rounding errors during scaling */
/* lead to refining with a matrix that is not equivalent to the */
/* input matrix, producing error estimates that may not be */
/* reliable. */
/* C (input or output) DOUBLE PRECISION array, dimension (N) */
/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
/* is not accessed. C is an input argument if FACT = 'F'; */
/* otherwise, C is an output argument. If FACT = 'F' and */
/* EQUED = 'C' or 'B', each element of C must be positive. */
/* If C is output, each element of C is a power of the radix. */
/* If C is input, each element of C should be a power of the radix */
/* to ensure a reliable solution and error estimates. Scaling by */
/* powers of the radix does not cause rounding errors unless the */
/* result underflows or overflows. Rounding errors during scaling */
/* lead to refining with a matrix that is not equivalent to the */
/* input matrix, producing error estimates that may not be */
/* reliable. */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* On entry, the N-by-NRHS right hand side matrix B. */
/* On exit, */
/* if EQUED = 'N', B is not modified; */
/* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */
/* diag(R)*B; */
/* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */
/* overwritten by diag(C)*B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* If INFO = 0, the N-by-NRHS solution matrix X to the original */
/* system of equations. Note that A and B are modified on exit */
/* if EQUED .ne. 'N', and the solution to the equilibrated system is */
/* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or */
/* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* RCOND (output) DOUBLE PRECISION */
/* Reciprocal scaled condition number. This is an estimate of the */
/* reciprocal Skeel condition number of the matrix A after */
/* equilibration (if done). If this is less than the machine */
/* precision (in particular, if it is zero), the matrix is singular */
/* to working precision. Note that the error may still be small even */
/* if this number is very small and the matrix appears ill- */
/* conditioned. */
/* RPVGRW (output) DOUBLE PRECISION */
/* Reciprocal pivot growth. On exit, this contains the reciprocal */
/* pivot growth factor norm(A)/norm(U). The "max absolute element" */
/* norm is used. If this is much less than 1, then the stability of */
/* the LU factorization of the (equilibrated) matrix A could be poor. */
/* This also means that the solution X, estimated condition numbers, */
/* and error bounds could be unreliable. If factorization fails with */
/* 0<INFO<=N, then this contains the reciprocal pivot growth factor */
/* for the leading INFO columns of A. In DGESVX, this quantity is */
/* returned in WORK(1). */
/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
/* Componentwise relative backward error. This is the */
/* componentwise relative backward error of each solution vector X(j) */
/* (i.e., the smallest relative change in any element of A or B that */
/* makes X(j) an exact solution). */
/* N_ERR_BNDS (input) INTEGER */
/* Number of error bounds to return for each right hand side */
/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
/* ERR_BNDS_COMP below. */
/* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
/* For each right-hand side, this array contains information about */
/* various error bounds and condition numbers corresponding to the */
/* normwise relative error, which is defined as follows: */
/* Normwise relative error in the ith solution vector: */
/* max_j (abs(XTRUE(j,i) - X(j,i))) */
/* ------------------------------ */
/* max_j abs(X(j,i)) */
/* The array is indexed by the type of error information as described */
/* below. There currently are up to three pieces of information */
/* returned. */
/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
/* right-hand side. */
/* The second index in ERR_BNDS_NORM(:,err) contains the following */
/* three fields: */
/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
/* reciprocal condition number is less than the threshold */
/* sqrt(n) * dlamch('Epsilon'). */
/* err = 2 "Guaranteed" error bound: The estimated forward error, */
/* almost certainly within a factor of 10 of the true error */
/* so long as the next entry is greater than the threshold */
/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
/* be trusted if the previous boolean is true. */
/* err = 3 Reciprocal condition number: Estimated normwise */
/* reciprocal condition number. Compared with the threshold */
/* sqrt(n) * dlamch('Epsilon') to determine if the error */
/* estimate is "guaranteed". These reciprocal condition */
/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
/* appropriately scaled matrix Z. */
/* Let Z = S*A, where S scales each row by a power of the */
/* radix so all absolute row sums of Z are approximately 1. */
/* See Lapack Working Note 165 for further details and extra */
/* cautions. */
/* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
/* For each right-hand side, this array contains information about */
/* various error bounds and condition numbers corresponding to the */
/* componentwise relative error, which is defined as follows: */
/* Componentwise relative error in the ith solution vector: */
/* abs(XTRUE(j,i) - X(j,i)) */
/* max_j ---------------------- */
/* abs(X(j,i)) */
/* The array is indexed by the right-hand side i (on which the */
/* componentwise relative error depends), and the type of error */
/* information as described below. There currently are up to three */
/* pieces of information returned for each right-hand side. If */
/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
/* the first (:,N_ERR_BNDS) entries are returned. */
/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
/* right-hand side. */
/* The second index in ERR_BNDS_COMP(:,err) contains the following */
/* three fields: */
/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
/* reciprocal condition number is less than the threshold */
/* sqrt(n) * dlamch('Epsilon'). */
/* err = 2 "Guaranteed" error bound: The estimated forward error, */
/* almost certainly within a factor of 10 of the true error */
/* so long as the next entry is greater than the threshold */
/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
/* be trusted if the previous boolean is true. */
/* err = 3 Reciprocal condition number: Estimated componentwise */
/* reciprocal condition number. Compared with the threshold */
/* sqrt(n) * dlamch('Epsilon') to determine if the error */
/* estimate is "guaranteed". These reciprocal condition */
/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
/* appropriately scaled matrix Z. */
/* Let Z = S*(A*diag(x)), where x is the solution for the */
/* current right-hand side and S scales each row of */
/* A*diag(x) by a power of the radix so all absolute row */
/* sums of Z are approximately 1. */
/* See Lapack Working Note 165 for further details and extra */
/* cautions. */
/* NPARAMS (input) INTEGER */
/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
/* PARAMS array is never referenced and default values are used. */
/* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS */
/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
/* that entry will be filled with default value used for that */
/* parameter. Only positions up to NPARAMS are accessed; defaults */
/* are used for higher-numbered parameters. */
/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
/* refinement or not. */
/* Default: 1.0D+0 */
/* = 0.0 : No refinement is performed, and no error bounds are */
/* computed. */
/* = 1.0 : Use the extra-precise refinement algorithm. */
/* (other values are reserved for future use) */
/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
/* computations allowed for refinement. */
/* Default: 10 */
/* Aggressive: Set to 100 to permit convergence using approximate */
/* factorizations or factorizations other than LU. If */
/* the factorization uses a technique other than */
/* Gaussian elimination, the guarantees in */
/* err_bnds_norm and err_bnds_comp may no longer be */
/* trustworthy. */
/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
/* will attempt to find a solution with small componentwise */
/* relative error in the double-precision algorithm. Positive */
/* is true, 0.0 is false. */
/* Default: 1.0 (attempt componentwise convergence) */
/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */
/* IWORK (workspace) INTEGER array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: Successful exit. The solution to every right-hand side is */
/* guaranteed. */
/* < 0: If INFO = -i, the i-th argument had an illegal value */
/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
/* has been completed, but the factor U is exactly singular, so */
/* the solution and error bounds could not be computed. RCOND = 0 */
/* is returned. */
/* = N+J: The solution corresponding to the Jth right-hand side is */
/* not guaranteed. The solutions corresponding to other right- */
/* hand sides K with K > J may not be guaranteed as well, but */
/* only the first such right-hand side is reported. If a small */
/* componentwise error is not requested (PARAMS(3) = 0.0) then */
/* the Jth right-hand side is the first with a normwise error */
/* bound that is not guaranteed (the smallest J such */
/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
/* the Jth right-hand side is the first with either a normwise or */
/* componentwise error bound that is not guaranteed (the smallest */
/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
/* about all of the right-hand sides check ERR_BNDS_NORM or */
/* ERR_BNDS_COMP. */
/* ================================================================== */
/* Parameter adjustments */
err_bnds_comp_dim1 = *nrhs;
err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
err_bnds_comp__ -= err_bnds_comp_offset;
err_bnds_norm_dim1 = *nrhs;
err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
err_bnds_norm__ -= err_bnds_norm_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--ipiv;
--r__;
--c__;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--berr;
--params;
--work;
--iwork;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
notran = lsame_(trans, "N");
smlnum = dlamch_("Safe minimum");
bignum = 1. / smlnum;
if (nofact || equil) {
*(unsigned char *)equed = 'N';
rowequ = FALSE_;
colequ = FALSE_;
} else {
rowequ = lsame_(equed, "R") || lsame_(equed,
"B");
colequ = lsame_(equed, "C") || lsame_(equed,
"B");
}
/* Default is failure. If an input parameter is wrong or */
/* factorization fails, make everything look horrible. Only the */
/* pivot growth is set here, the rest is initialized in DGERFSX. */
*rpvgrw = 0.;
/* Test the input parameters. PARAMS is not tested until DGERFSX. */
if (! nofact && ! equil && ! lsame_(fact, "F")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && !
lsame_(trans, "C")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldaf < max(1,*n)) {
*info = -8;
} else if (lsame_(fact, "F") && ! (rowequ || colequ
|| lsame_(equed, "N"))) {
*info = -10;
} else {
if (rowequ) {
rcmin = bignum;
rcmax = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
d__1 = rcmin, d__2 = r__[j];
rcmin = min(d__1,d__2);
/* Computing MAX */
d__1 = rcmax, d__2 = r__[j];
rcmax = max(d__1,d__2);
}
if (rcmin <= 0.) {
*info = -11;
} else if (*n > 0) {
rowcnd = max(rcmin,smlnum) / min(rcmax,bignum);
} else {
rowcnd = 1.;
}
}
if (colequ && *info == 0) {
rcmin = bignum;
rcmax = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
d__1 = rcmin, d__2 = c__[j];
rcmin = min(d__1,d__2);
/* Computing MAX */
d__1 = rcmax, d__2 = c__[j];
rcmax = max(d__1,d__2);
}
if (rcmin <= 0.) {
*info = -12;
} else if (*n > 0) {
colcnd = max(rcmin,smlnum) / min(rcmax,bignum);
} else {
colcnd = 1.;
}
}
if (*info == 0) {
if (*ldb < max(1,*n)) {
*info = -14;
} else if (*ldx < max(1,*n)) {
*info = -16;
}
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGESVXX", &i__1);
return 0;
}
if (equil) {
/* Compute row and column scalings to equilibrate the matrix A. */
dgeequb_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, &colcnd,
&amax, &infequ);
if (infequ == 0) {
/* Equilibrate the matrix. */
dlaqge_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, &
colcnd, &amax, equed);
rowequ = lsame_(equed, "R") || lsame_(equed,
"B");
colequ = lsame_(equed, "C") || lsame_(equed,
"B");
}
/* If the scaling factors are not applied, set them to 1.0. */
if (! rowequ) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
r__[j] = 1.;
}
}
if (! colequ) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
c__[j] = 1.;
}
}
}
/* Scale the right-hand side. */
if (notran) {
if (rowequ) {
dlascl2_(n, nrhs, &r__[1], &b[b_offset], ldb);
}
} else {
if (colequ) {
dlascl2_(n, nrhs, &c__[1], &b[b_offset], ldb);
}
}
if (nofact || equil) {
/* Compute the LU factorization of A. */
dlacpy_("Full", n, n, &a[a_offset], lda, &af[af_offset], ldaf);
dgetrf_(n, n, &af[af_offset], ldaf, &ipiv[1], info);
/* Return if INFO is non-zero. */
if (*info > 0) {
/* Pivot in column INFO is exactly 0 */
/* Compute the reciprocal pivot growth factor of the */
/* leading rank-deficient INFO columns of A. */
*rpvgrw = dla_rpvgrw__(n, info, &a[a_offset], lda, &af[af_offset],
ldaf);
return 0;
}
}
/* Compute the reciprocal pivot growth factor RPVGRW. */
*rpvgrw = dla_rpvgrw__(n, n, &a[a_offset], lda, &af[af_offset], ldaf);
/* Compute the solution matrix X. */
dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
dgetrs_(trans, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx,
info);
/* Use iterative refinement to improve the computed solution and */
/* compute error bounds and backward error estimates for it. */
dgerfsx_(trans, equed, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &
ipiv[1], &r__[1], &c__[1], &b[b_offset], ldb, &x[x_offset], ldx,
rcond, &berr[1], n_err_bnds__, &err_bnds_norm__[
err_bnds_norm_offset], &err_bnds_comp__[err_bnds_comp_offset],
nparams, ¶ms[1], &work[1], &iwork[1], info);
/* Scale solutions. */
if (colequ && notran) {
dlascl2_(n, nrhs, &c__[1], &x[x_offset], ldx);
} else if (rowequ && ! notran) {
dlascl2_(n, nrhs, &r__[1], &x[x_offset], ldx);
}
return 0;
/* End of DGESVXX */
} /* dgesvxx_ */
void u8rdivma ( uint8 * in1, int lines1, int columns1,
uint8 * in2, int lines2, int columns2,
uint8 * out){
char cNorm = 0;
int iExit = 0;
/*temporary variables*/
int iWork = 0;
int iInfo = 0;
int iMax = 0;
uint8 dblRcond = 0;
uint8 dblEps = 0;
uint8 dblAnorm = 0;
uint8 *pAf = NULL;
uint8 *pAt = NULL;
uint8 *pBt = NULL;
uint8 *pDwork = NULL;
int *pRank = NULL;
int *pIpiv = NULL;
int *pJpvt = NULL;
int *pIwork = NULL;
iWork = max(4 * columns2, max(min(lines2, columns2) + 3 * lines2 + 1, 2 * min(lines2, columns2) + lines1));
/* Array allocations*/
pAf = (uint8*)malloc(sizeof(uint8) * (unsigned int)columns2 * (unsigned int)lines2);
pAt = (uint8*)malloc(sizeof(uint8) * (unsigned int)columns2 *(unsigned int) lines2);
pBt = (uint8*)malloc(sizeof(uint8) * (unsigned int)max(lines2,columns2) * (unsigned int)lines1);
pRank = (int*)malloc(sizeof(int));
pIpiv = (int*)malloc(sizeof(int) * (unsigned int)columns2);
pJpvt = (int*)malloc(sizeof(int) * (unsigned int)lines2);
pIwork = (int*)malloc(sizeof(int) * (unsigned int)columns2);
cNorm = '1';
pDwork = (uint8*)malloc(sizeof(uint8) * (unsigned int)iWork);
dblEps = getRelativeMachinePrecision() ;
dblAnorm = dlange_(&cNorm, &lines2, &columns1, in2, &lines2, pDwork);
/*tranpose A and B*/
dtransposea(in2, lines2, columns2, pAt);
dtransposea(in1, lines1, columns2, pBt);
if(lines2 == columns2)
{
cNorm = 'F';
dlacpy_(&cNorm, &columns2, &columns2, pAt, &columns2, pAf, &columns2);
dgetrf_(&columns2, &columns2, pAf, &columns2, pIpiv, &iInfo);
if(iInfo == 0)
{
cNorm = '1';
dgecon_(&cNorm, &columns2, pAf, &columns2, &dblAnorm, &dblRcond, pDwork, pIwork, &iInfo);
if(dblRcond > sqrt(dblEps))
{
cNorm = 'N';
dgetrs_(&cNorm, &columns2, &lines1, pAf, &columns2, pIpiv, pBt, &columns2, &iInfo);
dtransposea(pBt, columns2, lines1, out);
iExit = 1;
}
}
}
if(iExit == 0)
{
dblRcond = sqrt(dblEps);
cNorm = 'F';
iMax = max(lines2, columns2);
memset(pJpvt, 0x00, (unsigned int)sizeof(int) * (unsigned int)lines2);
dgelsy_(&columns2, &lines2, &lines1, pAt, &columns2, pBt, &iMax,
pJpvt, &dblRcond, &pRank[0], pDwork, &iWork, &iInfo);
if(iInfo == 0)
{
/* TransposeRealMatrix(pBt, lines1, lines2, out, Max(lines1,columns1), lines2);*/
/*Mega caca de la mort qui tue des ours a mains nues
mais je ne sais pas comment le rendre "beau" :(*/
{
int i,j,ij,ji;
for(j = 0 ; j < lines2 ; j++)
{
for(i = 0 ; i < lines1 ; i++)
{
ij = i + j * lines1;
ji = j + i * max(lines2, columns2);
out[ij] = pBt[ji];
}
}
}
}
}
free(pAf);
free(pAt);
free(pBt);
free(pRank);
free(pIpiv);
free(pJpvt);
free(pIwork);
free(pDwork);
}
int
stf::linsolv( int m, int n, int nrhs, Vector_double& A,
Vector_double& B)
{
#ifndef TEST_MINIMAL
if (A.size()<=0) {
throw std::runtime_error("Matrix A has size 0 in stf::linsolv");
}
if (B.size()<=0) {
throw std::runtime_error("Matrix B has size 0 in stf::linsolv");
}
if (A.size()!= std::size_t(m*n)) {
throw std::runtime_error("Size of matrix A is not m*n");
}
/* Arguments to dgetrf_
* ====================
*
* M (input) INTEGER
* The number of rows of the matrix A. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the M-by-N matrix to be factored.
* On exit, the factors L and U from the factorization
* A = P*L*U; the unit diagonal elements of L are not stored.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* IPIV (output) INTEGER array, dimension (min(M,N))
* The pivot indices; for 1 <= i <= min(M,N), row i of the
* matrix was interchanged with row IPIV(i).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
* has been completed, but the factor U is exactly
* singular, and division by zero will occur if it is used
* to solve a system of equations.
*/
int lda_f = m;
std::size_t ipiv_size = (m < n) ? m : n;
std::vector<int> ipiv(ipiv_size);
int info=0;
dgetrf_(&m, &n, &A[0], &lda_f, &ipiv[0], &info);
if (info<0) {
std::ostringstream error_msg;
error_msg << "Argument " << -info << " had an illegal value in LAPACK's dgetrf_";
throw std::runtime_error( std::string(error_msg.str()));
}
if (info>0) {
throw std::runtime_error("Singular matrix in LAPACK's dgetrf_; would result in division by zero");
}
/* Arguments to dgetrs_
* ====================
*
* TRANS (input) CHARACTER*1
* Specifies the form of the system of equations:
* = 'N': A * X = B (No transpose)
* = 'T': A'* X = B (Transpose)
* = 'C': A'* X = B (Conjugate transpose = Transpose)
*
* N (input) INTEGER
* The order of the matrix A. N >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrix B. NRHS >= 0.
*
* A (input) DOUBLE PRECISION array, dimension (LDA,N)
* The factors L and U from the factorization A = P*L*U
* as computed by DGETRF.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* IPIV (input) INTEGER array, dimension (N)
* The pivot indices from DGETRF; for 1<=i<=N, row i of the
* matrix was interchanged with row IPIV(i).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the right hand side matrix B.
* On exit, the solution matrix X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*/
char trans='N';
dgetrs_(&trans, &m, &nrhs, &A[0], &m, &ipiv[0], &B[0], &m, &info);
if (info<0) {
std::ostringstream error_msg;
error_msg << "Argument " << -info << " had an illegal value in LAPACK's dgetrs_";
throw std::runtime_error(error_msg.str());
}
#endif
return 0;
}
int dgerfs_(char *trans, int *n, int *nrhs,
double *a, int *lda, double *af, int *ldaf, int *
ipiv, double *b, int *ldb, double *x, int *ldx,
double *ferr, double *berr, double *work, int *iwork,
int *info)
{
/* System generated locals */
int a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
x_offset, i__1, i__2, i__3;
double d__1, d__2, d__3;
/* Local variables */
int i__, j, k;
double s, xk;
int nz;
double eps;
int kase;
double safe1, safe2;
extern int lsame_(char *, char *);
extern int dgemv_(char *, int *, int *,
double *, double *, int *, double *, int *,
double *, double *, int *);
int isave[3];
extern int dcopy_(int *, double *, int *,
double *, int *), daxpy_(int *, double *,
double *, int *, double *, int *);
int count;
extern int dlacn2_(int *, double *, double *,
int *, double *, int *, int *);
extern double dlamch_(char *);
double safmin;
extern int xerbla_(char *, int *), dgetrs_(
char *, int *, int *, double *, int *, int *,
double *, int *, int *);
int notran;
char transt[1];
double lstres;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGERFS improves the computed solution to a system of linear */
/* equations and provides error bounds and backward error estimates for */
/* the solution. */
/* Arguments */
/* ========= */
/* TRANS (input) CHARACTER*1 */
/* Specifies the form of the system of equations: */
/* = 'N': A * X = B (No transpose) */
/* = 'T': A**T * X = B (Transpose) */
/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The original N-by-N matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */
/* The factors L and U from the factorization A = P*L*U */
/* as computed by DGETRF. */
/* LDAF (input) INTEGER */
/* The leading dimension of the array AF. LDAF >= MAX(1,N). */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices from DGETRF; for 1<=i<=N, row i of the */
/* matrix was interchanged with row IPIV(i). */
/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* The right hand side matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= MAX(1,N). */
/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* On entry, the solution matrix X, as computed by DGETRS. */
/* On exit, the improved solution matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= MAX(1,N). */
/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
/* The estimated forward error bound for each solution vector */
/* X(j) (the j-th column of the solution matrix X). */
/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
/* is an estimated upper bound for the magnitude of the largest */
/* element in (X(j) - XTRUE) divided by the magnitude of the */
/* largest element in X(j). The estimate is as reliable as */
/* the estimate for RCOND, and is almost always a slight */
/* overestimate of the true error. */
/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector X(j) (i.e., the smallest relative change in */
/* any element of A or B that makes X(j) an exact solution). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
/* IWORK (workspace) INTEGER array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Internal Parameters */
/* =================== */
/* ITMAX is the maximum number of steps of iterative refinement. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--iwork;
/* Function Body */
*info = 0;
notran = lsame_(trans, "N");
if (! notran && ! lsame_(trans, "T") && ! lsame_(
trans, "C")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < MAX(1,*n)) {
*info = -5;
} else if (*ldaf < MAX(1,*n)) {
*info = -7;
} else if (*ldb < MAX(1,*n)) {
*info = -10;
} else if (*ldx < MAX(1,*n)) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGERFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] = 0.;
berr[j] = 0.;
/* L10: */
}
return 0;
}
if (notran) {
*(unsigned char *)transt = 'T';
} else {
*(unsigned char *)transt = 'N';
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
eps = dlamch_("Epsilon");
safmin = dlamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
count = 1;
lstres = 3.;
L20:
/* Loop until stopping criterion is satisfied. */
/* Compute residual R = B - op(A) * X, */
/* where op(A) = A, A**T, or A**H, depending on TRANS. */
dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
dgemv_(trans, n, n, &c_b15, &a[a_offset], lda, &x[j * x_dim1 + 1], &
c__1, &c_b17, &work[*n + 1], &c__1);
/* Compute componentwise relative backward error from formula */
/* MAX(i) ( ABS(R(i)) / ( ABS(op(A))*ABS(X) + ABS(B) )(i) ) */
/* where ABS(Z) is the componentwise absolute value of the matrix */
/* or vector Z. If the i-th component of the denominator is less */
/* than SAFE2, then SAFE1 is added to the i-th components of the */
/* numerator and denominator before dividing. */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] = (d__1 = b[i__ + j * b_dim1], ABS(d__1));
/* L30: */
}
/* Compute ABS(op(A))*ABS(X) + ABS(B). */
if (notran) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
xk = (d__1 = x[k + j * x_dim1], ABS(d__1));
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
work[i__] += (d__1 = a[i__ + k * a_dim1], ABS(d__1)) * xk;
/* L40: */
}
/* L50: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
s += (d__1 = a[i__ + k * a_dim1], ABS(d__1)) * (d__2 = x[
i__ + j * x_dim1], ABS(d__2));
/* L60: */
}
work[k] += s;
/* L70: */
}
}
s = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[i__] > safe2) {
/* Computing MAX */
d__2 = s, d__3 = (d__1 = work[*n + i__], ABS(d__1)) / work[
i__];
s = MAX(d__2,d__3);
} else {
/* Computing MAX */
d__2 = s, d__3 = ((d__1 = work[*n + i__], ABS(d__1)) + safe1)
/ (work[i__] + safe1);
s = MAX(d__2,d__3);
}
/* L80: */
}
berr[j] = s;
/* Test stopping criterion. Continue iterating if */
/* 1) The residual BERR(J) is larger than machine epsilon, and */
/* 2) BERR(J) decreased by at least a factor of 2 during the */
/* last iteration, and */
/* 3) At most ITMAX iterations tried. */
if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
/* Update solution and try again. */
dgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[*n
+ 1], n, info);
daxpy_(n, &c_b17, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1)
;
lstres = berr[j];
++count;
goto L20;
}
/* Bound error from formula */
/* norm(X - XTRUE) / norm(X) .le. FERR = */
/* norm( ABS(inv(op(A)))* */
/* ( ABS(R) + NZ*EPS*( ABS(op(A))*ABS(X)+ABS(B) ))) / norm(X) */
/* where */
/* norm(Z) is the magnitude of the largest component of Z */
/* inv(op(A)) is the inverse of op(A) */
/* ABS(Z) is the componentwise absolute value of the matrix or */
/* vector Z */
/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
/* EPS is machine epsilon */
/* The i-th component of ABS(R)+NZ*EPS*(ABS(op(A))*ABS(X)+ABS(B)) */
/* is incremented by SAFE1 if the i-th component of */
/* ABS(op(A))*ABS(X) + ABS(B) is less than SAFE2. */
/* Use DLACN2 to estimate the infinity-norm of the matrix */
/* inv(op(A)) * diag(W), */
/* where W = ABS(R) + NZ*EPS*( ABS(op(A))*ABS(X)+ABS(B) ))) */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[i__] > safe2) {
work[i__] = (d__1 = work[*n + i__], ABS(d__1)) + nz * eps *
work[i__];
} else {
work[i__] = (d__1 = work[*n + i__], ABS(d__1)) + nz * eps *
work[i__] + safe1;
}
/* L90: */
}
kase = 0;
L100:
dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
kase, isave);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)**T). */
dgetrs_(transt, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &
work[*n + 1], n, info);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = work[i__] * work[*n + i__];
/* L110: */
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = work[i__] * work[*n + i__];
/* L120: */
}
dgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &
work[*n + 1], n, info);
}
goto L100;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], ABS(d__1));
lstres = MAX(d__2,d__3);
/* L130: */
}
if (lstres != 0.) {
ferr[j] /= lstres;
}
/* L140: */
}
return 0;
/* End of DGERFS */
} /* dgerfs_ */
int new_ABG(gradient_structure grad , double delta_E , double delta_F , double delta_G , double& alpha , double& beta , double& gamma , bool conserve_flux , int npol, bool force_chi2_method)
{
double l , arg;
double alpha1 , beta1 , gamma1;
double alpha2 , beta2 , gamma2;
double dalpha , dbeta , dgamma;
double quad_tol = 0.01; // tolerance for checking if the changes in alpha etc. are "small enough". This is the MEM's equivalent of Gain. Keep very small.
double chi2_mode_tol = 0.05; // MEM gain tolerance. If lower than this MEM is progressing slowly.
int err;
int n; // parameters for LAPACK functions dgetrf (factorise into LU) and dgetrs (solve A x = b when A is LU factorised)
char trans='T'; // indicate that the transpose should be used in LAPACK functions (row major to column major)
int nrhs = 1;
beta2 = 0.0;
gamma2 = 0.0;
l = fabs( grad.JJ / grad.II ); // a measure of how quickly the cost function is changing scaled with how quickly the I map is changing
if(alpha <= 0)
{
l=0.0;
}
if(npol ==1 )
{
if(conserve_flux)
{
n=2;
double A[4] = { grad.EE , grad.EG , grad.EG , grad.GG};
double b[2] = { grad.EH , grad.GH};
int ipiv[2];
dgetrf_(&n , &n , A , &n , ipiv, &err );
if(err != 0)
{
cout<<"Error : new_ABG : dgetrf_ : Error performing LU factorisation."<<endl;
return(1);
}
dgetrs_( &trans , &n , &nrhs , A , &n , ipiv , b , &n , &err );
if(err != 0)
{
cout<<"Error : new_ABG : dgetrs_ : Error solving linear equation."<<endl;
return(1);
}
alpha1 = b[0];
beta1 = 0.0;
gamma1 = b[1];
b[0] = delta_E + grad.EJ; // reset b
b[1] = delta_G + grad.GJ;
dgetrs_( &trans , &n , &nrhs , A , &n , ipiv , b , &n , &err );
if(err != 0)
{
cout<<"Error : new_ABG : dgetrs_ : Error solving linear equation."<<endl;
return(1);
}
dalpha = b[0];
dbeta = 0.0;
dgamma = b[1];
}
else
{
// no beta or gamma
// need only to solve gradE.gradJ = 0, i.e. gradE.(gradH - alpha * grad E)=0, or alpha = grad HE / grad EE
alpha1 = grad.EH / grad.EE;
beta1 = 0.0;
gamma1 = 0.0;
// need to solve grad EE * dalpha = delta E + grad EJ
dalpha = ( delta_E + grad.EJ ) / grad.EE;
dbeta = 0.0;
dgamma = 0.0;
}
}
else
{
if(conserve_flux)
{
// If conserving flux solve 3x3 matrix to find changes in alpha, beta, gamma
n=3;
double A[9] = { grad.EE , grad.EF , grad.EG , grad.EF , grad.FF , grad.FG , grad.EG , grad.FG , grad.GG };
double b[3] = { grad.EH , grad.FH , grad. GH};
int ipiv[3];
dgetrf_(&n , &n , A , &n , ipiv, &err );
if(err != 0)
{
cout<<"Error : new_ABG : dgetrf_ : Error performing LU factorisation."<<endl;
return(1);
}
dgetrs_( &trans , &n , &nrhs , &A[0] , &n , ipiv , &b[0] , &n , &err );
if(err != 0)
{
cout<<"Error : new_ABG : dgetrs_ : Error solving linear equation."<<endl;
return(1);
}
alpha1 = b[0];
beta1 = b[1];
gamma1 = b[2];
b[0] = (delta_E + grad.EJ); // reset b
b[1] = (delta_F + grad.FJ);
b[2] = (delta_G + grad.GJ);
dgetrs_( &trans , &n , &nrhs , A , &n , ipiv , b , &n , &err );
if(err != 0)
{
cout<<"Error : new_ABG : dgetrs_ : Error solving linear equation."<<endl;
return(1);
}
dalpha = b[0];
dbeta = b[1];
dgamma = b[2];
}
else
{
n=2;
double A[4] = { grad.EE , grad.EF , grad.EF , grad.FF };
double b[2] = { grad.EH , grad.FH};
int ipiv[2];
dgetrf_(&n , &n , A , &n , ipiv, &err );
if(err != 0)
{
cout<<"Error : new_ABG : dgetrf_ : Error performing LU factorisation."<<endl;
return(1);
}
dgetrs_( &trans , &n , &nrhs , A , &n , ipiv , b , &n , &err );
if(err != 0)
{
cout<<"Error : new_ABG : dgetrs_ : Error solving linear equation."<<endl;
return(1);
}
alpha1 = b[0];
beta1 = b[1];
gamma1 = 0.0;
b[0] = delta_E + grad.EJ; // reset b
b[1] = delta_F + grad.FJ;
dgetrs_( &trans , &n , &nrhs , A , &n , ipiv , b , &n , &err );
if(err != 0)
{
cout<<"Error : new_ABG : dgetrs_ : Error solving linear equation."<<endl;
return(1);
}
dalpha = b[0];
dbeta = b[1];
dgamma = 0.0;
}
}
// check if change in alpha is "small enough"
arg = grad.EJ * grad.EJ - (grad.JJ - quad_tol * grad.II) * grad.EE;
if( arg > 0 )
{
arg = sqrt(arg);
dalpha = max( (grad.EJ - arg) / grad.EE , min( (grad.EJ + arg) / grad.EE , dalpha ) );
}
else
{
if(alpha != 0)
{
dalpha = 0.0;
}
else
{
dalpha = 1.0;
cout<<"Alpha = 0 detected. Accepting unconstrained new value of alpha = "<<dalpha<<endl;
}
}
alpha2 = alpha + dalpha;
// check if change in beta is "small enough"
if(npol>1)
{
arg = grad.FJ * grad.FJ - (grad.JJ - quad_tol * grad.II) * grad.FF;
if( arg > 0 )
{
arg = sqrt(arg);
dbeta = max( (grad.FJ - arg) / grad.FF , min( (grad.FJ + arg) / grad.FF , dbeta ) );
}
else
{
dbeta = 0.0;
}
beta2 = beta + dbeta;
}
// check if change in gamma is "small enough"
if(conserve_flux)
{
arg = grad.GJ * grad.GJ - (grad.JJ - quad_tol * grad.II) * grad.GG;
if( arg > 0 )
{
arg = sqrt(arg);
dgamma = max( (grad.GJ - arg) / grad.GG , min( (grad.GJ + arg) / grad.GG , dgamma ) );
}
else
{
dgamma = 0.0;
}
gamma2 = gamma + dgamma;
}
// decide on alpha
/*
cout<<"l = "<<l<<", chi2_mode_tol = "<<chi2_mode_tol<<endl;
cout<<"alpha1 = "<<alpha1<<", alpha2 = "<<alpha2<<endl;
cout<<"beta1 = "<<beta1<<", beta2 = "<<beta2<<endl;
cout<<"gamma1 = "<<gamma1<<", gamma2 = "<<gamma2<<endl;
*/
if( (l < chi2_mode_tol or alpha1 <=0.0) or force_chi2_method )
{
alpha=max(alpha2,0.0);
}
else
{
alpha=max(alpha1,0.0); // watch out if falling back to alpha2 when alpha 1 is zero. Alpha 2 can be very large and throw things out.
}
// decide on beta
if(npol>1)
{
if( (l < chi2_mode_tol or beta1 <=0.0) or force_chi2_method)
{
beta=max(beta2,0.0);
}
else
{
beta=max(beta1,0.0);
}
}
// decide on gamma
if(conserve_flux)
{
if( (l < chi2_mode_tol or gamma1 <=0.0) or force_chi2_method )
{
gamma=max(gamma2,0.0);
}
else
{
gamma=max(gamma1,0.0);
}
}
return(0);
}
/* Subroutine */ int dchkge_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
nns, integer *nsval, doublereal *thresh, logical *tsterr, integer *
nmax, doublereal *a, doublereal *afac, doublereal *ainv, doublereal *
b, doublereal *x, doublereal *xact, doublereal *work, doublereal *
rwork, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char transs[1*3] = "N" "T" "C";
/* Format strings */
static char fmt_9999[] = "(\002 M = \002,i5,\002, N =\002,i5,\002, NB "
"=\002,i4,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
;
static char fmt_9998[] = "(\002 TRANS='\002,a1,\002', N =\002,i5,\002, N"
"RHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g1"
"2.5)";
static char fmt_9997[] = "(\002 NORM ='\002,a1,\002', N =\002,i5,\002"
",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
;
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, k, m, n, nb, im, in, kl, ku, nt, lda, inb, ioff, mode, imat,
info;
char path[3], dist[1];
integer irhs, nrhs;
char norm[1], type__[1];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *), dget01_(
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, integer *, doublereal *, doublereal *), dget02_(char *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *), dget03_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *), dget04_(integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *);
integer nfail, iseed[4];
extern doublereal dget06_(doublereal *, doublereal *);
extern /* Subroutine */ int dget07_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, logical *,
doublereal *, doublereal *);
doublereal rcond;
integer nimat;
doublereal anorm;
integer itran;
char trans[1];
integer izero, nerrs;
doublereal dummy;
integer lwork;
logical zerot;
char xtype[1];
extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *);
extern doublereal dlange_(char *, integer *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *), dgecon_(char *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *, integer *);
doublereal rcondc;
extern /* Subroutine */ int derrge_(char *, integer *), dgerfs_(
char *, integer *, integer *, doublereal *, integer *, doublereal
*, integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
integer *), dgetrf_(integer *, integer *, doublereal *,
integer *, integer *, integer *), dlacpy_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *), dlarhs_(char *, char *, char *, char *, integer *,
integer *, integer *, integer *, integer *, doublereal *, integer
*, doublereal *, integer *, doublereal *, integer *, integer *,
integer *);
doublereal rcondi;
extern /* Subroutine */ int dgetri_(integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *), dlaset_(char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *), alasum_(char *, integer *, integer *, integer
*, integer *);
doublereal cndnum, anormi, rcondo;
extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublereal *, integer *, doublereal
*, integer *);
doublereal ainvnm;
extern /* Subroutine */ int dgetrs_(char *, integer *, integer *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *);
logical trfcon;
doublereal anormo;
extern /* Subroutine */ int xlaenv_(integer *, integer *);
doublereal result[8];
/* Fortran I/O blocks */
static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* January 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DCHKGE tests DGETRF, -TRI, -TRS, -RFS, and -CON. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NM (input) INTEGER */
/* The number of values of M contained in the vector MVAL. */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix row dimension M. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension N. */
/* NNB (input) INTEGER */
/* The number of values of NB contained in the vector NBVAL. */
/* NBVAL (input) INTEGER array, dimension (NBVAL) */
/* The values of the blocksize NB. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for M or N, used in dimensioning */
/* the work arrays. */
/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension */
/* (max(2*NMAX,2*NSMAX+NWORK)) */
/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nsval;
--nbval;
--nval;
--mval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "GE", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
xlaenv_(&c__1, &c__1);
if (*tsterr) {
derrge_(path, nout);
}
infoc_1.infot = 0;
xlaenv_(&c__2, &c__2);
/* Do for each value of M in MVAL */
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
m = mval[im];
lda = max(1,m);
/* Do for each value of N in NVAL */
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
n = nval[in];
*(unsigned char *)xtype = 'N';
nimat = 11;
if (m <= 0 || n <= 0) {
nimat = 1;
}
i__3 = nimat;
for (imat = 1; imat <= i__3; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L100;
}
/* Skip types 5, 6, or 7 if the matrix size is too small. */
zerot = imat >= 5 && imat <= 7;
if (zerot && n < imat - 4) {
goto L100;
}
/* Set up parameters with DLATB4 and generate a test matrix */
/* with DLATMS. */
dlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
dlatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
work[1], &info);
/* Check error code from DLATMS. */
if (info != 0) {
alaerh_(path, "DLATMS", &info, &c__0, " ", &m, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L100;
}
/* For types 5-7, zero one or more columns of the matrix to */
/* test that INFO is returned correctly. */
if (zerot) {
if (imat == 5) {
izero = 1;
} else if (imat == 6) {
izero = min(m,n);
} else {
izero = min(m,n) / 2 + 1;
}
ioff = (izero - 1) * lda;
if (imat < 7) {
i__4 = m;
for (i__ = 1; i__ <= i__4; ++i__) {
a[ioff + i__] = 0.;
/* L20: */
}
} else {
i__4 = n - izero + 1;
dlaset_("Full", &m, &i__4, &c_b23, &c_b23, &a[ioff +
1], &lda);
}
} else {
izero = 0;
}
/* These lines, if used in place of the calls in the DO 60 */
/* loop, cause the code to bomb on a Sun SPARCstation. */
/* ANORMO = DLANGE( 'O', M, N, A, LDA, RWORK ) */
/* ANORMI = DLANGE( 'I', M, N, A, LDA, RWORK ) */
/* Do for each blocksize in NBVAL */
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* Compute the LU factorization of the matrix. */
dlacpy_("Full", &m, &n, &a[1], &lda, &afac[1], &lda);
s_copy(srnamc_1.srnamt, "DGETRF", (ftnlen)32, (ftnlen)6);
dgetrf_(&m, &n, &afac[1], &lda, &iwork[1], &info);
/* Check error code from DGETRF. */
if (info != izero) {
alaerh_(path, "DGETRF", &info, &izero, " ", &m, &n, &
c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
}
trfcon = FALSE_;
/* + TEST 1 */
/* Reconstruct matrix from factors and compute residual. */
dlacpy_("Full", &m, &n, &afac[1], &lda, &ainv[1], &lda);
dget01_(&m, &n, &a[1], &lda, &ainv[1], &lda, &iwork[1], &
rwork[1], result);
nt = 1;
/* + TEST 2 */
/* Form the inverse if the factorization was successful */
/* and compute the residual. */
if (m == n && info == 0) {
dlacpy_("Full", &n, &n, &afac[1], &lda, &ainv[1], &
lda);
s_copy(srnamc_1.srnamt, "DGETRI", (ftnlen)32, (ftnlen)
6);
nrhs = nsval[1];
lwork = *nmax * max(3,nrhs);
dgetri_(&n, &ainv[1], &lda, &iwork[1], &work[1], &
lwork, &info);
/* Check error code from DGETRI. */
if (info != 0) {
alaerh_(path, "DGETRI", &info, &c__0, " ", &n, &n,
&c_n1, &c_n1, &nb, &imat, &nfail, &nerrs,
nout);
}
/* Compute the residual for the matrix times its */
/* inverse. Also compute the 1-norm condition number */
/* of A. */
dget03_(&n, &a[1], &lda, &ainv[1], &lda, &work[1], &
lda, &rwork[1], &rcondo, &result[1]);
anormo = dlange_("O", &m, &n, &a[1], &lda, &rwork[1]);
/* Compute the infinity-norm condition number of A. */
anormi = dlange_("I", &m, &n, &a[1], &lda, &rwork[1]);
ainvnm = dlange_("I", &n, &n, &ainv[1], &lda, &rwork[
1]);
if (anormi <= 0. || ainvnm <= 0.) {
rcondi = 1.;
} else {
rcondi = 1. / anormi / ainvnm;
}
nt = 2;
} else {
/* Do only the condition estimate if INFO > 0. */
trfcon = TRUE_;
anormo = dlange_("O", &m, &n, &a[1], &lda, &rwork[1]);
anormi = dlange_("I", &m, &n, &a[1], &lda, &rwork[1]);
rcondo = 0.;
rcondi = 0.;
}
/* Print information about the tests so far that did not */
/* pass the threshold. */
i__5 = nt;
for (k = 1; k <= i__5; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L30: */
}
nrun += nt;
/* Skip the remaining tests if this is not the first */
/* block size or if M .ne. N. Skip the solve tests if */
/* the matrix is singular. */
if (inb > 1 || m != n) {
goto L90;
}
if (trfcon) {
goto L70;
}
i__5 = *nns;
for (irhs = 1; irhs <= i__5; ++irhs) {
nrhs = nsval[irhs];
*(unsigned char *)xtype = 'N';
for (itran = 1; itran <= 3; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&
transs[itran - 1];
if (itran == 1) {
rcondc = rcondo;
} else {
rcondc = rcondi;
}
/* + TEST 3 */
/* Solve and compute residual for A * X = B. */
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (
ftnlen)6);
dlarhs_(path, xtype, " ", trans, &n, &n, &kl, &ku,
&nrhs, &a[1], &lda, &xact[1], &lda, &b[1]
, &lda, iseed, &info);
*(unsigned char *)xtype = 'C';
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "DGETRS", (ftnlen)32, (
ftnlen)6);
dgetrs_(trans, &n, &nrhs, &afac[1], &lda, &iwork[
1], &x[1], &lda, &info);
/* Check error code from DGETRS. */
if (info != 0) {
alaerh_(path, "DGETRS", &info, &c__0, trans, &
n, &n, &c_n1, &c_n1, &nrhs, &imat, &
nfail, &nerrs, nout);
}
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1],
&lda);
dget02_(trans, &n, &n, &nrhs, &a[1], &lda, &x[1],
&lda, &work[1], &lda, &rwork[1], &result[
2]);
/* + TEST 4 */
/* Check solution from generated exact solution. */
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[3]);
/* + TESTS 5, 6, and 7 */
/* Use iterative refinement to improve the */
/* solution. */
s_copy(srnamc_1.srnamt, "DGERFS", (ftnlen)32, (
ftnlen)6);
dgerfs_(trans, &n, &nrhs, &a[1], &lda, &afac[1], &
lda, &iwork[1], &b[1], &lda, &x[1], &lda,
&rwork[1], &rwork[nrhs + 1], &work[1], &
iwork[n + 1], &info);
/* Check error code from DGERFS. */
if (info != 0) {
alaerh_(path, "DGERFS", &info, &c__0, trans, &
n, &n, &c_n1, &c_n1, &nrhs, &imat, &
nfail, &nerrs, nout);
}
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[4]);
dget07_(trans, &n, &nrhs, &a[1], &lda, &b[1], &
lda, &x[1], &lda, &xact[1], &lda, &rwork[
1], &c_true, &rwork[nrhs + 1], &result[5]);
/* Print information about the tests that did not */
/* pass the threshold. */
for (k = 3; k <= 7; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L40: */
}
nrun += 5;
/* L50: */
}
/* L60: */
}
/* + TEST 8 */
/* Get an estimate of RCOND = 1/CNDNUM. */
L70:
for (itran = 1; itran <= 2; ++itran) {
if (itran == 1) {
anorm = anormo;
rcondc = rcondo;
*(unsigned char *)norm = 'O';
} else {
anorm = anormi;
rcondc = rcondi;
*(unsigned char *)norm = 'I';
}
s_copy(srnamc_1.srnamt, "DGECON", (ftnlen)32, (ftnlen)
6);
dgecon_(norm, &n, &afac[1], &lda, &anorm, &rcond, &
work[1], &iwork[n + 1], &info);
/* Check error code from DGECON. */
if (info != 0) {
alaerh_(path, "DGECON", &info, &c__0, norm, &n, &
n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
nerrs, nout);
}
/* This line is needed on a Sun SPARCstation. */
dummy = rcond;
result[7] = dget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass */
/* the threshold. */
if (result[7] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___50.ciunit = *nout;
s_wsfe(&io___50);
do_fio(&c__1, norm, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
/* L80: */
}
L90:
;
}
L100:
;
}
/* L110: */
}
/* L120: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DCHKGE */
} /* dchkge_ */
/* Subroutine */ int dgesv_(integer *n, integer *nrhs, doublereal *a, integer
*lda, integer *ipiv, doublereal *b, integer *ldb, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1;
/* Local variables */
extern /* Subroutine */ int dgetrf_(integer *, integer *, doublereal *,
integer *, integer *, integer *), xerbla_(char *, integer *), dgetrs_(char *, integer *, integer *, doublereal *,
integer *, integer *, doublereal *, integer *, integer *);
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGESV computes the solution to a real system of linear equations */
/* A * X = B, */
/* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. */
/* The LU decomposition with partial pivoting and row interchanges is */
/* used to factor A as */
/* A = P * L * U, */
/* where P is a permutation matrix, L is unit lower triangular, and U is */
/* upper triangular. The factored form of A is then used to solve the */
/* system of equations A * X = B. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrix B. NRHS >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the N-by-N coefficient matrix A. */
/* On exit, the factors L and U from the factorization */
/* A = P*L*U; the unit diagonal elements of L are not stored. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* IPIV (output) INTEGER array, dimension (N) */
/* The pivot indices that define the permutation matrix P; */
/* row i of the matrix was interchanged with row IPIV(i). */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* On entry, the N-by-NRHS matrix of right hand side matrix B. */
/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
/* has been completed, but the factor U is exactly */
/* singular, so the solution could not be computed. */
/* ===================================================================== */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*nrhs < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGESV ", &i__1);
return 0;
}
/* Compute the LU factorization of A. */
dgetrf_(n, n, &a[a_offset], lda, &ipiv[1], info);
if (*info == 0) {
/* Solve the system A*X = B, overwriting B with X. */
dgetrs_("No transpose", n, nrhs, &a[a_offset], lda, &ipiv[1], &b[
b_offset], ldb, info);
}
return 0;
/* End of DGESV */
} /* dgesv_ */
void dgetrf_test ( )
/******************************************************************************/
/*
Purpose:
DGETRF_TEST demonstrates DGETRF and DGETRS.
Licensing:
This code is distributed under the GNU LGPL license.
Modified:
07 January 2014
Author:
John Burkardt
*/
{
double A[4*4] = {
1.0, 2.0, 1.0, 1.0,
-1.0, -2.0, 1.0, -1.0,
2.0, 3.0, 1.0, 4.0,
-1.0, -3.0, 0.0, 3.0 };
double B[4] = {
-8.0, -20.0, -2.0, 4.0 };
int i;
static long int INFO;
int info2;
static long int IPIV[4];
int j;
long int LDA;
long int LDB;
long int N = 4;
long int NRHS;
char TRANS;
printf ( "\n" );
printf ( "DGETRF_TEST\n" );
printf ( " Demonstrate the use of:\n" );
printf ( " DGETRF to factor a general matrix A,\n" );
printf ( " DGETRS to solve A*x=b after A has been factored,\n" );
printf ( " using double precision real arithmetic.\n" );
/*
Print the coefficient matrix.
*/
r8mat_print ( N, N, A, " Coefficient matrix A:" );
/*
Call DGETRF to factor the matrix.
*/
LDA = N;
dgetrf_ ( &N, &N, A, &LDA, IPIV, &INFO );
printf ( "\n" );
printf ( " Return value of DGETRF error flag INFO = %d\n", ( int ) INFO );
/*
Print the right hand side.
*/
r8vec_print ( N, B, " Right hand side B:\n" );
/*
Call DGETRS to solve the linear system A*x=b.
*/
TRANS = 'N';
NRHS = 1;
LDB = N;
dgetrs_ ( &TRANS, &N, &NRHS, A, &LDA, IPIV, B, &LDB, &INFO );
printf ( "\n" );
printf ( " Return value of DGETRS error flag INFO = %d\n", ( int ) INFO );
/*
Solution X is returned in B.
*/
r8vec_print ( N, B, " Computed solution X:\n" );
return;
}
