static void
icgs(double *u, double *unrm, int n, int m, double *A,
double *um) {
const int maxcgsit = 5;
const double alpha = 0.5;
double unrm_old;
int i, isorth = 0;
*unrm = F77(dnrm2)(&n, u, &ONE);
if (m == 0)
return;
for (i = 0; !isorth && i < maxcgsit; i ++) {
F77(dgemv)("t", &n, &m, &DONE, A, &n, u, &ONE, &DZER, um, &ONE, 1);
F77(dgemv)("n", &n, &m, &DMONE, A, &n, um, &ONE, &DONE, u, &ONE, 1);
unrm_old = (*unrm);
*unrm = F77(dnrm2)(&n, u, &ONE);
isorth=((*unrm) > alpha*unrm_old);
}
if (i >= maxcgsit) {
printf("warning: loss of orthogonality. ");
printf("icgs() not converged after %d steps.\n", maxcgsit);
}
}
static void
mgsm(double *u, int n, int m, double *Q, double *QM) {
int i;
double s;
for (i = 0; i < m; i ++) {
s = - F77(ddot)(&n, QM+i*n, &ONE, u, &ONE);
F77(daxpy)(&n, &s, Q+i*n, &ONE, u, &ONE);
}
}
static void
icgsm(double *u, double *unrm, int n, int m, double *Q,
PyObject *mmat,
double *um, double *temp) {
const int maxcgsit = 5;
const double alpha = 0.5;
double unrm_old;
int ret, i, isorth = 0;
ret = SpMatrix_Matvec(mmat, n, u, n, um);
assert(ret == 0);
*unrm = sqrt(F77(ddot)(&n, u, &ONE, um, &ONE));
if (m == 0)
return;
for (i = 0; !isorth && i < maxcgsit; i ++) {
F77(dgemv)("t", &n, &m, &DONE, Q, &n, um, &ONE, &DZER, temp, &ONE, 1);
F77(dgemv)("n", &n, &m, &DMONE, Q, &n, temp, &ONE, &DONE, u, &ONE, 1);
ret = SpMatrix_Matvec(mmat, n, u, n, um);
assert(ret == 0);
unrm_old = (*unrm);
*unrm = sqrt(F77(ddot)(&n, u, &ONE, um, &ONE));
isorth=((*unrm) > alpha*unrm_old);
}
if (i >= maxcgsit) {
printf("warning: loss of orthogonality. ");
printf("icgsm() not converged after %d steps.\n", maxcgsit);
}
}
static int
jacobi(PyObject *matrix, int n, double *dinv, int steps, double *x, double *y, double *temp) {
int ONE = 1;
int i, step, res;
/* 1st step */
for (i = 0; i < n; i ++)
y[i] = x[i]*dinv[i];
/* following steps */
for(step = 1; step < steps; step ++) {
F77(dcopy)(&n, y, &ONE, temp, &ONE);
res = SpMatrix_Matvec(matrix, n, temp, n, y);
if (res == -1)
return res;
for (i = 0; i < n; i ++)
y[i] = (x[i] - y[i])*dinv[i] + temp[i];
}
return 0;
}
/* PCG - Conjugate Gradients Algorithm
*/
void pcg(int n,
double *x,
double *b,
double tol,
int maxit,
int clvl,
int *iter,
double *relres,
int *flag,
double *work,
void (*matvec)(double *, double *),
void (*precon)(double *, double *))
{
double ALPHA; /* used for passing parameters */
int ONE = 1; /* to BLAS routines */
double n2b; /* norm of rhs vector */
double tolb; /* requested tolerance for residual */
double normr; /* residual norm */
double alpha, beta;
double rho, rho1;
double pq;
double dmax, ddum; /* used to detect stagnation */
int stag; /* flag to indicate stagnation */
int it; /* current iteration number */
int i; /* index variable */
double *r, *z, *p, *q; /* pointers to vectors in PCG algorithm */
/* setup pointers into work */
r = work;
z = work + n;
p = work + 2*n;
q = work + 3*n;
/* Check for all zero right hand side vector => all zero solution */
n2b = F77(dnrm2)(&n, b, &ONE);/* Norm of rhs vector, b */
if (n2b == 0.0) { /* if rhs vector is all zeros */
for (i = 0; i < n; i ++) /* then solution is all zeros */
x[i] = 0.0;
*flag = 0; /* a valid solution has been obtained */
*relres = 0.0; /* the relative residual is actually 0/0 */
*iter = 0; /* no iterations need be performed */
if (clvl)
itermsg(tol,maxit,*flag,*iter,*relres);
return;
}
/* Set up for the method */
*flag = 1;
tolb = tol * n2b; /* Relative tolerance */
matvec(x, r); /* Zero-th residual: r = b - A * x*/
for (i = 0; i < n; i ++) /* then solution is all zeros */
r[i] = b[i] - r[i];
normr = F77(dnrm2)(&n, r, &ONE); /* Norm of residual */
if (normr <= tolb) { /* Initial guess is a good enough solution */
*flag = 0;
*relres = normr / n2b;
*iter = 0;
if (clvl)
itermsg(tol,maxit,*flag,*iter,*relres);
return;
}
rho = 1.0;
stag = 0; /* stagnation of the method */
/* loop over maxit iterations (unless convergence or failure) */
for (it = 1; it <= maxit; it ++) {
if (precon) {
precon(r, z);
/*
if isinf(norm(y,inf))
flag = 2;
break
end
*/
} else {
F77(dcopy)(&n, r, &ONE, z, &ONE);
}
rho1 = rho;
rho = F77(ddot)(&n, r, &ONE, z, &ONE);
if (rho == 0.0) { /* or isinf(rho) */
*flag = 4;
break;
}
if (it == 1) {
F77(dcopy)(&n, z, &ONE, p, &ONE);
} else {
beta = rho / rho1;
if (beta == 0.0) { /* | isinf(beta) */
*flag = 4;
break;
}
for (i = 0; i < n; i ++) /* p = z + beta * p; */
p[i] = z[i] + beta * p[i];
}
matvec(p, q); /* q = A * p */
pq = F77(ddot)(&n, p, &ONE, q, &ONE); /* pq = p' * q */
if (pq == 0.0) { /* | isinf(pq) */
*flag = 4;
break;
} else {
alpha = rho / pq;
}
/*
if isinf(alpha)
flag = 4;
break
end
*/
if (alpha == 0.0) /* stagnation of the method */
stag = 1;
/* Check for stagnation of the method */
if (stag == 0) {
dmax = 0.0;
for (i = 0; i < n; i ++)
if (x[i] != 0.0) {
ddum = fabs(alpha * p[i]/x[i]);
if (ddum > dmax)
dmax = ddum;
} else
if (p[i] != 0.0)
dmax = 1.0;
stag = (1.0 + dmax == 1.0);
}
F77(daxpy)(&n, &alpha, p, &ONE, x, &ONE); /* form new iterate */
ALPHA = -alpha;
F77(daxpy)(&n, &ALPHA, q, &ONE, r, &ONE); /* r = r - alpha * q */
/* check for convergence */
#ifdef EXPENSIVE_CRIT
matvec(x, z); /* normr = norm(b - A * x) */
for (i = 0; i < n; i ++)
z[i] = b[i] - z[i];
normr = F77(dnrm2)(&n, z, &ONE);
#else
normr = F77(dnrm2)(&n, r, &ONE); /* normr = norm(r) */
#endif
if (normr <= tolb) {
*flag = 0;
break;
}
if (stag == 1) {
*flag = 3;
break;
}
} /* for it = 1 : maxit */
*iter = it;
*relres = normr / n2b;
if (clvl)
itermsg(tol,maxit,*flag,*iter,*relres);
}
