int
f2c_csscal(integer* N,
real* alpha,
complex* X, integer* incX)
{
csscal_(N, alpha, X, incX);
return 0;
}
/* Subroutine */ int cbdsqr_(char *uplo, integer *n, integer *ncvt, integer *
nru, integer *ncc, real *d__, real *e, complex *vt, integer *ldvt,
complex *u, integer *ldu, complex *c__, integer *ldc, real *rwork,
integer *info)
{
/* System generated locals */
integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1,
i__2;
real r__1, r__2, r__3, r__4;
doublereal d__1;
/* Local variables */
real f, g, h__;
integer i__, j, m;
real r__, cs;
integer ll;
real sn, mu;
integer nm1, nm12, nm13, lll;
real eps, sll, tol, abse;
integer idir;
real abss;
integer oldm;
real cosl;
integer isub, iter;
real unfl, sinl, cosr, smin, smax, sinr;
real oldcs;
integer oldll;
real shift, sigmn, oldsn;
integer maxit;
real sminl, sigmx;
logical lower;
real sminoa;
real thresh;
logical rotate;
real tolmul;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CBDSQR computes the singular values and, optionally, the right and/or */
/* left singular vectors from the singular value decomposition (SVD) of */
/* a real N-by-N (upper or lower) bidiagonal matrix B using the implicit */
/* zero-shift QR algorithm. The SVD of B has the form */
/* B = Q * S * P**H */
/* where S is the diagonal matrix of singular values, Q is an orthogonal */
/* matrix of left singular vectors, and P is an orthogonal matrix of */
/* right singular vectors. If left singular vectors are requested, this */
/* subroutine actually returns U*Q instead of Q, and, if right singular */
/* vectors are requested, this subroutine returns P**H*VT instead of */
/* P**H, for given complex input matrices U and VT. When U and VT are */
/* the unitary matrices that reduce a general matrix A to bidiagonal */
/* form: A = U*B*VT, as computed by CGEBRD, then */
/* A = (U*Q) * S * (P**H*VT) */
/* is the SVD of A. Optionally, the subroutine may also compute Q**H*C */
/* for a given complex input matrix C. */
/* See "Computing Small Singular Values of Bidiagonal Matrices With */
/* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, */
/* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11, */
/* no. 5, pp. 873-912, Sept 1990) and */
/* "Accurate singular values and differential qd algorithms," by */
/* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics */
/* Department, University of California at Berkeley, July 1992 */
/* for a detailed description of the algorithm. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': B is upper bidiagonal; */
/* = 'L': B is lower bidiagonal. */
/* N (input) INTEGER */
/* The order of the matrix B. N >= 0. */
/* NCVT (input) INTEGER */
/* The number of columns of the matrix VT. NCVT >= 0. */
/* NRU (input) INTEGER */
/* The number of rows of the matrix U. NRU >= 0. */
/* NCC (input) INTEGER */
/* The number of columns of the matrix C. NCC >= 0. */
/* D (input/output) REAL array, dimension (N) */
/* On entry, the n diagonal elements of the bidiagonal matrix B. */
/* On exit, if INFO=0, the singular values of B in decreasing */
/* order. */
/* E (input/output) REAL array, dimension (N-1) */
/* On entry, the N-1 offdiagonal elements of the bidiagonal */
/* matrix B. */
/* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E */
/* will contain the diagonal and superdiagonal elements of a */
/* bidiagonal matrix orthogonally equivalent to the one given */
/* as input. */
/* VT (input/output) COMPLEX array, dimension (LDVT, NCVT) */
/* On entry, an N-by-NCVT matrix VT. */
/* On exit, VT is overwritten by P**H * VT. */
/* Not referenced if NCVT = 0. */
/* LDVT (input) INTEGER */
/* The leading dimension of the array VT. */
/* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. */
/* U (input/output) COMPLEX array, dimension (LDU, N) */
/* On entry, an NRU-by-N matrix U. */
/* On exit, U is overwritten by U * Q. */
/* Not referenced if NRU = 0. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= max(1,NRU). */
/* C (input/output) COMPLEX array, dimension (LDC, NCC) */
/* On entry, an N-by-NCC matrix C. */
/* On exit, C is overwritten by Q**H * C. */
/* Not referenced if NCC = 0. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. */
/* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. */
/* RWORK (workspace) REAL array, dimension (2*N) */
/* if NCVT = NRU = NCC = 0, (max(1, 4*N-4)) otherwise */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: If INFO = -i, the i-th argument had an illegal value */
/* > 0: the algorithm did not converge; D and E contain the */
/* elements of a bidiagonal matrix which is orthogonally */
/* similar to the input matrix B; if INFO = i, i */
/* elements of E have not converged to zero. */
/* Internal Parameters */
/* =================== */
/* TOLMUL REAL, default = max(10,min(100,EPS**(-1/8))) */
/* TOLMUL controls the convergence criterion of the QR loop. */
/* If it is positive, TOLMUL*EPS is the desired relative */
/* precision in the computed singular values. */
/* If it is negative, abs(TOLMUL*EPS*sigma_max) is the */
/* desired absolute accuracy in the computed singular */
/* values (corresponds to relative accuracy */
/* abs(TOLMUL*EPS) in the largest singular value. */
/* abs(TOLMUL) should be between 1 and 1/EPS, and preferably */
/* between 10 (for fast convergence) and .1/EPS */
/* (for there to be some accuracy in the results). */
/* Default is to lose at either one eighth or 2 of the */
/* available decimal digits in each computed singular value */
/* (whichever is smaller). */
/* MAXITR INTEGER, default = 6 */
/* MAXITR controls the maximum number of passes of the */
/* algorithm through its inner loop. The algorithms stops */
/* (and so fails to converge) if the number of passes */
/* through the inner loop exceeds MAXITR*N**2. */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--rwork;
/* Function Body */
*info = 0;
lower = lsame_(uplo, "L");
if (! lsame_(uplo, "U") && ! lower) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ncvt < 0) {
*info = -3;
} else if (*nru < 0) {
*info = -4;
} else if (*ncc < 0) {
*info = -5;
} else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < max(1,*n)) {
*info = -9;
} else if (*ldu < max(1,*nru)) {
*info = -11;
} else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < max(1,*n)) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CBDSQR", &i__1);
return 0;
}
if (*n == 0) {
return 0;
}
if (*n == 1) {
goto L160;
}
/* ROTATE is true if any singular vectors desired, false otherwise */
rotate = *ncvt > 0 || *nru > 0 || *ncc > 0;
/* If no singular vectors desired, use qd algorithm */
if (! rotate) {
slasq1_(n, &d__[1], &e[1], &rwork[1], info);
return 0;
}
nm1 = *n - 1;
nm12 = nm1 + nm1;
nm13 = nm12 + nm1;
idir = 0;
/* Get machine constants */
eps = slamch_("Epsilon");
unfl = slamch_("Safe minimum");
/* If matrix lower bidiagonal, rotate to be upper bidiagonal */
/* by applying Givens rotations on the left */
if (lower) {
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
slartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__;
e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1];
rwork[i__] = cs;
rwork[nm1 + i__] = sn;
}
/* Update singular vectors if desired */
if (*nru > 0) {
clasr_("R", "V", "F", nru, n, &rwork[1], &rwork[*n], &u[u_offset],
ldu);
}
if (*ncc > 0) {
clasr_("L", "V", "F", n, ncc, &rwork[1], &rwork[*n], &c__[
c_offset], ldc);
}
}
/* Compute singular values to relative accuracy TOL */
/* (By setting TOL to be negative, algorithm will compute */
/* singular values to absolute accuracy ABS(TOL)*norm(input matrix)) */
/* Computing MAX */
/* Computing MIN */
d__1 = (doublereal) eps;
r__3 = 100.f, r__4 = pow_dd(&d__1, &c_b15);
r__1 = 10.f, r__2 = dmin(r__3,r__4);
tolmul = dmax(r__1,r__2);
tol = tolmul * eps;
/* Compute approximate maximum, minimum singular values */
smax = 0.f;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__2 = smax, r__3 = (r__1 = d__[i__], dabs(r__1));
smax = dmax(r__2,r__3);
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__2 = smax, r__3 = (r__1 = e[i__], dabs(r__1));
smax = dmax(r__2,r__3);
}
sminl = 0.f;
if (tol >= 0.f) {
/* Relative accuracy desired */
sminoa = dabs(d__[1]);
if (sminoa == 0.f) {
goto L50;
}
mu = sminoa;
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
mu = (r__2 = d__[i__], dabs(r__2)) * (mu / (mu + (r__1 = e[i__ -
1], dabs(r__1))));
sminoa = dmin(sminoa,mu);
if (sminoa == 0.f) {
goto L50;
}
}
L50:
sminoa /= sqrt((real) (*n));
/* Computing MAX */
r__1 = tol * sminoa, r__2 = *n * 6 * *n * unfl;
thresh = dmax(r__1,r__2);
} else {
/* Absolute accuracy desired */
/* Computing MAX */
r__1 = dabs(tol) * smax, r__2 = *n * 6 * *n * unfl;
thresh = dmax(r__1,r__2);
}
/* Prepare for main iteration loop for the singular values */
/* (MAXIT is the maximum number of passes through the inner */
/* loop permitted before nonconvergence signalled.) */
maxit = *n * 6 * *n;
iter = 0;
oldll = -1;
oldm = -1;
/* M points to last element of unconverged part of matrix */
m = *n;
/* Begin main iteration loop */
L60:
/* Check for convergence or exceeding iteration count */
if (m <= 1) {
goto L160;
}
if (iter > maxit) {
goto L200;
}
/* Find diagonal block of matrix to work on */
if (tol < 0.f && (r__1 = d__[m], dabs(r__1)) <= thresh) {
d__[m] = 0.f;
}
smax = (r__1 = d__[m], dabs(r__1));
smin = smax;
i__1 = m - 1;
for (lll = 1; lll <= i__1; ++lll) {
ll = m - lll;
abss = (r__1 = d__[ll], dabs(r__1));
abse = (r__1 = e[ll], dabs(r__1));
if (tol < 0.f && abss <= thresh) {
d__[ll] = 0.f;
}
if (abse <= thresh) {
goto L80;
}
smin = dmin(smin,abss);
/* Computing MAX */
r__1 = max(smax,abss);
smax = dmax(r__1,abse);
}
ll = 0;
goto L90;
L80:
e[ll] = 0.f;
/* Matrix splits since E(LL) = 0 */
if (ll == m - 1) {
/* Convergence of bottom singular value, return to top of loop */
--m;
goto L60;
}
L90:
++ll;
/* E(LL) through E(M-1) are nonzero, E(LL-1) is zero */
if (ll == m - 1) {
/* 2 by 2 block, handle separately */
slasv2_(&d__[m - 1], &e[m - 1], &d__[m], &sigmn, &sigmx, &sinr, &cosr,
&sinl, &cosl);
d__[m - 1] = sigmx;
e[m - 1] = 0.f;
d__[m] = sigmn;
/* Compute singular vectors, if desired */
if (*ncvt > 0) {
csrot_(ncvt, &vt[m - 1 + vt_dim1], ldvt, &vt[m + vt_dim1], ldvt, &
cosr, &sinr);
}
if (*nru > 0) {
csrot_(nru, &u[(m - 1) * u_dim1 + 1], &c__1, &u[m * u_dim1 + 1], &
c__1, &cosl, &sinl);
}
if (*ncc > 0) {
csrot_(ncc, &c__[m - 1 + c_dim1], ldc, &c__[m + c_dim1], ldc, &
cosl, &sinl);
}
m += -2;
goto L60;
}
/* If working on new submatrix, choose shift direction */
/* (from larger end diagonal element towards smaller) */
if (ll > oldm || m < oldll) {
if ((r__1 = d__[ll], dabs(r__1)) >= (r__2 = d__[m], dabs(r__2))) {
/* Chase bulge from top (big end) to bottom (small end) */
idir = 1;
} else {
/* Chase bulge from bottom (big end) to top (small end) */
idir = 2;
}
}
/* Apply convergence tests */
if (idir == 1) {
/* Run convergence test in forward direction */
/* First apply standard test to bottom of matrix */
if ((r__2 = e[m - 1], dabs(r__2)) <= dabs(tol) * (r__1 = d__[m], dabs(
r__1)) || tol < 0.f && (r__3 = e[m - 1], dabs(r__3)) <=
thresh) {
e[m - 1] = 0.f;
goto L60;
}
if (tol >= 0.f) {
/* If relative accuracy desired, */
/* apply convergence criterion forward */
mu = (r__1 = d__[ll], dabs(r__1));
sminl = mu;
i__1 = m - 1;
for (lll = ll; lll <= i__1; ++lll) {
if ((r__1 = e[lll], dabs(r__1)) <= tol * mu) {
e[lll] = 0.f;
goto L60;
}
mu = (r__2 = d__[lll + 1], dabs(r__2)) * (mu / (mu + (r__1 =
e[lll], dabs(r__1))));
sminl = dmin(sminl,mu);
}
}
} else {
/* Run convergence test in backward direction */
/* First apply standard test to top of matrix */
if ((r__2 = e[ll], dabs(r__2)) <= dabs(tol) * (r__1 = d__[ll], dabs(
r__1)) || tol < 0.f && (r__3 = e[ll], dabs(r__3)) <= thresh) {
e[ll] = 0.f;
goto L60;
}
if (tol >= 0.f) {
/* If relative accuracy desired, */
/* apply convergence criterion backward */
mu = (r__1 = d__[m], dabs(r__1));
sminl = mu;
i__1 = ll;
for (lll = m - 1; lll >= i__1; --lll) {
if ((r__1 = e[lll], dabs(r__1)) <= tol * mu) {
e[lll] = 0.f;
goto L60;
}
mu = (r__2 = d__[lll], dabs(r__2)) * (mu / (mu + (r__1 = e[
lll], dabs(r__1))));
sminl = dmin(sminl,mu);
}
}
}
oldll = ll;
oldm = m;
/* Compute shift. First, test if shifting would ruin relative */
/* accuracy, and if so set the shift to zero. */
/* Computing MAX */
r__1 = eps, r__2 = tol * .01f;
if (tol >= 0.f && *n * tol * (sminl / smax) <= dmax(r__1,r__2)) {
/* Use a zero shift to avoid loss of relative accuracy */
shift = 0.f;
} else {
/* Compute the shift from 2-by-2 block at end of matrix */
if (idir == 1) {
sll = (r__1 = d__[ll], dabs(r__1));
slas2_(&d__[m - 1], &e[m - 1], &d__[m], &shift, &r__);
} else {
sll = (r__1 = d__[m], dabs(r__1));
slas2_(&d__[ll], &e[ll], &d__[ll + 1], &shift, &r__);
}
/* Test if shift negligible, and if so set to zero */
if (sll > 0.f) {
/* Computing 2nd power */
r__1 = shift / sll;
if (r__1 * r__1 < eps) {
shift = 0.f;
}
}
}
/* Increment iteration count */
iter = iter + m - ll;
/* If SHIFT = 0, do simplified QR iteration */
if (shift == 0.f) {
if (idir == 1) {
/* Chase bulge from top to bottom */
/* Save cosines and sines for later singular vector updates */
cs = 1.f;
oldcs = 1.f;
i__1 = m - 1;
for (i__ = ll; i__ <= i__1; ++i__) {
r__1 = d__[i__] * cs;
slartg_(&r__1, &e[i__], &cs, &sn, &r__);
if (i__ > ll) {
e[i__ - 1] = oldsn * r__;
}
r__1 = oldcs * r__;
r__2 = d__[i__ + 1] * sn;
slartg_(&r__1, &r__2, &oldcs, &oldsn, &d__[i__]);
rwork[i__ - ll + 1] = cs;
rwork[i__ - ll + 1 + nm1] = sn;
rwork[i__ - ll + 1 + nm12] = oldcs;
rwork[i__ - ll + 1 + nm13] = oldsn;
}
h__ = d__[m] * cs;
d__[m] = h__ * oldcs;
e[m - 1] = h__ * oldsn;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
clasr_("L", "V", "F", &i__1, ncvt, &rwork[1], &rwork[*n], &vt[
ll + vt_dim1], ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
clasr_("R", "V", "F", nru, &i__1, &rwork[nm12 + 1], &rwork[
nm13 + 1], &u[ll * u_dim1 + 1], ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
clasr_("L", "V", "F", &i__1, ncc, &rwork[nm12 + 1], &rwork[
nm13 + 1], &c__[ll + c_dim1], ldc);
}
/* Test convergence */
if ((r__1 = e[m - 1], dabs(r__1)) <= thresh) {
e[m - 1] = 0.f;
}
} else {
/* Chase bulge from bottom to top */
/* Save cosines and sines for later singular vector updates */
cs = 1.f;
oldcs = 1.f;
i__1 = ll + 1;
for (i__ = m; i__ >= i__1; --i__) {
r__1 = d__[i__] * cs;
slartg_(&r__1, &e[i__ - 1], &cs, &sn, &r__);
if (i__ < m) {
e[i__] = oldsn * r__;
}
r__1 = oldcs * r__;
r__2 = d__[i__ - 1] * sn;
slartg_(&r__1, &r__2, &oldcs, &oldsn, &d__[i__]);
rwork[i__ - ll] = cs;
rwork[i__ - ll + nm1] = -sn;
rwork[i__ - ll + nm12] = oldcs;
rwork[i__ - ll + nm13] = -oldsn;
}
h__ = d__[ll] * cs;
d__[ll] = h__ * oldcs;
e[ll] = h__ * oldsn;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
clasr_("L", "V", "B", &i__1, ncvt, &rwork[nm12 + 1], &rwork[
nm13 + 1], &vt[ll + vt_dim1], ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
clasr_("R", "V", "B", nru, &i__1, &rwork[1], &rwork[*n], &u[
ll * u_dim1 + 1], ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
clasr_("L", "V", "B", &i__1, ncc, &rwork[1], &rwork[*n], &c__[
ll + c_dim1], ldc);
}
/* Test convergence */
if ((r__1 = e[ll], dabs(r__1)) <= thresh) {
e[ll] = 0.f;
}
}
} else {
/* Use nonzero shift */
if (idir == 1) {
/* Chase bulge from top to bottom */
/* Save cosines and sines for later singular vector updates */
f = ((r__1 = d__[ll], dabs(r__1)) - shift) * (r_sign(&c_b49, &d__[
ll]) + shift / d__[ll]);
g = e[ll];
i__1 = m - 1;
for (i__ = ll; i__ <= i__1; ++i__) {
slartg_(&f, &g, &cosr, &sinr, &r__);
if (i__ > ll) {
e[i__ - 1] = r__;
}
f = cosr * d__[i__] + sinr * e[i__];
e[i__] = cosr * e[i__] - sinr * d__[i__];
g = sinr * d__[i__ + 1];
d__[i__ + 1] = cosr * d__[i__ + 1];
slartg_(&f, &g, &cosl, &sinl, &r__);
d__[i__] = r__;
f = cosl * e[i__] + sinl * d__[i__ + 1];
d__[i__ + 1] = cosl * d__[i__ + 1] - sinl * e[i__];
if (i__ < m - 1) {
g = sinl * e[i__ + 1];
e[i__ + 1] = cosl * e[i__ + 1];
}
rwork[i__ - ll + 1] = cosr;
rwork[i__ - ll + 1 + nm1] = sinr;
rwork[i__ - ll + 1 + nm12] = cosl;
rwork[i__ - ll + 1 + nm13] = sinl;
}
e[m - 1] = f;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
clasr_("L", "V", "F", &i__1, ncvt, &rwork[1], &rwork[*n], &vt[
ll + vt_dim1], ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
clasr_("R", "V", "F", nru, &i__1, &rwork[nm12 + 1], &rwork[
nm13 + 1], &u[ll * u_dim1 + 1], ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
clasr_("L", "V", "F", &i__1, ncc, &rwork[nm12 + 1], &rwork[
nm13 + 1], &c__[ll + c_dim1], ldc);
}
/* Test convergence */
if ((r__1 = e[m - 1], dabs(r__1)) <= thresh) {
e[m - 1] = 0.f;
}
} else {
/* Chase bulge from bottom to top */
/* Save cosines and sines for later singular vector updates */
f = ((r__1 = d__[m], dabs(r__1)) - shift) * (r_sign(&c_b49, &d__[
m]) + shift / d__[m]);
g = e[m - 1];
i__1 = ll + 1;
for (i__ = m; i__ >= i__1; --i__) {
slartg_(&f, &g, &cosr, &sinr, &r__);
if (i__ < m) {
e[i__] = r__;
}
f = cosr * d__[i__] + sinr * e[i__ - 1];
e[i__ - 1] = cosr * e[i__ - 1] - sinr * d__[i__];
g = sinr * d__[i__ - 1];
d__[i__ - 1] = cosr * d__[i__ - 1];
slartg_(&f, &g, &cosl, &sinl, &r__);
d__[i__] = r__;
f = cosl * e[i__ - 1] + sinl * d__[i__ - 1];
d__[i__ - 1] = cosl * d__[i__ - 1] - sinl * e[i__ - 1];
if (i__ > ll + 1) {
g = sinl * e[i__ - 2];
e[i__ - 2] = cosl * e[i__ - 2];
}
rwork[i__ - ll] = cosr;
rwork[i__ - ll + nm1] = -sinr;
rwork[i__ - ll + nm12] = cosl;
rwork[i__ - ll + nm13] = -sinl;
}
e[ll] = f;
/* Test convergence */
if ((r__1 = e[ll], dabs(r__1)) <= thresh) {
e[ll] = 0.f;
}
/* Update singular vectors if desired */
if (*ncvt > 0) {
i__1 = m - ll + 1;
clasr_("L", "V", "B", &i__1, ncvt, &rwork[nm12 + 1], &rwork[
nm13 + 1], &vt[ll + vt_dim1], ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
clasr_("R", "V", "B", nru, &i__1, &rwork[1], &rwork[*n], &u[
ll * u_dim1 + 1], ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
clasr_("L", "V", "B", &i__1, ncc, &rwork[1], &rwork[*n], &c__[
ll + c_dim1], ldc);
}
}
}
/* QR iteration finished, go back and check convergence */
goto L60;
/* All singular values converged, so make them positive */
L160:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (d__[i__] < 0.f) {
d__[i__] = -d__[i__];
/* Change sign of singular vectors, if desired */
if (*ncvt > 0) {
csscal_(ncvt, &c_b72, &vt[i__ + vt_dim1], ldvt);
}
}
}
/* Sort the singular values into decreasing order (insertion sort on */
/* singular values, but only one transposition per singular vector) */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Scan for smallest D(I) */
isub = 1;
smin = d__[1];
i__2 = *n + 1 - i__;
for (j = 2; j <= i__2; ++j) {
if (d__[j] <= smin) {
isub = j;
smin = d__[j];
}
}
if (isub != *n + 1 - i__) {
/* Swap singular values and vectors */
d__[isub] = d__[*n + 1 - i__];
d__[*n + 1 - i__] = smin;
if (*ncvt > 0) {
cswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[*n + 1 - i__ +
vt_dim1], ldvt);
}
if (*nru > 0) {
cswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[(*n + 1 - i__) *
u_dim1 + 1], &c__1);
}
if (*ncc > 0) {
cswap_(ncc, &c__[isub + c_dim1], ldc, &c__[*n + 1 - i__ +
c_dim1], ldc);
}
}
}
goto L220;
/* Maximum number of iterations exceeded, failure to converge */
L200:
*info = 0;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (e[i__] != 0.f) {
++(*info);
}
}
L220:
return 0;
/* End of CBDSQR */
} /* cbdsqr_ */
int cgeev_(char *jobvl, char *jobvr, int *n, complex *a,
int *lda, complex *w, complex *vl, int *ldvl, complex *vr,
int *ldvr, complex *work, int *lwork, float *rwork, int *
info)
{
/* System generated locals */
int a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3;
float r__1, r__2;
complex q__1, q__2;
/* Builtin functions */
double sqrt(double), r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
int i__, k, ihi;
float scl;
int ilo;
float dum[1], eps;
complex tmp;
int ibal;
char side[1];
float anrm;
int ierr, itau, iwrk, nout;
extern int cscal_(int *, complex *, complex *,
int *);
extern int lsame_(char *, char *);
extern double scnrm2_(int *, complex *, int *);
extern int cgebak_(char *, char *, int *, int *,
int *, float *, int *, complex *, int *, int *), cgebal_(char *, int *, complex *, int *,
int *, int *, float *, int *), slabad_(float *,
float *);
int scalea;
extern double clange_(char *, int *, int *, complex *,
int *, float *);
float cscale;
extern int cgehrd_(int *, int *, int *,
complex *, int *, complex *, complex *, int *, int *),
clascl_(char *, int *, int *, float *, float *, int *,
int *, complex *, int *, int *);
extern double slamch_(char *);
extern int csscal_(int *, float *, complex *, int
*), clacpy_(char *, int *, int *, complex *, int *,
complex *, int *), xerbla_(char *, int *);
extern int ilaenv_(int *, char *, char *, int *, int *,
int *, int *);
int select[1];
float bignum;
extern int isamax_(int *, float *, int *);
extern int chseqr_(char *, char *, int *, int *,
int *, complex *, int *, complex *, complex *, int *,
complex *, int *, int *), ctrevc_(char *,
char *, int *, int *, complex *, int *, complex *,
int *, complex *, int *, int *, int *, complex *,
float *, int *), cunghr_(int *, int *,
int *, complex *, int *, complex *, complex *, int *,
int *);
int minwrk, maxwrk;
int wantvl;
float smlnum;
int hswork, irwork;
int lquery, wantvr;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGEEV computes for an N-by-N complex nonsymmetric matrix A, the */
/* eigenvalues and, optionally, the left and/or right eigenvectors. */
/* The right eigenvector v(j) of A satisfies */
/* A * v(j) = lambda(j) * v(j) */
/* where lambda(j) is its eigenvalue. */
/* The left eigenvector u(j) of A satisfies */
/* u(j)**H * A = lambda(j) * u(j)**H */
/* where u(j)**H denotes the conjugate transpose of u(j). */
/* The computed eigenvectors are normalized to have Euclidean norm */
/* equal to 1 and largest component float. */
/* Arguments */
/* ========= */
/* JOBVL (input) CHARACTER*1 */
/* = 'N': left eigenvectors of A are not computed; */
/* = 'V': left eigenvectors of are computed. */
/* JOBVR (input) CHARACTER*1 */
/* = 'N': right eigenvectors of A are not computed; */
/* = 'V': right eigenvectors of A are computed. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the N-by-N matrix A. */
/* On exit, A has been overwritten. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* W (output) COMPLEX array, dimension (N) */
/* W contains the computed eigenvalues. */
/* VL (output) COMPLEX array, dimension (LDVL,N) */
/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
/* after another in the columns of VL, in the same order */
/* as their eigenvalues. */
/* If JOBVL = 'N', VL is not referenced. */
/* u(j) = VL(:,j), the j-th column of VL. */
/* LDVL (input) INTEGER */
/* The leading dimension of the array VL. LDVL >= 1; if */
/* JOBVL = 'V', LDVL >= N. */
/* VR (output) COMPLEX array, dimension (LDVR,N) */
/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
/* after another in the columns of VR, in the same order */
/* as their eigenvalues. */
/* If JOBVR = 'N', VR is not referenced. */
/* v(j) = VR(:,j), the j-th column of VR. */
/* LDVR (input) INTEGER */
/* The leading dimension of the array VR. LDVR >= 1; if */
/* JOBVR = 'V', LDVR >= N. */
/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= MAX(1,2*N). */
/* For good performance, LWORK must generally be larger. */
/* 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) REAL array, dimension (2*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = i, the QR algorithm failed to compute all the */
/* eigenvalues, and no eigenvectors have been computed; */
/* elements and i+1:N of W contain eigenvalues which have */
/* converged. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--work;
--rwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1;
wantvl = lsame_(jobvl, "V");
wantvr = lsame_(jobvr, "V");
if (! wantvl && ! lsame_(jobvl, "N")) {
*info = -1;
} else if (! wantvr && ! lsame_(jobvr, "N")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < MAX(1,*n)) {
*info = -5;
} else if (*ldvl < 1 || wantvl && *ldvl < *n) {
*info = -8;
} else if (*ldvr < 1 || wantvr && *ldvr < *n) {
*info = -10;
}
/* 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. */
/* CWorkspace refers to complex workspace, and RWorkspace to float */
/* workspace. NB refers to the optimal block size for the */
/* immediately following subroutine, as returned by ILAENV. */
/* HSWORK refers to the workspace preferred by CHSEQR, as */
/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
/* the worst case.) */
if (*info == 0) {
if (*n == 0) {
minwrk = 1;
maxwrk = 1;
} else {
maxwrk = *n + *n * ilaenv_(&c__1, "CGEHRD", " ", n, &c__1, n, &
c__0);
minwrk = *n << 1;
if (wantvl) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "CUNGHR",
" ", n, &c__1, n, &c_n1);
maxwrk = MAX(i__1,i__2);
chseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vl[
vl_offset], ldvl, &work[1], &c_n1, info);
} else if (wantvr) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "CUNGHR",
" ", n, &c__1, n, &c_n1);
maxwrk = MAX(i__1,i__2);
chseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[1], &c_n1, info);
} else {
chseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[1], &c_n1, info);
}
hswork = work[1].r;
/* Computing MAX */
i__1 = MAX(maxwrk,hswork);
maxwrk = MAX(i__1,minwrk);
}
work[1].r = (float) maxwrk, work[1].i = 0.f;
if (*lwork < minwrk && ! lquery) {
*info = -12;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGEEV ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = clange_("M", n, n, &a[a_offset], lda, dum);
scalea = FALSE;
if (anrm > 0.f && anrm < smlnum) {
scalea = TRUE;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE;
cscale = bignum;
}
if (scalea) {
clascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
ierr);
}
/* Balance the matrix */
/* (CWorkspace: none) */
/* (RWorkspace: need N) */
ibal = 1;
cgebal_("B", n, &a[a_offset], lda, &ilo, &ihi, &rwork[ibal], &ierr);
/* Reduce to upper Hessenberg form */
/* (CWorkspace: need 2*N, prefer N+N*NB) */
/* (RWorkspace: none) */
itau = 1;
iwrk = itau + *n;
i__1 = *lwork - iwrk + 1;
cgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
&ierr);
if (wantvl) {
/* Want left eigenvectors */
/* Copy Householder vectors to VL */
*(unsigned char *)side = 'L';
clacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl)
;
/* Generate unitary matrix in VL */
/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
/* (RWorkspace: none) */
i__1 = *lwork - iwrk + 1;
cunghr_(n, &ilo, &ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk],
&i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VL */
/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
/* (RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
chseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vl[
vl_offset], ldvl, &work[iwrk], &i__1, info);
if (wantvr) {
/* Want left and right eigenvectors */
/* Copy Schur vectors to VR */
*(unsigned char *)side = 'B';
clacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
}
} else if (wantvr) {
/* Want right eigenvectors */
/* Copy Householder vectors to VR */
*(unsigned char *)side = 'R';
clacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr)
;
/* Generate unitary matrix in VR */
/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
/* (RWorkspace: none) */
i__1 = *lwork - iwrk + 1;
cunghr_(n, &ilo, &ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk],
&i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VR */
/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
/* (RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
chseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
} else {
/* Compute eigenvalues only */
/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
/* (RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
chseqr_("E", "N", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
}
/* If INFO > 0 from CHSEQR, then quit */
if (*info > 0) {
goto L50;
}
if (wantvl || wantvr) {
/* Compute left and/or right eigenvectors */
/* (CWorkspace: need 2*N) */
/* (RWorkspace: need 2*N) */
irwork = ibal + *n;
ctrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
&vr[vr_offset], ldvr, n, &nout, &work[iwrk], &rwork[irwork],
&ierr);
}
if (wantvl) {
/* Undo balancing of left eigenvectors */
/* (CWorkspace: none) */
/* (RWorkspace: need N) */
cgebak_("B", "L", n, &ilo, &ihi, &rwork[ibal], n, &vl[vl_offset],
ldvl, &ierr);
/* Normalize left eigenvectors and make largest component float */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
scl = 1.f / scnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
csscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = k + i__ * vl_dim1;
/* Computing 2nd power */
r__1 = vl[i__3].r;
/* Computing 2nd power */
r__2 = r_imag(&vl[k + i__ * vl_dim1]);
rwork[irwork + k - 1] = r__1 * r__1 + r__2 * r__2;
/* L10: */
}
k = isamax_(n, &rwork[irwork], &c__1);
r_cnjg(&q__2, &vl[k + i__ * vl_dim1]);
r__1 = sqrt(rwork[irwork + k - 1]);
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
tmp.r = q__1.r, tmp.i = q__1.i;
cscal_(n, &tmp, &vl[i__ * vl_dim1 + 1], &c__1);
i__2 = k + i__ * vl_dim1;
i__3 = k + i__ * vl_dim1;
r__1 = vl[i__3].r;
q__1.r = r__1, q__1.i = 0.f;
vl[i__2].r = q__1.r, vl[i__2].i = q__1.i;
/* L20: */
}
}
if (wantvr) {
/* Undo balancing of right eigenvectors */
/* (CWorkspace: none) */
/* (RWorkspace: need N) */
cgebak_("B", "R", n, &ilo, &ihi, &rwork[ibal], n, &vr[vr_offset],
ldvr, &ierr);
/* Normalize right eigenvectors and make largest component float */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
scl = 1.f / scnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
csscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = k + i__ * vr_dim1;
/* Computing 2nd power */
r__1 = vr[i__3].r;
/* Computing 2nd power */
r__2 = r_imag(&vr[k + i__ * vr_dim1]);
rwork[irwork + k - 1] = r__1 * r__1 + r__2 * r__2;
/* L30: */
}
k = isamax_(n, &rwork[irwork], &c__1);
r_cnjg(&q__2, &vr[k + i__ * vr_dim1]);
r__1 = sqrt(rwork[irwork + k - 1]);
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
tmp.r = q__1.r, tmp.i = q__1.i;
cscal_(n, &tmp, &vr[i__ * vr_dim1 + 1], &c__1);
i__2 = k + i__ * vr_dim1;
i__3 = k + i__ * vr_dim1;
r__1 = vr[i__3].r;
q__1.r = r__1, q__1.i = 0.f;
vr[i__2].r = q__1.r, vr[i__2].i = q__1.i;
/* L40: */
}
}
/* Undo scaling if necessary */
L50:
if (scalea) {
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = MAX(i__3,1);
clascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[*info + 1]
, &i__2, &ierr);
if (*info > 0) {
i__1 = ilo - 1;
clascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[1], n,
&ierr);
}
}
work[1].r = (float) maxwrk, work[1].i = 0.f;
return 0;
/* End of CGEEV */
} /* cgeev_ */
/* Subroutine */ int cheevr_(char *jobz, char *range, char *uplo, integer *n,
complex *a, integer *lda, real *vl, real *vu, integer *il, integer *
iu, real *abstol, integer *m, real *w, complex *z__, integer *ldz,
integer *isuppz, complex *work, integer *lwork, real *rwork, integer *
lrwork, integer *iwork, integer *liwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, nb, jj;
real eps, vll, vuu, tmp1, anrm;
integer imax;
real rmin, rmax;
logical test;
integer itmp1, indrd, indre;
real sigma;
extern logical lsame_(char *, char *);
integer iinfo;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
char order[1];
integer indwk;
extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
complex *, integer *);
integer lwmin;
logical lower;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
logical wantz, alleig, indeig;
integer iscale, ieeeok, indibl, indrdd, indifl, indree;
logical valeig;
extern doublereal slamch_(char *);
extern /* Subroutine */ int chetrd_(char *, integer *, complex *, integer
*, real *, real *, complex *, complex *, integer *, integer *), csscal_(integer *, real *, complex *, integer *);
real safmin;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *);
real abstll, bignum;
integer indtau, indisp;
extern /* Subroutine */ int cstein_(integer *, real *, real *, integer *,
real *, integer *, integer *, complex *, integer *, real *,
integer *, integer *, integer *);
integer indiwo, indwkn;
extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
real *);
extern /* Subroutine */ int cstemr_(char *, char *, integer *, real *,
real *, real *, real *, integer *, integer *, integer *, real *,
complex *, integer *, integer *, integer *, logical *, real *,
integer *, integer *, integer *, integer *);
integer indrwk, liwmin;
logical tryrac;
extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *);
integer lrwmin, llwrkn, llwork, nsplit;
real smlnum;
extern /* Subroutine */ int cunmtr_(char *, char *, char *, integer *,
integer *, complex *, integer *, complex *, complex *, integer *,
complex *, integer *, integer *), sstebz_(
char *, char *, integer *, real *, real *, integer *, integer *,
real *, real *, real *, integer *, integer *, real *, integer *,
integer *, real *, integer *, integer *);
logical lquery;
integer lwkopt, llrwork;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHEEVR computes selected eigenvalues and, optionally, eigenvectors */
/* of a complex Hermitian matrix A. Eigenvalues and eigenvectors can */
/* be selected by specifying either a range of values or a range of */
/* indices for the desired eigenvalues. */
/* CHEEVR first reduces the matrix A to tridiagonal form T with a call */
/* to CHETRD. Then, whenever possible, CHEEVR calls CSTEMR to compute */
/* the eigenspectrum using Relatively Robust Representations. CSTEMR */
/* computes eigenvalues by the dqds algorithm, while orthogonal */
/* eigenvectors are computed from various "good" L D L^T representations */
/* (also known as Relatively Robust Representations). Gram-Schmidt */
/* orthogonalization is avoided as far as possible. More specifically, */
/* the various steps of the algorithm are as follows. */
/* For each unreduced block (submatrix) of T, */
/* (a) Compute T - sigma I = L D L^T, so that L and D */
/* define all the wanted eigenvalues to high relative accuracy. */
/* This means that small relative changes in the entries of D and L */
/* cause only small relative changes in the eigenvalues and */
/* eigenvectors. The standard (unfactored) representation of the */
/* tridiagonal matrix T does not have this property in general. */
/* (b) Compute the eigenvalues to suitable accuracy. */
/* If the eigenvectors are desired, the algorithm attains full */
/* accuracy of the computed eigenvalues only right before */
/* the corresponding vectors have to be computed, see steps c) and d). */
/* (c) For each cluster of close eigenvalues, select a new */
/* shift close to the cluster, find a new factorization, and refine */
/* the shifted eigenvalues to suitable accuracy. */
/* (d) For each eigenvalue with a large enough relative separation compute */
/* the corresponding eigenvector by forming a rank revealing twisted */
/* factorization. Go back to (c) for any clusters that remain. */
/* The desired accuracy of the output can be specified by the input */
/* parameter ABSTOL. */
/* For more details, see DSTEMR's documentation and: */
/* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */
/* to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */
/* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */
/* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */
/* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */
/* 2004. Also LAPACK Working Note 154. */
/* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */
/* tridiagonal eigenvalue/eigenvector problem", */
/* Computer Science Division Technical Report No. UCB/CSD-97-971, */
/* UC Berkeley, May 1997. */
/* Note 1 : CHEEVR calls CSTEMR when the full spectrum is requested */
/* on machines which conform to the ieee-754 floating point standard. */
/* CHEEVR calls SSTEBZ and CSTEIN on non-ieee machines and */
/* when partial spectrum requests are made. */
/* Normal execution of CSTEMR may create NaNs and infinities and */
/* hence may abort due to a floating point exception in environments */
/* which do not handle NaNs and infinities in the ieee standard default */
/* manner. */
/* Arguments */
/* ========= */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* RANGE (input) CHARACTER*1 */
/* = 'A': all eigenvalues will be found. */
/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
/* will be found. */
/* = 'I': the IL-th through IU-th eigenvalues will be found. */
/* ********* For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and */
/* ********* CSTEIN are called */
/* 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. */
/* A (input/output) COMPLEX array, dimension (LDA, N) */
/* On entry, 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. If UPLO = 'L', */
/* the leading N-by-N lower triangular part of A contains */
/* the lower triangular part of the matrix A. */
/* On exit, the lower triangle (if UPLO='L') or the upper */
/* triangle (if UPLO='U') of A, including the diagonal, is */
/* destroyed. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* VL (input) REAL */
/* VU (input) REAL */
/* If RANGE='V', the lower and upper bounds of the interval to */
/* be searched for eigenvalues. VL < VU. */
/* Not referenced if RANGE = 'A' or 'I'. */
/* IL (input) INTEGER */
/* IU (input) INTEGER */
/* If RANGE='I', the indices (in ascending order) of the */
/* smallest and largest eigenvalues to be returned. */
/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
/* Not referenced if RANGE = 'A' or 'V'. */
/* ABSTOL (input) REAL */
/* The absolute error tolerance for the eigenvalues. */
/* An approximate eigenvalue is accepted as converged */
/* when it is determined to lie in an interval [a,b] */
/* of width less than or equal to */
/* ABSTOL + EPS * max( |a|,|b| ) , */
/* where EPS is the machine precision. If ABSTOL is less than */
/* or equal to zero, then EPS*|T| will be used in its place, */
/* where |T| is the 1-norm of the tridiagonal matrix obtained */
/* by reducing A to tridiagonal form. */
/* See "Computing Small Singular Values of Bidiagonal Matrices */
/* with Guaranteed High Relative Accuracy," by Demmel and */
/* Kahan, LAPACK Working Note #3. */
/* If high relative accuracy is important, set ABSTOL to */
/* SLAMCH( 'Safe minimum' ). Doing so will guarantee that */
/* eigenvalues are computed to high relative accuracy when */
/* possible in future releases. The current code does not */
/* make any guarantees about high relative accuracy, but */
/* furutre releases will. See J. Barlow and J. Demmel, */
/* "Computing Accurate Eigensystems of Scaled Diagonally */
/* Dominant Matrices", LAPACK Working Note #7, for a discussion */
/* of which matrices define their eigenvalues to high relative */
/* accuracy. */
/* M (output) INTEGER */
/* The total number of eigenvalues found. 0 <= M <= N. */
/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
/* W (output) REAL array, dimension (N) */
/* The first M elements contain the selected eigenvalues in */
/* ascending order. */
/* Z (output) COMPLEX array, dimension (LDZ, max(1,M)) */
/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
/* contain the orthonormal eigenvectors of the matrix A */
/* corresponding to the selected eigenvalues, with the i-th */
/* column of Z holding the eigenvector associated with W(i). */
/* If JOBZ = 'N', then Z is not referenced. */
/* Note: the user must ensure that at least max(1,M) columns are */
/* supplied in the array Z; if RANGE = 'V', the exact value of M */
/* is not known in advance and an upper bound must be used. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= max(1,N). */
/* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) ) */
/* The support of the eigenvectors in Z, i.e., the indices */
/* indicating the nonzero elements in Z. The i-th eigenvector */
/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */
/* ISUPPZ( 2*i ). */
/* ********* Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 */
/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The length of the array WORK. LWORK >= max(1,2*N). */
/* For optimal efficiency, LWORK >= (NB+1)*N, */
/* where NB is the max of the blocksize for CHETRD and for */
/* CUNMTR as returned by ILAENV. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal sizes of the WORK, RWORK and */
/* IWORK arrays, returns these values as the first entries of */
/* the WORK, RWORK and IWORK arrays, and no error message */
/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
/* RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK)) */
/* On exit, if INFO = 0, RWORK(1) returns the optimal */
/* (and minimal) LRWORK. */
/* LRWORK (input) INTEGER */
/* The length of the array RWORK. LRWORK >= max(1,24*N). */
/* If LRWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal sizes of the WORK, RWORK */
/* and IWORK arrays, returns these values as the first entries */
/* of the WORK, RWORK and IWORK arrays, and no error message */
/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
/* On exit, if INFO = 0, IWORK(1) returns the optimal */
/* (and minimal) LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. LIWORK >= max(1,10*N). */
/* If LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal sizes of the WORK, RWORK */
/* and IWORK arrays, returns these values as the first entries */
/* of the WORK, RWORK and IWORK arrays, and no error message */
/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: Internal error */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Inderjit Dhillon, IBM Almaden, USA */
/* Osni Marques, LBNL/NERSC, USA */
/* Ken Stanley, Computer Science Division, University of */
/* California at Berkeley, USA */
/* Jason Riedy, Computer Science Division, University of */
/* California at Berkeley, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--isuppz;
--work;
--rwork;
--iwork;
/* Function Body */
ieeeok = ilaenv_(&c__10, "CHEEVR", "N", &c__1, &c__2, &c__3, &c__4);
lower = lsame_(uplo, "L");
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1;
/* Computing MAX */
i__1 = 1, i__2 = *n * 24;
lrwmin = max(i__1,i__2);
/* Computing MAX */
i__1 = 1, i__2 = *n * 10;
liwmin = max(i__1,i__2);
/* Computing MAX */
i__1 = 1, i__2 = *n << 1;
lwmin = max(i__1,i__2);
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (! (lower || lsame_(uplo, "U"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else {
if (valeig) {
if (*n > 0 && *vu <= *vl) {
*info = -8;
}
} else if (indeig) {
if (*il < 1 || *il > max(1,*n)) {
*info = -9;
} else if (*iu < min(*n,*il) || *iu > *n) {
*info = -10;
}
}
}
if (*info == 0) {
if (*ldz < 1 || wantz && *ldz < *n) {
*info = -15;
}
}
if (*info == 0) {
nb = ilaenv_(&c__1, "CHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__1, "CUNMTR", uplo, n, &c_n1, &c_n1, &
c_n1);
nb = max(i__1,i__2);
/* Computing MAX */
i__1 = (nb + 1) * *n;
lwkopt = max(i__1,lwmin);
work[1].r = (real) lwkopt, work[1].i = 0.f;
rwork[1] = (real) lrwmin;
iwork[1] = liwmin;
if (*lwork < lwmin && ! lquery) {
*info = -18;
} else if (*lrwork < lrwmin && ! lquery) {
*info = -20;
} else if (*liwork < liwmin && ! lquery) {
*info = -22;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHEEVR", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
work[1].r = 1.f, work[1].i = 0.f;
return 0;
}
if (*n == 1) {
work[1].r = 2.f, work[1].i = 0.f;
if (alleig || indeig) {
*m = 1;
i__1 = a_dim1 + 1;
w[1] = a[i__1].r;
} else {
i__1 = a_dim1 + 1;
i__2 = a_dim1 + 1;
if (*vl < a[i__1].r && *vu >= a[i__2].r) {
*m = 1;
i__1 = a_dim1 + 1;
w[1] = a[i__1].r;
}
}
if (wantz) {
i__1 = z_dim1 + 1;
z__[i__1].r = 1.f, z__[i__1].i = 0.f;
}
return 0;
}
/* Get machine constants. */
safmin = slamch_("Safe minimum");
eps = slamch_("Precision");
smlnum = safmin / eps;
bignum = 1.f / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin));
rmax = dmin(r__1,r__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
abstll = *abstol;
if (valeig) {
vll = *vl;
vuu = *vu;
}
anrm = clansy_("M", uplo, n, &a[a_offset], lda, &rwork[1]);
if (anrm > 0.f && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
if (lower) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j + 1;
csscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1);
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
csscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1);
/* L20: */
}
}
if (*abstol > 0.f) {
abstll = *abstol * sigma;
}
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Initialize indices into workspaces. Note: The IWORK indices are */
/* used only if SSTERF or CSTEMR fail. */
/* WORK(INDTAU:INDTAU+N-1) stores the complex scalar factors of the */
/* elementary reflectors used in CHETRD. */
indtau = 1;
/* INDWK is the starting offset of the remaining complex workspace, */
/* and LLWORK is the remaining complex workspace size. */
indwk = indtau + *n;
llwork = *lwork - indwk + 1;
/* RWORK(INDRD:INDRD+N-1) stores the real tridiagonal's diagonal */
/* entries. */
indrd = 1;
/* RWORK(INDRE:INDRE+N-1) stores the off-diagonal entries of the */
/* tridiagonal matrix from CHETRD. */
indre = indrd + *n;
/* RWORK(INDRDD:INDRDD+N-1) is a copy of the diagonal entries over */
/* -written by CSTEMR (the SSTERF path copies the diagonal to W). */
indrdd = indre + *n;
/* RWORK(INDREE:INDREE+N-1) is a copy of the off-diagonal entries over */
/* -written while computing the eigenvalues in SSTERF and CSTEMR. */
indree = indrdd + *n;
/* INDRWK is the starting offset of the left-over real workspace, and */
/* LLRWORK is the remaining workspace size. */
indrwk = indree + *n;
llrwork = *lrwork - indrwk + 1;
/* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in SSTEBZ and */
/* stores the block indices of each of the M<=N eigenvalues. */
indibl = 1;
/* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in SSTEBZ and */
/* stores the starting and finishing indices of each block. */
indisp = indibl + *n;
/* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors */
/* that corresponding to eigenvectors that fail to converge in */
/* SSTEIN. This information is discarded; if any fail, the driver */
/* returns INFO > 0. */
indifl = indisp + *n;
/* INDIWO is the offset of the remaining integer workspace. */
indiwo = indisp + *n;
/* Call CHETRD to reduce Hermitian matrix to tridiagonal form. */
chetrd_(uplo, n, &a[a_offset], lda, &rwork[indrd], &rwork[indre], &work[
indtau], &work[indwk], &llwork, &iinfo);
/* If all eigenvalues are desired */
/* then call SSTERF or CSTEMR and CUNMTR. */
test = FALSE_;
if (indeig) {
if (*il == 1 && *iu == *n) {
test = TRUE_;
}
}
if ((alleig || test) && ieeeok == 1) {
if (! wantz) {
scopy_(n, &rwork[indrd], &c__1, &w[1], &c__1);
i__1 = *n - 1;
scopy_(&i__1, &rwork[indre], &c__1, &rwork[indree], &c__1);
ssterf_(n, &w[1], &rwork[indree], info);
} else {
i__1 = *n - 1;
scopy_(&i__1, &rwork[indre], &c__1, &rwork[indree], &c__1);
scopy_(n, &rwork[indrd], &c__1, &rwork[indrdd], &c__1);
if (*abstol <= *n * 2.f * eps) {
tryrac = TRUE_;
} else {
tryrac = FALSE_;
}
cstemr_(jobz, "A", n, &rwork[indrdd], &rwork[indree], vl, vu, il,
iu, m, &w[1], &z__[z_offset], ldz, n, &isuppz[1], &tryrac,
&rwork[indrwk], &llrwork, &iwork[1], liwork, info);
/* Apply unitary matrix used in reduction to tridiagonal */
/* form to eigenvectors returned by CSTEIN. */
if (wantz && *info == 0) {
indwkn = indwk;
llwrkn = *lwork - indwkn + 1;
cunmtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau]
, &z__[z_offset], ldz, &work[indwkn], &llwrkn, &iinfo);
}
}
if (*info == 0) {
*m = *n;
goto L30;
}
*info = 0;
}
/* Otherwise, call SSTEBZ and, if eigenvectors are desired, CSTEIN. */
/* Also call SSTEBZ and CSTEIN if CSTEMR fails. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indrd], &
rwork[indre], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &
rwork[indrwk], &iwork[indiwo], info);
if (wantz) {
cstein_(n, &rwork[indrd], &rwork[indre], m, &w[1], &iwork[indibl], &
iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[
indiwo], &iwork[indifl], info);
/* Apply unitary matrix used in reduction to tridiagonal */
/* form to eigenvectors returned by CSTEIN. */
indwkn = indwk;
llwrkn = *lwork - indwkn + 1;
cunmtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[
z_offset], ldz, &work[indwkn], &llwrkn, &iinfo);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
L30:
if (iscale == 1) {
if (*info == 0) {
imax = *m;
} else {
imax = *info - 1;
}
r__1 = 1.f / sigma;
sscal_(&imax, &r__1, &w[1], &c__1);
}
/* If eigenvalues are not in order, then sort them, along with */
/* eigenvectors. */
if (wantz) {
i__1 = *m - 1;
for (j = 1; j <= i__1; ++j) {
i__ = 0;
tmp1 = w[j];
i__2 = *m;
for (jj = j + 1; jj <= i__2; ++jj) {
if (w[jj] < tmp1) {
i__ = jj;
tmp1 = w[jj];
}
/* L40: */
}
if (i__ != 0) {
itmp1 = iwork[indibl + i__ - 1];
w[i__] = w[j];
iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
w[j] = tmp1;
iwork[indibl + j - 1] = itmp1;
cswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
&c__1);
}
/* L50: */
}
}
/* Set WORK(1) to optimal workspace size. */
work[1].r = (real) lwkopt, work[1].i = 0.f;
rwork[1] = (real) lrwmin;
iwork[1] = liwmin;
return 0;
/* End of CHEEVR */
} /* cheevr_ */
/* DECK CSPCO */
/* Subroutine */ int cspco_(complex *ap, integer *n, integer *kpvt, real *
rcond, complex *z__)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8;
complex q__1, q__2, q__3;
/* Local variables */
static integer i__, j, k;
static real s;
static complex t;
static integer j1;
static complex ak, bk, ek;
static integer ij, ik, kk, kp, ks, jm1, kps;
static complex akm1, bkm1;
static integer ikm1, km1k, ikp1, info;
extern /* Subroutine */ int cspfa_(complex *, integer *, integer *,
integer *);
static integer km1km1;
static complex denom;
static real anorm;
extern /* Complex */ void cdotu_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
static real ynorm;
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*);
extern doublereal scasum_(integer *, complex *, integer *);
/* ***BEGIN PROLOGUE CSPCO */
/* ***PURPOSE Factor a complex symmetric matrix stored in packed form */
/* by elimination with symmetric pivoting and estimate the */
/* condition number of the matrix. */
/* ***LIBRARY SLATEC (LINPACK) */
/* ***CATEGORY D2C1 */
/* ***TYPE COMPLEX (SSPCO-S, DSPCO-D, CHPCO-C, CSPCO-C) */
/* ***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, */
/* MATRIX FACTORIZATION, PACKED, SYMMETRIC */
/* ***AUTHOR Moler, C. B., (U. of New Mexico) */
/* ***DESCRIPTION */
/* CSPCO factors a complex symmetric matrix stored in packed */
/* form by elimination with symmetric pivoting and estimates */
/* the condition of the matrix. */
/* If RCOND is not needed, CSPFA is slightly faster. */
/* To solve A*X = B , follow CSPCO by CSPSL. */
/* To compute INVERSE(A)*C , follow CSPCO by CSPSL. */
/* To compute INVERSE(A) , follow CSPCO by CSPDI. */
/* To compute DETERMINANT(A) , follow CSPCO by CSPDI. */
/* On Entry */
/* AP COMPLEX (N*(N+1)/2) */
/* the packed form of a symmetric matrix A . The */
/* columns of the upper triangle are stored sequentially */
/* in a one-dimensional array of length N*(N+1)/2 . */
/* See comments below for details. */
/* N INTEGER */
/* the order of the matrix A . */
/* On Return */
/* AP a block diagonal matrix and the multipliers which */
/* were used to obtain it stored in packed form. */
/* The factorization can be written A = U*D*TRANS(U) */
/* where U is a product of permutation and unit */
/* upper triangular matrices , TRANS(U) is the */
/* transpose of U , and D is block diagonal */
/* with 1 by 1 and 2 by 2 blocks. */
/* KVPT INTEGER(N) */
/* an integer vector of pivot indices. */
/* RCOND REAL */
/* an estimate of the reciprocal condition of A . */
/* For the system A*X = B , relative perturbations */
/* in A and B of size EPSILON may cause */
/* relative perturbations in X of size EPSILON/RCOND . */
/* If RCOND is so small that the logical expression */
/* 1.0 + RCOND .EQ. 1.0 */
/* is true, then A may be singular to working */
/* precision. In particular, RCOND is zero if */
/* exact singularity is detected or the estimate */
/* underflows. */
/* Z COMPLEX(N) */
/* a work vector whose contents are usually unimportant. */
/* If A is close to a singular matrix, then Z is */
/* an approximate null vector in the sense that */
/* NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . */
/* Packed Storage */
/* The following program segment will pack the upper */
/* triangle of a symmetric matrix. */
/* K = 0 */
/* DO 20 J = 1, N */
/* DO 10 I = 1, J */
/* K = K + 1 */
/* AP(K) = A(I,J) */
/* 10 CONTINUE */
/* 20 CONTINUE */
/* ***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. */
/* Stewart, LINPACK Users' Guide, SIAM, 1979. */
/* ***ROUTINES CALLED CAXPY, CDOTU, CSPFA, CSSCAL, SCASUM */
/* ***REVISION HISTORY (YYMMDD) */
/* 780814 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 891107 Corrected category and modified routine equivalence */
/* list. (WRB) */
/* 891107 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE CSPCO */
/* FIND NORM OF A USING ONLY UPPER HALF */
/* ***FIRST EXECUTABLE STATEMENT CSPCO */
/* Parameter adjustments */
--z__;
--kpvt;
--ap;
/* Function Body */
j1 = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
r__1 = scasum_(&j, &ap[j1], &c__1);
q__1.r = r__1, q__1.i = 0.f;
z__[i__2].r = q__1.r, z__[i__2].i = q__1.i;
ij = j1;
j1 += j;
jm1 = j - 1;
if (jm1 < 1) {
goto L20;
}
i__2 = jm1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = ij;
r__3 = z__[i__4].r + ((r__1 = ap[i__5].r, dabs(r__1)) + (r__2 =
r_imag(&ap[ij]), dabs(r__2)));
q__1.r = r__3, q__1.i = 0.f;
z__[i__3].r = q__1.r, z__[i__3].i = q__1.i;
++ij;
/* L10: */
}
L20:
/* L30: */
;
}
anorm = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = j;
r__1 = anorm, r__2 = z__[i__2].r;
anorm = dmax(r__1,r__2);
/* L40: */
}
/* FACTOR */
cspfa_(&ap[1], n, &kpvt[1], &info);
/* RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . */
/* ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . */
/* THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL */
/* GROWTH IN THE ELEMENTS OF W WHERE U*D*W = E . */
/* THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. */
/* SOLVE U*D*W = E */
ek.r = 1.f, ek.i = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
z__[i__2].r = 0.f, z__[i__2].i = 0.f;
/* L50: */
}
k = *n;
ik = *n * (*n - 1) / 2;
L60:
if (k == 0) {
goto L120;
}
kk = ik + k;
ikm1 = ik - (k - 1);
ks = 1;
if (kpvt[k] < 0) {
ks = 2;
}
kp = (i__1 = kpvt[k], abs(i__1));
kps = k + 1 - ks;
if (kp == kps) {
goto L70;
}
i__1 = kps;
t.r = z__[i__1].r, t.i = z__[i__1].i;
i__1 = kps;
i__2 = kp;
z__[i__1].r = z__[i__2].r, z__[i__1].i = z__[i__2].i;
i__1 = kp;
z__[i__1].r = t.r, z__[i__1].i = t.i;
L70:
i__1 = k;
if ((r__1 = z__[i__1].r, dabs(r__1)) + (r__2 = r_imag(&z__[k]), dabs(r__2)
) != 0.f) {
r__7 = (r__3 = ek.r, dabs(r__3)) + (r__4 = r_imag(&ek), dabs(r__4));
i__2 = k;
i__3 = k;
r__8 = (r__5 = z__[i__3].r, dabs(r__5)) + (r__6 = r_imag(&z__[k]),
dabs(r__6));
q__2.r = z__[i__2].r / r__8, q__2.i = z__[i__2].i / r__8;
q__1.r = r__7 * q__2.r, q__1.i = r__7 * q__2.i;
ek.r = q__1.r, ek.i = q__1.i;
}
i__1 = k;
i__2 = k;
q__1.r = z__[i__2].r + ek.r, q__1.i = z__[i__2].i + ek.i;
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
i__1 = k - ks;
caxpy_(&i__1, &z__[k], &ap[ik + 1], &c__1, &z__[1], &c__1);
if (ks == 1) {
goto L80;
}
i__1 = k - 1;
if ((r__1 = z__[i__1].r, dabs(r__1)) + (r__2 = r_imag(&z__[k - 1]), dabs(
r__2)) != 0.f) {
r__7 = (r__3 = ek.r, dabs(r__3)) + (r__4 = r_imag(&ek), dabs(r__4));
i__2 = k - 1;
i__3 = k - 1;
r__8 = (r__5 = z__[i__3].r, dabs(r__5)) + (r__6 = r_imag(&z__[k - 1]),
dabs(r__6));
q__2.r = z__[i__2].r / r__8, q__2.i = z__[i__2].i / r__8;
q__1.r = r__7 * q__2.r, q__1.i = r__7 * q__2.i;
ek.r = q__1.r, ek.i = q__1.i;
}
i__1 = k - 1;
i__2 = k - 1;
q__1.r = z__[i__2].r + ek.r, q__1.i = z__[i__2].i + ek.i;
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
i__1 = k - ks;
caxpy_(&i__1, &z__[k - 1], &ap[ikm1 + 1], &c__1, &z__[1], &c__1);
L80:
if (ks == 2) {
goto L100;
}
i__1 = k;
i__2 = kk;
if ((r__1 = z__[i__1].r, dabs(r__1)) + (r__2 = r_imag(&z__[k]), dabs(r__2)
) <= (r__3 = ap[i__2].r, dabs(r__3)) + (r__4 = r_imag(&ap[kk]),
dabs(r__4))) {
goto L90;
}
i__1 = kk;
i__2 = k;
s = ((r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[kk]), dabs(r__2)
)) / ((r__3 = z__[i__2].r, dabs(r__3)) + (r__4 = r_imag(&z__[k]),
dabs(r__4)));
csscal_(n, &s, &z__[1], &c__1);
q__2.r = s, q__2.i = 0.f;
q__1.r = q__2.r * ek.r - q__2.i * ek.i, q__1.i = q__2.r * ek.i + q__2.i *
ek.r;
ek.r = q__1.r, ek.i = q__1.i;
L90:
i__1 = kk;
if ((r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[kk]), dabs(r__2))
!= 0.f) {
i__2 = k;
c_div(&q__1, &z__[k], &ap[kk]);
z__[i__2].r = q__1.r, z__[i__2].i = q__1.i;
}
i__1 = kk;
if ((r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[kk]), dabs(r__2))
== 0.f) {
i__2 = k;
z__[i__2].r = 1.f, z__[i__2].i = 0.f;
}
goto L110;
L100:
km1k = ik + k - 1;
km1km1 = ikm1 + k - 1;
c_div(&q__1, &ap[kk], &ap[km1k]);
ak.r = q__1.r, ak.i = q__1.i;
c_div(&q__1, &ap[km1km1], &ap[km1k]);
akm1.r = q__1.r, akm1.i = q__1.i;
c_div(&q__1, &z__[k], &ap[km1k]);
bk.r = q__1.r, bk.i = q__1.i;
c_div(&q__1, &z__[k - 1], &ap[km1k]);
bkm1.r = q__1.r, bkm1.i = q__1.i;
q__2.r = ak.r * akm1.r - ak.i * akm1.i, q__2.i = ak.r * akm1.i + ak.i *
akm1.r;
q__1.r = q__2.r - 1.f, q__1.i = q__2.i;
denom.r = q__1.r, denom.i = q__1.i;
i__1 = k;
q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r * bk.i + akm1.i *
bk.r;
q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i;
c_div(&q__1, &q__2, &denom);
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
i__1 = k - 1;
q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r * bkm1.i + ak.i *
bkm1.r;
q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i;
c_div(&q__1, &q__2, &denom);
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
L110:
k -= ks;
ik -= k;
if (ks == 2) {
ik -= k + 1;
}
goto L60;
L120:
s = 1.f / scasum_(n, &z__[1], &c__1);
csscal_(n, &s, &z__[1], &c__1);
/* SOLVE TRANS(U)*Y = W */
k = 1;
ik = 0;
L130:
if (k > *n) {
goto L160;
}
ks = 1;
if (kpvt[k] < 0) {
ks = 2;
}
if (k == 1) {
goto L150;
}
i__1 = k;
i__2 = k;
i__3 = k - 1;
cdotu_(&q__2, &i__3, &ap[ik + 1], &c__1, &z__[1], &c__1);
q__1.r = z__[i__2].r + q__2.r, q__1.i = z__[i__2].i + q__2.i;
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
ikp1 = ik + k;
if (ks == 2) {
i__1 = k + 1;
i__2 = k + 1;
i__3 = k - 1;
cdotu_(&q__2, &i__3, &ap[ikp1 + 1], &c__1, &z__[1], &c__1);
q__1.r = z__[i__2].r + q__2.r, q__1.i = z__[i__2].i + q__2.i;
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
}
kp = (i__1 = kpvt[k], abs(i__1));
if (kp == k) {
goto L140;
}
i__1 = k;
t.r = z__[i__1].r, t.i = z__[i__1].i;
i__1 = k;
i__2 = kp;
z__[i__1].r = z__[i__2].r, z__[i__1].i = z__[i__2].i;
i__1 = kp;
z__[i__1].r = t.r, z__[i__1].i = t.i;
L140:
L150:
ik += k;
if (ks == 2) {
ik += k + 1;
}
k += ks;
goto L130;
L160:
s = 1.f / scasum_(n, &z__[1], &c__1);
csscal_(n, &s, &z__[1], &c__1);
ynorm = 1.f;
/* SOLVE U*D*V = Y */
k = *n;
ik = *n * (*n - 1) / 2;
L170:
if (k == 0) {
goto L230;
}
kk = ik + k;
ikm1 = ik - (k - 1);
ks = 1;
if (kpvt[k] < 0) {
ks = 2;
}
if (k == ks) {
goto L190;
}
kp = (i__1 = kpvt[k], abs(i__1));
kps = k + 1 - ks;
if (kp == kps) {
goto L180;
}
i__1 = kps;
t.r = z__[i__1].r, t.i = z__[i__1].i;
i__1 = kps;
i__2 = kp;
z__[i__1].r = z__[i__2].r, z__[i__1].i = z__[i__2].i;
i__1 = kp;
z__[i__1].r = t.r, z__[i__1].i = t.i;
L180:
i__1 = k - ks;
caxpy_(&i__1, &z__[k], &ap[ik + 1], &c__1, &z__[1], &c__1);
if (ks == 2) {
i__1 = k - ks;
caxpy_(&i__1, &z__[k - 1], &ap[ikm1 + 1], &c__1, &z__[1], &c__1);
}
L190:
if (ks == 2) {
goto L210;
}
i__1 = k;
i__2 = kk;
if ((r__1 = z__[i__1].r, dabs(r__1)) + (r__2 = r_imag(&z__[k]), dabs(r__2)
) <= (r__3 = ap[i__2].r, dabs(r__3)) + (r__4 = r_imag(&ap[kk]),
dabs(r__4))) {
goto L200;
}
i__1 = kk;
i__2 = k;
s = ((r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[kk]), dabs(r__2)
)) / ((r__3 = z__[i__2].r, dabs(r__3)) + (r__4 = r_imag(&z__[k]),
dabs(r__4)));
csscal_(n, &s, &z__[1], &c__1);
ynorm = s * ynorm;
L200:
i__1 = kk;
if ((r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[kk]), dabs(r__2))
!= 0.f) {
i__2 = k;
c_div(&q__1, &z__[k], &ap[kk]);
z__[i__2].r = q__1.r, z__[i__2].i = q__1.i;
}
i__1 = kk;
if ((r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[kk]), dabs(r__2))
== 0.f) {
i__2 = k;
z__[i__2].r = 1.f, z__[i__2].i = 0.f;
}
goto L220;
L210:
km1k = ik + k - 1;
km1km1 = ikm1 + k - 1;
c_div(&q__1, &ap[kk], &ap[km1k]);
ak.r = q__1.r, ak.i = q__1.i;
c_div(&q__1, &ap[km1km1], &ap[km1k]);
akm1.r = q__1.r, akm1.i = q__1.i;
c_div(&q__1, &z__[k], &ap[km1k]);
bk.r = q__1.r, bk.i = q__1.i;
c_div(&q__1, &z__[k - 1], &ap[km1k]);
bkm1.r = q__1.r, bkm1.i = q__1.i;
q__2.r = ak.r * akm1.r - ak.i * akm1.i, q__2.i = ak.r * akm1.i + ak.i *
akm1.r;
q__1.r = q__2.r - 1.f, q__1.i = q__2.i;
denom.r = q__1.r, denom.i = q__1.i;
i__1 = k;
q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r * bk.i + akm1.i *
bk.r;
q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i;
c_div(&q__1, &q__2, &denom);
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
i__1 = k - 1;
q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r * bkm1.i + ak.i *
bkm1.r;
q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i;
c_div(&q__1, &q__2, &denom);
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
L220:
k -= ks;
ik -= k;
if (ks == 2) {
ik -= k + 1;
}
goto L170;
L230:
s = 1.f / scasum_(n, &z__[1], &c__1);
csscal_(n, &s, &z__[1], &c__1);
ynorm = s * ynorm;
/* SOLVE TRANS(U)*Z = V */
k = 1;
ik = 0;
L240:
if (k > *n) {
goto L270;
}
ks = 1;
if (kpvt[k] < 0) {
ks = 2;
}
if (k == 1) {
goto L260;
}
i__1 = k;
i__2 = k;
i__3 = k - 1;
cdotu_(&q__2, &i__3, &ap[ik + 1], &c__1, &z__[1], &c__1);
q__1.r = z__[i__2].r + q__2.r, q__1.i = z__[i__2].i + q__2.i;
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
ikp1 = ik + k;
if (ks == 2) {
i__1 = k + 1;
i__2 = k + 1;
i__3 = k - 1;
cdotu_(&q__2, &i__3, &ap[ikp1 + 1], &c__1, &z__[1], &c__1);
q__1.r = z__[i__2].r + q__2.r, q__1.i = z__[i__2].i + q__2.i;
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
}
kp = (i__1 = kpvt[k], abs(i__1));
if (kp == k) {
goto L250;
}
i__1 = k;
t.r = z__[i__1].r, t.i = z__[i__1].i;
i__1 = k;
i__2 = kp;
z__[i__1].r = z__[i__2].r, z__[i__1].i = z__[i__2].i;
i__1 = kp;
z__[i__1].r = t.r, z__[i__1].i = t.i;
L250:
L260:
ik += k;
if (ks == 2) {
ik += k + 1;
}
k += ks;
goto L240;
L270:
/* MAKE ZNORM = 1.0 */
s = 1.f / scasum_(n, &z__[1], &c__1);
csscal_(n, &s, &z__[1], &c__1);
ynorm = s * ynorm;
if (anorm != 0.f) {
*rcond = ynorm / anorm;
}
if (anorm == 0.f) {
*rcond = 0.f;
}
return 0;
} /* cspco_ */
/* Subroutine */ int cggbak_(char *job, char *side, integer *n, integer *ilo,
integer *ihi, real *lscale, real *rscale, integer *m, complex *v,
integer *ldv, integer *info)
{
/* System generated locals */
integer v_dim1, v_offset, i__1;
/* Local variables */
integer i__, k;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
complex *, integer *);
logical leftv;
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), xerbla_(char *, integer *);
logical rightv;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGGBAK forms the right or left eigenvectors of a complex generalized */
/* eigenvalue problem A*x = lambda*B*x, by backward transformation on */
/* the computed eigenvectors of the balanced pair of matrices output by */
/* CGGBAL. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* Specifies the type of backward transformation required: */
/* = 'N': do nothing, return immediately; */
/* = 'P': do backward transformation for permutation only; */
/* = 'S': do backward transformation for scaling only; */
/* = 'B': do backward transformations for both permutation and */
/* scaling. */
/* JOB must be the same as the argument JOB supplied to CGGBAL. */
/* SIDE (input) CHARACTER*1 */
/* = 'R': V contains right eigenvectors; */
/* = 'L': V contains left eigenvectors. */
/* N (input) INTEGER */
/* The number of rows of the matrix V. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* The integers ILO and IHI determined by CGGBAL. */
/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
/* LSCALE (input) REAL array, dimension (N) */
/* Details of the permutations and/or scaling factors applied */
/* to the left side of A and B, as returned by CGGBAL. */
/* RSCALE (input) REAL array, dimension (N) */
/* Details of the permutations and/or scaling factors applied */
/* to the right side of A and B, as returned by CGGBAL. */
/* M (input) INTEGER */
/* The number of columns of the matrix V. M >= 0. */
/* V (input/output) COMPLEX array, dimension (LDV,M) */
/* On entry, the matrix of right or left eigenvectors to be */
/* transformed, as returned by CTGEVC. */
/* On exit, V is overwritten by the transformed eigenvectors. */
/* LDV (input) INTEGER */
/* The leading dimension of the matrix V. LDV >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* See R.C. Ward, Balancing the generalized eigenvalue problem, */
/* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
--lscale;
--rscale;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
/* Function Body */
rightv = lsame_(side, "R");
leftv = lsame_(side, "L");
*info = 0;
if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S")
&& ! lsame_(job, "B")) {
*info = -1;
} else if (! rightv && ! leftv) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ilo < 1) {
*info = -4;
} else if (*n == 0 && *ihi == 0 && *ilo != 1) {
*info = -4;
} else if (*n > 0 && (*ihi < *ilo || *ihi > max(1,*n))) {
*info = -5;
} else if (*n == 0 && *ilo == 1 && *ihi != 0) {
*info = -5;
} else if (*m < 0) {
*info = -8;
} else if (*ldv < max(1,*n)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGGBAK", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*m == 0) {
return 0;
}
if (lsame_(job, "N")) {
return 0;
}
if (*ilo == *ihi) {
goto L30;
}
/* Backward balance */
if (lsame_(job, "S") || lsame_(job, "B")) {
/* Backward transformation on right eigenvectors */
if (rightv) {
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
csscal_(m, &rscale[i__], &v[i__ + v_dim1], ldv);
/* L10: */
}
}
/* Backward transformation on left eigenvectors */
if (leftv) {
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
csscal_(m, &lscale[i__], &v[i__ + v_dim1], ldv);
/* L20: */
}
}
}
/* Backward permutation */
L30:
if (lsame_(job, "P") || lsame_(job, "B")) {
/* Backward permutation on right eigenvectors */
if (rightv) {
if (*ilo == 1) {
goto L50;
}
for (i__ = *ilo - 1; i__ >= 1; --i__) {
k = rscale[i__];
if (k == i__) {
goto L40;
}
cswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
L40:
;
}
L50:
if (*ihi == *n) {
goto L70;
}
i__1 = *n;
for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
k = rscale[i__];
if (k == i__) {
goto L60;
}
cswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
L60:
;
}
}
/* Backward permutation on left eigenvectors */
L70:
if (leftv) {
if (*ilo == 1) {
goto L90;
}
for (i__ = *ilo - 1; i__ >= 1; --i__) {
k = lscale[i__];
if (k == i__) {
goto L80;
}
cswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
L80:
;
}
L90:
if (*ihi == *n) {
goto L110;
}
i__1 = *n;
for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
k = lscale[i__];
if (k == i__) {
goto L100;
}
cswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
L100:
;
}
}
}
L110:
return 0;
/* End of CGGBAK */
} /* cggbak_ */
int cggbal_(char *job, int *n, complex *a, int *lda,
complex *b, int *ldb, int *ilo, int *ihi, float *lscale,
float *rscale, float *work, int *info)
{
/* System generated locals */
int a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
float r__1, r__2, r__3;
/* Builtin functions */
double r_lg10(float *), r_imag(complex *), c_abs(complex *), r_sign(float *,
float *), pow_ri(float *, int *);
/* Local variables */
int i__, j, k, l, m;
float t;
int jc;
float ta, tb, tc;
int ir;
float ew;
int it, nr, ip1, jp1, lm1;
float cab, rab, ewc, cor, sum;
int nrp2, icab, lcab;
float beta, coef;
int irab, lrab;
float basl, cmax;
extern double sdot_(int *, float *, int *, float *, int *);
float coef2, coef5, gamma, alpha;
extern int lsame_(char *, char *);
extern int sscal_(int *, float *, float *, int *);
float sfmin;
extern int cswap_(int *, complex *, int *,
complex *, int *);
float sfmax;
int iflow, kount;
extern int saxpy_(int *, float *, float *, int *,
float *, int *);
float pgamma;
extern int icamax_(int *, complex *, int *);
extern double slamch_(char *);
extern int csscal_(int *, float *, complex *, int
*), xerbla_(char *, int *);
int lsfmin, lsfmax;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGGBAL balances a pair of general complex matrices (A,B). This */
/* involves, first, permuting A and B by similarity transformations to */
/* isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N */
/* elements on the diagonal; and second, applying a diagonal similarity */
/* transformation to rows and columns ILO to IHI to make the rows */
/* and columns as close in norm as possible. Both steps are optional. */
/* Balancing may reduce the 1-norm of the matrices, and improve the */
/* accuracy of the computed eigenvalues and/or eigenvectors in the */
/* generalized eigenvalue problem A*x = lambda*B*x. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* Specifies the operations to be performed on A and B: */
/* = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0 */
/* and RSCALE(I) = 1.0 for i=1,...,N; */
/* = 'P': permute only; */
/* = 'S': scale only; */
/* = 'B': both permute and scale. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the input matrix A. */
/* On exit, A is overwritten by the balanced matrix. */
/* If JOB = 'N', A is not referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* B (input/output) COMPLEX array, dimension (LDB,N) */
/* On entry, the input matrix B. */
/* On exit, B is overwritten by the balanced matrix. */
/* If JOB = 'N', B is not referenced. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= MAX(1,N). */
/* ILO (output) INTEGER */
/* IHI (output) INTEGER */
/* ILO and IHI are set to ints such that on exit */
/* A(i,j) = 0 and B(i,j) = 0 if i > j and */
/* j = 1,...,ILO-1 or i = IHI+1,...,N. */
/* If JOB = 'N' or 'S', ILO = 1 and IHI = N. */
/* LSCALE (output) REAL array, dimension (N) */
/* Details of the permutations and scaling factors applied */
/* to the left side of A and B. If P(j) is the index of the */
/* row interchanged with row j, and D(j) is the scaling factor */
/* applied to row j, then */
/* LSCALE(j) = P(j) for J = 1,...,ILO-1 */
/* = D(j) for J = ILO,...,IHI */
/* = P(j) for J = IHI+1,...,N. */
/* The order in which the interchanges are made is N to IHI+1, */
/* then 1 to ILO-1. */
/* RSCALE (output) REAL array, dimension (N) */
/* Details of the permutations and scaling factors applied */
/* to the right side of A and B. If P(j) is the index of the */
/* column interchanged with column j, and D(j) is the scaling */
/* factor applied to column j, then */
/* RSCALE(j) = P(j) for J = 1,...,ILO-1 */
/* = D(j) for J = ILO,...,IHI */
/* = P(j) for J = IHI+1,...,N. */
/* The order in which the interchanges are made is N to IHI+1, */
/* then 1 to ILO-1. */
/* WORK (workspace) REAL array, dimension (lwork) */
/* lwork must be at least MAX(1,6*N) when JOB = 'S' or 'B', and */
/* at least 1 when JOB = 'N' or 'P'. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* See R.C. WARD, Balancing the generalized eigenvalue problem, */
/* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. 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;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--lscale;
--rscale;
--work;
/* Function Body */
*info = 0;
if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S")
&& ! lsame_(job, "B")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < MAX(1,*n)) {
*info = -4;
} else if (*ldb < MAX(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGGBAL", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*ilo = 1;
*ihi = *n;
return 0;
}
if (*n == 1) {
*ilo = 1;
*ihi = *n;
lscale[1] = 1.f;
rscale[1] = 1.f;
return 0;
}
if (lsame_(job, "N")) {
*ilo = 1;
*ihi = *n;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
lscale[i__] = 1.f;
rscale[i__] = 1.f;
/* L10: */
}
return 0;
}
k = 1;
l = *n;
if (lsame_(job, "S")) {
goto L190;
}
goto L30;
/* Permute the matrices A and B to isolate the eigenvalues. */
/* Find row with one nonzero in columns 1 through L */
L20:
l = lm1;
if (l != 1) {
goto L30;
}
rscale[1] = 1.f;
lscale[1] = 1.f;
goto L190;
L30:
lm1 = l - 1;
for (i__ = l; i__ >= 1; --i__) {
i__1 = lm1;
for (j = 1; j <= i__1; ++j) {
jp1 = j + 1;
i__2 = i__ + j * a_dim1;
i__3 = i__ + j * b_dim1;
if (a[i__2].r != 0.f || a[i__2].i != 0.f || (b[i__3].r != 0.f ||
b[i__3].i != 0.f)) {
goto L50;
}
/* L40: */
}
j = l;
goto L70;
L50:
i__1 = l;
for (j = jp1; j <= i__1; ++j) {
i__2 = i__ + j * a_dim1;
i__3 = i__ + j * b_dim1;
if (a[i__2].r != 0.f || a[i__2].i != 0.f || (b[i__3].r != 0.f ||
b[i__3].i != 0.f)) {
goto L80;
}
/* L60: */
}
j = jp1 - 1;
L70:
m = l;
iflow = 1;
goto L160;
L80:
;
}
goto L100;
/* Find column with one nonzero in rows K through N */
L90:
++k;
L100:
i__1 = l;
for (j = k; j <= i__1; ++j) {
i__2 = lm1;
for (i__ = k; i__ <= i__2; ++i__) {
ip1 = i__ + 1;
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * b_dim1;
if (a[i__3].r != 0.f || a[i__3].i != 0.f || (b[i__4].r != 0.f ||
b[i__4].i != 0.f)) {
goto L120;
}
/* L110: */
}
i__ = l;
goto L140;
L120:
i__2 = l;
for (i__ = ip1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * b_dim1;
if (a[i__3].r != 0.f || a[i__3].i != 0.f || (b[i__4].r != 0.f ||
b[i__4].i != 0.f)) {
goto L150;
}
/* L130: */
}
i__ = ip1 - 1;
L140:
m = k;
iflow = 2;
goto L160;
L150:
;
}
goto L190;
/* Permute rows M and I */
L160:
lscale[m] = (float) i__;
if (i__ == m) {
goto L170;
}
i__1 = *n - k + 1;
cswap_(&i__1, &a[i__ + k * a_dim1], lda, &a[m + k * a_dim1], lda);
i__1 = *n - k + 1;
cswap_(&i__1, &b[i__ + k * b_dim1], ldb, &b[m + k * b_dim1], ldb);
/* Permute columns M and J */
L170:
rscale[m] = (float) j;
if (j == m) {
goto L180;
}
cswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
cswap_(&l, &b[j * b_dim1 + 1], &c__1, &b[m * b_dim1 + 1], &c__1);
L180:
switch (iflow) {
case 1: goto L20;
case 2: goto L90;
}
L190:
*ilo = k;
*ihi = l;
if (lsame_(job, "P")) {
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
lscale[i__] = 1.f;
rscale[i__] = 1.f;
/* L195: */
}
return 0;
}
if (*ilo == *ihi) {
return 0;
}
/* Balance the submatrix in rows ILO to IHI. */
nr = *ihi - *ilo + 1;
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
rscale[i__] = 0.f;
lscale[i__] = 0.f;
work[i__] = 0.f;
work[i__ + *n] = 0.f;
work[i__ + (*n << 1)] = 0.f;
work[i__ + *n * 3] = 0.f;
work[i__ + (*n << 2)] = 0.f;
work[i__ + *n * 5] = 0.f;
/* L200: */
}
/* Compute right side vector in resulting linear equations */
basl = r_lg10(&c_b36);
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
i__2 = *ihi;
for (j = *ilo; j <= i__2; ++j) {
i__3 = i__ + j * a_dim1;
if (a[i__3].r == 0.f && a[i__3].i == 0.f) {
ta = 0.f;
goto L210;
}
i__3 = i__ + j * a_dim1;
r__3 = (r__1 = a[i__3].r, ABS(r__1)) + (r__2 = r_imag(&a[i__ + j
* a_dim1]), ABS(r__2));
ta = r_lg10(&r__3) / basl;
L210:
i__3 = i__ + j * b_dim1;
if (b[i__3].r == 0.f && b[i__3].i == 0.f) {
tb = 0.f;
goto L220;
}
i__3 = i__ + j * b_dim1;
r__3 = (r__1 = b[i__3].r, ABS(r__1)) + (r__2 = r_imag(&b[i__ + j
* b_dim1]), ABS(r__2));
tb = r_lg10(&r__3) / basl;
L220:
work[i__ + (*n << 2)] = work[i__ + (*n << 2)] - ta - tb;
work[j + *n * 5] = work[j + *n * 5] - ta - tb;
/* L230: */
}
/* L240: */
}
coef = 1.f / (float) (nr << 1);
coef2 = coef * coef;
coef5 = coef2 * .5f;
nrp2 = nr + 2;
beta = 0.f;
it = 1;
/* Start generalized conjugate gradient iteration */
L250:
gamma = sdot_(&nr, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + (*n << 2)]
, &c__1) + sdot_(&nr, &work[*ilo + *n * 5], &c__1, &work[*ilo + *
n * 5], &c__1);
ew = 0.f;
ewc = 0.f;
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
ew += work[i__ + (*n << 2)];
ewc += work[i__ + *n * 5];
/* L260: */
}
/* Computing 2nd power */
r__1 = ew;
/* Computing 2nd power */
r__2 = ewc;
/* Computing 2nd power */
r__3 = ew - ewc;
gamma = coef * gamma - coef2 * (r__1 * r__1 + r__2 * r__2) - coef5 * (
r__3 * r__3);
if (gamma == 0.f) {
goto L350;
}
if (it != 1) {
beta = gamma / pgamma;
}
t = coef5 * (ewc - ew * 3.f);
tc = coef5 * (ew - ewc * 3.f);
sscal_(&nr, &beta, &work[*ilo], &c__1);
sscal_(&nr, &beta, &work[*ilo + *n], &c__1);
saxpy_(&nr, &coef, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + *n], &
c__1);
saxpy_(&nr, &coef, &work[*ilo + *n * 5], &c__1, &work[*ilo], &c__1);
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
work[i__] += tc;
work[i__ + *n] += t;
/* L270: */
}
/* Apply matrix to vector */
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
kount = 0;
sum = 0.f;
i__2 = *ihi;
for (j = *ilo; j <= i__2; ++j) {
i__3 = i__ + j * a_dim1;
if (a[i__3].r == 0.f && a[i__3].i == 0.f) {
goto L280;
}
++kount;
sum += work[j];
L280:
i__3 = i__ + j * b_dim1;
if (b[i__3].r == 0.f && b[i__3].i == 0.f) {
goto L290;
}
++kount;
sum += work[j];
L290:
;
}
work[i__ + (*n << 1)] = (float) kount * work[i__ + *n] + sum;
/* L300: */
}
i__1 = *ihi;
for (j = *ilo; j <= i__1; ++j) {
kount = 0;
sum = 0.f;
i__2 = *ihi;
for (i__ = *ilo; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
if (a[i__3].r == 0.f && a[i__3].i == 0.f) {
goto L310;
}
++kount;
sum += work[i__ + *n];
L310:
i__3 = i__ + j * b_dim1;
if (b[i__3].r == 0.f && b[i__3].i == 0.f) {
goto L320;
}
++kount;
sum += work[i__ + *n];
L320:
;
}
work[j + *n * 3] = (float) kount * work[j] + sum;
/* L330: */
}
sum = sdot_(&nr, &work[*ilo + *n], &c__1, &work[*ilo + (*n << 1)], &c__1)
+ sdot_(&nr, &work[*ilo], &c__1, &work[*ilo + *n * 3], &c__1);
alpha = gamma / sum;
/* Determine correction to current iteration */
cmax = 0.f;
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
cor = alpha * work[i__ + *n];
if (ABS(cor) > cmax) {
cmax = ABS(cor);
}
lscale[i__] += cor;
cor = alpha * work[i__];
if (ABS(cor) > cmax) {
cmax = ABS(cor);
}
rscale[i__] += cor;
/* L340: */
}
if (cmax < .5f) {
goto L350;
}
r__1 = -alpha;
saxpy_(&nr, &r__1, &work[*ilo + (*n << 1)], &c__1, &work[*ilo + (*n << 2)]
, &c__1);
r__1 = -alpha;
saxpy_(&nr, &r__1, &work[*ilo + *n * 3], &c__1, &work[*ilo + *n * 5], &
c__1);
pgamma = gamma;
++it;
if (it <= nrp2) {
goto L250;
}
/* End generalized conjugate gradient iteration */
L350:
sfmin = slamch_("S");
sfmax = 1.f / sfmin;
lsfmin = (int) (r_lg10(&sfmin) / basl + 1.f);
lsfmax = (int) (r_lg10(&sfmax) / basl);
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
i__2 = *n - *ilo + 1;
irab = icamax_(&i__2, &a[i__ + *ilo * a_dim1], lda);
rab = c_abs(&a[i__ + (irab + *ilo - 1) * a_dim1]);
i__2 = *n - *ilo + 1;
irab = icamax_(&i__2, &b[i__ + *ilo * b_dim1], ldb);
/* Computing MAX */
r__1 = rab, r__2 = c_abs(&b[i__ + (irab + *ilo - 1) * b_dim1]);
rab = MAX(r__1,r__2);
r__1 = rab + sfmin;
lrab = (int) (r_lg10(&r__1) / basl + 1.f);
ir = lscale[i__] + r_sign(&c_b72, &lscale[i__]);
/* Computing MIN */
i__2 = MAX(ir,lsfmin), i__2 = MIN(i__2,lsfmax), i__3 = lsfmax - lrab;
ir = MIN(i__2,i__3);
lscale[i__] = pow_ri(&c_b36, &ir);
icab = icamax_(ihi, &a[i__ * a_dim1 + 1], &c__1);
cab = c_abs(&a[icab + i__ * a_dim1]);
icab = icamax_(ihi, &b[i__ * b_dim1 + 1], &c__1);
/* Computing MAX */
r__1 = cab, r__2 = c_abs(&b[icab + i__ * b_dim1]);
cab = MAX(r__1,r__2);
r__1 = cab + sfmin;
lcab = (int) (r_lg10(&r__1) / basl + 1.f);
jc = rscale[i__] + r_sign(&c_b72, &rscale[i__]);
/* Computing MIN */
i__2 = MAX(jc,lsfmin), i__2 = MIN(i__2,lsfmax), i__3 = lsfmax - lcab;
jc = MIN(i__2,i__3);
rscale[i__] = pow_ri(&c_b36, &jc);
/* L360: */
}
/* Row scaling of matrices A and B */
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
i__2 = *n - *ilo + 1;
csscal_(&i__2, &lscale[i__], &a[i__ + *ilo * a_dim1], lda);
i__2 = *n - *ilo + 1;
csscal_(&i__2, &lscale[i__], &b[i__ + *ilo * b_dim1], ldb);
/* L370: */
}
/* Column scaling of matrices A and B */
i__1 = *ihi;
for (j = *ilo; j <= i__1; ++j) {
csscal_(ihi, &rscale[j], &a[j * a_dim1 + 1], &c__1);
csscal_(ihi, &rscale[j], &b[j * b_dim1 + 1], &c__1);
/* L380: */
}
return 0;
/* End of CGGBAL */
} /* cggbal_ */
/* Subroutine */ int chseqr_(char *job, char *compz, integer *n, integer *ilo,
integer *ihi, complex *h__, integer *ldh, complex *w, complex *z__,
integer *ldz, complex *work, integer *lwork, integer *info)
{
/* System generated locals */
address a__1[2];
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4[2],
i__5, i__6;
real r__1, r__2, r__3, r__4;
complex q__1;
char ch__1[2];
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static integer maxb, ierr;
static real unfl;
static complex temp;
static real ovfl, opst;
static integer i__, j, k, l;
static complex s[225] /* was [15][15] */;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
static complex v[16];
extern logical lsame_(char *, char *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *), ccopy_(integer *, complex *, integer *,
complex *, integer *);
static integer itemp;
static real rtemp;
static integer i1, i2;
static logical initz, wantt, wantz;
static real rwork[1];
extern doublereal slapy2_(real *, real *);
static integer ii, nh;
extern /* Subroutine */ int slabad_(real *, real *), clarfg_(integer *,
complex *, complex *, integer *, complex *);
static integer nr, ns;
extern integer icamax_(integer *, complex *, integer *);
static integer nv;
extern doublereal slamch_(char *), clanhs_(char *, integer *,
complex *, integer *, real *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), clahqr_(logical *, logical *, integer *, integer *, integer *,
complex *, integer *, complex *, integer *, integer *, complex *,
integer *, integer *), clacpy_(char *, integer *, integer *,
complex *, integer *, complex *, integer *);
static complex vv[16];
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int clarfx_(char *, integer *, integer *, complex
*, complex *, complex *, integer *, complex *), xerbla_(
char *, integer *);
static real smlnum;
static logical lquery;
static integer itn;
static complex tau;
static integer its;
static real ulp, tst1;
#define h___subscr(a_1,a_2) (a_2)*h_dim1 + a_1
#define h___ref(a_1,a_2) h__[h___subscr(a_1,a_2)]
#define s_subscr(a_1,a_2) (a_2)*15 + a_1 - 16
#define s_ref(a_1,a_2) s[s_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
Common block to return operation count.
Purpose
=======
CHSEQR computes the eigenvalues of a complex upper Hessenberg
matrix H, and, optionally, the matrices T and Z from the Schur
decomposition H = Z T Z**H, where T is an upper triangular matrix
(the Schur form), and Z is the unitary matrix of Schur vectors.
Optionally Z may be postmultiplied into an input unitary matrix Q,
so that this routine can give the Schur factorization of a matrix A
which has been reduced to the Hessenberg form H by the unitary
matrix Q: A = Q*H*Q**H = (QZ)*T*(QZ)**H.
Arguments
=========
JOB (input) CHARACTER*1
= 'E': compute eigenvalues only;
= 'S': compute eigenvalues and the Schur form T.
COMPZ (input) CHARACTER*1
= 'N': no Schur vectors are computed;
= 'I': Z is initialized to the unit matrix and the matrix Z
of Schur vectors of H is returned;
= 'V': Z must contain an unitary matrix Q on entry, and
the product Q*Z is returned.
N (input) INTEGER
The order of the matrix H. N >= 0.
ILO (input) INTEGER
IHI (input) INTEGER
It is assumed that H is already upper triangular in rows
and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
set by a previous call to CGEBAL, and then passed to CGEHRD
when the matrix output by CGEBAL is reduced to Hessenberg
form. Otherwise ILO and IHI should be set to 1 and N
respectively.
1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
H (input/output) COMPLEX array, dimension (LDH,N)
On entry, the upper Hessenberg matrix H.
On exit, if JOB = 'S', H contains the upper triangular matrix
T from the Schur decomposition (the Schur form). If
JOB = 'E', the contents of H are unspecified on exit.
LDH (input) INTEGER
The leading dimension of the array H. LDH >= max(1,N).
W (output) COMPLEX array, dimension (N)
The computed eigenvalues. If JOB = 'S', the eigenvalues are
stored in the same order as on the diagonal of the Schur form
returned in H, with W(i) = H(i,i).
Z (input/output) COMPLEX array, dimension (LDZ,N)
If COMPZ = 'N': Z is not referenced.
If COMPZ = 'I': on entry, Z need not be set, and on exit, Z
contains the unitary matrix Z of the Schur vectors of H.
If COMPZ = 'V': on entry Z must contain an N-by-N matrix Q,
which is assumed to be equal to the unit matrix except for
the submatrix Z(ILO:IHI,ILO:IHI); on exit Z contains Q*Z.
Normally Q is the unitary matrix generated by CUNGHR after
the call to CGEHRD which formed the Hessenberg matrix H.
LDZ (input) INTEGER
The leading dimension of the array Z.
LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise.
WORK (workspace/output) COMPLEX 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.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, CHSEQR failed to compute all the
eigenvalues in a total of 30*(IHI-ILO+1) iterations;
elements 1:ilo-1 and i+1:n of W contain those
eigenvalues which have been successfully computed.
=====================================================================
Decode and test the input parameters
Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1 * 1;
h__ -= h_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
/* Function Body */
wantt = lsame_(job, "S");
initz = lsame_(compz, "I");
wantz = initz || lsame_(compz, "V");
*info = 0;
i__1 = max(1,*n);
work[1].r = (real) i__1, work[1].i = 0.f;
lquery = *lwork == -1;
if (! lsame_(job, "E") && ! wantt) {
*info = -1;
} else if (! lsame_(compz, "N") && ! wantz) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ilo < 1 || *ilo > max(1,*n)) {
*info = -4;
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
*info = -5;
} else if (*ldh < max(1,*n)) {
*info = -7;
} else if (*ldz < 1 || wantz && *ldz < max(1,*n)) {
*info = -10;
} else if (*lwork < max(1,*n) && ! lquery) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHSEQR", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* **
Initialize */
opst = 0.f;
/* **
Initialize Z, if necessary */
if (initz) {
claset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
}
/* Store the eigenvalues isolated by CGEBAL. */
i__1 = *ilo - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = h___subscr(i__, i__);
w[i__2].r = h__[i__3].r, w[i__2].i = h__[i__3].i;
/* L10: */
}
i__1 = *n;
for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = h___subscr(i__, i__);
w[i__2].r = h__[i__3].r, w[i__2].i = h__[i__3].i;
/* L20: */
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
i__1 = *ilo;
i__2 = h___subscr(*ilo, *ilo);
w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
return 0;
}
/* Set rows and columns ILO to IHI to zero below the first
subdiagonal. */
i__1 = *ihi - 2;
for (j = *ilo; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 2; i__ <= i__2; ++i__) {
i__3 = h___subscr(i__, j);
h__[i__3].r = 0.f, h__[i__3].i = 0.f;
/* L30: */
}
/* L40: */
}
nh = *ihi - *ilo + 1;
/* I1 and I2 are the indices of the first row and last column of H
to which transformations must be applied. If eigenvalues only are
being computed, I1 and I2 are re-set inside the main loop. */
if (wantt) {
i1 = 1;
i2 = *n;
} else {
i1 = *ilo;
i2 = *ihi;
}
/* Ensure that the subdiagonal elements are real. */
i__1 = *ihi;
for (i__ = *ilo + 1; i__ <= i__1; ++i__) {
i__2 = h___subscr(i__, i__ - 1);
temp.r = h__[i__2].r, temp.i = h__[i__2].i;
if (r_imag(&temp) != 0.f) {
r__1 = temp.r;
r__2 = r_imag(&temp);
rtemp = slapy2_(&r__1, &r__2);
i__2 = h___subscr(i__, i__ - 1);
h__[i__2].r = rtemp, h__[i__2].i = 0.f;
q__1.r = temp.r / rtemp, q__1.i = temp.i / rtemp;
temp.r = q__1.r, temp.i = q__1.i;
if (i2 > i__) {
i__2 = i2 - i__;
r_cnjg(&q__1, &temp);
cscal_(&i__2, &q__1, &h___ref(i__, i__ + 1), ldh);
}
i__2 = i__ - i1;
cscal_(&i__2, &temp, &h___ref(i1, i__), &c__1);
if (i__ < *ihi) {
i__2 = h___subscr(i__ + 1, i__);
i__3 = h___subscr(i__ + 1, i__);
q__1.r = temp.r * h__[i__3].r - temp.i * h__[i__3].i, q__1.i =
temp.r * h__[i__3].i + temp.i * h__[i__3].r;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
}
/* **
Increment op count */
opst += (i2 - i1 + 2) * 6;
/* ** */
if (wantz) {
cscal_(&nh, &temp, &z___ref(*ilo, i__), &c__1);
/* **
Increment op count */
opst += nh * 6;
/* ** */
}
}
/* L50: */
}
/* Determine the order of the multi-shift QR algorithm to be used.
Writing concatenation */
i__4[0] = 1, a__1[0] = job;
i__4[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__4, &c__2, (ftnlen)2);
ns = ilaenv_(&c__4, "CHSEQR", ch__1, n, ilo, ihi, &c_n1, (ftnlen)6, (
ftnlen)2);
/* Writing concatenation */
i__4[0] = 1, a__1[0] = job;
i__4[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__4, &c__2, (ftnlen)2);
maxb = ilaenv_(&c__8, "CHSEQR", ch__1, n, ilo, ihi, &c_n1, (ftnlen)6, (
ftnlen)2);
if (ns <= 1 || ns > nh || maxb >= nh) {
/* Use the standard double-shift algorithm */
clahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1], ilo,
ihi, &z__[z_offset], ldz, info);
return 0;
}
maxb = max(2,maxb);
/* Computing MIN */
i__1 = min(ns,maxb);
ns = min(i__1,15);
/* Now 1 < NS <= MAXB < NH.
Set machine-dependent constants for the stopping criterion.
If norm(H) <= sqrt(OVFL), overflow should not occur. */
unfl = slamch_("Safe minimum");
ovfl = 1.f / unfl;
slabad_(&unfl, &ovfl);
ulp = slamch_("Precision");
smlnum = unfl * (nh / ulp);
/* ITN is the total number of multiple-shift QR iterations allowed. */
itn = nh * 30;
/* The main loop begins here. I is the loop index and decreases from
IHI to ILO in steps of at most MAXB. Each iteration of the loop
works with the active submatrix in rows and columns L to I.
Eigenvalues I+1 to IHI have already converged. Either L = ILO, or
H(L,L-1) is negligible so that the matrix splits. */
i__ = *ihi;
L60:
if (i__ < *ilo) {
goto L180;
}
/* Perform multiple-shift QR iterations on rows and columns ILO to I
until a submatrix of order at most MAXB splits off at the bottom
because a subdiagonal element has become negligible. */
l = *ilo;
i__1 = itn;
for (its = 0; its <= i__1; ++its) {
/* Look for a single small subdiagonal element. */
i__2 = l + 1;
for (k = i__; k >= i__2; --k) {
i__3 = h___subscr(k - 1, k - 1);
i__5 = h___subscr(k, k);
tst1 = (r__1 = h__[i__3].r, dabs(r__1)) + (r__2 = r_imag(&h___ref(
k - 1, k - 1)), dabs(r__2)) + ((r__3 = h__[i__5].r, dabs(
r__3)) + (r__4 = r_imag(&h___ref(k, k)), dabs(r__4)));
if (tst1 == 0.f) {
i__3 = i__ - l + 1;
tst1 = clanhs_("1", &i__3, &h___ref(l, l), ldh, rwork);
/* **
Increment op count */
latime_1.ops += (i__ - l + 1) * 5 * (i__ - l) / 2;
/* ** */
}
i__3 = h___subscr(k, k - 1);
/* Computing MAX */
r__2 = ulp * tst1;
if ((r__1 = h__[i__3].r, dabs(r__1)) <= dmax(r__2,smlnum)) {
goto L80;
}
/* L70: */
}
L80:
l = k;
/* **
Increment op count */
opst += (i__ - l + 1) * 5;
/* ** */
if (l > *ilo) {
/* H(L,L-1) is negligible. */
i__2 = h___subscr(l, l - 1);
h__[i__2].r = 0.f, h__[i__2].i = 0.f;
}
/* Exit from loop if a submatrix of order <= MAXB has split off. */
if (l >= i__ - maxb + 1) {
goto L170;
}
/* Now the active submatrix is in rows and columns L to I. If
eigenvalues only are being computed, only the active submatrix
need be transformed. */
if (! wantt) {
i1 = l;
i2 = i__;
}
if (its == 20 || its == 30) {
/* Exceptional shifts. */
i__2 = i__;
for (ii = i__ - ns + 1; ii <= i__2; ++ii) {
i__3 = ii;
i__5 = h___subscr(ii, ii - 1);
i__6 = h___subscr(ii, ii);
r__3 = ((r__1 = h__[i__5].r, dabs(r__1)) + (r__2 = h__[i__6]
.r, dabs(r__2))) * 1.5f;
w[i__3].r = r__3, w[i__3].i = 0.f;
/* L90: */
}
/* **
Increment op count */
opst += ns << 1;
/* ** */
} else {
/* Use eigenvalues of trailing submatrix of order NS as shifts. */
clacpy_("Full", &ns, &ns, &h___ref(i__ - ns + 1, i__ - ns + 1),
ldh, s, &c__15);
clahqr_(&c_false, &c_false, &ns, &c__1, &ns, s, &c__15, &w[i__ -
ns + 1], &c__1, &ns, &z__[z_offset], ldz, &ierr);
if (ierr > 0) {
/* If CLAHQR failed to compute all NS eigenvalues, use the
unconverged diagonal elements as the remaining shifts. */
i__2 = ierr;
for (ii = 1; ii <= i__2; ++ii) {
i__3 = i__ - ns + ii;
i__5 = s_subscr(ii, ii);
w[i__3].r = s[i__5].r, w[i__3].i = s[i__5].i;
/* L100: */
}
}
}
/* Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns))
where G is the Hessenberg submatrix H(L:I,L:I) and w is
the vector of shifts (stored in W). The result is
stored in the local array V. */
v[0].r = 1.f, v[0].i = 0.f;
i__2 = ns + 1;
for (ii = 2; ii <= i__2; ++ii) {
i__3 = ii - 1;
v[i__3].r = 0.f, v[i__3].i = 0.f;
/* L110: */
}
nv = 1;
i__2 = i__;
for (j = i__ - ns + 1; j <= i__2; ++j) {
i__3 = nv + 1;
ccopy_(&i__3, v, &c__1, vv, &c__1);
i__3 = nv + 1;
i__5 = j;
q__1.r = -w[i__5].r, q__1.i = -w[i__5].i;
cgemv_("No transpose", &i__3, &nv, &c_b2, &h___ref(l, l), ldh, vv,
&c__1, &q__1, v, &c__1);
++nv;
/* **
Increment op count */
opst = opst + (nv << 3) * (*n + 1) + (nv + 1) * 6;
/* **
Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero,
reset it to the unit vector. */
itemp = icamax_(&nv, v, &c__1);
/* **
Increment op count */
opst += nv << 1;
/* ** */
i__3 = itemp - 1;
rtemp = (r__1 = v[i__3].r, dabs(r__1)) + (r__2 = r_imag(&v[itemp
- 1]), dabs(r__2));
if (rtemp == 0.f) {
v[0].r = 1.f, v[0].i = 0.f;
i__3 = nv;
for (ii = 2; ii <= i__3; ++ii) {
i__5 = ii - 1;
v[i__5].r = 0.f, v[i__5].i = 0.f;
/* L120: */
}
} else {
rtemp = dmax(rtemp,smlnum);
r__1 = 1.f / rtemp;
csscal_(&nv, &r__1, v, &c__1);
/* **
Increment op count */
opst += nv << 1;
/* ** */
}
/* L130: */
}
/* Multiple-shift QR step */
i__2 = i__ - 1;
for (k = l; k <= i__2; ++k) {
/* The first iteration of this loop determines a reflection G
from the vector V and applies it from left and right to H,
thus creating a nonzero bulge below the subdiagonal.
Each subsequent iteration determines a reflection G to
restore the Hessenberg form in the (K-1)th column, and thus
chases the bulge one step toward the bottom of the active
submatrix. NR is the order of G.
Computing MIN */
i__3 = ns + 1, i__5 = i__ - k + 1;
nr = min(i__3,i__5);
if (k > l) {
ccopy_(&nr, &h___ref(k, k - 1), &c__1, v, &c__1);
}
clarfg_(&nr, v, &v[1], &c__1, &tau);
/* **
Increment op count */
opst = opst + nr * 10 + 12;
/* ** */
if (k > l) {
i__3 = h___subscr(k, k - 1);
h__[i__3].r = v[0].r, h__[i__3].i = v[0].i;
i__3 = i__;
for (ii = k + 1; ii <= i__3; ++ii) {
i__5 = h___subscr(ii, k - 1);
h__[i__5].r = 0.f, h__[i__5].i = 0.f;
/* L140: */
}
}
v[0].r = 1.f, v[0].i = 0.f;
/* Apply G' from the left to transform the rows of the matrix
in columns K to I2. */
i__3 = i2 - k + 1;
r_cnjg(&q__1, &tau);
clarfx_("Left", &nr, &i__3, v, &q__1, &h___ref(k, k), ldh, &work[
1]);
/* Apply G from the right to transform the columns of the
matrix in rows I1 to min(K+NR,I).
Computing MIN */
i__5 = k + nr;
i__3 = min(i__5,i__) - i1 + 1;
clarfx_("Right", &i__3, &nr, v, &tau, &h___ref(i1, k), ldh, &work[
1]);
/* **
Increment op count
Computing MIN */
i__3 = nr, i__5 = i__ - k;
latime_1.ops += ((nr << 2) - 2 << 2) * (i2 - i1 + 2 + min(i__3,
i__5));
/* ** */
if (wantz) {
/* Accumulate transformations in the matrix Z */
clarfx_("Right", &nh, &nr, v, &tau, &z___ref(*ilo, k), ldz, &
work[1]);
/* **
Increment op count */
latime_1.ops += ((nr << 2) - 2 << 2) * nh;
/* ** */
}
/* L150: */
}
/* Ensure that H(I,I-1) is real. */
i__2 = h___subscr(i__, i__ - 1);
temp.r = h__[i__2].r, temp.i = h__[i__2].i;
if (r_imag(&temp) != 0.f) {
r__1 = temp.r;
r__2 = r_imag(&temp);
rtemp = slapy2_(&r__1, &r__2);
i__2 = h___subscr(i__, i__ - 1);
h__[i__2].r = rtemp, h__[i__2].i = 0.f;
q__1.r = temp.r / rtemp, q__1.i = temp.i / rtemp;
temp.r = q__1.r, temp.i = q__1.i;
if (i2 > i__) {
i__2 = i2 - i__;
r_cnjg(&q__1, &temp);
cscal_(&i__2, &q__1, &h___ref(i__, i__ + 1), ldh);
}
i__2 = i__ - i1;
cscal_(&i__2, &temp, &h___ref(i1, i__), &c__1);
/* **
Increment op count */
opst += (i2 - i1 + 1) * 6;
/* ** */
if (wantz) {
cscal_(&nh, &temp, &z___ref(*ilo, i__), &c__1);
/* **
Increment op count */
opst += nh * 6;
/* ** */
}
}
/* L160: */
}
/* Failure to converge in remaining number of iterations */
*info = i__;
return 0;
L170:
/* A submatrix of order <= MAXB in rows and columns L to I has split
off. Use the double-shift QR algorithm to handle it. */
clahqr_(&wantt, &wantz, n, &l, &i__, &h__[h_offset], ldh, &w[1], ilo, ihi,
&z__[z_offset], ldz, info);
if (*info > 0) {
return 0;
}
/* Decrement number of remaining iterations, and return to start of
the main loop with a new value of I. */
itn -= its;
i__ = l - 1;
goto L60;
L180:
/* **
Compute final op count */
latime_1.ops += opst;
/* ** */
i__1 = max(1,*n);
work[1].r = (real) i__1, work[1].i = 0.f;
return 0;
/* End of CHSEQR */
} /* chseqr_ */
/* Subroutine */ int ctbt03_(char *uplo, char *trans, char *diag, integer *n,
integer *kd, integer *nrhs, complex *ab, integer *ldab, real *scale,
real *cnorm, real *tscal, complex *x, integer *ldx, complex *b,
integer *ldb, complex *work, real *resid)
{
/* System generated locals */
integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
real r__1, r__2;
complex q__1;
/* Builtin functions */
double c_abs(complex *);
/* Local variables */
static integer j;
extern logical lsame_(char *, char *);
static real xscal;
extern /* Subroutine */ int ctbmv_(char *, char *, char *, integer *,
integer *, complex *, integer *, complex *, integer *), ccopy_(integer *, complex *, integer *, complex *
, integer *), caxpy_(integer *, complex *, complex *, integer *,
complex *, integer *);
static real tnorm, xnorm;
static integer ix;
extern integer icamax_(integer *, complex *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*);
static real smlnum, eps, err;
#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 x_subscr(a_1,a_2) (a_2)*x_dim1 + a_1
#define x_ref(a_1,a_2) x[x_subscr(a_1,a_2)]
#define ab_subscr(a_1,a_2) (a_2)*ab_dim1 + a_1
#define ab_ref(a_1,a_2) ab[ab_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
February 29, 1992
Purpose
=======
CTBT03 computes the residual for the solution to a scaled triangular
system of equations A*x = s*b, A**T *x = s*b, or A**H *x = s*b
when A is a triangular band matrix. Here A**T denotes the transpose
of A, A**H denotes the conjugate transpose of A, s is a scalar, and
x and b are N by NRHS matrices. The test ratio is the maximum over
the number of right hand sides of
norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ),
where op(A) denotes A, A**T, or A**H, and EPS is the machine epsilon.
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': A *x = s*b (No transpose)
= 'T': A**T *x = s*b (Transpose)
= 'C': 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
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.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices X and B. NRHS >= 0.
AB (input) COMPLEX 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).
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
SCALE (input) REAL
The scaling factor s used in solving the triangular system.
CNORM (input) REAL array, dimension (N)
The 1-norms of the columns of A, not counting the diagonal.
TSCAL (input) REAL
The scaling factor used in computing the 1-norms in CNORM.
CNORM actually contains the column norms of TSCAL*A.
X (input) COMPLEX array, dimension (LDX,NRHS)
The computed solution vectors for the system of linear
equations.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
B (input) COMPLEX 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).
WORK (workspace) COMPLEX array, dimension (N)
RESID (output) REAL
The maximum over the number of right hand sides of
norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ).
=====================================================================
Quick exit if N = 0
Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
--cnorm;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--work;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
*resid = 0.f;
return 0;
}
eps = slamch_("Epsilon");
smlnum = slamch_("Safe minimum");
/* Compute the norm of the triangular matrix A using the column
norms already computed by CLATBS. */
tnorm = 0.f;
if (lsame_(diag, "N")) {
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__1 = tnorm, r__2 = *tscal * c_abs(&ab_ref(*kd + 1, j)) +
cnorm[j];
tnorm = dmax(r__1,r__2);
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__1 = tnorm, r__2 = *tscal * c_abs(&ab_ref(1, j)) + cnorm[j];
tnorm = dmax(r__1,r__2);
/* L20: */
}
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__1 = tnorm, r__2 = *tscal + cnorm[j];
tnorm = dmax(r__1,r__2);
/* L30: */
}
}
/* Compute the maximum over the number of right hand sides of
norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
*resid = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ccopy_(n, &x_ref(1, j), &c__1, &work[1], &c__1);
ix = icamax_(n, &work[1], &c__1);
/* Computing MAX */
r__1 = 1.f, r__2 = c_abs(&x_ref(ix, j));
xnorm = dmax(r__1,r__2);
xscal = 1.f / xnorm / (real) (*kd + 1);
csscal_(n, &xscal, &work[1], &c__1);
ctbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[1], &
c__1);
r__1 = -(*scale) * xscal;
q__1.r = r__1, q__1.i = 0.f;
caxpy_(n, &q__1, &b_ref(1, j), &c__1, &work[1], &c__1);
ix = icamax_(n, &work[1], &c__1);
err = *tscal * c_abs(&work[ix]);
ix = icamax_(n, &x_ref(1, j), &c__1);
xnorm = c_abs(&x_ref(ix, j));
if (err * smlnum <= xnorm) {
if (xnorm > 0.f) {
err /= xnorm;
}
} else {
if (err > 0.f) {
err = 1.f / eps;
}
}
if (err * smlnum <= tnorm) {
if (tnorm > 0.f) {
err /= tnorm;
}
} else {
if (err > 0.f) {
err = 1.f / eps;
}
}
*resid = dmax(*resid,err);
/* L40: */
}
return 0;
/* End of CTBT03 */
} /* ctbt03_ */
/* Subroutine */
int clarfgp_(integer *n, complex *alpha, complex *x, integer *incx, complex *tau)
{
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
complex q__1, q__2;
/* Builtin functions */
double r_imag(complex *), r_sign(real *, real *), c_abs(complex *);
/* Local variables */
integer j;
complex savealpha;
integer knt;
real beta;
extern /* Subroutine */
int cscal_(integer *, complex *, complex *, integer *);
real alphi, alphr, xnorm;
extern real scnrm2_(integer *, complex *, integer *), slapy2_(real *, real *), slapy3_(real *, real *, real *);
extern /* Complex */
VOID cladiv_(complex *, complex *, complex *);
extern real slamch_(char *);
extern /* Subroutine */
int csscal_(integer *, real *, complex *, integer *);
real bignum, 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.f, tau->i = 0.f;
return 0;
}
i__1 = *n - 1;
xnorm = scnrm2_(&i__1, &x[1], incx);
alphr = alpha->r;
alphi = r_imag(alpha);
if (xnorm == 0.f)
{
/* H = [1-alpha/f2c_abs(alpha) 0;
0 I], sign chosen so ALPHA >= 0. */
if (alphi == 0.f)
{
if (alphr >= 0.f)
{
/* 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.f, tau->i = 0.f;
}
else
{
/* However, the application routines rely on explicit */
/* zero checks when TAU.ne.ZERO, and we must clear X. */
tau->r = 2.f, tau->i = 0.f;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f;
x[i__2].i = 0.f; // , expr subst
}
q__1.r = -alpha->r;
q__1.i = -alpha->i; // , expr subst
alpha->r = q__1.r, alpha->i = q__1.i;
}
}
else
{
/* Only "reflecting" the diagonal entry to be real and non-negative. */
xnorm = slapy2_(&alphr, &alphi);
r__1 = 1.f - alphr / xnorm;
r__2 = -alphi / xnorm;
q__1.r = r__1;
q__1.i = r__2; // , expr subst
tau->r = q__1.r, tau->i = q__1.i;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f;
x[i__2].i = 0.f; // , expr subst
}
alpha->r = xnorm, alpha->i = 0.f;
}
}
else
{
/* general case */
r__1 = slapy3_(&alphr, &alphi, &xnorm);
beta = r_sign(&r__1, &alphr);
smlnum = slamch_("S") / slamch_("E");
bignum = 1.f / smlnum;
knt = 0;
if (f2c_abs(beta) < smlnum)
{
/* XNORM, BETA may be inaccurate;
scale X and recompute them */
L10:
++knt;
i__1 = *n - 1;
csscal_(&i__1, &bignum, &x[1], incx);
beta *= bignum;
alphi *= bignum;
alphr *= bignum;
if (f2c_abs(beta) < smlnum)
{
goto L10;
}
/* New BETA is at most 1, at least SMLNUM */
i__1 = *n - 1;
xnorm = scnrm2_(&i__1, &x[1], incx);
q__1.r = alphr;
q__1.i = alphi; // , expr subst
alpha->r = q__1.r, alpha->i = q__1.i;
r__1 = slapy3_(&alphr, &alphi, &xnorm);
beta = r_sign(&r__1, &alphr);
}
savealpha.r = alpha->r;
savealpha.i = alpha->i; // , expr subst
q__1.r = alpha->r + beta;
q__1.i = alpha->i; // , expr subst
alpha->r = q__1.r, alpha->i = q__1.i;
if (beta < 0.f)
{
beta = -beta;
q__2.r = -alpha->r;
q__2.i = -alpha->i; // , expr subst
q__1.r = q__2.r / beta;
q__1.i = q__2.i / beta; // , expr subst
tau->r = q__1.r, tau->i = q__1.i;
}
else
{
alphr = alphi * (alphi / alpha->r);
alphr += xnorm * (xnorm / alpha->r);
r__1 = alphr / beta;
r__2 = -alphi / beta;
q__1.r = r__1;
q__1.i = r__2; // , expr subst
tau->r = q__1.r, tau->i = q__1.i;
r__1 = -alphr;
q__1.r = r__1;
q__1.i = alphi; // , expr subst
alpha->r = q__1.r, alpha->i = q__1.i;
}
cladiv_(&q__1, &c_b5, alpha);
alpha->r = q__1.r, alpha->i = q__1.i;
if (c_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 = r_imag(&savealpha);
if (alphi == 0.f)
{
if (alphr >= 0.f)
{
tau->r = 0.f, tau->i = 0.f;
}
else
{
tau->r = 2.f, tau->i = 0.f;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f;
x[i__2].i = 0.f; // , expr subst
}
q__1.r = -savealpha.r;
q__1.i = -savealpha.i; // , expr subst
beta = q__1.r;
}
}
else
{
xnorm = slapy2_(&alphr, &alphi);
r__1 = 1.f - alphr / xnorm;
r__2 = -alphi / xnorm;
q__1.r = r__1;
q__1.i = r__2; // , expr subst
tau->r = q__1.r, tau->i = q__1.i;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f;
x[i__2].i = 0.f; // , expr subst
}
beta = xnorm;
}
}
else
{
/* This is the general case. */
i__1 = *n - 1;
cscal_(&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.f;
}
return 0;
/* End of CLARFGP */
}
/* Subroutine */ int ctrsyl_(char *trana, char *tranb, integer *isgn, integer
*m, integer *n, complex *a, integer *lda, complex *b, integer *ldb,
complex *c__, integer *ldc, real *scale, 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
=======
CTRSYL solves the complex Sylvester matrix equation:
op(A)*X + X*op(B) = scale*C or
op(A)*X - X*op(B) = scale*C,
where op(A) = A or A**H, and A and B are both upper triangular. A is
M-by-M and B is N-by-N; the right hand side C and the solution X are
M-by-N; and scale is an output scale factor, set <= 1 to avoid
overflow in X.
Arguments
=========
TRANA (input) CHARACTER*1
Specifies the option op(A):
= 'N': op(A) = A (No transpose)
= 'C': op(A) = A**H (Conjugate transpose)
TRANB (input) CHARACTER*1
Specifies the option op(B):
= 'N': op(B) = B (No transpose)
= 'C': op(B) = B**H (Conjugate transpose)
ISGN (input) INTEGER
Specifies the sign in the equation:
= +1: solve op(A)*X + X*op(B) = scale*C
= -1: solve op(A)*X - X*op(B) = scale*C
M (input) INTEGER
The order of the matrix A, and the number of rows in the
matrices X and C. M >= 0.
N (input) INTEGER
The order of the matrix B, and the number of columns in the
matrices X and C. N >= 0.
A (input) COMPLEX array, dimension (LDA,M)
The upper triangular matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
B (input) COMPLEX array, dimension (LDB,N)
The upper triangular matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
C (input/output) COMPLEX array, dimension (LDC,N)
On entry, the M-by-N right hand side matrix C.
On exit, C is overwritten by the solution matrix X.
LDC (input) INTEGER
The leading dimension of the array C. LDC >= max(1,M)
SCALE (output) REAL
The scale factor, scale, set <= 1 to avoid overflow in X.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
= 1: A and B have common or very close eigenvalues; perturbed
values were used to solve the equation (but the matrices
A and B are unchanged).
=====================================================================
Decode and Test input parameters
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
i__3, i__4;
real r__1, r__2;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
static real smin;
static complex suml, sumr;
static integer j, k, l;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
*, complex *, integer *);
static complex a11;
static real db;
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
static complex x11;
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
static real scaloc;
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), xerbla_(char *, integer *);
static real bignum;
static logical notrna, notrnb;
static real smlnum, da11;
static complex vec;
static real dum[1], eps, sgn;
#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 c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1
#define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
/* Function Body */
notrna = lsame_(trana, "N");
notrnb = lsame_(tranb, "N");
*info = 0;
if (! notrna && ! lsame_(trana, "T") && ! lsame_(
trana, "C")) {
*info = -1;
} else if (! notrnb && ! lsame_(tranb, "T") && !
lsame_(tranb, "C")) {
*info = -2;
} else if (*isgn != 1 && *isgn != -1) {
*info = -3;
} else if (*m < 0) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*m)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldc < max(1,*m)) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTRSYL", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Set constants to control overflow */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = smlnum * (real) (*m * *n) / eps;
bignum = 1.f / smlnum;
/* Computing MAX */
r__1 = smlnum, r__2 = eps * clange_("M", m, m, &a[a_offset], lda, dum), r__1 = max(r__1,r__2), r__2 = eps * clange_("M", n, n,
&b[b_offset], ldb, dum);
smin = dmax(r__1,r__2);
*scale = 1.f;
sgn = (real) (*isgn);
if (notrna && notrnb) {
/* Solve A*X + ISGN*X*B = scale*C.
The (K,L)th block of X is determined starting from
bottom-left corner column by column by
A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
Where
M L-1
R(K,L) = SUM [A(K,I)*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)].
I=K+1 J=1 */
i__1 = *n;
for (l = 1; l <= i__1; ++l) {
for (k = *m; k >= 1; --k) {
/* Computing MIN */
i__2 = k + 1;
/* Computing MIN */
i__3 = k + 1;
i__4 = *m - k;
cdotu_(&q__1, &i__4, &a_ref(k, min(i__2,*m)), lda, &c___ref(
min(i__3,*m), l), &c__1);
suml.r = q__1.r, suml.i = q__1.i;
i__2 = l - 1;
cdotu_(&q__1, &i__2, &c___ref(k, 1), ldc, &b_ref(1, l), &c__1)
;
sumr.r = q__1.r, sumr.i = q__1.i;
i__2 = c___subscr(k, l);
q__3.r = sgn * sumr.r, q__3.i = sgn * sumr.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__2].r - q__2.r, q__1.i = c__[i__2].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
i__2 = a_subscr(k, k);
i__3 = b_subscr(l, l);
q__2.r = sgn * b[i__3].r, q__2.i = sgn * b[i__3].i;
q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i;
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
csscal_(m, &scaloc, &c___ref(1, j), &c__1);
/* L10: */
}
*scale *= scaloc;
}
i__2 = c___subscr(k, l);
c__[i__2].r = x11.r, c__[i__2].i = x11.i;
/* L20: */
}
/* L30: */
}
} else if (! notrna && notrnb) {
/* Solve A' *X + ISGN*X*B = scale*C.
The (K,L)th block of X is determined starting from
upper-left corner column by column by
A'(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
Where
K-1 L-1
R(K,L) = SUM [A'(I,K)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)]
I=1 J=1 */
i__1 = *n;
for (l = 1; l <= i__1; ++l) {
i__2 = *m;
for (k = 1; k <= i__2; ++k) {
i__3 = k - 1;
cdotc_(&q__1, &i__3, &a_ref(1, k), &c__1, &c___ref(1, l), &
c__1);
suml.r = q__1.r, suml.i = q__1.i;
i__3 = l - 1;
cdotu_(&q__1, &i__3, &c___ref(k, 1), ldc, &b_ref(1, l), &c__1)
;
sumr.r = q__1.r, sumr.i = q__1.i;
i__3 = c___subscr(k, l);
q__3.r = sgn * sumr.r, q__3.i = sgn * sumr.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
r_cnjg(&q__2, &a_ref(k, k));
i__3 = b_subscr(l, l);
q__3.r = sgn * b[i__3].r, q__3.i = sgn * b[i__3].i;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
csscal_(m, &scaloc, &c___ref(1, j), &c__1);
/* L40: */
}
*scale *= scaloc;
}
i__3 = c___subscr(k, l);
c__[i__3].r = x11.r, c__[i__3].i = x11.i;
/* L50: */
}
/* L60: */
}
} else if (! notrna && ! notrnb) {
/* Solve A'*X + ISGN*X*B' = C.
The (K,L)th block of X is determined starting from
upper-right corner column by column by
A'(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L)
Where
K-1
R(K,L) = SUM [A'(I,K)*X(I,L)] +
I=1
N
ISGN*SUM [X(K,J)*B'(L,J)].
J=L+1 */
for (l = *n; l >= 1; --l) {
i__1 = *m;
for (k = 1; k <= i__1; ++k) {
i__2 = k - 1;
cdotc_(&q__1, &i__2, &a_ref(1, k), &c__1, &c___ref(1, l), &
c__1);
suml.r = q__1.r, suml.i = q__1.i;
/* Computing MIN */
i__2 = l + 1;
/* Computing MIN */
i__3 = l + 1;
i__4 = *n - l;
cdotc_(&q__1, &i__4, &c___ref(k, min(i__2,*n)), ldc, &b_ref(l,
min(i__3,*n)), ldb);
sumr.r = q__1.r, sumr.i = q__1.i;
i__2 = c___subscr(k, l);
r_cnjg(&q__4, &sumr);
q__3.r = sgn * q__4.r, q__3.i = sgn * q__4.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__2].r - q__2.r, q__1.i = c__[i__2].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
i__2 = a_subscr(k, k);
i__3 = b_subscr(l, l);
q__3.r = sgn * b[i__3].r, q__3.i = sgn * b[i__3].i;
q__2.r = a[i__2].r + q__3.r, q__2.i = a[i__2].i + q__3.i;
r_cnjg(&q__1, &q__2);
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
csscal_(m, &scaloc, &c___ref(1, j), &c__1);
/* L70: */
}
*scale *= scaloc;
}
i__2 = c___subscr(k, l);
c__[i__2].r = x11.r, c__[i__2].i = x11.i;
/* L80: */
}
/* L90: */
}
} else if (notrna && ! notrnb) {
/* Solve A*X + ISGN*X*B' = C.
The (K,L)th block of X is determined starting from
bottom-left corner column by column by
A(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L)
Where
M N
R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B'(L,J)]
I=K+1 J=L+1 */
for (l = *n; l >= 1; --l) {
for (k = *m; k >= 1; --k) {
/* Computing MIN */
i__1 = k + 1;
/* Computing MIN */
i__2 = k + 1;
i__3 = *m - k;
cdotu_(&q__1, &i__3, &a_ref(k, min(i__1,*m)), lda, &c___ref(
min(i__2,*m), l), &c__1);
suml.r = q__1.r, suml.i = q__1.i;
/* Computing MIN */
i__1 = l + 1;
/* Computing MIN */
i__2 = l + 1;
i__3 = *n - l;
cdotc_(&q__1, &i__3, &c___ref(k, min(i__1,*n)), ldc, &b_ref(l,
min(i__2,*n)), ldb);
sumr.r = q__1.r, sumr.i = q__1.i;
i__1 = c___subscr(k, l);
r_cnjg(&q__4, &sumr);
q__3.r = sgn * q__4.r, q__3.i = sgn * q__4.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__1].r - q__2.r, q__1.i = c__[i__1].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
i__1 = a_subscr(k, k);
r_cnjg(&q__3, &b_ref(l, l));
q__2.r = sgn * q__3.r, q__2.i = sgn * q__3.i;
q__1.r = a[i__1].r + q__2.r, q__1.i = a[i__1].i + q__2.i;
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
csscal_(m, &scaloc, &c___ref(1, j), &c__1);
/* L100: */
}
*scale *= scaloc;
}
i__1 = c___subscr(k, l);
c__[i__1].r = x11.r, c__[i__1].i = x11.i;
/* L110: */
}
/* L120: */
}
}
return 0;
/* End of CTRSYL */
} /* ctrsyl_ */
/* Subroutine */ int chetrs_(char *uplo, integer *n, integer *nrhs, complex *
a, integer *lda, integer *ipiv, complex *b, integer *ldb, integer *
info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CHETRS solves a system of linear equations A*X = B with a complex
Hermitian matrix A using the factorization A = U*D*U**H or
A = L*D*L**H computed by CHETRF.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the details of the factorization are stored
as an upper or lower triangular matrix.
= 'U': Upper triangular, form is A = U*D*U**H;
= 'L': Lower triangular, form is A = L*D*L**H.
N (input) INTEGER
The order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrix B. NRHS >= 0.
A (input) COMPLEX array, dimension (LDA,N)
The block diagonal matrix D and the multipliers used to
obtain the factor U or L as computed by CHETRF.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
IPIV (input) INTEGER array, dimension (N)
Details of the interchanges and the block structure of D
as determined by CHETRF.
B (input/output) COMPLEX array, dimension (LDB,NRHS)
On entry, the right hand side matrix B.
On exit, the solution matrix X.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
complex q__1, q__2, q__3;
/* Builtin functions */
void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *);
/* Local variables */
static complex akm1k;
static integer j, k;
static real s;
extern logical lsame_(char *, char *);
static complex denom;
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *), cgeru_(integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *),
cswap_(integer *, complex *, integer *, complex *, integer *);
static logical upper;
static complex ak, bk;
static integer kp;
extern /* Subroutine */ int clacgv_(integer *, complex *, integer *),
csscal_(integer *, real *, complex *, integer *), xerbla_(char *,
integer *);
static complex akm1, bkm1;
#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)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
/* 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 (*ldb < max(1,*n)) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHETRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
return 0;
}
if (upper) {
/* Solve A*X = B, where A = U*D*U'.
First solve U*D*X = B, overwriting B with X.
K is the main loop index, decreasing from N to 1 in steps of
1 or 2, depending on the size of the diagonal blocks. */
k = *n;
L10:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L30;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block
Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
cswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb);
}
/* Multiply by inv(U(K)), where U(K) is the transformation
stored in column K of A. */
i__1 = k - 1;
q__1.r = -1.f, q__1.i = 0.f;
cgeru_(&i__1, nrhs, &q__1, &a_ref(1, k), &c__1, &b_ref(k, 1), ldb,
&b_ref(1, 1), ldb);
/* Multiply by the inverse of the diagonal block. */
i__1 = a_subscr(k, k);
s = 1.f / a[i__1].r;
csscal_(nrhs, &s, &b_ref(k, 1), ldb);
--k;
} else {
/* 2 x 2 diagonal block
Interchange rows K-1 and -IPIV(K). */
kp = -ipiv[k];
if (kp != k - 1) {
cswap_(nrhs, &b_ref(k - 1, 1), ldb, &b_ref(kp, 1), ldb);
}
/* Multiply by inv(U(K)), where U(K) is the transformation
stored in columns K-1 and K of A. */
i__1 = k - 2;
q__1.r = -1.f, q__1.i = 0.f;
cgeru_(&i__1, nrhs, &q__1, &a_ref(1, k), &c__1, &b_ref(k, 1), ldb,
&b_ref(1, 1), ldb);
i__1 = k - 2;
q__1.r = -1.f, q__1.i = 0.f;
cgeru_(&i__1, nrhs, &q__1, &a_ref(1, k - 1), &c__1, &b_ref(k - 1,
1), ldb, &b_ref(1, 1), ldb);
/* Multiply by the inverse of the diagonal block. */
i__1 = a_subscr(k - 1, k);
akm1k.r = a[i__1].r, akm1k.i = a[i__1].i;
c_div(&q__1, &a_ref(k - 1, k - 1), &akm1k);
akm1.r = q__1.r, akm1.i = q__1.i;
r_cnjg(&q__2, &akm1k);
c_div(&q__1, &a_ref(k, k), &q__2);
ak.r = q__1.r, ak.i = q__1.i;
q__2.r = akm1.r * ak.r - akm1.i * ak.i, q__2.i = akm1.r * ak.i +
akm1.i * ak.r;
q__1.r = q__2.r - 1.f, q__1.i = q__2.i + 0.f;
denom.r = q__1.r, denom.i = q__1.i;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
c_div(&q__1, &b_ref(k - 1, j), &akm1k);
bkm1.r = q__1.r, bkm1.i = q__1.i;
r_cnjg(&q__2, &akm1k);
c_div(&q__1, &b_ref(k, j), &q__2);
bk.r = q__1.r, bk.i = q__1.i;
i__2 = b_subscr(k - 1, j);
q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r *
bkm1.i + ak.i * bkm1.r;
q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i;
c_div(&q__1, &q__2, &denom);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = b_subscr(k, j);
q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r *
bk.i + akm1.i * bk.r;
q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i;
c_div(&q__1, &q__2, &denom);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L20: */
}
k += -2;
}
goto L10;
L30:
/* Next solve U'*X = B, overwriting B with X.
K is the main loop index, increasing from 1 to N in steps of
1 or 2, depending on the size of the diagonal blocks. */
k = 1;
L40:
/* If K > N, exit from loop. */
if (k > *n) {
goto L50;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block
Multiply by inv(U'(K)), where U(K) is the transformation
stored in column K of A. */
if (k > 1) {
clacgv_(nrhs, &b_ref(k, 1), ldb);
i__1 = k - 1;
q__1.r = -1.f, q__1.i = 0.f;
cgemv_("Conjugate transpose", &i__1, nrhs, &q__1, &b[b_offset]
, ldb, &a_ref(1, k), &c__1, &c_b1, &b_ref(k, 1), ldb);
clacgv_(nrhs, &b_ref(k, 1), ldb);
}
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
cswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb);
}
++k;
} else {
/* 2 x 2 diagonal block
Multiply by inv(U'(K+1)), where U(K+1) is the transformation
stored in columns K and K+1 of A. */
if (k > 1) {
clacgv_(nrhs, &b_ref(k, 1), ldb);
i__1 = k - 1;
q__1.r = -1.f, q__1.i = 0.f;
cgemv_("Conjugate transpose", &i__1, nrhs, &q__1, &b[b_offset]
, ldb, &a_ref(1, k), &c__1, &c_b1, &b_ref(k, 1), ldb);
clacgv_(nrhs, &b_ref(k, 1), ldb);
clacgv_(nrhs, &b_ref(k + 1, 1), ldb);
i__1 = k - 1;
q__1.r = -1.f, q__1.i = 0.f;
cgemv_("Conjugate transpose", &i__1, nrhs, &q__1, &b[b_offset]
, ldb, &a_ref(1, k + 1), &c__1, &c_b1, &b_ref(k + 1,
1), ldb);
clacgv_(nrhs, &b_ref(k + 1, 1), ldb);
}
/* Interchange rows K and -IPIV(K). */
kp = -ipiv[k];
if (kp != k) {
cswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb);
}
k += 2;
}
goto L40;
L50:
;
} else {
/* Solve A*X = B, where A = L*D*L'.
First solve L*D*X = B, overwriting B with X.
K is the main loop index, increasing from 1 to N in steps of
1 or 2, depending on the size of the diagonal blocks. */
k = 1;
L60:
/* If K > N, exit from loop. */
if (k > *n) {
goto L80;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block
Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
cswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb);
}
/* Multiply by inv(L(K)), where L(K) is the transformation
stored in column K of A. */
if (k < *n) {
i__1 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
cgeru_(&i__1, nrhs, &q__1, &a_ref(k + 1, k), &c__1, &b_ref(k,
1), ldb, &b_ref(k + 1, 1), ldb);
}
/* Multiply by the inverse of the diagonal block. */
i__1 = a_subscr(k, k);
s = 1.f / a[i__1].r;
csscal_(nrhs, &s, &b_ref(k, 1), ldb);
++k;
} else {
/* 2 x 2 diagonal block
Interchange rows K+1 and -IPIV(K). */
kp = -ipiv[k];
if (kp != k + 1) {
cswap_(nrhs, &b_ref(k + 1, 1), ldb, &b_ref(kp, 1), ldb);
}
/* Multiply by inv(L(K)), where L(K) is the transformation
stored in columns K and K+1 of A. */
if (k < *n - 1) {
i__1 = *n - k - 1;
q__1.r = -1.f, q__1.i = 0.f;
cgeru_(&i__1, nrhs, &q__1, &a_ref(k + 2, k), &c__1, &b_ref(k,
1), ldb, &b_ref(k + 2, 1), ldb);
i__1 = *n - k - 1;
q__1.r = -1.f, q__1.i = 0.f;
cgeru_(&i__1, nrhs, &q__1, &a_ref(k + 2, k + 1), &c__1, &
b_ref(k + 1, 1), ldb, &b_ref(k + 2, 1), ldb);
}
/* Multiply by the inverse of the diagonal block. */
i__1 = a_subscr(k + 1, k);
akm1k.r = a[i__1].r, akm1k.i = a[i__1].i;
r_cnjg(&q__2, &akm1k);
c_div(&q__1, &a_ref(k, k), &q__2);
akm1.r = q__1.r, akm1.i = q__1.i;
c_div(&q__1, &a_ref(k + 1, k + 1), &akm1k);
ak.r = q__1.r, ak.i = q__1.i;
q__2.r = akm1.r * ak.r - akm1.i * ak.i, q__2.i = akm1.r * ak.i +
akm1.i * ak.r;
q__1.r = q__2.r - 1.f, q__1.i = q__2.i + 0.f;
denom.r = q__1.r, denom.i = q__1.i;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
r_cnjg(&q__2, &akm1k);
c_div(&q__1, &b_ref(k, j), &q__2);
bkm1.r = q__1.r, bkm1.i = q__1.i;
c_div(&q__1, &b_ref(k + 1, j), &akm1k);
bk.r = q__1.r, bk.i = q__1.i;
i__2 = b_subscr(k, j);
q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r *
bkm1.i + ak.i * bkm1.r;
q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i;
c_div(&q__1, &q__2, &denom);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = b_subscr(k + 1, j);
q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r *
bk.i + akm1.i * bk.r;
q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i;
c_div(&q__1, &q__2, &denom);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L70: */
}
k += 2;
}
goto L60;
L80:
/* Next solve L'*X = B, overwriting B with X.
K is the main loop index, decreasing from N to 1 in steps of
1 or 2, depending on the size of the diagonal blocks. */
k = *n;
L90:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L100;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block
Multiply by inv(L'(K)), where L(K) is the transformation
stored in column K of A. */
if (k < *n) {
clacgv_(nrhs, &b_ref(k, 1), ldb);
i__1 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
cgemv_("Conjugate transpose", &i__1, nrhs, &q__1, &b_ref(k +
1, 1), ldb, &a_ref(k + 1, k), &c__1, &c_b1, &b_ref(k,
1), ldb);
clacgv_(nrhs, &b_ref(k, 1), ldb);
}
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
cswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb);
}
--k;
} else {
/* 2 x 2 diagonal block
Multiply by inv(L'(K-1)), where L(K-1) is the transformation
stored in columns K-1 and K of A. */
if (k < *n) {
clacgv_(nrhs, &b_ref(k, 1), ldb);
i__1 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
cgemv_("Conjugate transpose", &i__1, nrhs, &q__1, &b_ref(k +
1, 1), ldb, &a_ref(k + 1, k), &c__1, &c_b1, &b_ref(k,
1), ldb);
clacgv_(nrhs, &b_ref(k, 1), ldb);
clacgv_(nrhs, &b_ref(k - 1, 1), ldb);
i__1 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
cgemv_("Conjugate transpose", &i__1, nrhs, &q__1, &b_ref(k +
1, 1), ldb, &a_ref(k + 1, k - 1), &c__1, &c_b1, &
b_ref(k - 1, 1), ldb);
clacgv_(nrhs, &b_ref(k - 1, 1), ldb);
}
/* Interchange rows K and -IPIV(K). */
kp = -ipiv[k];
if (kp != k) {
cswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb);
}
k += -2;
}
goto L90;
L100:
;
}
return 0;
/* End of CHETRS */
} /* chetrs_ */
int claein_(int *rightv, int *noinit, int *n,
complex *h__, int *ldh, complex *w, complex *v, complex *b,
int *ldb, float *rwork, float *eps3, float *smlnum, int *info)
{
/* System generated locals */
int b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4, i__5;
float r__1, r__2, r__3, r__4;
complex q__1, q__2;
/* Builtin functions */
double sqrt(double), r_imag(complex *);
/* Local variables */
int i__, j;
complex x, ei, ej;
int its, ierr;
complex temp;
float scale;
char trans[1];
float rtemp, rootn, vnorm;
extern double scnrm2_(int *, complex *, int *);
extern int icamax_(int *, complex *, int *);
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern int csscal_(int *, float *, complex *, int
*), clatrs_(char *, char *, char *, char *, int *, complex *,
int *, complex *, float *, float *, int *);
extern double scasum_(int *, complex *, int *);
char normin[1];
float nrmsml, growto;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLAEIN uses inverse iteration to find a right or left eigenvector */
/* corresponding to the eigenvalue W of a complex upper Hessenberg */
/* matrix H. */
/* Arguments */
/* ========= */
/* RIGHTV (input) LOGICAL */
/* = .TRUE. : compute right eigenvector; */
/* = .FALSE.: compute left eigenvector. */
/* NOINIT (input) LOGICAL */
/* = .TRUE. : no initial vector supplied in V */
/* = .FALSE.: initial vector supplied in V. */
/* N (input) INTEGER */
/* The order of the matrix H. N >= 0. */
/* H (input) COMPLEX array, dimension (LDH,N) */
/* The upper Hessenberg matrix H. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= MAX(1,N). */
/* W (input) COMPLEX */
/* The eigenvalue of H whose corresponding right or left */
/* eigenvector is to be computed. */
/* V (input/output) COMPLEX array, dimension (N) */
/* On entry, if NOINIT = .FALSE., V must contain a starting */
/* vector for inverse iteration; otherwise V need not be set. */
/* On exit, V contains the computed eigenvector, normalized so */
/* that the component of largest magnitude has magnitude 1; here */
/* the magnitude of a complex number (x,y) is taken to be */
/* |x| + |y|. */
/* B (workspace) COMPLEX array, dimension (LDB,N) */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= MAX(1,N). */
/* RWORK (workspace) REAL array, dimension (N) */
/* EPS3 (input) REAL */
/* A small machine-dependent value which is used to perturb */
/* close eigenvalues, and to replace zero pivots. */
/* SMLNUM (input) REAL */
/* A machine-dependent value close to the underflow threshold. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* = 1: inverse iteration did not converge; V is set to the */
/* last iterate. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--v;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--rwork;
/* Function Body */
*info = 0;
/* GROWTO is the threshold used in the acceptance test for an */
/* eigenvector. */
rootn = sqrt((float) (*n));
growto = .1f / rootn;
/* Computing MAX */
r__1 = 1.f, r__2 = *eps3 * rootn;
nrmsml = MAX(r__1,r__2) * *smlnum;
/* Form B = H - W*I (except that the subdiagonal elements are not */
/* stored). */
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 * b_dim1;
i__4 = i__ + j * h_dim1;
b[i__3].r = h__[i__4].r, b[i__3].i = h__[i__4].i;
/* L10: */
}
i__2 = j + j * b_dim1;
i__3 = j + j * h_dim1;
q__1.r = h__[i__3].r - w->r, q__1.i = h__[i__3].i - w->i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L20: */
}
if (*noinit) {
/* Initialize V. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
v[i__2].r = *eps3, v[i__2].i = 0.f;
/* L30: */
}
} else {
/* Scale supplied initial vector. */
vnorm = scnrm2_(n, &v[1], &c__1);
r__1 = *eps3 * rootn / MAX(vnorm,nrmsml);
csscal_(n, &r__1, &v[1], &c__1);
}
if (*rightv) {
/* LU decomposition with partial pivoting of B, replacing zero */
/* pivots by EPS3. */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + 1 + i__ * h_dim1;
ei.r = h__[i__2].r, ei.i = h__[i__2].i;
i__2 = i__ + i__ * b_dim1;
if ((r__1 = b[i__2].r, ABS(r__1)) + (r__2 = r_imag(&b[i__ + i__ *
b_dim1]), ABS(r__2)) < (r__3 = ei.r, ABS(r__3)) + (
r__4 = r_imag(&ei), ABS(r__4))) {
/* Interchange rows and eliminate. */
cladiv_(&q__1, &b[i__ + i__ * b_dim1], &ei);
x.r = q__1.r, x.i = q__1.i;
i__2 = i__ + i__ * b_dim1;
b[i__2].r = ei.r, b[i__2].i = ei.i;
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = i__ + 1 + j * b_dim1;
temp.r = b[i__3].r, temp.i = b[i__3].i;
i__3 = i__ + 1 + j * b_dim1;
i__4 = i__ + j * b_dim1;
q__2.r = x.r * temp.r - x.i * temp.i, q__2.i = x.r *
temp.i + x.i * temp.r;
q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i - q__2.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
i__3 = i__ + j * b_dim1;
b[i__3].r = temp.r, b[i__3].i = temp.i;
/* L40: */
}
} else {
/* Eliminate without interchange. */
i__2 = i__ + i__ * b_dim1;
if (b[i__2].r == 0.f && b[i__2].i == 0.f) {
i__3 = i__ + i__ * b_dim1;
b[i__3].r = *eps3, b[i__3].i = 0.f;
}
cladiv_(&q__1, &ei, &b[i__ + i__ * b_dim1]);
x.r = q__1.r, x.i = q__1.i;
if (x.r != 0.f || x.i != 0.f) {
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = i__ + 1 + j * b_dim1;
i__4 = i__ + 1 + j * b_dim1;
i__5 = i__ + j * b_dim1;
q__2.r = x.r * b[i__5].r - x.i * b[i__5].i, q__2.i =
x.r * b[i__5].i + x.i * b[i__5].r;
q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i -
q__2.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L50: */
}
}
}
/* L60: */
}
i__1 = *n + *n * b_dim1;
if (b[i__1].r == 0.f && b[i__1].i == 0.f) {
i__2 = *n + *n * b_dim1;
b[i__2].r = *eps3, b[i__2].i = 0.f;
}
*(unsigned char *)trans = 'N';
} else {
/* UL decomposition with partial pivoting of B, replacing zero */
/* pivots by EPS3. */
for (j = *n; j >= 2; --j) {
i__1 = j + (j - 1) * h_dim1;
ej.r = h__[i__1].r, ej.i = h__[i__1].i;
i__1 = j + j * b_dim1;
if ((r__1 = b[i__1].r, ABS(r__1)) + (r__2 = r_imag(&b[j + j *
b_dim1]), ABS(r__2)) < (r__3 = ej.r, ABS(r__3)) + (r__4
= r_imag(&ej), ABS(r__4))) {
/* Interchange columns and eliminate. */
cladiv_(&q__1, &b[j + j * b_dim1], &ej);
x.r = q__1.r, x.i = q__1.i;
i__1 = j + j * b_dim1;
b[i__1].r = ej.r, b[i__1].i = ej.i;
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + (j - 1) * b_dim1;
temp.r = b[i__2].r, temp.i = b[i__2].i;
i__2 = i__ + (j - 1) * b_dim1;
i__3 = i__ + j * b_dim1;
q__2.r = x.r * temp.r - x.i * temp.i, q__2.i = x.r *
temp.i + x.i * temp.r;
q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = i__ + j * b_dim1;
b[i__2].r = temp.r, b[i__2].i = temp.i;
/* L70: */
}
} else {
/* Eliminate without interchange. */
i__1 = j + j * b_dim1;
if (b[i__1].r == 0.f && b[i__1].i == 0.f) {
i__2 = j + j * b_dim1;
b[i__2].r = *eps3, b[i__2].i = 0.f;
}
cladiv_(&q__1, &ej, &b[j + j * b_dim1]);
x.r = q__1.r, x.i = q__1.i;
if (x.r != 0.f || x.i != 0.f) {
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + (j - 1) * b_dim1;
i__3 = i__ + (j - 1) * b_dim1;
i__4 = i__ + j * b_dim1;
q__2.r = x.r * b[i__4].r - x.i * b[i__4].i, q__2.i =
x.r * b[i__4].i + x.i * b[i__4].r;
q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i -
q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L80: */
}
}
}
/* L90: */
}
i__1 = b_dim1 + 1;
if (b[i__1].r == 0.f && b[i__1].i == 0.f) {
i__2 = b_dim1 + 1;
b[i__2].r = *eps3, b[i__2].i = 0.f;
}
*(unsigned char *)trans = 'C';
}
*(unsigned char *)normin = 'N';
i__1 = *n;
for (its = 1; its <= i__1; ++its) {
/* Solve U*x = scale*v for a right eigenvector */
/* or U'*x = scale*v for a left eigenvector, */
/* overwriting x on v. */
clatrs_("Upper", trans, "Nonunit", normin, n, &b[b_offset], ldb, &v[1]
, &scale, &rwork[1], &ierr);
*(unsigned char *)normin = 'Y';
/* Test for sufficient growth in the norm of v. */
vnorm = scasum_(n, &v[1], &c__1);
if (vnorm >= growto * scale) {
goto L120;
}
/* Choose new orthogonal starting vector and try again. */
rtemp = *eps3 / (rootn + 1.f);
v[1].r = *eps3, v[1].i = 0.f;
i__2 = *n;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = i__;
v[i__3].r = rtemp, v[i__3].i = 0.f;
/* L100: */
}
i__2 = *n - its + 1;
i__3 = *n - its + 1;
r__1 = *eps3 * rootn;
q__1.r = v[i__3].r - r__1, q__1.i = v[i__3].i;
v[i__2].r = q__1.r, v[i__2].i = q__1.i;
/* L110: */
}
/* Failure to find eigenvector in N iterations. */
*info = 1;
L120:
/* Normalize eigenvector. */
i__ = icamax_(n, &v[1], &c__1);
i__1 = i__;
r__3 = 1.f / ((r__1 = v[i__1].r, ABS(r__1)) + (r__2 = r_imag(&v[i__]),
ABS(r__2)));
csscal_(n, &r__3, &v[1], &c__1);
return 0;
/* End of CLAEIN */
} /* claein_ */
/* Subroutine */
int cpbtf2_(char *uplo, integer *n, integer *kd, complex *ab, integer *ldab, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer j, kn;
real ajj;
integer kld;
extern /* Subroutine */
int cher_(char *, integer *, real *, complex *, integer *, complex *, integer *);
extern logical lsame_(char *, char *);
logical upper;
extern /* Subroutine */
int clacgv_(integer *, complex *, integer *), csscal_(integer *, real *, complex *, integer *), xerbla_(char *, integer *);
/* -- 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 Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*kd < 0)
{
*info = -3;
}
else if (*ldab < *kd + 1)
{
*info = -5;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CPBTF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
/* Computing MAX */
i__1 = 1;
i__2 = *ldab - 1; // , expr subst
kld = max(i__1,i__2);
if (upper)
{
/* Compute the Cholesky factorization A = U**H * U. */
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Compute U(J,J) and test for non-positive-definiteness. */
i__2 = *kd + 1 + j * ab_dim1;
ajj = ab[i__2].r;
if (ajj <= 0.f)
{
i__2 = *kd + 1 + j * ab_dim1;
ab[i__2].r = ajj;
ab[i__2].i = 0.f; // , expr subst
goto L30;
}
ajj = sqrt(ajj);
i__2 = *kd + 1 + j * ab_dim1;
ab[i__2].r = ajj;
ab[i__2].i = 0.f; // , expr subst
/* Compute elements J+1:J+KN of row J and update the */
/* trailing submatrix within the band. */
/* Computing MIN */
i__2 = *kd;
i__3 = *n - j; // , expr subst
kn = min(i__2,i__3);
if (kn > 0)
{
r__1 = 1.f / ajj;
csscal_(&kn, &r__1, &ab[*kd + (j + 1) * ab_dim1], &kld);
clacgv_(&kn, &ab[*kd + (j + 1) * ab_dim1], &kld);
cher_("Upper", &kn, &c_b8, &ab[*kd + (j + 1) * ab_dim1], &kld, &ab[*kd + 1 + (j + 1) * ab_dim1], &kld);
clacgv_(&kn, &ab[*kd + (j + 1) * ab_dim1], &kld);
}
/* L10: */
}
}
else
{
/* Compute the Cholesky factorization A = L*L**H. */
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Compute L(J,J) and test for non-positive-definiteness. */
i__2 = j * ab_dim1 + 1;
ajj = ab[i__2].r;
if (ajj <= 0.f)
{
i__2 = j * ab_dim1 + 1;
ab[i__2].r = ajj;
ab[i__2].i = 0.f; // , expr subst
goto L30;
}
ajj = sqrt(ajj);
i__2 = j * ab_dim1 + 1;
ab[i__2].r = ajj;
ab[i__2].i = 0.f; // , expr subst
/* Compute elements J+1:J+KN of column J and update the */
/* trailing submatrix within the band. */
/* Computing MIN */
i__2 = *kd;
i__3 = *n - j; // , expr subst
kn = min(i__2,i__3);
if (kn > 0)
{
r__1 = 1.f / ajj;
csscal_(&kn, &r__1, &ab[j * ab_dim1 + 2], &c__1);
cher_("Lower", &kn, &c_b8, &ab[j * ab_dim1 + 2], &c__1, &ab[( j + 1) * ab_dim1 + 1], &kld);
}
/* L20: */
}
}
return 0;
L30:
*info = j;
return 0;
/* End of CPBTF2 */
}
/* Subroutine */ int ctrt03_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, complex *a, integer *lda, real *scale, real *cnorm,
real *tscal, complex *x, integer *ldx, complex *b, integer *ldb,
complex *work, real *resid)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
real r__1, r__2;
complex q__1;
/* Local variables */
integer j, ix;
real eps, err;
real xscal;
real tnorm, xnorm;
real smlnum;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CTRT03 computes the residual for the solution to a scaled triangular */
/* system of equations A*x = s*b, A**T *x = s*b, or A**H *x = s*b. */
/* Here A is a triangular matrix, A**T denotes the transpose of A, A**H */
/* denotes the conjugate transpose of A, s is a scalar, and x and b are */
/* N by NRHS matrices. The test ratio is the maximum over the number of */
/* right hand sides of */
/* norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
/* where op(A) denotes A, A**T, or A**H, and EPS is the machine epsilon. */
/* 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': A *x = s*b (No transpose) */
/* = 'T': A**T *x = s*b (Transpose) */
/* = 'C': 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 */
/* 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 X and B. NRHS >= 0. */
/* A (input) COMPLEX 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). */
/* SCALE (input) REAL */
/* The scaling factor s used in solving the triangular system. */
/* CNORM (input) REAL array, dimension (N) */
/* The 1-norms of the columns of A, not counting the diagonal. */
/* TSCAL (input) REAL */
/* The scaling factor used in computing the 1-norms in CNORM. */
/* CNORM actually contains the column norms of TSCAL*A. */
/* X (input) COMPLEX array, dimension (LDX,NRHS) */
/* The computed solution vectors for the system of linear */
/* equations. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* B (input) COMPLEX 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). */
/* WORK (workspace) COMPLEX array, dimension (N) */
/* RESID (output) REAL */
/* The maximum over the number of right hand sides of */
/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * 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;
--cnorm;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--work;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
*resid = 0.f;
return 0;
}
eps = slamch_("Epsilon");
smlnum = slamch_("Safe minimum");
/* Compute the norm of the triangular matrix A using the column */
/* norms already computed by CLATRS. */
tnorm = 0.f;
if (lsame_(diag, "N")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__1 = tnorm, r__2 = *tscal * c_abs(&a[j + j * a_dim1]) + cnorm[j]
;
tnorm = dmax(r__1,r__2);
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__1 = tnorm, r__2 = *tscal + cnorm[j];
tnorm = dmax(r__1,r__2);
/* L20: */
}
}
/* Compute the maximum over the number of right hand sides of */
/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
*resid = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ccopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
ix = icamax_(n, &work[1], &c__1);
/* Computing MAX */
r__1 = 1.f, r__2 = c_abs(&x[ix + j * x_dim1]);
xnorm = dmax(r__1,r__2);
xscal = 1.f / xnorm / (real) (*n);
csscal_(n, &xscal, &work[1], &c__1);
ctrmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[1], &c__1);
r__1 = -(*scale) * xscal;
q__1.r = r__1, q__1.i = 0.f;
caxpy_(n, &q__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
ix = icamax_(n, &work[1], &c__1);
err = *tscal * c_abs(&work[ix]);
ix = icamax_(n, &x[j * x_dim1 + 1], &c__1);
xnorm = c_abs(&x[ix + j * x_dim1]);
if (err * smlnum <= xnorm) {
if (xnorm > 0.f) {
err /= xnorm;
}
} else {
if (err > 0.f) {
err = 1.f / eps;
}
}
if (err * smlnum <= tnorm) {
if (tnorm > 0.f) {
err /= tnorm;
}
} else {
if (err > 0.f) {
err = 1.f / eps;
}
}
*resid = dmax(*resid,err);
/* L30: */
}
return 0;
/* End of CTRT03 */
} /* ctrt03_ */
/* Subroutine */ int cdrvgt_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, real *thresh, logical *tsterr, complex *a, complex *af,
complex *b, complex *x, complex *xact, complex *work, real *rwork,
integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
static char transs[1*3] = "N" "T" "C";
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002, N =\002,i5,\002, type \002,i2,"
"\002, test \002,i2,\002, ratio = \002,g12.5)";
static char fmt_9998[] = "(1x,a6,\002, FACT='\002,a1,\002', TRANS='\002,"
"a1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002,"
" ratio = \002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5, i__6[2];
real r__1, r__2;
char ch__1[2];
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static char fact[1];
static real cond;
static integer mode, koff, imat, info;
static char path[3], dist[1], type__[1];
static integer nrun, i__, j, k, m, n, ifact;
extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
integer *, complex *, integer *, real *, real *);
static integer nfail, iseed[4];
static real z__[3];
extern /* Subroutine */ int cgtt01_(integer *, complex *, complex *,
complex *, complex *, complex *, complex *, complex *, integer *,
complex *, integer *, real *, real *), cgtt02_(char *, integer *,
integer *, complex *, complex *, complex *, complex *, integer *,
complex *, integer *, real *, real *);
static real rcond;
extern /* Subroutine */ int cgtt05_(char *, integer *, integer *, complex
*, complex *, complex *, complex *, integer *, complex *, integer
*, complex *, integer *, real *, real *, real *);
static integer nimat;
extern doublereal sget06_(real *, real *);
static real anorm;
static integer itran;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), cgtsv_(integer *, integer *, complex *,
complex *, complex *, complex *, integer *, integer *);
static char trans[1];
static integer izero, nerrs, k1;
static logical zerot;
extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, real *, integer *, real *, char *
), aladhd_(integer *, char *);
static integer in, kl;
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
static integer ku, ix, nt;
extern /* Subroutine */ int clagtm_(char *, integer *, integer *, real *,
complex *, complex *, complex *, complex *, integer *, real *,
complex *, integer *);
static real rcondc;
extern doublereal clangt_(char *, integer *, complex *, complex *,
complex *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), clacpy_(char *, integer *, integer *, complex *, integer *,
complex *, integer *), claset_(char *, integer *, integer
*, complex *, complex *, complex *, integer *);
static real rcondi;
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *);
static real rcondo, anormi;
extern /* Subroutine */ int clarnv_(integer *, integer *, integer *,
complex *), clatms_(integer *, integer *, char *, integer *, char
*, real *, integer *, real *, real *, integer *, integer *, char *
, complex *, integer *, complex *, integer *);
static real ainvnm;
extern /* Subroutine */ int cgttrf_(integer *, complex *, complex *,
complex *, complex *, integer *, integer *);
static logical trfcon;
static real anormo;
extern doublereal scasum_(integer *, complex *, integer *);
extern /* Subroutine */ int cgttrs_(char *, integer *, integer *, complex
*, complex *, complex *, complex *, integer *, complex *, integer
*, integer *), cerrvx_(char *, integer *);
static real result[6];
extern /* Subroutine */ int cgtsvx_(char *, char *, integer *, integer *,
complex *, complex *, complex *, complex *, complex *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *,
real *, real *, real *, complex *, real *, integer *);
static integer lda;
/* Fortran I/O blocks */
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9998, 0 };
/* -- 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
=======
CDRVGT tests CGTSV and -SVX.
Arguments
=========
DOTYPE (input) LOGICAL array, dimension (NTYPES)
The matrix types to be used for testing. Matrices of type j
(for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
.TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix dimension N.
THRESH (input) REAL
The threshold value for the test ratios. A result is
included in the output file if RESULT >= THRESH. To have
every test ratio printed, use THRESH = 0.
TSTERR (input) LOGICAL
Flag that indicates whether error exits are to be tested.
A (workspace) COMPLEX array, dimension (NMAX*4)
AF (workspace) COMPLEX array, dimension (NMAX*4)
B (workspace) COMPLEX array, dimension (NMAX*NRHS)
X (workspace) COMPLEX array, dimension (NMAX*NRHS)
XACT (workspace) COMPLEX array, dimension (NMAX*NRHS)
WORK (workspace) COMPLEX array, dimension
(NMAX*max(3,NRHS))
RWORK (workspace) REAL array, dimension (NMAX+2*NRHS)
IWORK (workspace) INTEGER array, dimension (2*NMAX)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--af;
--a;
--nval;
--dotype;
/* Function Body */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "GT", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
cerrvx_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
/* Computing MAX */
i__2 = n - 1;
m = max(i__2,0);
lda = max(1,n);
nimat = 12;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L130;
}
/* Set up parameters with CLATB4. */
clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cond, dist);
zerot = imat >= 8 && imat <= 10;
if (imat <= 6) {
/* Types 1-6: generate matrices of known condition number.
Computing MAX */
i__3 = 2 - ku, i__4 = 3 - max(1,n);
koff = max(i__3,i__4);
s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)6, (ftnlen)6);
clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
&anorm, &kl, &ku, "Z", &af[koff], &c__3, &work[1], &
info);
/* Check the error code from CLATMS. */
if (info != 0) {
alaerh_(path, "CLATMS", &info, &c__0, " ", &n, &n, &kl, &
ku, &c_n1, &imat, &nfail, &nerrs, nout);
goto L130;
}
izero = 0;
if (n > 1) {
i__3 = n - 1;
ccopy_(&i__3, &af[4], &c__3, &a[1], &c__1);
i__3 = n - 1;
ccopy_(&i__3, &af[3], &c__3, &a[n + m + 1], &c__1);
}
ccopy_(&n, &af[2], &c__3, &a[m + 1], &c__1);
} else {
/* Types 7-12: generate tridiagonal matrices with
unknown condition numbers. */
if (! zerot || ! dotype[7]) {
/* Generate a matrix with elements from [-1,1]. */
i__3 = n + (m << 1);
clarnv_(&c__2, iseed, &i__3, &a[1]);
if (anorm != 1.f) {
i__3 = n + (m << 1);
csscal_(&i__3, &anorm, &a[1], &c__1);
}
} else if (izero > 0) {
/* Reuse the last matrix by copying back the zeroed out
elements. */
if (izero == 1) {
i__3 = n;
a[i__3].r = z__[1], a[i__3].i = 0.f;
if (n > 1) {
a[1].r = z__[2], a[1].i = 0.f;
}
} else if (izero == n) {
i__3 = n * 3 - 2;
a[i__3].r = z__[0], a[i__3].i = 0.f;
i__3 = (n << 1) - 1;
a[i__3].r = z__[1], a[i__3].i = 0.f;
} else {
i__3 = (n << 1) - 2 + izero;
a[i__3].r = z__[0], a[i__3].i = 0.f;
i__3 = n - 1 + izero;
a[i__3].r = z__[1], a[i__3].i = 0.f;
i__3 = izero;
a[i__3].r = z__[2], a[i__3].i = 0.f;
}
}
/* If IMAT > 7, set one column of the matrix to 0. */
if (! zerot) {
izero = 0;
} else if (imat == 8) {
izero = 1;
i__3 = n;
z__[1] = a[i__3].r;
i__3 = n;
a[i__3].r = 0.f, a[i__3].i = 0.f;
if (n > 1) {
z__[2] = a[1].r;
a[1].r = 0.f, a[1].i = 0.f;
}
} else if (imat == 9) {
izero = n;
i__3 = n * 3 - 2;
z__[0] = a[i__3].r;
i__3 = (n << 1) - 1;
z__[1] = a[i__3].r;
i__3 = n * 3 - 2;
a[i__3].r = 0.f, a[i__3].i = 0.f;
i__3 = (n << 1) - 1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
} else {
izero = (n + 1) / 2;
i__3 = n - 1;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = (n << 1) - 2 + i__;
a[i__4].r = 0.f, a[i__4].i = 0.f;
i__4 = n - 1 + i__;
a[i__4].r = 0.f, a[i__4].i = 0.f;
i__4 = i__;
a[i__4].r = 0.f, a[i__4].i = 0.f;
/* L20: */
}
i__3 = n * 3 - 2;
a[i__3].r = 0.f, a[i__3].i = 0.f;
i__3 = (n << 1) - 1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
}
}
for (ifact = 1; ifact <= 2; ++ifact) {
if (ifact == 1) {
*(unsigned char *)fact = 'F';
} else {
*(unsigned char *)fact = 'N';
}
/* Compute the condition number for comparison with
the value returned by CGTSVX. */
if (zerot) {
if (ifact == 1) {
goto L120;
}
rcondo = 0.f;
rcondi = 0.f;
} else if (ifact == 1) {
i__3 = n + (m << 1);
ccopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
/* Compute the 1-norm and infinity-norm of A. */
anormo = clangt_("1", &n, &a[1], &a[m + 1], &a[n + m + 1]);
anormi = clangt_("I", &n, &a[1], &a[m + 1], &a[n + m + 1]);
/* Factor the matrix A. */
cgttrf_(&n, &af[1], &af[m + 1], &af[n + m + 1], &af[n + (
m << 1) + 1], &iwork[1], &info);
/* Use CGTTRS to solve for one column at a time of
inv(A), computing the maximum column sum as we go. */
ainvnm = 0.f;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
i__5 = j;
x[i__5].r = 0.f, x[i__5].i = 0.f;
/* L30: */
}
i__4 = i__;
x[i__4].r = 1.f, x[i__4].i = 0.f;
cgttrs_("No transpose", &n, &c__1, &af[1], &af[m + 1],
&af[n + m + 1], &af[n + (m << 1) + 1], &
iwork[1], &x[1], &lda, &info);
/* Computing MAX */
r__1 = ainvnm, r__2 = scasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* L40: */
}
/* Compute the 1-norm condition number of A. */
if (anormo <= 0.f || ainvnm <= 0.f) {
rcondo = 1.f;
} else {
rcondo = 1.f / anormo / ainvnm;
}
/* Use CGTTRS to solve for one column at a time of
inv(A'), computing the maximum column sum as we go. */
ainvnm = 0.f;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
i__5 = j;
x[i__5].r = 0.f, x[i__5].i = 0.f;
/* L50: */
}
i__4 = i__;
x[i__4].r = 1.f, x[i__4].i = 0.f;
cgttrs_("Conjugate transpose", &n, &c__1, &af[1], &af[
m + 1], &af[n + m + 1], &af[n + (m << 1) + 1],
&iwork[1], &x[1], &lda, &info);
/* Computing MAX */
r__1 = ainvnm, r__2 = scasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* L60: */
}
/* Compute the infinity-norm condition number of A. */
if (anormi <= 0.f || ainvnm <= 0.f) {
rcondi = 1.f;
} else {
rcondi = 1.f / anormi / ainvnm;
}
}
for (itran = 1; itran <= 3; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&transs[itran
- 1];
if (itran == 1) {
rcondc = rcondo;
} else {
rcondc = rcondi;
}
/* Generate NRHS random solution vectors. */
ix = 1;
i__3 = *nrhs;
for (j = 1; j <= i__3; ++j) {
clarnv_(&c__2, iseed, &n, &xact[ix]);
ix += lda;
/* L70: */
}
/* Set the right hand side. */
clagtm_(trans, &n, nrhs, &c_b43, &a[1], &a[m + 1], &a[n +
m + 1], &xact[1], &lda, &c_b44, &b[1], &lda);
if (ifact == 2 && itran == 1) {
/* --- Test CGTSV ---
Solve the system using Gaussian elimination with
partial pivoting. */
i__3 = n + (m << 1);
ccopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "CGTSV ", (ftnlen)6, (ftnlen)
6);
cgtsv_(&n, nrhs, &af[1], &af[m + 1], &af[n + m + 1], &
x[1], &lda, &info);
/* Check error code from CGTSV . */
if (info != izero) {
alaerh_(path, "CGTSV ", &info, &izero, " ", &n, &
n, &c__1, &c__1, nrhs, &imat, &nfail, &
nerrs, nout);
}
nt = 1;
if (izero == 0) {
/* Check residual of computed solution. */
clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
lda);
cgtt02_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n +
m + 1], &x[1], &lda, &work[1], &lda, &
rwork[1], &result[1]);
/* Check solution from generated exact solution. */
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
}
/* Print information about the tests that did not pass
the threshold. */
i__3 = nt;
for (k = 2; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, "CGTSV ", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L80: */
}
nrun = nrun + nt - 1;
}
/* --- Test CGTSVX --- */
if (ifact > 1) {
/* Initialize AF to zero. */
i__3 = n * 3 - 2;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
af[i__4].r = 0.f, af[i__4].i = 0.f;
/* L90: */
}
}
claset_("Full", &n, nrhs, &c_b65, &c_b65, &x[1], &lda);
/* Solve the system and compute the condition number and
error bounds using CGTSVX. */
s_copy(srnamc_1.srnamt, "CGTSVX", (ftnlen)6, (ftnlen)6);
cgtsvx_(fact, trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m
+ 1], &af[1], &af[m + 1], &af[n + m + 1], &af[n +
(m << 1) + 1], &iwork[1], &b[1], &lda, &x[1], &
lda, &rcond, &rwork[1], &rwork[*nrhs + 1], &work[
1], &rwork[(*nrhs << 1) + 1], &info);
/* Check the error code from CGTSVX. */
if (info != izero) {
/* Writing concatenation */
i__6[0] = 1, a__1[0] = fact;
i__6[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__6, &c__2, (ftnlen)2);
alaerh_(path, "CGTSVX", &info, &izero, ch__1, &n, &n,
&c__1, &c__1, nrhs, &imat, &nfail, &nerrs,
nout);
}
if (ifact >= 2) {
/* Reconstruct matrix from factors and compute
residual. */
cgtt01_(&n, &a[1], &a[m + 1], &a[n + m + 1], &af[1], &
af[m + 1], &af[n + m + 1], &af[n + (m << 1) +
1], &iwork[1], &work[1], &lda, &rwork[1],
result);
k1 = 1;
} else {
k1 = 2;
}
if (info == 0) {
trfcon = FALSE_;
/* Check residual of computed solution. */
clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
cgtt02_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m +
1], &x[1], &lda, &work[1], &lda, &rwork[1], &
result[1]);
/* Check solution from generated exact solution. */
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
/* Check the error bounds from iterative refinement. */
cgtt05_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m +
1], &b[1], &lda, &x[1], &lda, &xact[1], &lda,
&rwork[1], &rwork[*nrhs + 1], &result[3]);
nt = 5;
}
/* Print information about the tests that did not pass
the threshold. */
i__3 = nt;
for (k = k1; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, "CGTSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L100: */
}
/* Check the reciprocal of the condition number. */
result[5] = sget06_(&rcond, &rcondc);
if (result[5] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___47.ciunit = *nout;
s_wsfe(&io___47);
do_fio(&c__1, "CGTSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
real));
e_wsfe();
++nfail;
}
nrun = nrun + nt - k1 + 2;
/* L110: */
}
L120:
;
}
L130:
;
}
/* L140: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of CDRVGT */
} /* cdrvgt_ */
/* Subroutine */ int clauu2_(char *uplo, integer *n, complex *a, integer *lda,
integer *info)
{
/* -- 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
=======
CLAUU2 computes the product U * U' or L' * L, where the triangular
factor U or L is stored in the upper or lower triangular part of
the array A.
If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
overwriting the factor U in A.
If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
overwriting the factor L in A.
This is the unblocked form of the algorithm, calling Level 2 BLAS.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the triangular factor stored in the array A
is upper or lower triangular:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the triangular factor U or L. N >= 0.
A (input/output) COMPLEX array, dimension (LDA,N)
On entry, the triangular factor U or L.
On exit, if UPLO = 'U', the upper triangle of A is
overwritten with the upper triangle of the product U * U';
if UPLO = 'L', the lower triangle of A is overwritten with
the lower triangle of the product L' * L.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -k, the k-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
real r__1;
complex q__1;
/* Local variables */
static integer i__;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *);
static logical upper;
extern /* Subroutine */ int clacgv_(integer *, complex *, integer *),
csscal_(integer *, real *, complex *, integer *), xerbla_(char *,
integer *);
static real aii;
#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;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! 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_("CLAUU2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (upper) {
/* Compute the product U * U'. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = a_subscr(i__, i__);
aii = a[i__2].r;
if (i__ < *n) {
i__2 = a_subscr(i__, i__);
i__3 = *n - i__;
cdotc_(&q__1, &i__3, &a_ref(i__, i__ + 1), lda, &a_ref(i__,
i__ + 1), lda);
r__1 = aii * aii + q__1.r;
a[i__2].r = r__1, a[i__2].i = 0.f;
i__2 = *n - i__;
clacgv_(&i__2, &a_ref(i__, i__ + 1), lda);
i__2 = i__ - 1;
i__3 = *n - i__;
q__1.r = aii, q__1.i = 0.f;
cgemv_("No transpose", &i__2, &i__3, &c_b1, &a_ref(1, i__ + 1)
, lda, &a_ref(i__, i__ + 1), lda, &q__1, &a_ref(1,
i__), &c__1);
i__2 = *n - i__;
clacgv_(&i__2, &a_ref(i__, i__ + 1), lda);
} else {
csscal_(&i__, &aii, &a_ref(1, i__), &c__1);
}
/* L10: */
}
} else {
/* Compute the product L' * L. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = a_subscr(i__, i__);
aii = a[i__2].r;
if (i__ < *n) {
i__2 = a_subscr(i__, i__);
i__3 = *n - i__;
cdotc_(&q__1, &i__3, &a_ref(i__ + 1, i__), &c__1, &a_ref(i__
+ 1, i__), &c__1);
r__1 = aii * aii + q__1.r;
a[i__2].r = r__1, a[i__2].i = 0.f;
i__2 = i__ - 1;
clacgv_(&i__2, &a_ref(i__, 1), lda);
i__2 = *n - i__;
i__3 = i__ - 1;
q__1.r = aii, q__1.i = 0.f;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b1, &a_ref(i__
+ 1, 1), lda, &a_ref(i__ + 1, i__), &c__1, &q__1, &
a_ref(i__, 1), lda);
i__2 = i__ - 1;
clacgv_(&i__2, &a_ref(i__, 1), lda);
} else {
csscal_(&i__, &aii, &a_ref(i__, 1), lda);
}
/* L20: */
}
}
return 0;
/* End of CLAUU2 */
} /* clauu2_ */
/* Subroutine */ int ctrevc_(char *side, char *howmny, logical *select,
integer *n, complex *t, integer *ldt, complex *vl, integer *ldvl,
complex *vr, integer *ldvr, integer *mm, integer *m, complex *work,
real *rwork, integer *info)
{
/* 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;
real r__1, r__2, r__3;
complex q__1, q__2;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
integer i__, j, k, ii, ki, is;
real ulp;
logical allv;
real unfl, ovfl, smin;
logical over;
real scale;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *);
real remax;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
logical leftv, bothv, somev;
extern /* Subroutine */ int slabad_(real *, real *);
extern integer icamax_(integer *, complex *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), xerbla_(char *, integer *), clatrs_(char *, char *,
char *, char *, integer *, complex *, integer *, complex *, real *
, real *, integer *);
extern doublereal scasum_(integer *, complex *, integer *);
logical rightv;
real smlnum;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CTREVC computes some or all of the right and/or left eigenvectors of */
/* a complex upper triangular matrix T. */
/* Matrices of this type are produced by the Schur factorization of */
/* a complex general matrix: A = Q*T*Q**H, as computed by CHSEQR. */
/* The right eigenvector x and the left eigenvector y of T corresponding */
/* to an eigenvalue w are defined by: */
/* T*x = w*x, (y**H)*T = w*(y**H) */
/* where y**H denotes the conjugate transpose of the vector y. */
/* The eigenvalues are not input to this routine, but are read directly */
/* from the diagonal of T. */
/* This routine returns the matrices X and/or Y of right and left */
/* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an */
/* input matrix. If Q is the unitary factor that reduces a matrix A to */
/* Schur form T, then Q*X and Q*Y are the matrices of right and 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, */
/* backtransformed using the matrices supplied in */
/* VR and/or VL; */
/* = 'S': compute selected right and/or left eigenvectors, */
/* as indicated by the logical array SELECT. */
/* SELECT (input) LOGICAL array, dimension (N) */
/* If HOWMNY = 'S', SELECT specifies the eigenvectors to be */
/* computed. */
/* The eigenvector corresponding to the j-th eigenvalue is */
/* computed if SELECT(j) = .TRUE.. */
/* Not referenced if HOWMNY = 'A' or 'B'. */
/* N (input) INTEGER */
/* The order of the matrix T. N >= 0. */
/* T (input/output) COMPLEX 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 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 CHSEQR). */
/* On exit, if SIDE = 'L' or 'B', VL contains: */
/* if HOWMNY = 'A', the matrix Y of left eigenvectors of T; */
/* 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. */
/* Not referenced if SIDE = 'R'. */
/* LDVL (input) INTEGER */
/* The leading dimension of the array VL. LDVL >= 1, and if */
/* SIDE = 'L' or 'B', LDVL >= N. */
/* VR (input/output) COMPLEX 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 CHSEQR). */
/* On exit, if SIDE = 'R' or 'B', VR contains: */
/* if HOWMNY = 'A', the matrix X of right eigenvectors of T; */
/* 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. */
/* Not referenced if SIDE = 'L'. */
/* LDVR (input) INTEGER */
/* The leading dimension of the array VR. LDVR >= 1, and if */
/* SIDE = 'R' or 'B'; LDVR >= N. */
/* 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 array, dimension (2*N) */
/* RWORK (workspace) REAL 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|. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters */
/* Parameter adjustments */
--select;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
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_("CTREVC", &i__1);
return 0;
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
/* Set the constants to control overflow. */
unfl = slamch_("Safe minimum");
ovfl = 1.f / unfl;
slabad_(&unfl, &ovfl);
ulp = slamch_("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 = i__ + i__ * t_dim1;
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.f;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
i__2 = j - 1;
rwork[j] = scasum_(&i__2, &t[j * t_dim1 + 1], &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 = ki + ki * t_dim1;
r__3 = ulp * ((r__1 = t[i__1].r, dabs(r__1)) + (r__2 = r_imag(&t[
ki + ki * t_dim1]), dabs(r__2)));
smin = dmax(r__3,smlnum);
work[1].r = 1.f, work[1].i = 0.f;
/* Form right-hand side. */
i__1 = ki - 1;
for (k = 1; k <= i__1; ++k) {
i__2 = k;
i__3 = k + ki * t_dim1;
q__1.r = -t[i__3].r, q__1.i = -t[i__3].i;
work[i__2].r = q__1.r, work[i__2].i = q__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 = k + k * t_dim1;
i__3 = k + k * t_dim1;
i__4 = ki + ki * t_dim1;
q__1.r = t[i__3].r - t[i__4].r, q__1.i = t[i__3].i - t[i__4]
.i;
t[i__2].r = q__1.r, t[i__2].i = q__1.i;
i__2 = k + k * t_dim1;
if ((r__1 = t[i__2].r, dabs(r__1)) + (r__2 = r_imag(&t[k + k *
t_dim1]), dabs(r__2)) < smin) {
i__3 = k + k * t_dim1;
t[i__3].r = smin, t[i__3].i = 0.f;
}
/* L50: */
}
if (ki > 1) {
i__1 = ki - 1;
clatrs_("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.f;
}
/* Copy the vector x or Q*x to VR and normalize. */
if (! over) {
ccopy_(&ki, &work[1], &c__1, &vr[is * vr_dim1 + 1], &c__1);
ii = icamax_(&ki, &vr[is * vr_dim1 + 1], &c__1);
i__1 = ii + is * vr_dim1;
remax = 1.f / ((r__1 = vr[i__1].r, dabs(r__1)) + (r__2 =
r_imag(&vr[ii + is * vr_dim1]), dabs(r__2)));
csscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1);
i__1 = *n;
for (k = ki + 1; k <= i__1; ++k) {
i__2 = k + is * vr_dim1;
vr[i__2].r = 0.f, vr[i__2].i = 0.f;
/* L60: */
}
} else {
if (ki > 1) {
i__1 = ki - 1;
q__1.r = scale, q__1.i = 0.f;
cgemv_("N", n, &i__1, &c_b2, &vr[vr_offset], ldvr, &work[
1], &c__1, &q__1, &vr[ki * vr_dim1 + 1], &c__1);
}
ii = icamax_(n, &vr[ki * vr_dim1 + 1], &c__1);
i__1 = ii + ki * vr_dim1;
remax = 1.f / ((r__1 = vr[i__1].r, dabs(r__1)) + (r__2 =
r_imag(&vr[ii + ki * vr_dim1]), dabs(r__2)));
csscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1);
}
/* Set back the original diagonal elements of T. */
i__1 = ki - 1;
for (k = 1; k <= i__1; ++k) {
i__2 = k + k * t_dim1;
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 = ki + ki * t_dim1;
r__3 = ulp * ((r__1 = t[i__2].r, dabs(r__1)) + (r__2 = r_imag(&t[
ki + ki * t_dim1]), dabs(r__2)));
smin = dmax(r__3,smlnum);
i__2 = *n;
work[i__2].r = 1.f, work[i__2].i = 0.f;
/* Form right-hand side. */
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
i__3 = k;
r_cnjg(&q__2, &t[ki + k * t_dim1]);
q__1.r = -q__2.r, q__1.i = -q__2.i;
work[i__3].r = q__1.r, work[i__3].i = q__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 = k + k * t_dim1;
i__4 = k + k * t_dim1;
i__5 = ki + ki * t_dim1;
q__1.r = t[i__4].r - t[i__5].r, q__1.i = t[i__4].i - t[i__5]
.i;
t[i__3].r = q__1.r, t[i__3].i = q__1.i;
i__3 = k + k * t_dim1;
if ((r__1 = t[i__3].r, dabs(r__1)) + (r__2 = r_imag(&t[k + k *
t_dim1]), dabs(r__2)) < smin) {
i__4 = k + k * t_dim1;
t[i__4].r = smin, t[i__4].i = 0.f;
}
/* L100: */
}
if (ki < *n) {
i__2 = *n - ki;
clatrs_("Upper", "Conjugate transpose", "Non-unit", "Y", &
i__2, &t[ki + 1 + (ki + 1) * t_dim1], ldt, &work[ki +
1], &scale, &rwork[1], info);
i__2 = ki;
work[i__2].r = scale, work[i__2].i = 0.f;
}
/* Copy the vector x or Q*x to VL and normalize. */
if (! over) {
i__2 = *n - ki + 1;
ccopy_(&i__2, &work[ki], &c__1, &vl[ki + is * vl_dim1], &c__1)
;
i__2 = *n - ki + 1;
ii = icamax_(&i__2, &vl[ki + is * vl_dim1], &c__1) + ki - 1;
i__2 = ii + is * vl_dim1;
remax = 1.f / ((r__1 = vl[i__2].r, dabs(r__1)) + (r__2 =
r_imag(&vl[ii + is * vl_dim1]), dabs(r__2)));
i__2 = *n - ki + 1;
csscal_(&i__2, &remax, &vl[ki + is * vl_dim1], &c__1);
i__2 = ki - 1;
for (k = 1; k <= i__2; ++k) {
i__3 = k + is * vl_dim1;
vl[i__3].r = 0.f, vl[i__3].i = 0.f;
/* L110: */
}
} else {
if (ki < *n) {
i__2 = *n - ki;
q__1.r = scale, q__1.i = 0.f;
cgemv_("N", n, &i__2, &c_b2, &vl[(ki + 1) * vl_dim1 + 1],
ldvl, &work[ki + 1], &c__1, &q__1, &vl[ki *
vl_dim1 + 1], &c__1);
}
ii = icamax_(n, &vl[ki * vl_dim1 + 1], &c__1);
i__2 = ii + ki * vl_dim1;
remax = 1.f / ((r__1 = vl[i__2].r, dabs(r__1)) + (r__2 =
r_imag(&vl[ii + ki * vl_dim1]), dabs(r__2)));
csscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1);
}
/* Set back the original diagonal elements of T. */
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
i__3 = k + k * t_dim1;
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 CTREVC */
} /* ctrevc_ */
/** CHETRF_ROOK_REC2 computes a partial factorization of a complex Hermitian indefinite matrix using the boun ded Bunch-Kaufman ("rook") diagonal pivoting method
*
* This routine is a minor modification of LAPACK's clahef_rook.
* It serves as an unblocked kernel in the recursive algorithms.
* The blocked BLAS Level 3 updates were removed and moved to the
* recursive algorithm.
* */
/* Subroutine */ void RELAPACK_chetrf_rook_rec2(char *uplo, int *n,
int *nb, int *kb, complex *a, int *lda, int *ipiv,
complex *w, int *ldw, int *info, ftnlen uplo_len)
{
/* System generated locals */
int a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4;
float r__1, r__2;
complex q__1, q__2, q__3, q__4, q__5;
/* Builtin functions */
double sqrt(double), r_imag(complex *);
void r_cnjg(complex *, complex *), c_div(complex *, complex *, complex *);
/* Local variables */
static int j, k, p;
static float t, r1;
static complex d11, d21, d22;
static int ii, jj, kk, kp, kw, jp1, jp2, kkw;
static logical done;
static int imax, jmax;
static float alpha;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int cgemv_(char *, int *, int *, complex *
, complex *, int *, complex *, int *, complex *, complex *
, int *, ftnlen);
static float sfmin;
extern /* Subroutine */ int ccopy_(int *, complex *, int *,
complex *, int *);
static int itemp;
extern /* Subroutine */ int cswap_(int *, complex *, int *,
complex *, int *);
static int kstep;
static float stemp, absakk;
extern /* Subroutine */ int clacgv_(int *, complex *, int *);
extern int icamax_(int *, complex *, int *);
extern double slamch_(char *, ftnlen);
extern /* Subroutine */ int csscal_(int *, float *, complex *, int
*);
static float colmax, rowmax;
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
w_dim1 = *ldw;
w_offset = 1 + w_dim1;
w -= w_offset;
/* Function Body */
*info = 0;
alpha = (sqrt(17.f) + 1.f) / 8.f;
sfmin = slamch_("S", (ftnlen)1);
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
k = *n;
L10:
kw = *nb + k - *n;
if ((k <= *n - *nb + 1 && *nb < *n) || k < 1) {
goto L30;
}
kstep = 1;
p = k;
if (k > 1) {
i__1 = k - 1;
ccopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &
c__1);
}
i__1 = k + kw * w_dim1;
i__2 = k + k * a_dim1;
r__1 = a[i__2].r;
w[i__1].r = r__1, w[i__1].i = 0.f;
if (k < *n) {
i__1 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &k, &i__1, &q__1, &a[(k + 1) * a_dim1 + 1],
lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw *
w_dim1 + 1], &c__1, (ftnlen)12);
i__1 = k + kw * w_dim1;
i__2 = k + kw * w_dim1;
r__1 = w[i__2].r;
w[i__1].r = r__1, w[i__1].i = 0.f;
}
i__1 = k + kw * w_dim1;
absakk = (r__1 = w[i__1].r, dabs(r__1));
if (k > 1) {
i__1 = k - 1;
imax = icamax_(&i__1, &w[kw * w_dim1 + 1], &c__1);
i__1 = imax + kw * w_dim1;
colmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[imax
+ kw * w_dim1]), dabs(r__2));
} else {
colmax = 0.f;
}
if (dmax(absakk,colmax) == 0.f) {
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = k + k * a_dim1;
i__2 = k + kw * w_dim1;
r__1 = w[i__2].r;
a[i__1].r = r__1, a[i__1].i = 0.f;
if (k > 1) {
i__1 = k - 1;
ccopy_(&i__1, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1],
&c__1);
}
} else {
if (! (absakk < alpha * colmax)) {
kp = k;
} else {
done = FALSE_;
L12:
if (imax > 1) {
i__1 = imax - 1;
ccopy_(&i__1, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) *
w_dim1 + 1], &c__1);
}
i__1 = imax + (kw - 1) * w_dim1;
i__2 = imax + imax * a_dim1;
r__1 = a[i__2].r;
w[i__1].r = r__1, w[i__1].i = 0.f;
i__1 = k - imax;
ccopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax +
1 + (kw - 1) * w_dim1], &c__1);
i__1 = k - imax;
clacgv_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], &c__1);
if (k < *n) {
i__1 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &k, &i__1, &q__1, &a[(k + 1) *
a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1],
ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1], &c__1, (
ftnlen)12);
i__1 = imax + (kw - 1) * w_dim1;
i__2 = imax + (kw - 1) * w_dim1;
r__1 = w[i__2].r;
w[i__1].r = r__1, w[i__1].i = 0.f;
}
if (imax != k) {
i__1 = k - imax;
jmax = imax + icamax_(&i__1, &w[imax + 1 + (kw - 1) *
w_dim1], &c__1);
i__1 = jmax + (kw - 1) * w_dim1;
rowmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
w[jmax + (kw - 1) * w_dim1]), dabs(r__2));
} else {
rowmax = 0.f;
}
if (imax > 1) {
i__1 = imax - 1;
itemp = icamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1);
i__1 = itemp + (kw - 1) * w_dim1;
stemp = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
w[itemp + (kw - 1) * w_dim1]), dabs(r__2));
if (stemp > rowmax) {
rowmax = stemp;
jmax = itemp;
}
}
i__1 = imax + (kw - 1) * w_dim1;
if (! ((r__1 = w[i__1].r, dabs(r__1)) < alpha * rowmax)) {
kp = imax;
ccopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw *
w_dim1 + 1], &c__1);
done = TRUE_;
} else if (p == jmax || rowmax <= colmax) {
kp = imax;
kstep = 2;
done = TRUE_;
} else {
p = imax;
colmax = rowmax;
imax = jmax;
ccopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw *
w_dim1 + 1], &c__1);
}
if (! done) {
goto L12;
}
}
kk = k - kstep + 1;
kkw = *nb + kk - *n;
if (kstep == 2 && p != k) {
i__1 = p + p * a_dim1;
i__2 = k + k * a_dim1;
r__1 = a[i__2].r;
a[i__1].r = r__1, a[i__1].i = 0.f;
i__1 = k - 1 - p;
ccopy_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + (p + 1) *
a_dim1], lda);
i__1 = k - 1 - p;
clacgv_(&i__1, &a[p + (p + 1) * a_dim1], lda);
if (p > 1) {
i__1 = p - 1;
ccopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[p * a_dim1 +
1], &c__1);
}
if (k < *n) {
i__1 = *n - k;
cswap_(&i__1, &a[k + (k + 1) * a_dim1], lda, &a[p + (k +
1) * a_dim1], lda);
}
i__1 = *n - kk + 1;
cswap_(&i__1, &w[k + kkw * w_dim1], ldw, &w[p + kkw * w_dim1],
ldw);
}
if (kp != kk) {
i__1 = kp + kp * a_dim1;
i__2 = kk + kk * a_dim1;
r__1 = a[i__2].r;
a[i__1].r = r__1, a[i__1].i = 0.f;
i__1 = kk - 1 - kp;
ccopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp +
1) * a_dim1], lda);
i__1 = kk - 1 - kp;
clacgv_(&i__1, &a[kp + (kp + 1) * a_dim1], lda);
if (kp > 1) {
i__1 = kp - 1;
ccopy_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1
+ 1], &c__1);
}
if (k < *n) {
i__1 = *n - k;
cswap_(&i__1, &a[kk + (k + 1) * a_dim1], lda, &a[kp + (k
+ 1) * a_dim1], lda);
}
i__1 = *n - kk + 1;
cswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw *
w_dim1], ldw);
}
if (kstep == 1) {
ccopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &
c__1);
if (k > 1) {
i__1 = k + k * a_dim1;
t = a[i__1].r;
if (dabs(t) >= sfmin) {
r1 = 1.f / t;
i__1 = k - 1;
csscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1);
} else {
i__1 = k - 1;
for (ii = 1; ii <= i__1; ++ii) {
i__2 = ii + k * a_dim1;
i__3 = ii + k * a_dim1;
q__1.r = a[i__3].r / t, q__1.i = a[i__3].i / t;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
/* L14: */
}
}
i__1 = k - 1;
clacgv_(&i__1, &w[kw * w_dim1 + 1], &c__1);
}
} else {
if (k > 2) {
i__1 = k - 1 + kw * w_dim1;
d21.r = w[i__1].r, d21.i = w[i__1].i;
r_cnjg(&q__2, &d21);
c_div(&q__1, &w[k + kw * w_dim1], &q__2);
d11.r = q__1.r, d11.i = q__1.i;
c_div(&q__1, &w[k - 1 + (kw - 1) * w_dim1], &d21);
d22.r = q__1.r, d22.i = q__1.i;
q__1.r = d11.r * d22.r - d11.i * d22.i, q__1.i = d11.r *
d22.i + d11.i * d22.r;
t = 1.f / (q__1.r - 1.f);
i__1 = k - 2;
for (j = 1; j <= i__1; ++j) {
i__2 = j + (k - 1) * a_dim1;
i__3 = j + (kw - 1) * w_dim1;
q__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i,
q__4.i = d11.r * w[i__3].i + d11.i * w[i__3]
.r;
i__4 = j + kw * w_dim1;
q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4]
.i;
c_div(&q__2, &q__3, &d21);
q__1.r = t * q__2.r, q__1.i = t * q__2.i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
i__2 = j + k * a_dim1;
i__3 = j + kw * w_dim1;
q__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i,
q__4.i = d22.r * w[i__3].i + d22.i * w[i__3]
.r;
i__4 = j + (kw - 1) * w_dim1;
q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4]
.i;
r_cnjg(&q__5, &d21);
c_div(&q__2, &q__3, &q__5);
q__1.r = t * q__2.r, q__1.i = t * q__2.i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
/* L20: */
}
}
i__1 = k - 1 + (k - 1) * a_dim1;
i__2 = k - 1 + (kw - 1) * w_dim1;
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = k - 1 + k * a_dim1;
i__2 = k - 1 + kw * w_dim1;
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = k + k * a_dim1;
i__2 = k + kw * w_dim1;
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = k - 1;
clacgv_(&i__1, &w[kw * w_dim1 + 1], &c__1);
i__1 = k - 2;
clacgv_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1);
}
}
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -p;
ipiv[k - 1] = -kp;
}
k -= kstep;
goto L10;
L30:
j = k + 1;
L60:
kstep = 1;
jp1 = 1;
jj = j;
jp2 = ipiv[j];
if (jp2 < 0) {
jp2 = -jp2;
++j;
jp1 = -ipiv[j];
kstep = 2;
}
++j;
if (jp2 != jj && j <= *n) {
i__1 = *n - j + 1;
cswap_(&i__1, &a[jp2 + j * a_dim1], lda, &a[jj + j * a_dim1], lda)
;
}
++jj;
if (kstep == 2 && jp1 != jj && j <= *n) {
i__1 = *n - j + 1;
cswap_(&i__1, &a[jp1 + j * a_dim1], lda, &a[jj + j * a_dim1], lda)
;
}
if (j < *n) {
goto L60;
}
*kb = *n - k;
} else {
k = 1;
L70:
if ((k >= *nb && *nb < *n) || k > *n) {
goto L90;
}
kstep = 1;
p = k;
i__1 = k + k * w_dim1;
i__2 = k + k * a_dim1;
r__1 = a[i__2].r;
w[i__1].r = r__1, w[i__1].i = 0.f;
if (k < *n) {
i__1 = *n - k;
ccopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &w[k + 1 + k *
w_dim1], &c__1);
}
if (k > 1) {
i__1 = *n - k + 1;
i__2 = k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__1, &i__2, &q__1, &a[k + a_dim1], lda, &
w[k + w_dim1], ldw, &c_b1, &w[k + k * w_dim1], &c__1, (
ftnlen)12);
i__1 = k + k * w_dim1;
i__2 = k + k * w_dim1;
r__1 = w[i__2].r;
w[i__1].r = r__1, w[i__1].i = 0.f;
}
i__1 = k + k * w_dim1;
absakk = (r__1 = w[i__1].r, dabs(r__1));
if (k < *n) {
i__1 = *n - k;
imax = k + icamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1);
i__1 = imax + k * w_dim1;
colmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[imax
+ k * w_dim1]), dabs(r__2));
} else {
colmax = 0.f;
}
if (dmax(absakk,colmax) == 0.f) {
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = k + k * a_dim1;
i__2 = k + k * w_dim1;
r__1 = w[i__2].r;
a[i__1].r = r__1, a[i__1].i = 0.f;
if (k < *n) {
i__1 = *n - k;
ccopy_(&i__1, &w[k + 1 + k * w_dim1], &c__1, &a[k + 1 + k *
a_dim1], &c__1);
}
} else {
if (! (absakk < alpha * colmax)) {
kp = k;
} else {
done = FALSE_;
L72:
i__1 = imax - k;
ccopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) *
w_dim1], &c__1);
i__1 = imax - k;
clacgv_(&i__1, &w[k + (k + 1) * w_dim1], &c__1);
i__1 = imax + (k + 1) * w_dim1;
i__2 = imax + imax * a_dim1;
r__1 = a[i__2].r;
w[i__1].r = r__1, w[i__1].i = 0.f;
if (imax < *n) {
i__1 = *n - imax;
ccopy_(&i__1, &a[imax + 1 + imax * a_dim1], &c__1, &w[
imax + 1 + (k + 1) * w_dim1], &c__1);
}
if (k > 1) {
i__1 = *n - k + 1;
i__2 = k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__1, &i__2, &q__1, &a[k + a_dim1]
, lda, &w[imax + w_dim1], ldw, &c_b1, &w[k + (k +
1) * w_dim1], &c__1, (ftnlen)12);
i__1 = imax + (k + 1) * w_dim1;
i__2 = imax + (k + 1) * w_dim1;
r__1 = w[i__2].r;
w[i__1].r = r__1, w[i__1].i = 0.f;
}
if (imax != k) {
i__1 = imax - k;
jmax = k - 1 + icamax_(&i__1, &w[k + (k + 1) * w_dim1], &
c__1);
i__1 = jmax + (k + 1) * w_dim1;
rowmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
w[jmax + (k + 1) * w_dim1]), dabs(r__2));
} else {
rowmax = 0.f;
}
if (imax < *n) {
i__1 = *n - imax;
itemp = imax + icamax_(&i__1, &w[imax + 1 + (k + 1) *
w_dim1], &c__1);
i__1 = itemp + (k + 1) * w_dim1;
stemp = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
w[itemp + (k + 1) * w_dim1]), dabs(r__2));
if (stemp > rowmax) {
rowmax = stemp;
jmax = itemp;
}
}
i__1 = imax + (k + 1) * w_dim1;
if (! ((r__1 = w[i__1].r, dabs(r__1)) < alpha * rowmax)) {
kp = imax;
i__1 = *n - k + 1;
ccopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k *
w_dim1], &c__1);
done = TRUE_;
} else if (p == jmax || rowmax <= colmax) {
kp = imax;
kstep = 2;
done = TRUE_;
} else {
p = imax;
colmax = rowmax;
imax = jmax;
i__1 = *n - k + 1;
ccopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k *
w_dim1], &c__1);
}
if (! done) {
goto L72;
}
}
kk = k + kstep - 1;
if (kstep == 2 && p != k) {
i__1 = p + p * a_dim1;
i__2 = k + k * a_dim1;
r__1 = a[i__2].r;
a[i__1].r = r__1, a[i__1].i = 0.f;
i__1 = p - k - 1;
ccopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[p + (k + 1) *
a_dim1], lda);
i__1 = p - k - 1;
clacgv_(&i__1, &a[p + (k + 1) * a_dim1], lda);
if (p < *n) {
i__1 = *n - p;
ccopy_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + 1 + p
* a_dim1], &c__1);
}
if (k > 1) {
i__1 = k - 1;
cswap_(&i__1, &a[k + a_dim1], lda, &a[p + a_dim1], lda);
}
cswap_(&kk, &w[k + w_dim1], ldw, &w[p + w_dim1], ldw);
}
if (kp != kk) {
i__1 = kp + kp * a_dim1;
i__2 = kk + kk * a_dim1;
r__1 = a[i__2].r;
a[i__1].r = r__1, a[i__1].i = 0.f;
i__1 = kp - kk - 1;
ccopy_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk +
1) * a_dim1], lda);
i__1 = kp - kk - 1;
clacgv_(&i__1, &a[kp + (kk + 1) * a_dim1], lda);
if (kp < *n) {
i__1 = *n - kp;
ccopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1
+ kp * a_dim1], &c__1);
}
if (k > 1) {
i__1 = k - 1;
cswap_(&i__1, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda);
}
cswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw);
}
if (kstep == 1) {
i__1 = *n - k + 1;
ccopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], &
c__1);
if (k < *n) {
i__1 = k + k * a_dim1;
t = a[i__1].r;
if (dabs(t) >= sfmin) {
r1 = 1.f / t;
i__1 = *n - k;
csscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1);
} else {
i__1 = *n;
for (ii = k + 1; ii <= i__1; ++ii) {
i__2 = ii + k * a_dim1;
i__3 = ii + k * a_dim1;
q__1.r = a[i__3].r / t, q__1.i = a[i__3].i / t;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
/* L74: */
}
}
i__1 = *n - k;
clacgv_(&i__1, &w[k + 1 + k * w_dim1], &c__1);
}
} else {
if (k < *n - 1) {
i__1 = k + 1 + k * w_dim1;
d21.r = w[i__1].r, d21.i = w[i__1].i;
c_div(&q__1, &w[k + 1 + (k + 1) * w_dim1], &d21);
d11.r = q__1.r, d11.i = q__1.i;
r_cnjg(&q__2, &d21);
c_div(&q__1, &w[k + k * w_dim1], &q__2);
d22.r = q__1.r, d22.i = q__1.i;
q__1.r = d11.r * d22.r - d11.i * d22.i, q__1.i = d11.r *
d22.i + d11.i * d22.r;
t = 1.f / (q__1.r - 1.f);
i__1 = *n;
for (j = k + 2; j <= i__1; ++j) {
i__2 = j + k * a_dim1;
i__3 = j + k * w_dim1;
q__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i,
q__4.i = d11.r * w[i__3].i + d11.i * w[i__3]
.r;
i__4 = j + (k + 1) * w_dim1;
q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4]
.i;
r_cnjg(&q__5, &d21);
c_div(&q__2, &q__3, &q__5);
q__1.r = t * q__2.r, q__1.i = t * q__2.i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
i__2 = j + (k + 1) * a_dim1;
i__3 = j + (k + 1) * w_dim1;
q__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i,
q__4.i = d22.r * w[i__3].i + d22.i * w[i__3]
.r;
i__4 = j + k * w_dim1;
q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4]
.i;
c_div(&q__2, &q__3, &d21);
q__1.r = t * q__2.r, q__1.i = t * q__2.i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
/* L80: */
}
}
i__1 = k + k * a_dim1;
i__2 = k + k * w_dim1;
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = k + 1 + k * a_dim1;
i__2 = k + 1 + k * w_dim1;
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = k + 1 + (k + 1) * a_dim1;
i__2 = k + 1 + (k + 1) * w_dim1;
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = *n - k;
clacgv_(&i__1, &w[k + 1 + k * w_dim1], &c__1);
i__1 = *n - k - 1;
clacgv_(&i__1, &w[k + 2 + (k + 1) * w_dim1], &c__1);
}
}
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -p;
ipiv[k + 1] = -kp;
}
k += kstep;
goto L70;
L90:
j = k - 1;
L120:
kstep = 1;
jp1 = 1;
jj = j;
jp2 = ipiv[j];
if (jp2 < 0) {
jp2 = -jp2;
--j;
jp1 = -ipiv[j];
kstep = 2;
}
--j;
if (jp2 != jj && j >= 1) {
cswap_(&j, &a[jp2 + a_dim1], lda, &a[jj + a_dim1], lda);
}
--jj;
if (kstep == 2 && jp1 != jj && j >= 1) {
cswap_(&j, &a[jp1 + a_dim1], lda, &a[jj + a_dim1], lda);
}
if (j > 1) {
goto L120;
}
*kb = k - 1;
}
return;
}
/* Subroutine */ int chpgst_(integer *itype, char *uplo, integer *n, complex *
ap, complex *bp, integer *info, ftnlen uplo_len)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
real r__1, r__2;
complex q__1, q__2, q__3;
/* Local variables */
static integer j, k, j1, k1, jj, kk;
static complex ct;
static real ajj;
static integer j1j1;
static real akk;
static integer k1k1;
static real bjj, bkk;
extern /* Subroutine */ int chpr2_(char *, integer *, complex *, complex *
, integer *, complex *, integer *, complex *, ftnlen);
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int chpmv_(char *, integer *, complex *, complex *
, complex *, integer *, complex *, complex *, integer *, ftnlen),
caxpy_(integer *, complex *, complex *, integer *, complex *,
integer *), ctpmv_(char *, char *, char *, integer *, complex *,
complex *, integer *, ftnlen, ftnlen, ftnlen);
static logical upper;
extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *,
complex *, complex *, integer *, ftnlen, ftnlen, ftnlen), csscal_(
integer *, real *, complex *, integer *), 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 */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHPGST reduces a complex Hermitian-definite generalized */
/* eigenproblem to standard form, using packed storage. */
/* If ITYPE = 1, the problem is A*x = lambda*B*x, */
/* and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H) */
/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
/* B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L. */
/* B must have been previously factorized as U**H*U or L*L**H by CPPTRF. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H); */
/* = 2 or 3: compute U*A*U**H or L**H*A*L. */
/* UPLO (input) CHARACTER */
/* = 'U': Upper triangle of A is stored and B is factored as */
/* U**H*U; */
/* = 'L': Lower triangle of A is stored and B is factored as */
/* L*L**H. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the Hermitian matrix */
/* A, packed columnwise in a linear array. The j-th column of A */
/* is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/* On exit, if INFO = 0, the transformed matrix, stored in the */
/* same format as A. */
/* BP (input) COMPLEX array, dimension (N*(N+1)/2) */
/* The triangular factor from the Cholesky factorization of B, */
/* stored in the same format as A, as returned by CPPTRF. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--bp;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
*info = -2;
} else if (*n < 0) {
*info = -3;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHPGST", &i__1, (ftnlen)6);
return 0;
}
if (*itype == 1) {
if (upper) {
/* Compute inv(U')*A*inv(U) */
/* J1 and JJ are the indices of A(1,j) and A(j,j) */
jj = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
j1 = jj + 1;
jj += j;
/* Compute the j-th column of the upper triangle of A */
i__2 = jj;
i__3 = jj;
r__1 = ap[i__3].r;
ap[i__2].r = r__1, ap[i__2].i = 0.f;
i__2 = jj;
bjj = bp[i__2].r;
ctpsv_(uplo, "Conjugate transpose", "Non-unit", &j, &bp[1], &
ap[j1], &c__1, (ftnlen)1, (ftnlen)19, (ftnlen)8);
i__2 = j - 1;
q__1.r = -1.f, q__1.i = -0.f;
chpmv_(uplo, &i__2, &q__1, &ap[1], &bp[j1], &c__1, &c_b1, &ap[
j1], &c__1, (ftnlen)1);
i__2 = j - 1;
r__1 = 1.f / bjj;
csscal_(&i__2, &r__1, &ap[j1], &c__1);
i__2 = jj;
i__3 = jj;
i__4 = j - 1;
cdotc_(&q__3, &i__4, &ap[j1], &c__1, &bp[j1], &c__1);
q__2.r = ap[i__3].r - q__3.r, q__2.i = ap[i__3].i - q__3.i;
q__1.r = q__2.r / bjj, q__1.i = q__2.i / bjj;
ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
/* L10: */
}
} else {
/* Compute inv(L)*A*inv(L') */
/* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) */
kk = 1;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
k1k1 = kk + *n - k + 1;
/* Update the lower triangle of A(k:n,k:n) */
i__2 = kk;
akk = ap[i__2].r;
i__2 = kk;
bkk = bp[i__2].r;
/* Computing 2nd power */
r__1 = bkk;
akk /= r__1 * r__1;
i__2 = kk;
ap[i__2].r = akk, ap[i__2].i = 0.f;
if (k < *n) {
i__2 = *n - k;
r__1 = 1.f / bkk;
csscal_(&i__2, &r__1, &ap[kk + 1], &c__1);
r__1 = akk * -.5f;
ct.r = r__1, ct.i = 0.f;
i__2 = *n - k;
caxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
;
i__2 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
chpr2_(uplo, &i__2, &q__1, &ap[kk + 1], &c__1, &bp[kk + 1]
, &c__1, &ap[k1k1], (ftnlen)1);
i__2 = *n - k;
caxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
;
i__2 = *n - k;
ctpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1],
&ap[kk + 1], &c__1, (ftnlen)1, (ftnlen)12, (
ftnlen)8);
}
kk = k1k1;
/* L20: */
}
}
} else {
if (upper) {
/* Compute U*A*U' */
/* K1 and KK are the indices of A(1,k) and A(k,k) */
kk = 0;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
k1 = kk + 1;
kk += k;
/* Update the upper triangle of A(1:k,1:k) */
i__2 = kk;
akk = ap[i__2].r;
i__2 = kk;
bkk = bp[i__2].r;
i__2 = k - 1;
ctpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[
k1], &c__1, (ftnlen)1, (ftnlen)12, (ftnlen)8);
r__1 = akk * .5f;
ct.r = r__1, ct.i = 0.f;
i__2 = k - 1;
caxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
chpr2_(uplo, &i__2, &c_b1, &ap[k1], &c__1, &bp[k1], &c__1, &
ap[1], (ftnlen)1);
i__2 = k - 1;
caxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
csscal_(&i__2, &bkk, &ap[k1], &c__1);
i__2 = kk;
/* Computing 2nd power */
r__2 = bkk;
r__1 = akk * (r__2 * r__2);
ap[i__2].r = r__1, ap[i__2].i = 0.f;
/* L30: */
}
} else {
/* Compute L'*A*L */
/* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) */
jj = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
j1j1 = jj + *n - j + 1;
/* Compute the j-th column of the lower triangle of A */
i__2 = jj;
ajj = ap[i__2].r;
i__2 = jj;
bjj = bp[i__2].r;
i__2 = jj;
r__1 = ajj * bjj;
i__3 = *n - j;
cdotc_(&q__2, &i__3, &ap[jj + 1], &c__1, &bp[jj + 1], &c__1);
q__1.r = r__1 + q__2.r, q__1.i = q__2.i;
ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
i__2 = *n - j;
csscal_(&i__2, &bjj, &ap[jj + 1], &c__1);
i__2 = *n - j;
chpmv_(uplo, &i__2, &c_b1, &ap[j1j1], &bp[jj + 1], &c__1, &
c_b1, &ap[jj + 1], &c__1, (ftnlen)1);
i__2 = *n - j + 1;
ctpmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &bp[jj]
, &ap[jj], &c__1, (ftnlen)1, (ftnlen)19, (ftnlen)8);
jj = j1j1;
/* L40: */
}
}
}
return 0;
/* End of CHPGST */
} /* chpgst_ */
int chegs2_(int *itype, char *uplo, int *n, complex *
a, int *lda, complex *b, int *ldb, int *info)
{
/* System generated locals */
int a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
float r__1, r__2;
complex q__1;
/* Local variables */
int k;
complex ct;
float akk, bkk;
extern int cher2_(char *, int *, complex *, complex *
, int *, complex *, int *, complex *, int *);
extern int lsame_(char *, char *);
extern int caxpy_(int *, complex *, complex *,
int *, complex *, int *);
int upper;
extern int ctrmv_(char *, char *, char *, int *,
complex *, int *, complex *, int *), ctrsv_(char *, char *, char *, int *, complex *,
int *, complex *, int *), clacgv_(
int *, complex *, int *), csscal_(int *, float *,
complex *, int *), xerbla_(char *, int *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHEGS2 reduces a complex Hermitian-definite generalized */
/* eigenproblem to standard form. */
/* If ITYPE = 1, the problem is A*x = lambda*B*x, */
/* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L') */
/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
/* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L. */
/* B must have been previously factorized as U'*U or L*L' by CPOTRF. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L'); */
/* = 2 or 3: compute U*A*U' or L'*A*L. */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored, and how B has been factorized. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, 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. */
/* On exit, if INFO = 0, the transformed matrix, stored in the */
/* same format as A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* B (input) COMPLEX array, dimension (LDB,N) */
/* The triangular factor from the Cholesky factorization of B, */
/* as returned by CPOTRF. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= MAX(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < MAX(1,*n)) {
*info = -5;
} else if (*ldb < MAX(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHEGS2", &i__1);
return 0;
}
if (*itype == 1) {
if (upper) {
/* Compute inv(U')*A*inv(U) */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the upper triangle of A(k:n,k:n) */
i__2 = k + k * a_dim1;
akk = a[i__2].r;
i__2 = k + k * b_dim1;
bkk = b[i__2].r;
/* Computing 2nd power */
r__1 = bkk;
akk /= r__1 * r__1;
i__2 = k + k * a_dim1;
a[i__2].r = akk, a[i__2].i = 0.f;
if (k < *n) {
i__2 = *n - k;
r__1 = 1.f / bkk;
csscal_(&i__2, &r__1, &a[k + (k + 1) * a_dim1], lda);
r__1 = akk * -.5f;
ct.r = r__1, ct.i = 0.f;
i__2 = *n - k;
clacgv_(&i__2, &a[k + (k + 1) * a_dim1], lda);
i__2 = *n - k;
clacgv_(&i__2, &b[k + (k + 1) * b_dim1], ldb);
i__2 = *n - k;
caxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (
k + 1) * a_dim1], lda);
i__2 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cher2_(uplo, &i__2, &q__1, &a[k + (k + 1) * a_dim1], lda,
&b[k + (k + 1) * b_dim1], ldb, &a[k + 1 + (k + 1)
* a_dim1], lda);
i__2 = *n - k;
caxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (
k + 1) * a_dim1], lda);
i__2 = *n - k;
clacgv_(&i__2, &b[k + (k + 1) * b_dim1], ldb);
i__2 = *n - k;
ctrsv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &b[
k + 1 + (k + 1) * b_dim1], ldb, &a[k + (k + 1) *
a_dim1], lda);
i__2 = *n - k;
clacgv_(&i__2, &a[k + (k + 1) * a_dim1], lda);
}
/* L10: */
}
} else {
/* Compute inv(L)*A*inv(L') */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the lower triangle of A(k:n,k:n) */
i__2 = k + k * a_dim1;
akk = a[i__2].r;
i__2 = k + k * b_dim1;
bkk = b[i__2].r;
/* Computing 2nd power */
r__1 = bkk;
akk /= r__1 * r__1;
i__2 = k + k * a_dim1;
a[i__2].r = akk, a[i__2].i = 0.f;
if (k < *n) {
i__2 = *n - k;
r__1 = 1.f / bkk;
csscal_(&i__2, &r__1, &a[k + 1 + k * a_dim1], &c__1);
r__1 = akk * -.5f;
ct.r = r__1, ct.i = 0.f;
i__2 = *n - k;
caxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k +
1 + k * a_dim1], &c__1);
i__2 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cher2_(uplo, &i__2, &q__1, &a[k + 1 + k * a_dim1], &c__1,
&b[k + 1 + k * b_dim1], &c__1, &a[k + 1 + (k + 1)
* a_dim1], lda);
i__2 = *n - k;
caxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k +
1 + k * a_dim1], &c__1);
i__2 = *n - k;
ctrsv_(uplo, "No transpose", "Non-unit", &i__2, &b[k + 1
+ (k + 1) * b_dim1], ldb, &a[k + 1 + k * a_dim1],
&c__1);
}
/* L20: */
}
}
} else {
if (upper) {
/* Compute U*A*U' */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the upper triangle of A(1:k,1:k) */
i__2 = k + k * a_dim1;
akk = a[i__2].r;
i__2 = k + k * b_dim1;
bkk = b[i__2].r;
i__2 = k - 1;
ctrmv_(uplo, "No transpose", "Non-unit", &i__2, &b[b_offset],
ldb, &a[k * a_dim1 + 1], &c__1);
r__1 = akk * .5f;
ct.r = r__1, ct.i = 0.f;
i__2 = k - 1;
caxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 +
1], &c__1);
i__2 = k - 1;
cher2_(uplo, &i__2, &c_b1, &a[k * a_dim1 + 1], &c__1, &b[k *
b_dim1 + 1], &c__1, &a[a_offset], lda);
i__2 = k - 1;
caxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 +
1], &c__1);
i__2 = k - 1;
csscal_(&i__2, &bkk, &a[k * a_dim1 + 1], &c__1);
i__2 = k + k * a_dim1;
/* Computing 2nd power */
r__2 = bkk;
r__1 = akk * (r__2 * r__2);
a[i__2].r = r__1, a[i__2].i = 0.f;
/* L30: */
}
} else {
/* Compute L'*A*L */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the lower triangle of A(1:k,1:k) */
i__2 = k + k * a_dim1;
akk = a[i__2].r;
i__2 = k + k * b_dim1;
bkk = b[i__2].r;
i__2 = k - 1;
clacgv_(&i__2, &a[k + a_dim1], lda);
i__2 = k - 1;
ctrmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &b[
b_offset], ldb, &a[k + a_dim1], lda);
r__1 = akk * .5f;
ct.r = r__1, ct.i = 0.f;
i__2 = k - 1;
clacgv_(&i__2, &b[k + b_dim1], ldb);
i__2 = k - 1;
caxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
i__2 = k - 1;
cher2_(uplo, &i__2, &c_b1, &a[k + a_dim1], lda, &b[k + b_dim1]
, ldb, &a[a_offset], lda);
i__2 = k - 1;
caxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
i__2 = k - 1;
clacgv_(&i__2, &b[k + b_dim1], ldb);
i__2 = k - 1;
csscal_(&i__2, &bkk, &a[k + a_dim1], lda);
i__2 = k - 1;
clacgv_(&i__2, &a[k + a_dim1], lda);
i__2 = k + k * a_dim1;
/* Computing 2nd power */
r__2 = bkk;
r__1 = akk * (r__2 * r__2);
a[i__2].r = r__1, a[i__2].i = 0.f;
/* L40: */
}
}
}
return 0;
/* End of CHEGS2 */
} /* chegs2_ */
/* Subroutine */
int cgebak_(char *job, char *side, integer *n, integer *ilo, integer *ihi, real *scale, integer *m, complex *v, integer *ldv, integer *info)
{
/* System generated locals */
integer v_dim1, v_offset, i__1;
/* Local variables */
integer i__, k;
real s;
integer ii;
extern logical lsame_(char *, char *);
extern /* Subroutine */
int cswap_(integer *, complex *, integer *, complex *, integer *);
logical leftv;
extern /* Subroutine */
int csscal_(integer *, real *, complex *, integer *), xerbla_(char *, integer *);
logical rightv;
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and Test the input parameters */
/* Parameter adjustments */
--scale;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
/* Function Body */
rightv = lsame_(side, "R");
leftv = lsame_(side, "L");
*info = 0;
if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S") && ! lsame_(job, "B"))
{
*info = -1;
}
else if (! rightv && ! leftv)
{
*info = -2;
}
else if (*n < 0)
{
*info = -3;
}
else if (*ilo < 1 || *ilo > max(1,*n))
{
*info = -4;
}
else if (*ihi < min(*ilo,*n) || *ihi > *n)
{
*info = -5;
}
else if (*m < 0)
{
*info = -7;
}
else if (*ldv < max(1,*n))
{
*info = -9;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CGEBAK", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
if (*m == 0)
{
return 0;
}
if (lsame_(job, "N"))
{
return 0;
}
if (*ilo == *ihi)
{
goto L30;
}
/* Backward balance */
if (lsame_(job, "S") || lsame_(job, "B"))
{
if (rightv)
{
i__1 = *ihi;
for (i__ = *ilo;
i__ <= i__1;
++i__)
{
s = scale[i__];
csscal_(m, &s, &v[i__ + v_dim1], ldv);
/* L10: */
}
}
if (leftv)
{
i__1 = *ihi;
for (i__ = *ilo;
i__ <= i__1;
++i__)
{
s = 1.f / scale[i__];
csscal_(m, &s, &v[i__ + v_dim1], ldv);
/* L20: */
}
}
}
/* Backward permutation */
/* For I = ILO-1 step -1 until 1, */
/* IHI+1 step 1 until N do -- */
L30:
if (lsame_(job, "P") || lsame_(job, "B"))
{
if (rightv)
{
i__1 = *n;
for (ii = 1;
ii <= i__1;
++ii)
{
i__ = ii;
if (i__ >= *ilo && i__ <= *ihi)
{
goto L40;
}
if (i__ < *ilo)
{
i__ = *ilo - ii;
}
k = scale[i__];
if (k == i__)
{
goto L40;
}
cswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
L40:
;
}
}
if (leftv)
{
i__1 = *n;
for (ii = 1;
ii <= i__1;
++ii)
{
i__ = ii;
if (i__ >= *ilo && i__ <= *ihi)
{
goto L50;
}
if (i__ < *ilo)
{
i__ = *ilo - ii;
}
k = scale[i__];
if (k == i__)
{
goto L50;
}
cswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
L50:
;
}
}
}
return 0;
/* End of CGEBAK */
}
/* Subroutine */ int cdrvpt_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, real *thresh, logical *tsterr, complex *a, real *d__,
complex *e, complex *b, complex *x, complex *xact, complex *work,
real *rwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
/* Format strings */
static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
", test \002,i2,\002, ratio = \002,g12.5)";
static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', N =\002,i5"
",\002, type \002,i2,\002, test \002,i2,\002, ratio = \002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
real r__1, r__2;
/* Local variables */
integer i__, j, k, n;
real z__[3];
integer k1, ia, in, kl, ku, ix, nt, lda;
char fact[1];
real cond;
integer mode;
real dmax__;
integer imat, info;
char path[3], dist[1], type__[1];
integer nrun, ifact;
integer nfail, iseed[4];
real rcond;
integer nimat;
real anorm;
integer izero, nerrs;
logical zerot;
real rcondc;
real ainvnm;
real result[6];
/* Fortran I/O blocks */
static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CDRVPT tests CPTSV and -SVX. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors to be generated for */
/* each linear system. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) COMPLEX array, dimension (NMAX*2) */
/* D (workspace) REAL array, dimension (NMAX*2) */
/* E (workspace) COMPLEX array, dimension (NMAX*2) */
/* B (workspace) COMPLEX array, dimension (NMAX*NRHS) */
/* X (workspace) COMPLEX array, dimension (NMAX*NRHS) */
/* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) */
/* WORK (workspace) COMPLEX array, dimension */
/* (NMAX*max(3,NRHS)) */
/* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--rwork;
--work;
--xact;
--x;
--b;
--e;
--d__;
--a;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "PT", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
cerrvx_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
lda = max(1,n);
nimat = 12;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (n > 0 && ! dotype[imat]) {
goto L110;
}
/* Set up parameters with CLATB4. */
clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cond, dist);
zerot = imat >= 8 && imat <= 10;
if (imat <= 6) {
/* Type 1-6: generate a symmetric tridiagonal matrix of */
/* known condition number in lower triangular band storage. */
s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
&anorm, &kl, &ku, "B", &a[1], &c__2, &work[1], &info);
/* Check the error code from CLATMS. */
if (info != 0) {
alaerh_(path, "CLATMS", &info, &c__0, " ", &n, &n, &kl, &
ku, &c_n1, &imat, &nfail, &nerrs, nout);
goto L110;
}
izero = 0;
/* Copy the matrix to D and E. */
ia = 1;
i__3 = n - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
i__5 = ia;
d__[i__4] = a[i__5].r;
i__4 = i__;
i__5 = ia + 1;
e[i__4].r = a[i__5].r, e[i__4].i = a[i__5].i;
ia += 2;
/* L20: */
}
if (n > 0) {
i__3 = n;
i__4 = ia;
d__[i__3] = a[i__4].r;
}
} else {
/* Type 7-12: generate a diagonally dominant matrix with */
/* unknown condition number in the vectors D and E. */
if (! zerot || ! dotype[7]) {
/* Let D and E have values from [-1,1]. */
slarnv_(&c__2, iseed, &n, &d__[1]);
i__3 = n - 1;
clarnv_(&c__2, iseed, &i__3, &e[1]);
/* Make the tridiagonal matrix diagonally dominant. */
if (n == 1) {
d__[1] = dabs(d__[1]);
} else {
d__[1] = dabs(d__[1]) + c_abs(&e[1]);
d__[n] = (r__1 = d__[n], dabs(r__1)) + c_abs(&e[n - 1]
);
i__3 = n - 1;
for (i__ = 2; i__ <= i__3; ++i__) {
d__[i__] = (r__1 = d__[i__], dabs(r__1)) + c_abs(&
e[i__]) + c_abs(&e[i__ - 1]);
/* L30: */
}
}
/* Scale D and E so the maximum element is ANORM. */
ix = isamax_(&n, &d__[1], &c__1);
dmax__ = d__[ix];
r__1 = anorm / dmax__;
sscal_(&n, &r__1, &d__[1], &c__1);
if (n > 1) {
i__3 = n - 1;
r__1 = anorm / dmax__;
csscal_(&i__3, &r__1, &e[1], &c__1);
}
} else if (izero > 0) {
/* Reuse the last matrix by copying back the zeroed out */
/* elements. */
if (izero == 1) {
d__[1] = z__[1];
if (n > 1) {
e[1].r = z__[2], e[1].i = 0.f;
}
} else if (izero == n) {
i__3 = n - 1;
e[i__3].r = z__[0], e[i__3].i = 0.f;
d__[n] = z__[1];
} else {
i__3 = izero - 1;
e[i__3].r = z__[0], e[i__3].i = 0.f;
d__[izero] = z__[1];
i__3 = izero;
e[i__3].r = z__[2], e[i__3].i = 0.f;
}
}
/* For types 8-10, set one row and column of the matrix to */
/* zero. */
izero = 0;
if (imat == 8) {
izero = 1;
z__[1] = d__[1];
d__[1] = 0.f;
if (n > 1) {
z__[2] = e[1].r;
e[1].r = 0.f, e[1].i = 0.f;
}
} else if (imat == 9) {
izero = n;
if (n > 1) {
i__3 = n - 1;
z__[0] = e[i__3].r;
i__3 = n - 1;
e[i__3].r = 0.f, e[i__3].i = 0.f;
}
z__[1] = d__[n];
d__[n] = 0.f;
} else if (imat == 10) {
izero = (n + 1) / 2;
if (izero > 1) {
i__3 = izero - 1;
z__[0] = e[i__3].r;
i__3 = izero - 1;
e[i__3].r = 0.f, e[i__3].i = 0.f;
i__3 = izero;
z__[2] = e[i__3].r;
i__3 = izero;
e[i__3].r = 0.f, e[i__3].i = 0.f;
}
z__[1] = d__[izero];
d__[izero] = 0.f;
}
}
/* Generate NRHS random solution vectors. */
ix = 1;
i__3 = *nrhs;
for (j = 1; j <= i__3; ++j) {
clarnv_(&c__2, iseed, &n, &xact[ix]);
ix += lda;
/* L40: */
}
/* Set the right hand side. */
claptm_("Lower", &n, nrhs, &c_b24, &d__[1], &e[1], &xact[1], &lda,
&c_b25, &b[1], &lda);
for (ifact = 1; ifact <= 2; ++ifact) {
if (ifact == 1) {
*(unsigned char *)fact = 'F';
} else {
*(unsigned char *)fact = 'N';
}
/* Compute the condition number for comparison with */
/* the value returned by CPTSVX. */
if (zerot) {
if (ifact == 1) {
goto L100;
}
rcondc = 0.f;
} else if (ifact == 1) {
/* Compute the 1-norm of A. */
anorm = clanht_("1", &n, &d__[1], &e[1]);
scopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
if (n > 1) {
i__3 = n - 1;
ccopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
}
/* Factor the matrix A. */
cpttrf_(&n, &d__[n + 1], &e[n + 1], &info);
/* Use CPTTRS to solve for one column at a time of */
/* inv(A), computing the maximum column sum as we go. */
ainvnm = 0.f;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
i__5 = j;
x[i__5].r = 0.f, x[i__5].i = 0.f;
/* L50: */
}
i__4 = i__;
x[i__4].r = 1.f, x[i__4].i = 0.f;
cpttrs_("Lower", &n, &c__1, &d__[n + 1], &e[n + 1], &
x[1], &lda, &info);
/* Computing MAX */
r__1 = ainvnm, r__2 = scasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* L60: */
}
/* Compute the 1-norm condition number of A. */
if (anorm <= 0.f || ainvnm <= 0.f) {
rcondc = 1.f;
} else {
rcondc = 1.f / anorm / ainvnm;
}
}
if (ifact == 2) {
/* --- Test CPTSV -- */
scopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
if (n > 1) {
i__3 = n - 1;
ccopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
}
clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
/* Factor A as L*D*L' and solve the system A*X = B. */
s_copy(srnamc_1.srnamt, "CPTSV ", (ftnlen)32, (ftnlen)6);
cptsv_(&n, nrhs, &d__[n + 1], &e[n + 1], &x[1], &lda, &
info);
/* Check error code from CPTSV . */
if (info != izero) {
alaerh_(path, "CPTSV ", &info, &izero, " ", &n, &n, &
c__1, &c__1, nrhs, &imat, &nfail, &nerrs,
nout);
}
nt = 0;
if (izero == 0) {
/* Check the factorization by computing the ratio */
/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
cptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &
work[1], result);
/* Compute the residual in the solution. */
clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
cptt02_("Lower", &n, nrhs, &d__[1], &e[1], &x[1], &
lda, &work[1], &lda, &result[1]);
/* Check solution from generated exact solution. */
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
}
/* Print information about the tests that did not pass */
/* the threshold. */
i__3 = nt;
for (k = 1; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, "CPTSV ", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L70: */
}
nrun += nt;
}
/* --- Test CPTSVX --- */
if (ifact > 1) {
/* Initialize D( N+1:2*N ) and E( N+1:2*N ) to zero. */
i__3 = n - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
d__[n + i__] = 0.f;
i__4 = n + i__;
e[i__4].r = 0.f, e[i__4].i = 0.f;
/* L80: */
}
if (n > 0) {
d__[n + n] = 0.f;
}
}
claset_("Full", &n, nrhs, &c_b62, &c_b62, &x[1], &lda);
/* Solve the system and compute the condition number and */
/* error bounds using CPTSVX. */
s_copy(srnamc_1.srnamt, "CPTSVX", (ftnlen)32, (ftnlen)6);
cptsvx_(fact, &n, nrhs, &d__[1], &e[1], &d__[n + 1], &e[n + 1]
, &b[1], &lda, &x[1], &lda, &rcond, &rwork[1], &rwork[
*nrhs + 1], &work[1], &rwork[(*nrhs << 1) + 1], &info);
/* Check the error code from CPTSVX. */
if (info != izero) {
alaerh_(path, "CPTSVX", &info, &izero, fact, &n, &n, &
c__1, &c__1, nrhs, &imat, &nfail, &nerrs, nout);
}
if (izero == 0) {
if (ifact == 2) {
/* Check the factorization by computing the ratio */
/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
k1 = 1;
cptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &
work[1], result);
} else {
k1 = 2;
}
/* Compute the residual in the solution. */
clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
cptt02_("Lower", &n, nrhs, &d__[1], &e[1], &x[1], &lda, &
work[1], &lda, &result[1]);
/* Check solution from generated exact solution. */
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[2]);
/* Check error bounds from iterative refinement. */
cptt05_(&n, nrhs, &d__[1], &e[1], &b[1], &lda, &x[1], &
lda, &xact[1], &lda, &rwork[1], &rwork[*nrhs + 1],
&result[3]);
} else {
k1 = 6;
}
/* Check the reciprocal of the condition number. */
result[5] = sget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = k1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, "CPTSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
real));
e_wsfe();
++nfail;
}
/* L90: */
}
nrun = nrun + 7 - k1;
L100:
;
}
L110:
;
}
/* L120: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of CDRVPT */
} /* cdrvpt_ */
/* Subroutine */ int chptrf_(char *uplo, integer *n, complex *ap, integer *
ipiv, integer *info, ftnlen uplo_len)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6;
real r__1, r__2, r__3, r__4;
complex q__1, q__2, q__3, q__4, q__5, q__6;
/* Builtin functions */
double sqrt(doublereal), r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
static real d__;
static integer i__, j, k;
static complex t;
static real r1, d11;
static complex d12;
static real d22;
static complex d21;
static integer kc, kk, kp;
static complex wk;
static integer kx;
static real tt;
static integer knc, kpc, npp;
static complex wkm1, wkp1;
extern /* Subroutine */ int chpr_(char *, integer *, real *, complex *,
integer *, complex *, ftnlen);
static integer imax, jmax;
static real alpha;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
complex *, integer *);
static integer kstep;
static logical upper;
extern doublereal slapy2_(real *, real *);
static real absakk;
extern integer icamax_(integer *, complex *, integer *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), xerbla_(char *, integer *, ftnlen);
static real colmax, rowmax;
/* -- 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 */
/* ======= */
/* CHPTRF computes the factorization of a complex Hermitian packed */
/* matrix A using the Bunch-Kaufman diagonal pivoting method: */
/* A = U*D*U**H or A = L*D*L**H */
/* where U (or L) is a product of permutation and unit upper (lower) */
/* triangular matrices, and D is Hermitian and block diagonal with */
/* 1-by-1 and 2-by-2 diagonal blocks. */
/* 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. */
/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the Hermitian matrix */
/* A, packed columnwise in a linear array. The j-th column of A */
/* is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/* On exit, the block diagonal matrix D and the multipliers used */
/* to obtain the factor U or L, stored as a packed triangular */
/* matrix overwriting A (see below for further details). */
/* IPIV (output) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D. */
/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, D(i,i) is exactly zero. The factorization */
/* has been completed, but the block diagonal matrix D is */
/* exactly singular, and division by zero will occur if it */
/* is used to solve a system of equations. */
/* Further Details */
/* =============== */
/* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services */
/* Company */
/* If UPLO = 'U', then A = U*D*U', where */
/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */
/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
/* ( I v 0 ) k-s */
/* U(k) = ( 0 I 0 ) s */
/* ( 0 0 I ) n-k */
/* k-s s n-k */
/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */
/* If UPLO = 'L', then A = L*D*L', where */
/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
/* ( I 0 0 ) k-1 */
/* L(k) = ( 0 I 0 ) s */
/* ( 0 v I ) n-k-s+1 */
/* k-1 s n-k-s+1 */
/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ipiv;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHPTRF", &i__1, (ftnlen)6);
return 0;
}
/* Initialize ALPHA for use in choosing pivot block size. */
alpha = (sqrt(17.f) + 1.f) / 8.f;
if (upper) {
/* Factorize A as U*D*U' using the upper triangle of A */
/* K is the main loop index, decreasing from N to 1 in steps of */
/* 1 or 2 */
k = *n;
kc = (*n - 1) * *n / 2 + 1;
L10:
knc = kc;
/* If K < 1, exit from loop */
if (k < 1) {
goto L110;
}
kstep = 1;
/* Determine rows and columns to be interchanged and whether */
/* a 1-by-1 or 2-by-2 pivot block will be used */
i__1 = kc + k - 1;
absakk = (r__1 = ap[i__1].r, dabs(r__1));
/* IMAX is the row-index of the largest off-diagonal element in */
/* column K, and COLMAX is its absolute value */
if (k > 1) {
i__1 = k - 1;
imax = icamax_(&i__1, &ap[kc], &c__1);
i__1 = kc + imax - 1;
colmax = (r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[kc
+ imax - 1]), dabs(r__2));
} else {
colmax = 0.f;
}
if (dmax(absakk,colmax) == 0.f) {
/* Column K is zero: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = kc + k - 1;
i__2 = kc + k - 1;
r__1 = ap[i__2].r;
ap[i__1].r = r__1, ap[i__1].i = 0.f;
} else {
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else {
/* JMAX is the column-index of the largest off-diagonal */
/* element in row IMAX, and ROWMAX is its absolute value */
rowmax = 0.f;
jmax = imax;
kx = imax * (imax + 1) / 2 + imax;
i__1 = k;
for (j = imax + 1; j <= i__1; ++j) {
i__2 = kx;
if ((r__1 = ap[i__2].r, dabs(r__1)) + (r__2 = r_imag(&ap[
kx]), dabs(r__2)) > rowmax) {
i__2 = kx;
rowmax = (r__1 = ap[i__2].r, dabs(r__1)) + (r__2 =
r_imag(&ap[kx]), dabs(r__2));
jmax = j;
}
kx += j;
/* L20: */
}
kpc = (imax - 1) * imax / 2 + 1;
if (imax > 1) {
i__1 = imax - 1;
jmax = icamax_(&i__1, &ap[kpc], &c__1);
/* Computing MAX */
i__1 = kpc + jmax - 1;
r__3 = rowmax, r__4 = (r__1 = ap[i__1].r, dabs(r__1)) + (
r__2 = r_imag(&ap[kpc + jmax - 1]), dabs(r__2));
rowmax = dmax(r__3,r__4);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else /* if(complicated condition) */ {
i__1 = kpc + imax - 1;
if ((r__1 = ap[i__1].r, dabs(r__1)) >= alpha * rowmax) {
/* interchange rows and columns K and IMAX, use 1-by-1 */
/* pivot block */
kp = imax;
} else {
/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
/* pivot block */
kp = imax;
kstep = 2;
}
}
}
kk = k - kstep + 1;
if (kstep == 2) {
knc = knc - k + 1;
}
if (kp != kk) {
/* Interchange rows and columns KK and KP in the leading */
/* submatrix A(1:k,1:k) */
i__1 = kp - 1;
cswap_(&i__1, &ap[knc], &c__1, &ap[kpc], &c__1);
kx = kpc + kp - 1;
i__1 = kk - 1;
for (j = kp + 1; j <= i__1; ++j) {
kx = kx + j - 1;
r_cnjg(&q__1, &ap[knc + j - 1]);
t.r = q__1.r, t.i = q__1.i;
i__2 = knc + j - 1;
r_cnjg(&q__1, &ap[kx]);
ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
i__2 = kx;
ap[i__2].r = t.r, ap[i__2].i = t.i;
/* L30: */
}
i__1 = kx + kk - 1;
r_cnjg(&q__1, &ap[kx + kk - 1]);
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
i__1 = knc + kk - 1;
r1 = ap[i__1].r;
i__1 = knc + kk - 1;
i__2 = kpc + kp - 1;
r__1 = ap[i__2].r;
ap[i__1].r = r__1, ap[i__1].i = 0.f;
i__1 = kpc + kp - 1;
ap[i__1].r = r1, ap[i__1].i = 0.f;
if (kstep == 2) {
i__1 = kc + k - 1;
i__2 = kc + k - 1;
r__1 = ap[i__2].r;
ap[i__1].r = r__1, ap[i__1].i = 0.f;
i__1 = kc + k - 2;
t.r = ap[i__1].r, t.i = ap[i__1].i;
i__1 = kc + k - 2;
i__2 = kc + kp - 1;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kc + kp - 1;
ap[i__1].r = t.r, ap[i__1].i = t.i;
}
} else {
i__1 = kc + k - 1;
i__2 = kc + k - 1;
r__1 = ap[i__2].r;
ap[i__1].r = r__1, ap[i__1].i = 0.f;
if (kstep == 2) {
i__1 = kc - 1;
i__2 = kc - 1;
r__1 = ap[i__2].r;
ap[i__1].r = r__1, ap[i__1].i = 0.f;
}
}
/* Update the leading submatrix */
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column k now holds */
/* W(k) = U(k)*D(k) */
/* where U(k) is the k-th column of U */
/* Perform a rank-1 update of A(1:k-1,1:k-1) as */
/* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' */
i__1 = kc + k - 1;
r1 = 1.f / ap[i__1].r;
i__1 = k - 1;
r__1 = -r1;
chpr_(uplo, &i__1, &r__1, &ap[kc], &c__1, &ap[1], (ftnlen)1);
/* Store U(k) in column k */
i__1 = k - 1;
csscal_(&i__1, &r1, &ap[kc], &c__1);
} else {
/* 2-by-2 pivot block D(k): columns k and k-1 now hold */
/* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */
/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */
/* of U */
/* Perform a rank-2 update of A(1:k-2,1:k-2) as */
/* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )' */
/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' */
if (k > 2) {
i__1 = k - 1 + (k - 1) * k / 2;
r__1 = ap[i__1].r;
r__2 = r_imag(&ap[k - 1 + (k - 1) * k / 2]);
d__ = slapy2_(&r__1, &r__2);
i__1 = k - 1 + (k - 2) * (k - 1) / 2;
d22 = ap[i__1].r / d__;
i__1 = k + (k - 1) * k / 2;
d11 = ap[i__1].r / d__;
tt = 1.f / (d11 * d22 - 1.f);
i__1 = k - 1 + (k - 1) * k / 2;
q__1.r = ap[i__1].r / d__, q__1.i = ap[i__1].i / d__;
d12.r = q__1.r, d12.i = q__1.i;
d__ = tt / d__;
for (j = k - 2; j >= 1; --j) {
i__1 = j + (k - 2) * (k - 1) / 2;
q__3.r = d11 * ap[i__1].r, q__3.i = d11 * ap[i__1].i;
r_cnjg(&q__5, &d12);
i__2 = j + (k - 1) * k / 2;
q__4.r = q__5.r * ap[i__2].r - q__5.i * ap[i__2].i,
q__4.i = q__5.r * ap[i__2].i + q__5.i * ap[
i__2].r;
q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i;
q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i;
wkm1.r = q__1.r, wkm1.i = q__1.i;
i__1 = j + (k - 1) * k / 2;
q__3.r = d22 * ap[i__1].r, q__3.i = d22 * ap[i__1].i;
i__2 = j + (k - 2) * (k - 1) / 2;
q__4.r = d12.r * ap[i__2].r - d12.i * ap[i__2].i,
q__4.i = d12.r * ap[i__2].i + d12.i * ap[i__2]
.r;
q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i;
q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i;
wk.r = q__1.r, wk.i = q__1.i;
for (i__ = j; i__ >= 1; --i__) {
i__1 = i__ + (j - 1) * j / 2;
i__2 = i__ + (j - 1) * j / 2;
i__3 = i__ + (k - 1) * k / 2;
r_cnjg(&q__4, &wk);
q__3.r = ap[i__3].r * q__4.r - ap[i__3].i *
q__4.i, q__3.i = ap[i__3].r * q__4.i + ap[
i__3].i * q__4.r;
q__2.r = ap[i__2].r - q__3.r, q__2.i = ap[i__2].i
- q__3.i;
i__4 = i__ + (k - 2) * (k - 1) / 2;
r_cnjg(&q__6, &wkm1);
q__5.r = ap[i__4].r * q__6.r - ap[i__4].i *
q__6.i, q__5.i = ap[i__4].r * q__6.i + ap[
i__4].i * q__6.r;
q__1.r = q__2.r - q__5.r, q__1.i = q__2.i -
q__5.i;
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
/* L40: */
}
i__1 = j + (k - 1) * k / 2;
ap[i__1].r = wk.r, ap[i__1].i = wk.i;
i__1 = j + (k - 2) * (k - 1) / 2;
ap[i__1].r = wkm1.r, ap[i__1].i = wkm1.i;
i__1 = j + (j - 1) * j / 2;
i__2 = j + (j - 1) * j / 2;
r__1 = ap[i__2].r;
q__1.r = r__1, q__1.i = 0.f;
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
/* L50: */
}
}
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k - 1] = -kp;
}
/* Decrease K and return to the start of the main loop */
k -= kstep;
kc = knc - k;
goto L10;
} else {
/* Factorize A as L*D*L' using the lower triangle of A */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2 */
k = 1;
kc = 1;
npp = *n * (*n + 1) / 2;
L60:
knc = kc;
/* If K > N, exit from loop */
if (k > *n) {
goto L110;
}
kstep = 1;
/* Determine rows and columns to be interchanged and whether */
/* a 1-by-1 or 2-by-2 pivot block will be used */
i__1 = kc;
absakk = (r__1 = ap[i__1].r, dabs(r__1));
/* IMAX is the row-index of the largest off-diagonal element in */
/* column K, and COLMAX is its absolute value */
if (k < *n) {
i__1 = *n - k;
imax = k + icamax_(&i__1, &ap[kc + 1], &c__1);
i__1 = kc + imax - k;
colmax = (r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[kc
+ imax - k]), dabs(r__2));
} else {
colmax = 0.f;
}
if (dmax(absakk,colmax) == 0.f) {
/* Column K is zero: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = kc;
i__2 = kc;
r__1 = ap[i__2].r;
ap[i__1].r = r__1, ap[i__1].i = 0.f;
} else {
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else {
/* JMAX is the column-index of the largest off-diagonal */
/* element in row IMAX, and ROWMAX is its absolute value */
rowmax = 0.f;
kx = kc + imax - k;
i__1 = imax - 1;
for (j = k; j <= i__1; ++j) {
i__2 = kx;
if ((r__1 = ap[i__2].r, dabs(r__1)) + (r__2 = r_imag(&ap[
kx]), dabs(r__2)) > rowmax) {
i__2 = kx;
rowmax = (r__1 = ap[i__2].r, dabs(r__1)) + (r__2 =
r_imag(&ap[kx]), dabs(r__2));
jmax = j;
}
kx = kx + *n - j;
/* L70: */
}
kpc = npp - (*n - imax + 1) * (*n - imax + 2) / 2 + 1;
if (imax < *n) {
i__1 = *n - imax;
jmax = imax + icamax_(&i__1, &ap[kpc + 1], &c__1);
/* Computing MAX */
i__1 = kpc + jmax - imax;
r__3 = rowmax, r__4 = (r__1 = ap[i__1].r, dabs(r__1)) + (
r__2 = r_imag(&ap[kpc + jmax - imax]), dabs(r__2))
;
rowmax = dmax(r__3,r__4);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else /* if(complicated condition) */ {
i__1 = kpc;
if ((r__1 = ap[i__1].r, dabs(r__1)) >= alpha * rowmax) {
/* interchange rows and columns K and IMAX, use 1-by-1 */
/* pivot block */
kp = imax;
} else {
/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
/* pivot block */
kp = imax;
kstep = 2;
}
}
}
kk = k + kstep - 1;
if (kstep == 2) {
knc = knc + *n - k + 1;
}
if (kp != kk) {
/* Interchange rows and columns KK and KP in the trailing */
/* submatrix A(k:n,k:n) */
if (kp < *n) {
i__1 = *n - kp;
cswap_(&i__1, &ap[knc + kp - kk + 1], &c__1, &ap[kpc + 1],
&c__1);
}
kx = knc + kp - kk;
i__1 = kp - 1;
for (j = kk + 1; j <= i__1; ++j) {
kx = kx + *n - j + 1;
r_cnjg(&q__1, &ap[knc + j - kk]);
t.r = q__1.r, t.i = q__1.i;
i__2 = knc + j - kk;
r_cnjg(&q__1, &ap[kx]);
ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
i__2 = kx;
ap[i__2].r = t.r, ap[i__2].i = t.i;
/* L80: */
}
i__1 = knc + kp - kk;
r_cnjg(&q__1, &ap[knc + kp - kk]);
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
i__1 = knc;
r1 = ap[i__1].r;
i__1 = knc;
i__2 = kpc;
r__1 = ap[i__2].r;
ap[i__1].r = r__1, ap[i__1].i = 0.f;
i__1 = kpc;
ap[i__1].r = r1, ap[i__1].i = 0.f;
if (kstep == 2) {
i__1 = kc;
i__2 = kc;
r__1 = ap[i__2].r;
ap[i__1].r = r__1, ap[i__1].i = 0.f;
i__1 = kc + 1;
t.r = ap[i__1].r, t.i = ap[i__1].i;
i__1 = kc + 1;
i__2 = kc + kp - k;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kc + kp - k;
ap[i__1].r = t.r, ap[i__1].i = t.i;
}
} else {
i__1 = kc;
i__2 = kc;
r__1 = ap[i__2].r;
ap[i__1].r = r__1, ap[i__1].i = 0.f;
if (kstep == 2) {
i__1 = knc;
i__2 = knc;
r__1 = ap[i__2].r;
ap[i__1].r = r__1, ap[i__1].i = 0.f;
}
}
/* Update the trailing submatrix */
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column k now holds */
/* W(k) = L(k)*D(k) */
/* where L(k) is the k-th column of L */
if (k < *n) {
/* Perform a rank-1 update of A(k+1:n,k+1:n) as */
/* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' */
i__1 = kc;
r1 = 1.f / ap[i__1].r;
i__1 = *n - k;
r__1 = -r1;
chpr_(uplo, &i__1, &r__1, &ap[kc + 1], &c__1, &ap[kc + *n
- k + 1], (ftnlen)1);
/* Store L(k) in column K */
i__1 = *n - k;
csscal_(&i__1, &r1, &ap[kc + 1], &c__1);
}
} else {
/* 2-by-2 pivot block D(k): columns K and K+1 now hold */
/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */
/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */
/* of L */
if (k < *n - 1) {
/* Perform a rank-2 update of A(k+2:n,k+2:n) as */
/* A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )' */
/* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )' */
/* where L(k) and L(k+1) are the k-th and (k+1)-th */
/* columns of L */
i__1 = k + 1 + (k - 1) * ((*n << 1) - k) / 2;
r__1 = ap[i__1].r;
r__2 = r_imag(&ap[k + 1 + (k - 1) * ((*n << 1) - k) / 2]);
d__ = slapy2_(&r__1, &r__2);
i__1 = k + 1 + k * ((*n << 1) - k - 1) / 2;
d11 = ap[i__1].r / d__;
i__1 = k + (k - 1) * ((*n << 1) - k) / 2;
d22 = ap[i__1].r / d__;
tt = 1.f / (d11 * d22 - 1.f);
i__1 = k + 1 + (k - 1) * ((*n << 1) - k) / 2;
q__1.r = ap[i__1].r / d__, q__1.i = ap[i__1].i / d__;
d21.r = q__1.r, d21.i = q__1.i;
d__ = tt / d__;
i__1 = *n;
for (j = k + 2; j <= i__1; ++j) {
i__2 = j + (k - 1) * ((*n << 1) - k) / 2;
q__3.r = d11 * ap[i__2].r, q__3.i = d11 * ap[i__2].i;
i__3 = j + k * ((*n << 1) - k - 1) / 2;
q__4.r = d21.r * ap[i__3].r - d21.i * ap[i__3].i,
q__4.i = d21.r * ap[i__3].i + d21.i * ap[i__3]
.r;
q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i;
q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i;
wk.r = q__1.r, wk.i = q__1.i;
i__2 = j + k * ((*n << 1) - k - 1) / 2;
q__3.r = d22 * ap[i__2].r, q__3.i = d22 * ap[i__2].i;
r_cnjg(&q__5, &d21);
i__3 = j + (k - 1) * ((*n << 1) - k) / 2;
q__4.r = q__5.r * ap[i__3].r - q__5.i * ap[i__3].i,
q__4.i = q__5.r * ap[i__3].i + q__5.i * ap[
i__3].r;
q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i;
q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i;
wkp1.r = q__1.r, wkp1.i = q__1.i;
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = i__ + (j - 1) * ((*n << 1) - j) / 2;
i__4 = i__ + (j - 1) * ((*n << 1) - j) / 2;
i__5 = i__ + (k - 1) * ((*n << 1) - k) / 2;
r_cnjg(&q__4, &wk);
q__3.r = ap[i__5].r * q__4.r - ap[i__5].i *
q__4.i, q__3.i = ap[i__5].r * q__4.i + ap[
i__5].i * q__4.r;
q__2.r = ap[i__4].r - q__3.r, q__2.i = ap[i__4].i
- q__3.i;
i__6 = i__ + k * ((*n << 1) - k - 1) / 2;
r_cnjg(&q__6, &wkp1);
q__5.r = ap[i__6].r * q__6.r - ap[i__6].i *
q__6.i, q__5.i = ap[i__6].r * q__6.i + ap[
i__6].i * q__6.r;
q__1.r = q__2.r - q__5.r, q__1.i = q__2.i -
q__5.i;
ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
/* L90: */
}
i__2 = j + (k - 1) * ((*n << 1) - k) / 2;
ap[i__2].r = wk.r, ap[i__2].i = wk.i;
i__2 = j + k * ((*n << 1) - k - 1) / 2;
ap[i__2].r = wkp1.r, ap[i__2].i = wkp1.i;
i__2 = j + (j - 1) * ((*n << 1) - j) / 2;
i__3 = j + (j - 1) * ((*n << 1) - j) / 2;
r__1 = ap[i__3].r;
q__1.r = r__1, q__1.i = 0.f;
ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
/* L100: */
}
}
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k + 1] = -kp;
}
/* Increase K and return to the start of the main loop */
k += kstep;
kc = knc + *n - k + 2;
goto L60;
}
L110:
return 0;
/* End of CHPTRF */
} /* chptrf_ */
int cpbstf_(char *uplo, int *n, int *kd, complex *ab,
int *ldab, int *info)
{
/* System generated locals */
int ab_dim1, ab_offset, i__1, i__2, i__3;
float r__1;
/* Builtin functions */
double sqrt(double);
/* Local variables */
int j, m, km;
float ajj;
int kld;
extern int cher_(char *, int *, float *, complex *,
int *, complex *, int *);
extern int lsame_(char *, char *);
int upper;
extern int clacgv_(int *, complex *, int *),
csscal_(int *, float *, complex *, int *), xerbla_(char *,
int *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CPBSTF computes a split Cholesky factorization of a complex */
/* Hermitian positive definite band matrix A. */
/* This routine is designed to be used in conjunction with CHBGST. */
/* The factorization has the form A = S**H*S where S is a band matrix */
/* of the same bandwidth as A and the following structure: */
/* S = ( U ) */
/* ( M L ) */
/* where U is upper triangular of order m = (n+kd)/2, and L is lower */
/* triangular of order n-m. */
/* 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. */
/* KD (input) INTEGER */
/* The number of superdiagonals of the matrix A if UPLO = 'U', */
/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
/* AB (input/output) COMPLEX array, dimension (LDAB,N) */
/* On entry, the upper or lower triangle of the Hermitian 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). */
/* On exit, if INFO = 0, the factor S from the split Cholesky */
/* factorization A = S**H*S. See Further Details. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KD+1. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the factorization could not be completed, */
/* because the updated element a(i,i) was negative; the */
/* matrix A is not positive definite. */
/* Further Details */
/* =============== */
/* The band storage scheme is illustrated by the following example, when */
/* N = 7, KD = 2: */
/* S = ( s11 s12 s13 ) */
/* ( s22 s23 s24 ) */
/* ( s33 s34 ) */
/* ( s44 ) */
/* ( s53 s54 s55 ) */
/* ( s64 s65 s66 ) */
/* ( s75 s76 s77 ) */
/* If UPLO = 'U', the array AB holds: */
/* on entry: on exit: */
/* * * a13 a24 a35 a46 a57 * * s13 s24 s53' s64' s75' */
/* * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54' s65' s76' */
/* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77 */
/* If UPLO = 'L', the array AB holds: */
/* on entry: on exit: */
/* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77 */
/* a21 a32 a43 a54 a65 a76 * s12' s23' s34' s54 s65 s76 * */
/* a31 a42 a53 a64 a64 * * s13' s24' s53 s64 s75 * * */
/* Array elements marked * are not used by the routine; s12' denotes */
/* conjg(s12); the diagonal elements of S are float. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kd < 0) {
*info = -3;
} else if (*ldab < *kd + 1) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CPBSTF", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Computing MAX */
i__1 = 1, i__2 = *ldab - 1;
kld = MAX(i__1,i__2);
/* Set the splitting point m. */
m = (*n + *kd) / 2;
if (upper) {
/* Factorize A(m+1:n,m+1:n) as L**H*L, and update A(1:m,1:m). */
i__1 = m + 1;
for (j = *n; j >= i__1; --j) {
/* Compute s(j,j) and test for non-positive-definiteness. */
i__2 = *kd + 1 + j * ab_dim1;
ajj = ab[i__2].r;
if (ajj <= 0.f) {
i__2 = *kd + 1 + j * ab_dim1;
ab[i__2].r = ajj, ab[i__2].i = 0.f;
goto L50;
}
ajj = sqrt(ajj);
i__2 = *kd + 1 + j * ab_dim1;
ab[i__2].r = ajj, ab[i__2].i = 0.f;
/* Computing MIN */
i__2 = j - 1;
km = MIN(i__2,*kd);
/* Compute elements j-km:j-1 of the j-th column and update the */
/* the leading submatrix within the band. */
r__1 = 1.f / ajj;
csscal_(&km, &r__1, &ab[*kd + 1 - km + j * ab_dim1], &c__1);
cher_("Upper", &km, &c_b9, &ab[*kd + 1 - km + j * ab_dim1], &c__1,
&ab[*kd + 1 + (j - km) * ab_dim1], &kld);
/* L10: */
}
/* Factorize the updated submatrix A(1:m,1:m) as U**H*U. */
i__1 = m;
for (j = 1; j <= i__1; ++j) {
/* Compute s(j,j) and test for non-positive-definiteness. */
i__2 = *kd + 1 + j * ab_dim1;
ajj = ab[i__2].r;
if (ajj <= 0.f) {
i__2 = *kd + 1 + j * ab_dim1;
ab[i__2].r = ajj, ab[i__2].i = 0.f;
goto L50;
}
ajj = sqrt(ajj);
i__2 = *kd + 1 + j * ab_dim1;
ab[i__2].r = ajj, ab[i__2].i = 0.f;
/* Computing MIN */
i__2 = *kd, i__3 = m - j;
km = MIN(i__2,i__3);
/* Compute elements j+1:j+km of the j-th row and update the */
/* trailing submatrix within the band. */
if (km > 0) {
r__1 = 1.f / ajj;
csscal_(&km, &r__1, &ab[*kd + (j + 1) * ab_dim1], &kld);
clacgv_(&km, &ab[*kd + (j + 1) * ab_dim1], &kld);
cher_("Upper", &km, &c_b9, &ab[*kd + (j + 1) * ab_dim1], &kld,
&ab[*kd + 1 + (j + 1) * ab_dim1], &kld);
clacgv_(&km, &ab[*kd + (j + 1) * ab_dim1], &kld);
}
/* L20: */
}
} else {
/* Factorize A(m+1:n,m+1:n) as L**H*L, and update A(1:m,1:m). */
i__1 = m + 1;
for (j = *n; j >= i__1; --j) {
/* Compute s(j,j) and test for non-positive-definiteness. */
i__2 = j * ab_dim1 + 1;
ajj = ab[i__2].r;
if (ajj <= 0.f) {
i__2 = j * ab_dim1 + 1;
ab[i__2].r = ajj, ab[i__2].i = 0.f;
goto L50;
}
ajj = sqrt(ajj);
i__2 = j * ab_dim1 + 1;
ab[i__2].r = ajj, ab[i__2].i = 0.f;
/* Computing MIN */
i__2 = j - 1;
km = MIN(i__2,*kd);
/* Compute elements j-km:j-1 of the j-th row and update the */
/* trailing submatrix within the band. */
r__1 = 1.f / ajj;
csscal_(&km, &r__1, &ab[km + 1 + (j - km) * ab_dim1], &kld);
clacgv_(&km, &ab[km + 1 + (j - km) * ab_dim1], &kld);
cher_("Lower", &km, &c_b9, &ab[km + 1 + (j - km) * ab_dim1], &kld,
&ab[(j - km) * ab_dim1 + 1], &kld);
clacgv_(&km, &ab[km + 1 + (j - km) * ab_dim1], &kld);
/* L30: */
}
/* Factorize the updated submatrix A(1:m,1:m) as U**H*U. */
i__1 = m;
for (j = 1; j <= i__1; ++j) {
/* Compute s(j,j) and test for non-positive-definiteness. */
i__2 = j * ab_dim1 + 1;
ajj = ab[i__2].r;
if (ajj <= 0.f) {
i__2 = j * ab_dim1 + 1;
ab[i__2].r = ajj, ab[i__2].i = 0.f;
goto L50;
}
ajj = sqrt(ajj);
i__2 = j * ab_dim1 + 1;
ab[i__2].r = ajj, ab[i__2].i = 0.f;
/* Computing MIN */
i__2 = *kd, i__3 = m - j;
km = MIN(i__2,i__3);
/* Compute elements j+1:j+km of the j-th column and update the */
/* trailing submatrix within the band. */
if (km > 0) {
r__1 = 1.f / ajj;
csscal_(&km, &r__1, &ab[j * ab_dim1 + 2], &c__1);
cher_("Lower", &km, &c_b9, &ab[j * ab_dim1 + 2], &c__1, &ab[(
j + 1) * ab_dim1 + 1], &kld);
}
/* L40: */
}
}
return 0;
L50:
*info = j;
return 0;
/* End of CPBSTF */
} /* cpbstf_ */
/* Subroutine */ int claein_(logical *rightv, logical *noinit, integer *n,
complex *h__, integer *ldh, complex *w, complex *v, complex *b,
integer *ldb, real *rwork, real *eps3, real *smlnum, integer *info)
{
/* -- 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
=======
CLAEIN uses inverse iteration to find a right or left eigenvector
corresponding to the eigenvalue W of a complex upper Hessenberg
matrix H.
Arguments
=========
RIGHTV (input) LOGICAL
= .TRUE. : compute right eigenvector;
= .FALSE.: compute left eigenvector.
NOINIT (input) LOGICAL
= .TRUE. : no initial vector supplied in V
= .FALSE.: initial vector supplied in V.
N (input) INTEGER
The order of the matrix H. N >= 0.
H (input) COMPLEX array, dimension (LDH,N)
The upper Hessenberg matrix H.
LDH (input) INTEGER
The leading dimension of the array H. LDH >= max(1,N).
W (input) COMPLEX
The eigenvalue of H whose corresponding right or left
eigenvector is to be computed.
V (input/output) COMPLEX array, dimension (N)
On entry, if NOINIT = .FALSE., V must contain a starting
vector for inverse iteration; otherwise V need not be set.
On exit, V contains the computed eigenvector, normalized so
that the component of largest magnitude has magnitude 1; here
the magnitude of a complex number (x,y) is taken to be
|x| + |y|.
B (workspace) COMPLEX array, dimension (LDB,N)
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
RWORK (workspace) REAL array, dimension (N)
EPS3 (input) REAL
A small machine-dependent value which is used to perturb
close eigenvalues, and to replace zero pivots.
SMLNUM (input) REAL
A machine-dependent value close to the underflow threshold.
INFO (output) INTEGER
= 0: successful exit
= 1: inverse iteration did not converge; V is set to the
last iterate.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1, q__2;
/* Builtin functions */
double sqrt(doublereal), r_imag(complex *);
/* Local variables */
static integer ierr;
static complex temp;
static integer i__, j;
static real scale;
static complex x;
static char trans[1];
static real rtemp, rootn, vnorm;
extern doublereal scnrm2_(integer *, complex *, integer *);
static complex ei, ej;
extern integer icamax_(integer *, complex *, integer *);
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), clatrs_(char *, char *, char *, char *, integer *, complex *,
integer *, complex *, real *, real *, integer *);
extern doublereal scasum_(integer *, complex *, integer *);
static char normin[1];
static real nrmsml, growto;
static integer its;
#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 h___subscr(a_1,a_2) (a_2)*h_dim1 + a_1
#define h___ref(a_1,a_2) h__[h___subscr(a_1,a_2)]
h_dim1 = *ldh;
h_offset = 1 + h_dim1 * 1;
h__ -= h_offset;
--v;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--rwork;
/* Function Body */
*info = 0;
/* GROWTO is the threshold used in the acceptance test for an
eigenvector. */
rootn = sqrt((real) (*n));
growto = .1f / rootn;
/* Computing MAX */
r__1 = 1.f, r__2 = *eps3 * rootn;
nrmsml = dmax(r__1,r__2) * *smlnum;
/* Form B = H - W*I (except that the subdiagonal elements are not
stored). */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = h___subscr(i__, j);
b[i__3].r = h__[i__4].r, b[i__3].i = h__[i__4].i;
/* L10: */
}
i__2 = b_subscr(j, j);
i__3 = h___subscr(j, j);
q__1.r = h__[i__3].r - w->r, q__1.i = h__[i__3].i - w->i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L20: */
}
if (*noinit) {
/* Initialize V. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
v[i__2].r = *eps3, v[i__2].i = 0.f;
/* L30: */
}
} else {
/* Scale supplied initial vector. */
vnorm = scnrm2_(n, &v[1], &c__1);
r__1 = *eps3 * rootn / dmax(vnorm,nrmsml);
csscal_(n, &r__1, &v[1], &c__1);
}
if (*rightv) {
/* LU decomposition with partial pivoting of B, replacing zero
pivots by EPS3. */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = h___subscr(i__ + 1, i__);
ei.r = h__[i__2].r, ei.i = h__[i__2].i;
i__2 = b_subscr(i__, i__);
if ((r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(i__,
i__)), dabs(r__2)) < (r__3 = ei.r, dabs(r__3)) + (r__4 =
r_imag(&ei), dabs(r__4))) {
/* Interchange rows and eliminate. */
cladiv_(&q__1, &b_ref(i__, i__), &ei);
x.r = q__1.r, x.i = q__1.i;
i__2 = b_subscr(i__, i__);
b[i__2].r = ei.r, b[i__2].i = ei.i;
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = b_subscr(i__ + 1, j);
temp.r = b[i__3].r, temp.i = b[i__3].i;
i__3 = b_subscr(i__ + 1, j);
i__4 = b_subscr(i__, j);
q__2.r = x.r * temp.r - x.i * temp.i, q__2.i = x.r *
temp.i + x.i * temp.r;
q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i - q__2.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
i__3 = b_subscr(i__, j);
b[i__3].r = temp.r, b[i__3].i = temp.i;
/* L40: */
}
} else {
/* Eliminate without interchange. */
i__2 = b_subscr(i__, i__);
if (b[i__2].r == 0.f && b[i__2].i == 0.f) {
i__3 = b_subscr(i__, i__);
b[i__3].r = *eps3, b[i__3].i = 0.f;
}
cladiv_(&q__1, &ei, &b_ref(i__, i__));
x.r = q__1.r, x.i = q__1.i;
if (x.r != 0.f || x.i != 0.f) {
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = b_subscr(i__ + 1, j);
i__4 = b_subscr(i__ + 1, j);
i__5 = b_subscr(i__, j);
q__2.r = x.r * b[i__5].r - x.i * b[i__5].i, q__2.i =
x.r * b[i__5].i + x.i * b[i__5].r;
q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i -
q__2.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L50: */
}
}
}
/* L60: */
}
i__1 = b_subscr(*n, *n);
if (b[i__1].r == 0.f && b[i__1].i == 0.f) {
i__2 = b_subscr(*n, *n);
b[i__2].r = *eps3, b[i__2].i = 0.f;
}
*(unsigned char *)trans = 'N';
} else {
/* UL decomposition with partial pivoting of B, replacing zero
pivots by EPS3. */
for (j = *n; j >= 2; --j) {
i__1 = h___subscr(j, j - 1);
ej.r = h__[i__1].r, ej.i = h__[i__1].i;
i__1 = b_subscr(j, j);
if ((r__1 = b[i__1].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(j, j)),
dabs(r__2)) < (r__3 = ej.r, dabs(r__3)) + (r__4 = r_imag(
&ej), dabs(r__4))) {
/* Interchange columns and eliminate. */
cladiv_(&q__1, &b_ref(j, j), &ej);
x.r = q__1.r, x.i = q__1.i;
i__1 = b_subscr(j, j);
b[i__1].r = ej.r, b[i__1].i = ej.i;
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = b_subscr(i__, j - 1);
temp.r = b[i__2].r, temp.i = b[i__2].i;
i__2 = b_subscr(i__, j - 1);
i__3 = b_subscr(i__, j);
q__2.r = x.r * temp.r - x.i * temp.i, q__2.i = x.r *
temp.i + x.i * temp.r;
q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = b_subscr(i__, j);
b[i__2].r = temp.r, b[i__2].i = temp.i;
/* L70: */
}
} else {
/* Eliminate without interchange. */
i__1 = b_subscr(j, j);
if (b[i__1].r == 0.f && b[i__1].i == 0.f) {
i__2 = b_subscr(j, j);
b[i__2].r = *eps3, b[i__2].i = 0.f;
}
cladiv_(&q__1, &ej, &b_ref(j, j));
x.r = q__1.r, x.i = q__1.i;
if (x.r != 0.f || x.i != 0.f) {
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = b_subscr(i__, j - 1);
i__3 = b_subscr(i__, j - 1);
i__4 = b_subscr(i__, j);
q__2.r = x.r * b[i__4].r - x.i * b[i__4].i, q__2.i =
x.r * b[i__4].i + x.i * b[i__4].r;
q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i -
q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L80: */
}
}
}
/* L90: */
}
i__1 = b_subscr(1, 1);
if (b[i__1].r == 0.f && b[i__1].i == 0.f) {
i__2 = b_subscr(1, 1);
b[i__2].r = *eps3, b[i__2].i = 0.f;
}
*(unsigned char *)trans = 'C';
}
*(unsigned char *)normin = 'N';
i__1 = *n;
for (its = 1; its <= i__1; ++its) {
/* Solve U*x = scale*v for a right eigenvector
or U'*x = scale*v for a left eigenvector,
overwriting x on v. */
clatrs_("Upper", trans, "Nonunit", normin, n, &b[b_offset], ldb, &v[1]
, &scale, &rwork[1], &ierr);
*(unsigned char *)normin = 'Y';
/* Test for sufficient growth in the norm of v. */
vnorm = scasum_(n, &v[1], &c__1);
if (vnorm >= growto * scale) {
goto L120;
}
/* Choose new orthogonal starting vector and try again. */
rtemp = *eps3 / (rootn + 1.f);
v[1].r = *eps3, v[1].i = 0.f;
i__2 = *n;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = i__;
v[i__3].r = rtemp, v[i__3].i = 0.f;
/* L100: */
}
i__2 = *n - its + 1;
i__3 = *n - its + 1;
r__1 = *eps3 * rootn;
q__1.r = v[i__3].r - r__1, q__1.i = v[i__3].i;
v[i__2].r = q__1.r, v[i__2].i = q__1.i;
/* L110: */
}
/* Failure to find eigenvector in N iterations. */
*info = 1;
L120:
/* Normalize eigenvector. */
i__ = icamax_(n, &v[1], &c__1);
i__1 = i__;
r__3 = 1.f / ((r__1 = v[i__1].r, dabs(r__1)) + (r__2 = r_imag(&v[i__]),
dabs(r__2)));
csscal_(n, &r__3, &v[1], &c__1);
return 0;
/* End of CLAEIN */
} /* claein_ */
/* Subroutine */ int cgeevx_(char *balanc, char *jobvl, char *jobvr, char *
sense, integer *n, complex *a, integer *lda, complex *w, complex *vl,
integer *ldvl, complex *vr, integer *ldvr, integer *ilo, integer *ihi,
real *scale, real *abnrm, real *rconde, real *rcondv, complex *work,
integer *lwork, real *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3;
real r__1, r__2;
complex q__1, q__2;
/* Local variables */
integer i__, k;
char job[1];
real scl, dum[1], eps;
complex tmp;
char side[1];
real anrm;
integer ierr, itau, iwrk, nout;
integer icond;
logical scalea;
real cscale;
logical select[1];
real bignum;
integer minwrk, maxwrk;
logical wantvl, wntsnb;
integer hswork;
logical wntsne;
real smlnum;
logical lquery, wantvr, wntsnn, wntsnv;
/* -- LAPACK driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CGEEVX computes for an N-by-N complex nonsymmetric matrix A, the */
/* eigenvalues and, optionally, the left and/or right eigenvectors. */
/* Optionally also, it computes a balancing transformation to improve */
/* the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */
/* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues */
/* (RCONDE), and reciprocal condition numbers for the right */
/* eigenvectors (RCONDV). */
/* The right eigenvector v(j) of A satisfies */
/* A * v(j) = lambda(j) * v(j) */
/* where lambda(j) is its eigenvalue. */
/* The left eigenvector u(j) of A satisfies */
/* u(j)**H * A = lambda(j) * u(j)**H */
/* where u(j)**H denotes the conjugate transpose of u(j). */
/* The computed eigenvectors are normalized to have Euclidean norm */
/* equal to 1 and largest component real. */
/* Balancing a matrix means permuting the rows and columns to make it */
/* more nearly upper triangular, and applying a diagonal similarity */
/* transformation D * A * D**(-1), where D is a diagonal matrix, to */
/* make its rows and columns closer in norm and the condition numbers */
/* of its eigenvalues and eigenvectors smaller. The computed */
/* reciprocal condition numbers correspond to the balanced matrix. */
/* Permuting rows and columns will not change the condition numbers */
/* (in exact arithmetic) but diagonal scaling will. For further */
/* explanation of balancing, see section 4.10.2 of the LAPACK */
/* Users' Guide. */
/* Arguments */
/* ========= */
/* BALANC (input) CHARACTER*1 */
/* Indicates how the input matrix should be diagonally scaled */
/* and/or permuted to improve the conditioning of its */
/* eigenvalues. */
/* = 'N': Do not diagonally scale or permute; */
/* = 'P': Perform permutations to make the matrix more nearly */
/* upper triangular. Do not diagonally scale; */
/* = 'S': Diagonally scale the matrix, ie. replace A by */
/* D*A*D**(-1), where D is a diagonal matrix chosen */
/* to make the rows and columns of A more equal in */
/* norm. Do not permute; */
/* = 'B': Both diagonally scale and permute A. */
/* Computed reciprocal condition numbers will be for the matrix */
/* after balancing and/or permuting. Permuting does not change */
/* condition numbers (in exact arithmetic), but balancing does. */
/* JOBVL (input) CHARACTER*1 */
/* = 'N': left eigenvectors of A are not computed; */
/* = 'V': left eigenvectors of A are computed. */
/* If SENSE = 'E' or 'B', JOBVL must = 'V'. */
/* JOBVR (input) CHARACTER*1 */
/* = 'N': right eigenvectors of A are not computed; */
/* = 'V': right eigenvectors of A are computed. */
/* If SENSE = 'E' or 'B', JOBVR must = 'V'. */
/* SENSE (input) CHARACTER*1 */
/* Determines which reciprocal condition numbers are computed. */
/* = 'N': None are computed; */
/* = 'E': Computed for eigenvalues only; */
/* = 'V': Computed for right eigenvectors only; */
/* = 'B': Computed for eigenvalues and right eigenvectors. */
/* If SENSE = 'E' or 'B', both left and right eigenvectors */
/* must also be computed (JOBVL = 'V' and JOBVR = 'V'). */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the N-by-N matrix A. */
/* On exit, A has been overwritten. If JOBVL = 'V' or */
/* JOBVR = 'V', A contains the Schur form of the balanced */
/* version of the matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* W (output) COMPLEX array, dimension (N) */
/* W contains the computed eigenvalues. */
/* VL (output) COMPLEX array, dimension (LDVL,N) */
/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
/* after another in the columns of VL, in the same order */
/* as their eigenvalues. */
/* If JOBVL = 'N', VL is not referenced. */
/* u(j) = VL(:,j), the j-th column of VL. */
/* LDVL (input) INTEGER */
/* The leading dimension of the array VL. LDVL >= 1; if */
/* JOBVL = 'V', LDVL >= N. */
/* VR (output) COMPLEX array, dimension (LDVR,N) */
/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
/* after another in the columns of VR, in the same order */
/* as their eigenvalues. */
/* If JOBVR = 'N', VR is not referenced. */
/* v(j) = VR(:,j), the j-th column of VR. */
/* LDVR (input) INTEGER */
/* The leading dimension of the array VR. LDVR >= 1; if */
/* JOBVR = 'V', LDVR >= N. */
/* ILO (output) INTEGER */
/* IHI (output) INTEGER */
/* ILO and IHI are integer values determined when A was */
/* balanced. The balanced A(i,j) = 0 if I > J and */
/* SCALE (output) REAL array, dimension (N) */
/* Details of the permutations and scaling factors applied */
/* when balancing A. If P(j) is the index of the row and column */
/* interchanged with row and column j, and D(j) is the scaling */
/* factor applied to row and column j, then */
/* The order in which the interchanges are made is N to IHI+1, */
/* then 1 to ILO-1. */
/* ABNRM (output) REAL */
/* The one-norm of the balanced matrix (the maximum */
/* of the sum of absolute values of elements of any column). */
/* RCONDE (output) REAL array, dimension (N) */
/* RCONDE(j) is the reciprocal condition number of the j-th */
/* eigenvalue. */
/* RCONDV (output) REAL array, dimension (N) */
/* RCONDV(j) is the reciprocal condition number of the j-th */
/* right eigenvector. */
/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. If SENSE = 'N' or 'E', */
/* LWORK >= max(1,2*N), and if SENSE = 'V' or 'B', */
/* LWORK >= N*N+2*N. */
/* For good performance, LWORK must generally be larger. */
/* 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) REAL array, dimension (2*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = i, the QR algorithm failed to compute all the */
/* eigenvalues, and no eigenvectors or condition numbers */
/* have been computed; elements 1:ILO-1 and i+1:N of W */
/* contain eigenvalues which have converged. */
/* ===================================================================== */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--scale;
--rconde;
--rcondv;
--work;
--rwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1;
wantvl = lsame_(jobvl, "V");
wantvr = lsame_(jobvr, "V");
wntsnn = lsame_(sense, "N");
wntsne = lsame_(sense, "E");
wntsnv = lsame_(sense, "V");
wntsnb = lsame_(sense, "B");
if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P")
|| lsame_(balanc, "B"))) {
*info = -1;
} else if (! wantvl && ! lsame_(jobvl, "N")) {
*info = -2;
} else if (! wantvr && ! lsame_(jobvr, "N")) {
*info = -3;
} else if (! (wntsnn || wntsne || wntsnb || wntsnv) || (wntsne || wntsnb)
&& ! (wantvl && wantvr)) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldvl < 1 || wantvl && *ldvl < *n) {
*info = -10;
} else if (*ldvr < 1 || wantvr && *ldvr < *n) {
*info = -12;
}
/* 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. */
/* CWorkspace refers to complex workspace, and RWorkspace to real */
/* workspace. NB refers to the optimal block size for the */
/* immediately following subroutine, as returned by ILAENV. */
/* HSWORK refers to the workspace preferred by CHSEQR, as */
/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
/* the worst case.) */
if (*info == 0) {
if (*n == 0) {
minwrk = 1;
maxwrk = 1;
} else {
maxwrk = *n + *n * ilaenv_(&c__1, "CGEHRD", " ", n, &c__1, n, &
c__0);
if (wantvl) {
chseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vl[
vl_offset], ldvl, &work[1], &c_n1, info);
} else if (wantvr) {
chseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[1], &c_n1, info);
} else {
if (wntsnn) {
chseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &w[1], &
vr[vr_offset], ldvr, &work[1], &c_n1, info);
} else {
chseqr_("S", "N", n, &c__1, n, &a[a_offset], lda, &w[1], &
vr[vr_offset], ldvr, &work[1], &c_n1, info);
}
}
hswork = work[1].r;
if (! wantvl && ! wantvr) {
minwrk = *n << 1;
if (! (wntsnn || wntsne)) {
/* Computing MAX */
i__1 = minwrk, i__2 = *n * *n + (*n << 1);
minwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,hswork);
if (! (wntsnn || wntsne)) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *n + (*n << 1);
maxwrk = max(i__1,i__2);
}
} else {
minwrk = *n << 1;
if (! (wntsnn || wntsne)) {
/* Computing MAX */
i__1 = minwrk, i__2 = *n * *n + (*n << 1);
minwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,hswork);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "CUNGHR",
" ", n, &c__1, n, &c_n1);
maxwrk = max(i__1,i__2);
if (! (wntsnn || wntsne)) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *n + (*n << 1);
maxwrk = max(i__1,i__2);
}
/* Computing MAX */
i__1 = maxwrk, i__2 = *n << 1;
maxwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,minwrk);
}
work[1].r = (real) maxwrk, work[1].i = 0.f;
if (*lwork < minwrk && ! lquery) {
*info = -20;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGEEVX", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
icond = 0;
anrm = clange_("M", n, n, &a[a_offset], lda, dum);
scalea = FALSE_;
if (anrm > 0.f && anrm < smlnum) {
scalea = TRUE_;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE_;
cscale = bignum;
}
if (scalea) {
clascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
ierr);
}
/* Balance the matrix and compute ABNRM */
cgebal_(balanc, n, &a[a_offset], lda, ilo, ihi, &scale[1], &ierr);
*abnrm = clange_("1", n, n, &a[a_offset], lda, dum);
if (scalea) {
dum[0] = *abnrm;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &c__1, &
ierr);
*abnrm = dum[0];
}
/* Reduce to upper Hessenberg form */
/* (CWorkspace: need 2*N, prefer N+N*NB) */
/* (RWorkspace: none) */
itau = 1;
iwrk = itau + *n;
i__1 = *lwork - iwrk + 1;
cgehrd_(n, ilo, ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, &
ierr);
if (wantvl) {
/* Want left eigenvectors */
/* Copy Householder vectors to VL */
*(unsigned char *)side = 'L';
clacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl)
;
/* Generate unitary matrix in VL */
/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
/* (RWorkspace: none) */
i__1 = *lwork - iwrk + 1;
cunghr_(n, ilo, ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], &
i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VL */
/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
/* (RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
chseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &w[1], &vl[
vl_offset], ldvl, &work[iwrk], &i__1, info);
if (wantvr) {
/* Want left and right eigenvectors */
/* Copy Schur vectors to VR */
*(unsigned char *)side = 'B';
clacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
}
} else if (wantvr) {
/* Want right eigenvectors */
/* Copy Householder vectors to VR */
*(unsigned char *)side = 'R';
clacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr)
;
/* Generate unitary matrix in VR */
/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
/* (RWorkspace: none) */
i__1 = *lwork - iwrk + 1;
cunghr_(n, ilo, ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], &
i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VR */
/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
/* (RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
chseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
} else {
/* Compute eigenvalues only */
/* If condition numbers desired, compute Schur form */
if (wntsnn) {
*(unsigned char *)job = 'E';
} else {
*(unsigned char *)job = 'S';
}
/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
/* (RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
chseqr_(job, "N", n, ilo, ihi, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
}
/* If INFO > 0 from CHSEQR, then quit */
if (*info > 0) {
goto L50;
}
if (wantvl || wantvr) {
/* Compute left and/or right eigenvectors */
/* (CWorkspace: need 2*N) */
/* (RWorkspace: need N) */
ctrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
&vr[vr_offset], ldvr, n, &nout, &work[iwrk], &rwork[1], &
ierr);
}
/* Compute condition numbers if desired */
/* (CWorkspace: need N*N+2*N unless SENSE = 'E') */
/* (RWorkspace: need 2*N unless SENSE = 'E') */
if (! wntsnn) {
ctrsna_(sense, "A", select, n, &a[a_offset], lda, &vl[vl_offset],
ldvl, &vr[vr_offset], ldvr, &rconde[1], &rcondv[1], n, &nout,
&work[iwrk], n, &rwork[1], &icond);
}
if (wantvl) {
/* Undo balancing of left eigenvectors */
cgebak_(balanc, "L", n, ilo, ihi, &scale[1], n, &vl[vl_offset], ldvl,
&ierr);
/* Normalize left eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
scl = 1.f / scnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
csscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = k + i__ * vl_dim1;
/* Computing 2nd power */
r__1 = vl[i__3].r;
/* Computing 2nd power */
r__2 = r_imag(&vl[k + i__ * vl_dim1]);
rwork[k] = r__1 * r__1 + r__2 * r__2;
}
k = isamax_(n, &rwork[1], &c__1);
r_cnjg(&q__2, &vl[k + i__ * vl_dim1]);
r__1 = sqrt(rwork[k]);
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
tmp.r = q__1.r, tmp.i = q__1.i;
cscal_(n, &tmp, &vl[i__ * vl_dim1 + 1], &c__1);
i__2 = k + i__ * vl_dim1;
i__3 = k + i__ * vl_dim1;
r__1 = vl[i__3].r;
q__1.r = r__1, q__1.i = 0.f;
vl[i__2].r = q__1.r, vl[i__2].i = q__1.i;
}
}
if (wantvr) {
/* Undo balancing of right eigenvectors */
cgebak_(balanc, "R", n, ilo, ihi, &scale[1], n, &vr[vr_offset], ldvr,
&ierr);
/* Normalize right eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
scl = 1.f / scnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
csscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = k + i__ * vr_dim1;
/* Computing 2nd power */
r__1 = vr[i__3].r;
/* Computing 2nd power */
r__2 = r_imag(&vr[k + i__ * vr_dim1]);
rwork[k] = r__1 * r__1 + r__2 * r__2;
}
k = isamax_(n, &rwork[1], &c__1);
r_cnjg(&q__2, &vr[k + i__ * vr_dim1]);
r__1 = sqrt(rwork[k]);
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
tmp.r = q__1.r, tmp.i = q__1.i;
cscal_(n, &tmp, &vr[i__ * vr_dim1 + 1], &c__1);
i__2 = k + i__ * vr_dim1;
i__3 = k + i__ * vr_dim1;
r__1 = vr[i__3].r;
q__1.r = r__1, q__1.i = 0.f;
vr[i__2].r = q__1.r, vr[i__2].i = q__1.i;
}
}
/* Undo scaling if necessary */
L50:
if (scalea) {
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
clascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[*info + 1]
, &i__2, &ierr);
if (*info == 0) {
if ((wntsnv || wntsnb) && icond == 0) {
slascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &rcondv[
1], n, &ierr);
}
} else {
i__1 = *ilo - 1;
clascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[1], n,
&ierr);
}
}
work[1].r = (real) maxwrk, work[1].i = 0.f;
return 0;
/* End of CGEEVX */
} /* cgeevx_ */
/* Subroutine */ int cchkpt_(logical *dotype, integer *nn, integer *nval,
integer *nns, integer *nsval, real *thresh, logical *tsterr, complex *
a, real *d__, complex *e, complex *b, complex *x, complex *xact,
complex *work, real *rwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
static char uplos[1*2] = "U" "L";
/* Format strings */
static char fmt_9999[] = "(\002 N =\002,i5,\002, type \002,i2,\002, te"
"st \002,i2,\002, ratio = \002,g12.5)";
static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NRHS =\002,i3,\002, type \002,i2,\002, test \002,i2,\002, ratio "
"= \002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
real r__1, r__2;
/* Local variables */
integer i__, j, k, n;
complex z__[3];
integer ia, in, kl, ku, ix, lda;
real cond;
integer mode;
real dmax__;
integer imat, info;
char path[3], dist[1];
integer irhs, nrhs;
char uplo[1], type__[1];
integer nrun;
integer nfail, iseed[4];
real rcond;
integer nimat;
real anorm;
integer iuplo, izero, nerrs;
logical zerot;
real rcondc;
real ainvnm;
real result[7];
/* Fortran I/O blocks */
static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CCHKPT tests CPTTRF, -TRS, -RFS, and -CON */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) COMPLEX array, dimension (NMAX*2) */
/* D (workspace) REAL array, dimension (NMAX*2) */
/* E (workspace) COMPLEX array, dimension (NMAX*2) */
/* B (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
/* XACT (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
/* WORK (workspace) COMPLEX array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) REAL array, dimension */
/* (max(NMAX,2*NSMAX)) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--rwork;
--work;
--xact;
--x;
--b;
--e;
--d__;
--a;
--nsval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "PT", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
cerrgt_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
lda = max(1,n);
nimat = 12;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (n > 0 && ! dotype[imat]) {
goto L110;
}
/* Set up parameters with CLATB4. */
clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cond, dist);
zerot = imat >= 8 && imat <= 10;
if (imat <= 6) {
/* Type 1-6: generate a Hermitian tridiagonal matrix of */
/* known condition number in lower triangular band storage. */
s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
&anorm, &kl, &ku, "B", &a[1], &c__2, &work[1], &info);
/* Check the error code from CLATMS. */
if (info != 0) {
alaerh_(path, "CLATMS", &info, &c__0, " ", &n, &n, &kl, &
ku, &c_n1, &imat, &nfail, &nerrs, nout);
goto L110;
}
izero = 0;
/* Copy the matrix to D and E. */
ia = 1;
i__3 = n - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ia;
d__[i__] = a[i__4].r;
i__4 = i__;
i__5 = ia + 1;
e[i__4].r = a[i__5].r, e[i__4].i = a[i__5].i;
ia += 2;
/* L20: */
}
if (n > 0) {
i__3 = ia;
d__[n] = a[i__3].r;
}
} else {
/* Type 7-12: generate a diagonally dominant matrix with */
/* unknown condition number in the vectors D and E. */
if (! zerot || ! dotype[7]) {
/* Let E be complex, D real, with values from [-1,1]. */
slarnv_(&c__2, iseed, &n, &d__[1]);
i__3 = n - 1;
clarnv_(&c__2, iseed, &i__3, &e[1]);
/* Make the tridiagonal matrix diagonally dominant. */
if (n == 1) {
d__[1] = dabs(d__[1]);
} else {
d__[1] = dabs(d__[1]) + c_abs(&e[1]);
d__[n] = (r__1 = d__[n], dabs(r__1)) + c_abs(&e[n - 1]
);
i__3 = n - 1;
for (i__ = 2; i__ <= i__3; ++i__) {
d__[i__] = (r__1 = d__[i__], dabs(r__1)) + c_abs(&
e[i__]) + c_abs(&e[i__ - 1]);
/* L30: */
}
}
/* Scale D and E so the maximum element is ANORM. */
ix = isamax_(&n, &d__[1], &c__1);
dmax__ = d__[ix];
r__1 = anorm / dmax__;
sscal_(&n, &r__1, &d__[1], &c__1);
i__3 = n - 1;
r__1 = anorm / dmax__;
csscal_(&i__3, &r__1, &e[1], &c__1);
} else if (izero > 0) {
/* Reuse the last matrix by copying back the zeroed out */
/* elements. */
if (izero == 1) {
d__[1] = z__[1].r;
if (n > 1) {
e[1].r = z__[2].r, e[1].i = z__[2].i;
}
} else if (izero == n) {
i__3 = n - 1;
e[i__3].r = z__[0].r, e[i__3].i = z__[0].i;
i__3 = n;
d__[i__3] = z__[1].r;
} else {
i__3 = izero - 1;
e[i__3].r = z__[0].r, e[i__3].i = z__[0].i;
i__3 = izero;
d__[i__3] = z__[1].r;
i__3 = izero;
e[i__3].r = z__[2].r, e[i__3].i = z__[2].i;
}
}
/* For types 8-10, set one row and column of the matrix to */
/* zero. */
izero = 0;
if (imat == 8) {
izero = 1;
z__[1].r = d__[1], z__[1].i = 0.f;
d__[1] = 0.f;
if (n > 1) {
z__[2].r = e[1].r, z__[2].i = e[1].i;
e[1].r = 0.f, e[1].i = 0.f;
}
} else if (imat == 9) {
izero = n;
if (n > 1) {
i__3 = n - 1;
z__[0].r = e[i__3].r, z__[0].i = e[i__3].i;
i__3 = n - 1;
e[i__3].r = 0.f, e[i__3].i = 0.f;
}
i__3 = n;
z__[1].r = d__[i__3], z__[1].i = 0.f;
d__[n] = 0.f;
} else if (imat == 10) {
izero = (n + 1) / 2;
if (izero > 1) {
i__3 = izero - 1;
z__[0].r = e[i__3].r, z__[0].i = e[i__3].i;
i__3 = izero;
z__[2].r = e[i__3].r, z__[2].i = e[i__3].i;
i__3 = izero - 1;
e[i__3].r = 0.f, e[i__3].i = 0.f;
i__3 = izero;
e[i__3].r = 0.f, e[i__3].i = 0.f;
}
i__3 = izero;
z__[1].r = d__[i__3], z__[1].i = 0.f;
d__[izero] = 0.f;
}
}
scopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
if (n > 1) {
i__3 = n - 1;
ccopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
}
/* + TEST 1 */
/* Factor A as L*D*L' and compute the ratio */
/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
cpttrf_(&n, &d__[n + 1], &e[n + 1], &info);
/* Check error code from CPTTRF. */
if (info != izero) {
alaerh_(path, "CPTTRF", &info, &izero, " ", &n, &n, &c_n1, &
c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L110;
}
if (info > 0) {
rcondc = 0.f;
goto L100;
}
cptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &work[1],
result);
/* Print the test ratio if greater than or equal to THRESH. */
if (result[0] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___30.ciunit = *nout;
s_wsfe(&io___30);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(real));
e_wsfe();
++nfail;
}
++nrun;
/* Compute RCONDC = 1 / (norm(A) * norm(inv(A)) */
/* Compute norm(A). */
anorm = clanht_("1", &n, &d__[1], &e[1]);
/* Use CPTTRS to solve for one column at a time of inv(A), */
/* computing the maximum column sum as we go. */
ainvnm = 0.f;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
i__5 = j;
x[i__5].r = 0.f, x[i__5].i = 0.f;
/* L40: */
}
i__4 = i__;
x[i__4].r = 1.f, x[i__4].i = 0.f;
cpttrs_("Lower", &n, &c__1, &d__[n + 1], &e[n + 1], &x[1], &
lda, &info);
/* Computing MAX */
r__1 = ainvnm, r__2 = scasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* L50: */
}
/* Computing MAX */
r__1 = 1.f, r__2 = anorm * ainvnm;
rcondc = 1.f / dmax(r__1,r__2);
i__3 = *nns;
for (irhs = 1; irhs <= i__3; ++irhs) {
nrhs = nsval[irhs];
/* Generate NRHS random solution vectors. */
ix = 1;
i__4 = nrhs;
for (j = 1; j <= i__4; ++j) {
clarnv_(&c__2, iseed, &n, &xact[ix]);
ix += lda;
/* L60: */
}
for (iuplo = 1; iuplo <= 2; ++iuplo) {
/* Do first for UPLO = 'U', then for UPLO = 'L'. */
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
1];
/* Set the right hand side. */
claptm_(uplo, &n, &nrhs, &c_b48, &d__[1], &e[1], &xact[1],
&lda, &c_b49, &b[1], &lda);
/* + TEST 2 */
/* Solve A*x = b and compute the residual. */
clacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
cpttrs_(uplo, &n, &nrhs, &d__[n + 1], &e[n + 1], &x[1], &
lda, &info);
/* Check error code from CPTTRS. */
if (info != 0) {
alaerh_(path, "CPTTRS", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
clacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
cptt02_(uplo, &n, &nrhs, &d__[1], &e[1], &x[1], &lda, &
work[1], &lda, &result[1]);
/* + TEST 3 */
/* Check solution from generated exact solution. */
cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[2]);
/* + TESTS 4, 5, and 6 */
/* Use iterative refinement to improve the solution. */
s_copy(srnamc_1.srnamt, "CPTRFS", (ftnlen)32, (ftnlen)6);
cptrfs_(uplo, &n, &nrhs, &d__[1], &e[1], &d__[n + 1], &e[
n + 1], &b[1], &lda, &x[1], &lda, &rwork[1], &
rwork[nrhs + 1], &work[1], &rwork[(nrhs << 1) + 1]
, &info);
/* Check error code from CPTRFS. */
if (info != 0) {
alaerh_(path, "CPTRFS", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[3]);
cptt05_(&n, &nrhs, &d__[1], &e[1], &b[1], &lda, &x[1], &
lda, &xact[1], &lda, &rwork[1], &rwork[nrhs + 1],
&result[4]);
/* Print information about the tests that did not pass the */
/* threshold. */
for (k = 2; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L70: */
}
nrun += 5;
/* L80: */
}
/* L90: */
}
/* + TEST 7 */
/* Estimate the reciprocal of the condition number of the */
/* matrix. */
L100:
s_copy(srnamc_1.srnamt, "CPTCON", (ftnlen)32, (ftnlen)6);
cptcon_(&n, &d__[n + 1], &e[n + 1], &anorm, &rcond, &rwork[1], &
info);
/* Check error code from CPTCON. */
if (info != 0) {
alaerh_(path, "CPTCON", &info, &c__0, " ", &n, &n, &c_n1, &
c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
}
result[6] = sget06_(&rcond, &rcondc);
/* Print the test ratio if greater than or equal to THRESH. */
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(real));
e_wsfe();
++nfail;
}
++nrun;
L110:
;
}
/* L120: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of CCHKPT */
} /* cchkpt_ */
/* Subroutine */ int clatrs_(char *uplo, char *trans, char *diag, char *
normin, integer *n, complex *a, integer *lda, complex *x, real *scale,
real *cnorm, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
integer i__, j;
real xj, rec, tjj;
integer jinc;
real xbnd;
integer imax;
real tmax;
complex tjjs;
real xmax, grow;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
real tscal;
complex uscal;
integer jlast;
extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
*, complex *, integer *);
complex csumj;
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
logical upper;
extern /* Subroutine */ int ctrsv_(char *, char *, char *, integer *,
complex *, integer *, complex *, integer *), slabad_(real *, real *);
extern integer icamax_(integer *, complex *, integer *);
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), xerbla_(char *, integer *);
real bignum;
extern integer isamax_(integer *, real *, integer *);
extern doublereal scasum_(integer *, complex *, integer *);
logical notran;
integer jfirst;
real smlnum;
logical nounit;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLATRS 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 */
/* CTRSV 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 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 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) REAL */
/* 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) REAL 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, CTRSV */
/* 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] */
/* for j = 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] */
/* Initially, let M(0) = 0 and G(0) = max{x(i), i=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 CTRSV if the */
/* reciprocal of the largest M(j), j=1,..,n, is larger than */
/* 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 */
/* for j = 1, ..., n */
/* 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 */
/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */
/* 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 CTRSV if 1/M(n) and 1/G(n) are both greater */
/* than max(underflow, 1/overflow). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* 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_("CLATRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine machine dependent parameters to control overflow. */
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum /= slamch_("Precision");
bignum = 1.f / smlnum;
*scale = 1.f;
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] = scasum_(&i__2, &a[j * a_dim1 + 1], &c__1);
/* L10: */
}
} else {
/* A is lower triangular. */
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j;
cnorm[j] = scasum_(&i__2, &a[j + 1 + j * a_dim1], &c__1);
/* L20: */
}
cnorm[*n] = 0.f;
}
}
/* Scale the column norms by TSCAL if the maximum element in CNORM is */
/* greater than BIGNUM/2. */
imax = isamax_(n, &cnorm[1], &c__1);
tmax = cnorm[imax];
if (tmax <= bignum * .5f) {
tscal = 1.f;
} else {
tscal = .5f / (smlnum * tmax);
sscal_(n, &tscal, &cnorm[1], &c__1);
}
/* Compute a bound on the computed solution vector to see if the */
/* Level 2 BLAS routine CTRSV can be used. */
xmax = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = j;
r__3 = xmax, r__4 = (r__1 = x[i__2].r / 2.f, dabs(r__1)) + (r__2 =
r_imag(&x[j]) / 2.f, dabs(r__2));
xmax = dmax(r__3,r__4);
/* L30: */
}
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.f) {
grow = 0.f;
goto L60;
}
if (nounit) {
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
/* Initially, G(0) = max{x(i), i=1,...,n}. */
grow = .5f / dmax(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 = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj >= smlnum) {
/* M(j) = G(j-1) / abs(A(j,j)) */
/* Computing MIN */
r__1 = xbnd, r__2 = dmin(1.f,tjj) * grow;
xbnd = dmin(r__1,r__2);
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.f;
}
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.f;
}
/* L40: */
}
grow = xbnd;
} else {
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
/* Computing MIN */
r__1 = 1.f, r__2 = .5f / dmax(xbnd,smlnum);
grow = dmin(r__1,r__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.f / (cnorm[j] + 1.f);
/* L50: */
}
}
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.f) {
grow = 0.f;
goto L90;
}
if (nounit) {
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
/* Initially, M(0) = max{x(i), i=1,...,n}. */
grow = .5f / dmax(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.f;
/* Computing MIN */
r__1 = grow, r__2 = xbnd / xj;
grow = dmin(r__1,r__2);
i__3 = j + j * a_dim1;
tjjs.r = a[i__3].r, tjjs.i = a[i__3].i;
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__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.f;
}
/* L70: */
}
grow = dmin(grow,xbnd);
} else {
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
/* Computing MIN */
r__1 = 1.f, r__2 = .5f / dmax(xbnd,smlnum);
grow = dmin(r__1,r__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.f;
grow /= xj;
/* L80: */
}
}
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. */
ctrsv_(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 * .5f) {
/* Scale X so that its components are less than or equal to */
/* BIGNUM in absolute value. */
*scale = bignum * .5f / xmax;
csscal_(n, scale, &x[1], &c__1);
xmax = bignum;
} else {
xmax *= 2.f;
}
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 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
dabs(r__2));
if (nounit) {
i__3 = j + j * a_dim1;
q__1.r = tscal * a[i__3].r, q__1.i = tscal * a[i__3].i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
if (tscal == 1.f) {
goto L105;
}
}
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f) {
if (xj > tjj * bignum) {
/* Scale x by 1/b(j). */
rec = 1.f / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
} else if (tjj > 0.f) {
/* 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.f) {
/* Scale by 1/CNORM(j) to avoid overflow when */
/* multiplying x(j) times column j. */
rec /= cnorm[j];
}
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__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.f, x[i__4].i = 0.f;
/* L100: */
}
i__3 = j;
x[i__3].r = 1.f, x[i__3].i = 0.f;
xj = 1.f;
*scale = 0.f;
xmax = 0.f;
}
L105:
/* Scale x if necessary to avoid overflow when adding a */
/* multiple of column j of A. */
if (xj > 1.f) {
rec = 1.f / xj;
if (cnorm[j] > (bignum - xmax) * rec) {
/* Scale x by 1/(2*abs(x(j))). */
rec *= .5f;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
} else if (xj * cnorm[j] > bignum - xmax) {
/* Scale x by 1/2. */
csscal_(n, &c_b36, &x[1], &c__1);
*scale *= .5f;
}
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;
q__2.r = -x[i__4].r, q__2.i = -x[i__4].i;
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
caxpy_(&i__3, &q__1, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
i__3 = j - 1;
i__ = icamax_(&i__3, &x[1], &c__1);
i__3 = i__;
xmax = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[i__]), dabs(r__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;
q__2.r = -x[i__4].r, q__2.i = -x[i__4].i;
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
caxpy_(&i__3, &q__1, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
i__3 = *n - j;
i__ = j + icamax_(&i__3, &x[j + 1], &c__1);
i__3 = i__;
xmax = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[i__]), dabs(r__2));
}
}
/* L110: */
}
} 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 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
dabs(r__2));
uscal.r = tscal, uscal.i = 0.f;
rec = 1.f / dmax(xmax,1.f);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5f;
if (nounit) {
i__3 = j + j * a_dim1;
q__1.r = tscal * a[i__3].r, q__1.i = tscal * a[i__3]
.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
}
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > 1.f) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
r__1 = 1.f, r__2 = rec * tjj;
rec = dmin(r__1,r__2);
cladiv_(&q__1, &uscal, &tjjs);
uscal.r = q__1.r, uscal.i = q__1.i;
}
if (rec < 1.f) {
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0.f, csumj.i = 0.f;
if (uscal.r == 1.f && uscal.i == 0.f) {
/* If the scaling needed for A in the dot product is 1, */
/* call CDOTU to perform the dot product. */
if (upper) {
i__3 = j - 1;
cdotu_(&q__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
} else if (j < *n) {
i__3 = *n - j;
cdotu_(&q__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
csumj.r = q__1.r, csumj.i = q__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;
q__3.r = a[i__4].r * uscal.r - a[i__4].i *
uscal.i, q__3.i = a[i__4].r * uscal.i + a[
i__4].i * uscal.r;
i__5 = i__;
q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i,
q__2.i = q__3.r * x[i__5].i + q__3.i * x[
i__5].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L120: */
}
} else if (j < *n) {
i__3 = *n;
for (i__ = j + 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * a_dim1;
q__3.r = a[i__4].r * uscal.r - a[i__4].i *
uscal.i, q__3.i = a[i__4].r * uscal.i + a[
i__4].i * uscal.r;
i__5 = i__;
q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i,
q__2.i = q__3.r * x[i__5].i + q__3.i * x[
i__5].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L130: */
}
}
}
q__1.r = tscal, q__1.i = 0.f;
if (uscal.r == q__1.r && uscal.i == q__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;
q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i -
csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
if (nounit) {
i__3 = j + j * a_dim1;
q__1.r = tscal * a[i__3].r, q__1.i = tscal * a[i__3]
.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
if (tscal == 1.f) {
goto L145;
}
}
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f) {
if (xj > tjj * bignum) {
/* Scale X by 1/abs(x(j)). */
rec = 1.f / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} else if (tjj > 0.f) {
/* 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;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__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.f, x[i__4].i = 0.f;
/* L140: */
}
i__3 = j;
x[i__3].r = 1.f, x[i__3].i = 0.f;
*scale = 0.f;
xmax = 0.f;
}
L145:
;
} 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;
cladiv_(&q__2, &x[j], &tjjs);
q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
}
/* Computing MAX */
i__3 = j;
r__3 = xmax, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[j]), dabs(r__2));
xmax = dmax(r__3,r__4);
/* L150: */
}
} 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 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
dabs(r__2));
uscal.r = tscal, uscal.i = 0.f;
rec = 1.f / dmax(xmax,1.f);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5f;
if (nounit) {
r_cnjg(&q__2, &a[j + j * a_dim1]);
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
}
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > 1.f) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
r__1 = 1.f, r__2 = rec * tjj;
rec = dmin(r__1,r__2);
cladiv_(&q__1, &uscal, &tjjs);
uscal.r = q__1.r, uscal.i = q__1.i;
}
if (rec < 1.f) {
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0.f, csumj.i = 0.f;
if (uscal.r == 1.f && uscal.i == 0.f) {
/* If the scaling needed for A in the dot product is 1, */
/* call CDOTC to perform the dot product. */
if (upper) {
i__3 = j - 1;
cdotc_(&q__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
} else if (j < *n) {
i__3 = *n - j;
cdotc_(&q__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
csumj.r = q__1.r, csumj.i = q__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__) {
r_cnjg(&q__4, &a[i__ + j * a_dim1]);
q__3.r = q__4.r * uscal.r - q__4.i * uscal.i,
q__3.i = q__4.r * uscal.i + q__4.i *
uscal.r;
i__4 = i__;
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i,
q__2.i = q__3.r * x[i__4].i + q__3.i * x[
i__4].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L160: */
}
} else if (j < *n) {
i__3 = *n;
for (i__ = j + 1; i__ <= i__3; ++i__) {
r_cnjg(&q__4, &a[i__ + j * a_dim1]);
q__3.r = q__4.r * uscal.r - q__4.i * uscal.i,
q__3.i = q__4.r * uscal.i + q__4.i *
uscal.r;
i__4 = i__;
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i,
q__2.i = q__3.r * x[i__4].i + q__3.i * x[
i__4].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L170: */
}
}
}
q__1.r = tscal, q__1.i = 0.f;
if (uscal.r == q__1.r && uscal.i == q__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;
q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i -
csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
if (nounit) {
r_cnjg(&q__2, &a[j + j * a_dim1]);
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
if (tscal == 1.f) {
goto L185;
}
}
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f) {
if (xj > tjj * bignum) {
/* Scale X by 1/abs(x(j)). */
rec = 1.f / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} else if (tjj > 0.f) {
/* 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;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__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.f, x[i__4].i = 0.f;
/* L180: */
}
i__3 = j;
x[i__3].r = 1.f, x[i__3].i = 0.f;
*scale = 0.f;
xmax = 0.f;
}
L185:
;
} 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;
cladiv_(&q__2, &x[j], &tjjs);
q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
}
/* Computing MAX */
i__3 = j;
r__3 = xmax, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[j]), dabs(r__2));
xmax = dmax(r__3,r__4);
/* L190: */
}
}
*scale /= tscal;
}
/* Scale the column norms by 1/TSCAL for return. */
if (tscal != 1.f) {
r__1 = 1.f / tscal;
sscal_(n, &r__1, &cnorm[1], &c__1);
}
return 0;
/* End of CLATRS */
} /* clatrs_ */
void csscal( int n, float alpha, complex *x, int incx)
{
csscal_(&n, &alpha, x, &incx);
}
