Subroutine */ int ctest_(integer *len, doublecomplex *ccomp, doublecomplex
*ctrue, doublecomplex *csize, doublereal *sfac)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer i__;
static doublereal scomp[20], ssize[20], strue[20];
extern /* Subroutine */ int stest_(integer *, doublereal *, doublereal *,
doublereal *, doublereal *);
/* **************************** CTEST *****************************
C.L. LAWSON, JPL, 1978 DEC 6
Parameter adjustments */
--csize;
--ctrue;
--ccomp;
/* Function Body */
i__1 = *len;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
scomp[(i__ << 1) - 2] = ccomp[i__2].r;
scomp[(i__ << 1) - 1] = d_imag(&ccomp[i__]);
i__2 = i__;
strue[(i__ << 1) - 2] = ctrue[i__2].r;
strue[(i__ << 1) - 1] = d_imag(&ctrue[i__]);
i__2 = i__;
ssize[(i__ << 1) - 2] = csize[i__2].r;
ssize[(i__ << 1) - 1] = d_imag(&csize[i__]);
/* L20: */
}
i__1 = *len << 1;
stest_(&i__1, scomp, strue, ssize, sfac);
return 0;
} /* ctest_
double dcabs1_(doublecomplex *z__)
{
/* System generated locals */
double ret_val, d__1, d__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* .. Scalar Arguments .. */
/* .. */
/* .. */
/* Purpose */
/* ======= */
/* DCABS1 computes absolute value of a double complex number */
/* .. Intrinsic Functions .. */
ret_val = (d__1 = z__->r, ABS(d__1)) + (d__2 = d_imag(z__), ABS(d__2));
return ret_val;
} /* dcabs1_ */
/* Subroutine */ int zgeequ_(integer *m, integer *n, doublecomplex *a,
integer *lda, doublereal *r__, doublereal *c__, doublereal *rowcnd,
doublereal *colcnd, doublereal *amax, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
ZGEEQU computes row and column scalings intended to equilibrate an
M-by-N matrix A and reduce its condition number. R returns the row
scale factors and C the column scale factors, chosen to try to make
the largest element in each row and column of the matrix B with
elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
R(i) and C(j) are restricted to be between SMLNUM = smallest safe
number and BIGNUM = largest safe number. Use of these scaling
factors is not guaranteed to reduce the condition number of A but
works well in practice.
Arguments
=========
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) COMPLEX*16 array, dimension (LDA,N)
The M-by-N matrix whose equilibration factors are
to be computed.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
R (output) DOUBLE PRECISION array, dimension (M)
If INFO = 0 or INFO > M, R contains the row scale factors
for A.
C (output) DOUBLE PRECISION array, dimension (N)
If INFO = 0, C contains the column scale factors for A.
ROWCND (output) DOUBLE PRECISION
If INFO = 0 or INFO > M, ROWCND contains the ratio of the
smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
AMAX is neither too large nor too small, it is not worth
scaling by R.
COLCND (output) DOUBLE PRECISION
If INFO = 0, COLCND contains the ratio of the smallest
C(i) to the largest C(i). If COLCND >= 0.1, it is not
worth scaling by C.
AMAX (output) DOUBLE PRECISION
Absolute value of largest matrix element. If AMAX is very
close to overflow or very close to underflow, the matrix
should be scaled.
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
<= M: the i-th row of A is exactly zero
> M: the (i-M)-th column of A is exactly zero
=====================================================================
Test the input parameters.
Parameter adjustments */
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3, d__4;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer i__, j;
static doublereal rcmin, rcmax;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal bignum, smlnum;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--r__;
--c__;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEEQU", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
*rowcnd = 1.;
*colcnd = 1.;
*amax = 0.;
return 0;
}
/* Get machine constants. */
smlnum = dlamch_("S");
bignum = 1. / smlnum;
/* Compute row scale factors. */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
r__[i__] = 0.;
/* L10: */
}
/* Find the maximum element in each row. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = a_subscr(i__, j);
d__3 = r__[i__], d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
d_imag(&a_ref(i__, j)), abs(d__2));
r__[i__] = max(d__3,d__4);
/* L20: */
}
/* L30: */
}
/* Find the maximum and minimum scale factors. */
rcmin = bignum;
rcmax = 0.;
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = rcmax, d__2 = r__[i__];
rcmax = max(d__1,d__2);
/* Computing MIN */
d__1 = rcmin, d__2 = r__[i__];
rcmin = min(d__1,d__2);
/* L40: */
}
*amax = rcmax;
if (rcmin == 0.) {
/* Find the first zero scale factor and return an error code. */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
if (r__[i__] == 0.) {
*info = i__;
return 0;
}
/* L50: */
}
} else {
/* Invert the scale factors. */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MIN
Computing MAX */
d__2 = r__[i__];
d__1 = max(d__2,smlnum);
r__[i__] = 1. / min(d__1,bignum);
/* L60: */
}
/* Compute ROWCND = min(R(I)) / max(R(I)) */
*rowcnd = max(rcmin,smlnum) / min(rcmax,bignum);
}
/* Compute column scale factors */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
c__[j] = 0.;
/* L70: */
}
/* Find the maximum element in each column,
assuming the row scaling computed above. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = a_subscr(i__, j);
d__3 = c__[j], d__4 = ((d__1 = a[i__3].r, abs(d__1)) + (d__2 =
d_imag(&a_ref(i__, j)), abs(d__2))) * r__[i__];
c__[j] = max(d__3,d__4);
/* L80: */
}
/* L90: */
}
/* Find the maximum and minimum scale factors. */
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);
/* L100: */
}
if (rcmin == 0.) {
/* Find the first zero scale factor and return an error code. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (c__[j] == 0.) {
*info = *m + j;
return 0;
}
/* L110: */
}
} else {
/* Invert the scale factors. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN
Computing MAX */
d__2 = c__[j];
d__1 = max(d__2,smlnum);
c__[j] = 1. / min(d__1,bignum);
/* L120: */
}
/* Compute COLCND = min(C(J)) / max(C(J)) */
*colcnd = max(rcmin,smlnum) / min(rcmax,bignum);
}
return 0;
/* End of ZGEEQU */
} /* zgeequ_ */
/* Subroutine */ int zporfs_(char *uplo, integer *n, integer *nrhs,
doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf,
doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *
rwork, 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, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1;
/* Local variables */
integer i__, j, k;
doublereal s, xk;
integer nz;
doublereal eps;
integer kase;
doublereal safe1, safe2;
integer isave[3], count;
logical upper;
doublereal safmin;
doublereal lstres;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
/* Purpose */
/* ======= */
/* ZPORFS improves the computed solution to a system of linear */
/* equations when the coefficient matrix is Hermitian positive definite, */
/* and provides error bounds and backward error estimates for the */
/* solution. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* 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) COMPLEX*16 array, dimension (LDA,N) */
/* The Hermitian matrix A. If UPLO = 'U', the leading N-by-N */
/* upper triangular part of A contains the upper triangular part */
/* of the matrix A, and the strictly lower triangular part of A */
/* is not referenced. If UPLO = 'L', the leading N-by-N lower */
/* triangular part of A contains the lower triangular part of */
/* the matrix A, and the strictly upper triangular part of A is */
/* not referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* AF (input) COMPLEX*16 array, dimension (LDAF,N) */
/* The triangular factor U or L from the Cholesky factorization */
/* A = U**H*U or A = L*L**H, as computed by ZPOTRF. */
/* LDAF (input) INTEGER */
/* The leading dimension of the array AF. LDAF >= max(1,N). */
/* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS) */
/* On entry, the solution matrix X, as computed by ZPOTRS. */
/* 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) COMPLEX*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION 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 */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
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;
--rwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*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 = -9;
} else if (*ldx < max(1,*n)) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPORFS", &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.;
}
return 0;
}
/* 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 - A * X */
zcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
z__1.r = -1., z__1.i = -0.;
zhemv_(uplo, n, &z__1, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, &
c_b1, &work[1], &c__1);
/* Compute componentwise relative backward error from formula */
/* max(i) ( abs(R(i)) / ( abs(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__) {
i__3 = i__ + j * b_dim1;
rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[
i__ + j * b_dim1]), abs(d__2));
}
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
i__3 = k + j * x_dim1;
xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
x_dim1]), abs(d__2));
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + k * a_dim1;
rwork[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
d_imag(&a[i__ + k * a_dim1]), abs(d__2))) * xk;
i__4 = i__ + k * a_dim1;
i__5 = i__ + j * x_dim1;
s += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[
i__ + k * a_dim1]), abs(d__2))) * ((d__3 = x[i__5]
.r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j *
x_dim1]), abs(d__4)));
}
i__3 = k + k * a_dim1;
rwork[k] = rwork[k] + (d__1 = a[i__3].r, abs(d__1)) * xk + s;
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
i__3 = k + j * x_dim1;
xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
x_dim1]), abs(d__2));
i__3 = k + k * a_dim1;
rwork[k] += (d__1 = a[i__3].r, abs(d__1)) * xk;
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
i__4 = i__ + k * a_dim1;
rwork[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
d_imag(&a[i__ + k * a_dim1]), abs(d__2))) * xk;
i__4 = i__ + k * a_dim1;
i__5 = i__ + j * x_dim1;
s += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[
i__ + k * a_dim1]), abs(d__2))) * ((d__3 = x[i__5]
.r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j *
x_dim1]), abs(d__4)));
}
rwork[k] += s;
}
}
s = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
/* Computing MAX */
i__3 = i__;
d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2))) / rwork[i__];
s = max(d__3,d__4);
} else {
/* Computing MAX */
i__3 = i__;
d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__]
+ safe1);
s = max(d__3,d__4);
}
}
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. */
zpotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &work[1], n, info);
zaxpy_(n, &c_b1, &work[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(A))* */
/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
/* where */
/* norm(Z) is the magnitude of the largest component of Z */
/* inv(A) is the inverse of 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(A)*abs(X)+abs(B)) */
/* is incremented by SAFE1 if the i-th component of */
/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
/* Use ZLACN2 to estimate the infinity-norm of the matrix */
/* inv(A) * diag(W), */
/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
i__3 = i__;
rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
;
} else {
i__3 = i__;
rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ safe1;
}
}
kase = 0;
L100:
zlacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(A'). */
zpotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &work[1], n,
info);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
}
} else if (kase == 2) {
/* Multiply by inv(A)*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
}
zpotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &work[1], n,
info);
}
goto L100;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = i__ + j * x_dim1;
d__3 = lstres, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
d_imag(&x[i__ + j * x_dim1]), abs(d__2));
lstres = max(d__3,d__4);
}
if (lstres != 0.) {
ferr[j] /= lstres;
}
}
return 0;
/* End of ZPORFS */
} /* zporfs_ */
/* Subroutine */
int zlarfgp_(integer *n, doublecomplex *alpha, doublecomplex *x, integer *incx, doublecomplex *tau)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *), d_sign(doublereal *, doublereal *), z_abs( doublecomplex *);
/* Local variables */
integer j;
doublecomplex savealpha;
integer knt;
doublereal beta, alphi, alphr;
extern /* Subroutine */
int zscal_(integer *, doublecomplex *, doublecomplex *, integer *);
doublereal xnorm;
extern doublereal dlapy2_(doublereal *, doublereal *), dlapy3_(doublereal *, doublereal *, doublereal *), dznrm2_(integer *, doublecomplex * , integer *), dlamch_(char *);
extern /* Subroutine */
int zdscal_(integer *, doublereal *, doublecomplex *, integer *);
doublereal bignum;
extern /* Double Complex */
VOID zladiv_(doublecomplex *, doublecomplex *, doublecomplex *);
doublereal smlnum;
/* -- LAPACK auxiliary 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 .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--x;
/* Function Body */
if (*n <= 0)
{
tau->r = 0., tau->i = 0.;
return 0;
}
i__1 = *n - 1;
xnorm = dznrm2_(&i__1, &x[1], incx);
alphr = alpha->r;
alphi = d_imag(alpha);
if (xnorm == 0.)
{
/* H = [1-alpha/abs(alpha) 0;
0 I], sign chosen so ALPHA >= 0. */
if (alphi == 0.)
{
if (alphr >= 0.)
{
/* When TAU.eq.ZERO, the vector is special-cased to be */
/* all zeros in the application routines. We do not need */
/* to clear it. */
tau->r = 0., tau->i = 0.;
}
else
{
/* However, the application routines rely on explicit */
/* zero checks when TAU.ne.ZERO, and we must clear X. */
tau->r = 2., tau->i = 0.;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.;
x[i__2].i = 0.; // , expr subst
}
z__1.r = -alpha->r;
z__1.i = -alpha->i; // , expr subst
alpha->r = z__1.r, alpha->i = z__1.i;
}
}
else
{
/* Only "reflecting" the diagonal entry to be real and non-negative. */
xnorm = dlapy2_(&alphr, &alphi);
d__1 = 1. - alphr / xnorm;
d__2 = -alphi / xnorm;
z__1.r = d__1;
z__1.i = d__2; // , expr subst
tau->r = z__1.r, tau->i = z__1.i;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.;
x[i__2].i = 0.; // , expr subst
}
alpha->r = xnorm, alpha->i = 0.;
}
}
else
{
/* general case */
d__1 = dlapy3_(&alphr, &alphi, &xnorm);
beta = d_sign(&d__1, &alphr);
smlnum = dlamch_("S") / dlamch_("E");
bignum = 1. / smlnum;
knt = 0;
if (abs(beta) < smlnum)
{
/* XNORM, BETA may be inaccurate;
scale X and recompute them */
L10:
++knt;
i__1 = *n - 1;
zdscal_(&i__1, &bignum, &x[1], incx);
beta *= bignum;
alphi *= bignum;
alphr *= bignum;
if (abs(beta) < smlnum)
{
goto L10;
}
/* New BETA is at most 1, at least SMLNUM */
i__1 = *n - 1;
xnorm = dznrm2_(&i__1, &x[1], incx);
z__1.r = alphr;
z__1.i = alphi; // , expr subst
alpha->r = z__1.r, alpha->i = z__1.i;
d__1 = dlapy3_(&alphr, &alphi, &xnorm);
beta = d_sign(&d__1, &alphr);
}
savealpha.r = alpha->r;
savealpha.i = alpha->i; // , expr subst
z__1.r = alpha->r + beta;
z__1.i = alpha->i; // , expr subst
alpha->r = z__1.r, alpha->i = z__1.i;
if (beta < 0.)
{
beta = -beta;
z__2.r = -alpha->r;
z__2.i = -alpha->i; // , expr subst
z__1.r = z__2.r / beta;
z__1.i = z__2.i / beta; // , expr subst
tau->r = z__1.r, tau->i = z__1.i;
}
else
{
alphr = alphi * (alphi / alpha->r);
alphr += xnorm * (xnorm / alpha->r);
d__1 = alphr / beta;
d__2 = -alphi / beta;
z__1.r = d__1;
z__1.i = d__2; // , expr subst
tau->r = z__1.r, tau->i = z__1.i;
d__1 = -alphr;
z__1.r = d__1;
z__1.i = alphi; // , expr subst
alpha->r = z__1.r, alpha->i = z__1.i;
}
zladiv_(&z__1, &c_b5, alpha);
alpha->r = z__1.r, alpha->i = z__1.i;
if (z_abs(tau) <= smlnum)
{
/* In the case where the computed TAU ends up being a denormalized number, */
/* it loses relative accuracy. This is a BIG problem. Solution: flush TAU */
/* to ZERO (or TWO or whatever makes a nonnegative real number for BETA). */
/* (Bug report provided by Pat Quillen from MathWorks on Jul 29, 2009.) */
/* (Thanks Pat. Thanks MathWorks.) */
alphr = savealpha.r;
alphi = d_imag(&savealpha);
if (alphi == 0.)
{
if (alphr >= 0.)
{
tau->r = 0., tau->i = 0.;
}
else
{
tau->r = 2., tau->i = 0.;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.;
x[i__2].i = 0.; // , expr subst
}
z__1.r = -savealpha.r;
z__1.i = -savealpha.i; // , expr subst
beta = z__1.r;
}
}
else
{
xnorm = dlapy2_(&alphr, &alphi);
d__1 = 1. - alphr / xnorm;
d__2 = -alphi / xnorm;
z__1.r = d__1;
z__1.i = d__2; // , expr subst
tau->r = z__1.r, tau->i = z__1.i;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.;
x[i__2].i = 0.; // , expr subst
}
beta = xnorm;
}
}
else
{
/* This is the general case. */
i__1 = *n - 1;
zscal_(&i__1, alpha, &x[1], incx);
}
/* If BETA is subnormal, it may lose relative accuracy */
i__1 = knt;
for (j = 1;
j <= i__1;
++j)
{
beta *= smlnum;
/* L20: */
}
alpha->r = beta, alpha->i = 0.;
}
return 0;
/* End of ZLARFGP */
}
/* Subroutine */ int zlarfg_(integer *n, doublecomplex *alpha, doublecomplex *
x, integer *incx, doublecomplex *tau)
{
/* -- LAPACK auxiliary 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
=======
ZLARFG generates a complex elementary reflector H of order n, such
that
H' * ( alpha ) = ( beta ), H' * H = I.
( x ) ( 0 )
where alpha and beta are scalars, with beta real, and x is an
(n-1)-element complex vector. H is represented in the form
H = I - tau * ( 1 ) * ( 1 v' ) ,
( v )
where tau is a complex scalar and v is a complex (n-1)-element
vector. Note that H is not hermitian.
If the elements of x are all zero and alpha is real, then tau = 0
and H is taken to be the unit matrix.
Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 .
Arguments
=========
N (input) INTEGER
The order of the elementary reflector.
ALPHA (input/output) COMPLEX*16
On entry, the value alpha.
On exit, it is overwritten with the value beta.
X (input/output) COMPLEX*16 array, dimension
(1+(N-2)*abs(INCX))
On entry, the vector x.
On exit, it is overwritten with the vector v.
INCX (input) INTEGER
The increment between elements of X. INCX > 0.
TAU (output) COMPLEX*16
The value tau.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b5 = {1.,0.};
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *), d_sign(doublereal *, doublereal *);
/* Local variables */
static doublereal beta;
static integer j;
static doublereal alphi, alphr;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
static doublereal xnorm;
extern doublereal dlapy3_(doublereal *, doublereal *, doublereal *),
dznrm2_(integer *, doublecomplex *, integer *), dlamch_(char *);
static doublereal safmin;
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *);
static doublereal rsafmn;
extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *,
doublecomplex *);
static integer knt;
--x;
/* Function Body */
if (*n <= 0) {
tau->r = 0., tau->i = 0.;
return 0;
}
i__1 = *n - 1;
xnorm = dznrm2_(&i__1, &x[1], incx);
alphr = alpha->r;
alphi = d_imag(alpha);
if (xnorm == 0. && alphi == 0.) {
/* H = I */
tau->r = 0., tau->i = 0.;
} else {
/* general case */
d__1 = dlapy3_(&alphr, &alphi, &xnorm);
beta = -d_sign(&d__1, &alphr);
safmin = dlamch_("S") / dlamch_("E");
rsafmn = 1. / safmin;
if (abs(beta) < safmin) {
/* XNORM, BETA may be inaccurate; scale X and recompute them */
knt = 0;
L10:
++knt;
i__1 = *n - 1;
zdscal_(&i__1, &rsafmn, &x[1], incx);
beta *= rsafmn;
alphi *= rsafmn;
alphr *= rsafmn;
if (abs(beta) < safmin) {
goto L10;
}
/* New BETA is at most 1, at least SAFMIN */
i__1 = *n - 1;
xnorm = dznrm2_(&i__1, &x[1], incx);
z__1.r = alphr, z__1.i = alphi;
alpha->r = z__1.r, alpha->i = z__1.i;
d__1 = dlapy3_(&alphr, &alphi, &xnorm);
beta = -d_sign(&d__1, &alphr);
d__1 = (beta - alphr) / beta;
d__2 = -alphi / beta;
z__1.r = d__1, z__1.i = d__2;
tau->r = z__1.r, tau->i = z__1.i;
z__2.r = alpha->r - beta, z__2.i = alpha->i;
zladiv_(&z__1, &c_b5, &z__2);
alpha->r = z__1.r, alpha->i = z__1.i;
i__1 = *n - 1;
zscal_(&i__1, alpha, &x[1], incx);
/* If ALPHA is subnormal, it may lose relative accuracy */
alpha->r = beta, alpha->i = 0.;
i__1 = knt;
for (j = 1; j <= i__1; ++j) {
z__1.r = safmin * alpha->r, z__1.i = safmin * alpha->i;
alpha->r = z__1.r, alpha->i = z__1.i;
/* L20: */
}
} else {
d__1 = (beta - alphr) / beta;
d__2 = -alphi / beta;
z__1.r = d__1, z__1.i = d__2;
tau->r = z__1.r, tau->i = z__1.i;
z__2.r = alpha->r - beta, z__2.i = alpha->i;
zladiv_(&z__1, &c_b5, &z__2);
alpha->r = z__1.r, alpha->i = z__1.i;
i__1 = *n - 1;
zscal_(&i__1, alpha, &x[1], incx);
alpha->r = beta, alpha->i = 0.;
}
}
return 0;
/* End of ZLARFG */
} /* zlarfg_ */
/* Subroutine */ int zchkbk_(integer *nin, integer *nout)
{
/* Format strings */
static char fmt_9999[] = "(1x,\002.. test output of ZGEBAK .. \002)";
static char fmt_9998[] = "(1x,\002value of largest test error "
" = \002,d12.3)";
static char fmt_9997[] = "(1x,\002example number where info is not zero "
" = \002,i4)";
static char fmt_9996[] = "(1x,\002example number having largest error "
" = \002,i4)";
static char fmt_9995[] = "(1x,\002number of examples where info is not 0"
" = \002,i4)";
static char fmt_9994[] = "(1x,\002total number of examples tested "
" = \002,i4)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2;
/* Builtin functions */
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
double d_imag(doublecomplex *);
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
/* Local variables */
static integer info, lmax[2];
static doublereal rmax, vmax;
static doublecomplex e[400] /* was [20][20] */;
static integer i__, j, n;
static doublereal scale[20], x;
static integer ninfo;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int zgebak_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublecomplex *, integer *,
integer *);
static doublereal safmin;
static integer ihi;
static doublecomplex ein[400] /* was [20][20] */;
static integer ilo;
static doublereal eps;
static integer knt;
/* Fortran I/O blocks */
static cilist io___7 = { 0, 0, 0, 0, 0 };
static cilist io___11 = { 0, 0, 0, 0, 0 };
static cilist io___14 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___24 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___25 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___26 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___27 = { 0, 0, 0, fmt_9994, 0 };
#define e_subscr(a_1,a_2) (a_2)*20 + a_1 - 21
#define e_ref(a_1,a_2) e[e_subscr(a_1,a_2)]
#define ein_subscr(a_1,a_2) (a_2)*20 + a_1 - 21
#define ein_ref(a_1,a_2) ein[ein_subscr(a_1,a_2)]
/* -- LAPACK test 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
=======
ZCHKBK tests ZGEBAK, a routine for backward transformation of
the computed right or left eigenvectors if the orginal matrix
was preprocessed by balance subroutine ZGEBAL.
Arguments
=========
NIN (input) INTEGER
The logical unit number for input. NIN > 0.
NOUT (input) INTEGER
The logical unit number for output. NOUT > 0.
====================================================================== */
lmax[0] = 0;
lmax[1] = 0;
ninfo = 0;
knt = 0;
rmax = 0.;
eps = dlamch_("E");
safmin = dlamch_("S");
L10:
io___7.ciunit = *nin;
s_rsle(&io___7);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ilo, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ihi, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
goto L60;
}
io___11.ciunit = *nin;
s_rsle(&io___11);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__5, &c__1, (char *)&scale[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_rsle();
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___14.ciunit = *nin;
s_rsle(&io___14);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&e_ref(i__, j), (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___17.ciunit = *nin;
s_rsle(&io___17);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&ein_ref(i__, j), (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L30: */
}
++knt;
zgebak_("B", "R", &n, &ilo, &ihi, scale, &n, e, &c__20, &info);
if (info != 0) {
++ninfo;
lmax[0] = knt;
}
vmax = 0.;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = e_subscr(i__, j);
i__4 = ein_subscr(i__, j);
z__2.r = e[i__3].r - ein[i__4].r, z__2.i = e[i__3].i - ein[i__4]
.i;
z__1.r = z__2.r, z__1.i = z__2.i;
x = ((d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), abs(d__2)
)) / eps;
i__3 = e_subscr(i__, j);
if ((d__1 = e[i__3].r, abs(d__1)) + (d__2 = d_imag(&e_ref(i__, j))
, abs(d__2)) > safmin) {
i__4 = e_subscr(i__, j);
x /= (d__3 = e[i__4].r, abs(d__3)) + (d__4 = d_imag(&e_ref(
i__, j)), abs(d__4));
}
vmax = max(vmax,x);
/* L40: */
}
/* L50: */
}
if (vmax > rmax) {
lmax[1] = knt;
rmax = vmax;
}
goto L10;
L60:
io___22.ciunit = *nout;
s_wsfe(&io___22);
e_wsfe();
io___23.ciunit = *nout;
s_wsfe(&io___23);
do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
e_wsfe();
io___24.ciunit = *nout;
s_wsfe(&io___24);
do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
e_wsfe();
io___25.ciunit = *nout;
s_wsfe(&io___25);
do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
e_wsfe();
io___26.ciunit = *nout;
s_wsfe(&io___26);
do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
e_wsfe();
io___27.ciunit = *nout;
s_wsfe(&io___27);
do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
e_wsfe();
return 0;
/* End of ZCHKBK */
} /* zchkbk_ */
/* Subroutine */ int zsyequb_(char *uplo, integer *n, doublecomplex *a,
integer *lda, doublereal *s, doublereal *scond, doublereal *amax,
doublecomplex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double d_imag(doublecomplex *), sqrt(doublereal), log(doublereal), pow_di(
doublereal *, integer *);
/* Local variables */
doublereal d__;
integer i__, j;
doublereal t, u, c0, c1, c2, si;
logical up;
doublereal avg, std, tol, base;
integer iter;
doublereal smin, smax, scale;
extern logical lsame_(char *, char *);
doublereal sumsq;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal bignum, smlnum;
extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
doublereal *, doublereal *);
/* -- LAPACK 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. -- */
/* .. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZSYEQUB computes row and column scalings intended to equilibrate a */
/* symmetric matrix A and reduce its condition number */
/* (with respect to the two-norm). S contains the scale factors, */
/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */
/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */
/* choice of S puts the condition number of B within a factor N of the */
/* smallest possible condition number over all possible diagonal */
/* scalings. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The N-by-N symmetric matrix whose scaling */
/* factors are to be computed. Only the diagonal elements of A */
/* are referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* S (output) DOUBLE PRECISION array, dimension (N) */
/* If INFO = 0, S contains the scale factors for A. */
/* SCOND (output) DOUBLE PRECISION */
/* If INFO = 0, S contains the ratio of the smallest S(i) to */
/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
/* large nor too small, it is not worth scaling by S. */
/* AMAX (output) DOUBLE PRECISION */
/* Absolute value of largest matrix element. If AMAX is very */
/* close to overflow or very close to underflow, the matrix */
/* should be scaled. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
/* Further Details */
/* ======= ======= */
/* Reference: Livne, O.E. and Golub, G.H., "Scaling by Binormalization", */
/* Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004. */
/* DOI 10.1023/B:NUMA.0000016606.32820.69 */
/* Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* Statement Function Definitions */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--s;
--work;
/* Function Body */
*info = 0;
if (! (lsame_(uplo, "U") || lsame_(uplo, "L"))) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZSYEQUB", &i__1);
return 0;
}
up = lsame_(uplo, "U");
*amax = 0.;
/* Quick return if possible. */
if (*n == 0) {
*scond = 1.;
return 0;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
s[i__] = 0.;
}
*amax = 0.;
if (up) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = i__ + j * a_dim1;
d__3 = s[i__], d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
d_imag(&a[i__ + j * a_dim1]), abs(d__2));
s[i__] = max(d__3,d__4);
/* Computing MAX */
i__3 = i__ + j * a_dim1;
d__3 = s[j], d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
d_imag(&a[i__ + j * a_dim1]), abs(d__2));
s[j] = max(d__3,d__4);
/* Computing MAX */
i__3 = i__ + j * a_dim1;
d__3 = *amax, d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
d_imag(&a[i__ + j * a_dim1]), abs(d__2));
*amax = max(d__3,d__4);
}
/* Computing MAX */
i__2 = j + j * a_dim1;
d__3 = s[j], d__4 = (d__1 = a[i__2].r, abs(d__1)) + (d__2 =
d_imag(&a[j + j * a_dim1]), abs(d__2));
s[j] = max(d__3,d__4);
/* Computing MAX */
i__2 = j + j * a_dim1;
d__3 = *amax, d__4 = (d__1 = a[i__2].r, abs(d__1)) + (d__2 =
d_imag(&a[j + j * a_dim1]), abs(d__2));
*amax = max(d__3,d__4);
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = j + j * a_dim1;
d__3 = s[j], d__4 = (d__1 = a[i__2].r, abs(d__1)) + (d__2 =
d_imag(&a[j + j * a_dim1]), abs(d__2));
s[j] = max(d__3,d__4);
/* Computing MAX */
i__2 = j + j * a_dim1;
d__3 = *amax, d__4 = (d__1 = a[i__2].r, abs(d__1)) + (d__2 =
d_imag(&a[j + j * a_dim1]), abs(d__2));
*amax = max(d__3,d__4);
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = i__ + j * a_dim1;
d__3 = s[i__], d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
d_imag(&a[i__ + j * a_dim1]), abs(d__2));
s[i__] = max(d__3,d__4);
/* Computing MAX */
i__3 = i__ + j * a_dim1;
d__3 = s[j], d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
d_imag(&a[i__ + j * a_dim1]), abs(d__2));
s[j] = max(d__3,d__4);
/* Computing MAX */
i__3 = i__ + j * a_dim1;
d__3 = *amax, d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
d_imag(&a[i__ + j * a_dim1]), abs(d__2));
*amax = max(d__3,d__4);
}
}
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
s[j] = 1. / s[j];
}
tol = 1. / sqrt(*n * 2.);
for (iter = 1; iter <= 100; ++iter) {
scale = 0.;
sumsq = 0.;
/* beta = |A|s */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
work[i__2].r = 0., work[i__2].i = 0.;
}
if (up) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__
+ j * a_dim1]), abs(d__2));
i__3 = i__;
i__4 = i__;
i__5 = i__ + j * a_dim1;
d__3 = ((d__1 = a[i__5].r, abs(d__1)) + (d__2 = d_imag(&a[
i__ + j * a_dim1]), abs(d__2))) * s[j];
z__1.r = work[i__4].r + d__3, z__1.i = work[i__4].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
i__3 = j;
i__4 = j;
i__5 = i__ + j * a_dim1;
d__3 = ((d__1 = a[i__5].r, abs(d__1)) + (d__2 = d_imag(&a[
i__ + j * a_dim1]), abs(d__2))) * s[i__];
z__1.r = work[i__4].r + d__3, z__1.i = work[i__4].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
}
i__2 = j;
i__3 = j;
i__4 = j + j * a_dim1;
d__3 = ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[j +
j * a_dim1]), abs(d__2))) * s[j];
z__1.r = work[i__3].r + d__3, z__1.i = work[i__3].i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
i__3 = j;
i__4 = j + j * a_dim1;
d__3 = ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[j +
j * a_dim1]), abs(d__2))) * s[j];
z__1.r = work[i__3].r + d__3, z__1.i = work[i__3].i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__
+ j * a_dim1]), abs(d__2));
i__3 = i__;
i__4 = i__;
i__5 = i__ + j * a_dim1;
d__3 = ((d__1 = a[i__5].r, abs(d__1)) + (d__2 = d_imag(&a[
i__ + j * a_dim1]), abs(d__2))) * s[j];
z__1.r = work[i__4].r + d__3, z__1.i = work[i__4].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
i__3 = j;
i__4 = j;
i__5 = i__ + j * a_dim1;
d__3 = ((d__1 = a[i__5].r, abs(d__1)) + (d__2 = d_imag(&a[
i__ + j * a_dim1]), abs(d__2))) * s[i__];
z__1.r = work[i__4].r + d__3, z__1.i = work[i__4].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
}
}
}
/* avg = s^T beta / n */
avg = 0.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__;
z__2.r = s[i__2] * work[i__3].r, z__2.i = s[i__2] * work[i__3].i;
z__1.r = avg + z__2.r, z__1.i = z__2.i;
avg = z__1.r;
}
avg /= *n;
std = 0.;
i__1 = *n << 1;
for (i__ = *n + 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__ - *n;
i__4 = i__ - *n;
z__2.r = s[i__3] * work[i__4].r, z__2.i = s[i__3] * work[i__4].i;
z__1.r = z__2.r - avg, z__1.i = z__2.i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
}
zlassq_(n, &work[*n + 1], &c__1, &scale, &sumsq);
std = scale * sqrt(sumsq / *n);
if (std < tol * avg) {
goto L999;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + i__ * a_dim1;
t = (d__1 = a[i__2].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + i__ *
a_dim1]), abs(d__2));
si = s[i__];
c2 = (*n - 1) * t;
i__2 = *n - 2;
i__3 = i__;
d__1 = t * si;
z__2.r = work[i__3].r - d__1, z__2.i = work[i__3].i;
d__2 = (doublereal) i__2;
z__1.r = d__2 * z__2.r, z__1.i = d__2 * z__2.i;
c1 = z__1.r;
d__1 = -(t * si) * si;
i__2 = i__;
d__2 = 2.;
z__4.r = d__2 * work[i__2].r, z__4.i = d__2 * work[i__2].i;
z__3.r = si * z__4.r, z__3.i = si * z__4.i;
z__2.r = d__1 + z__3.r, z__2.i = z__3.i;
d__3 = *n * avg;
z__1.r = z__2.r - d__3, z__1.i = z__2.i;
c0 = z__1.r;
d__ = c1 * c1 - c0 * 4 * c2;
if (d__ <= 0.) {
*info = -1;
return 0;
}
si = c0 * -2 / (c1 + sqrt(d__));
d__ = si - s[i__];
u = 0.;
if (up) {
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
i__3 = j + i__ * a_dim1;
t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[j +
i__ * a_dim1]), abs(d__2));
u += s[j] * t;
i__3 = j;
i__4 = j;
d__1 = d__ * t;
z__1.r = work[i__4].r + d__1, z__1.i = work[i__4].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
}
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = i__ + j * a_dim1;
t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__
+ j * a_dim1]), abs(d__2));
u += s[j] * t;
i__3 = j;
i__4 = j;
d__1 = d__ * t;
z__1.r = work[i__4].r + d__1, z__1.i = work[i__4].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
}
} else {
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
i__3 = i__ + j * a_dim1;
t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__
+ j * a_dim1]), abs(d__2));
u += s[j] * t;
i__3 = j;
i__4 = j;
d__1 = d__ * t;
z__1.r = work[i__4].r + d__1, z__1.i = work[i__4].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
}
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = j + i__ * a_dim1;
t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[j +
i__ * a_dim1]), abs(d__2));
u += s[j] * t;
i__3 = j;
i__4 = j;
d__1 = d__ * t;
z__1.r = work[i__4].r + d__1, z__1.i = work[i__4].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
}
}
i__2 = i__;
z__4.r = u + work[i__2].r, z__4.i = work[i__2].i;
z__3.r = d__ * z__4.r, z__3.i = d__ * z__4.i;
d__1 = (doublereal) (*n);
z__2.r = z__3.r / d__1, z__2.i = z__3.i / d__1;
z__1.r = avg + z__2.r, z__1.i = z__2.i;
avg = z__1.r;
s[i__] = si;
}
}
L999:
smlnum = dlamch_("SAFEMIN");
bignum = 1. / smlnum;
smin = bignum;
smax = 0.;
t = 1. / sqrt(avg);
base = dlamch_("B");
u = 1. / log(base);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = (integer) (u * log(s[i__] * t));
s[i__] = pow_di(&base, &i__2);
/* Computing MIN */
d__1 = smin, d__2 = s[i__];
smin = min(d__1,d__2);
/* Computing MAX */
d__1 = smax, d__2 = s[i__];
smax = max(d__1,d__2);
}
*scond = max(smin,smlnum) / min(smax,bignum);
return 0;
} /* zsyequb_ */
doublereal zla_hercond_x__(char *uplo, integer *n, doublecomplex *a, integer *
lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublecomplex *
x, integer *info, doublecomplex *work, doublereal *rwork, ftnlen
uplo_len)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4;
doublereal ret_val, d__1, d__2;
doublecomplex z__1, z__2;
/* Local variables */
integer i__, j;
logical up;
doublereal tmp;
integer kase;
integer isave[3];
doublereal anorm;
doublereal ainvnm;
/* -- 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. -- */
/* Purpose */
/* ======= */
/* ZLA_HERCOND_X computes the infinity norm condition number of */
/* op(A) * diag(X) where X is a COMPLEX*16 vector. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* A (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDAF,N) */
/* The block diagonal matrix D and the multipliers used to */
/* obtain the factor U or L as computed by ZHETRF. */
/* LDAF (input) INTEGER */
/* The leading dimension of the array AF. LDAF >= max(1,N). */
/* IPIV (input) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D */
/* as determined by CHETRF. */
/* X (input) COMPLEX*16 array, dimension (N) */
/* The vector X in the formula op(A) * diag(X). */
/* INFO (output) INTEGER */
/* = 0: Successful exit. */
/* i > 0: The ith argument is invalid. */
/* WORK (input) COMPLEX*16 array, dimension (2*N). */
/* Workspace. */
/* RWORK (input) DOUBLE PRECISION array, dimension (N). */
/* Workspace. */
/* ===================================================================== */
/* 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;
--x;
--work;
--rwork;
/* Function Body */
ret_val = 0.;
*info = 0;
if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZLA_HERCOND_X", &i__1);
return ret_val;
}
up = FALSE_;
if (lsame_(uplo, "U")) {
up = TRUE_;
}
/* Compute norm of op(A)*op2(C). */
anorm = 0.;
if (up) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
tmp = 0.;
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
i__3 = j + i__ * a_dim1;
i__4 = j;
z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
.r;
z__1.r = z__2.r, z__1.i = z__2.i;
tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
abs(d__2));
}
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = i__ + j * a_dim1;
i__4 = j;
z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
.r;
z__1.r = z__2.r, z__1.i = z__2.i;
tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
abs(d__2));
}
rwork[i__] = tmp;
anorm = max(anorm,tmp);
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
tmp = 0.;
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
i__3 = i__ + j * a_dim1;
i__4 = j;
z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
.r;
z__1.r = z__2.r, z__1.i = z__2.i;
tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
abs(d__2));
}
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = j + i__ * a_dim1;
i__4 = j;
z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
.r;
z__1.r = z__2.r, z__1.i = z__2.i;
tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
abs(d__2));
}
rwork[i__] = tmp;
anorm = max(anorm,tmp);
}
}
/* Quick return if possible. */
if (*n == 0) {
ret_val = 1.;
return ret_val;
} else if (anorm == 0.) {
return ret_val;
}
/* Estimate the norm of inv(op(A)). */
ainvnm = 0.;
kase = 0;
L10:
zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
if (kase != 0) {
if (kase == 2) {
/* Multiply by R. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__;
i__4 = i__;
z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] *
work[i__3].i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
}
if (up) {
zhetrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
1], n, info);
} else {
zhetrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
1], n, info);
}
/* Multiply by inv(X). */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
z_div(&z__1, &work[i__], &x[i__]);
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
}
} else {
/* Multiply by inv(X'). */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
z_div(&z__1, &work[i__], &x[i__]);
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
}
if (up) {
zhetrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
1], n, info);
} else {
zhetrs_("L", 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__) {
i__2 = i__;
i__3 = i__;
i__4 = i__;
z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] *
work[i__3].i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
}
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) {
ret_val = 1. / ainvnm;
}
return ret_val;
} /* zla_hercond_x__ */
/* Subroutine */
int zgtsv_(integer *n, integer *nrhs, doublecomplex *dl, doublecomplex *d__, doublecomplex *du, doublecomplex *b, integer *ldb, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4, z__5;
/* Builtin functions */
double d_imag(doublecomplex *);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
integer j, k;
doublecomplex temp, mult;
extern /* Subroutine */
int xerbla_(char *, integer *);
/* -- LAPACK driver 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 .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--dl;
--d__;
--du;
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 (*ldb < max(1,*n))
{
*info = -7;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZGTSV ", &i__1);
return 0;
}
if (*n == 0)
{
return 0;
}
i__1 = *n - 1;
for (k = 1;
k <= i__1;
++k)
{
i__2 = k;
if (dl[i__2].r == 0. && dl[i__2].i == 0.)
{
/* Subdiagonal is zero, no elimination is required. */
i__2 = k;
if (d__[i__2].r == 0. && d__[i__2].i == 0.)
{
/* Diagonal is zero: set INFO = K and return;
a unique */
/* solution can not be found. */
*info = k;
return 0;
}
}
else /* if(complicated condition) */
{
i__2 = k;
i__3 = k;
if ((d__1 = d__[i__2].r, f2c_abs(d__1)) + (d__2 = d_imag(&d__[k]), f2c_abs(d__2)) >= (d__3 = dl[i__3].r, f2c_abs(d__3)) + (d__4 = d_imag(&dl[k]), f2c_abs(d__4)))
{
/* No row interchange required */
z_div(&z__1, &dl[k], &d__[k]);
mult.r = z__1.r;
mult.i = z__1.i; // , expr subst
i__2 = k + 1;
i__3 = k + 1;
i__4 = k;
z__2.r = mult.r * du[i__4].r - mult.i * du[i__4].i;
z__2.i = mult.r * du[i__4].i + mult.i * du[i__4].r; // , expr subst
z__1.r = d__[i__3].r - z__2.r;
z__1.i = d__[i__3].i - z__2.i; // , expr subst
d__[i__2].r = z__1.r;
d__[i__2].i = z__1.i; // , expr subst
i__2 = *nrhs;
for (j = 1;
j <= i__2;
++j)
{
i__3 = k + 1 + j * b_dim1;
i__4 = k + 1 + j * b_dim1;
i__5 = k + j * b_dim1;
z__2.r = mult.r * b[i__5].r - mult.i * b[i__5].i;
z__2.i = mult.r * b[i__5].i + mult.i * b[i__5].r; // , expr subst
z__1.r = b[i__4].r - z__2.r;
z__1.i = b[i__4].i - z__2.i; // , expr subst
b[i__3].r = z__1.r;
b[i__3].i = z__1.i; // , expr subst
/* L10: */
}
if (k < *n - 1)
{
i__2 = k;
dl[i__2].r = 0.;
dl[i__2].i = 0.; // , expr subst
}
}
else
{
/* Interchange rows K and K+1 */
z_div(&z__1, &d__[k], &dl[k]);
mult.r = z__1.r;
mult.i = z__1.i; // , expr subst
i__2 = k;
i__3 = k;
d__[i__2].r = dl[i__3].r;
d__[i__2].i = dl[i__3].i; // , expr subst
i__2 = k + 1;
temp.r = d__[i__2].r;
temp.i = d__[i__2].i; // , expr subst
i__2 = k + 1;
i__3 = k;
z__2.r = mult.r * temp.r - mult.i * temp.i;
z__2.i = mult.r * temp.i + mult.i * temp.r; // , expr subst
z__1.r = du[i__3].r - z__2.r;
z__1.i = du[i__3].i - z__2.i; // , expr subst
d__[i__2].r = z__1.r;
d__[i__2].i = z__1.i; // , expr subst
if (k < *n - 1)
{
i__2 = k;
i__3 = k + 1;
dl[i__2].r = du[i__3].r;
dl[i__2].i = du[i__3].i; // , expr subst
i__2 = k + 1;
z__2.r = -mult.r;
z__2.i = -mult.i; // , expr subst
i__3 = k;
z__1.r = z__2.r * dl[i__3].r - z__2.i * dl[i__3].i;
z__1.i = z__2.r * dl[i__3].i + z__2.i * dl[i__3] .r; // , expr subst
du[i__2].r = z__1.r;
du[i__2].i = z__1.i; // , expr subst
}
i__2 = k;
du[i__2].r = temp.r;
du[i__2].i = temp.i; // , expr subst
i__2 = *nrhs;
for (j = 1;
j <= i__2;
++j)
{
i__3 = k + j * b_dim1;
temp.r = b[i__3].r;
temp.i = b[i__3].i; // , expr subst
i__3 = k + j * b_dim1;
i__4 = k + 1 + j * b_dim1;
b[i__3].r = b[i__4].r;
b[i__3].i = b[i__4].i; // , expr subst
i__3 = k + 1 + j * b_dim1;
i__4 = k + 1 + j * b_dim1;
z__2.r = mult.r * b[i__4].r - mult.i * b[i__4].i;
z__2.i = mult.r * b[i__4].i + mult.i * b[i__4].r; // , expr subst
z__1.r = temp.r - z__2.r;
z__1.i = temp.i - z__2.i; // , expr subst
b[i__3].r = z__1.r;
b[i__3].i = z__1.i; // , expr subst
/* L20: */
}
}
}
/* L30: */
}
i__1 = *n;
if (d__[i__1].r == 0. && d__[i__1].i == 0.)
{
*info = *n;
return 0;
}
/* Back solve with the matrix U from the factorization. */
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n + j * b_dim1;
z_div(&z__1, &b[*n + j * b_dim1], &d__[*n]);
b[i__2].r = z__1.r;
b[i__2].i = z__1.i; // , expr subst
if (*n > 1)
{
i__2 = *n - 1 + j * b_dim1;
i__3 = *n - 1 + j * b_dim1;
i__4 = *n - 1;
i__5 = *n + j * b_dim1;
z__3.r = du[i__4].r * b[i__5].r - du[i__4].i * b[i__5].i;
z__3.i = du[i__4].r * b[i__5].i + du[i__4].i * b[i__5].r; // , expr subst
z__2.r = b[i__3].r - z__3.r;
z__2.i = b[i__3].i - z__3.i; // , expr subst
z_div(&z__1, &z__2, &d__[*n - 1]);
b[i__2].r = z__1.r;
b[i__2].i = z__1.i; // , expr subst
}
for (k = *n - 2;
k >= 1;
--k)
{
i__2 = k + j * b_dim1;
i__3 = k + j * b_dim1;
i__4 = k;
i__5 = k + 1 + j * b_dim1;
z__4.r = du[i__4].r * b[i__5].r - du[i__4].i * b[i__5].i;
z__4.i = du[i__4].r * b[i__5].i + du[i__4].i * b[i__5].r; // , expr subst
z__3.r = b[i__3].r - z__4.r;
z__3.i = b[i__3].i - z__4.i; // , expr subst
i__6 = k;
i__7 = k + 2 + j * b_dim1;
z__5.r = dl[i__6].r * b[i__7].r - dl[i__6].i * b[i__7].i;
z__5.i = dl[i__6].r * b[i__7].i + dl[i__6].i * b[i__7].r; // , expr subst
z__2.r = z__3.r - z__5.r;
z__2.i = z__3.i - z__5.i; // , expr subst
z_div(&z__1, &z__2, &d__[k]);
b[i__2].r = z__1.r;
b[i__2].i = z__1.i; // , expr subst
/* L40: */
}
/* L50: */
}
return 0;
/* End of ZGTSV */
}
/* Subroutine */ int zgbrfs_(char *trans, integer *n, integer *kl, integer *
ku, integer *nrhs, doublecomplex *ab, integer *ldab, doublecomplex *
afb, integer *ldafb, integer *ipiv, doublecomplex *b, integer *ldb,
doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr,
doublecomplex *work, doublereal *rwork, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
integer i__, j, k;
doublereal s;
integer kk;
doublereal xk;
integer nz;
doublereal eps;
integer kase;
doublereal safe1, safe2;
extern logical lsame_(char *, char *);
integer isave[3];
extern /* Subroutine */ int zgbmv_(char *, integer *, integer *, integer *
, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
integer count;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *), zlacn2_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *, integer *);
extern doublereal dlamch_(char *);
doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
logical notran;
char transn[1], transt[1];
doublereal lstres;
extern /* Subroutine */ int zgbtrs_(char *, integer *, integer *, integer
*, integer *, doublecomplex *, integer *, integer *,
doublecomplex *, integer *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGBRFS improves the computed solution to a system of linear */
/* equations when the coefficient matrix is banded, 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) */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* KL (input) INTEGER */
/* The number of subdiagonals within the band of A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of superdiagonals within the band of A. KU >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
/* The original band matrix A, stored in rows 1 to KL+KU+1. */
/* The j-th column of A is stored in the j-th column of the */
/* array AB as follows: */
/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
/* AFB (input) COMPLEX*16 array, dimension (LDAFB,N) */
/* Details of the LU factorization of the band matrix A, as */
/* computed by ZGBTRF. U is stored as an upper triangular band */
/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
/* the multipliers used during the factorization are stored in */
/* rows KL+KU+2 to 2*KL+KU+1. */
/* LDAFB (input) INTEGER */
/* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices from ZGBTRF; for 1<=i<=N, row i of the */
/* matrix was interchanged with row IPIV(i). */
/* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS) */
/* On entry, the solution matrix X, as computed by ZGBTRS. */
/* 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) COMPLEX*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION 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 .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
afb_dim1 = *ldafb;
afb_offset = 1 + afb_dim1;
afb -= afb_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;
--rwork;
/* 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 (*kl < 0) {
*info = -3;
} else if (*ku < 0) {
*info = -4;
} else if (*nrhs < 0) {
*info = -5;
} else if (*ldab < *kl + *ku + 1) {
*info = -7;
} else if (*ldafb < (*kl << 1) + *ku + 1) {
*info = -9;
} else if (*ldb < max(1,*n)) {
*info = -12;
} else if (*ldx < max(1,*n)) {
*info = -14;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGBRFS", &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 *)transn = 'N';
*(unsigned char *)transt = 'C';
} else {
*(unsigned char *)transn = 'C';
*(unsigned char *)transt = 'N';
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
/* Computing MIN */
i__1 = *kl + *ku + 2, i__2 = *n + 1;
nz = min(i__1,i__2);
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. */
zcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
z__1.r = -1., z__1.i = -0.;
zgbmv_(trans, n, n, kl, ku, &z__1, &ab[ab_offset], ldab, &x[j *
x_dim1 + 1], &c__1, &c_b1, &work[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__) {
i__3 = i__ + j * b_dim1;
rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[
i__ + j * b_dim1]), abs(d__2));
/* L30: */
}
/* Compute abs(op(A))*abs(X) + abs(B). */
if (notran) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
kk = *ku + 1 - k;
i__3 = k + j * x_dim1;
xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
x_dim1]), abs(d__2));
/* Computing MAX */
i__3 = 1, i__4 = k - *ku;
/* Computing MIN */
i__6 = *n, i__7 = k + *kl;
i__5 = min(i__6,i__7);
for (i__ = max(i__3,i__4); i__ <= i__5; ++i__) {
i__3 = kk + i__ + k * ab_dim1;
rwork[i__] += ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 =
d_imag(&ab[kk + i__ + k * ab_dim1]), abs(d__2))) *
xk;
/* L40: */
}
/* L50: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
kk = *ku + 1 - k;
/* Computing MAX */
i__5 = 1, i__3 = k - *ku;
/* Computing MIN */
i__6 = *n, i__7 = k + *kl;
i__4 = min(i__6,i__7);
for (i__ = max(i__5,i__3); i__ <= i__4; ++i__) {
i__5 = kk + i__ + k * ab_dim1;
i__3 = i__ + j * x_dim1;
s += ((d__1 = ab[i__5].r, abs(d__1)) + (d__2 = d_imag(&ab[
kk + i__ + k * ab_dim1]), abs(d__2))) * ((d__3 =
x[i__3].r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j
* x_dim1]), abs(d__4)));
/* L60: */
}
rwork[k] += s;
/* L70: */
}
}
s = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
/* Computing MAX */
i__4 = i__;
d__3 = s, d__4 = ((d__1 = work[i__4].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2))) / rwork[i__];
s = max(d__3,d__4);
} else {
/* Computing MAX */
i__4 = i__;
d__3 = s, d__4 = ((d__1 = work[i__4].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__]
+ safe1);
s = max(d__3,d__4);
}
/* 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. */
zgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &ipiv[1]
, &work[1], n, info);
zaxpy_(n, &c_b1, &work[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 ZLACN2 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 (rwork[i__] > safe2) {
i__4 = i__;
rwork[i__] = (d__1 = work[i__4].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
;
} else {
i__4 = i__;
rwork[i__] = (d__1 = work[i__4].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ safe1;
}
/* L90: */
}
kase = 0;
L100:
zlacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)**H). */
zgbtrs_(transt, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &
ipiv[1], &work[1], n, info);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__4 = i__;
i__5 = i__;
i__3 = i__;
z__1.r = rwork[i__5] * work[i__3].r, z__1.i = rwork[i__5]
* work[i__3].i;
work[i__4].r = z__1.r, work[i__4].i = z__1.i;
/* L110: */
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__4 = i__;
i__5 = i__;
i__3 = i__;
z__1.r = rwork[i__5] * work[i__3].r, z__1.i = rwork[i__5]
* work[i__3].i;
work[i__4].r = z__1.r, work[i__4].i = z__1.i;
/* L120: */
}
zgbtrs_(transn, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &
ipiv[1], &work[1], n, info);
}
goto L100;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__4 = i__ + j * x_dim1;
d__3 = lstres, d__4 = (d__1 = x[i__4].r, abs(d__1)) + (d__2 =
d_imag(&x[i__ + j * x_dim1]), abs(d__2));
lstres = max(d__3,d__4);
/* L130: */
}
if (lstres != 0.) {
ferr[j] /= lstres;
}
/* L140: */
}
return 0;
/* End of ZGBRFS */
} /* zgbrfs_ */
/* Subroutine */ int zlacn2_(integer *n, doublecomplex *v, doublecomplex *x,
doublereal *est, integer *kase, integer *isave)
{
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1, d__2;
doublecomplex z__1;
/* Builtin functions */
double z_abs(doublecomplex *), d_imag(doublecomplex *);
/* Local variables */
integer i__;
doublereal temp, absxi;
integer jlast;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern integer izmax1_(integer *, doublecomplex *, integer *);
extern doublereal dzsum1_(integer *, doublecomplex *, integer *), dlamch_(
char *);
doublereal safmin, altsgn, estold;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLACN2 estimates the 1-norm of a square, complex matrix A. */
/* Reverse communication is used for evaluating matrix-vector products. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix. N >= 1. */
/* V (workspace) COMPLEX*16 array, dimension (N) */
/* On the final return, V = A*W, where EST = norm(V)/norm(W) */
/* (W is not returned). */
/* X (input/output) COMPLEX*16 array, dimension (N) */
/* On an intermediate return, X should be overwritten by */
/* A * X, if KASE=1, */
/* A' * X, if KASE=2, */
/* where A' is the conjugate transpose of A, and ZLACN2 must be */
/* re-called with all the other parameters unchanged. */
/* EST (input/output) DOUBLE PRECISION */
/* On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be */
/* unchanged from the previous call to ZLACN2. */
/* On exit, EST is an estimate (a lower bound) for norm(A). */
/* KASE (input/output) INTEGER */
/* On the initial call to ZLACN2, KASE should be 0. */
/* On an intermediate return, KASE will be 1 or 2, indicating */
/* whether X should be overwritten by A * X or A' * X. */
/* On the final return from ZLACN2, KASE will again be 0. */
/* ISAVE (input/output) INTEGER array, dimension (3) */
/* ISAVE is used to save variables between calls to ZLACN2 */
/* Further Details */
/* ======= ======= */
/* Contributed by Nick Higham, University of Manchester. */
/* Originally named CONEST, dated March 16, 1988. */
/* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of */
/* a real or complex matrix, with applications to condition estimation", */
/* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */
/* Last modified: April, 1999 */
/* This is a thread safe version of ZLACON, which uses the array ISAVE */
/* in place of a SAVE statement, as follows: */
/* ZLACON ZLACN2 */
/* JUMP ISAVE(1) */
/* J ISAVE(2) */
/* ITER ISAVE(3) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--isave;
--x;
--v;
/* Function Body */
safmin = dlamch_("Safe minimum");
if (*kase == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
d__1 = 1. / (doublereal) (*n);
z__1.r = d__1, z__1.i = 0.;
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
/* L10: */
}
*kase = 1;
isave[1] = 1;
return 0;
}
switch (isave[1]) {
case 1: goto L20;
case 2: goto L40;
case 3: goto L70;
case 4: goto L90;
case 5: goto L120;
}
/* ................ ENTRY (ISAVE( 1 ) = 1) */
/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */
L20:
if (*n == 1) {
v[1].r = x[1].r, v[1].i = x[1].i;
*est = z_abs(&v[1]);
/* ... QUIT */
goto L130;
}
*est = dzsum1_(n, &x[1], &c__1);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
absxi = z_abs(&x[i__]);
if (absxi > safmin) {
i__2 = i__;
i__3 = i__;
d__1 = x[i__3].r / absxi;
d__2 = d_imag(&x[i__]) / absxi;
z__1.r = d__1, z__1.i = d__2;
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
} else {
i__2 = i__;
x[i__2].r = 1., x[i__2].i = 0.;
}
/* L30: */
}
*kase = 2;
isave[1] = 2;
return 0;
/* ................ ENTRY (ISAVE( 1 ) = 2) */
/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. */
L40:
isave[2] = izmax1_(n, &x[1], &c__1);
isave[3] = 2;
/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */
L50:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
x[i__2].r = 0., x[i__2].i = 0.;
/* L60: */
}
i__1 = isave[2];
x[i__1].r = 1., x[i__1].i = 0.;
*kase = 1;
isave[1] = 3;
return 0;
/* ................ ENTRY (ISAVE( 1 ) = 3) */
/* X HAS BEEN OVERWRITTEN BY A*X. */
L70:
zcopy_(n, &x[1], &c__1, &v[1], &c__1);
estold = *est;
*est = dzsum1_(n, &v[1], &c__1);
/* TEST FOR CYCLING. */
if (*est <= estold) {
goto L100;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
absxi = z_abs(&x[i__]);
if (absxi > safmin) {
i__2 = i__;
i__3 = i__;
d__1 = x[i__3].r / absxi;
d__2 = d_imag(&x[i__]) / absxi;
z__1.r = d__1, z__1.i = d__2;
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
} else {
i__2 = i__;
x[i__2].r = 1., x[i__2].i = 0.;
}
/* L80: */
}
*kase = 2;
isave[1] = 4;
return 0;
/* ................ ENTRY (ISAVE( 1 ) = 4) */
/* X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. */
L90:
jlast = isave[2];
isave[2] = izmax1_(n, &x[1], &c__1);
if (z_abs(&x[jlast]) != z_abs(&x[isave[2]]) && isave[3] < 5) {
++isave[3];
goto L50;
}
/* ITERATION COMPLETE. FINAL STAGE. */
L100:
altsgn = 1.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
d__1 = altsgn * ((doublereal) (i__ - 1) / (doublereal) (*n - 1) + 1.);
z__1.r = d__1, z__1.i = 0.;
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
altsgn = -altsgn;
/* L110: */
}
*kase = 1;
isave[1] = 5;
return 0;
/* ................ ENTRY (ISAVE( 1 ) = 5) */
/* X HAS BEEN OVERWRITTEN BY A*X. */
L120:
temp = dzsum1_(n, &x[1], &c__1) / (doublereal) (*n * 3) * 2.;
if (temp > *est) {
zcopy_(n, &x[1], &c__1, &v[1], &c__1);
*est = temp;
}
L130:
*kase = 0;
return 0;
/* End of ZLACN2 */
} /* zlacn2_ */
/* Subroutine */ int ztbcon_(char *norm, char *uplo, char *diag, integer *n,
integer *kd, doublecomplex *ab, integer *ldab, doublereal *rcond,
doublecomplex *work, doublereal *rwork, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
ZTBCON estimates the reciprocal of the condition number of a
triangular band matrix A, in either the 1-norm or the infinity-norm.
The norm of A is computed and an estimate is obtained for
norm(inv(A)), then the reciprocal of the condition number is
computed as
RCOND = 1 / ( norm(A) * norm(inv(A)) ).
Arguments
=========
NORM (input) CHARACTER*1
Specifies whether the 1-norm condition number or the
infinity-norm condition number is required:
= '1' or 'O': 1-norm;
= 'I': Infinity-norm.
UPLO (input) CHARACTER*1
= 'U': A is upper triangular;
= 'L': A is lower triangular.
DIAG (input) CHARACTER*1
= 'N': A is non-unit triangular;
= 'U': A is unit triangular.
N (input) INTEGER
The order of the matrix A. N >= 0.
KD (input) INTEGER
The number of superdiagonals or subdiagonals of the
triangular band matrix A. KD >= 0.
AB (input) COMPLEX*16 array, dimension (LDAB,N)
The upper or lower triangular band matrix A, stored in the
first kd+1 rows of the array. The j-th column of A is stored
in the j-th column of the array AB as follows:
if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
If DIAG = 'U', the diagonal elements of A are not referenced
and are assumed to be 1.
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
RCOND (output) DOUBLE PRECISION
The reciprocal of the condition number of the matrix A,
computed as RCOND = 1/(norm(A) * norm(inv(A))).
WORK (workspace) COMPLEX*16 array, dimension (2*N)
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, i__1;
doublereal d__1, d__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer kase, kase1;
static doublereal scale;
extern logical lsame_(char *, char *);
static doublereal anorm;
static logical upper;
static doublereal xnorm;
extern doublereal dlamch_(char *);
static integer ix;
extern /* Subroutine */ int xerbla_(char *, integer *), zlacon_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *);
static doublereal ainvnm;
extern integer izamax_(integer *, doublecomplex *, integer *);
extern doublereal zlantb_(char *, char *, char *, integer *, integer *,
doublecomplex *, integer *, doublereal *);
static logical onenrm;
extern /* Subroutine */ int zlatbs_(char *, char *, char *, char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, doublereal *, integer *), zdrscl_(integer *, doublereal *, doublecomplex *,
integer *);
static char normin[1];
static doublereal smlnum;
static logical nounit;
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
--work;
--rwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
nounit = lsame_(diag, "N");
if (! onenrm && ! lsame_(norm, "I")) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*kd < 0) {
*info = -5;
} else if (*ldab < *kd + 1) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTBCON", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*rcond = 1.;
return 0;
}
*rcond = 0.;
smlnum = dlamch_("Safe minimum") * (doublereal) max(*n,1);
/* Compute the 1-norm of the triangular matrix A or A'. */
anorm = zlantb_(norm, uplo, diag, n, kd, &ab[ab_offset], ldab, &rwork[1]);
/* Continue only if ANORM > 0. */
if (anorm > 0.) {
/* Estimate the 1-norm of the inverse of A. */
ainvnm = 0.;
*(unsigned char *)normin = 'N';
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kase = 0;
L10:
zlacon_(n, &work[*n + 1], &work[1], &ainvnm, &kase);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(A). */
zlatbs_(uplo, "No transpose", diag, normin, n, kd, &ab[
ab_offset], ldab, &work[1], &scale, &rwork[1], info);
} else {
/* Multiply by inv(A'). */
zlatbs_(uplo, "Conjugate transpose", diag, normin, n, kd, &ab[
ab_offset], ldab, &work[1], &scale, &rwork[1], info);
}
*(unsigned char *)normin = 'Y';
/* Multiply by 1/SCALE if doing so will not cause overflow. */
if (scale != 1.) {
ix = izamax_(n, &work[1], &c__1);
i__1 = ix;
xnorm = (d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(&
work[ix]), abs(d__2));
if (scale < xnorm * smlnum || scale == 0.) {
goto L20;
}
zdrscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) {
*rcond = 1. / anorm / ainvnm;
}
}
L20:
return 0;
/* End of ZTBCON */
} /* ztbcon_ */
/* Subroutine */ int zptrfs_(char *uplo, integer *n, integer *nrhs,
doublereal *d__, doublecomplex *e, doublereal *df, doublecomplex *ef,
doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *
rwork, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5,
i__6;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10,
d__11, d__12;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
double d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
double z_abs(doublecomplex *);
/* Local variables */
integer i__, j;
doublereal s;
doublecomplex bi, cx, dx, ex;
integer ix, nz;
doublereal eps, safe1, safe2;
extern logical lsame_(char *, char *);
integer count;
logical upper;
extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dlamch_(char *);
extern integer idamax_(integer *, doublereal *, integer *);
doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal lstres;
extern /* Subroutine */ int zpttrs_(char *, integer *, integer *,
doublereal *, doublecomplex *, doublecomplex *, integer *,
integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZPTRFS improves the computed solution to a system of linear */
/* equations when the coefficient matrix is Hermitian positive definite */
/* and tridiagonal, and provides error bounds and backward error */
/* estimates for the solution. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the superdiagonal or the subdiagonal of the */
/* tridiagonal matrix A is stored and the form of the */
/* factorization: */
/* = 'U': E is the superdiagonal of A, and A = U**H*D*U; */
/* = 'L': E is the subdiagonal of A, and A = L*D*L**H. */
/* (The two forms are equivalent if A is real.) */
/* 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. */
/* D (input) DOUBLE PRECISION array, dimension (N) */
/* The n real diagonal elements of the tridiagonal matrix A. */
/* E (input) COMPLEX*16 array, dimension (N-1) */
/* The (n-1) off-diagonal elements of the tridiagonal matrix A */
/* (see UPLO). */
/* DF (input) DOUBLE PRECISION array, dimension (N) */
/* The n diagonal elements of the diagonal matrix D from */
/* the factorization computed by ZPTTRF. */
/* EF (input) COMPLEX*16 array, dimension (N-1) */
/* The (n-1) off-diagonal elements of the unit bidiagonal */
/* factor U or L from the factorization computed by ZPTTRF */
/* (see UPLO). */
/* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS) */
/* On entry, the solution matrix X, as computed by ZPTTRS. */
/* 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 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). */
/* 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) COMPLEX*16 array, dimension (N) */
/* RWORK (workspace) DOUBLE PRECISION 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 .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
--df;
--ef;
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;
--rwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldx < max(1,*n)) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPTRFS", &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;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = 4;
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 - A * X. Also compute */
/* abs(A)*abs(x) + abs(b) for use in the backward error bound. */
if (upper) {
if (*n == 1) {
i__2 = j * b_dim1 + 1;
bi.r = b[i__2].r, bi.i = b[i__2].i;
i__2 = j * x_dim1 + 1;
z__1.r = d__[1] * x[i__2].r, z__1.i = d__[1] * x[i__2].i;
dx.r = z__1.r, dx.i = z__1.i;
z__1.r = bi.r - dx.r, z__1.i = bi.i - dx.i;
work[1].r = z__1.r, work[1].i = z__1.i;
rwork[1] = (d__1 = bi.r, abs(d__1)) + (d__2 = d_imag(&bi),
abs(d__2)) + ((d__3 = dx.r, abs(d__3)) + (d__4 =
d_imag(&dx), abs(d__4)));
} else {
i__2 = j * b_dim1 + 1;
bi.r = b[i__2].r, bi.i = b[i__2].i;
i__2 = j * x_dim1 + 1;
z__1.r = d__[1] * x[i__2].r, z__1.i = d__[1] * x[i__2].i;
dx.r = z__1.r, dx.i = z__1.i;
i__2 = j * x_dim1 + 2;
z__1.r = e[1].r * x[i__2].r - e[1].i * x[i__2].i, z__1.i = e[
1].r * x[i__2].i + e[1].i * x[i__2].r;
ex.r = z__1.r, ex.i = z__1.i;
z__2.r = bi.r - dx.r, z__2.i = bi.i - dx.i;
z__1.r = z__2.r - ex.r, z__1.i = z__2.i - ex.i;
work[1].r = z__1.r, work[1].i = z__1.i;
i__2 = j * x_dim1 + 2;
rwork[1] = (d__1 = bi.r, abs(d__1)) + (d__2 = d_imag(&bi),
abs(d__2)) + ((d__3 = dx.r, abs(d__3)) + (d__4 =
d_imag(&dx), abs(d__4))) + ((d__5 = e[1].r, abs(d__5))
+ (d__6 = d_imag(&e[1]), abs(d__6))) * ((d__7 = x[
i__2].r, abs(d__7)) + (d__8 = d_imag(&x[j * x_dim1 +
2]), abs(d__8)));
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
bi.r = b[i__3].r, bi.i = b[i__3].i;
d_cnjg(&z__2, &e[i__ - 1]);
i__3 = i__ - 1 + j * x_dim1;
z__1.r = z__2.r * x[i__3].r - z__2.i * x[i__3].i, z__1.i =
z__2.r * x[i__3].i + z__2.i * x[i__3].r;
cx.r = z__1.r, cx.i = z__1.i;
i__3 = i__;
i__4 = i__ + j * x_dim1;
z__1.r = d__[i__3] * x[i__4].r, z__1.i = d__[i__3] * x[
i__4].i;
dx.r = z__1.r, dx.i = z__1.i;
i__3 = i__;
i__4 = i__ + 1 + j * x_dim1;
z__1.r = e[i__3].r * x[i__4].r - e[i__3].i * x[i__4].i,
z__1.i = e[i__3].r * x[i__4].i + e[i__3].i * x[
i__4].r;
ex.r = z__1.r, ex.i = z__1.i;
i__3 = i__;
z__3.r = bi.r - cx.r, z__3.i = bi.i - cx.i;
z__2.r = z__3.r - dx.r, z__2.i = z__3.i - dx.i;
z__1.r = z__2.r - ex.r, z__1.i = z__2.i - ex.i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
i__3 = i__ - 1;
i__4 = i__ - 1 + j * x_dim1;
i__5 = i__;
i__6 = i__ + 1 + j * x_dim1;
rwork[i__] = (d__1 = bi.r, abs(d__1)) + (d__2 = d_imag(&
bi), abs(d__2)) + ((d__3 = e[i__3].r, abs(d__3))
+ (d__4 = d_imag(&e[i__ - 1]), abs(d__4))) * ((
d__5 = x[i__4].r, abs(d__5)) + (d__6 = d_imag(&x[
i__ - 1 + j * x_dim1]), abs(d__6))) + ((d__7 =
dx.r, abs(d__7)) + (d__8 = d_imag(&dx), abs(d__8))
) + ((d__9 = e[i__5].r, abs(d__9)) + (d__10 =
d_imag(&e[i__]), abs(d__10))) * ((d__11 = x[i__6]
.r, abs(d__11)) + (d__12 = d_imag(&x[i__ + 1 + j *
x_dim1]), abs(d__12)));
/* L30: */
}
i__2 = *n + j * b_dim1;
bi.r = b[i__2].r, bi.i = b[i__2].i;
d_cnjg(&z__2, &e[*n - 1]);
i__2 = *n - 1 + j * x_dim1;
z__1.r = z__2.r * x[i__2].r - z__2.i * x[i__2].i, z__1.i =
z__2.r * x[i__2].i + z__2.i * x[i__2].r;
cx.r = z__1.r, cx.i = z__1.i;
i__2 = *n;
i__3 = *n + j * x_dim1;
z__1.r = d__[i__2] * x[i__3].r, z__1.i = d__[i__2] * x[i__3]
.i;
dx.r = z__1.r, dx.i = z__1.i;
i__2 = *n;
z__2.r = bi.r - cx.r, z__2.i = bi.i - cx.i;
z__1.r = z__2.r - dx.r, z__1.i = z__2.i - dx.i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
i__2 = *n - 1;
i__3 = *n - 1 + j * x_dim1;
rwork[*n] = (d__1 = bi.r, abs(d__1)) + (d__2 = d_imag(&bi),
abs(d__2)) + ((d__3 = e[i__2].r, abs(d__3)) + (d__4 =
d_imag(&e[*n - 1]), abs(d__4))) * ((d__5 = x[i__3].r,
abs(d__5)) + (d__6 = d_imag(&x[*n - 1 + j * x_dim1]),
abs(d__6))) + ((d__7 = dx.r, abs(d__7)) + (d__8 =
d_imag(&dx), abs(d__8)));
}
} else {
if (*n == 1) {
i__2 = j * b_dim1 + 1;
bi.r = b[i__2].r, bi.i = b[i__2].i;
i__2 = j * x_dim1 + 1;
z__1.r = d__[1] * x[i__2].r, z__1.i = d__[1] * x[i__2].i;
dx.r = z__1.r, dx.i = z__1.i;
z__1.r = bi.r - dx.r, z__1.i = bi.i - dx.i;
work[1].r = z__1.r, work[1].i = z__1.i;
rwork[1] = (d__1 = bi.r, abs(d__1)) + (d__2 = d_imag(&bi),
abs(d__2)) + ((d__3 = dx.r, abs(d__3)) + (d__4 =
d_imag(&dx), abs(d__4)));
} else {
i__2 = j * b_dim1 + 1;
bi.r = b[i__2].r, bi.i = b[i__2].i;
i__2 = j * x_dim1 + 1;
z__1.r = d__[1] * x[i__2].r, z__1.i = d__[1] * x[i__2].i;
dx.r = z__1.r, dx.i = z__1.i;
d_cnjg(&z__2, &e[1]);
i__2 = j * x_dim1 + 2;
z__1.r = z__2.r * x[i__2].r - z__2.i * x[i__2].i, z__1.i =
z__2.r * x[i__2].i + z__2.i * x[i__2].r;
ex.r = z__1.r, ex.i = z__1.i;
z__2.r = bi.r - dx.r, z__2.i = bi.i - dx.i;
z__1.r = z__2.r - ex.r, z__1.i = z__2.i - ex.i;
work[1].r = z__1.r, work[1].i = z__1.i;
i__2 = j * x_dim1 + 2;
rwork[1] = (d__1 = bi.r, abs(d__1)) + (d__2 = d_imag(&bi),
abs(d__2)) + ((d__3 = dx.r, abs(d__3)) + (d__4 =
d_imag(&dx), abs(d__4))) + ((d__5 = e[1].r, abs(d__5))
+ (d__6 = d_imag(&e[1]), abs(d__6))) * ((d__7 = x[
i__2].r, abs(d__7)) + (d__8 = d_imag(&x[j * x_dim1 +
2]), abs(d__8)));
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
bi.r = b[i__3].r, bi.i = b[i__3].i;
i__3 = i__ - 1;
i__4 = i__ - 1 + j * x_dim1;
z__1.r = e[i__3].r * x[i__4].r - e[i__3].i * x[i__4].i,
z__1.i = e[i__3].r * x[i__4].i + e[i__3].i * x[
i__4].r;
cx.r = z__1.r, cx.i = z__1.i;
i__3 = i__;
i__4 = i__ + j * x_dim1;
z__1.r = d__[i__3] * x[i__4].r, z__1.i = d__[i__3] * x[
i__4].i;
dx.r = z__1.r, dx.i = z__1.i;
d_cnjg(&z__2, &e[i__]);
i__3 = i__ + 1 + j * x_dim1;
z__1.r = z__2.r * x[i__3].r - z__2.i * x[i__3].i, z__1.i =
z__2.r * x[i__3].i + z__2.i * x[i__3].r;
ex.r = z__1.r, ex.i = z__1.i;
i__3 = i__;
z__3.r = bi.r - cx.r, z__3.i = bi.i - cx.i;
z__2.r = z__3.r - dx.r, z__2.i = z__3.i - dx.i;
z__1.r = z__2.r - ex.r, z__1.i = z__2.i - ex.i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
i__3 = i__ - 1;
i__4 = i__ - 1 + j * x_dim1;
i__5 = i__;
i__6 = i__ + 1 + j * x_dim1;
rwork[i__] = (d__1 = bi.r, abs(d__1)) + (d__2 = d_imag(&
bi), abs(d__2)) + ((d__3 = e[i__3].r, abs(d__3))
+ (d__4 = d_imag(&e[i__ - 1]), abs(d__4))) * ((
d__5 = x[i__4].r, abs(d__5)) + (d__6 = d_imag(&x[
i__ - 1 + j * x_dim1]), abs(d__6))) + ((d__7 =
dx.r, abs(d__7)) + (d__8 = d_imag(&dx), abs(d__8))
) + ((d__9 = e[i__5].r, abs(d__9)) + (d__10 =
d_imag(&e[i__]), abs(d__10))) * ((d__11 = x[i__6]
.r, abs(d__11)) + (d__12 = d_imag(&x[i__ + 1 + j *
x_dim1]), abs(d__12)));
/* L40: */
}
i__2 = *n + j * b_dim1;
bi.r = b[i__2].r, bi.i = b[i__2].i;
i__2 = *n - 1;
i__3 = *n - 1 + j * x_dim1;
z__1.r = e[i__2].r * x[i__3].r - e[i__2].i * x[i__3].i,
z__1.i = e[i__2].r * x[i__3].i + e[i__2].i * x[i__3]
.r;
cx.r = z__1.r, cx.i = z__1.i;
i__2 = *n;
i__3 = *n + j * x_dim1;
z__1.r = d__[i__2] * x[i__3].r, z__1.i = d__[i__2] * x[i__3]
.i;
dx.r = z__1.r, dx.i = z__1.i;
i__2 = *n;
z__2.r = bi.r - cx.r, z__2.i = bi.i - cx.i;
z__1.r = z__2.r - dx.r, z__1.i = z__2.i - dx.i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
i__2 = *n - 1;
i__3 = *n - 1 + j * x_dim1;
rwork[*n] = (d__1 = bi.r, abs(d__1)) + (d__2 = d_imag(&bi),
abs(d__2)) + ((d__3 = e[i__2].r, abs(d__3)) + (d__4 =
d_imag(&e[*n - 1]), abs(d__4))) * ((d__5 = x[i__3].r,
abs(d__5)) + (d__6 = d_imag(&x[*n - 1 + j * x_dim1]),
abs(d__6))) + ((d__7 = dx.r, abs(d__7)) + (d__8 =
d_imag(&dx), abs(d__8)));
}
}
/* Compute componentwise relative backward error from formula */
/* max(i) ( abs(R(i)) / ( abs(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. */
s = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
/* Computing MAX */
i__3 = i__;
d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2))) / rwork[i__];
s = max(d__3,d__4);
} else {
/* Computing MAX */
i__3 = i__;
d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__]
+ safe1);
s = max(d__3,d__4);
}
/* L50: */
}
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. */
zpttrs_(uplo, n, &c__1, &df[1], &ef[1], &work[1], n, info);
zaxpy_(n, &c_b16, &work[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(A))* */
/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
/* where */
/* norm(Z) is the magnitude of the largest component of Z */
/* inv(A) is the inverse of 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(A)*abs(X)+abs(B)) */
/* is incremented by SAFE1 if the i-th component of */
/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
i__3 = i__;
rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
;
} else {
i__3 = i__;
rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ safe1;
}
/* L60: */
}
ix = idamax_(n, &rwork[1], &c__1);
ferr[j] = rwork[ix];
/* Estimate the norm of inv(A). */
/* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by */
/* m(i,j) = abs(A(i,j)), i = j, */
/* m(i,j) = -abs(A(i,j)), i .ne. j, */
/* and e = [ 1, 1, ..., 1 ]'. Note M(A) = M(L)*D*M(L)'. */
/* Solve M(L) * x = e. */
rwork[1] = 1.;
i__2 = *n;
for (i__ = 2; i__ <= i__2; ++i__) {
rwork[i__] = rwork[i__ - 1] * z_abs(&ef[i__ - 1]) + 1.;
/* L70: */
}
/* Solve D * M(L)' * x = b. */
rwork[*n] /= df[*n];
for (i__ = *n - 1; i__ >= 1; --i__) {
rwork[i__] = rwork[i__] / df[i__] + rwork[i__ + 1] * z_abs(&ef[
i__]);
/* L80: */
}
/* Compute norm(inv(A)) = max(x(i)), 1<=i<=n. */
ix = idamax_(n, &rwork[1], &c__1);
ferr[j] *= (d__1 = rwork[ix], abs(d__1));
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__1 = lstres, d__2 = z_abs(&x[i__ + j * x_dim1]);
lstres = max(d__1,d__2);
/* L90: */
}
if (lstres != 0.) {
ferr[j] /= lstres;
}
/* L100: */
}
return 0;
/* End of ZPTRFS */
} /* zptrfs_ */
/* Subroutine */ int zget22_(char *transa, char *transe, char *transw,
integer *n, doublecomplex *a, integer *lda, doublecomplex *e, integer
*lde, doublecomplex *w, doublecomplex *work, doublereal *rwork,
doublereal *result)
{
/* System generated locals */
integer a_dim1, a_offset, e_dim1, e_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer j;
doublereal ulp;
integer joff, jcol, jvec;
doublereal unfl;
integer jrow;
doublereal temp1;
extern logical lsame_(char *, char *);
char norma[1];
doublereal anorm;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
char norme[1];
doublereal enorm;
doublecomplex wtemp;
extern doublereal dlamch_(char *), zlange_(char *, integer *,
integer *, doublecomplex *, integer *, doublereal *);
doublereal enrmin, enrmax;
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
integer itrnse;
doublereal errnrm;
integer itrnsw;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGET22 does an eigenvector check. */
/* The basic test is: */
/* RESULT(1) = | A E - E W | / ( |A| |E| ulp ) */
/* using the 1-norm. It also tests the normalization of E: */
/* RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp ) */
/* j */
/* where E(j) is the j-th eigenvector, and m-norm is the max-norm of a */
/* vector. The max-norm of a complex n-vector x in this case is the */
/* maximum of |re(x(i)| + |im(x(i)| over i = 1, ..., n. */
/* Arguments */
/* ========== */
/* TRANSA (input) CHARACTER*1 */
/* Specifies whether or not A is transposed. */
/* = 'N': No transpose */
/* = 'T': Transpose */
/* = 'C': Conjugate transpose */
/* TRANSE (input) CHARACTER*1 */
/* Specifies whether or not E is transposed. */
/* = 'N': No transpose, eigenvectors are in columns of E */
/* = 'T': Transpose, eigenvectors are in rows of E */
/* = 'C': Conjugate transpose, eigenvectors are in rows of E */
/* TRANSW (input) CHARACTER*1 */
/* Specifies whether or not W is transposed. */
/* = 'N': No transpose */
/* = 'T': Transpose, same as TRANSW = 'N' */
/* = 'C': Conjugate transpose, use -WI(j) instead of WI(j) */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The matrix whose eigenvectors are in E. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* E (input) COMPLEX*16 array, dimension (LDE,N) */
/* The matrix of eigenvectors. If TRANSE = 'N', the eigenvectors */
/* are stored in the columns of E, if TRANSE = 'T' or 'C', the */
/* eigenvectors are stored in the rows of E. */
/* LDE (input) INTEGER */
/* The leading dimension of the array E. LDE >= max(1,N). */
/* W (input) COMPLEX*16 array, dimension (N) */
/* The eigenvalues of A. */
/* WORK (workspace) COMPLEX*16 array, dimension (N*N) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
/* RESULT(1) = | A E - E W | / ( |A| |E| ulp ) */
/* RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp ) */
/* j */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Initialize RESULT (in case N=0) */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
e_dim1 = *lde;
e_offset = 1 + e_dim1;
e -= e_offset;
--w;
--work;
--rwork;
--result;
/* Function Body */
result[1] = 0.;
result[2] = 0.;
if (*n <= 0) {
return 0;
}
unfl = dlamch_("Safe minimum");
ulp = dlamch_("Precision");
itrnse = 0;
itrnsw = 0;
*(unsigned char *)norma = 'O';
*(unsigned char *)norme = 'O';
if (lsame_(transa, "T") || lsame_(transa, "C")) {
*(unsigned char *)norma = 'I';
}
if (lsame_(transe, "T")) {
itrnse = 1;
*(unsigned char *)norme = 'I';
} else if (lsame_(transe, "C")) {
itrnse = 2;
*(unsigned char *)norme = 'I';
}
if (lsame_(transw, "C")) {
itrnsw = 1;
}
/* Normalization of E: */
enrmin = 1. / ulp;
enrmax = 0.;
if (itrnse == 0) {
i__1 = *n;
for (jvec = 1; jvec <= i__1; ++jvec) {
temp1 = 0.;
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
/* Computing MAX */
i__3 = j + jvec * e_dim1;
d__3 = temp1, d__4 = (d__1 = e[i__3].r, abs(d__1)) + (d__2 =
d_imag(&e[j + jvec * e_dim1]), abs(d__2));
temp1 = max(d__3,d__4);
/* L10: */
}
enrmin = min(enrmin,temp1);
enrmax = max(enrmax,temp1);
/* L20: */
}
} else {
i__1 = *n;
for (jvec = 1; jvec <= i__1; ++jvec) {
rwork[jvec] = 0.;
/* L30: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (jvec = 1; jvec <= i__2; ++jvec) {
/* Computing MAX */
i__3 = jvec + j * e_dim1;
d__3 = rwork[jvec], d__4 = (d__1 = e[i__3].r, abs(d__1)) + (
d__2 = d_imag(&e[jvec + j * e_dim1]), abs(d__2));
rwork[jvec] = max(d__3,d__4);
/* L40: */
}
/* L50: */
}
i__1 = *n;
for (jvec = 1; jvec <= i__1; ++jvec) {
/* Computing MIN */
d__1 = enrmin, d__2 = rwork[jvec];
enrmin = min(d__1,d__2);
/* Computing MAX */
d__1 = enrmax, d__2 = rwork[jvec];
enrmax = max(d__1,d__2);
/* L60: */
}
}
/* Norm of A: */
/* Computing MAX */
d__1 = zlange_(norma, n, n, &a[a_offset], lda, &rwork[1]);
anorm = max(d__1,unfl);
/* Norm of E: */
/* Computing MAX */
d__1 = zlange_(norme, n, n, &e[e_offset], lde, &rwork[1]);
enorm = max(d__1,ulp);
/* Norm of error: */
/* Error = AE - EW */
zlaset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
joff = 0;
i__1 = *n;
for (jcol = 1; jcol <= i__1; ++jcol) {
if (itrnsw == 0) {
i__2 = jcol;
wtemp.r = w[i__2].r, wtemp.i = w[i__2].i;
} else {
d_cnjg(&z__1, &w[jcol]);
wtemp.r = z__1.r, wtemp.i = z__1.i;
}
if (itrnse == 0) {
i__2 = *n;
for (jrow = 1; jrow <= i__2; ++jrow) {
i__3 = joff + jrow;
i__4 = jrow + jcol * e_dim1;
z__1.r = e[i__4].r * wtemp.r - e[i__4].i * wtemp.i, z__1.i =
e[i__4].r * wtemp.i + e[i__4].i * wtemp.r;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L70: */
}
} else if (itrnse == 1) {
i__2 = *n;
for (jrow = 1; jrow <= i__2; ++jrow) {
i__3 = joff + jrow;
i__4 = jcol + jrow * e_dim1;
z__1.r = e[i__4].r * wtemp.r - e[i__4].i * wtemp.i, z__1.i =
e[i__4].r * wtemp.i + e[i__4].i * wtemp.r;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L80: */
}
} else {
i__2 = *n;
for (jrow = 1; jrow <= i__2; ++jrow) {
i__3 = joff + jrow;
d_cnjg(&z__2, &e[jcol + jrow * e_dim1]);
z__1.r = z__2.r * wtemp.r - z__2.i * wtemp.i, z__1.i = z__2.r
* wtemp.i + z__2.i * wtemp.r;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L90: */
}
}
joff += *n;
/* L100: */
}
z__1.r = -1., z__1.i = -0.;
zgemm_(transa, transe, n, n, n, &c_b2, &a[a_offset], lda, &e[e_offset],
lde, &z__1, &work[1], n);
errnrm = zlange_("One", n, n, &work[1], n, &rwork[1]) / enorm;
/* Compute RESULT(1) (avoiding under/overflow) */
if (anorm > errnrm) {
result[1] = errnrm / anorm / ulp;
} else {
if (anorm < 1.) {
result[1] = min(errnrm,anorm) / anorm / ulp;
} else {
/* Computing MIN */
d__1 = errnrm / anorm;
result[1] = min(d__1,1.) / ulp;
}
}
/* Compute RESULT(2) : the normalization error in E. */
/* Computing MAX */
d__3 = (d__1 = enrmax - 1., abs(d__1)), d__4 = (d__2 = enrmin - 1., abs(
d__2));
result[2] = max(d__3,d__4) / ((doublereal) (*n) * ulp);
return 0;
/* End of ZGET22 */
} /* zget22_ */
/* Subroutine */ int znaitr_(integer *ido, char *bmat, integer *n, integer *k,
integer *np, integer *nb, doublecomplex *resid, doublereal *rnorm,
doublecomplex *v, integer *ldv, doublecomplex *h__, integer *ldh,
integer *ipntr, doublecomplex *workd, integer *info, ftnlen bmat_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer h_dim1, h_offset, v_dim1, v_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1;
/* Builtin functions */
double d_imag(doublecomplex *), sqrt(doublereal);
/* Local variables */
static integer i__, j;
static real t0, t1, t2, t3, t4, t5;
static integer jj, ipj, irj, ivj;
static doublereal ulp, tst1;
static integer ierr, iter;
static doublereal unfl, ovfl;
static integer itry;
static doublereal temp1;
static logical orth1, orth2, step3, step4;
static doublereal betaj;
static integer infol;
static doublecomplex cnorm;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal rtemp[2];
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, ftnlen);
static doublereal wnorm;
extern /* Subroutine */ int dvout_(integer *, integer *, doublereal *,
integer *, char *, ftnlen), zcopy_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *), ivout_(integer *, integer
*, integer *, integer *, char *, ftnlen), zaxpy_(integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *), zmout_(integer *, integer *, integer *, doublecomplex
*, integer *, integer *, char *, ftnlen), zvout_(integer *,
integer *, doublecomplex *, integer *, char *, ftnlen);
extern doublereal dlapy2_(doublereal *, doublereal *);
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
static doublereal rnorm1;
extern /* Subroutine */ int zgetv0_(integer *, char *, integer *, logical
*, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, doublereal *, integer *, doublecomplex *,
integer *, ftnlen);
extern doublereal dlamch_(char *, ftnlen);
extern /* Subroutine */ int second_(real *), zdscal_(integer *,
doublereal *, doublecomplex *, integer *);
static logical rstart;
static integer msglvl;
static doublereal smlnum;
extern doublereal zlanhs_(char *, integer *, doublecomplex *, integer *,
doublecomplex *, ftnlen);
extern /* Subroutine */ int zlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublecomplex *,
integer *, integer *, ftnlen);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %--------------% */
/* | Local Arrays | */
/* %--------------% */
/* %---------------% */
/* | Local Scalars | */
/* %---------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %---------------------% */
/* | Intrinsic Functions | */
/* %---------------------% */
/* %-----------------% */
/* | Data statements | */
/* %-----------------% */
/* Parameter adjustments */
--workd;
--resid;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--ipntr;
/* Function Body */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
if (first) {
/* %-----------------------------------------% */
/* | Set machine-dependent constants for the | */
/* | the splitting and deflation criterion. | */
/* | If norm(H) <= sqrt(OVFL), | */
/* | overflow should not occur. | */
/* | REFERENCE: LAPACK subroutine zlahqr | */
/* %-----------------------------------------% */
unfl = dlamch_("safe minimum", (ftnlen)12);
z__1.r = 1. / unfl, z__1.i = 0. / unfl;
ovfl = z__1.r;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("precision", (ftnlen)9);
smlnum = unfl * (*n / ulp);
first = FALSE_;
}
if (*ido == 0) {
/* %-------------------------------% */
/* | Initialize timing statistics | */
/* | & message level for debugging | */
/* %-------------------------------% */
second_(&t0);
msglvl = debug_1.mcaitr;
/* %------------------------------% */
/* | Initial call to this routine | */
/* %------------------------------% */
*info = 0;
step3 = FALSE_;
step4 = FALSE_;
rstart = FALSE_;
orth1 = FALSE_;
orth2 = FALSE_;
j = *k + 1;
ipj = 1;
irj = ipj + *n;
ivj = irj + *n;
}
/* %-------------------------------------------------% */
/* | When in reverse communication mode one of: | */
/* | STEP3, STEP4, ORTH1, ORTH2, RSTART | */
/* | will be .true. when .... | */
/* | STEP3: return from computing OP*v_{j}. | */
/* | STEP4: return from computing B-norm of OP*v_{j} | */
/* | ORTH1: return from computing B-norm of r_{j+1} | */
/* | ORTH2: return from computing B-norm of | */
/* | correction to the residual vector. | */
/* | RSTART: return from OP computations needed by | */
/* | zgetv0. | */
/* %-------------------------------------------------% */
if (step3) {
goto L50;
}
if (step4) {
goto L60;
}
if (orth1) {
goto L70;
}
if (orth2) {
goto L90;
}
if (rstart) {
goto L30;
}
/* %-----------------------------% */
/* | Else this is the first step | */
/* %-----------------------------% */
/* %--------------------------------------------------------------% */
/* | | */
/* | A R N O L D I I T E R A T I O N L O O P | */
/* | | */
/* | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | */
/* %--------------------------------------------------------------% */
L1000:
if (msglvl > 1) {
ivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: generat"
"ing Arnoldi vector number", (ftnlen)40);
dvout_(&debug_1.logfil, &c__1, rnorm, &debug_1.ndigit, "_naitr: B-no"
"rm of the current residual is", (ftnlen)41);
}
/* %---------------------------------------------------% */
/* | STEP 1: Check if the B norm of j-th residual | */
/* | vector is zero. Equivalent to determine whether | */
/* | an exact j-step Arnoldi factorization is present. | */
/* %---------------------------------------------------% */
betaj = *rnorm;
if (*rnorm > 0.) {
goto L40;
}
/* %---------------------------------------------------% */
/* | Invariant subspace found, generate a new starting | */
/* | vector which is orthogonal to the current Arnoldi | */
/* | basis and continue the iteration. | */
/* %---------------------------------------------------% */
if (msglvl > 0) {
ivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: ****** "
"RESTART AT STEP ******", (ftnlen)37);
}
/* %---------------------------------------------% */
/* | ITRY is the loop variable that controls the | */
/* | maximum amount of times that a restart is | */
/* | attempted. NRSTRT is used by stat.h | */
/* %---------------------------------------------% */
betaj = 0.;
++timing_1.nrstrt;
itry = 1;
L20:
rstart = TRUE_;
*ido = 0;
L30:
/* %--------------------------------------% */
/* | If in reverse communication mode and | */
/* | RSTART = .true. flow returns here. | */
/* %--------------------------------------% */
zgetv0_(ido, bmat, &itry, &c_false, n, &j, &v[v_offset], ldv, &resid[1],
rnorm, &ipntr[1], &workd[1], &ierr, (ftnlen)1);
if (*ido != 99) {
goto L9000;
}
if (ierr < 0) {
++itry;
if (itry <= 3) {
goto L20;
}
/* %------------------------------------------------% */
/* | Give up after several restart attempts. | */
/* | Set INFO to the size of the invariant subspace | */
/* | which spans OP and exit. | */
/* %------------------------------------------------% */
*info = j - 1;
second_(&t1);
timing_1.tcaitr += t1 - t0;
*ido = 99;
goto L9000;
}
L40:
/* %---------------------------------------------------------% */
/* | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | */
/* | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | */
/* | when reciprocating a small RNORM, test against lower | */
/* | machine bound. | */
/* %---------------------------------------------------------% */
zcopy_(n, &resid[1], &c__1, &v[j * v_dim1 + 1], &c__1);
if (*rnorm >= unfl) {
temp1 = 1. / *rnorm;
zdscal_(n, &temp1, &v[j * v_dim1 + 1], &c__1);
zdscal_(n, &temp1, &workd[ipj], &c__1);
} else {
/* %-----------------------------------------% */
/* | To scale both v_{j} and p_{j} carefully | */
/* | use LAPACK routine zlascl | */
/* %-----------------------------------------% */
zlascl_("General", &i__, &i__, rnorm, &c_b27, n, &c__1, &v[j * v_dim1
+ 1], n, &infol, (ftnlen)7);
zlascl_("General", &i__, &i__, rnorm, &c_b27, n, &c__1, &workd[ipj],
n, &infol, (ftnlen)7);
}
/* %------------------------------------------------------% */
/* | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | */
/* | Note that this is not quite yet r_{j}. See STEP 4 | */
/* %------------------------------------------------------% */
step3 = TRUE_;
++timing_1.nopx;
second_(&t2);
zcopy_(n, &v[j * v_dim1 + 1], &c__1, &workd[ivj], &c__1);
ipntr[1] = ivj;
ipntr[2] = irj;
ipntr[3] = ipj;
*ido = 1;
/* %-----------------------------------% */
/* | Exit in order to compute OP*v_{j} | */
/* %-----------------------------------% */
goto L9000;
L50:
/* %----------------------------------% */
/* | Back from reverse communication; | */
/* | WORKD(IRJ:IRJ+N-1) := OP*v_{j} | */
/* | if step3 = .true. | */
/* %----------------------------------% */
second_(&t3);
timing_1.tmvopx += t3 - t2;
step3 = FALSE_;
/* %------------------------------------------% */
/* | Put another copy of OP*v_{j} into RESID. | */
/* %------------------------------------------% */
zcopy_(n, &workd[irj], &c__1, &resid[1], &c__1);
/* %---------------------------------------% */
/* | STEP 4: Finish extending the Arnoldi | */
/* | factorization to length j. | */
/* %---------------------------------------% */
second_(&t2);
if (*(unsigned char *)bmat == 'G') {
++timing_1.nbx;
step4 = TRUE_;
ipntr[1] = irj;
ipntr[2] = ipj;
*ido = 2;
/* %-------------------------------------% */
/* | Exit in order to compute B*OP*v_{j} | */
/* %-------------------------------------% */
goto L9000;
} else if (*(unsigned char *)bmat == 'I') {
zcopy_(n, &resid[1], &c__1, &workd[ipj], &c__1);
}
L60:
/* %----------------------------------% */
/* | Back from reverse communication; | */
/* | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} | */
/* | if step4 = .true. | */
/* %----------------------------------% */
if (*(unsigned char *)bmat == 'G') {
second_(&t3);
timing_1.tmvbx += t3 - t2;
}
step4 = FALSE_;
/* %-------------------------------------% */
/* | The following is needed for STEP 5. | */
/* | Compute the B-norm of OP*v_{j}. | */
/* %-------------------------------------% */
if (*(unsigned char *)bmat == 'G') {
zdotc_(&z__1, n, &resid[1], &c__1, &workd[ipj], &c__1);
cnorm.r = z__1.r, cnorm.i = z__1.i;
d__1 = cnorm.r;
d__2 = d_imag(&cnorm);
wnorm = sqrt(dlapy2_(&d__1, &d__2));
} else if (*(unsigned char *)bmat == 'I') {
wnorm = dznrm2_(n, &resid[1], &c__1);
}
/* %-----------------------------------------% */
/* | Compute the j-th residual corresponding | */
/* | to the j step factorization. | */
/* | Use Classical Gram Schmidt and compute: | */
/* | w_{j} <- V_{j}^T * B * OP * v_{j} | */
/* | r_{j} <- OP*v_{j} - V_{j} * w_{j} | */
/* %-----------------------------------------% */
/* %------------------------------------------% */
/* | Compute the j Fourier coefficients w_{j} | */
/* | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | */
/* %------------------------------------------% */
zgemv_("C", n, &j, &c_b1, &v[v_offset], ldv, &workd[ipj], &c__1, &c_b2, &
h__[j * h_dim1 + 1], &c__1, (ftnlen)1);
/* %--------------------------------------% */
/* | Orthogonalize r_{j} against V_{j}. | */
/* | RESID contains OP*v_{j}. See STEP 3. | */
/* %--------------------------------------% */
z__1.r = -1., z__1.i = -0.;
zgemv_("N", n, &j, &z__1, &v[v_offset], ldv, &h__[j * h_dim1 + 1], &c__1,
&c_b1, &resid[1], &c__1, (ftnlen)1);
if (j > 1) {
i__1 = j + (j - 1) * h_dim1;
z__1.r = betaj, z__1.i = 0.;
h__[i__1].r = z__1.r, h__[i__1].i = z__1.i;
}
second_(&t4);
orth1 = TRUE_;
second_(&t2);
if (*(unsigned char *)bmat == 'G') {
++timing_1.nbx;
zcopy_(n, &resid[1], &c__1, &workd[irj], &c__1);
ipntr[1] = irj;
ipntr[2] = ipj;
*ido = 2;
/* %----------------------------------% */
/* | Exit in order to compute B*r_{j} | */
/* %----------------------------------% */
goto L9000;
} else if (*(unsigned char *)bmat == 'I') {
zcopy_(n, &resid[1], &c__1, &workd[ipj], &c__1);
}
L70:
/* %---------------------------------------------------% */
/* | Back from reverse communication if ORTH1 = .true. | */
/* | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | */
/* %---------------------------------------------------% */
if (*(unsigned char *)bmat == 'G') {
second_(&t3);
timing_1.tmvbx += t3 - t2;
}
orth1 = FALSE_;
/* %------------------------------% */
/* | Compute the B-norm of r_{j}. | */
/* %------------------------------% */
if (*(unsigned char *)bmat == 'G') {
zdotc_(&z__1, n, &resid[1], &c__1, &workd[ipj], &c__1);
cnorm.r = z__1.r, cnorm.i = z__1.i;
d__1 = cnorm.r;
d__2 = d_imag(&cnorm);
*rnorm = sqrt(dlapy2_(&d__1, &d__2));
} else if (*(unsigned char *)bmat == 'I') {
*rnorm = dznrm2_(n, &resid[1], &c__1);
}
/* %-----------------------------------------------------------% */
/* | STEP 5: Re-orthogonalization / Iterative refinement phase | */
/* | Maximum NITER_ITREF tries. | */
/* | | */
/* | s = V_{j}^T * B * r_{j} | */
/* | r_{j} = r_{j} - V_{j}*s | */
/* | alphaj = alphaj + s_{j} | */
/* | | */
/* | The stopping criteria used for iterative refinement is | */
/* | discussed in Parlett's book SEP, page 107 and in Gragg & | */
/* | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | */
/* | Determine if we need to correct the residual. The goal is | */
/* | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | */
/* | The following test determines whether the sine of the | */
/* | angle between OP*x and the computed residual is less | */
/* | than or equal to 0.717. | */
/* %-----------------------------------------------------------% */
if (*rnorm > wnorm * .717f) {
goto L100;
}
iter = 0;
++timing_1.nrorth;
/* %---------------------------------------------------% */
/* | Enter the Iterative refinement phase. If further | */
/* | refinement is necessary, loop back here. The loop | */
/* | variable is ITER. Perform a step of Classical | */
/* | Gram-Schmidt using all the Arnoldi vectors V_{j} | */
/* %---------------------------------------------------% */
L80:
if (msglvl > 2) {
rtemp[0] = wnorm;
rtemp[1] = *rnorm;
dvout_(&debug_1.logfil, &c__2, rtemp, &debug_1.ndigit, "_naitr: re-o"
"rthogonalization; wnorm and rnorm are", (ftnlen)49);
zvout_(&debug_1.logfil, &j, &h__[j * h_dim1 + 1], &debug_1.ndigit,
"_naitr: j-th column of H", (ftnlen)24);
}
/* %----------------------------------------------------% */
/* | Compute V_{j}^T * B * r_{j}. | */
/* | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | */
/* %----------------------------------------------------% */
zgemv_("C", n, &j, &c_b1, &v[v_offset], ldv, &workd[ipj], &c__1, &c_b2, &
workd[irj], &c__1, (ftnlen)1);
/* %---------------------------------------------% */
/* | Compute the correction to the residual: | */
/* | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | */
/* | The correction to H is v(:,1:J)*H(1:J,1:J) | */
/* | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. | */
/* %---------------------------------------------% */
z__1.r = -1., z__1.i = -0.;
zgemv_("N", n, &j, &z__1, &v[v_offset], ldv, &workd[irj], &c__1, &c_b1, &
resid[1], &c__1, (ftnlen)1);
zaxpy_(&j, &c_b1, &workd[irj], &c__1, &h__[j * h_dim1 + 1], &c__1);
orth2 = TRUE_;
second_(&t2);
if (*(unsigned char *)bmat == 'G') {
++timing_1.nbx;
zcopy_(n, &resid[1], &c__1, &workd[irj], &c__1);
ipntr[1] = irj;
ipntr[2] = ipj;
*ido = 2;
/* %-----------------------------------% */
/* | Exit in order to compute B*r_{j}. | */
/* | r_{j} is the corrected residual. | */
/* %-----------------------------------% */
goto L9000;
} else if (*(unsigned char *)bmat == 'I') {
zcopy_(n, &resid[1], &c__1, &workd[ipj], &c__1);
}
L90:
/* %---------------------------------------------------% */
/* | Back from reverse communication if ORTH2 = .true. | */
/* %---------------------------------------------------% */
if (*(unsigned char *)bmat == 'G') {
second_(&t3);
timing_1.tmvbx += t3 - t2;
}
/* %-----------------------------------------------------% */
/* | Compute the B-norm of the corrected residual r_{j}. | */
/* %-----------------------------------------------------% */
if (*(unsigned char *)bmat == 'G') {
zdotc_(&z__1, n, &resid[1], &c__1, &workd[ipj], &c__1);
cnorm.r = z__1.r, cnorm.i = z__1.i;
d__1 = cnorm.r;
d__2 = d_imag(&cnorm);
rnorm1 = sqrt(dlapy2_(&d__1, &d__2));
} else if (*(unsigned char *)bmat == 'I') {
rnorm1 = dznrm2_(n, &resid[1], &c__1);
}
if (msglvl > 0 && iter > 0) {
ivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: Iterati"
"ve refinement for Arnoldi residual", (ftnlen)49);
if (msglvl > 2) {
rtemp[0] = *rnorm;
rtemp[1] = rnorm1;
dvout_(&debug_1.logfil, &c__2, rtemp, &debug_1.ndigit, "_naitr: "
"iterative refinement ; rnorm and rnorm1 are", (ftnlen)51);
}
}
/* %-----------------------------------------% */
/* | Determine if we need to perform another | */
/* | step of re-orthogonalization. | */
/* %-----------------------------------------% */
if (rnorm1 > *rnorm * .717f) {
/* %---------------------------------------% */
/* | No need for further refinement. | */
/* | The cosine of the angle between the | */
/* | corrected residual vector and the old | */
/* | residual vector is greater than 0.717 | */
/* | In other words the corrected residual | */
/* | and the old residual vector share an | */
/* | angle of less than arcCOS(0.717) | */
/* %---------------------------------------% */
*rnorm = rnorm1;
} else {
/* %-------------------------------------------% */
/* | Another step of iterative refinement step | */
/* | is required. NITREF is used by stat.h | */
/* %-------------------------------------------% */
++timing_1.nitref;
*rnorm = rnorm1;
++iter;
if (iter <= 1) {
goto L80;
}
/* %-------------------------------------------------% */
/* | Otherwise RESID is numerically in the span of V | */
/* %-------------------------------------------------% */
i__1 = *n;
for (jj = 1; jj <= i__1; ++jj) {
i__2 = jj;
resid[i__2].r = 0., resid[i__2].i = 0.;
/* L95: */
}
*rnorm = 0.;
}
/* %----------------------------------------------% */
/* | Branch here directly if iterative refinement | */
/* | wasn't necessary or after at most NITER_REF | */
/* | steps of iterative refinement. | */
/* %----------------------------------------------% */
L100:
rstart = FALSE_;
orth2 = FALSE_;
second_(&t5);
timing_1.titref += t5 - t4;
/* %------------------------------------% */
/* | STEP 6: Update j = j+1; Continue | */
/* %------------------------------------% */
++j;
if (j > *k + *np) {
second_(&t1);
timing_1.tcaitr += t1 - t0;
*ido = 99;
i__1 = *k + *np - 1;
for (i__ = max(1,*k); i__ <= i__1; ++i__) {
/* %--------------------------------------------% */
/* | Check for splitting and deflation. | */
/* | Use a standard test as in the QR algorithm | */
/* | REFERENCE: LAPACK subroutine zlahqr | */
/* %--------------------------------------------% */
i__2 = i__ + i__ * h_dim1;
d__1 = h__[i__2].r;
d__2 = d_imag(&h__[i__ + i__ * h_dim1]);
i__3 = i__ + 1 + (i__ + 1) * h_dim1;
d__3 = h__[i__3].r;
d__4 = d_imag(&h__[i__ + 1 + (i__ + 1) * h_dim1]);
tst1 = dlapy2_(&d__1, &d__2) + dlapy2_(&d__3, &d__4);
if (tst1 == 0.) {
i__2 = *k + *np;
tst1 = zlanhs_("1", &i__2, &h__[h_offset], ldh, &workd[*n + 1]
, (ftnlen)1);
}
i__2 = i__ + 1 + i__ * h_dim1;
d__1 = h__[i__2].r;
d__2 = d_imag(&h__[i__ + 1 + i__ * h_dim1]);
/* Computing MAX */
d__3 = ulp * tst1;
if (dlapy2_(&d__1, &d__2) <= max(d__3,smlnum)) {
i__3 = i__ + 1 + i__ * h_dim1;
h__[i__3].r = 0., h__[i__3].i = 0.;
}
/* L110: */
}
if (msglvl > 2) {
i__1 = *k + *np;
i__2 = *k + *np;
zmout_(&debug_1.logfil, &i__1, &i__2, &h__[h_offset], ldh, &
debug_1.ndigit, "_naitr: Final upper Hessenberg matrix H"
" of order K+NP", (ftnlen)53);
}
goto L9000;
}
/* %--------------------------------------------------------% */
/* | Loop back to extend the factorization by another step. | */
/* %--------------------------------------------------------% */
goto L1000;
/* %---------------------------------------------------------------% */
/* | | */
/* | E N D O F M A I N I T E R A T I O N L O O P | */
/* | | */
/* %---------------------------------------------------------------% */
L9000:
return 0;
/* %---------------% */
/* | End of znaitr | */
/* %---------------% */
} /* znaitr_ */
/* Subroutine */
int zla_syamv_(integer *uplo, integer *n, doublereal *alpha, doublecomplex *a, integer *lda, doublecomplex *x, integer *incx, doublereal *beta, doublereal *y, integer *incy)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1, d__2;
/* Builtin functions */
double d_imag(doublecomplex *), d_sign(doublereal *, doublereal *);
/* Local variables */
integer i__, j;
logical symb_zero__;
integer iy, jx, kx, ky, info;
doublereal temp, safe1;
extern doublereal dlamch_(char *);
extern /* Subroutine */
int xerbla_(char *, integer *);
extern integer ilauplo_(char *);
/* -- 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 .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function Definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--x;
--y;
/* Function Body */
info = 0;
if (*uplo != ilauplo_("U") && *uplo != ilauplo_("L") )
{
info = 1;
}
else if (*n < 0)
{
info = 2;
}
else if (*lda < max(1,*n))
{
info = 5;
}
else if (*incx == 0)
{
info = 7;
}
else if (*incy == 0)
{
info = 10;
}
if (info != 0)
{
xerbla_("DSYMV ", &info);
return 0;
}
/* Quick return if possible. */
if (*n == 0 || *alpha == 0. && *beta == 1.)
{
return 0;
}
/* Set up the start points in X and Y. */
if (*incx > 0)
{
kx = 1;
}
else
{
kx = 1 - (*n - 1) * *incx;
}
if (*incy > 0)
{
ky = 1;
}
else
{
ky = 1 - (*n - 1) * *incy;
}
/* Set SAFE1 essentially to be the underflow threshold times the */
/* number of additions in each row. */
safe1 = dlamch_("Safe minimum");
safe1 = (*n + 1) * safe1;
/* Form y := alpha*f2c_abs(A)*f2c_abs(x) + beta*f2c_abs(y). */
/* The O(N^2) SYMB_ZERO tests could be replaced by O(N) queries to */
/* the inexact flag. Still doesn't help change the iteration order */
/* to per-column. */
iy = ky;
if (*incx == 1)
{
if (*uplo == ilauplo_("U"))
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
if (*beta == 0.)
{
symb_zero__ = TRUE_;
y[iy] = 0.;
}
else if (y[iy] == 0.)
{
symb_zero__ = TRUE_;
}
else
{
symb_zero__ = FALSE_;
y[iy] = *beta * (d__1 = y[iy], f2c_abs(d__1));
}
if (*alpha != 0.)
{
i__2 = i__;
for (j = 1;
j <= i__2;
++j)
{
i__3 = j + i__ * a_dim1;
temp = (d__1 = a[i__3].r, f2c_abs(d__1)) + (d__2 = d_imag( &a[j + i__ * a_dim1]), f2c_abs(d__2));
i__3 = j;
symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ i__3].i == 0. || temp == 0.);
i__3 = j;
y[iy] += *alpha * ((d__1 = x[i__3].r, f2c_abs(d__1)) + ( d__2 = d_imag(&x[j]), f2c_abs(d__2))) * temp;
}
i__2 = *n;
for (j = i__ + 1;
j <= i__2;
++j)
{
i__3 = i__ + j * a_dim1;
temp = (d__1 = a[i__3].r, f2c_abs(d__1)) + (d__2 = d_imag( &a[i__ + j * a_dim1]), f2c_abs(d__2));
i__3 = j;
symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ i__3].i == 0. || temp == 0.);
i__3 = j;
y[iy] += *alpha * ((d__1 = x[i__3].r, f2c_abs(d__1)) + ( d__2 = d_imag(&x[j]), f2c_abs(d__2))) * temp;
}
}
if (! symb_zero__)
{
y[iy] += d_sign(&safe1, &y[iy]);
}
iy += *incy;
}
}
else
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
if (*beta == 0.)
{
symb_zero__ = TRUE_;
y[iy] = 0.;
}
else if (y[iy] == 0.)
{
symb_zero__ = TRUE_;
}
else
{
symb_zero__ = FALSE_;
y[iy] = *beta * (d__1 = y[iy], f2c_abs(d__1));
}
if (*alpha != 0.)
{
i__2 = i__;
for (j = 1;
j <= i__2;
++j)
{
i__3 = i__ + j * a_dim1;
temp = (d__1 = a[i__3].r, f2c_abs(d__1)) + (d__2 = d_imag( &a[i__ + j * a_dim1]), f2c_abs(d__2));
i__3 = j;
symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ i__3].i == 0. || temp == 0.);
i__3 = j;
y[iy] += *alpha * ((d__1 = x[i__3].r, f2c_abs(d__1)) + ( d__2 = d_imag(&x[j]), f2c_abs(d__2))) * temp;
}
i__2 = *n;
for (j = i__ + 1;
j <= i__2;
++j)
{
i__3 = j + i__ * a_dim1;
temp = (d__1 = a[i__3].r, f2c_abs(d__1)) + (d__2 = d_imag( &a[j + i__ * a_dim1]), f2c_abs(d__2));
i__3 = j;
symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ i__3].i == 0. || temp == 0.);
i__3 = j;
y[iy] += *alpha * ((d__1 = x[i__3].r, f2c_abs(d__1)) + ( d__2 = d_imag(&x[j]), f2c_abs(d__2))) * temp;
}
}
if (! symb_zero__)
{
y[iy] += d_sign(&safe1, &y[iy]);
}
iy += *incy;
}
}
}
else
{
if (*uplo == ilauplo_("U"))
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
if (*beta == 0.)
{
symb_zero__ = TRUE_;
y[iy] = 0.;
}
else if (y[iy] == 0.)
{
symb_zero__ = TRUE_;
}
else
{
symb_zero__ = FALSE_;
y[iy] = *beta * (d__1 = y[iy], f2c_abs(d__1));
}
jx = kx;
if (*alpha != 0.)
{
i__2 = i__;
for (j = 1;
j <= i__2;
++j)
{
i__3 = j + i__ * a_dim1;
temp = (d__1 = a[i__3].r, f2c_abs(d__1)) + (d__2 = d_imag( &a[j + i__ * a_dim1]), f2c_abs(d__2));
i__3 = j;
symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ i__3].i == 0. || temp == 0.);
i__3 = jx;
y[iy] += *alpha * ((d__1 = x[i__3].r, f2c_abs(d__1)) + ( d__2 = d_imag(&x[jx]), f2c_abs(d__2))) * temp;
jx += *incx;
}
i__2 = *n;
for (j = i__ + 1;
j <= i__2;
++j)
{
i__3 = i__ + j * a_dim1;
temp = (d__1 = a[i__3].r, f2c_abs(d__1)) + (d__2 = d_imag( &a[i__ + j * a_dim1]), f2c_abs(d__2));
i__3 = j;
symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ i__3].i == 0. || temp == 0.);
i__3 = jx;
y[iy] += *alpha * ((d__1 = x[i__3].r, f2c_abs(d__1)) + ( d__2 = d_imag(&x[jx]), f2c_abs(d__2))) * temp;
jx += *incx;
}
}
if (! symb_zero__)
{
y[iy] += d_sign(&safe1, &y[iy]);
}
iy += *incy;
}
}
else
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
if (*beta == 0.)
{
symb_zero__ = TRUE_;
y[iy] = 0.;
}
else if (y[iy] == 0.)
{
symb_zero__ = TRUE_;
}
else
{
symb_zero__ = FALSE_;
y[iy] = *beta * (d__1 = y[iy], f2c_abs(d__1));
}
jx = kx;
if (*alpha != 0.)
{
i__2 = i__;
for (j = 1;
j <= i__2;
++j)
{
i__3 = i__ + j * a_dim1;
temp = (d__1 = a[i__3].r, f2c_abs(d__1)) + (d__2 = d_imag( &a[i__ + j * a_dim1]), f2c_abs(d__2));
i__3 = j;
symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ i__3].i == 0. || temp == 0.);
i__3 = jx;
y[iy] += *alpha * ((d__1 = x[i__3].r, f2c_abs(d__1)) + ( d__2 = d_imag(&x[jx]), f2c_abs(d__2))) * temp;
jx += *incx;
}
i__2 = *n;
for (j = i__ + 1;
j <= i__2;
++j)
{
i__3 = j + i__ * a_dim1;
temp = (d__1 = a[i__3].r, f2c_abs(d__1)) + (d__2 = d_imag( &a[j + i__ * a_dim1]), f2c_abs(d__2));
i__3 = j;
symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ i__3].i == 0. || temp == 0.);
i__3 = jx;
y[iy] += *alpha * ((d__1 = x[i__3].r, f2c_abs(d__1)) + ( d__2 = d_imag(&x[jx]), f2c_abs(d__2))) * temp;
jx += *incx;
}
}
if (! symb_zero__)
{
y[iy] += d_sign(&safe1, &y[iy]);
}
iy += *incy;
}
}
}
return 0;
/* End of ZLA_SYAMV */
}
/* Subroutine */ int zgetv0_(integer *ido, char *bmat, integer *itry, logical
*initv, integer *n, integer *j, doublecomplex *v, integer *ldv,
doublecomplex *resid, doublereal *rnorm, integer *ipntr,
doublecomplex *workd, integer *ierr, ftnlen bmat_len)
{
/* Initialized data */
static logical inits = TRUE_;
/* System generated locals */
integer v_dim1, v_offset, i__1, i__2;
doublereal d__1, d__2;
doublecomplex z__1;
/* Local variables */
static real t0, t1, t2, t3;
static integer jj, iter;
static logical orth;
static integer iseed[4], idist;
static doublecomplex cnorm;
extern /* Double Complex */ void zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static logical first;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, ftnlen),
dvout_(integer *, integer *, doublereal *, integer *, char *,
ftnlen), zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zvout_(integer *, integer *,
doublecomplex *, integer *, char *, ftnlen);
extern doublereal dlapy2_(doublereal *, doublereal *), dznrm2_(integer *,
doublecomplex *, integer *);
static doublereal rnorm0;
extern /* Subroutine */ int arscnd_(real *);
static integer msglvl;
extern /* Subroutine */ int zlarnv_(integer *, integer *, integer *,
doublecomplex *);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %------------------------% */
/* | Local Scalars & Arrays | */
/* %------------------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %-----------------% */
/* | Data Statements | */
/* %-----------------% */
/* Parameter adjustments */
--workd;
--resid;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--ipntr;
/* Function Body */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* %-----------------------------------% */
/* | Initialize the seed of the LAPACK | */
/* | random number generator | */
/* %-----------------------------------% */
if (inits) {
iseed[0] = 1;
iseed[1] = 3;
iseed[2] = 5;
iseed[3] = 7;
inits = FALSE_;
}
if (*ido == 0) {
/* %-------------------------------% */
/* | Initialize timing statistics | */
/* | & message level for debugging | */
/* %-------------------------------% */
arscnd_(&t0);
msglvl = debug_1.mgetv0;
*ierr = 0;
iter = 0;
first = FALSE_;
orth = FALSE_;
/* %-----------------------------------------------------% */
/* | Possibly generate a random starting vector in RESID | */
/* | Use a LAPACK random number generator used by the | */
/* | matrix generation routines. | */
/* | idist = 1: uniform (0,1) distribution; | */
/* | idist = 2: uniform (-1,1) distribution; | */
/* | idist = 3: normal (0,1) distribution; | */
/* %-----------------------------------------------------% */
if (! (*initv)) {
idist = 2;
zlarnv_(&idist, iseed, n, &resid[1]);
}
/* %----------------------------------------------------------% */
/* | Force the starting vector into the range of OP to handle | */
/* | the generalized problem when B is possibly (singular). | */
/* %----------------------------------------------------------% */
arscnd_(&t2);
if (*(unsigned char *)bmat == 'G') {
++timing_1.nopx;
ipntr[1] = 1;
ipntr[2] = *n + 1;
zcopy_(n, &resid[1], &c__1, &workd[1], &c__1);
*ido = -1;
goto L9000;
}
}
/* %----------------------------------------% */
/* | Back from computing B*(initial-vector) | */
/* %----------------------------------------% */
if (first) {
goto L20;
}
/* %-----------------------------------------------% */
/* | Back from computing B*(orthogonalized-vector) | */
/* %-----------------------------------------------% */
if (orth) {
goto L40;
}
arscnd_(&t3);
timing_1.tmvopx += t3 - t2;
/* %------------------------------------------------------% */
/* | Starting vector is now in the range of OP; r = OP*r; | */
/* | Compute B-norm of starting vector. | */
/* %------------------------------------------------------% */
arscnd_(&t2);
first = TRUE_;
if (*(unsigned char *)bmat == 'G') {
++timing_1.nbx;
zcopy_(n, &workd[*n + 1], &c__1, &resid[1], &c__1);
ipntr[1] = *n + 1;
ipntr[2] = 1;
*ido = 2;
goto L9000;
} else if (*(unsigned char *)bmat == 'I') {
zcopy_(n, &resid[1], &c__1, &workd[1], &c__1);
}
L20:
if (*(unsigned char *)bmat == 'G') {
arscnd_(&t3);
timing_1.tmvbx += t3 - t2;
}
first = FALSE_;
if (*(unsigned char *)bmat == 'G') {
zdotc_(&z__1, n, &resid[1], &c__1, &workd[1], &c__1);
cnorm.r = z__1.r, cnorm.i = z__1.i;
d__1 = cnorm.r;
d__2 = d_imag(&cnorm);
rnorm0 = sqrt(dlapy2_(&d__1, &d__2));
} else if (*(unsigned char *)bmat == 'I') {
rnorm0 = dznrm2_(n, &resid[1], &c__1);
}
*rnorm = rnorm0;
/* %---------------------------------------------% */
/* | Exit if this is the very first Arnoldi step | */
/* %---------------------------------------------% */
if (*j == 1) {
goto L50;
}
/* %---------------------------------------------------------------- */
/* | Otherwise need to B-orthogonalize the starting vector against | */
/* | the current Arnoldi basis using Gram-Schmidt with iter. ref. | */
/* | This is the case where an invariant subspace is encountered | */
/* | in the middle of the Arnoldi factorization. | */
/* | | */
/* | s = V^{T}*B*r; r = r - V*s; | */
/* | | */
/* | Stopping criteria used for iter. ref. is discussed in | */
/* | Parlett's book, page 107 and in Gragg & Reichel TOMS paper. | */
/* %---------------------------------------------------------------% */
orth = TRUE_;
L30:
i__1 = *j - 1;
zgemv_("C", n, &i__1, &c_b1, &v[v_offset], ldv, &workd[1], &c__1, &c_b2, &
workd[*n + 1], &c__1, (ftnlen)1);
i__1 = *j - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("N", n, &i__1, &z__1, &v[v_offset], ldv, &workd[*n + 1], &c__1, &
c_b1, &resid[1], &c__1, (ftnlen)1);
/* %----------------------------------------------------------% */
/* | Compute the B-norm of the orthogonalized starting vector | */
/* %----------------------------------------------------------% */
arscnd_(&t2);
if (*(unsigned char *)bmat == 'G') {
++timing_1.nbx;
zcopy_(n, &resid[1], &c__1, &workd[*n + 1], &c__1);
ipntr[1] = *n + 1;
ipntr[2] = 1;
*ido = 2;
goto L9000;
} else if (*(unsigned char *)bmat == 'I') {
zcopy_(n, &resid[1], &c__1, &workd[1], &c__1);
}
L40:
if (*(unsigned char *)bmat == 'G') {
arscnd_(&t3);
timing_1.tmvbx += t3 - t2;
}
if (*(unsigned char *)bmat == 'G') {
zdotc_(&z__1, n, &resid[1], &c__1, &workd[1], &c__1);
cnorm.r = z__1.r, cnorm.i = z__1.i;
d__1 = cnorm.r;
d__2 = d_imag(&cnorm);
*rnorm = sqrt(dlapy2_(&d__1, &d__2));
} else if (*(unsigned char *)bmat == 'I') {
*rnorm = dznrm2_(n, &resid[1], &c__1);
}
/* %--------------------------------------% */
/* | Check for further orthogonalization. | */
/* %--------------------------------------% */
if (msglvl > 2) {
dvout_(&debug_1.logfil, &c__1, &rnorm0, &debug_1.ndigit, "_getv0: re"
"-orthonalization ; rnorm0 is", (ftnlen)38);
dvout_(&debug_1.logfil, &c__1, rnorm, &debug_1.ndigit, "_getv0: re-o"
"rthonalization ; rnorm is", (ftnlen)37);
}
if (*rnorm > rnorm0 * .717f) {
goto L50;
}
++iter;
if (iter <= 1) {
/* %-----------------------------------% */
/* | Perform iterative refinement step | */
/* %-----------------------------------% */
rnorm0 = *rnorm;
goto L30;
} else {
/* %------------------------------------% */
/* | Iterative refinement step "failed" | */
/* %------------------------------------% */
i__1 = *n;
for (jj = 1; jj <= i__1; ++jj) {
i__2 = jj;
resid[i__2].r = 0., resid[i__2].i = 0.;
/* L45: */
}
*rnorm = 0.;
*ierr = -1;
}
L50:
if (msglvl > 0) {
dvout_(&debug_1.logfil, &c__1, rnorm, &debug_1.ndigit, "_getv0: B-no"
"rm of initial / restarted starting vector", (ftnlen)53);
}
if (msglvl > 2) {
zvout_(&debug_1.logfil, n, &resid[1], &debug_1.ndigit, "_getv0: init"
"ial / restarted starting vector", (ftnlen)43);
}
*ido = 99;
arscnd_(&t1);
timing_1.tgetv0 += t1 - t0;
L9000:
return 0;
/* %---------------% */
/* | End of zgetv0 | */
/* %---------------% */
} /* zgetv0_ */
/* Subroutine */ int zgbequ_(integer *m, integer *n, integer *kl, integer *ku,
doublecomplex *ab, integer *ldab, doublereal *r__, doublereal *c__,
doublereal *rowcnd, doublereal *colcnd, doublereal *amax, integer *
info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
integer i__, j, kd;
doublereal rcmin, rcmax;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal bignum, smlnum;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGBEQU computes row and column scalings intended to equilibrate an */
/* M-by-N band matrix A and reduce its condition number. R returns the */
/* row scale factors and C the column scale factors, chosen to try to */
/* make the largest element in each row and column of the matrix B with */
/* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. */
/* R(i) and C(j) are restricted to be between SMLNUM = smallest safe */
/* number and BIGNUM = largest safe number. Use of these scaling */
/* factors is not guaranteed to reduce the condition number of A but */
/* works well in practice. */
/* Arguments */
/* ========= */
/* 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. */
/* KL (input) INTEGER */
/* The number of subdiagonals within the band of A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of superdiagonals within the band of A. KU >= 0. */
/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
/* The band matrix A, stored in rows 1 to KL+KU+1. The j-th */
/* column of A is stored in the j-th column of the array AB as */
/* follows: */
/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl). */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
/* R (output) DOUBLE PRECISION array, dimension (M) */
/* If INFO = 0, or INFO > M, R contains the row scale factors */
/* for A. */
/* C (output) DOUBLE PRECISION array, dimension (N) */
/* If INFO = 0, C contains the column scale factors for A. */
/* ROWCND (output) DOUBLE PRECISION */
/* If INFO = 0 or INFO > M, ROWCND contains the ratio of the */
/* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */
/* AMAX is neither too large nor too small, it is not worth */
/* scaling by R. */
/* COLCND (output) DOUBLE PRECISION */
/* If INFO = 0, COLCND contains the ratio of the smallest */
/* C(i) to the largest C(i). If COLCND >= 0.1, it is not */
/* worth scaling by C. */
/* AMAX (output) DOUBLE PRECISION */
/* Absolute value of largest matrix element. If AMAX is very */
/* close to overflow or very close to underflow, the matrix */
/* should be scaled. */
/* 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 */
/* <= M: the i-th row of A is exactly zero */
/* > M: the (i-M)-th column of A is exactly zero */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--r__;
--c__;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kl < 0) {
*info = -3;
} else if (*ku < 0) {
*info = -4;
} else if (*ldab < *kl + *ku + 1) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGBEQU", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
*rowcnd = 1.;
*colcnd = 1.;
*amax = 0.;
return 0;
}
/* Get machine constants. */
smlnum = dlamch_("S");
bignum = 1. / smlnum;
/* Compute row scale factors. */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
r__[i__] = 0.;
/* L10: */
}
/* Find the maximum element in each row. */
kd = *ku + 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = j - *ku;
/* Computing MIN */
i__4 = j + *kl;
i__3 = min(i__4,*m);
for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
/* Computing MAX */
i__2 = kd + i__ - j + j * ab_dim1;
d__3 = r__[i__], d__4 = (d__1 = ab[i__2].r, abs(d__1)) + (d__2 =
d_imag(&ab[kd + i__ - j + j * ab_dim1]), abs(d__2));
r__[i__] = max(d__3,d__4);
/* L20: */
}
/* L30: */
}
/* Find the maximum and minimum scale factors. */
rcmin = bignum;
rcmax = 0.;
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = rcmax, d__2 = r__[i__];
rcmax = max(d__1,d__2);
/* Computing MIN */
d__1 = rcmin, d__2 = r__[i__];
rcmin = min(d__1,d__2);
/* L40: */
}
*amax = rcmax;
if (rcmin == 0.) {
/* Find the first zero scale factor and return an error code. */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
if (r__[i__] == 0.) {
*info = i__;
return 0;
}
/* L50: */
}
} else {
/* Invert the scale factors. */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MIN */
/* Computing MAX */
d__2 = r__[i__];
d__1 = max(d__2,smlnum);
r__[i__] = 1. / min(d__1,bignum);
/* L60: */
}
/* Compute ROWCND = min(R(I)) / max(R(I)) */
*rowcnd = max(rcmin,smlnum) / min(rcmax,bignum);
}
/* Compute column scale factors */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
c__[j] = 0.;
/* L70: */
}
/* Find the maximum element in each column, */
/* assuming the row scaling computed above. */
kd = *ku + 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__3 = j - *ku;
/* Computing MIN */
i__4 = j + *kl;
i__2 = min(i__4,*m);
for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = kd + i__ - j + j * ab_dim1;
d__3 = c__[j], d__4 = ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 =
d_imag(&ab[kd + i__ - j + j * ab_dim1]), abs(d__2))) *
r__[i__];
c__[j] = max(d__3,d__4);
/* L80: */
}
/* L90: */
}
/* Find the maximum and minimum scale factors. */
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);
/* L100: */
}
if (rcmin == 0.) {
/* Find the first zero scale factor and return an error code. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (c__[j] == 0.) {
*info = *m + j;
return 0;
}
/* L110: */
}
} else {
/* Invert the scale factors. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
/* Computing MAX */
d__2 = c__[j];
d__1 = max(d__2,smlnum);
c__[j] = 1. / min(d__1,bignum);
/* L120: */
}
/* Compute COLCND = min(C(J)) / max(C(J)) */
*colcnd = max(rcmin,smlnum) / min(rcmax,bignum);
}
return 0;
/* End of ZGBEQU */
} /* zgbequ_ */
/* Subroutine */ int zdrges_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
doublecomplex *a, integer *lda, doublecomplex *b, doublecomplex *s,
doublecomplex *t, doublecomplex *q, integer *ldq, doublecomplex *z__,
doublecomplex *alpha, doublecomplex *beta, doublecomplex *work,
integer *lwork, doublereal *rwork, doublereal *result, logical *bwork,
integer *info)
{
/* Initialized data */
static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
2,2,2,3 };
static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
2,3,2,1 };
static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
1,1,1,1 };
static logical lasign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
TRUE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,FALSE_,
TRUE_,FALSE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,FALSE_ };
static logical lbsign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,FALSE_,
TRUE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_ };
static integer kz1[6] = { 0,1,2,1,3,3 };
static integer kz2[6] = { 0,0,1,2,1,1 };
static integer kadd[6] = { 0,0,0,0,3,2 };
static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
4,4,4,0 };
static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
8,8,8,8,8,0 };
static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
3,3,3,1 };
static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
4,4,4,1 };
static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
3,3,2,1 };
/* Format strings */
static char fmt_9999[] = "(\002 ZDRGES: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,4(i4,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 ZDRGES: S not in Schur form at eigenvalu"
"e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, "
"ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9997[] = "(/1x,a3,\002 -- Complex Generalized Schur from"
" problem \002,\002driver\002)";
static char fmt_9996[] = "(\002 Matrix types (see ZDRGES for details):"
" \002)";
static char fmt_9995[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
"osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
"onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
"I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
"arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
"(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
"=(D, reversed D)\002)";
static char fmt_9994[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
"atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
" 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
"ha&beta \002,\002 20=arithmetic alpha, beta=0,"
"1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
"=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
"/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
"l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
".\002)";
static char fmt_9993[] = "(/\002 Tests performed: (S is Schur, T is tri"
"angular, \002,\002Q and Z are \002,a,\002,\002,/19x,\002l and r "
"are the appropriate left and right\002,/19x,\002eigenvectors, re"
"sp., a is alpha, b is beta, and\002,/19x,a,\002 means \002,a,"
"\002.)\002,/\002 Without ordering: \002,/\002 1 = | A - Q S "
"Z\002,a,\002 | / ( |A| n ulp ) 2 = | B - Q T Z\002,a,\002 |"
" / ( |B| n ulp )\002,/\002 3 = | I - QQ\002,a,\002 | / ( n ulp "
") 4 = | I - ZZ\002,a,\002 | / ( n ulp )\002,/\002 5"
" = A is in Schur form S\002,/\002 6 = difference between (alpha"
",beta)\002,\002 and diagonals of (S,T)\002,/\002 With ordering:"
" \002,/\002 7 = | (A,B) - Q (S,T) Z\002,a,\002 | / ( |(A,B)| n "
"ulp )\002,/\002 8 = | I - QQ\002,a,\002 | / ( n ulp ) "
" 9 = | I - ZZ\002,a,\002 | / ( n ulp )\002,/\002 10 = A is in "
"Schur form S\002,/\002 11 = difference between (alpha,beta) and "
"diagonals\002,\002 of (S,T)\002,/\002 12 = SDIM is the correct n"
"umber of \002,\002selected eigenvalues\002,/)";
static char fmt_9992[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
",0p,f8.2)";
static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
",1p,d10.3)";
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, s_dim1,
s_offset, t_dim1, t_offset, z_dim1, z_offset, i__1, i__2, i__3,
i__4, i__5, i__6, i__7, i__8, i__9, i__10, i__11;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10,
d__11, d__12, d__13, d__14, d__15, d__16;
doublecomplex z__1, z__2, z__3, z__4;
/* Local variables */
integer i__, j, n, n1, jc, nb, in, jr;
doublereal ulp;
integer iadd, sdim, nmax, rsub;
char sort[1];
doublereal temp1, temp2;
logical badnn;
integer iinfo;
doublereal rmagn[4];
doublecomplex ctemp;
extern /* Subroutine */ int zget51_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *
, doublecomplex *, integer *, doublecomplex *, doublereal *,
doublereal *), zgges_(char *, char *, char *, L_fp, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, logical *, integer *);
integer nmats, jsize;
extern /* Subroutine */ int zget54_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublereal *);
integer nerrs, jtype, ntest, isort;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), zlatm4_(
integer *, integer *, integer *, integer *, logical *, doublereal
*, doublereal *, doublereal *, integer *, integer *,
doublecomplex *, integer *);
logical ilabad;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
doublereal safmin, safmax;
integer knteig, ioldsd[4];
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *), xerbla_(char *, integer *),
zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *);
extern /* Double Complex */ void zlarnd_(doublecomplex *, integer *,
integer *);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *);
extern logical zlctes_(doublecomplex *, doublecomplex *);
integer minwrk, maxwrk;
doublereal ulpinv;
integer mtypes, ntestt;
/* Fortran I/O blocks */
static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9991, 0 };
/* -- LAPACK test routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* February 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZDRGES checks the nonsymmetric generalized eigenvalue (Schur form) */
/* problem driver ZGGES. */
/* ZGGES factors A and B as Q*S*Z' and Q*T*Z' , where ' means conjugate */
/* transpose, S and T are upper triangular (i.e., in generalized Schur */
/* form), and Q and Z are unitary. It also computes the generalized */
/* eigenvalues (alpha(j),beta(j)), j=1,...,n. Thus, */
/* w(j) = alpha(j)/beta(j) is a root of the characteristic equation */
/* det( A - w(j) B ) = 0 */
/* Optionally it also reorder the eigenvalues so that a selected */
/* cluster of eigenvalues appears in the leading diagonal block of the */
/* Schur forms. */
/* When ZDRGES is called, a number of matrix "sizes" ("N's") and a */
/* number of matrix "TYPES" are specified. For each size ("N") */
/* and each TYPE of matrix, a pair of matrices (A, B) will be generated */
/* and used for testing. For each matrix pair, the following 13 tests */
/* will be performed and compared with the threshhold THRESH except */
/* the tests (5), (11) and (13). */
/* (1) | A - Q S Z' | / ( |A| n ulp ) (no sorting of eigenvalues) */
/* (2) | B - Q T Z' | / ( |B| n ulp ) (no sorting of eigenvalues) */
/* (3) | I - QQ' | / ( n ulp ) (no sorting of eigenvalues) */
/* (4) | I - ZZ' | / ( n ulp ) (no sorting of eigenvalues) */
/* (5) if A is in Schur form (i.e. triangular form) (no sorting of */
/* eigenvalues) */
/* (6) if eigenvalues = diagonal elements of the Schur form (S, T), */
/* i.e., test the maximum over j of D(j) where: */
/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
/* D(j) = ------------------------ + ----------------------- */
/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
/* (no sorting of eigenvalues) */
/* (7) | (A,B) - Q (S,T) Z' | / ( |(A,B)| n ulp ) */
/* (with sorting of eigenvalues). */
/* (8) | I - QQ' | / ( n ulp ) (with sorting of eigenvalues). */
/* (9) | I - ZZ' | / ( n ulp ) (with sorting of eigenvalues). */
/* (10) if A is in Schur form (i.e. quasi-triangular form) */
/* (with sorting of eigenvalues). */
/* (11) if eigenvalues = diagonal elements of the Schur form (S, T), */
/* i.e. test the maximum over j of D(j) where: */
/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
/* D(j) = ------------------------ + ----------------------- */
/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
/* (with sorting of eigenvalues). */
/* (12) if sorting worked and SDIM is the number of eigenvalues */
/* which were CELECTed. */
/* Test Matrices */
/* ============= */
/* The sizes of the test matrices are specified by an array */
/* NN(1:NSIZES); the value of each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if */
/* DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) ( 0, 0 ) (a pair of zero matrices) */
/* (2) ( I, 0 ) (an identity and a zero matrix) */
/* (3) ( 0, I ) (an identity and a zero matrix) */
/* (4) ( I, I ) (a pair of identity matrices) */
/* t t */
/* (5) ( J , J ) (a pair of transposed Jordan blocks) */
/* t ( I 0 ) */
/* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) */
/* ( 0 I ) ( 0 J ) */
/* and I is a k x k identity and J a (k+1)x(k+1) */
/* Jordan block; k=(N-1)/2 */
/* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal */
/* matrix with those diagonal entries.) */
/* (8) ( I, D ) */
/* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big */
/* (10) ( small*D, big*I ) */
/* (11) ( big*I, small*D ) */
/* (12) ( small*I, big*D ) */
/* (13) ( big*D, big*I ) */
/* (14) ( small*D, small*I ) */
/* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and */
/* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) */
/* t t */
/* (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. */
/* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices */
/* with random O(1) entries above the diagonal */
/* and diagonal entries diag(T1) = */
/* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = */
/* ( 0, N-3, N-4,..., 1, 0, 0 ) */
/* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) */
/* s = machine precision. */
/* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) */
/* N-5 */
/* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
/* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
/* where r1,..., r(N-4) are random. */
/* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular */
/* matrices. */
/* Arguments */
/* ========= */
/* NSIZES (input) INTEGER */
/* The number of sizes of matrices to use. If it is zero, */
/* DDRGES does nothing. NSIZES >= 0. */
/* NN (input) INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. NN >= 0. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. If it is zero, DDRGES */
/* does nothing. It must be at least zero. If it is MAXTYP+1 */
/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
/* defined, which is to use whatever matrix is in A on input. */
/* This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/* DOTYPE(MAXTYP+1) is .TRUE. . */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The random number generator uses a linear */
/* congruential sequence limited to small integers, and so */
/* should produce machine independent random numbers. The */
/* values of ISEED are changed on exit, and can be used in the */
/* next call to DDRGES to continue the same random number */
/* sequence. */
/* THRESH (input) DOUBLE PRECISION */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error is */
/* scaled to be O(1), so THRESH should be a reasonably small */
/* multiple of 1, e.g., 10 or 100. In particular, it should */
/* not depend on the precision (single vs. double) or the size */
/* of the matrix. THRESH >= 0. */
/* NOUNIT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* A (input/workspace) COMPLEX*16 array, dimension(LDA, max(NN)) */
/* Used to hold the original A matrix. Used as input only */
/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
/* DOTYPE(MAXTYP+1)=.TRUE. */
/* LDA (input) INTEGER */
/* The leading dimension of A, B, S, and T. */
/* It must be at least 1 and at least max( NN ). */
/* B (input/workspace) COMPLEX*16 array, dimension(LDA, max(NN)) */
/* Used to hold the original B matrix. Used as input only */
/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
/* DOTYPE(MAXTYP+1)=.TRUE. */
/* S (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
/* The Schur form matrix computed from A by ZGGES. On exit, S */
/* contains the Schur form matrix corresponding to the matrix */
/* in A. */
/* T (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
/* The upper triangular matrix computed from B by ZGGES. */
/* Q (workspace) COMPLEX*16 array, dimension (LDQ, max(NN)) */
/* The (left) orthogonal matrix computed by ZGGES. */
/* LDQ (input) INTEGER */
/* The leading dimension of Q and Z. It must */
/* be at least 1 and at least max( NN ). */
/* Z (workspace) COMPLEX*16 array, dimension( LDQ, max(NN) ) */
/* The (right) orthogonal matrix computed by ZGGES. */
/* ALPHA (workspace) COMPLEX*16 array, dimension (max(NN)) */
/* BETA (workspace) COMPLEX*16 array, dimension (max(NN)) */
/* The generalized eigenvalues of (A,B) computed by ZGGES. */
/* ALPHA(k) / BETA(k) is the k-th generalized eigenvalue of A */
/* and B. */
/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= 3*N*N. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension ( 8*N ) */
/* Real workspace. */
/* RESULT (output) DOUBLE PRECISION array, dimension (15) */
/* The values computed by the tests described above. */
/* The values are currently limited to 1/ulp, to avoid overflow. */
/* BWORK (workspace) LOGICAL array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: A routine returned an error code. INFO is the */
/* absolute value of the INFO value returned. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--dotype;
--iseed;
t_dim1 = *lda;
t_offset = 1 + t_dim1;
t -= t_offset;
s_dim1 = *lda;
s_offset = 1 + s_dim1;
s -= s_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
z_dim1 = *ldq;
z_offset = 1 + z_dim1;
z__ -= z_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--alpha;
--beta;
--work;
--rwork;
--result;
--bwork;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
*info = 0;
badnn = FALSE_;
nmax = 1;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.) {
*info = -6;
} else if (*lda <= 1 || *lda < nmax) {
*info = -9;
} else if (*ldq <= 1 || *ldq < nmax) {
*info = -14;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* NB refers to the optimal block size for the immediately */
/* following subroutine, as returned by ILAENV. */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
minwrk = nmax * 3 * nmax;
/* Computing MAX */
i__1 = 1, i__2 = ilaenv_(&c__1, "ZGEQRF", " ", &nmax, &nmax, &c_n1, &
c_n1), i__1 = max(i__1,i__2), i__2 =
ilaenv_(&c__1, "ZUNMQR", "LC", &nmax, &nmax, &nmax, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
c__1, "ZUNGQR", " ", &nmax, &nmax, &nmax, &c_n1);
nb = max(i__1,i__2);
/* Computing MAX */
i__1 = nmax + nmax * nb, i__2 = nmax * 3 * nmax;
maxwrk = max(i__1,i__2);
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
}
if (*lwork < minwrk) {
*info = -19;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZDRGES", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
ulp = dlamch_("Precision");
safmin = dlamch_("Safe minimum");
safmin /= ulp;
safmax = 1. / safmin;
dlabad_(&safmin, &safmax);
ulpinv = 1. / ulp;
/* The values RMAGN(2:3) depend on N, see below. */
rmagn[0] = 0.;
rmagn[1] = 1.;
/* Loop over matrix sizes */
ntestt = 0;
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
n1 = max(1,n);
rmagn[2] = safmax * ulp / (doublereal) n1;
rmagn[3] = safmin * ulpinv * (doublereal) n1;
if (*nsizes != 1) {
mtypes = min(26,*ntypes);
} else {
mtypes = min(27,*ntypes);
}
/* Loop over matrix types */
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L180;
}
++nmats;
ntest = 0;
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Initialize RESULT */
for (j = 1; j <= 13; ++j) {
result[j] = 0.;
/* L30: */
}
/* Generate test matrices A and B */
/* Description of control parameters: */
/* KZLASS: =1 means w/o rotation, =2 means w/ rotation, */
/* =3 means random. */
/* KATYPE: the "type" to be passed to ZLATM4 for computing A. */
/* KAZERO: the pattern of zeros on the diagonal for A: */
/* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), */
/* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), */
/* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of */
/* non-zero entries.) */
/* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), */
/* =2: large, =3: small. */
/* LASIGN: .TRUE. if the diagonal elements of A are to be */
/* multiplied by a random magnitude 1 number. */
/* KBTYPE, KBZERO, KBMAGN, LBSIGN: the same, but for B. */
/* KTRIAN: =0: don't fill in the upper triangle, =1: do. */
/* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. */
/* RMAGN: used to implement KAMAGN and KBMAGN. */
if (mtypes > 26) {
goto L110;
}
iinfo = 0;
if (kclass[jtype - 1] < 3) {
/* Generate A (w/o rotation) */
if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
zlaset_("Full", &n, &n, &c_b1, &c_b1, &a[a_offset],
lda);
}
} else {
in = n;
}
zlatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
&kz2[kazero[jtype - 1] - 1], &lasign[jtype - 1], &
rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
a_offset], lda);
iadd = kadd[kazero[jtype - 1] - 1];
if (iadd > 0 && iadd <= n) {
i__3 = iadd + iadd * a_dim1;
i__4 = kamagn[jtype - 1];
a[i__3].r = rmagn[i__4], a[i__3].i = 0.;
}
/* Generate B (w/o rotation) */
if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
zlaset_("Full", &n, &n, &c_b1, &c_b1, &b[b_offset],
lda);
}
} else {
in = n;
}
zlatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
&kz2[kbzero[jtype - 1] - 1], &lbsign[jtype - 1], &
rmagn[kbmagn[jtype - 1]], &c_b29, &rmagn[ktrian[jtype
- 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
b_offset], lda);
iadd = kadd[kbzero[jtype - 1] - 1];
if (iadd != 0 && iadd <= n) {
i__3 = iadd + iadd * b_dim1;
i__4 = kbmagn[jtype - 1];
b[i__3].r = rmagn[i__4], b[i__3].i = 0.;
}
if (kclass[jtype - 1] == 2 && n > 0) {
/* Include rotations */
/* Generate Q, Z as Householder transformations times */
/* a diagonal matrix. */
i__3 = n - 1;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = jc; jr <= i__4; ++jr) {
i__5 = jr + jc * q_dim1;
zlarnd_(&z__1, &c__3, &iseed[1]);
q[i__5].r = z__1.r, q[i__5].i = z__1.i;
i__5 = jr + jc * z_dim1;
zlarnd_(&z__1, &c__3, &iseed[1]);
z__[i__5].r = z__1.r, z__[i__5].i = z__1.i;
/* L40: */
}
i__4 = n + 1 - jc;
zlarfg_(&i__4, &q[jc + jc * q_dim1], &q[jc + 1 + jc *
q_dim1], &c__1, &work[jc]);
i__4 = (n << 1) + jc;
i__5 = jc + jc * q_dim1;
d__2 = q[i__5].r;
d__1 = d_sign(&c_b29, &d__2);
work[i__4].r = d__1, work[i__4].i = 0.;
i__4 = jc + jc * q_dim1;
q[i__4].r = 1., q[i__4].i = 0.;
i__4 = n + 1 - jc;
zlarfg_(&i__4, &z__[jc + jc * z_dim1], &z__[jc + 1 +
jc * z_dim1], &c__1, &work[n + jc]);
i__4 = n * 3 + jc;
i__5 = jc + jc * z_dim1;
d__2 = z__[i__5].r;
d__1 = d_sign(&c_b29, &d__2);
work[i__4].r = d__1, work[i__4].i = 0.;
i__4 = jc + jc * z_dim1;
z__[i__4].r = 1., z__[i__4].i = 0.;
/* L50: */
}
zlarnd_(&z__1, &c__3, &iseed[1]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__3 = n + n * q_dim1;
q[i__3].r = 1., q[i__3].i = 0.;
i__3 = n;
work[i__3].r = 0., work[i__3].i = 0.;
i__3 = n * 3;
d__1 = z_abs(&ctemp);
z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
zlarnd_(&z__1, &c__3, &iseed[1]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__3 = n + n * z_dim1;
z__[i__3].r = 1., z__[i__3].i = 0.;
i__3 = n << 1;
work[i__3].r = 0., work[i__3].i = 0.;
i__3 = n << 2;
d__1 = z_abs(&ctemp);
z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* Apply the diagonal matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
i__5 = jr + jc * a_dim1;
i__6 = (n << 1) + jr;
d_cnjg(&z__3, &work[n * 3 + jc]);
z__2.r = work[i__6].r * z__3.r - work[i__6].i *
z__3.i, z__2.i = work[i__6].r * z__3.i +
work[i__6].i * z__3.r;
i__7 = jr + jc * a_dim1;
z__1.r = z__2.r * a[i__7].r - z__2.i * a[i__7].i,
z__1.i = z__2.r * a[i__7].i + z__2.i * a[
i__7].r;
a[i__5].r = z__1.r, a[i__5].i = z__1.i;
i__5 = jr + jc * b_dim1;
i__6 = (n << 1) + jr;
d_cnjg(&z__3, &work[n * 3 + jc]);
z__2.r = work[i__6].r * z__3.r - work[i__6].i *
z__3.i, z__2.i = work[i__6].r * z__3.i +
work[i__6].i * z__3.r;
i__7 = jr + jc * b_dim1;
z__1.r = z__2.r * b[i__7].r - z__2.i * b[i__7].i,
z__1.i = z__2.r * b[i__7].i + z__2.i * b[
i__7].r;
b[i__5].r = z__1.r, b[i__5].i = z__1.i;
/* L60: */
}
/* L70: */
}
i__3 = n - 1;
zunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &a[a_offset], lda, &work[(n << 1) + 1], &
iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
zunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &a[a_offset], lda, &work[(n << 1) +
1], &iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
zunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &b[b_offset], lda, &work[(n << 1) + 1], &
iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
zunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &b[b_offset], lda, &work[(n << 1) +
1], &iinfo);
if (iinfo != 0) {
goto L100;
}
}
} else {
/* Random matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
i__5 = jr + jc * a_dim1;
i__6 = kamagn[jtype - 1];
zlarnd_(&z__2, &c__4, &iseed[1]);
z__1.r = rmagn[i__6] * z__2.r, z__1.i = rmagn[i__6] *
z__2.i;
a[i__5].r = z__1.r, a[i__5].i = z__1.i;
i__5 = jr + jc * b_dim1;
i__6 = kbmagn[jtype - 1];
zlarnd_(&z__2, &c__4, &iseed[1]);
z__1.r = rmagn[i__6] * z__2.r, z__1.i = rmagn[i__6] *
z__2.i;
b[i__5].r = z__1.r, b[i__5].i = z__1.i;
/* L80: */
}
/* L90: */
}
}
L100:
if (iinfo != 0) {
io___41.ciunit = *nounit;
s_wsfe(&io___41);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L110:
for (i__ = 1; i__ <= 13; ++i__) {
result[i__] = -1.;
/* L120: */
}
/* Test with and without sorting of eigenvalues */
for (isort = 0; isort <= 1; ++isort) {
if (isort == 0) {
*(unsigned char *)sort = 'N';
rsub = 0;
} else {
*(unsigned char *)sort = 'S';
rsub = 5;
}
/* Call ZGGES to compute H, T, Q, Z, alpha, and beta. */
zlacpy_("Full", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
zlacpy_("Full", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
ntest = rsub + 1 + isort;
result[rsub + 1 + isort] = ulpinv;
zgges_("V", "V", sort, (L_fp)zlctes_, &n, &s[s_offset], lda, &
t[t_offset], lda, &sdim, &alpha[1], &beta[1], &q[
q_offset], ldq, &z__[z_offset], ldq, &work[1], lwork,
&rwork[1], &bwork[1], &iinfo);
if (iinfo != 0 && iinfo != n + 2) {
result[rsub + 1 + isort] = ulpinv;
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, "ZGGES", (ftnlen)5);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
goto L160;
}
ntest = rsub + 4;
/* Do tests 1--4 (or tests 7--9 when reordering ) */
if (isort == 0) {
zget51_(&c__1, &n, &a[a_offset], lda, &s[s_offset], lda, &
q[q_offset], ldq, &z__[z_offset], ldq, &work[1], &
rwork[1], &result[1]);
zget51_(&c__1, &n, &b[b_offset], lda, &t[t_offset], lda, &
q[q_offset], ldq, &z__[z_offset], ldq, &work[1], &
rwork[1], &result[2]);
} else {
zget54_(&n, &a[a_offset], lda, &b[b_offset], lda, &s[
s_offset], lda, &t[t_offset], lda, &q[q_offset],
ldq, &z__[z_offset], ldq, &work[1], &result[rsub
+ 2]);
}
zget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &q[
q_offset], ldq, &q[q_offset], ldq, &work[1], &rwork[1]
, &result[rsub + 3]);
zget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &z__[
z_offset], ldq, &z__[z_offset], ldq, &work[1], &rwork[
1], &result[rsub + 4]);
/* Do test 5 and 6 (or Tests 10 and 11 when reordering): */
/* check Schur form of A and compare eigenvalues with */
/* diagonals. */
ntest = rsub + 6;
temp1 = 0.;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
ilabad = FALSE_;
i__4 = j;
i__5 = j + j * s_dim1;
z__2.r = alpha[i__4].r - s[i__5].r, z__2.i = alpha[i__4]
.i - s[i__5].i;
z__1.r = z__2.r, z__1.i = z__2.i;
i__6 = j;
i__7 = j + j * t_dim1;
z__4.r = beta[i__6].r - t[i__7].r, z__4.i = beta[i__6].i
- t[i__7].i;
z__3.r = z__4.r, z__3.i = z__4.i;
/* Computing MAX */
i__8 = j;
i__9 = j + j * s_dim1;
d__13 = safmin, d__14 = (d__1 = alpha[i__8].r, abs(d__1))
+ (d__2 = d_imag(&alpha[j]), abs(d__2)), d__13 =
max(d__13,d__14), d__14 = (d__3 = s[i__9].r, abs(
d__3)) + (d__4 = d_imag(&s[j + j * s_dim1]), abs(
d__4));
/* Computing MAX */
i__10 = j;
i__11 = j + j * t_dim1;
d__15 = safmin, d__16 = (d__5 = beta[i__10].r, abs(d__5))
+ (d__6 = d_imag(&beta[j]), abs(d__6)), d__15 =
max(d__15,d__16), d__16 = (d__7 = t[i__11].r, abs(
d__7)) + (d__8 = d_imag(&t[j + j * t_dim1]), abs(
d__8));
temp2 = (((d__9 = z__1.r, abs(d__9)) + (d__10 = d_imag(&
z__1), abs(d__10))) / max(d__13,d__14) + ((d__11 =
z__3.r, abs(d__11)) + (d__12 = d_imag(&z__3),
abs(d__12))) / max(d__15,d__16)) / ulp;
if (j < n) {
i__4 = j + 1 + j * s_dim1;
if (s[i__4].r != 0. || s[i__4].i != 0.) {
ilabad = TRUE_;
result[rsub + 5] = ulpinv;
}
}
if (j > 1) {
i__4 = j + (j - 1) * s_dim1;
if (s[i__4].r != 0. || s[i__4].i != 0.) {
ilabad = TRUE_;
result[rsub + 5] = ulpinv;
}
}
temp1 = max(temp1,temp2);
if (ilabad) {
io___51.ciunit = *nounit;
s_wsfe(&io___51);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
e_wsfe();
}
/* L130: */
}
result[rsub + 6] = temp1;
if (isort >= 1) {
/* Do test 12 */
ntest = 12;
result[12] = 0.;
knteig = 0;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
if (zlctes_(&alpha[i__], &beta[i__])) {
++knteig;
}
/* L140: */
}
if (sdim != knteig) {
result[13] = ulpinv;
}
}
/* L150: */
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L160:
ntestt += ntest;
/* Print out tests which fail. */
i__3 = ntest;
for (jr = 1; jr <= i__3; ++jr) {
if (result[jr] >= *thresh) {
/* If this is the first test to fail, */
/* print a header to the data file. */
if (nerrs == 0) {
io___53.ciunit = *nounit;
s_wsfe(&io___53);
do_fio(&c__1, "ZGS", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___54.ciunit = *nounit;
s_wsfe(&io___54);
e_wsfe();
io___55.ciunit = *nounit;
s_wsfe(&io___55);
e_wsfe();
io___56.ciunit = *nounit;
s_wsfe(&io___56);
do_fio(&c__1, "Unitary", (ftnlen)7);
e_wsfe();
/* Tests performed */
io___57.ciunit = *nounit;
s_wsfe(&io___57);
do_fio(&c__1, "unitary", (ftnlen)7);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
for (j = 1; j <= 8; ++j) {
do_fio(&c__1, "'", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
if (result[jr] < 1e4) {
io___58.ciunit = *nounit;
s_wsfe(&io___58);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
doublereal));
e_wsfe();
} else {
io___59.ciunit = *nounit;
s_wsfe(&io___59);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
}
/* L170: */
}
L180:
;
}
/* L190: */
}
/* Summary */
alasvm_("ZGS", nounit, &nerrs, &ntestt, &c__0);
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
return 0;
/* End of ZDRGES */
} /* zdrges_ */
/* Subroutine */ int ztrevc_(char *side, char *howmny, logical *select,
integer *n, doublecomplex *t, integer *ldt, doublecomplex *vl,
integer *ldvl, doublecomplex *vr, integer *ldvr, integer *mm, integer
*m, doublecomplex *work, doublereal *rwork, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
ZTREVC computes some or all of the right and/or left eigenvectors of
a complex upper triangular matrix T.
The right eigenvector x and the left eigenvector y of T corresponding
to an eigenvalue w are defined by:
T*x = w*x, y'*T = w*y'
where y' denotes the conjugate transpose of the vector y.
If all eigenvectors are requested, the routine may either return the
matrices X and/or Y of right or left eigenvectors of T, or the
products Q*X and/or Q*Y, where Q is an input unitary
matrix. If T was obtained from the Schur factorization of an
original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of
right or left eigenvectors of A.
Arguments
=========
SIDE (input) CHARACTER*1
= 'R': compute right eigenvectors only;
= 'L': compute left eigenvectors only;
= 'B': compute both right and left eigenvectors.
HOWMNY (input) CHARACTER*1
= 'A': compute all right and/or left eigenvectors;
= 'B': compute all right and/or left eigenvectors,
and backtransform them using the input matrices
supplied in VR and/or VL;
= 'S': compute selected right and/or left eigenvectors,
specified by the logical array SELECT.
SELECT (input) LOGICAL array, dimension (N)
If HOWMNY = 'S', SELECT specifies the eigenvectors to be
computed.
If HOWMNY = 'A' or 'B', SELECT is not referenced.
To select the eigenvector corresponding to the j-th
eigenvalue, SELECT(j) must be set to .TRUE..
N (input) INTEGER
The order of the matrix T. N >= 0.
T (input/output) COMPLEX*16 array, dimension (LDT,N)
The upper triangular matrix T. T is modified, but restored
on exit.
LDT (input) INTEGER
The leading dimension of the array T. LDT >= max(1,N).
VL (input/output) COMPLEX*16 array, dimension (LDVL,MM)
On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
contain an N-by-N matrix Q (usually the unitary matrix Q of
Schur vectors returned by ZHSEQR).
On exit, if SIDE = 'L' or 'B', VL contains:
if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
VL is lower triangular. The i-th column
VL(i) of VL is the eigenvector corresponding
to T(i,i).
if HOWMNY = 'B', the matrix Q*Y;
if HOWMNY = 'S', the left eigenvectors of T specified by
SELECT, stored consecutively in the columns
of VL, in the same order as their
eigenvalues.
If SIDE = 'R', VL is not referenced.
LDVL (input) INTEGER
The leading dimension of the array VL. LDVL >= max(1,N) if
SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
VR (input/output) COMPLEX*16 array, dimension (LDVR,MM)
On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
contain an N-by-N matrix Q (usually the unitary matrix Q of
Schur vectors returned by ZHSEQR).
On exit, if SIDE = 'R' or 'B', VR contains:
if HOWMNY = 'A', the matrix X of right eigenvectors of T;
VR is upper triangular. The i-th column
VR(i) of VR is the eigenvector corresponding
to T(i,i).
if HOWMNY = 'B', the matrix Q*X;
if HOWMNY = 'S', the right eigenvectors of T specified by
SELECT, stored consecutively in the columns
of VR, in the same order as their
eigenvalues.
If SIDE = 'L', VR is not referenced.
LDVR (input) INTEGER
The leading dimension of the array VR. LDVR >= max(1,N) if
SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
MM (input) INTEGER
The number of columns in the arrays VL and/or VR. MM >= M.
M (output) INTEGER
The number of columns in the arrays VL and/or VR actually
used to store the eigenvectors. If HOWMNY = 'A' or 'B', M
is set to N. Each selected eigenvector occupies one
column.
WORK (workspace) COMPLEX*16 array, dimension (2*N)
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Further Details
===============
The algorithm used in this program is basically backward (forward)
substitution, with scaling to make the the code robust against
possible overflow.
Each eigenvector is normalized so that the element of largest
magnitude has magnitude 1; here the magnitude of a complex number
(x,y) is taken to be |x| + |y|.
=====================================================================
Decode and test the input parameters
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b2 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static logical allv;
static doublereal unfl, ovfl, smin;
static logical over;
static integer i__, j, k;
static doublereal scale;
extern logical lsame_(char *, char *);
static doublereal remax;
static logical leftv, bothv;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static logical somev;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
static integer ii, ki;
extern doublereal dlamch_(char *);
static integer is;
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *);
extern integer izamax_(integer *, doublecomplex *, integer *);
static logical rightv;
extern doublereal dzasum_(integer *, doublecomplex *, integer *);
static doublereal smlnum;
extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, doublereal *, integer *);
static doublereal ulp;
#define t_subscr(a_1,a_2) (a_2)*t_dim1 + a_1
#define t_ref(a_1,a_2) t[t_subscr(a_1,a_2)]
#define vl_subscr(a_1,a_2) (a_2)*vl_dim1 + a_1
#define vl_ref(a_1,a_2) vl[vl_subscr(a_1,a_2)]
#define vr_subscr(a_1,a_2) (a_2)*vr_dim1 + a_1
#define vr_ref(a_1,a_2) vr[vr_subscr(a_1,a_2)]
--select;
t_dim1 = *ldt;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1 * 1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1 * 1;
vr -= vr_offset;
--work;
--rwork;
/* Function Body */
bothv = lsame_(side, "B");
rightv = lsame_(side, "R") || bothv;
leftv = lsame_(side, "L") || bothv;
allv = lsame_(howmny, "A");
over = lsame_(howmny, "B");
somev = lsame_(howmny, "S");
/* Set M to the number of columns required to store the selected
eigenvectors. */
if (somev) {
*m = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (select[j]) {
++(*m);
}
/* L10: */
}
} else {
*m = *n;
}
*info = 0;
if (! rightv && ! leftv) {
*info = -1;
} else if (! allv && ! over && ! somev) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*ldt < max(1,*n)) {
*info = -6;
} else if (*ldvl < 1 || leftv && *ldvl < *n) {
*info = -8;
} else if (*ldvr < 1 || rightv && *ldvr < *n) {
*info = -10;
} else if (*mm < *m) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTREVC", &i__1);
return 0;
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
/* Set the constants to control overflow. */
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Precision");
smlnum = unfl * (*n / ulp);
/* Store the diagonal elements of T in working array WORK. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + *n;
i__3 = t_subscr(i__, i__);
work[i__2].r = t[i__3].r, work[i__2].i = t[i__3].i;
/* L20: */
}
/* Compute 1-norm of each column of strictly upper triangular
part of T to control overflow in triangular solver. */
rwork[1] = 0.;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
i__2 = j - 1;
rwork[j] = dzasum_(&i__2, &t_ref(1, j), &c__1);
/* L30: */
}
if (rightv) {
/* Compute right eigenvectors. */
is = *m;
for (ki = *n; ki >= 1; --ki) {
if (somev) {
if (! select[ki]) {
goto L80;
}
}
/* Computing MAX */
i__1 = t_subscr(ki, ki);
d__3 = ulp * ((d__1 = t[i__1].r, abs(d__1)) + (d__2 = d_imag(&
t_ref(ki, ki)), abs(d__2)));
smin = max(d__3,smlnum);
work[1].r = 1., work[1].i = 0.;
/* Form right-hand side. */
i__1 = ki - 1;
for (k = 1; k <= i__1; ++k) {
i__2 = k;
i__3 = t_subscr(k, ki);
z__1.r = -t[i__3].r, z__1.i = -t[i__3].i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L40: */
}
/* Solve the triangular system:
(T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK. */
i__1 = ki - 1;
for (k = 1; k <= i__1; ++k) {
i__2 = t_subscr(k, k);
i__3 = t_subscr(k, k);
i__4 = t_subscr(ki, ki);
z__1.r = t[i__3].r - t[i__4].r, z__1.i = t[i__3].i - t[i__4]
.i;
t[i__2].r = z__1.r, t[i__2].i = z__1.i;
i__2 = t_subscr(k, k);
if ((d__1 = t[i__2].r, abs(d__1)) + (d__2 = d_imag(&t_ref(k,
k)), abs(d__2)) < smin) {
i__3 = t_subscr(k, k);
t[i__3].r = smin, t[i__3].i = 0.;
}
/* L50: */
}
if (ki > 1) {
i__1 = ki - 1;
zlatrs_("Upper", "No transpose", "Non-unit", "Y", &i__1, &t[
t_offset], ldt, &work[1], &scale, &rwork[1], info);
i__1 = ki;
work[i__1].r = scale, work[i__1].i = 0.;
}
/* Copy the vector x or Q*x to VR and normalize. */
if (! over) {
zcopy_(&ki, &work[1], &c__1, &vr_ref(1, is), &c__1);
ii = izamax_(&ki, &vr_ref(1, is), &c__1);
i__1 = vr_subscr(ii, is);
remax = 1. / ((d__1 = vr[i__1].r, abs(d__1)) + (d__2 = d_imag(
&vr_ref(ii, is)), abs(d__2)));
zdscal_(&ki, &remax, &vr_ref(1, is), &c__1);
i__1 = *n;
for (k = ki + 1; k <= i__1; ++k) {
i__2 = vr_subscr(k, is);
vr[i__2].r = 0., vr[i__2].i = 0.;
/* L60: */
}
} else {
if (ki > 1) {
i__1 = ki - 1;
z__1.r = scale, z__1.i = 0.;
zgemv_("N", n, &i__1, &c_b2, &vr[vr_offset], ldvr, &work[
1], &c__1, &z__1, &vr_ref(1, ki), &c__1);
}
ii = izamax_(n, &vr_ref(1, ki), &c__1);
i__1 = vr_subscr(ii, ki);
remax = 1. / ((d__1 = vr[i__1].r, abs(d__1)) + (d__2 = d_imag(
&vr_ref(ii, ki)), abs(d__2)));
zdscal_(n, &remax, &vr_ref(1, ki), &c__1);
}
/* Set back the original diagonal elements of T. */
i__1 = ki - 1;
for (k = 1; k <= i__1; ++k) {
i__2 = t_subscr(k, k);
i__3 = k + *n;
t[i__2].r = work[i__3].r, t[i__2].i = work[i__3].i;
/* L70: */
}
--is;
L80:
;
}
}
if (leftv) {
/* Compute left eigenvectors. */
is = 1;
i__1 = *n;
for (ki = 1; ki <= i__1; ++ki) {
if (somev) {
if (! select[ki]) {
goto L130;
}
}
/* Computing MAX */
i__2 = t_subscr(ki, ki);
d__3 = ulp * ((d__1 = t[i__2].r, abs(d__1)) + (d__2 = d_imag(&
t_ref(ki, ki)), abs(d__2)));
smin = max(d__3,smlnum);
i__2 = *n;
work[i__2].r = 1., work[i__2].i = 0.;
/* Form right-hand side. */
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
i__3 = k;
d_cnjg(&z__2, &t_ref(ki, k));
z__1.r = -z__2.r, z__1.i = -z__2.i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L90: */
}
/* Solve the triangular system:
(T(KI+1:N,KI+1:N) - T(KI,KI))'*X = SCALE*WORK. */
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
i__3 = t_subscr(k, k);
i__4 = t_subscr(k, k);
i__5 = t_subscr(ki, ki);
z__1.r = t[i__4].r - t[i__5].r, z__1.i = t[i__4].i - t[i__5]
.i;
t[i__3].r = z__1.r, t[i__3].i = z__1.i;
i__3 = t_subscr(k, k);
if ((d__1 = t[i__3].r, abs(d__1)) + (d__2 = d_imag(&t_ref(k,
k)), abs(d__2)) < smin) {
i__4 = t_subscr(k, k);
t[i__4].r = smin, t[i__4].i = 0.;
}
/* L100: */
}
if (ki < *n) {
i__2 = *n - ki;
zlatrs_("Upper", "Conjugate transpose", "Non-unit", "Y", &
i__2, &t_ref(ki + 1, ki + 1), ldt, &work[ki + 1], &
scale, &rwork[1], info);
i__2 = ki;
work[i__2].r = scale, work[i__2].i = 0.;
}
/* Copy the vector x or Q*x to VL and normalize. */
if (! over) {
i__2 = *n - ki + 1;
zcopy_(&i__2, &work[ki], &c__1, &vl_ref(ki, is), &c__1);
i__2 = *n - ki + 1;
ii = izamax_(&i__2, &vl_ref(ki, is), &c__1) + ki - 1;
i__2 = vl_subscr(ii, is);
remax = 1. / ((d__1 = vl[i__2].r, abs(d__1)) + (d__2 = d_imag(
&vl_ref(ii, is)), abs(d__2)));
i__2 = *n - ki + 1;
zdscal_(&i__2, &remax, &vl_ref(ki, is), &c__1);
i__2 = ki - 1;
for (k = 1; k <= i__2; ++k) {
i__3 = vl_subscr(k, is);
vl[i__3].r = 0., vl[i__3].i = 0.;
/* L110: */
}
} else {
if (ki < *n) {
i__2 = *n - ki;
z__1.r = scale, z__1.i = 0.;
zgemv_("N", n, &i__2, &c_b2, &vl_ref(1, ki + 1), ldvl, &
work[ki + 1], &c__1, &z__1, &vl_ref(1, ki), &c__1);
}
ii = izamax_(n, &vl_ref(1, ki), &c__1);
i__2 = vl_subscr(ii, ki);
remax = 1. / ((d__1 = vl[i__2].r, abs(d__1)) + (d__2 = d_imag(
&vl_ref(ii, ki)), abs(d__2)));
zdscal_(n, &remax, &vl_ref(1, ki), &c__1);
}
/* Set back the original diagonal elements of T. */
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
i__3 = t_subscr(k, k);
i__4 = k + *n;
t[i__3].r = work[i__4].r, t[i__3].i = work[i__4].i;
/* L120: */
}
++is;
L130:
;
}
}
return 0;
/* End of ZTREVC */
} /* ztrevc_ */
/* Subroutine */ int zhgeqz_(char *job, char *compq, char *compz, integer *n,
integer *ilo, integer *ihi, doublecomplex *a, integer *lda,
doublecomplex *b, integer *ldb, doublecomplex *alpha, doublecomplex *
beta, doublecomplex *q, integer *ldq, doublecomplex *z__, integer *
ldz, doublecomplex *work, integer *lwork, doublereal *rwork, integer *
info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
z_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
/* Builtin functions */
double z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
double d_imag(doublecomplex *);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *), pow_zi(
doublecomplex *, doublecomplex *, integer *), z_sqrt(
doublecomplex *, doublecomplex *);
/* Local variables */
static doublereal absb, atol, btol, temp, opst;
extern /* Subroutine */ int zrot_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublecomplex *);
static doublereal temp2, c__;
static integer j;
static doublecomplex s, t;
extern logical lsame_(char *, char *);
static doublecomplex ctemp;
static integer iiter, ilast, jiter;
static doublereal anorm;
static integer maxit;
static doublereal bnorm;
static doublecomplex shift;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
static doublereal tempr;
static doublecomplex ctemp2, ctemp3;
static logical ilazr2;
static integer jc, in;
static doublereal ascale, bscale;
static doublecomplex u12;
extern doublereal dlamch_(char *);
static integer jr, nq;
static doublecomplex signbc;
static integer nz;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublecomplex eshift;
static logical ilschr;
static integer icompq, ilastm;
static doublecomplex rtdisc;
static integer ischur;
extern doublereal zlanhs_(char *, integer *, doublecomplex *, integer *,
doublereal *);
static logical ilazro;
static integer icompz, ifirst;
extern /* Subroutine */ int zlartg_(doublecomplex *, doublecomplex *,
doublereal *, doublecomplex *, doublecomplex *);
static integer ifrstm;
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
static integer istart;
static logical lquery;
static doublecomplex ad11, ad12, ad21, ad22;
static integer jch;
static logical ilq, ilz;
static doublereal ulp;
static doublecomplex abi22;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1
#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]
#define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1
#define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)]
/* -- LAPACK routine (instrumented to count operations, version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
----------------------- Begin Timing Code ------------------------
Common block to return operation count and iteration count
ITCNT is initialized to 0, OPS is only incremented
OPST is used to accumulate small contributions to OPS
to avoid roundoff error
------------------------ End Timing Code -------------------------
Purpose
=======
ZHGEQZ implements a single-shift version of the QZ
method for finding the generalized eigenvalues w(i)=ALPHA(i)/BETA(i)
of the equation
det( A - w(i) B ) = 0
If JOB='S', then the pair (A,B) is simultaneously
reduced to Schur form (i.e., A and B are both upper triangular) by
applying one unitary tranformation (usually called Q) on the left and
another (usually called Z) on the right. The diagonal elements of
A are then ALPHA(1),...,ALPHA(N), and of B are BETA(1),...,BETA(N).
If JOB='S' and COMPQ and COMPZ are 'V' or 'I', then the unitary
transformations used to reduce (A,B) are accumulated into the arrays
Q and Z s.t.:
Q(in) A(in) Z(in)* = Q(out) A(out) Z(out)*
Q(in) B(in) Z(in)* = Q(out) B(out) Z(out)*
Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix
Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973),
pp. 241--256.
Arguments
=========
JOB (input) CHARACTER*1
= 'E': compute only ALPHA and BETA. A and B will not
necessarily be put into generalized Schur form.
= 'S': put A and B into generalized Schur form, as well
as computing ALPHA and BETA.
COMPQ (input) CHARACTER*1
= 'N': do not modify Q.
= 'V': multiply the array Q on the right by the conjugate
transpose of the unitary tranformation that is
applied to the left side of A and B to reduce them
to Schur form.
= 'I': like COMPQ='V', except that Q will be initialized to
the identity first.
COMPZ (input) CHARACTER*1
= 'N': do not modify Z.
= 'V': multiply the array Z on the right by the unitary
tranformation that is applied to the right side of
A and B to reduce them to Schur form.
= 'I': like COMPZ='V', except that Z will be initialized to
the identity first.
N (input) INTEGER
The order of the matrices A, B, Q, and Z. N >= 0.
ILO (input) INTEGER
IHI (input) INTEGER
It is assumed that A is already upper triangular in rows and
columns 1:ILO-1 and IHI+1:N.
1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
A (input/output) COMPLEX*16 array, dimension (LDA, N)
On entry, the N-by-N upper Hessenberg matrix A. Elements
below the subdiagonal must be zero.
If JOB='S', then on exit A and B will have been
simultaneously reduced to upper triangular form.
If JOB='E', then on exit A will have been destroyed.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max( 1, N ).
B (input/output) COMPLEX*16 array, dimension (LDB, N)
On entry, the N-by-N upper triangular matrix B. Elements
below the diagonal must be zero.
If JOB='S', then on exit A and B will have been
simultaneously reduced to upper triangular form.
If JOB='E', then on exit B will have been destroyed.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max( 1, N ).
ALPHA (output) COMPLEX*16 array, dimension (N)
The diagonal elements of A when the pair (A,B) has been
reduced to Schur form. ALPHA(i)/BETA(i) i=1,...,N
are the generalized eigenvalues.
BETA (output) COMPLEX*16 array, dimension (N)
The diagonal elements of B when the pair (A,B) has been
reduced to Schur form. ALPHA(i)/BETA(i) i=1,...,N
are the generalized eigenvalues. A and B are normalized
so that BETA(1),...,BETA(N) are non-negative real numbers.
Q (input/output) COMPLEX*16 array, dimension (LDQ, N)
If COMPQ='N', then Q will not be referenced.
If COMPQ='V' or 'I', then the conjugate transpose of the
unitary transformations which are applied to A and B on
the left will be applied to the array Q on the right.
LDQ (input) INTEGER
The leading dimension of the array Q. LDQ >= 1.
If COMPQ='V' or 'I', then LDQ >= N.
Z (input/output) COMPLEX*16 array, dimension (LDZ, N)
If COMPZ='N', then Z will not be referenced.
If COMPZ='V' or 'I', then the unitary transformations which
are applied to A and B on the right will be applied to the
array Z on the right.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1.
If COMPZ='V' or 'I', then LDZ >= N.
WORK (workspace/output) COMPLEX*16 array, dimension (LWORK)
On exit, if INFO >= 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= max(1,N).
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
= 1,...,N: the QZ iteration did not converge. (A,B) is not
in Schur form, but ALPHA(i) and BETA(i),
i=INFO+1,...,N should be correct.
= N+1,...,2*N: the shift calculation failed. (A,B) is not
in Schur form, but ALPHA(i) and BETA(i),
i=INFO-N+1,...,N should be correct.
> 2*N: various "impossible" errors.
Further Details
===============
We assume that complex ABS works as long as its value is less than
overflow.
=====================================================================
----------------------- Begin Timing Code ------------------------
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--alpha;
--beta;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
--rwork;
/* Function Body */
latime_1.itcnt = 0.;
/* ------------------------ End Timing Code -------------------------
Decode JOB, COMPQ, COMPZ */
if (lsame_(job, "E")) {
ilschr = FALSE_;
ischur = 1;
} else if (lsame_(job, "S")) {
ilschr = TRUE_;
ischur = 2;
} else {
ischur = 0;
}
if (lsame_(compq, "N")) {
ilq = FALSE_;
icompq = 1;
nq = 0;
} else if (lsame_(compq, "V")) {
ilq = TRUE_;
icompq = 2;
nq = *n;
} else if (lsame_(compq, "I")) {
ilq = TRUE_;
icompq = 3;
nq = *n;
} else {
icompq = 0;
}
if (lsame_(compz, "N")) {
ilz = FALSE_;
icompz = 1;
nz = 0;
} else if (lsame_(compz, "V")) {
ilz = TRUE_;
icompz = 2;
nz = *n;
} else if (lsame_(compz, "I")) {
ilz = TRUE_;
icompz = 3;
nz = *n;
} else {
icompz = 0;
}
/* Check Argument Values */
*info = 0;
i__1 = max(1,*n);
work[1].r = (doublereal) i__1, work[1].i = 0.;
lquery = *lwork == -1;
if (ischur == 0) {
*info = -1;
} else if (icompq == 0) {
*info = -2;
} else if (icompz == 0) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*ilo < 1) {
*info = -5;
} else if (*ihi > *n || *ihi < *ilo - 1) {
*info = -6;
} else if (*lda < *n) {
*info = -8;
} else if (*ldb < *n) {
*info = -10;
} else if (*ldq < 1 || ilq && *ldq < *n) {
*info = -14;
} else if (*ldz < 1 || ilz && *ldz < *n) {
*info = -16;
} else if (*lwork < max(1,*n) && ! lquery) {
*info = -18;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHGEQZ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible
WORK( 1 ) = CMPLX( 1 ) */
if (*n <= 0) {
work[1].r = 1., work[1].i = 0.;
return 0;
}
/* Initialize Q and Z */
if (icompq == 3) {
zlaset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq);
}
if (icompz == 3) {
zlaset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
}
/* Machine Constants */
in = *ihi + 1 - *ilo;
safmin = dlamch_("S");
ulp = dlamch_("E") * dlamch_("B");
anorm = zlanhs_("F", &in, &a_ref(*ilo, *ilo), lda, &rwork[1]);
bnorm = zlanhs_("F", &in, &b_ref(*ilo, *ilo), ldb, &rwork[1]);
/* Computing MAX */
d__1 = safmin, d__2 = ulp * anorm;
atol = max(d__1,d__2);
/* Computing MAX */
d__1 = safmin, d__2 = ulp * bnorm;
btol = max(d__1,d__2);
ascale = 1. / max(safmin,anorm);
bscale = 1. / max(safmin,bnorm);
/* ---------------------- Begin Timing Code -------------------------
Count ops for norms, etc. */
opst = 0.;
/* Computing 2nd power */
i__1 = *n;
latime_1.ops += (doublereal) ((i__1 * i__1 << 2) + *n * 12 - 5);
/* ----------------------- End Timing Code --------------------------
Set Eigenvalues IHI+1:N */
i__1 = *n;
for (j = *ihi + 1; j <= i__1; ++j) {
absb = z_abs(&b_ref(j, j));
if (absb > safmin) {
i__2 = b_subscr(j, j);
z__2.r = b[i__2].r / absb, z__2.i = b[i__2].i / absb;
d_cnjg(&z__1, &z__2);
signbc.r = z__1.r, signbc.i = z__1.i;
i__2 = b_subscr(j, j);
b[i__2].r = absb, b[i__2].i = 0.;
if (ilschr) {
i__2 = j - 1;
zscal_(&i__2, &signbc, &b_ref(1, j), &c__1);
zscal_(&j, &signbc, &a_ref(1, j), &c__1);
/* ----------------- Begin Timing Code --------------------- */
opst += (doublereal) ((j - 1) * 12);
/* ------------------ End Timing Code ---------------------- */
} else {
i__2 = a_subscr(j, j);
i__3 = a_subscr(j, j);
z__1.r = a[i__3].r * signbc.r - a[i__3].i * signbc.i, z__1.i =
a[i__3].r * signbc.i + a[i__3].i * signbc.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
if (ilz) {
zscal_(n, &signbc, &z___ref(1, j), &c__1);
}
/* ------------------- Begin Timing Code ---------------------- */
opst += (doublereal) (nz * 6 + 13);
/* -------------------- End Timing Code ----------------------- */
} else {
i__2 = b_subscr(j, j);
b[i__2].r = 0., b[i__2].i = 0.;
}
i__2 = j;
i__3 = a_subscr(j, j);
alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i;
i__2 = j;
i__3 = b_subscr(j, j);
beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i;
/* L10: */
}
/* If IHI < ILO, skip QZ steps */
if (*ihi < *ilo) {
goto L190;
}
/* MAIN QZ ITERATION LOOP
Initialize dynamic indices
Eigenvalues ILAST+1:N have been found.
Column operations modify rows IFRSTM:whatever
Row operations modify columns whatever:ILASTM
If only eigenvalues are being computed, then
IFRSTM is the row of the last splitting row above row ILAST;
this is always at least ILO.
IITER counts iterations since the last eigenvalue was found,
to tell when to use an extraordinary shift.
MAXIT is the maximum number of QZ sweeps allowed. */
ilast = *ihi;
if (ilschr) {
ifrstm = 1;
ilastm = *n;
} else {
ifrstm = *ilo;
ilastm = *ihi;
}
iiter = 0;
eshift.r = 0., eshift.i = 0.;
maxit = (*ihi - *ilo + 1) * 30;
i__1 = maxit;
for (jiter = 1; jiter <= i__1; ++jiter) {
/* Check for too many iterations. */
if (jiter > maxit) {
goto L180;
}
/* Split the matrix if possible.
Two tests:
1: A(j,j-1)=0 or j=ILO
2: B(j,j)=0
Special case: j=ILAST */
if (ilast == *ilo) {
goto L60;
} else {
i__2 = a_subscr(ilast, ilast - 1);
if ((d__1 = a[i__2].r, abs(d__1)) + (d__2 = d_imag(&a_ref(ilast,
ilast - 1)), abs(d__2)) <= atol) {
i__2 = a_subscr(ilast, ilast - 1);
a[i__2].r = 0., a[i__2].i = 0.;
goto L60;
}
}
if (z_abs(&b_ref(ilast, ilast)) <= btol) {
i__2 = b_subscr(ilast, ilast);
b[i__2].r = 0., b[i__2].i = 0.;
goto L50;
}
/* General case: j<ILAST */
i__2 = *ilo;
for (j = ilast - 1; j >= i__2; --j) {
/* Test 1: for A(j,j-1)=0 or j=ILO */
if (j == *ilo) {
ilazro = TRUE_;
} else {
i__3 = a_subscr(j, j - 1);
if ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a_ref(j,
j - 1)), abs(d__2)) <= atol) {
i__3 = a_subscr(j, j - 1);
a[i__3].r = 0., a[i__3].i = 0.;
ilazro = TRUE_;
} else {
ilazro = FALSE_;
}
}
/* Test 2: for B(j,j)=0 */
if (z_abs(&b_ref(j, j)) < btol) {
i__3 = b_subscr(j, j);
b[i__3].r = 0., b[i__3].i = 0.;
/* Test 1a: Check for 2 consecutive small subdiagonals in A */
ilazr2 = FALSE_;
if (! ilazro) {
i__3 = a_subscr(j, j - 1);
i__4 = a_subscr(j + 1, j);
i__5 = a_subscr(j, j);
if (((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&
a_ref(j, j - 1)), abs(d__2))) * (ascale * ((d__3 =
a[i__4].r, abs(d__3)) + (d__4 = d_imag(&a_ref(j
+ 1, j)), abs(d__4)))) <= ((d__5 = a[i__5].r, abs(
d__5)) + (d__6 = d_imag(&a_ref(j, j)), abs(d__6)))
* (ascale * atol)) {
ilazr2 = TRUE_;
}
}
/* If both tests pass (1 & 2), i.e., the leading diagonal
element of B in the block is zero, split a 1x1 block off
at the top. (I.e., at the J-th row/column) The leading
diagonal element of the remainder can also be zero, so
this may have to be done repeatedly. */
if (ilazro || ilazr2) {
i__3 = ilast - 1;
for (jch = j; jch <= i__3; ++jch) {
i__4 = a_subscr(jch, jch);
ctemp.r = a[i__4].r, ctemp.i = a[i__4].i;
zlartg_(&ctemp, &a_ref(jch + 1, jch), &c__, &s, &
a_ref(jch, jch));
i__4 = a_subscr(jch + 1, jch);
a[i__4].r = 0., a[i__4].i = 0.;
i__4 = ilastm - jch;
zrot_(&i__4, &a_ref(jch, jch + 1), lda, &a_ref(jch +
1, jch + 1), lda, &c__, &s);
i__4 = ilastm - jch;
zrot_(&i__4, &b_ref(jch, jch + 1), ldb, &b_ref(jch +
1, jch + 1), ldb, &c__, &s);
if (ilq) {
d_cnjg(&z__1, &s);
zrot_(n, &q_ref(1, jch), &c__1, &q_ref(1, jch + 1)
, &c__1, &c__, &z__1);
}
if (ilazr2) {
i__4 = a_subscr(jch, jch - 1);
i__5 = a_subscr(jch, jch - 1);
z__1.r = c__ * a[i__5].r, z__1.i = c__ * a[i__5]
.i;
a[i__4].r = z__1.r, a[i__4].i = z__1.i;
}
ilazr2 = FALSE_;
/* --------------- Begin Timing Code ----------------- */
opst += (doublereal) ((ilastm - jch) * 40 + 32 + nq *
20);
/* ---------------- End Timing Code ------------------ */
i__4 = b_subscr(jch + 1, jch + 1);
if ((d__1 = b[i__4].r, abs(d__1)) + (d__2 = d_imag(&
b_ref(jch + 1, jch + 1)), abs(d__2)) >= btol)
{
if (jch + 1 >= ilast) {
goto L60;
} else {
ifirst = jch + 1;
goto L70;
}
}
i__4 = b_subscr(jch + 1, jch + 1);
b[i__4].r = 0., b[i__4].i = 0.;
/* L20: */
}
goto L50;
} else {
/* Only test 2 passed -- chase the zero to B(ILAST,ILAST)
Then process as in the case B(ILAST,ILAST)=0 */
i__3 = ilast - 1;
for (jch = j; jch <= i__3; ++jch) {
i__4 = b_subscr(jch, jch + 1);
ctemp.r = b[i__4].r, ctemp.i = b[i__4].i;
zlartg_(&ctemp, &b_ref(jch + 1, jch + 1), &c__, &s, &
b_ref(jch, jch + 1));
i__4 = b_subscr(jch + 1, jch + 1);
b[i__4].r = 0., b[i__4].i = 0.;
if (jch < ilastm - 1) {
i__4 = ilastm - jch - 1;
zrot_(&i__4, &b_ref(jch, jch + 2), ldb, &b_ref(
jch + 1, jch + 2), ldb, &c__, &s);
}
i__4 = ilastm - jch + 2;
zrot_(&i__4, &a_ref(jch, jch - 1), lda, &a_ref(jch +
1, jch - 1), lda, &c__, &s);
if (ilq) {
d_cnjg(&z__1, &s);
zrot_(n, &q_ref(1, jch), &c__1, &q_ref(1, jch + 1)
, &c__1, &c__, &z__1);
}
i__4 = a_subscr(jch + 1, jch);
ctemp.r = a[i__4].r, ctemp.i = a[i__4].i;
zlartg_(&ctemp, &a_ref(jch + 1, jch - 1), &c__, &s, &
a_ref(jch + 1, jch));
i__4 = a_subscr(jch + 1, jch - 1);
a[i__4].r = 0., a[i__4].i = 0.;
i__4 = jch + 1 - ifrstm;
zrot_(&i__4, &a_ref(ifrstm, jch), &c__1, &a_ref(
ifrstm, jch - 1), &c__1, &c__, &s);
i__4 = jch - ifrstm;
zrot_(&i__4, &b_ref(ifrstm, jch), &c__1, &b_ref(
ifrstm, jch - 1), &c__1, &c__, &s);
if (ilz) {
zrot_(n, &z___ref(1, jch), &c__1, &z___ref(1, jch
- 1), &c__1, &c__, &s);
}
/* L30: */
}
/* ---------------- Begin Timing Code ------------------- */
opst += (doublereal) ((ilastm + 1 - ifrstm) * 40 + 64 + (
nq + nz) * 20) * (doublereal) (ilast - j);
/* ----------------- End Timing Code -------------------- */
goto L50;
}
} else if (ilazro) {
/* Only test 1 passed -- work on J:ILAST */
ifirst = j;
goto L70;
}
/* Neither test passed -- try next J
L40: */
}
/* (Drop-through is "impossible") */
*info = (*n << 1) + 1;
goto L210;
/* B(ILAST,ILAST)=0 -- clear A(ILAST,ILAST-1) to split off a
1x1 block. */
L50:
i__2 = a_subscr(ilast, ilast);
ctemp.r = a[i__2].r, ctemp.i = a[i__2].i;
zlartg_(&ctemp, &a_ref(ilast, ilast - 1), &c__, &s, &a_ref(ilast,
ilast));
i__2 = a_subscr(ilast, ilast - 1);
a[i__2].r = 0., a[i__2].i = 0.;
i__2 = ilast - ifrstm;
zrot_(&i__2, &a_ref(ifrstm, ilast), &c__1, &a_ref(ifrstm, ilast - 1),
&c__1, &c__, &s);
i__2 = ilast - ifrstm;
zrot_(&i__2, &b_ref(ifrstm, ilast), &c__1, &b_ref(ifrstm, ilast - 1),
&c__1, &c__, &s);
if (ilz) {
zrot_(n, &z___ref(1, ilast), &c__1, &z___ref(1, ilast - 1), &c__1,
&c__, &s);
}
/* --------------------- Begin Timing Code ----------------------- */
opst += (doublereal) ((ilast - ifrstm) * 40 + 32 + nz * 20);
/* ---------------------- End Timing Code ------------------------
A(ILAST,ILAST-1)=0 -- Standardize B, set ALPHA and BETA */
L60:
absb = z_abs(&b_ref(ilast, ilast));
if (absb > safmin) {
i__2 = b_subscr(ilast, ilast);
z__2.r = b[i__2].r / absb, z__2.i = b[i__2].i / absb;
d_cnjg(&z__1, &z__2);
signbc.r = z__1.r, signbc.i = z__1.i;
i__2 = b_subscr(ilast, ilast);
b[i__2].r = absb, b[i__2].i = 0.;
if (ilschr) {
i__2 = ilast - ifrstm;
zscal_(&i__2, &signbc, &b_ref(ifrstm, ilast), &c__1);
i__2 = ilast + 1 - ifrstm;
zscal_(&i__2, &signbc, &a_ref(ifrstm, ilast), &c__1);
/* ----------------- Begin Timing Code --------------------- */
opst += (doublereal) ((ilast - ifrstm) * 12);
/* ------------------ End Timing Code ---------------------- */
} else {
i__2 = a_subscr(ilast, ilast);
i__3 = a_subscr(ilast, ilast);
z__1.r = a[i__3].r * signbc.r - a[i__3].i * signbc.i, z__1.i =
a[i__3].r * signbc.i + a[i__3].i * signbc.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
if (ilz) {
zscal_(n, &signbc, &z___ref(1, ilast), &c__1);
}
/* ------------------- Begin Timing Code ---------------------- */
opst += (doublereal) (nz * 6 + 13);
/* -------------------- End Timing Code ----------------------- */
} else {
i__2 = b_subscr(ilast, ilast);
b[i__2].r = 0., b[i__2].i = 0.;
}
i__2 = ilast;
i__3 = a_subscr(ilast, ilast);
alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i;
i__2 = ilast;
i__3 = b_subscr(ilast, ilast);
beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i;
/* Go to next block -- exit if finished. */
--ilast;
if (ilast < *ilo) {
goto L190;
}
/* Reset counters */
iiter = 0;
eshift.r = 0., eshift.i = 0.;
if (! ilschr) {
ilastm = ilast;
if (ifrstm > ilast) {
ifrstm = *ilo;
}
}
goto L160;
/* QZ step
This iteration only involves rows/columns IFIRST:ILAST. We
assume IFIRST < ILAST, and that the diagonal of B is non-zero. */
L70:
++iiter;
if (! ilschr) {
ifrstm = ifirst;
}
/* Compute the Shift.
At this point, IFIRST < ILAST, and the diagonal elements of
B(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in
magnitude) */
if (iiter / 10 * 10 != iiter) {
/* The Wilkinson shift (AEP p.512), i.e., the eigenvalue of
the bottom-right 2x2 block of A inv(B) which is nearest to
the bottom-right element.
We factor B as U*D, where U has unit diagonals, and
compute (A*inv(D))*inv(U). */
i__2 = b_subscr(ilast - 1, ilast);
z__2.r = bscale * b[i__2].r, z__2.i = bscale * b[i__2].i;
i__3 = b_subscr(ilast, ilast);
z__3.r = bscale * b[i__3].r, z__3.i = bscale * b[i__3].i;
z_div(&z__1, &z__2, &z__3);
u12.r = z__1.r, u12.i = z__1.i;
i__2 = a_subscr(ilast - 1, ilast - 1);
z__2.r = ascale * a[i__2].r, z__2.i = ascale * a[i__2].i;
i__3 = b_subscr(ilast - 1, ilast - 1);
z__3.r = bscale * b[i__3].r, z__3.i = bscale * b[i__3].i;
z_div(&z__1, &z__2, &z__3);
ad11.r = z__1.r, ad11.i = z__1.i;
i__2 = a_subscr(ilast, ilast - 1);
z__2.r = ascale * a[i__2].r, z__2.i = ascale * a[i__2].i;
i__3 = b_subscr(ilast - 1, ilast - 1);
z__3.r = bscale * b[i__3].r, z__3.i = bscale * b[i__3].i;
z_div(&z__1, &z__2, &z__3);
ad21.r = z__1.r, ad21.i = z__1.i;
i__2 = a_subscr(ilast - 1, ilast);
z__2.r = ascale * a[i__2].r, z__2.i = ascale * a[i__2].i;
i__3 = b_subscr(ilast, ilast);
z__3.r = bscale * b[i__3].r, z__3.i = bscale * b[i__3].i;
z_div(&z__1, &z__2, &z__3);
ad12.r = z__1.r, ad12.i = z__1.i;
i__2 = a_subscr(ilast, ilast);
z__2.r = ascale * a[i__2].r, z__2.i = ascale * a[i__2].i;
i__3 = b_subscr(ilast, ilast);
z__3.r = bscale * b[i__3].r, z__3.i = bscale * b[i__3].i;
z_div(&z__1, &z__2, &z__3);
ad22.r = z__1.r, ad22.i = z__1.i;
z__2.r = u12.r * ad21.r - u12.i * ad21.i, z__2.i = u12.r * ad21.i
+ u12.i * ad21.r;
z__1.r = ad22.r - z__2.r, z__1.i = ad22.i - z__2.i;
abi22.r = z__1.r, abi22.i = z__1.i;
z__2.r = ad11.r + abi22.r, z__2.i = ad11.i + abi22.i;
z__1.r = z__2.r * .5, z__1.i = z__2.i * .5;
t.r = z__1.r, t.i = z__1.i;
pow_zi(&z__4, &t, &c__2);
z__5.r = ad12.r * ad21.r - ad12.i * ad21.i, z__5.i = ad12.r *
ad21.i + ad12.i * ad21.r;
z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
z__6.r = ad11.r * ad22.r - ad11.i * ad22.i, z__6.i = ad11.r *
ad22.i + ad11.i * ad22.r;
z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i;
z_sqrt(&z__1, &z__2);
rtdisc.r = z__1.r, rtdisc.i = z__1.i;
z__1.r = t.r - abi22.r, z__1.i = t.i - abi22.i;
z__2.r = t.r - abi22.r, z__2.i = t.i - abi22.i;
temp = z__1.r * rtdisc.r + d_imag(&z__2) * d_imag(&rtdisc);
if (temp <= 0.) {
z__1.r = t.r + rtdisc.r, z__1.i = t.i + rtdisc.i;
shift.r = z__1.r, shift.i = z__1.i;
} else {
z__1.r = t.r - rtdisc.r, z__1.i = t.i - rtdisc.i;
shift.r = z__1.r, shift.i = z__1.i;
}
/* ------------------- Begin Timing Code ---------------------- */
opst += 116.;
/* -------------------- End Timing Code ----------------------- */
} else {
/* Exceptional shift. Chosen for no particularly good reason. */
i__2 = a_subscr(ilast - 1, ilast);
z__4.r = ascale * a[i__2].r, z__4.i = ascale * a[i__2].i;
i__3 = b_subscr(ilast - 1, ilast - 1);
z__5.r = bscale * b[i__3].r, z__5.i = bscale * b[i__3].i;
z_div(&z__3, &z__4, &z__5);
d_cnjg(&z__2, &z__3);
z__1.r = eshift.r + z__2.r, z__1.i = eshift.i + z__2.i;
eshift.r = z__1.r, eshift.i = z__1.i;
shift.r = eshift.r, shift.i = eshift.i;
/* ------------------- Begin Timing Code ---------------------- */
opst += 15.;
/* -------------------- End Timing Code ----------------------- */
}
/* Now check for two consecutive small subdiagonals. */
i__2 = ifirst + 1;
for (j = ilast - 1; j >= i__2; --j) {
istart = j;
i__3 = a_subscr(j, j);
z__2.r = ascale * a[i__3].r, z__2.i = ascale * a[i__3].i;
i__4 = b_subscr(j, j);
z__4.r = bscale * b[i__4].r, z__4.i = bscale * b[i__4].i;
z__3.r = shift.r * z__4.r - shift.i * z__4.i, z__3.i = shift.r *
z__4.i + shift.i * z__4.r;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
temp = (d__1 = ctemp.r, abs(d__1)) + (d__2 = d_imag(&ctemp), abs(
d__2));
i__3 = a_subscr(j + 1, j);
temp2 = ascale * ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&
a_ref(j + 1, j)), abs(d__2)));
tempr = max(temp,temp2);
if (tempr < 1. && tempr != 0.) {
temp /= tempr;
temp2 /= tempr;
}
i__3 = a_subscr(j, j - 1);
if (((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a_ref(j, j -
1)), abs(d__2))) * temp2 <= temp * atol) {
goto L90;
}
/* L80: */
}
istart = ifirst;
i__2 = a_subscr(ifirst, ifirst);
z__2.r = ascale * a[i__2].r, z__2.i = ascale * a[i__2].i;
i__3 = b_subscr(ifirst, ifirst);
z__4.r = bscale * b[i__3].r, z__4.i = bscale * b[i__3].i;
z__3.r = shift.r * z__4.r - shift.i * z__4.i, z__3.i = shift.r *
z__4.i + shift.i * z__4.r;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
/* --------------------- Begin Timing Code ----------------------- */
opst += -6.;
/* ---------------------- End Timing Code ------------------------ */
L90:
/* Do an implicit-shift QZ sweep.
Initial Q */
i__2 = a_subscr(istart + 1, istart);
z__1.r = ascale * a[i__2].r, z__1.i = ascale * a[i__2].i;
ctemp2.r = z__1.r, ctemp2.i = z__1.i;
/* --------------------- Begin Timing Code ----------------------- */
opst += (doublereal) ((ilast - istart) * 18 + 2);
/* ---------------------- End Timing Code ------------------------ */
zlartg_(&ctemp, &ctemp2, &c__, &s, &ctemp3);
/* Sweep */
i__2 = ilast - 1;
for (j = istart; j <= i__2; ++j) {
if (j > istart) {
i__3 = a_subscr(j, j - 1);
ctemp.r = a[i__3].r, ctemp.i = a[i__3].i;
zlartg_(&ctemp, &a_ref(j + 1, j - 1), &c__, &s, &a_ref(j, j -
1));
i__3 = a_subscr(j + 1, j - 1);
a[i__3].r = 0., a[i__3].i = 0.;
}
i__3 = ilastm;
for (jc = j; jc <= i__3; ++jc) {
i__4 = a_subscr(j, jc);
z__2.r = c__ * a[i__4].r, z__2.i = c__ * a[i__4].i;
i__5 = a_subscr(j + 1, jc);
z__3.r = s.r * a[i__5].r - s.i * a[i__5].i, z__3.i = s.r * a[
i__5].i + s.i * a[i__5].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__4 = a_subscr(j + 1, jc);
d_cnjg(&z__4, &s);
z__3.r = -z__4.r, z__3.i = -z__4.i;
i__5 = a_subscr(j, jc);
z__2.r = z__3.r * a[i__5].r - z__3.i * a[i__5].i, z__2.i =
z__3.r * a[i__5].i + z__3.i * a[i__5].r;
i__6 = a_subscr(j + 1, jc);
z__5.r = c__ * a[i__6].r, z__5.i = c__ * a[i__6].i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
a[i__4].r = z__1.r, a[i__4].i = z__1.i;
i__4 = a_subscr(j, jc);
a[i__4].r = ctemp.r, a[i__4].i = ctemp.i;
i__4 = b_subscr(j, jc);
z__2.r = c__ * b[i__4].r, z__2.i = c__ * b[i__4].i;
i__5 = b_subscr(j + 1, jc);
z__3.r = s.r * b[i__5].r - s.i * b[i__5].i, z__3.i = s.r * b[
i__5].i + s.i * b[i__5].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
ctemp2.r = z__1.r, ctemp2.i = z__1.i;
i__4 = b_subscr(j + 1, jc);
d_cnjg(&z__4, &s);
z__3.r = -z__4.r, z__3.i = -z__4.i;
i__5 = b_subscr(j, jc);
z__2.r = z__3.r * b[i__5].r - z__3.i * b[i__5].i, z__2.i =
z__3.r * b[i__5].i + z__3.i * b[i__5].r;
i__6 = b_subscr(j + 1, jc);
z__5.r = c__ * b[i__6].r, z__5.i = c__ * b[i__6].i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
b[i__4].r = z__1.r, b[i__4].i = z__1.i;
i__4 = b_subscr(j, jc);
b[i__4].r = ctemp2.r, b[i__4].i = ctemp2.i;
/* L100: */
}
if (ilq) {
i__3 = *n;
for (jr = 1; jr <= i__3; ++jr) {
i__4 = q_subscr(jr, j);
z__2.r = c__ * q[i__4].r, z__2.i = c__ * q[i__4].i;
d_cnjg(&z__4, &s);
i__5 = q_subscr(jr, j + 1);
z__3.r = z__4.r * q[i__5].r - z__4.i * q[i__5].i, z__3.i =
z__4.r * q[i__5].i + z__4.i * q[i__5].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__4 = q_subscr(jr, j + 1);
z__3.r = -s.r, z__3.i = -s.i;
i__5 = q_subscr(jr, j);
z__2.r = z__3.r * q[i__5].r - z__3.i * q[i__5].i, z__2.i =
z__3.r * q[i__5].i + z__3.i * q[i__5].r;
i__6 = q_subscr(jr, j + 1);
z__4.r = c__ * q[i__6].r, z__4.i = c__ * q[i__6].i;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
q[i__4].r = z__1.r, q[i__4].i = z__1.i;
i__4 = q_subscr(jr, j);
q[i__4].r = ctemp.r, q[i__4].i = ctemp.i;
/* L110: */
}
}
i__3 = b_subscr(j + 1, j + 1);
ctemp.r = b[i__3].r, ctemp.i = b[i__3].i;
zlartg_(&ctemp, &b_ref(j + 1, j), &c__, &s, &b_ref(j + 1, j + 1));
i__3 = b_subscr(j + 1, j);
b[i__3].r = 0., b[i__3].i = 0.;
/* Computing MIN */
i__4 = j + 2;
i__3 = min(i__4,ilast);
for (jr = ifrstm; jr <= i__3; ++jr) {
i__4 = a_subscr(jr, j + 1);
z__2.r = c__ * a[i__4].r, z__2.i = c__ * a[i__4].i;
i__5 = a_subscr(jr, j);
z__3.r = s.r * a[i__5].r - s.i * a[i__5].i, z__3.i = s.r * a[
i__5].i + s.i * a[i__5].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__4 = a_subscr(jr, j);
d_cnjg(&z__4, &s);
z__3.r = -z__4.r, z__3.i = -z__4.i;
i__5 = a_subscr(jr, j + 1);
z__2.r = z__3.r * a[i__5].r - z__3.i * a[i__5].i, z__2.i =
z__3.r * a[i__5].i + z__3.i * a[i__5].r;
i__6 = a_subscr(jr, j);
z__5.r = c__ * a[i__6].r, z__5.i = c__ * a[i__6].i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
a[i__4].r = z__1.r, a[i__4].i = z__1.i;
i__4 = a_subscr(jr, j + 1);
a[i__4].r = ctemp.r, a[i__4].i = ctemp.i;
/* L120: */
}
i__3 = j;
for (jr = ifrstm; jr <= i__3; ++jr) {
i__4 = b_subscr(jr, j + 1);
z__2.r = c__ * b[i__4].r, z__2.i = c__ * b[i__4].i;
i__5 = b_subscr(jr, j);
z__3.r = s.r * b[i__5].r - s.i * b[i__5].i, z__3.i = s.r * b[
i__5].i + s.i * b[i__5].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__4 = b_subscr(jr, j);
d_cnjg(&z__4, &s);
z__3.r = -z__4.r, z__3.i = -z__4.i;
i__5 = b_subscr(jr, j + 1);
z__2.r = z__3.r * b[i__5].r - z__3.i * b[i__5].i, z__2.i =
z__3.r * b[i__5].i + z__3.i * b[i__5].r;
i__6 = b_subscr(jr, j);
z__5.r = c__ * b[i__6].r, z__5.i = c__ * b[i__6].i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
b[i__4].r = z__1.r, b[i__4].i = z__1.i;
i__4 = b_subscr(jr, j + 1);
b[i__4].r = ctemp.r, b[i__4].i = ctemp.i;
/* L130: */
}
if (ilz) {
i__3 = *n;
for (jr = 1; jr <= i__3; ++jr) {
i__4 = z___subscr(jr, j + 1);
z__2.r = c__ * z__[i__4].r, z__2.i = c__ * z__[i__4].i;
i__5 = z___subscr(jr, j);
z__3.r = s.r * z__[i__5].r - s.i * z__[i__5].i, z__3.i =
s.r * z__[i__5].i + s.i * z__[i__5].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__4 = z___subscr(jr, j);
d_cnjg(&z__4, &s);
z__3.r = -z__4.r, z__3.i = -z__4.i;
i__5 = z___subscr(jr, j + 1);
z__2.r = z__3.r * z__[i__5].r - z__3.i * z__[i__5].i,
z__2.i = z__3.r * z__[i__5].i + z__3.i * z__[i__5]
.r;
i__6 = z___subscr(jr, j);
z__5.r = c__ * z__[i__6].r, z__5.i = c__ * z__[i__6].i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
i__4 = z___subscr(jr, j + 1);
z__[i__4].r = ctemp.r, z__[i__4].i = ctemp.i;
/* L140: */
}
}
/* L150: */
}
/* --------------------- Begin Timing Code ----------------------- */
opst += (doublereal) (ilast - istart) * (doublereal) ((ilastm -
ifrstm) * 40 + 184 + (nq + nz) * 20) - 20;
/* ---------------------- End Timing Code ------------------------ */
L160:
/* --------------------- Begin Timing Code -----------------------
End of iteration -- add in "small" contributions. */
latime_1.ops += opst;
opst = 0.;
/* ---------------------- End Timing Code ------------------------
L170: */
}
/* Drop-through = non-convergence */
L180:
*info = ilast;
/* ---------------------- Begin Timing Code ------------------------- */
latime_1.ops += opst;
opst = 0.;
/* ----------------------- End Timing Code -------------------------- */
goto L210;
/* Successful completion of all QZ steps */
L190:
/* Set Eigenvalues 1:ILO-1 */
i__1 = *ilo - 1;
for (j = 1; j <= i__1; ++j) {
absb = z_abs(&b_ref(j, j));
if (absb > safmin) {
i__2 = b_subscr(j, j);
z__2.r = b[i__2].r / absb, z__2.i = b[i__2].i / absb;
d_cnjg(&z__1, &z__2);
signbc.r = z__1.r, signbc.i = z__1.i;
i__2 = b_subscr(j, j);
b[i__2].r = absb, b[i__2].i = 0.;
if (ilschr) {
i__2 = j - 1;
zscal_(&i__2, &signbc, &b_ref(1, j), &c__1);
zscal_(&j, &signbc, &a_ref(1, j), &c__1);
/* ----------------- Begin Timing Code --------------------- */
opst += (doublereal) ((j - 1) * 12);
/* ------------------ End Timing Code ---------------------- */
} else {
i__2 = a_subscr(j, j);
i__3 = a_subscr(j, j);
z__1.r = a[i__3].r * signbc.r - a[i__3].i * signbc.i, z__1.i =
a[i__3].r * signbc.i + a[i__3].i * signbc.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
if (ilz) {
zscal_(n, &signbc, &z___ref(1, j), &c__1);
}
/* ------------------- Begin Timing Code ---------------------- */
opst += (doublereal) (nz * 6 + 13);
/* -------------------- End Timing Code ----------------------- */
} else {
i__2 = b_subscr(j, j);
b[i__2].r = 0., b[i__2].i = 0.;
}
i__2 = j;
i__3 = a_subscr(j, j);
alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i;
i__2 = j;
i__3 = b_subscr(j, j);
beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i;
/* L200: */
}
/* Normal Termination */
*info = 0;
/* Exit (other than argument error) -- return optimal workspace size */
L210:
/* ---------------------- Begin Timing Code ------------------------- */
latime_1.ops += opst;
opst = 0.;
latime_1.itcnt = (doublereal) jiter;
/* ----------------------- End Timing Code -------------------------- */
z__1.r = (doublereal) (*n), z__1.i = 0.;
work[1].r = z__1.r, work[1].i = z__1.i;
return 0;
/* End of ZHGEQZ */
} /* zhgeqz_ */
/* Subroutine */ int zgttrf_(integer *n, doublecomplex *dl, doublecomplex *
d__, doublecomplex *du, doublecomplex *du2, integer *ipiv, integer *
info)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
static integer i__;
static doublecomplex fact, temp;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGTTRF computes an LU factorization of a complex tridiagonal matrix A */
/* using elimination with partial pivoting and row interchanges. */
/* The factorization has the form */
/* A = L * U */
/* where L is a product of permutation and unit lower bidiagonal */
/* matrices and U is upper triangular with nonzeros in only the main */
/* diagonal and first two superdiagonals. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. */
/* DL (input/output) COMPLEX*16 array, dimension (N-1) */
/* On entry, DL must contain the (n-1) sub-diagonal elements of */
/* A. */
/* On exit, DL is overwritten by the (n-1) multipliers that */
/* define the matrix L from the LU factorization of A. */
/* D (input/output) COMPLEX*16 array, dimension (N) */
/* On entry, D must contain the diagonal elements of A. */
/* On exit, D is overwritten by the n diagonal elements of the */
/* upper triangular matrix U from the LU factorization of A. */
/* DU (input/output) COMPLEX*16 array, dimension (N-1) */
/* On entry, DU must contain the (n-1) super-diagonal elements */
/* of A. */
/* On exit, DU is overwritten by the (n-1) elements of the first */
/* super-diagonal of U. */
/* DU2 (output) COMPLEX*16 array, dimension (N-2) */
/* On exit, DU2 is overwritten by the (n-2) elements of the */
/* second super-diagonal of U. */
/* IPIV (output) INTEGER array, dimension (N) */
/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
/* interchanged with row IPIV(i). IPIV(i) will always be either */
/* i or i+1; IPIV(i) = i indicates a row interchange was not */
/* required. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* > 0: if INFO = k, U(k,k) 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. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--ipiv;
--du2;
--du;
--d__;
--dl;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
i__1 = -(*info);
xerbla_("ZGTTRF", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Initialize IPIV(i) = i and DU2(i) = 0 */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
ipiv[i__] = i__;
/* L10: */
}
i__1 = *n - 2;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
du2[i__2].r = 0., du2[i__2].i = 0.;
/* L20: */
}
i__1 = *n - 2;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__;
if ((d__1 = d__[i__2].r, abs(d__1)) + (d__2 = d_imag(&d__[i__]), abs(
d__2)) >= (d__3 = dl[i__3].r, abs(d__3)) + (d__4 = d_imag(&dl[
i__]), abs(d__4))) {
/* No row interchange required, eliminate DL(I) */
i__2 = i__;
if ((d__1 = d__[i__2].r, abs(d__1)) + (d__2 = d_imag(&d__[i__]),
abs(d__2)) != 0.) {
z_div(&z__1, &dl[i__], &d__[i__]);
fact.r = z__1.r, fact.i = z__1.i;
i__2 = i__;
dl[i__2].r = fact.r, dl[i__2].i = fact.i;
i__2 = i__ + 1;
i__3 = i__ + 1;
i__4 = i__;
z__2.r = fact.r * du[i__4].r - fact.i * du[i__4].i, z__2.i =
fact.r * du[i__4].i + fact.i * du[i__4].r;
z__1.r = d__[i__3].r - z__2.r, z__1.i = d__[i__3].i - z__2.i;
d__[i__2].r = z__1.r, d__[i__2].i = z__1.i;
}
} else {
/* Interchange rows I and I+1, eliminate DL(I) */
z_div(&z__1, &d__[i__], &dl[i__]);
fact.r = z__1.r, fact.i = z__1.i;
i__2 = i__;
i__3 = i__;
d__[i__2].r = dl[i__3].r, d__[i__2].i = dl[i__3].i;
i__2 = i__;
dl[i__2].r = fact.r, dl[i__2].i = fact.i;
i__2 = i__;
temp.r = du[i__2].r, temp.i = du[i__2].i;
i__2 = i__;
i__3 = i__ + 1;
du[i__2].r = d__[i__3].r, du[i__2].i = d__[i__3].i;
i__2 = i__ + 1;
i__3 = i__ + 1;
z__2.r = fact.r * d__[i__3].r - fact.i * d__[i__3].i, z__2.i =
fact.r * d__[i__3].i + fact.i * d__[i__3].r;
z__1.r = temp.r - z__2.r, z__1.i = temp.i - z__2.i;
d__[i__2].r = z__1.r, d__[i__2].i = z__1.i;
i__2 = i__;
i__3 = i__ + 1;
du2[i__2].r = du[i__3].r, du2[i__2].i = du[i__3].i;
i__2 = i__ + 1;
z__2.r = -fact.r, z__2.i = -fact.i;
i__3 = i__ + 1;
z__1.r = z__2.r * du[i__3].r - z__2.i * du[i__3].i, z__1.i =
z__2.r * du[i__3].i + z__2.i * du[i__3].r;
du[i__2].r = z__1.r, du[i__2].i = z__1.i;
ipiv[i__] = i__ + 1;
}
/* L30: */
}
if (*n > 1) {
i__ = *n - 1;
i__1 = i__;
i__2 = i__;
if ((d__1 = d__[i__1].r, abs(d__1)) + (d__2 = d_imag(&d__[i__]), abs(
d__2)) >= (d__3 = dl[i__2].r, abs(d__3)) + (d__4 = d_imag(&dl[
i__]), abs(d__4))) {
i__1 = i__;
if ((d__1 = d__[i__1].r, abs(d__1)) + (d__2 = d_imag(&d__[i__]),
abs(d__2)) != 0.) {
z_div(&z__1, &dl[i__], &d__[i__]);
fact.r = z__1.r, fact.i = z__1.i;
i__1 = i__;
dl[i__1].r = fact.r, dl[i__1].i = fact.i;
i__1 = i__ + 1;
i__2 = i__ + 1;
i__3 = i__;
z__2.r = fact.r * du[i__3].r - fact.i * du[i__3].i, z__2.i =
fact.r * du[i__3].i + fact.i * du[i__3].r;
z__1.r = d__[i__2].r - z__2.r, z__1.i = d__[i__2].i - z__2.i;
d__[i__1].r = z__1.r, d__[i__1].i = z__1.i;
}
} else {
z_div(&z__1, &d__[i__], &dl[i__]);
fact.r = z__1.r, fact.i = z__1.i;
i__1 = i__;
i__2 = i__;
d__[i__1].r = dl[i__2].r, d__[i__1].i = dl[i__2].i;
i__1 = i__;
dl[i__1].r = fact.r, dl[i__1].i = fact.i;
i__1 = i__;
temp.r = du[i__1].r, temp.i = du[i__1].i;
i__1 = i__;
i__2 = i__ + 1;
du[i__1].r = d__[i__2].r, du[i__1].i = d__[i__2].i;
i__1 = i__ + 1;
i__2 = i__ + 1;
z__2.r = fact.r * d__[i__2].r - fact.i * d__[i__2].i, z__2.i =
fact.r * d__[i__2].i + fact.i * d__[i__2].r;
z__1.r = temp.r - z__2.r, z__1.i = temp.i - z__2.i;
d__[i__1].r = z__1.r, d__[i__1].i = z__1.i;
ipiv[i__] = i__ + 1;
}
}
/* Check for a zero on the diagonal of U. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
if ((d__1 = d__[i__2].r, abs(d__1)) + (d__2 = d_imag(&d__[i__]), abs(
d__2)) == 0.) {
*info = i__;
goto L50;
}
/* L40: */
}
L50:
return 0;
/* End of ZGTTRF */
} /* zgttrf_ */
/* Subroutine */ int zlatrs_(char *uplo, char *trans, char *diag, char *
normin, integer *n, doublecomplex *a, integer *lda, doublecomplex *x,
doublereal *scale, doublereal *cnorm, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4;
/* Local variables */
integer i__, j;
doublereal xj, rec, tjj;
integer jinc;
doublereal xbnd;
integer imax;
doublereal tmax;
doublecomplex tjjs;
doublereal xmax, grow;
doublereal tscal;
doublecomplex uscal;
integer jlast;
doublecomplex csumj;
logical upper;
doublereal bignum;
logical notran;
integer jfirst;
doublereal smlnum;
logical nounit;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* ZLATRS solves one of the triangular systems */
/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b, */
/* with scaling to prevent overflow. Here A is an upper or lower */
/* triangular matrix, A**T denotes the transpose of A, A**H denotes the */
/* conjugate transpose of A, x and b are n-element vectors, and s is a */
/* scaling factor, usually less than or equal to 1, chosen so that the */
/* components of x will be less than the overflow threshold. If the */
/* unscaled problem will not cause overflow, the Level 2 BLAS routine */
/* ZTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j), */
/* then s is set to 0 and a non-trivial solution to A*x = 0 is returned. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Specifies the operation applied to A. */
/* = 'N': Solve A * x = s*b (No transpose) */
/* = 'T': Solve A**T * x = s*b (Transpose) */
/* = 'C': Solve A**H * x = s*b (Conjugate transpose) */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* NORMIN (input) CHARACTER*1 */
/* Specifies whether CNORM has been set or not. */
/* = 'Y': CNORM contains the column norms on entry */
/* = 'N': CNORM is not set on entry. On exit, the norms will */
/* be computed and stored in CNORM. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The triangular matrix A. If UPLO = 'U', the leading n by n */
/* upper triangular part of the array A contains the upper */
/* triangular matrix, and the strictly lower triangular part of */
/* A is not referenced. If UPLO = 'L', the leading n by n lower */
/* triangular part of the array A contains the lower triangular */
/* matrix, and the strictly upper triangular part of A is not */
/* referenced. If DIAG = 'U', the diagonal elements of A are */
/* also not referenced and are assumed to be 1. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max (1,N). */
/* X (input/output) COMPLEX*16 array, dimension (N) */
/* On entry, the right hand side b of the triangular system. */
/* On exit, X is overwritten by the solution vector x. */
/* SCALE (output) DOUBLE PRECISION */
/* The scaling factor s for the triangular system */
/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b. */
/* If SCALE = 0, the matrix A is singular or badly scaled, and */
/* the vector x is an exact or approximate solution to A*x = 0. */
/* CNORM (input or output) DOUBLE PRECISION array, dimension (N) */
/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */
/* contains the norm of the off-diagonal part of the j-th column */
/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */
/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */
/* must be greater than or equal to the 1-norm. */
/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */
/* returns the 1-norm of the offdiagonal part of the j-th column */
/* of A. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* Further Details */
/* ======= ======= */
/* A rough bound on x is computed; if that is less than overflow, ZTRSV */
/* is called, otherwise, specific code is used which checks for possible */
/* overflow or divide-by-zero at every operation. */
/* A columnwise scheme is used for solving A*x = b. The basic algorithm */
/* if A is lower triangular is */
/* x[1:n] := b[1:n] */
/* x(j) := x(j) / A(j,j) */
/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */
/* end */
/* Define bounds on the components of x after j iterations of the loop: */
/* M(j) = bound on x[1:j] */
/* G(j) = bound on x[j+1:n] */
/* Then for iteration j+1 we have */
/* M(j+1) <= G(j) / | A(j+1,j+1) | */
/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */
/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */
/* where CNORM(j+1) is greater than or equal to the infinity-norm of */
/* column j+1 of A, not counting the diagonal. Hence */
/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */
/* 1<=i<=j */
/* and */
/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */
/* 1<=i< j */
/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTRSV if the */
/* max(underflow, 1/overflow). */
/* The bound on x(j) is also used to determine when a step in the */
/* columnwise method can be performed without fear of overflow. If */
/* the computed bound is greater than a large constant, x is scaled to */
/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */
/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */
/* Similarly, a row-wise scheme is used to solve A**T *x = b or */
/* A**H *x = b. The basic algorithm for A upper triangular is */
/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */
/* end */
/* We simultaneously compute two bounds */
/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */
/* M(j) = bound on x(i), 1<=i<=j */
/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */
/* Then the bound on x(j) is */
/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */
/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */
/* 1<=i<=j */
/* and we can safely call ZTRSV if 1/M(n) and 1/G(n) are both greater */
/* than max(underflow, 1/overflow). */
/* ===================================================================== */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--x;
--cnorm;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
/* Test the input parameters. */
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && !
lsame_(trans, "C")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (! lsame_(normin, "Y") && ! lsame_(normin,
"N")) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZLATRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine machine dependent parameters to control overflow. */
smlnum = dlamch_("Safe minimum");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum /= dlamch_("Precision");
bignum = 1. / smlnum;
*scale = 1.;
if (lsame_(normin, "N")) {
/* Compute the 1-norm of each column, not including the diagonal. */
if (upper) {
/* A is upper triangular. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
cnorm[j] = dzasum_(&i__2, &a[j * a_dim1 + 1], &c__1);
}
} else {
/* A is lower triangular. */
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j;
cnorm[j] = dzasum_(&i__2, &a[j + 1 + j * a_dim1], &c__1);
}
cnorm[*n] = 0.;
}
}
/* Scale the column norms by TSCAL if the maximum element in CNORM is */
/* greater than BIGNUM/2. */
imax = idamax_(n, &cnorm[1], &c__1);
tmax = cnorm[imax];
if (tmax <= bignum * .5) {
tscal = 1.;
} else {
tscal = .5 / (smlnum * tmax);
dscal_(n, &tscal, &cnorm[1], &c__1);
}
/* Compute a bound on the computed solution vector to see if the */
/* Level 2 BLAS routine ZTRSV can be used. */
xmax = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = j;
d__3 = xmax, d__4 = (d__1 = x[i__2].r / 2., abs(d__1)) + (d__2 =
d_imag(&x[j]) / 2., abs(d__2));
xmax = max(d__3,d__4);
}
xbnd = xmax;
if (notran) {
/* Compute the growth in A * x = b. */
if (upper) {
jfirst = *n;
jlast = 1;
jinc = -1;
} else {
jfirst = 1;
jlast = *n;
jinc = 1;
}
if (tscal != 1.) {
grow = 0.;
goto L60;
}
if (nounit) {
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
grow = .5 / max(xbnd,smlnum);
xbnd = grow;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L60;
}
i__3 = j + j * a_dim1;
tjjs.r = a[i__3].r, tjjs.i = a[i__3].i;
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
d__2));
if (tjj >= smlnum) {
/* M(j) = G(j-1) / abs(A(j,j)) */
/* Computing MIN */
d__1 = xbnd, d__2 = min(1.,tjj) * grow;
xbnd = min(d__1,d__2);
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.;
}
if (tjj + cnorm[j] >= smlnum) {
/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */
grow *= tjj / (tjj + cnorm[j]);
} else {
/* G(j) could overflow, set GROW to 0. */
grow = 0.;
}
}
grow = xbnd;
} else {
/* A is unit triangular. */
/* Computing MIN */
d__1 = 1., d__2 = .5 / max(xbnd,smlnum);
grow = min(d__1,d__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L60;
}
/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
grow *= 1. / (cnorm[j] + 1.);
}
}
L60:
;
} else {
/* Compute the growth in A**T * x = b or A**H * x = b. */
if (upper) {
jfirst = 1;
jlast = *n;
jinc = 1;
} else {
jfirst = *n;
jlast = 1;
jinc = -1;
}
if (tscal != 1.) {
grow = 0.;
goto L90;
}
if (nounit) {
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
grow = .5 / max(xbnd,smlnum);
xbnd = grow;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L90;
}
/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
xj = cnorm[j] + 1.;
/* Computing MIN */
d__1 = grow, d__2 = xbnd / xj;
grow = min(d__1,d__2);
i__3 = j + j * a_dim1;
tjjs.r = a[i__3].r, tjjs.i = a[i__3].i;
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
d__2));
if (tjj >= smlnum) {
/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
if (xj > tjj) {
xbnd *= tjj / xj;
}
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.;
}
}
grow = min(grow,xbnd);
} else {
/* A is unit triangular. */
/* Computing MIN */
d__1 = 1., d__2 = .5 / max(xbnd,smlnum);
grow = min(d__1,d__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L90;
}
/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
xj = cnorm[j] + 1.;
grow /= xj;
}
}
L90:
;
}
if (grow * tscal > smlnum) {
/* Use the Level 2 BLAS solve if the reciprocal of the bound on */
/* elements of X is not too small. */
ztrsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1);
} else {
/* Use a Level 1 BLAS solve, scaling intermediate results. */
if (xmax > bignum * .5) {
/* Scale X so that its components are less than or equal to */
/* BIGNUM in absolute value. */
*scale = bignum * .5 / xmax;
zdscal_(n, scale, &x[1], &c__1);
xmax = bignum;
} else {
xmax *= 2.;
}
if (notran) {
/* Solve A * x = b */
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]),
abs(d__2));
if (nounit) {
i__3 = j + j * a_dim1;
z__1.r = tscal * a[i__3].r, z__1.i = tscal * a[i__3].i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
if (tscal == 1.) {
goto L110;
}
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
d__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale x by 1/b(j). */
rec = 1. / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
, abs(d__2));
} else if (tjj > 0.) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */
/* to avoid overflow when dividing by A(j,j). */
rec = tjj * bignum / xj;
if (cnorm[j] > 1.) {
/* Scale by 1/CNORM(j) to avoid overflow when */
/* multiplying x(j) times column j. */
rec /= cnorm[j];
}
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
, abs(d__2));
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0, and compute a solution to A*x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0., x[i__4].i = 0.;
}
i__3 = j;
x[i__3].r = 1., x[i__3].i = 0.;
xj = 1.;
*scale = 0.;
xmax = 0.;
}
L110:
/* Scale x if necessary to avoid overflow when adding a */
/* multiple of column j of A. */
if (xj > 1.) {
rec = 1. / xj;
if (cnorm[j] > (bignum - xmax) * rec) {
/* Scale x by 1/(2*abs(x(j))). */
rec *= .5;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
} else if (xj * cnorm[j] > bignum - xmax) {
/* Scale x by 1/2. */
zdscal_(n, &c_b36, &x[1], &c__1);
*scale *= .5;
}
if (upper) {
if (j > 1) {
/* Compute the update */
/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */
i__3 = j - 1;
i__4 = j;
z__2.r = -x[i__4].r, z__2.i = -x[i__4].i;
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
zaxpy_(&i__3, &z__1, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
i__3 = j - 1;
i__ = izamax_(&i__3, &x[1], &c__1);
i__3 = i__;
xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
&x[i__]), abs(d__2));
}
} else {
if (j < *n) {
/* Compute the update */
/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */
i__3 = *n - j;
i__4 = j;
z__2.r = -x[i__4].r, z__2.i = -x[i__4].i;
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
zaxpy_(&i__3, &z__1, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
i__3 = *n - j;
i__ = j + izamax_(&i__3, &x[j + 1], &c__1);
i__3 = i__;
xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
&x[i__]), abs(d__2));
}
}
}
} else if (lsame_(trans, "T")) {
/* Solve A**T * x = b */
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
/* k<>j */
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]),
abs(d__2));
uscal.r = tscal, uscal.i = 0.;
rec = 1. / max(xmax,1.);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5;
if (nounit) {
i__3 = j + j * a_dim1;
z__1.r = tscal * a[i__3].r, z__1.i = tscal * a[i__3]
.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > 1.) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
d__1 = 1., d__2 = rec * tjj;
rec = min(d__1,d__2);
zladiv_(&z__1, &uscal, &tjjs);
uscal.r = z__1.r, uscal.i = z__1.i;
}
if (rec < 1.) {
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0., csumj.i = 0.;
if (uscal.r == 1. && uscal.i == 0.) {
/* If the scaling needed for A in the dot product is 1, */
/* call ZDOTU to perform the dot product. */
if (upper) {
i__3 = j - 1;
zdotu_(&z__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
} else if (j < *n) {
i__3 = *n - j;
zdotu_(&z__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
}
} else {
/* Otherwise, use in-line code for the dot product. */
if (upper) {
i__3 = j - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * a_dim1;
z__3.r = a[i__4].r * uscal.r - a[i__4].i *
uscal.i, z__3.i = a[i__4].r * uscal.i + a[
i__4].i * uscal.r;
i__5 = i__;
z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i,
z__2.i = z__3.r * x[i__5].i + z__3.i * x[
i__5].r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
}
} else if (j < *n) {
i__3 = *n;
for (i__ = j + 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * a_dim1;
z__3.r = a[i__4].r * uscal.r - a[i__4].i *
uscal.i, z__3.i = a[i__4].r * uscal.i + a[
i__4].i * uscal.r;
i__5 = i__;
z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i,
z__2.i = z__3.r * x[i__5].i + z__3.i * x[
i__5].r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
}
}
}
z__1.r = tscal, z__1.i = 0.;
if (uscal.r == z__1.r && uscal.i == z__1.i) {
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
/* was not used to scale the dotproduct. */
i__3 = j;
i__4 = j;
z__1.r = x[i__4].r - csumj.r, z__1.i = x[i__4].i -
csumj.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
, abs(d__2));
if (nounit) {
i__3 = j + j * a_dim1;
z__1.r = tscal * a[i__3].r, z__1.i = tscal * a[i__3]
.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
if (tscal == 1.) {
goto L160;
}
}
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale X by 1/abs(x(j)). */
rec = 1. / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
} else if (tjj > 0.) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0 and compute a solution to A**T *x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0., x[i__4].i = 0.;
}
i__3 = j;
x[i__3].r = 1., x[i__3].i = 0.;
*scale = 0.;
xmax = 0.;
}
L160:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
/* product has already been divided by 1/A(j,j). */
i__3 = j;
zladiv_(&z__2, &x[j], &tjjs);
z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
}
/* Computing MAX */
i__3 = j;
d__3 = xmax, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
d_imag(&x[j]), abs(d__2));
xmax = max(d__3,d__4);
}
} else {
/* Solve A**H * x = b */
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
/* k<>j */
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]),
abs(d__2));
uscal.r = tscal, uscal.i = 0.;
rec = 1. / max(xmax,1.);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5;
if (nounit) {
d_cnjg(&z__2, &a[j + j * a_dim1]);
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > 1.) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
d__1 = 1., d__2 = rec * tjj;
rec = min(d__1,d__2);
zladiv_(&z__1, &uscal, &tjjs);
uscal.r = z__1.r, uscal.i = z__1.i;
}
if (rec < 1.) {
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0., csumj.i = 0.;
if (uscal.r == 1. && uscal.i == 0.) {
/* If the scaling needed for A in the dot product is 1, */
/* call ZDOTC to perform the dot product. */
if (upper) {
i__3 = j - 1;
zdotc_(&z__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
} else if (j < *n) {
i__3 = *n - j;
zdotc_(&z__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
}
} else {
/* Otherwise, use in-line code for the dot product. */
if (upper) {
i__3 = j - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
d_cnjg(&z__4, &a[i__ + j * a_dim1]);
z__3.r = z__4.r * uscal.r - z__4.i * uscal.i,
z__3.i = z__4.r * uscal.i + z__4.i *
uscal.r;
i__4 = i__;
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i,
z__2.i = z__3.r * x[i__4].i + z__3.i * x[
i__4].r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
}
} else if (j < *n) {
i__3 = *n;
for (i__ = j + 1; i__ <= i__3; ++i__) {
d_cnjg(&z__4, &a[i__ + j * a_dim1]);
z__3.r = z__4.r * uscal.r - z__4.i * uscal.i,
z__3.i = z__4.r * uscal.i + z__4.i *
uscal.r;
i__4 = i__;
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i,
z__2.i = z__3.r * x[i__4].i + z__3.i * x[
i__4].r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
}
}
}
z__1.r = tscal, z__1.i = 0.;
if (uscal.r == z__1.r && uscal.i == z__1.i) {
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
/* was not used to scale the dotproduct. */
i__3 = j;
i__4 = j;
z__1.r = x[i__4].r - csumj.r, z__1.i = x[i__4].i -
csumj.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
, abs(d__2));
if (nounit) {
d_cnjg(&z__2, &a[j + j * a_dim1]);
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
if (tscal == 1.) {
goto L210;
}
}
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale X by 1/abs(x(j)). */
rec = 1. / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
} else if (tjj > 0.) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0 and compute a solution to A**H *x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0., x[i__4].i = 0.;
}
i__3 = j;
x[i__3].r = 1., x[i__3].i = 0.;
*scale = 0.;
xmax = 0.;
}
L210:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
/* product has already been divided by 1/A(j,j). */
i__3 = j;
zladiv_(&z__2, &x[j], &tjjs);
z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
}
/* Computing MAX */
i__3 = j;
d__3 = xmax, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
d_imag(&x[j]), abs(d__2));
xmax = max(d__3,d__4);
}
}
*scale /= tscal;
}
/* Scale the column norms by 1/TSCAL for return. */
if (tscal != 1.) {
d__1 = 1. / tscal;
dscal_(n, &d__1, &cnorm[1], &c__1);
}
return 0;
/* End of ZLATRS */
} /* zlatrs_ */
/* Subroutine */ int zgecon_(char *norm, integer *n, doublecomplex *a,
integer *lda, doublereal *anorm, doublereal *rcond, doublecomplex *
work, doublereal *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1;
doublereal d__1, d__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
doublereal sl;
integer ix;
doublereal su;
integer kase, kase1;
doublereal scale;
extern logical lsame_(char *, char *);
integer isave[3];
extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *,
doublecomplex *, doublereal *, integer *, integer *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal ainvnm;
extern integer izamax_(integer *, doublecomplex *, integer *);
logical onenrm;
extern /* Subroutine */ int zdrscl_(integer *, doublereal *,
doublecomplex *, integer *);
char normin[1];
doublereal smlnum;
extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, doublereal *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGECON estimates the reciprocal of the condition number of a general */
/* complex matrix A, in either the 1-norm or the infinity-norm, using */
/* the LU factorization computed by ZGETRF. */
/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
/* condition number is computed as */
/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies whether the 1-norm condition number or the */
/* infinity-norm condition number is required: */
/* = '1' or 'O': 1-norm; */
/* = 'I': Infinity-norm. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The factors L and U from the factorization A = P*L*U */
/* as computed by ZGETRF. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* ANORM (input) DOUBLE PRECISION */
/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */
/* If NORM = 'I', the infinity-norm of the original matrix A. */
/* RCOND (output) DOUBLE PRECISION */
/* The reciprocal of the condition number of the matrix A, */
/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--work;
--rwork;
/* Function Body */
*info = 0;
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
if (! onenrm && ! lsame_(norm, "I")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
} else if (*anorm < 0.) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGECON", &i__1);
return 0;
}
/* Quick return if possible */
*rcond = 0.;
if (*n == 0) {
*rcond = 1.;
return 0;
} else if (*anorm == 0.) {
return 0;
}
smlnum = dlamch_("Safe minimum");
/* Estimate the norm of inv(A). */
ainvnm = 0.;
*(unsigned char *)normin = 'N';
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kase = 0;
L10:
zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(L). */
zlatrs_("Lower", "No transpose", "Unit", normin, n, &a[a_offset],
lda, &work[1], &sl, &rwork[1], info);
/* Multiply by inv(U). */
zlatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[
a_offset], lda, &work[1], &su, &rwork[*n + 1], info);
} else {
/* Multiply by inv(U'). */
zlatrs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &a[
a_offset], lda, &work[1], &su, &rwork[*n + 1], info);
/* Multiply by inv(L'). */
zlatrs_("Lower", "Conjugate transpose", "Unit", normin, n, &a[
a_offset], lda, &work[1], &sl, &rwork[1], info);
}
/* Divide X by 1/(SL*SU) if doing so will not cause overflow. */
scale = sl * su;
*(unsigned char *)normin = 'Y';
if (scale != 1.) {
ix = izamax_(n, &work[1], &c__1);
i__1 = ix;
if (scale < ((d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(&
work[ix]), abs(d__2))) * smlnum || scale == 0.) {
goto L20;
}
zdrscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) {
*rcond = 1. / ainvnm / *anorm;
}
L20:
return 0;
/* End of ZGECON */
} /* zgecon_ */
/* Subroutine */ int zlassq_(integer *n, doublecomplex *x, integer *incx,
doublereal *scale, doublereal *sumsq)
{
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
integer ix;
doublereal temp1;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLASSQ returns the values scl and ssq such that */
/* ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, */
/* where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is */
/* assumed to be at least unity and the value of ssq will then satisfy */
/* 1.0 .le. ssq .le. ( sumsq + 2*n ). */
/* scale is assumed to be non-negative and scl returns the value */
/* scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ), */
/* i */
/* scale and sumsq must be supplied in SCALE and SUMSQ respectively. */
/* SCALE and SUMSQ are overwritten by scl and ssq respectively. */
/* The routine makes only one pass through the vector X. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The number of elements to be used from the vector X. */
/* X (input) COMPLEX*16 array, dimension (N) */
/* The vector x as described above. */
/* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. */
/* INCX (input) INTEGER */
/* The increment between successive values of the vector X. */
/* INCX > 0. */
/* SCALE (input/output) DOUBLE PRECISION */
/* On entry, the value scale in the equation above. */
/* On exit, SCALE is overwritten with the value scl . */
/* SUMSQ (input/output) DOUBLE PRECISION */
/* On entry, the value sumsq in the equation above. */
/* On exit, SUMSQ is overwritten with the value ssq . */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--x;
/* Function Body */
if (*n > 0) {
i__1 = (*n - 1) * *incx + 1;
i__2 = *incx;
for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
i__3 = ix;
if (x[i__3].r != 0.) {
i__3 = ix;
temp1 = (d__1 = x[i__3].r, abs(d__1));
if (*scale < temp1) {
/* Computing 2nd power */
d__1 = *scale / temp1;
*sumsq = *sumsq * (d__1 * d__1) + 1;
*scale = temp1;
} else {
/* Computing 2nd power */
d__1 = temp1 / *scale;
*sumsq += d__1 * d__1;
}
}
if (d_imag(&x[ix]) != 0.) {
temp1 = (d__1 = d_imag(&x[ix]), abs(d__1));
if (*scale < temp1) {
/* Computing 2nd power */
d__1 = *scale / temp1;
*sumsq = *sumsq * (d__1 * d__1) + 1;
*scale = temp1;
} else {
/* Computing 2nd power */
d__1 = temp1 / *scale;
*sumsq += d__1 * d__1;
}
}
/* L10: */
}
}
return 0;
/* End of ZLASSQ */
} /* zlassq_ */
int zlacrm_(int *m, int *n, doublecomplex *a,
int *lda, double *b, int *ldb, doublecomplex *c__,
int *ldc, double *rwork)
{
/* System generated locals */
int b_dim1, b_offset, a_dim1, a_offset, c_dim1, c_offset, i__1, i__2,
i__3, i__4, i__5;
double d__1;
doublecomplex z__1;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
int i__, j, l;
extern int dgemm_(char *, char *, int *, int *,
int *, double *, double *, int *, double *,
int *, double *, double *, int *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLACRM performs a very simple matrix-matrix multiplication: */
/* C := A * B, */
/* where A is M by N and complex; B is N by N and float; */
/* C is M by N and complex. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A and of the matrix C. */
/* M >= 0. */
/* N (input) INTEGER */
/* The number of columns and rows of the matrix B and */
/* the number of columns of the matrix C. */
/* N >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA, N) */
/* A contains the M by N matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >=MAX(1,M). */
/* B (input) DOUBLE PRECISION array, dimension (LDB, N) */
/* B contains the N by N matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >=MAX(1,N). */
/* C (input) COMPLEX*16 array, dimension (LDC, N) */
/* C contains the M by N matrix C. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >=MAX(1,N). */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*M*N) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--rwork;
/* Function Body */
if (*m == 0 || *n == 0) {
return 0;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
rwork[(j - 1) * *m + i__] = a[i__3].r;
/* L10: */
}
/* L20: */
}
l = *m * *n + 1;
dgemm_("N", "N", m, n, n, &c_b6, &rwork[1], m, &b[b_offset], ldb, &c_b7, &
rwork[l], m);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = l + (j - 1) * *m + i__ - 1;
c__[i__3].r = rwork[i__4], c__[i__3].i = 0.;
/* L30: */
}
/* L40: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
rwork[(j - 1) * *m + i__] = d_imag(&a[i__ + j * a_dim1]);
/* L50: */
}
/* L60: */
}
dgemm_("N", "N", m, n, n, &c_b6, &rwork[1], m, &b[b_offset], ldb, &c_b7, &
rwork[l], m);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
d__1 = c__[i__4].r;
i__5 = l + (j - 1) * *m + i__ - 1;
z__1.r = d__1, z__1.i = rwork[i__5];
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L70: */
}
/* L80: */
}
return 0;
/* End of ZLACRM */
} /* zlacrm_ */
/* Subroutine */ int ztbt05_(char *uplo, char *trans, char *diag, integer *n,
integer *kd, integer *nrhs, doublecomplex *ab, integer *ldab,
doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
doublecomplex *xact, integer *ldxact, doublereal *ferr, doublereal *
berr, doublereal *reslts)
{
/* System generated locals */
integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
xact_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
integer i__, j, k, nz, ifu;
doublereal eps, tmp, diff, axbi;
integer imax;
doublereal unfl, ovfl;
logical unit;
extern logical lsame_(char *, char *);
logical upper;
doublereal xnorm;
extern doublereal dlamch_(char *);
doublereal errbnd;
extern integer izamax_(integer *, doublecomplex *, integer *);
logical notran;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZTBT05 tests the error bounds from iterative refinement for the */
/* computed solution to a system of equations A*X = B, where A is a */
/* triangular band matrix. */
/* RESLTS(1) = test of the error bound */
/* = norm(X - XACT) / ( norm(X) * FERR ) */
/* A large value is returned if this ratio is not less than one. */
/* RESLTS(2) = residual from the iterative refinement routine */
/* = the maximum of BERR / ( NZ*EPS + (*) ), where */
/* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
/* and NZ = max. number of nonzeros in any row of A, plus 1 */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* 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) */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* N (input) INTEGER */
/* The number of rows of the matrices X, B, and XACT, and the */
/* order of the matrix A. N >= 0. */
/* KD (input) INTEGER */
/* The number of super-diagonals of the matrix A if UPLO = 'U', */
/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
/* NRHS (input) INTEGER */
/* The number of columns of the matrices X, B, and XACT. */
/* NRHS >= 0. */
/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
/* The upper or lower triangular band matrix A, stored in the */
/* first kd+1 rows of the array. The j-th column of A is stored */
/* in the j-th column of the array AB as follows: */
/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
/* If DIAG = 'U', the diagonal elements of A are not referenced */
/* and are assumed to be 1. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KD+1. */
/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
/* The right hand side vectors for the system of linear */
/* equations. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
/* The computed solution vectors. Each vector is stored as a */
/* column of the matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* XACT (input) COMPLEX*16 array, dimension (LDX,NRHS) */
/* The exact solution vectors. Each vector is stored as a */
/* column of the matrix XACT. */
/* LDXACT (input) INTEGER */
/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
/* FERR (input) DOUBLE PRECISION array, dimension (NRHS) */
/* The estimated forward error bounds for each solution vector */
/* X. If XTRUE is the true solution, FERR bounds the magnitude */
/* of the largest entry in (X - XTRUE) divided by the magnitude */
/* of the largest entry in X. */
/* BERR (input) DOUBLE PRECISION array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector (i.e., the smallest relative change in any entry of A */
/* or B that makes X an exact solution). */
/* RESLTS (output) DOUBLE PRECISION array, dimension (2) */
/* The maximum over the NRHS solution vectors of the ratios: */
/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
/* RESLTS(2) = BERR / ( NZ*EPS + (*) ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 or NRHS = 0. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
xact_dim1 = *ldxact;
xact_offset = 1 + xact_dim1;
xact -= xact_offset;
--ferr;
--berr;
--reslts;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
reslts[1] = 0.;
reslts[2] = 0.;
return 0;
}
eps = dlamch_("Epsilon");
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
unit = lsame_(diag, "U");
/* Computing MIN */
i__1 = *kd, i__2 = *n - 1;
nz = min(i__1,i__2) + 1;
/* Test 1: Compute the maximum of */
/* norm(X - XACT) / ( norm(X) * FERR ) */
/* over all the vectors X and XACT using the infinity-norm. */
errbnd = 0.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
imax = izamax_(n, &x[j * x_dim1 + 1], &c__1);
/* Computing MAX */
i__2 = imax + j * x_dim1;
d__3 = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x[imax + j *
x_dim1]), abs(d__2));
xnorm = max(d__3,unfl);
diff = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * x_dim1;
i__4 = i__ + j * xact_dim1;
z__2.r = x[i__3].r - xact[i__4].r, z__2.i = x[i__3].i - xact[i__4]
.i;
z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MAX */
d__3 = diff, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
z__1), abs(d__2));
diff = max(d__3,d__4);
/* L10: */
}
if (xnorm > 1.) {
goto L20;
} else if (diff <= ovfl * xnorm) {
goto L20;
} else {
errbnd = 1. / eps;
goto L30;
}
L20:
if (diff / xnorm <= ferr[j]) {
/* Computing MAX */
d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
errbnd = max(d__1,d__2);
} else {
errbnd = 1. / eps;
}
L30:
;
}
reslts[1] = errbnd;
/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where */
/* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
ifu = 0;
if (unit) {
ifu = 1;
}
i__1 = *nrhs;
for (k = 1; k <= i__1; ++k) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + k * b_dim1;
tmp = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[i__ + k *
b_dim1]), abs(d__2));
if (upper) {
if (! notran) {
/* Computing MAX */
i__3 = i__ - *kd;
i__4 = i__ - ifu;
for (j = max(i__3,1); j <= i__4; ++j) {
i__3 = *kd + 1 - i__ + j + i__ * ab_dim1;
i__5 = j + k * x_dim1;
tmp += ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 =
d_imag(&ab[*kd + 1 - i__ + j + i__ * ab_dim1])
, abs(d__2))) * ((d__3 = x[i__5].r, abs(d__3))
+ (d__4 = d_imag(&x[j + k * x_dim1]), abs(
d__4)));
/* L40: */
}
if (unit) {
i__4 = i__ + k * x_dim1;
tmp += (d__1 = x[i__4].r, abs(d__1)) + (d__2 = d_imag(
&x[i__ + k * x_dim1]), abs(d__2));
}
} else {
if (unit) {
i__4 = i__ + k * x_dim1;
tmp += (d__1 = x[i__4].r, abs(d__1)) + (d__2 = d_imag(
&x[i__ + k * x_dim1]), abs(d__2));
}
/* Computing MIN */
i__3 = i__ + *kd;
i__4 = min(i__3,*n);
for (j = i__ + ifu; j <= i__4; ++j) {
i__3 = *kd + 1 + i__ - j + j * ab_dim1;
i__5 = j + k * x_dim1;
tmp += ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 =
d_imag(&ab[*kd + 1 + i__ - j + j * ab_dim1]),
abs(d__2))) * ((d__3 = x[i__5].r, abs(d__3))
+ (d__4 = d_imag(&x[j + k * x_dim1]), abs(
d__4)));
/* L50: */
}
}
} else {
if (notran) {
/* Computing MAX */
i__4 = i__ - *kd;
i__3 = i__ - ifu;
for (j = max(i__4,1); j <= i__3; ++j) {
i__4 = i__ + 1 - j + j * ab_dim1;
i__5 = j + k * x_dim1;
tmp += ((d__1 = ab[i__4].r, abs(d__1)) + (d__2 =
d_imag(&ab[i__ + 1 - j + j * ab_dim1]), abs(
d__2))) * ((d__3 = x[i__5].r, abs(d__3)) + (
d__4 = d_imag(&x[j + k * x_dim1]), abs(d__4)))
;
/* L60: */
}
if (unit) {
i__3 = i__ + k * x_dim1;
tmp += (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
&x[i__ + k * x_dim1]), abs(d__2));
}
} else {
if (unit) {
i__3 = i__ + k * x_dim1;
tmp += (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
&x[i__ + k * x_dim1]), abs(d__2));
}
/* Computing MIN */
i__4 = i__ + *kd;
i__3 = min(i__4,*n);
for (j = i__ + ifu; j <= i__3; ++j) {
i__4 = j + 1 - i__ + i__ * ab_dim1;
i__5 = j + k * x_dim1;
tmp += ((d__1 = ab[i__4].r, abs(d__1)) + (d__2 =
d_imag(&ab[j + 1 - i__ + i__ * ab_dim1]), abs(
d__2))) * ((d__3 = x[i__5].r, abs(d__3)) + (
d__4 = d_imag(&x[j + k * x_dim1]), abs(d__4)))
;
/* L70: */
}
}
}
if (i__ == 1) {
axbi = tmp;
} else {
axbi = min(axbi,tmp);
}
/* L80: */
}
/* Computing MAX */
d__1 = axbi, d__2 = nz * unfl;
tmp = berr[k] / (nz * eps + nz * unfl / max(d__1,d__2));
if (k == 1) {
reslts[2] = tmp;
} else {
reslts[2] = max(reslts[2],tmp);
}
/* L90: */
}
return 0;
/* End of ZTBT05 */
} /* ztbt05_ */
/* Subroutine */ int zla_lin_berr__(integer *n, integer *nz, integer *nrhs,
doublecomplex *res, doublereal *ayb, doublereal *berr)
{
/* System generated locals */
integer ayb_dim1, ayb_offset, res_dim1, res_offset, i__1, i__2, i__3,
i__4;
doublereal d__1, d__2, d__3;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
integer i__, j;
doublereal tmp, safe1;
extern doublereal dlamch_(char *);
/* -- 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 */
/* ======= */
/* ZLA_LIN_BERR computes componentwise relative backward error from */
/* the 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. */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* NZ (input) INTEGER */
/* We add (NZ+1)*SLAMCH( 'Safe minimum' ) to R(i) in the numerator to */
/* guard against spuriously zero residuals. Default value is N. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices AYB, RES, and BERR. NRHS >= 0. */
/* RES (input) DOUBLE PRECISION array, dimension (N,NRHS) */
/* The residual matrix, i.e., the matrix R in the relative backward */
/* error formula above. */
/* AYB (input) DOUBLE PRECISION array, dimension (N, NRHS) */
/* The denominator in the relative backward error formula above, i.e., */
/* the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B */
/* are from iterative refinement (see zla_gerfsx_extended.f). */
/* RES (output) COMPLEX*16 array, dimension (NRHS) */
/* The componentwise relative backward error from the formula above. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function Definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Adding SAFE1 to the numerator guards against spuriously zero */
/* residuals. A similar safeguard is in the CLA_yyAMV routine used */
/* to compute AYB. */
/* Parameter adjustments */
--berr;
ayb_dim1 = *n;
ayb_offset = 1 + ayb_dim1;
ayb -= ayb_offset;
res_dim1 = *n;
res_offset = 1 + res_dim1;
res -= res_offset;
/* Function Body */
safe1 = dlamch_("Safe minimum");
safe1 = (*nz + 1) * safe1;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
berr[j] = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (ayb[i__ + j * ayb_dim1] != 0.) {
i__3 = i__ + j * res_dim1;
d__3 = (d__1 = res[i__3].r, abs(d__1)) + (d__2 = d_imag(&res[
i__ + j * res_dim1]), abs(d__2));
z__3.r = d__3, z__3.i = 0.;
z__2.r = safe1 + z__3.r, z__2.i = z__3.i;
i__4 = i__ + j * ayb_dim1;
z__1.r = z__2.r / ayb[i__4], z__1.i = z__2.i / ayb[i__4];
tmp = z__1.r;
/* Computing MAX */
d__1 = berr[j];
berr[j] = max(d__1,tmp);
}
/* If AYB is exactly 0.0 (and if computed by CLA_yyAMV), then we know */
/* the true residual also must be exactly 0.0. */
}
}
return 0;
} /* zla_lin_berr__ */
/* Subroutine */ int zpst01_(char *uplo, integer *n, doublecomplex *a,
integer *lda, doublecomplex *afac, integer *ldafac, doublecomplex *
perm, integer *ldperm, integer *piv, doublereal *rwork, doublereal *
resid, integer *rank)
{
/* System generated locals */
integer a_dim1, a_offset, afac_dim1, afac_offset, perm_dim1, perm_offset,
i__1, i__2, i__3, i__4, i__5;
doublereal d__1;
doublecomplex z__1;
/* Local variables */
integer i__, j, k;
doublecomplex tc;
doublereal tr, eps;
doublereal anorm;
/* -- LAPACK test routine (version 3.1) -- */
/* Craig Lucas, University of Manchester / NAG Ltd. */
/* October, 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZPST01 reconstructs an Hermitian positive semidefinite matrix A */
/* from its L or U factors and the permutation matrix P and computes */
/* the residual */
/* norm( P*L*L'*P' - A ) / ( N * norm(A) * EPS ) or */
/* norm( P*U'*U*P' - A ) / ( N * norm(A) * EPS ), */
/* where EPS is the machine epsilon, L' is the conjugate transpose of L, */
/* and U' is the conjugate transpose of U. */
/* Arguments */
/* ========== */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The number of rows and columns of the matrix A. N >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The original Hermitian matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N) */
/* AFAC (input) COMPLEX*16 array, dimension (LDAFAC,N) */
/* The factor L or U from the L*L' or U'*U */
/* factorization of A. */
/* LDAFAC (input) INTEGER */
/* The leading dimension of the array AFAC. LDAFAC >= max(1,N). */
/* PERM (output) COMPLEX*16 array, dimension (LDPERM,N) */
/* Overwritten with the reconstructed matrix, and then with the */
/* difference P*L*L'*P' - A (or P*U'*U*P' - A) */
/* LDPERM (input) INTEGER */
/* The leading dimension of the array PERM. */
/* LDAPERM >= max(1,N). */
/* PIV (input) INTEGER array, dimension (N) */
/* PIV is such that the nonzero entries are */
/* P( PIV( K ), K ) = 1. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* RESID (output) DOUBLE PRECISION */
/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
afac_dim1 = *ldafac;
afac_offset = 1 + afac_dim1;
afac -= afac_offset;
perm_dim1 = *ldperm;
perm_offset = 1 + perm_dim1;
perm -= perm_offset;
--piv;
--rwork;
/* Function Body */
if (*n <= 0) {
*resid = 0.;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = dlamch_("Epsilon");
anorm = zlanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
if (anorm <= 0.) {
*resid = 1. / eps;
return 0;
}
/* Check the imaginary parts of the diagonal elements and return with */
/* an error code if any are nonzero. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (d_imag(&afac[j + j * afac_dim1]) != 0.) {
*resid = 1. / eps;
return 0;
}
/* L100: */
}
/* Compute the product U'*U, overwriting U. */
if (lsame_(uplo, "U")) {
if (*rank < *n) {
i__1 = *n;
for (j = *rank + 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = *rank + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * afac_dim1;
afac[i__3].r = 0., afac[i__3].i = 0.;
/* L110: */
}
/* L120: */
}
}
for (k = *n; k >= 1; --k) {
/* Compute the (K,K) element of the result. */
zdotc_(&z__1, &k, &afac[k * afac_dim1 + 1], &c__1, &afac[k *
afac_dim1 + 1], &c__1);
tr = z__1.r;
i__1 = k + k * afac_dim1;
afac[i__1].r = tr, afac[i__1].i = 0.;
/* Compute the rest of column K. */
i__1 = k - 1;
ztrmv_("Upper", "Conjugate", "Non-unit", &i__1, &afac[afac_offset]
, ldafac, &afac[k * afac_dim1 + 1], &c__1);
/* L130: */
}
/* Compute the product L*L', overwriting L. */
} else {
if (*rank < *n) {
i__1 = *n;
for (j = *rank + 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = i__ + j * afac_dim1;
afac[i__3].r = 0., afac[i__3].i = 0.;
/* L140: */
}
/* L150: */
}
}
for (k = *n; k >= 1; --k) {
/* Add a multiple of column K of the factor L to each of */
/* columns K+1 through N. */
if (k + 1 <= *n) {
i__1 = *n - k;
zher_("Lower", &i__1, &c_b20, &afac[k + 1 + k * afac_dim1], &
c__1, &afac[k + 1 + (k + 1) * afac_dim1], ldafac);
}
/* Scale column K by the diagonal element. */
i__1 = k + k * afac_dim1;
tc.r = afac[i__1].r, tc.i = afac[i__1].i;
i__1 = *n - k + 1;
zscal_(&i__1, &tc, &afac[k + k * afac_dim1], &c__1);
/* L160: */
}
}
/* Form P*L*L'*P' or P*U'*U*P' */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (piv[i__] <= piv[j]) {
if (i__ <= j) {
i__3 = piv[i__] + piv[j] * perm_dim1;
i__4 = i__ + j * afac_dim1;
perm[i__3].r = afac[i__4].r, perm[i__3].i = afac[i__4]
.i;
} else {
i__3 = piv[i__] + piv[j] * perm_dim1;
d_cnjg(&z__1, &afac[j + i__ * afac_dim1]);
perm[i__3].r = z__1.r, perm[i__3].i = z__1.i;
}
}
/* L170: */
}
/* L180: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (piv[i__] >= piv[j]) {
if (i__ >= j) {
i__3 = piv[i__] + piv[j] * perm_dim1;
i__4 = i__ + j * afac_dim1;
perm[i__3].r = afac[i__4].r, perm[i__3].i = afac[i__4]
.i;
} else {
i__3 = piv[i__] + piv[j] * perm_dim1;
d_cnjg(&z__1, &afac[j + i__ * afac_dim1]);
perm[i__3].r = z__1.r, perm[i__3].i = z__1.i;
}
}
/* L190: */
}
/* L200: */
}
}
/* Compute the difference P*L*L'*P' - A (or P*U'*U*P' - A). */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * perm_dim1;
i__4 = i__ + j * perm_dim1;
i__5 = i__ + j * a_dim1;
z__1.r = perm[i__4].r - a[i__5].r, z__1.i = perm[i__4].i - a[
i__5].i;
perm[i__3].r = z__1.r, perm[i__3].i = z__1.i;
/* L210: */
}
i__2 = j + j * perm_dim1;
i__3 = j + j * perm_dim1;
i__4 = j + j * a_dim1;
d__1 = a[i__4].r;
z__1.r = perm[i__3].r - d__1, z__1.i = perm[i__3].i;
perm[i__2].r = z__1.r, perm[i__2].i = z__1.i;
/* L220: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j + j * perm_dim1;
i__3 = j + j * perm_dim1;
i__4 = j + j * a_dim1;
d__1 = a[i__4].r;
z__1.r = perm[i__3].r - d__1, z__1.i = perm[i__3].i;
perm[i__2].r = z__1.r, perm[i__2].i = z__1.i;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * perm_dim1;
i__4 = i__ + j * perm_dim1;
i__5 = i__ + j * a_dim1;
z__1.r = perm[i__4].r - a[i__5].r, z__1.i = perm[i__4].i - a[
i__5].i;
perm[i__3].r = z__1.r, perm[i__3].i = z__1.i;
/* L230: */
}
/* L240: */
}
}
/* Compute norm( P*L*L'P - A ) / ( N * norm(A) * EPS ), or */
/* ( P*U'*U*P' - A )/ ( N * norm(A) * EPS ). */
*resid = zlanhe_("1", uplo, n, &perm[perm_offset], ldafac, &rwork[1]);
*resid = *resid / (doublereal) (*n) / anorm / eps;
return 0;
/* End of ZPST01 */
} /* zpst01_ */