You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
859 lines
32 KiB
859 lines
32 KiB
/*
|
|
* Copyright(C) 1999-2020, 2022, 2023 National Technology & Engineering Solutions
|
|
* of Sandia, LLC (NTESS). Under the terms of Contract DE-NA0003525 with
|
|
* NTESS, the U.S. Government retains certain rights in this software.
|
|
*
|
|
* See packages/seacas/LICENSE for details
|
|
*/
|
|
/* symmlq.f -- translated by f2c (version of 16 May 1991 13:06:06).
|
|
*/
|
|
|
|
#include "prototypes.h"
|
|
#include <math.h>
|
|
|
|
/* Table of constant values */
|
|
|
|
static long int c__1 = 1;
|
|
static double c_b4 = 1.;
|
|
static double c_b18 = 1.0 / 3.0;
|
|
|
|
int symmlq(long int *n, double *b, double *r1, double *r2, double *v, double *w, double *x,
|
|
double *y, double *work, long int *checka, long int *goodb, long int *precon,
|
|
double *shift, long int *nout, long int *itnlim, double *rtol, long int *istop,
|
|
long int *itn, double *anorm, double *acond, double *rnorm, double *ynorm, double *a,
|
|
double *vwsqrt, double *orthlist, double *macheps, double *normxlim, long int *itnmin)
|
|
{
|
|
|
|
/* System generated locals */
|
|
long int i__1;
|
|
double d__1, d__2;
|
|
|
|
/* Local variables */
|
|
static double alfa, diag, dbar, beta, gbar, oldb, epsa;
|
|
extern double ch_ddot(long int *n, double *dx, long int *incx, double *dy, long int *incy);
|
|
static double gmin, gmax, zbar, epsr, epsx, beta1;
|
|
extern double chdnrm2(long int *n, double *dx, long int *incx);
|
|
static long int i;
|
|
static double gamma, s, t, delta, z, denom;
|
|
extern int aprod(long *lnvtxs, double *x, double *y, double *dA, double *vwsqrt, double *work,
|
|
double *dorthlist /* vectors to orthogonalize against */);
|
|
static double bstep;
|
|
static double epsln;
|
|
static double tnorm, cs, ynorm2, sn, cgnorm;
|
|
static double snprod, lqnorm, qrnorm, eps, rhs1, rhs2;
|
|
|
|
/* ------------------------------------------------------------------
|
|
*/
|
|
|
|
/* SYMMLQ is designed to solve the system of linear equations */
|
|
|
|
/* Ax = b */
|
|
|
|
/* where A is an n by n symmetric matrix and b is a given vector. */
|
|
/* The matrix A is not required to be positive definite. */
|
|
/* (If A is known to be definite, the method of conjugate gradients */
|
|
|
|
/* might be preferred, since it will require about the same number of
|
|
*/
|
|
/* iterations as SYMMLQ but slightly less work per iteration.) */
|
|
|
|
/* The matrix A is intended to be large and sparse. It is accessed */
|
|
|
|
/* by means of a subroutine call of the form */
|
|
|
|
/* old call aprod ( n, x, y ) */
|
|
/* new: call aprod ( n, x, y, A, vwsqrt, work, orthlist ) -rwl
|
|
*/
|
|
|
|
/* which must return the product y = Ax for any given vector x. */
|
|
|
|
/* More generally, SYMMLQ is designed to solve the system */
|
|
|
|
/* (A - shift*I) x = b */
|
|
|
|
/* where shift is a specified scalar value. If shift and b */
|
|
/* are suitably chosen, the computed vector x may approximate an */
|
|
/* (unnormalized) eigenvector of A, as in the methods of */
|
|
/* inverse iteration and/or Rayleigh-quotient iteration. */
|
|
/* Again, the matrix (A - shift*I) need not be positive definite. */
|
|
/* The work per iteration is very slightly less if shift = 0. */
|
|
|
|
/* A further option is that of preconditioning, which may reduce */
|
|
/* the number of iterations required. If M = C C' is a positive */
|
|
/* definite matrix that is known to approximate (A - shift*I) */
|
|
/* in some sense, and if systems of the form My = x can be */
|
|
/* solved efficiently, the parameters precon and msolve may be */
|
|
/* used (see below). When precon = .true., SYMMLQ will */
|
|
/* implicitly solve the system of equations */
|
|
|
|
/* P (A - shift*I) P' xbar = P b, */
|
|
|
|
/* i.e. Abar xbar = bbar */
|
|
/* where P = C**(-1), */
|
|
/* Abar = P (A - shift*I) P', */
|
|
/* bbar = P b, */
|
|
|
|
/* and return the solution x = P' xbar. */
|
|
/* The associated residual is rbar = bbar - Abar xbar */
|
|
/* = P (b - (A - shift*I)x) */
|
|
/* = P r. */
|
|
|
|
/* In the discussion below, eps refers to the machine precision. */
|
|
/* eps is computed by SYMMLQ. A typical value is eps = 2.22e-16 */
|
|
/* for IBM mainframes and IEEE double-precision arithmetic. */
|
|
|
|
/* Parameters */
|
|
/* ---------- */
|
|
|
|
/* n input The dimension of the matrix A. */
|
|
|
|
/* b(n) input The rhs vector b. */
|
|
|
|
/* r1(n) workspace */
|
|
/* r2(n) workspace */
|
|
/* v(n) workspace */
|
|
/* w(n) workspace */
|
|
|
|
/* x(n) output Returns the computed solution x. */
|
|
|
|
/* y(n) workspace */
|
|
|
|
/* aprod external A subroutine defining the matrix A. */
|
|
/* For a given vector x, the statement */
|
|
|
|
/* old: call aprod ( n, x, y, ) */
|
|
/* new: call aprod ( n, x, y, A, vwsqrt, work, orthl
|
|
ist ) -rwl*/
|
|
|
|
/* must return the product y = Ax */
|
|
/* without altering the vector x. */
|
|
|
|
/* msolve external An optional subroutine defining a */
|
|
/* preconditioning matrix M, which should */
|
|
/* approximate (A - shift*I) in some sense. */
|
|
/* M must be positive definite. */
|
|
/* For a given vector x, the statement */
|
|
|
|
/* old: call msolve( n, x, y ) */
|
|
/* new: call msolve( n, x, y ) -rwl */
|
|
|
|
/* must solve the linear system My = x */
|
|
/* without altering the vector x. */
|
|
|
|
/* In general, M should be chosen so that Abar has
|
|
*/
|
|
/* clustered eigenvalues. For example, */
|
|
/* if A is positive definite, Abar would ideally */
|
|
|
|
/* be close to a multiple of I. */
|
|
/* If A or A - shift*I is indefinite, Abar might */
|
|
|
|
/* be close to a multiple of diag( I -I ). */
|
|
|
|
/* NOTE. The program calling SYMMLQ must declare
|
|
*/
|
|
/* aprod and msolve to be external. */
|
|
|
|
/* checka input If checka = .true., an extra call of aprod will
|
|
*/
|
|
/* be used to check if A is symmetric. Also, */
|
|
/* if precon = .true., an extra call of msolve */
|
|
/* will be used to check if M is symmetric. */
|
|
|
|
/* goodb input Usually, goodb should be .false. */
|
|
/* If x is expected to contain a large multiple of
|
|
*/
|
|
/* b (as in Rayleigh-quotient iteration), */
|
|
/* better precision may result if goodb = .true. */
|
|
|
|
/* See Lewis (1977) below. */
|
|
/* When goodb = .true., an extra call to msolve */
|
|
/* is required. */
|
|
|
|
/* precon input If precon = .true., preconditioning will */
|
|
/* be invoked. Otherwise, subroutine msolve */
|
|
/* will not be referenced; in this case the */
|
|
/* actual parameter corresponding to msolve may */
|
|
/* be the same as that corresponding to aprod. */
|
|
|
|
/* shift input Should be zero if the system Ax = b is to be */
|
|
/* solved. Otherwise, it could be an */
|
|
/* approximation to an eigenvalue of A, such as */
|
|
/* the Rayleigh quotient b'Ab / (b'b) */
|
|
/* corresponding to the vector b. */
|
|
/* If b is sufficiently like an eigenvector */
|
|
/* corresponding to an eigenvalue near shift, */
|
|
/* then the computed x may have very large */
|
|
/* components. When normalized, x may be */
|
|
/* closer to an eigenvector than b. */
|
|
|
|
/* nout input A file number. */
|
|
/* If nout .gt. 0, a summary of the iterations */
|
|
/* will be printed on unit nout. */
|
|
|
|
/* itnlim input An upper limit on the number of iterations. */
|
|
|
|
/* rtol input A user-specified tolerance. SYMMLQ terminates
|
|
*/
|
|
/* if it appears that norm(rbar) is smaller than */
|
|
|
|
/* rtol * norm(Abar) * norm(xbar), */
|
|
/* where rbar is the transformed residual vector,
|
|
*/
|
|
/* rbar = bbar - Abar xbar. */
|
|
|
|
/* If shift = 0 and precon = .false., SYMMLQ */
|
|
/* terminates if norm(b - A*x) is smaller than */
|
|
/* rtol * norm(A) * norm(x). */
|
|
|
|
/* istop output An long int giving the reason for termination...
|
|
*/
|
|
|
|
/* -1 beta2 = 0 in the Lanczos iteration; i.e. the */
|
|
/* second Lanczos vector is zero. This means the
|
|
*/
|
|
/* rhs is very special. */
|
|
/* If there is no preconditioner, b is an */
|
|
/* eigenvector of A. */
|
|
/* Otherwise (if precon is true), let My = b. */
|
|
/* If shift is zero, y is a solution of the */
|
|
/* generalized eigenvalue problem Ay = lambda My,
|
|
*/
|
|
/* with lambda = alpha1 from the Lanczos vectors.
|
|
*/
|
|
|
|
/* In general, (A - shift*I)x = b */
|
|
/* has the solution x = (1/alpha1) y */
|
|
/* where My = b. */
|
|
|
|
/* 0 b = 0, so the exact solution is x = 0. */
|
|
/* No iterations were performed. */
|
|
|
|
/* 1 Norm(rbar) appears to be less than */
|
|
/* the value rtol * norm(Abar) * norm(xbar). */
|
|
/* The solution in x should be acceptable. */
|
|
|
|
/* 2 Norm(rbar) appears to be less than */
|
|
/* the value eps * norm(Abar) * norm(xbar). */
|
|
/* This means that the residual is as small as */
|
|
/* seems reasonable on this machine. */
|
|
|
|
/* 3 Norm(Abar) * norm(xbar) exceeds norm(b)/eps, */
|
|
/* which should indicate that x has essentially */
|
|
/* converged to an eigenvector of A */
|
|
/* corresponding to the eigenvalue shift. */
|
|
|
|
/* 4 acond (see below) has exceeded 0.1/eps, so */
|
|
/* the matrix Abar must be very ill-conditioned. */
|
|
|
|
/* x may not contain an acceptable solution. */
|
|
|
|
/* 5 The iteration limit was reached before any of */
|
|
|
|
/* the previous criteria were satisfied. */
|
|
|
|
/* 6 The matrix defined by aprod does not appear */
|
|
/* to be symmetric. */
|
|
/* For certain vectors y = Av and r = Ay, the */
|
|
/* products y'y and r'v differ significantly. */
|
|
|
|
/* 7 The matrix defined by msolve does not appear */
|
|
/* to be symmetric. */
|
|
/* For vectors satisfying My = v and Mr = y, the */
|
|
|
|
/* products y'y and r'v differ significantly. */
|
|
|
|
/* 8 An inner product of the form x' M**(-1) x */
|
|
/* was not positive, so the preconditioning matrix
|
|
*/
|
|
/* M does not appear to be positive definite. */
|
|
|
|
/* If istop .ge. 5, the final x may not be an */
|
|
/* acceptable solution. */
|
|
|
|
/* 9 The norm of the iterate is > than normxlim. */
|
|
/* Termination enforced on presumption that inverse */
|
|
/* iteration is being performed -rwl. */
|
|
|
|
/* itn output The number of iterations performed. */
|
|
|
|
/* anorm output An estimate of the norm of the matrix operator
|
|
*/
|
|
/* Abar = P (A - shift*I) P', where P = C**(-1).
|
|
*/
|
|
|
|
/* acond output An estimate of the condition of Abar above. */
|
|
/* This will usually be a substantial */
|
|
/* under-estimate of the true condition. */
|
|
|
|
/* rnorm output An estimate of the norm of the final */
|
|
/* transformed residual vector, */
|
|
/* P (b - (A - shift*I) x). */
|
|
|
|
/* ynorm output An estimate of the norm of xbar. */
|
|
/* This is sqrt( x'Mx ). If precon is false, */
|
|
/* ynorm is an estimate of norm(x). */
|
|
|
|
/* A input A pointer variable to the matrix data. Passed */
|
|
|
|
/* in to use in revised call to aprod and msolve */
|
|
/* added 14 Dec 92 by rwl. */
|
|
|
|
/* macheps output Used to return the calculated machine precision.
|
|
*/
|
|
/* Added 10 Feb 93 by rwl. */
|
|
|
|
/* normxlim input Used as possible termination criterion. 10 Feb 93 rwl.
|
|
*/
|
|
|
|
/* itnmin input Used to enforce a minimum number of itns. 10 Feb 93 rwl.
|
|
*/
|
|
|
|
/* To change precision */
|
|
/* ------------------- */
|
|
|
|
/* Alter the words */
|
|
/* double precision, */
|
|
/* chdaxpy, chdcopy, chddot, chdnrm2 */
|
|
/* to their single or double equivalents. */
|
|
/* ------------------------------------------------------------------
|
|
*/
|
|
|
|
/* This routine is an implementation of the algorithm described in */
|
|
/* the following references: */
|
|
|
|
/* C.C. Paige and M.A. Saunders, Solution of Sparse Indefinite */
|
|
/* Systems of Linear Equations, */
|
|
/* SIAM J. Numerical Analysis 12, 4, September 1975, pp. 617-629. */
|
|
|
|
/* J.G. Lewis, Algorithms for Sparse Matrix Eigenvalue Problems, */
|
|
/* Report STAN-CS-77-595, Computer Science Department, */
|
|
/* Stanford University, Stanford, California, March 1977. */
|
|
|
|
/* Applications of SYMMLQ and the theory of preconditioning */
|
|
/* are described in the following references: */
|
|
|
|
/* D.B. Szyld and O.B. Widlund, Applications of Conjugate Gradient */
|
|
|
|
/* Type Methods to Eigenvalue Calculations, */
|
|
/* in R. Vichnevetsky and R.S. Steplman (editors), */
|
|
/* Advances in Computer Methods for Partial Differential */
|
|
/* Equations -- III, IMACS, 1979, 167-173. */
|
|
|
|
/* D.B. Szyld, A Two-level Iterative Method for Large Sparse */
|
|
/* Generalized Eigenvalue Calculations, */
|
|
/* Ph. D. dissertation, Department of Mathematics, */
|
|
/* New York University, New York, October 1983. */
|
|
|
|
/* P.E. Gill, W. Murray, D.B. Ponceleon and M.A. Saunders, */
|
|
/* Preconditioners for indefinite systems arising in */
|
|
/* optimization, SIMAX 13, 1, 292--311, January 1992. */
|
|
/* (SIAM J. on Matrix Analysis and Applications) */
|
|
/* ------------------------------------------------------------------
|
|
*/
|
|
|
|
/* SYMMLQ development: */
|
|
/* 1972: First version. */
|
|
/* 1975: John Lewis recommended modifications to help with */
|
|
/* inverse iteration: */
|
|
/* 1. Reorthogonalize v1 and v2. */
|
|
/* 2. Regard the solution as x = x1 + bstep * b, */
|
|
/* with x1 and bstep accumulated separately */
|
|
/* and bstep * b added at the end. */
|
|
/* (In inverse iteration, b might be close to the */
|
|
/* required x already, so x1 may be a lot smaller */
|
|
/* than the multiple of b.) */
|
|
/* 1978: Daniel Szyld and Olof Widlund implemented the first */
|
|
|
|
/* form of preconditioning. */
|
|
/* This required both a solve and a multiply with M. */
|
|
/* 1979: Implemented present method for preconditioning. */
|
|
/* This requires only a solve with M. */
|
|
/* 1984: Sven Hammarling noted corrections to tnorm and x1lq.
|
|
*/
|
|
/* SYMMLQ added to NAG Fortran Library. */
|
|
/* 15 Sep 1985: Final F66 version. SYMMLQ sent to "misc" in netlib.
|
|
*/
|
|
/* 16 Feb 1989: First F77 version. */
|
|
|
|
/* 22 Feb 1989: Hans Mittelmann observed beta2 = 0 (hence failure) */
|
|
/* if Abar = const*I. istop = -1 added for this case. */
|
|
|
|
/* 01 Mar 1989: Hans Mittelmann observed premature termination on */
|
|
/* ( 1 1 1 ) ( ) ( 1 1 ) */
|
|
|
|
/* ( 1 1 ) x = ( 1 ), for which T3 = ( 1 1 1 ).
|
|
*/
|
|
/* ( 1 1 ) ( ) ( 1 1 ) */
|
|
|
|
/* T2 is exactly singular, so estimating cond(A) from */
|
|
/* the diagonals of Lbar is unsafe. We now use */
|
|
/* L or Lbar depending on whether */
|
|
/* lqnorm or cgnorm is least. */
|
|
|
|
/* 03 Mar 1989: eps computed internally instead of coming in as a */
|
|
/* parameter. */
|
|
/* 07 Jun 1989: ncheck added as a parameter to say if A and M */
|
|
/* should be checked for symmetry. */
|
|
/* Later changed to checka (see below). */
|
|
/* 20 Nov 1990: goodb added as a parameter to make Lewis's changes */
|
|
/* an option. Usually b is NOT much like x. Setting */
|
|
/* goodb = .false. saves a call to msolve at the end. */
|
|
/* 20 Nov 1990: Residual not computed exactly at end, to save time */
|
|
/* when only one or two iterations are required */
|
|
/* (e.g. if the preconditioner is very good). */
|
|
/* Beware, if precon is true, rnorm estimates the */
|
|
/* residual of the preconditioned system, not Ax = b. */
|
|
/* 04 Sep 1991: Parameter list changed and reordered. */
|
|
/* long int ncheck is now long int checka. */
|
|
/* 22 Jul 1992: Example from Lothar Reichel and Daniela Calvetti */
|
|
/* showed that beta2 = 0 (istop = -1) means that */
|
|
/* b is an eigenvector when M = I. */
|
|
/* More complicated if there is a preconditioner; */
|
|
/* not clear yet how to describe it. */
|
|
/* 14 Dec 1992: Modified by Robert Leland, Sandia National Laboratories
|
|
*/
|
|
/* to integrate with a C application code. The matrix */
|
|
/* data is now passed by reference through symmlq to */
|
|
/* aprod and msolve. These are now just Fortran wrappers
|
|
*/
|
|
/* for C codes consistent with the matrix data passed */
|
|
/* via the pointers "A", "vwsqrt", "work" and "orthlist"
|
|
*/
|
|
/* 10 Feb 1993: Modified by Robert Leland to return calculate machine
|
|
*/
|
|
/* precision and terminate if the norm of the iterate gets */
|
|
/* above the limit normxlim. Relevant for inverse iteration. */
|
|
/* Also incorporated itnmin to enforce minimum number itns. */
|
|
/* 17 Aug 1993: Observed that the Fortran i/o in this routine won't */
|
|
|
|
/* work because there is no main fortran program to open */
|
|
/* the standard i/o files. So for this (and other reasons)
|
|
*/
|
|
/* converted the Fortran to C, necessitating inclusion of
|
|
*/
|
|
/* the file f2c.h. To avoid a problem with maintaining */
|
|
|
|
/* Symmlq, I commented out the i/o within it and instead */
|
|
/* report its performance based only on the return value */
|
|
/* of various parameters. That means we can modify the */
|
|
/* Fortran source, run f2c and recompile without losing or */
|
|
/* re-writing any functionality. */
|
|
|
|
/* Michael A. Saunders na.saunders@na-net.ornl.gov
|
|
*/
|
|
/* Department of Operations Research mike@sol-michael.stanford.edu
|
|
*/
|
|
/* Stanford University */
|
|
/* Stanford, CA 94305-4022 (415) 723-1875
|
|
*/
|
|
/* ------------------------------------------------------------------
|
|
*/
|
|
|
|
/* Subroutines and functions */
|
|
|
|
/* USER aprod, msolve */
|
|
/* BLAS chdaxpy, chdcopy, chddot , chdnrm2 */
|
|
|
|
/* Intrinsics and local variables */
|
|
/* Parameter adjustments */
|
|
--vwsqrt;
|
|
--work;
|
|
--y;
|
|
--x;
|
|
--w;
|
|
--v;
|
|
--r2;
|
|
--r1;
|
|
--b;
|
|
|
|
/* Function Body */
|
|
/* ------------------------------------------------------------------
|
|
*/
|
|
/* Compute eps, the machine precision. The call to chdaxpy is */
|
|
/* intended to fool compilers that use extra-length registers. */
|
|
eps = .0625;
|
|
L10:
|
|
eps /= 2.;
|
|
x[1] = eps;
|
|
y[1] = 1.;
|
|
chdaxpy(&c__1, &c_b4, &x[1], &c__1, &y[1], &c__1);
|
|
if (y[1] > 1.) {
|
|
goto L10;
|
|
}
|
|
eps *= 2.;
|
|
/* Return the calculated machine precision - rwl */
|
|
*macheps = eps;
|
|
/* Print heading and initialize. */
|
|
/* This i/o won't work - see note in preamble.. */
|
|
/* if (nout .gt. 0) then */
|
|
/* write(nout, 1000) enter, n, checka, goodb, precon, */
|
|
/* $ itnlim, rtol, shift */
|
|
/* end if */
|
|
*istop = 0;
|
|
*itn = 0;
|
|
*anorm = 0.;
|
|
*acond = 0.;
|
|
*rnorm = 0.;
|
|
*ynorm = 0.;
|
|
i__1 = *n;
|
|
for (i = 1; i <= i__1; ++i) {
|
|
x[i] = 0.;
|
|
/* L50: */
|
|
}
|
|
/* Set up y for the first Lanczos vector v1. */
|
|
/* y is really beta1 * P * v1 where P = C**(-1). */
|
|
/* y and beta1 will be zero if b = 0. */
|
|
chdcopy(n, &b[1], &c__1, &y[1], &c__1);
|
|
chdcopy(n, &b[1], &c__1, &r1[1], &c__1);
|
|
if (*precon) {
|
|
msolve(n, &r1[1], &y[1]);
|
|
}
|
|
/* if ( goodb ) then */
|
|
/* b1 = y(1) */
|
|
/* else */
|
|
/* b1 = zero */
|
|
/* end if */
|
|
beta1 = ch_ddot(n, &r1[1], &c__1, &y[1], &c__1);
|
|
/* See if msolve is symmetric. */
|
|
if (*checka && *precon) {
|
|
msolve(n, &y[1], &r2[1]);
|
|
s = ch_ddot(n, &y[1], &c__1, &y[1], &c__1);
|
|
t = ch_ddot(n, &r1[1], &c__1, &r2[1], &c__1);
|
|
z = (d__1 = s - t, fabs(d__1));
|
|
epsa = (s + eps) * pow(eps, c_b18);
|
|
if (z > epsa) {
|
|
*istop = 7;
|
|
goto L900;
|
|
}
|
|
}
|
|
/* Test for an indefinite preconditioner. */
|
|
if (beta1 < 0.) {
|
|
*istop = 8;
|
|
goto L900;
|
|
}
|
|
/* If b = 0 exactly, stop with x = 0. */
|
|
if (beta1 == 0.) {
|
|
goto L900;
|
|
}
|
|
/* Here and later, v is really P * (the Lanczos v). */
|
|
beta1 = sqrt(beta1);
|
|
s = 1. / beta1;
|
|
i__1 = *n;
|
|
for (i = 1; i <= i__1; ++i) {
|
|
v[i] = s * y[i];
|
|
/* L100: */
|
|
}
|
|
/* See if aprod is symmetric. */
|
|
aprod(n, &v[1], &y[1], a, &vwsqrt[1], &work[1], orthlist);
|
|
if (*checka) {
|
|
aprod(n, &y[1], &r2[1], a, &vwsqrt[1], &work[1], orthlist);
|
|
s = ch_ddot(n, &y[1], &c__1, &y[1], &c__1);
|
|
t = ch_ddot(n, &v[1], &c__1, &r2[1], &c__1);
|
|
z = (d__1 = s - t, fabs(d__1));
|
|
epsa = (s + eps) * pow(eps, c_b18);
|
|
if (z > epsa) {
|
|
*istop = 6;
|
|
goto L900;
|
|
}
|
|
}
|
|
/* Set up y for the second Lanczos vector. */
|
|
/* Again, y is beta * P * v2 where P = C**(-1). */
|
|
/* y and beta will be zero or very small if b is an eigenvector. */
|
|
d__1 = -(*shift);
|
|
chdaxpy(n, &d__1, &v[1], &c__1, &y[1], &c__1);
|
|
alfa = ch_ddot(n, &v[1], &c__1, &y[1], &c__1);
|
|
d__1 = -alfa / beta1;
|
|
chdaxpy(n, &d__1, &r1[1], &c__1, &y[1], &c__1);
|
|
/* Make sure r2 will be orthogonal to the first v. */
|
|
z = ch_ddot(n, &v[1], &c__1, &y[1], &c__1);
|
|
s = ch_ddot(n, &v[1], &c__1, &v[1], &c__1);
|
|
d__1 = -z / s;
|
|
chdaxpy(n, &d__1, &v[1], &c__1, &y[1], &c__1);
|
|
chdcopy(n, &y[1], &c__1, &r2[1], &c__1);
|
|
if (*precon) {
|
|
msolve(n, &r2[1], &y[1]);
|
|
}
|
|
oldb = beta1;
|
|
beta = ch_ddot(n, &r2[1], &c__1, &y[1], &c__1);
|
|
if (beta < 0.) {
|
|
*istop = 8;
|
|
goto L900;
|
|
}
|
|
/* Cause termination (later) if beta is essentially zero. */
|
|
beta = sqrt(beta);
|
|
if (beta <= eps) {
|
|
*istop = -1;
|
|
}
|
|
/* See if the local reorthogonalization achieved anything. */
|
|
denom = sqrt(s) * chdnrm2(n, &r2[1], &c__1) + eps;
|
|
s = z / denom;
|
|
t = ch_ddot(n, &v[1], &c__1, &r2[1], &c__1) / denom;
|
|
/* if (nout .gt. 0 .and. goodb) then */
|
|
/* write(nout, 1100) beta1, alfa, s, t */
|
|
/* end if */
|
|
/* Initialize other quantities. */
|
|
cgnorm = beta1;
|
|
gbar = alfa;
|
|
dbar = beta;
|
|
rhs1 = beta1;
|
|
rhs2 = 0.;
|
|
bstep = 0.;
|
|
snprod = 1.;
|
|
/* Computing 2nd power */
|
|
d__1 = alfa;
|
|
tnorm = d__1 * d__1;
|
|
ynorm2 = 0.;
|
|
gmax = fabs(alfa);
|
|
gmin = gmax;
|
|
if (*goodb) {
|
|
i__1 = *n;
|
|
for (i = 1; i <= i__1; ++i) {
|
|
w[i] = 0.;
|
|
/* L200: */
|
|
}
|
|
}
|
|
else {
|
|
chdcopy(n, &v[1], &c__1, &w[1], &c__1);
|
|
}
|
|
/* ------------------------------------------------------------------
|
|
*/
|
|
/* Main iteration loop. */
|
|
/* ------------------------------------------------------------------
|
|
*/
|
|
/* Estimate various norms and test for convergence. */
|
|
L300:
|
|
*anorm = sqrt(tnorm);
|
|
*ynorm = sqrt(ynorm2);
|
|
epsa = *anorm * eps;
|
|
epsx = *anorm * *ynorm * eps;
|
|
epsr = *anorm * *ynorm * *rtol;
|
|
diag = gbar;
|
|
if (diag == 0.) {
|
|
diag = epsa;
|
|
}
|
|
/* Computing 2nd power */
|
|
d__1 = rhs1;
|
|
/* Computing 2nd power */
|
|
d__2 = rhs2;
|
|
lqnorm = sqrt(d__1 * d__1 + d__2 * d__2);
|
|
qrnorm = snprod * beta1;
|
|
cgnorm = qrnorm * beta / fabs(diag);
|
|
/* Estimate cond(A). */
|
|
/* In this version we look at the diagonals of L in the */
|
|
/* factorization of the tridiagonal matrix, T = L*Q. */
|
|
/* Sometimes, T(k) can be misleadingly ill-conditioned when */
|
|
/* T(k+1) is not, so we must be careful not to overestimate acond. */
|
|
if (lqnorm <= cgnorm) {
|
|
*acond = gmax / gmin;
|
|
}
|
|
else {
|
|
/* Computing MIN */
|
|
d__1 = gmin, d__2 = fabs(diag);
|
|
denom = d__1 < d__2 ? d__1 : d__2;
|
|
*acond = gmax / denom;
|
|
}
|
|
/* See if any of the stopping criteria are satisfied. */
|
|
/* In rare cases, istop is already -1 from above (Abar = const * I).
|
|
*/
|
|
if (*istop == 0) {
|
|
if (*itn >= *itnlim) {
|
|
*istop = 5;
|
|
}
|
|
/* if (acond .ge. 0.1/eps) istop = 4 */
|
|
if (epsx >= beta1) {
|
|
*istop = 3;
|
|
}
|
|
if (cgnorm <= epsx) {
|
|
*istop = 2;
|
|
}
|
|
if (cgnorm <= epsr) {
|
|
*istop = 1;
|
|
}
|
|
if (*istop != 4 && *ynorm >= *normxlim && *normxlim != 0.) {
|
|
*istop = 9;
|
|
}
|
|
}
|
|
if (*itn < *itnmin) {
|
|
*istop = 0;
|
|
}
|
|
/* ==================================================================
|
|
*/
|
|
/* See if it is time to print something. */
|
|
if (*nout <= 0) {
|
|
goto L600;
|
|
}
|
|
if (*n <= 40) {
|
|
goto L400;
|
|
}
|
|
if (*itn <= 10) {
|
|
goto L400;
|
|
}
|
|
if (*itn >= *itnlim - 10) {
|
|
goto L400;
|
|
}
|
|
if (*itn % 10 == 0) {
|
|
goto L400;
|
|
}
|
|
if (cgnorm <= epsx * (float)10.) {
|
|
goto L400;
|
|
}
|
|
if (cgnorm <= epsr * (float)10.) {
|
|
goto L400;
|
|
}
|
|
if (*acond >= (float).01 / eps) {
|
|
goto L400;
|
|
}
|
|
if (*istop != 0) {
|
|
goto L400;
|
|
}
|
|
goto L600;
|
|
/* Print a line for this iteration. */
|
|
L400:
|
|
zbar = rhs1 / diag;
|
|
z = (snprod * zbar + bstep) / beta1;
|
|
/* x1lq = x(1) + b1 * bstep / beta1 */
|
|
/* x1cg = x(1) + w(1) * zbar + b1 * z */
|
|
/* if ( itn .eq. 0) write(nout, 1200) */
|
|
/* write(nout, 1300) itn, x1cg, cgnorm, bstep/beta1, anorm, acond */
|
|
/* if (mod(itn,10) .eq. 0) write(nout, 1500) */
|
|
/* ==================================================================
|
|
*/
|
|
/* Obtain the current Lanczos vector v = (1 / beta)*y */
|
|
/* and set up y for the next iteration. */
|
|
L600:
|
|
if (*istop != 0) {
|
|
goto L800;
|
|
}
|
|
s = 1. / beta;
|
|
i__1 = *n;
|
|
for (i = 1; i <= i__1; ++i) {
|
|
v[i] = s * y[i];
|
|
/* L620: */
|
|
}
|
|
aprod(n, &v[1], &y[1], a, &vwsqrt[1], &work[1], orthlist);
|
|
d__1 = -(*shift);
|
|
chdaxpy(n, &d__1, &v[1], &c__1, &y[1], &c__1);
|
|
d__1 = -beta / oldb;
|
|
chdaxpy(n, &d__1, &r1[1], &c__1, &y[1], &c__1);
|
|
alfa = ch_ddot(n, &v[1], &c__1, &y[1], &c__1);
|
|
/* Computing 2nd power */
|
|
d__1 = alfa;
|
|
/* Computing 2nd power */
|
|
d__2 = beta;
|
|
tnorm = tnorm + d__1 * d__1 + d__2 * d__2 * 2.;
|
|
d__1 = -alfa / beta;
|
|
chdaxpy(n, &d__1, &r2[1], &c__1, &y[1], &c__1);
|
|
chdcopy(n, &r2[1], &c__1, &r1[1], &c__1);
|
|
chdcopy(n, &y[1], &c__1, &r2[1], &c__1);
|
|
if (*precon) {
|
|
msolve(n, &r2[1], &y[1]);
|
|
}
|
|
oldb = beta;
|
|
beta = ch_ddot(n, &r2[1], &c__1, &y[1], &c__1);
|
|
if (beta < 0.) {
|
|
*istop = 6;
|
|
goto L800;
|
|
}
|
|
beta = sqrt(beta);
|
|
/* Compute the next plane rotation for Q. */
|
|
/* Computing 2nd power */
|
|
d__1 = gbar;
|
|
/* Computing 2nd power */
|
|
d__2 = oldb;
|
|
gamma = sqrt(d__1 * d__1 + d__2 * d__2);
|
|
cs = gbar / gamma;
|
|
sn = oldb / gamma;
|
|
delta = cs * dbar + sn * alfa;
|
|
gbar = sn * dbar - cs * alfa;
|
|
epsln = sn * beta;
|
|
dbar = -cs * beta;
|
|
/* Update x. */
|
|
z = rhs1 / gamma;
|
|
s = z * cs;
|
|
t = z * sn;
|
|
i__1 = *n;
|
|
for (i = 1; i <= i__1; ++i) {
|
|
x[i] = w[i] * s + v[i] * t + x[i];
|
|
w[i] = w[i] * sn - v[i] * cs;
|
|
/* L700: */
|
|
}
|
|
/* Accumulate the step along the direction b, */
|
|
/* and go round again. */
|
|
bstep = snprod * cs * z + bstep;
|
|
snprod *= sn;
|
|
gmax = gmax > gamma ? gmax : gamma;
|
|
gmin = gmin < gamma ? gmin : gamma;
|
|
/* Computing 2nd power */
|
|
d__1 = z;
|
|
ynorm2 = d__1 * d__1 + ynorm2;
|
|
rhs1 = rhs2 - delta * z;
|
|
rhs2 = -epsln * z;
|
|
++(*itn);
|
|
goto L300;
|
|
/* ------------------------------------------------------------------
|
|
*/
|
|
/* End of main iteration loop. */
|
|
/* ------------------------------------------------------------------
|
|
*/
|
|
/* Move to the CG point if it seems better. */
|
|
/* In this version of SYMMLQ, the convergence tests involve */
|
|
/* only cgnorm, so we're unlikely to stop at an LQ point, */
|
|
/* EXCEPT if the iteration limit interferes. */
|
|
L800:
|
|
if (cgnorm <= lqnorm) {
|
|
zbar = rhs1 / diag;
|
|
bstep = snprod * zbar + bstep;
|
|
/* Computing 2nd power */
|
|
d__1 = zbar;
|
|
*ynorm = sqrt(ynorm2 + d__1 * d__1);
|
|
*rnorm = cgnorm;
|
|
chdaxpy(n, &zbar, &w[1], &c__1, &x[1], &c__1);
|
|
}
|
|
else {
|
|
*rnorm = lqnorm;
|
|
}
|
|
if (*goodb) {
|
|
/* Add the step along b. */
|
|
bstep /= beta1;
|
|
chdcopy(n, &b[1], &c__1, &y[1], &c__1);
|
|
if (*precon) {
|
|
msolve(n, &b[1], &y[1]);
|
|
}
|
|
chdaxpy(n, &bstep, &y[1], &c__1, &x[1], &c__1);
|
|
}
|
|
/* ==================================================================
|
|
*/
|
|
/* Display final status. */
|
|
/* ==================================================================
|
|
*/
|
|
L900:
|
|
/* if (nout .gt. 0) then */
|
|
/* write(nout, 2000) exit, istop, itn, */
|
|
/* $ exit, anorm, acond, */
|
|
/* $ exit, rnorm, ynorm */
|
|
/* write(nout, 3000) exit, msg(istop) */
|
|
/* end if */
|
|
return 0;
|
|
/* ------------------------------------------------------------------
|
|
*/
|
|
/* 1000 format(// 1p, a, 5x, 'Solution of symmetric Ax = b' */
|
|
/* $ / ' n =', i7, 5x, 'checka =', l4, 12x, */
|
|
/* $ 'goodb =', l4, 7x, 'precon =', l4 */
|
|
/* $ / ' itnlim =', i7, 5x, 'rtol =', e11.2, 5x, */
|
|
/* $ 'shift =', e23.14) */
|
|
/* 1100 format(/ 1p, ' beta1 =', e10.2, 3x, 'alpha1 =', e10.2 */
|
|
/* $ / ' (v1,v2) before and after ', e14.2 */
|
|
/* $ / ' local reorthogonalization', e14.2) */
|
|
/* 1200 format(// 5x, 'itn', 7x, 'x1(cg)', 10x, */
|
|
/* $ 'norm(r)', 5x, 'bstep', 7x, 'norm(A)', 3X, 'cond(A)') */
|
|
/* 1300 format(1p, i8, e19.10, e11.2, e14.5, 2e10.2) */
|
|
/* 1500 format(1x) */
|
|
/* 2000 format(/ 1p, a, 6x, 'istop =', i3, 15x, 'itn =', i8 */
|
|
/* $ / a, 6x, 'anorm =', e12.4, 6x, 'acond =', e12.4 */
|
|
/* $ / a, 6x, 'rnorm =', e12.4, 6x, 'ynorm =', e12.4) */
|
|
/* 3000 format( a, 6x, a ) */
|
|
/* ------------------------------------------------------------------
|
|
*/
|
|
/* end of SYMMLQ */
|
|
} /* symmlq_ */
|
|
|