inline size_t amax(size_t N, const std::complex<float> * x)
{
lapack_int num = (lapack_int)(N);
lapack_int incx = 1;
return icamax_(&num, (lapack_complex_float*)(x), &incx);
}
CBLAS_INDEX cblas_icamax( const integer N, const void *X, const integer incX)
{
integer iamax;
#define F77_N N
#define F77_incX incX
iamax = icamax_( &F77_N, X, &F77_incX );
return iamax ? iamax-1 : 0;
}
/* Subroutine */ int ctpt05_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, complex *ap, complex *b, integer *ldb, complex *x,
integer *ldx, complex *xact, integer *ldxact, real *ferr, real *berr,
real *reslts)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, xact_dim1, xact_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;
/* Local variables */
integer i__, j, k, jc, ifu;
real eps, tmp, diff, axbi;
integer imax;
real unfl, ovfl;
logical unit;
logical upper;
real xnorm;
real errbnd;
logical notran;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CTPT05 tests the error bounds from iterative refinement for the */
/* computed solution to a system of equations A*X = B, where A is a */
/* triangular matrix in packed storage format. */
/* RESLTS(1) = test of the error bound */
/* = norm(X - XACT) / ( norm(X) * FERR ) */
/* A large value is returned if this ratio is not less than one. */
/* RESLTS(2) = residual from the iterative refinement routine */
/* = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Specifies the form of the system of equations. */
/* = 'N': A * X = B (No transpose) */
/* = 'T': A'* X = B (Transpose) */
/* = 'C': A'* X = B (Conjugate transpose = Transpose) */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* N (input) INTEGER */
/* The number of rows of the matrices X, B, and XACT, and the */
/* order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of columns of the matrices X, B, and XACT. */
/* NRHS >= 0. */
/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
/* The upper or lower triangular 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. */
/* If DIAG = 'U', the diagonal elements of A are not referenced */
/* and are assumed to be 1. */
/* 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). */
/* X (input) COMPLEX array, dimension (LDX,NRHS) */
/* The computed solution vectors. Each vector is stored as a */
/* column of the matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* XACT (input) COMPLEX array, dimension (LDX,NRHS) */
/* The exact solution vectors. Each vector is stored as a */
/* column of the matrix XACT. */
/* LDXACT (input) INTEGER */
/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
/* FERR (input) REAL array, dimension (NRHS) */
/* The estimated forward error bounds for each solution vector */
/* X. If XTRUE is the true solution, FERR bounds the magnitude */
/* of the largest entry in (X - XTRUE) divided by the magnitude */
/* of the largest entry in X. */
/* BERR (input) REAL array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector (i.e., the smallest relative change in any entry of A */
/* or B that makes X an exact solution). */
/* RESLTS (output) REAL array, dimension (2) */
/* The maximum over the NRHS solution vectors of the ratios: */
/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
/* RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 or NRHS = 0. */
/* Parameter adjustments */
--ap;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
xact_dim1 = *ldxact;
xact_offset = 1 + xact_dim1;
xact -= xact_offset;
--ferr;
--berr;
--reslts;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
reslts[1] = 0.f;
reslts[2] = 0.f;
return 0;
}
eps = slamch_("Epsilon");
unfl = slamch_("Safe minimum");
ovfl = 1.f / unfl;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
unit = lsame_(diag, "U");
/* Test 1: Compute the maximum of */
/* norm(X - XACT) / ( norm(X) * FERR ) */
/* over all the vectors X and XACT using the infinity-norm. */
errbnd = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
imax = icamax_(n, &x[j * x_dim1 + 1], &c__1);
/* Computing MAX */
i__2 = imax + j * x_dim1;
r__3 = (r__1 = x[i__2].r, dabs(r__1)) + (r__2 = r_imag(&x[imax + j *
x_dim1]), dabs(r__2));
xnorm = dmax(r__3,unfl);
diff = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * x_dim1;
i__4 = i__ + j * xact_dim1;
q__2.r = x[i__3].r - xact[i__4].r, q__2.i = x[i__3].i - xact[i__4]
.i;
q__1.r = q__2.r, q__1.i = q__2.i;
/* Computing MAX */
r__3 = diff, r__4 = (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&
q__1), dabs(r__2));
diff = dmax(r__3,r__4);
/* L10: */
}
if (xnorm > 1.f) {
goto L20;
} else if (diff <= ovfl * xnorm) {
goto L20;
} else {
errbnd = 1.f / eps;
goto L30;
}
L20:
if (diff / xnorm <= ferr[j]) {
/* Computing MAX */
r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
errbnd = dmax(r__1,r__2);
} else {
errbnd = 1.f / eps;
}
L30:
;
}
reslts[1] = errbnd;
/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
ifu = 0;
if (unit) {
ifu = 1;
}
i__1 = *nrhs;
for (k = 1; k <= i__1; ++k) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + k * b_dim1;
tmp = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[i__ + k *
b_dim1]), dabs(r__2));
if (upper) {
jc = (i__ - 1) * i__ / 2;
if (! notran) {
i__3 = i__ - ifu;
for (j = 1; j <= i__3; ++j) {
i__4 = jc + j;
i__5 = j + k * x_dim1;
tmp += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&ap[jc + j]), dabs(r__2))) * ((r__3 =
x[i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[j
+ k * x_dim1]), dabs(r__4)));
/* L40: */
}
if (unit) {
i__3 = i__ + k * x_dim1;
tmp += (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[i__ + k * x_dim1]), dabs(r__2));
}
} else {
jc += i__;
if (unit) {
i__3 = i__ + k * x_dim1;
tmp += (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[i__ + k * x_dim1]), dabs(r__2));
jc += i__;
}
i__3 = *n;
for (j = i__ + ifu; j <= i__3; ++j) {
i__4 = jc;
i__5 = j + k * x_dim1;
tmp += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&ap[jc]), dabs(r__2))) * ((r__3 = x[
i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[j +
k * x_dim1]), dabs(r__4)));
jc += j;
/* L50: */
}
}
} else {
if (notran) {
jc = i__;
i__3 = i__ - ifu;
for (j = 1; j <= i__3; ++j) {
i__4 = jc;
i__5 = j + k * x_dim1;
tmp += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&ap[jc]), dabs(r__2))) * ((r__3 = x[
i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[j +
k * x_dim1]), dabs(r__4)));
jc = jc + *n - j;
/* L60: */
}
if (unit) {
i__3 = i__ + k * x_dim1;
tmp += (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[i__ + k * x_dim1]), dabs(r__2));
}
} else {
jc = (i__ - 1) * (*n - i__) + i__ * (i__ + 1) / 2;
if (unit) {
i__3 = i__ + k * x_dim1;
tmp += (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[i__ + k * x_dim1]), dabs(r__2));
}
i__3 = *n;
for (j = i__ + ifu; j <= i__3; ++j) {
i__4 = jc + j - i__;
i__5 = j + k * x_dim1;
tmp += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&ap[jc + j - i__]), dabs(r__2))) * ((
r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
r_imag(&x[j + k * x_dim1]), dabs(r__4)));
/* L70: */
}
}
}
if (i__ == 1) {
axbi = tmp;
} else {
axbi = dmin(axbi,tmp);
}
/* L80: */
}
/* Computing MAX */
r__1 = axbi, r__2 = (*n + 1) * unfl;
tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / dmax(r__1,r__2));
if (k == 1) {
reslts[2] = tmp;
} else {
reslts[2] = dmax(reslts[2],tmp);
}
/* L90: */
}
return 0;
/* End of CTPT05 */
} /* ctpt05_ */
/* Subroutine */ int cgbt05_(char *trans, integer *n, integer *kl, integer *
ku, integer *nrhs, complex *ab, integer *ldab, complex *b, integer *
ldb, complex *x, integer *ldx, complex *xact, integer *ldxact, real *
ferr, real *berr, real *reslts)
{
/* System generated locals */
integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
xact_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1, q__2;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static real diff, axbi;
static integer imax;
static real unfl, ovfl;
static integer i__, j, k;
extern logical lsame_(char *, char *);
static real xnorm;
extern integer icamax_(integer *, complex *, integer *);
extern doublereal slamch_(char *);
static integer nz;
static real errbnd;
static logical notran;
static real eps, tmp;
#define xact_subscr(a_1,a_2) (a_2)*xact_dim1 + a_1
#define xact_ref(a_1,a_2) xact[xact_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 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
=======
CGBT05 tests the error bounds from iterative refinement for the
computed solution to a system of equations op(A)*X = B, where A is a
general band matrix of order n with kl subdiagonals and ku
superdiagonals and op(A) = A or A**T, depending on TRANS.
RESLTS(1) = test of the error bound
= norm(X - XACT) / ( norm(X) * FERR )
A large value is returned if this ratio is not less than one.
RESLTS(2) = residual from the iterative refinement routine
= the maximum of BERR / ( NZ*EPS + (*) ), where
(*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
and NZ = max. number of nonzeros in any row of A, plus 1
Arguments
=========
TRANS (input) CHARACTER*1
Specifies the form of the system of equations.
= 'N': A * X = B (No transpose)
= 'T': A**T * X = B (Transpose)
= 'C': A**H * X = B (Conjugate transpose = Transpose)
N (input) INTEGER
The number of rows of the matrices X, B, and XACT, and the
order of the matrix A. N >= 0.
KL (input) INTEGER
The number of subdiagonals within the band of A. KL >= 0.
KU (input) INTEGER
The number of superdiagonals within the band of A. KU >= 0.
NRHS (input) INTEGER
The number of columns of the matrices X, B, and XACT.
NRHS >= 0.
AB (input) COMPLEX array, dimension (LDAB,N)
The original band matrix A, stored in rows 1 to KL+KU+1.
The j-th column of A is stored in the j-th column of the
array AB as follows:
AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KL+KU+1.
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).
X (input) COMPLEX array, dimension (LDX,NRHS)
The computed solution vectors. Each vector is stored as a
column of the matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
XACT (input) COMPLEX array, dimension (LDX,NRHS)
The exact solution vectors. Each vector is stored as a
column of the matrix XACT.
LDXACT (input) INTEGER
The leading dimension of the array XACT. LDXACT >= max(1,N).
FERR (input) REAL array, dimension (NRHS)
The estimated forward error bounds for each solution vector
X. If XTRUE is the true solution, FERR bounds the magnitude
of the largest entry in (X - XTRUE) divided by the magnitude
of the largest entry in X.
BERR (input) REAL array, dimension (NRHS)
The componentwise relative backward error of each solution
vector (i.e., the smallest relative change in any entry of A
or B that makes X an exact solution).
RESLTS (output) REAL array, dimension (2)
The maximum over the NRHS solution vectors of the ratios:
RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
RESLTS(2) = BERR / ( NZ*EPS + (*) )
=====================================================================
Quick exit if N = 0 or NRHS = 0.
Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
xact_dim1 = *ldxact;
xact_offset = 1 + xact_dim1 * 1;
xact -= xact_offset;
--ferr;
--berr;
--reslts;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
reslts[1] = 0.f;
reslts[2] = 0.f;
return 0;
}
eps = slamch_("Epsilon");
unfl = slamch_("Safe minimum");
ovfl = 1.f / unfl;
notran = lsame_(trans, "N");
/* Computing MIN */
i__1 = *kl + *ku + 2, i__2 = *n + 1;
nz = min(i__1,i__2);
/* Test 1: Compute the maximum of
norm(X - XACT) / ( norm(X) * FERR )
over all the vectors X and XACT using the infinity-norm. */
errbnd = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
imax = icamax_(n, &x_ref(1, j), &c__1);
/* Computing MAX */
i__2 = x_subscr(imax, j);
r__3 = (r__1 = x[i__2].r, dabs(r__1)) + (r__2 = r_imag(&x_ref(imax, j)
), dabs(r__2));
xnorm = dmax(r__3,unfl);
diff = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = x_subscr(i__, j);
i__4 = xact_subscr(i__, j);
q__2.r = x[i__3].r - xact[i__4].r, q__2.i = x[i__3].i - xact[i__4]
.i;
q__1.r = q__2.r, q__1.i = q__2.i;
/* Computing MAX */
r__3 = diff, r__4 = (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&
q__1), dabs(r__2));
diff = dmax(r__3,r__4);
/* L10: */
}
if (xnorm > 1.f) {
goto L20;
} else if (diff <= ovfl * xnorm) {
goto L20;
} else {
errbnd = 1.f / eps;
goto L30;
}
L20:
if (diff / xnorm <= ferr[j]) {
/* Computing MAX */
r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
errbnd = dmax(r__1,r__2);
} else {
errbnd = 1.f / eps;
}
L30:
;
}
reslts[1] = errbnd;
/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where
(*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
i__1 = *nrhs;
for (k = 1; k <= i__1; ++k) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, k);
tmp = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(i__,
k)), dabs(r__2));
if (notran) {
/* Computing MAX */
i__3 = i__ - *kl;
/* Computing MIN */
i__5 = i__ + *ku;
i__4 = min(i__5,*n);
for (j = max(i__3,1); j <= i__4; ++j) {
i__3 = ab_subscr(*ku + 1 + i__ - j, j);
i__5 = x_subscr(j, k);
tmp += ((r__1 = ab[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
ab_ref(*ku + 1 + i__ - j, j)), dabs(r__2))) * ((
r__3 = x[i__5].r, dabs(r__3)) + (r__4 = r_imag(&
x_ref(j, k)), dabs(r__4)));
/* L40: */
}
} else {
/* Computing MAX */
i__4 = i__ - *ku;
/* Computing MIN */
i__5 = i__ + *kl;
i__3 = min(i__5,*n);
for (j = max(i__4,1); j <= i__3; ++j) {
i__4 = ab_subscr(*ku + 1 + j - i__, i__);
i__5 = x_subscr(j, k);
tmp += ((r__1 = ab[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
ab_ref(*ku + 1 + j - i__, i__)), dabs(r__2))) * ((
r__3 = x[i__5].r, dabs(r__3)) + (r__4 = r_imag(&
x_ref(j, k)), dabs(r__4)));
/* L50: */
}
}
if (i__ == 1) {
axbi = tmp;
} else {
axbi = dmin(axbi,tmp);
}
/* L60: */
}
/* Computing MAX */
r__1 = axbi, r__2 = nz * unfl;
tmp = berr[k] / (nz * eps + nz * unfl / dmax(r__1,r__2));
if (k == 1) {
reslts[2] = tmp;
} else {
reslts[2] = dmax(reslts[2],tmp);
}
/* L70: */
}
return 0;
/* End of CGBT05 */
} /* cgbt05_ */
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 cppcon_(char *uplo, integer *n, complex *ap, real *anorm,
real *rcond, complex *work, real *rwork, integer *info)
{
/* System generated locals */
integer i__1;
real r__1, r__2;
/* Local variables */
integer ix, kase;
real scale;
integer isave[3];
logical upper;
real scalel;
real scaleu;
real ainvnm;
char normin[1];
real smlnum;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
/* Purpose */
/* ======= */
/* CPPCON estimates the reciprocal of the condition number (in the */
/* 1-norm) of a complex Hermitian positive definite packed matrix using */
/* the Cholesky factorization A = U**H*U or A = L*L**H computed by */
/* CPPTRF. */
/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
/* 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) COMPLEX array, dimension (N*(N+1)/2) */
/* The triangular factor U or L from the Cholesky factorization */
/* A = U**H*U or A = L*L**H, packed columnwise in a linear */
/* array. The j-th column of U or L is stored in the array AP */
/* as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */
/* ANORM (input) REAL */
/* The 1-norm (or infinity-norm) of the Hermitian matrix A. */
/* RCOND (output) REAL */
/* The reciprocal of the condition number of the matrix A, */
/* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */
/* estimate of the 1-norm of inv(A) computed in this routine. */
/* 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 */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
--rwork;
--work;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*anorm < 0.f) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CPPCON", &i__1);
return 0;
}
/* Quick return if possible */
*rcond = 0.f;
if (*n == 0) {
*rcond = 1.f;
return 0;
} else if (*anorm == 0.f) {
return 0;
}
smlnum = slamch_("Safe minimum");
/* Estimate the 1-norm of the inverse. */
kase = 0;
*(unsigned char *)normin = 'N';
L10:
clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
if (kase != 0) {
if (upper) {
/* Multiply by inv(U'). */
clatps_("Upper", "Conjugate transpose", "Non-unit", normin, n, &
ap[1], &work[1], &scalel, &rwork[1], info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(U). */
clatps_("Upper", "No transpose", "Non-unit", normin, n, &ap[1], &
work[1], &scaleu, &rwork[1], info);
} else {
/* Multiply by inv(L). */
clatps_("Lower", "No transpose", "Non-unit", normin, n, &ap[1], &
work[1], &scalel, &rwork[1], info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(L'). */
clatps_("Lower", "Conjugate transpose", "Non-unit", normin, n, &
ap[1], &work[1], &scaleu, &rwork[1], info);
}
/* Multiply by 1/SCALE if doing so will not cause overflow. */
scale = scalel * scaleu;
if (scale != 1.f) {
ix = icamax_(n, &work[1], &c__1);
i__1 = ix;
if (scale < ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
work[ix]), dabs(r__2))) * smlnum || scale == 0.f) {
goto L20;
}
csrscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f) {
*rcond = 1.f / ainvnm / *anorm;
}
L20:
return 0;
/* End of CPPCON */
} /* cppcon_ */
/* Subroutine */ int cgecon_(char *norm, integer *n, complex *a, integer *lda,
real *anorm, real *rcond, complex *work, real *rwork, integer *info,
ftnlen norm_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1;
real r__1, r__2;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static real sl;
static integer ix;
static real su;
static integer kase, kase1;
static real scale;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real
*, integer *);
extern integer icamax_(integer *, complex *, integer *);
extern doublereal slamch_(char *, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
static real ainvnm;
extern /* Subroutine */ int clatrs_(char *, char *, char *, char *,
integer *, complex *, integer *, complex *, real *, real *,
integer *, ftnlen, ftnlen, ftnlen, ftnlen), csrscl_(integer *,
real *, complex *, integer *);
static logical onenrm;
static char normin[1];
static real smlnum;
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* March 31, 1993 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGECON estimates the reciprocal of the condition number of a general */
/* complex matrix A, in either the 1-norm or the infinity-norm, using */
/* the LU factorization computed by CGETRF. */
/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
/* condition number is computed as */
/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies whether the 1-norm condition number or the */
/* infinity-norm condition number is required: */
/* = '1' or 'O': 1-norm; */
/* = 'I': Infinity-norm. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The factors L and U from the factorization A = P*L*U */
/* as computed by CGETRF. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* ANORM (input) REAL */
/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */
/* If NORM = 'I', the infinity-norm of the original matrix A. */
/* RCOND (output) REAL */
/* The reciprocal of the condition number of the matrix A, */
/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
/* WORK (workspace) COMPLEX array, dimension (2*N) */
/* 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 */
/* ===================================================================== */
/* .. 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;
--work;
--rwork;
/* Function Body */
*info = 0;
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O", (ftnlen)1, (
ftnlen)1);
if (! onenrm && ! lsame_(norm, "I", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
} else if (*anorm < 0.f) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGECON", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
*rcond = 0.f;
if (*n == 0) {
*rcond = 1.f;
return 0;
} else if (*anorm == 0.f) {
return 0;
}
smlnum = slamch_("Safe minimum", (ftnlen)12);
/* Estimate the norm of inv(A). */
ainvnm = 0.f;
*(unsigned char *)normin = 'N';
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kase = 0;
L10:
clacon_(n, &work[*n + 1], &work[1], &ainvnm, &kase);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(L). */
clatrs_("Lower", "No transpose", "Unit", normin, n, &a[a_offset],
lda, &work[1], &sl, &rwork[1], info, (ftnlen)5, (ftnlen)
12, (ftnlen)4, (ftnlen)1);
/* Multiply by inv(U). */
clatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[
a_offset], lda, &work[1], &su, &rwork[*n + 1], info, (
ftnlen)5, (ftnlen)12, (ftnlen)8, (ftnlen)1);
} else {
/* Multiply by inv(U'). */
clatrs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &a[
a_offset], lda, &work[1], &su, &rwork[*n + 1], info, (
ftnlen)5, (ftnlen)19, (ftnlen)8, (ftnlen)1);
/* Multiply by inv(L'). */
clatrs_("Lower", "Conjugate transpose", "Unit", normin, n, &a[
a_offset], lda, &work[1], &sl, &rwork[1], info, (ftnlen)5,
(ftnlen)19, (ftnlen)4, (ftnlen)1);
}
/* Divide X by 1/(SL*SU) if doing so will not cause overflow. */
scale = sl * su;
*(unsigned char *)normin = 'Y';
if (scale != 1.f) {
ix = icamax_(n, &work[1], &c__1);
i__1 = ix;
if (scale < ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
work[ix]), dabs(r__2))) * smlnum || scale == 0.f) {
goto L20;
}
csrscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f) {
*rcond = 1.f / ainvnm / *anorm;
}
L20:
return 0;
/* End of CGECON */
} /* cgecon_ */
/* Subroutine */ int ctrcon_(char *norm, char *uplo, char *diag, integer *n,
complex *a, integer *lda, real *rcond, complex *work, real *rwork,
integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
CTRCON estimates the reciprocal of the condition number of a
triangular matrix A, in either the 1-norm or the infinity-norm.
The norm of A is computed and an estimate is obtained for
norm(inv(A)), then the reciprocal of the condition number is
computed as
RCOND = 1 / ( norm(A) * norm(inv(A)) ).
Arguments
=========
NORM (input) CHARACTER*1
Specifies whether the 1-norm condition number or the
infinity-norm condition number is required:
= '1' or 'O': 1-norm;
= 'I': Infinity-norm.
UPLO (input) CHARACTER*1
= 'U': A is upper triangular;
= 'L': A is lower triangular.
DIAG (input) CHARACTER*1
= 'N': A is non-unit triangular;
= 'U': A is unit triangular.
N (input) INTEGER
The order of the matrix A. N >= 0.
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).
RCOND (output) REAL
The reciprocal of the condition number of the matrix A,
computed as RCOND = 1/(norm(A) * norm(inv(A))).
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
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1;
real r__1, r__2;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static integer kase, kase1;
static real scale;
extern logical lsame_(char *, char *);
static real anorm;
static logical upper;
static real xnorm;
extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real
*, integer *);
static integer ix;
extern integer icamax_(integer *, complex *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern doublereal clantr_(char *, char *, char *, integer *, integer *,
complex *, integer *, real *);
static real ainvnm;
extern /* Subroutine */ int clatrs_(char *, char *, char *, char *,
integer *, complex *, integer *, complex *, real *, real *,
integer *), csrscl_(integer *,
real *, complex *, integer *);
static logical onenrm;
static char normin[1];
static real smlnum;
static logical nounit;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--work;
--rwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
nounit = lsame_(diag, "N");
if (! onenrm && ! lsame_(norm, "I")) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTRCON", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*rcond = 1.f;
return 0;
}
*rcond = 0.f;
smlnum = slamch_("Safe minimum") * (real) max(1,*n);
/* Compute the norm of the triangular matrix A. */
anorm = clantr_(norm, uplo, diag, n, n, &a[a_offset], lda, &rwork[1]);
/* Continue only if ANORM > 0. */
if (anorm > 0.f) {
/* Estimate the norm of the inverse of A. */
ainvnm = 0.f;
*(unsigned char *)normin = 'N';
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kase = 0;
L10:
clacon_(n, &work[*n + 1], &work[1], &ainvnm, &kase);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(A). */
clatrs_(uplo, "No transpose", diag, normin, n, &a[a_offset],
lda, &work[1], &scale, &rwork[1], info);
} else {
/* Multiply by inv(A'). */
clatrs_(uplo, "Conjugate transpose", diag, normin, n, &a[
a_offset], lda, &work[1], &scale, &rwork[1], info);
}
*(unsigned char *)normin = 'Y';
/* Multiply by 1/SCALE if doing so will not cause overflow. */
if (scale != 1.f) {
ix = icamax_(n, &work[1], &c__1);
i__1 = ix;
xnorm = (r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
work[ix]), dabs(r__2));
if (scale < xnorm * smlnum || scale == 0.f) {
goto L20;
}
csrscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f) {
*rcond = 1.f / anorm / ainvnm;
}
}
L20:
return 0;
/* End of CTRCON */
} /* ctrcon_ */
/* Subroutine */ int cgbcon_(char *norm, integer *n, integer *kl, integer *ku,
complex *ab, integer *ldab, integer *ipiv, real *anorm, real *rcond,
complex *work, real *rwork, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3;
real r__1, r__2;
complex q__1, q__2;
/* Local variables */
integer j;
complex t;
integer kd, lm, jp, ix, kase, kase1;
real scale;
integer isave[3];
logical lnoti;
real ainvnm;
logical onenrm;
char normin[1];
real smlnum;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
/* Purpose */
/* ======= */
/* CGBCON estimates the reciprocal of the condition number of a complex */
/* general band matrix A, in either the 1-norm or the infinity-norm, */
/* using the LU factorization computed by CGBTRF. */
/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
/* condition number is computed as */
/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies whether the 1-norm condition number or the */
/* infinity-norm condition number is required: */
/* = '1' or 'O': 1-norm; */
/* = 'I': Infinity-norm. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* KL (input) INTEGER */
/* The number of subdiagonals within the band of A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of superdiagonals within the band of A. KU >= 0. */
/* AB (input) COMPLEX array, dimension (LDAB,N) */
/* Details of the LU factorization of the band matrix A, as */
/* computed by CGBTRF. U is stored as an upper triangular band */
/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
/* the multipliers used during the factorization are stored in */
/* rows KL+KU+2 to 2*KL+KU+1. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices; for 1 <= i <= N, row i of the matrix was */
/* interchanged with row IPIV(i). */
/* ANORM (input) REAL */
/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */
/* If NORM = 'I', the infinity-norm of the original matrix A. */
/* RCOND (output) REAL */
/* The reciprocal of the condition number of the matrix A, */
/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
/* 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 */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--ipiv;
--work;
--rwork;
/* Function Body */
*info = 0;
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
if (! onenrm && ! lsame_(norm, "I")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kl < 0) {
*info = -3;
} else if (*ku < 0) {
*info = -4;
} else if (*ldab < (*kl << 1) + *ku + 1) {
*info = -6;
} else if (*anorm < 0.f) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGBCON", &i__1);
return 0;
}
/* Quick return if possible */
*rcond = 0.f;
if (*n == 0) {
*rcond = 1.f;
return 0;
} else if (*anorm == 0.f) {
return 0;
}
smlnum = slamch_("Safe minimum");
/* Estimate the norm of inv(A). */
ainvnm = 0.f;
*(unsigned char *)normin = 'N';
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kd = *kl + *ku + 1;
lnoti = *kl > 0;
kase = 0;
L10:
clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(L). */
if (lnoti) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__2 = *kl, i__3 = *n - j;
lm = min(i__2,i__3);
jp = ipiv[j];
i__2 = jp;
t.r = work[i__2].r, t.i = work[i__2].i;
if (jp != j) {
i__2 = jp;
i__3 = j;
work[i__2].r = work[i__3].r, work[i__2].i = work[i__3]
.i;
i__2 = j;
work[i__2].r = t.r, work[i__2].i = t.i;
}
q__1.r = -t.r, q__1.i = -t.i;
caxpy_(&lm, &q__1, &ab[kd + 1 + j * ab_dim1], &c__1, &
work[j + 1], &c__1);
}
}
/* Multiply by inv(U). */
i__1 = *kl + *ku;
clatbs_("Upper", "No transpose", "Non-unit", normin, n, &i__1, &
ab[ab_offset], ldab, &work[1], &scale, &rwork[1], info);
} else {
/* Multiply by inv(U'). */
i__1 = *kl + *ku;
clatbs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &
i__1, &ab[ab_offset], ldab, &work[1], &scale, &rwork[1],
info);
/* Multiply by inv(L'). */
if (lnoti) {
for (j = *n - 1; j >= 1; --j) {
/* Computing MIN */
i__1 = *kl, i__2 = *n - j;
lm = min(i__1,i__2);
i__1 = j;
i__2 = j;
cdotc_(&q__2, &lm, &ab[kd + 1 + j * ab_dim1], &c__1, &
work[j + 1], &c__1);
q__1.r = work[i__2].r - q__2.r, q__1.i = work[i__2].i -
q__2.i;
work[i__1].r = q__1.r, work[i__1].i = q__1.i;
jp = ipiv[j];
if (jp != j) {
i__1 = jp;
t.r = work[i__1].r, t.i = work[i__1].i;
i__1 = jp;
i__2 = j;
work[i__1].r = work[i__2].r, work[i__1].i = work[i__2]
.i;
i__1 = j;
work[i__1].r = t.r, work[i__1].i = t.i;
}
}
}
}
/* Divide X by 1/SCALE if doing so will not cause overflow. */
*(unsigned char *)normin = 'Y';
if (scale != 1.f) {
ix = icamax_(n, &work[1], &c__1);
i__1 = ix;
if (scale < ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
work[ix]), dabs(r__2))) * smlnum || scale == 0.f) {
goto L40;
}
csrscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f) {
*rcond = 1.f / ainvnm / *anorm;
}
L40:
return 0;
/* End of CGBCON */
} /* cgbcon_ */
/* Subroutine */ int cgetf2_(integer *m, integer *n, complex *a, integer *lda,
integer *ipiv, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
complex q__1;
/* Builtin functions */
double c_abs(complex *);
void c_div(complex *, complex *, complex *);
/* Local variables */
integer i__, j, jp;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *), cgeru_(integer *, integer *, complex *, complex *,
integer *, complex *, integer *, complex *, integer *);
real sfmin;
extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
complex *, integer *);
extern integer icamax_(integer *, complex *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGETF2 computes an LU factorization of a general m-by-n matrix A */
/* using partial pivoting with row interchanges. */
/* The factorization has the form */
/* A = P * L * U */
/* where P is a permutation matrix, L is lower triangular with unit */
/* diagonal elements (lower trapezoidal if m > n), and U is upper */
/* triangular (upper trapezoidal if m < n). */
/* This is the right-looking Level 2 BLAS version of the algorithm. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the m by n matrix to be factored. */
/* On exit, the factors L and U from the factorization */
/* A = P*L*U; the unit diagonal elements of L are not stored. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* IPIV (output) INTEGER array, dimension (min(M,N)) */
/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
/* matrix was interchanged with row IPIV(i). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* > 0: if INFO = k, U(k,k) is exactly zero. The factorization */
/* has been completed, but the factor U is exactly */
/* singular, and division by zero will occur if it is used */
/* to solve a system of equations. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGETF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Compute machine safe minimum */
sfmin = slamch_("S");
i__1 = min(*m,*n);
for (j = 1; j <= i__1; ++j) {
/* Find pivot and test for singularity. */
i__2 = *m - j + 1;
jp = j - 1 + icamax_(&i__2, &a[j + j * a_dim1], &c__1);
ipiv[j] = jp;
i__2 = jp + j * a_dim1;
if (a[i__2].r != 0.f || a[i__2].i != 0.f) {
/* Apply the interchange to columns 1:N. */
if (jp != j) {
cswap_(n, &a[j + a_dim1], lda, &a[jp + a_dim1], lda);
}
/* Compute elements J+1:M of J-th column. */
if (j < *m) {
if (c_abs(&a[j + j * a_dim1]) >= sfmin) {
i__2 = *m - j;
c_div(&q__1, &c_b1, &a[j + j * a_dim1]);
cscal_(&i__2, &q__1, &a[j + 1 + j * a_dim1], &c__1);
} else {
i__2 = *m - j;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = j + i__ + j * a_dim1;
c_div(&q__1, &a[j + i__ + j * a_dim1], &a[j + j *
a_dim1]);
a[i__3].r = q__1.r, a[i__3].i = q__1.i;
/* L20: */
}
}
}
} else if (*info == 0) {
*info = j;
}
if (j < min(*m,*n)) {
/* Update trailing submatrix. */
i__2 = *m - j;
i__3 = *n - j;
q__1.r = -1.f, q__1.i = -0.f;
cgeru_(&i__2, &i__3, &q__1, &a[j + 1 + j * a_dim1], &c__1, &a[j +
(j + 1) * a_dim1], lda, &a[j + 1 + (j + 1) * a_dim1], lda)
;
}
/* L10: */
}
return 0;
/* End of CGETF2 */
} /* cgetf2_ */
/* Subroutine */
int cgbtf2_(integer *m, integer *n, integer *kl, integer *ku, complex *ab, integer *ldab, integer *ipiv, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
complex q__1;
/* Builtin functions */
void c_div(complex *, complex *, complex *);
/* Local variables */
integer i__, j, km, jp, ju, kv;
extern /* Subroutine */
int cscal_(integer *, complex *, complex *, integer *), cgeru_(integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, integer *), cswap_( integer *, complex *, integer *, complex *, integer *);
extern integer icamax_(integer *, complex *, integer *);
extern /* Subroutine */
int 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 .. */
/* KV is the number of superdiagonals in the factor U, allowing for */
/* fill-in. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--ipiv;
/* Function Body */
kv = *ku + *kl;
/* Test the input parameters. */
*info = 0;
if (*m < 0)
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*kl < 0)
{
*info = -3;
}
else if (*ku < 0)
{
*info = -4;
}
else if (*ldab < *kl + kv + 1)
{
*info = -6;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CGBTF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0)
{
return 0;
}
/* Gaussian elimination with partial pivoting */
/* Set fill-in elements in columns KU+2 to KV to zero. */
i__1 = min(kv,*n);
for (j = *ku + 2;
j <= i__1;
++j)
{
i__2 = *kl;
for (i__ = kv - j + 2;
i__ <= i__2;
++i__)
{
i__3 = i__ + j * ab_dim1;
ab[i__3].r = 0.f;
ab[i__3].i = 0.f; // , expr subst
/* L10: */
}
/* L20: */
}
/* JU is the index of the last column affected by the current stage */
/* of the factorization. */
ju = 1;
i__1 = min(*m,*n);
for (j = 1;
j <= i__1;
++j)
{
/* Set fill-in elements in column J+KV to zero. */
if (j + kv <= *n)
{
i__2 = *kl;
for (i__ = 1;
i__ <= i__2;
++i__)
{
i__3 = i__ + (j + kv) * ab_dim1;
ab[i__3].r = 0.f;
ab[i__3].i = 0.f; // , expr subst
/* L30: */
}
}
/* Find pivot and test for singularity. KM is the number of */
/* subdiagonal elements in the current column. */
/* Computing MIN */
i__2 = *kl;
i__3 = *m - j; // , expr subst
km = min(i__2,i__3);
i__2 = km + 1;
jp = icamax_(&i__2, &ab[kv + 1 + j * ab_dim1], &c__1);
ipiv[j] = jp + j - 1;
i__2 = kv + jp + j * ab_dim1;
if (ab[i__2].r != 0.f || ab[i__2].i != 0.f)
{
/* Computing MAX */
/* Computing MIN */
i__4 = j + *ku + jp - 1;
i__2 = ju;
i__3 = min(i__4,*n); // , expr subst
ju = max(i__2,i__3);
/* Apply interchange to columns J to JU. */
if (jp != 1)
{
i__2 = ju - j + 1;
i__3 = *ldab - 1;
i__4 = *ldab - 1;
cswap_(&i__2, &ab[kv + jp + j * ab_dim1], &i__3, &ab[kv + 1 + j * ab_dim1], &i__4);
}
if (km > 0)
{
/* Compute multipliers. */
c_div(&q__1, &c_b1, &ab[kv + 1 + j * ab_dim1]);
cscal_(&km, &q__1, &ab[kv + 2 + j * ab_dim1], &c__1);
/* Update trailing submatrix within the band. */
if (ju > j)
{
i__2 = ju - j;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
i__3 = *ldab - 1;
i__4 = *ldab - 1;
cgeru_(&km, &i__2, &q__1, &ab[kv + 2 + j * ab_dim1], & c__1, &ab[kv + (j + 1) * ab_dim1], &i__3, &ab[kv + 1 + (j + 1) * ab_dim1], &i__4);
}
}
}
else
{
/* If pivot is zero, set INFO to the index of the pivot */
/* unless a zero pivot has already been found. */
if (*info == 0)
{
*info = j;
}
}
/* L40: */
}
return 0;
/* End of CGBTF2 */
}
/* Subroutine */ int cpocon_(char *uplo, integer *n, complex *a, integer *lda,
real *anorm, real *rcond, complex *work, real *rwork, integer *info,
ftnlen uplo_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1;
real r__1, r__2;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static integer ix, kase;
static real scale;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static logical upper;
extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real
*, integer *);
extern integer icamax_(integer *, complex *, integer *);
static real scalel;
extern doublereal slamch_(char *, ftnlen);
static real scaleu;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
static real ainvnm;
extern /* Subroutine */ int clatrs_(char *, char *, char *, char *,
integer *, complex *, integer *, complex *, real *, real *,
integer *, ftnlen, ftnlen, ftnlen, ftnlen), csrscl_(integer *,
real *, complex *, integer *);
static char normin[1];
static real smlnum;
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* March 31, 1993 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CPOCON estimates the reciprocal of the condition number (in the */
/* 1-norm) of a complex Hermitian positive definite matrix using the */
/* Cholesky factorization A = U**H*U or A = L*L**H computed by CPOTRF. */
/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
/* 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. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The triangular factor U or L from the Cholesky factorization */
/* A = U**H*U or A = L*L**H, as computed by CPOTRF. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* ANORM (input) REAL */
/* The 1-norm (or infinity-norm) of the Hermitian matrix A. */
/* RCOND (output) REAL */
/* The reciprocal of the condition number of the matrix A, */
/* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */
/* estimate of the 1-norm of inv(A) computed in this routine. */
/* 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 */
/* ===================================================================== */
/* .. 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;
--work;
--rwork;
/* 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;
} else if (*lda < max(1,*n)) {
*info = -4;
} else if (*anorm < 0.f) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CPOCON", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
*rcond = 0.f;
if (*n == 0) {
*rcond = 1.f;
return 0;
} else if (*anorm == 0.f) {
return 0;
}
smlnum = slamch_("Safe minimum", (ftnlen)12);
/* Estimate the 1-norm of inv(A). */
kase = 0;
*(unsigned char *)normin = 'N';
L10:
clacon_(n, &work[*n + 1], &work[1], &ainvnm, &kase);
if (kase != 0) {
if (upper) {
/* Multiply by inv(U'). */
clatrs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &a[
a_offset], lda, &work[1], &scalel, &rwork[1], info, (
ftnlen)5, (ftnlen)19, (ftnlen)8, (ftnlen)1);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(U). */
clatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[
a_offset], lda, &work[1], &scaleu, &rwork[1], info, (
ftnlen)5, (ftnlen)12, (ftnlen)8, (ftnlen)1);
} else {
/* Multiply by inv(L). */
clatrs_("Lower", "No transpose", "Non-unit", normin, n, &a[
a_offset], lda, &work[1], &scalel, &rwork[1], info, (
ftnlen)5, (ftnlen)12, (ftnlen)8, (ftnlen)1);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(L'). */
clatrs_("Lower", "Conjugate transpose", "Non-unit", normin, n, &a[
a_offset], lda, &work[1], &scaleu, &rwork[1], info, (
ftnlen)5, (ftnlen)19, (ftnlen)8, (ftnlen)1);
}
/* Multiply by 1/SCALE if doing so will not cause overflow. */
scale = scalel * scaleu;
if (scale != 1.f) {
ix = icamax_(n, &work[1], &c__1);
i__1 = ix;
if (scale < ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
work[ix]), dabs(r__2))) * smlnum || scale == 0.f) {
goto L20;
}
csrscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f) {
*rcond = 1.f / ainvnm / *anorm;
}
L20:
return 0;
/* End of CPOCON */
} /* cpocon_ */
/* 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 real 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 real scasum_(integer *, complex *, integer *);
logical rightv;
real smlnum;
/* -- 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 .. */
/* .. */
/* .. 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; // , expr subst
/* 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, f2c_abs(r__1)) + (r__2 = r_imag(&t[ ki + ki * t_dim1]), f2c_abs(r__2)));
smin = max(r__3,smlnum);
work[1].r = 1.f;
work[1].i = 0.f; // , expr subst
/* 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; // , expr subst
work[i__2].r = q__1.r;
work[i__2].i = q__1.i; // , expr subst
/* 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; // , expr subst
t[i__2].r = q__1.r;
t[i__2].i = q__1.i; // , expr subst
i__2 = k + k * t_dim1;
if ((r__1 = t[i__2].r, f2c_abs(r__1)) + (r__2 = r_imag(&t[k + k * t_dim1]), f2c_abs(r__2)) < smin)
{
i__3 = k + k * t_dim1;
t[i__3].r = smin;
t[i__3].i = 0.f; // , expr subst
}
/* 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; // , expr subst
}
/* 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, f2c_abs(r__1)) + (r__2 = r_imag(&vr[ii + is * vr_dim1]), f2c_abs(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; // , expr subst
/* L60: */
}
}
else
{
if (ki > 1)
{
i__1 = ki - 1;
q__1.r = scale;
q__1.i = 0.f; // , expr subst
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, f2c_abs(r__1)) + (r__2 = r_imag(&vr[ii + ki * vr_dim1]), f2c_abs(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; // , expr subst
/* 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, f2c_abs(r__1)) + (r__2 = r_imag(&t[ ki + ki * t_dim1]), f2c_abs(r__2)));
smin = max(r__3,smlnum);
i__2 = *n;
work[i__2].r = 1.f;
work[i__2].i = 0.f; // , expr subst
/* 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; // , expr subst
work[i__3].r = q__1.r;
work[i__3].i = q__1.i; // , expr subst
/* L90: */
}
/* Solve the triangular system: */
/* (T(KI+1:N,KI+1:N) - T(KI,KI))**H*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; // , expr subst
t[i__3].r = q__1.r;
t[i__3].i = q__1.i; // , expr subst
i__3 = k + k * t_dim1;
if ((r__1 = t[i__3].r, f2c_abs(r__1)) + (r__2 = r_imag(&t[k + k * t_dim1]), f2c_abs(r__2)) < smin)
{
i__4 = k + k * t_dim1;
t[i__4].r = smin;
t[i__4].i = 0.f; // , expr subst
}
/* 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; // , expr subst
}
/* 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, f2c_abs(r__1)) + (r__2 = r_imag(&vl[ii + is * vl_dim1]), f2c_abs(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; // , expr subst
/* L110: */
}
}
else
{
if (ki < *n)
{
i__2 = *n - ki;
q__1.r = scale;
q__1.i = 0.f; // , expr subst
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, f2c_abs(r__1)) + (r__2 = r_imag(&vl[ii + ki * vl_dim1]), f2c_abs(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; // , expr subst
/* L120: */
}
++is;
L130:
;
}
}
return 0;
/* End of CTREVC */
}
/* Subroutine */ int ctrsna_(char *job, char *howmny, logical *select,
integer *n, complex *t, integer *ldt, complex *vl, integer *ldvl,
complex *vr, integer *ldvr, real *s, real *sep, integer *mm, integer *
m, complex *work, integer *ldwork, real *rwork, integer *info)
{
/* System generated locals */
integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset,
work_dim1, work_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2;
complex q__1;
/* Builtin functions */
double c_abs(complex *), r_imag(complex *);
/* Local variables */
integer i__, j, k, ks, ix;
real eps, est;
integer kase, ierr;
complex prod;
real lnrm, rnrm, scale;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
integer isave[3];
complex dummy[1];
logical wants;
extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
*, integer *, integer *);
real xnorm;
extern doublereal scnrm2_(integer *, complex *, integer *);
extern /* Subroutine */ int slabad_(real *, real *);
extern integer icamax_(integer *, complex *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), xerbla_(char *,
integer *);
real bignum;
logical wantbh;
extern /* Subroutine */ int clatrs_(char *, char *, char *, char *,
integer *, complex *, integer *, complex *, real *, real *,
integer *), csrscl_(integer *,
real *, complex *, integer *), ctrexc_(char *, integer *, complex
*, integer *, complex *, integer *, integer *, integer *, integer
*);
logical somcon;
char normin[1];
real smlnum;
logical wantsp;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CTRSNA estimates reciprocal condition numbers for specified */
/* eigenvalues and/or right eigenvectors of a complex upper triangular */
/* matrix T (or of any matrix Q*T*Q**H with Q unitary). */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* Specifies whether condition numbers are required for */
/* eigenvalues (S) or eigenvectors (SEP): */
/* = 'E': for eigenvalues only (S); */
/* = 'V': for eigenvectors only (SEP); */
/* = 'B': for both eigenvalues and eigenvectors (S and SEP). */
/* HOWMNY (input) CHARACTER*1 */
/* = 'A': compute condition numbers for all eigenpairs; */
/* = 'S': compute condition numbers for selected eigenpairs */
/* specified by the array SELECT. */
/* SELECT (input) LOGICAL array, dimension (N) */
/* If HOWMNY = 'S', SELECT specifies the eigenpairs for which */
/* condition numbers are required. To select condition numbers */
/* for the j-th eigenpair, SELECT(j) must be set to .TRUE.. */
/* If HOWMNY = 'A', SELECT is not referenced. */
/* N (input) INTEGER */
/* The order of the matrix T. N >= 0. */
/* T (input) COMPLEX array, dimension (LDT,N) */
/* The upper triangular matrix T. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= max(1,N). */
/* VL (input) COMPLEX array, dimension (LDVL,M) */
/* If JOB = 'E' or 'B', VL must contain left eigenvectors of T */
/* (or of any Q*T*Q**H with Q unitary), corresponding to the */
/* eigenpairs specified by HOWMNY and SELECT. The eigenvectors */
/* must be stored in consecutive columns of VL, as returned by */
/* CHSEIN or CTREVC. */
/* If JOB = 'V', VL is not referenced. */
/* LDVL (input) INTEGER */
/* The leading dimension of the array VL. */
/* LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N. */
/* VR (input) COMPLEX array, dimension (LDVR,M) */
/* If JOB = 'E' or 'B', VR must contain right eigenvectors of T */
/* (or of any Q*T*Q**H with Q unitary), corresponding to the */
/* eigenpairs specified by HOWMNY and SELECT. The eigenvectors */
/* must be stored in consecutive columns of VR, as returned by */
/* CHSEIN or CTREVC. */
/* If JOB = 'V', VR is not referenced. */
/* LDVR (input) INTEGER */
/* The leading dimension of the array VR. */
/* LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N. */
/* S (output) REAL array, dimension (MM) */
/* If JOB = 'E' or 'B', the reciprocal condition numbers of the */
/* selected eigenvalues, stored in consecutive elements of the */
/* array. Thus S(j), SEP(j), and the j-th columns of VL and VR */
/* all correspond to the same eigenpair (but not in general the */
/* j-th eigenpair, unless all eigenpairs are selected). */
/* If JOB = 'V', S is not referenced. */
/* SEP (output) REAL array, dimension (MM) */
/* If JOB = 'V' or 'B', the estimated reciprocal condition */
/* numbers of the selected eigenvectors, stored in consecutive */
/* elements of the array. */
/* If JOB = 'E', SEP is not referenced. */
/* MM (input) INTEGER */
/* The number of elements in the arrays S (if JOB = 'E' or 'B') */
/* and/or SEP (if JOB = 'V' or 'B'). MM >= M. */
/* M (output) INTEGER */
/* The number of elements of the arrays S and/or SEP actually */
/* used to store the estimated condition numbers. */
/* If HOWMNY = 'A', M is set to N. */
/* WORK (workspace) COMPLEX array, dimension (LDWORK,N+6) */
/* If JOB = 'E', WORK is not referenced. */
/* LDWORK (input) INTEGER */
/* The leading dimension of the array WORK. */
/* LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N. */
/* RWORK (workspace) REAL array, dimension (N) */
/* If JOB = 'E', RWORK is not referenced. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* The reciprocal of the condition number of an eigenvalue lambda is */
/* defined as */
/* S(lambda) = |v'*u| / (norm(u)*norm(v)) */
/* where u and v are the right and left eigenvectors of T corresponding */
/* to lambda; v' denotes the conjugate transpose of v, and norm(u) */
/* denotes the Euclidean norm. These reciprocal condition numbers always */
/* lie between zero (very badly conditioned) and one (very well */
/* conditioned). If n = 1, S(lambda) is defined to be 1. */
/* An approximate error bound for a computed eigenvalue W(i) is given by */
/* EPS * norm(T) / S(i) */
/* where EPS is the machine precision. */
/* The reciprocal of the condition number of the right eigenvector u */
/* corresponding to lambda is defined as follows. Suppose */
/* T = ( lambda c ) */
/* ( 0 T22 ) */
/* Then the reciprocal condition number is */
/* SEP( lambda, T22 ) = sigma-min( T22 - lambda*I ) */
/* where sigma-min denotes the smallest singular value. We approximate */
/* the smallest singular value by the reciprocal of an estimate of the */
/* one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is */
/* defined to be abs(T(1,1)). */
/* An approximate error bound for a computed right eigenvector VR(i) */
/* is given by */
/* EPS * norm(T) / SEP(i) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. 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;
--s;
--sep;
work_dim1 = *ldwork;
work_offset = 1 + work_dim1;
work -= work_offset;
--rwork;
/* Function Body */
wantbh = lsame_(job, "B");
wants = lsame_(job, "E") || wantbh;
wantsp = lsame_(job, "V") || wantbh;
somcon = lsame_(howmny, "S");
/* Set M to the number of eigenpairs for which condition numbers are */
/* to be computed. */
if (somcon) {
*m = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (select[j]) {
++(*m);
}
/* L10: */
}
} else {
*m = *n;
}
*info = 0;
if (! wants && ! wantsp) {
*info = -1;
} else if (! lsame_(howmny, "A") && ! somcon) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*ldt < max(1,*n)) {
*info = -6;
} else if (*ldvl < 1 || wants && *ldvl < *n) {
*info = -8;
} else if (*ldvr < 1 || wants && *ldvr < *n) {
*info = -10;
} else if (*mm < *m) {
*info = -13;
} else if (*ldwork < 1 || wantsp && *ldwork < *n) {
*info = -16;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTRSNA", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (somcon) {
if (! select[1]) {
return 0;
}
}
if (wants) {
s[1] = 1.f;
}
if (wantsp) {
sep[1] = c_abs(&t[t_dim1 + 1]);
}
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("S") / eps;
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
ks = 1;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (somcon) {
if (! select[k]) {
goto L50;
}
}
if (wants) {
/* Compute the reciprocal condition number of the k-th */
/* eigenvalue. */
cdotc_(&q__1, n, &vr[ks * vr_dim1 + 1], &c__1, &vl[ks * vl_dim1 +
1], &c__1);
prod.r = q__1.r, prod.i = q__1.i;
rnrm = scnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1);
lnrm = scnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1);
s[ks] = c_abs(&prod) / (rnrm * lnrm);
}
if (wantsp) {
/* Estimate the reciprocal condition number of the k-th */
/* eigenvector. */
/* Copy the matrix T to the array WORK and swap the k-th */
/* diagonal element to the (1,1) position. */
clacpy_("Full", n, n, &t[t_offset], ldt, &work[work_offset],
ldwork);
ctrexc_("No Q", n, &work[work_offset], ldwork, dummy, &c__1, &k, &
c__1, &ierr);
/* Form C = T22 - lambda*I in WORK(2:N,2:N). */
i__2 = *n;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = i__ + i__ * work_dim1;
i__4 = i__ + i__ * work_dim1;
i__5 = work_dim1 + 1;
q__1.r = work[i__4].r - work[i__5].r, q__1.i = work[i__4].i -
work[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L20: */
}
/* Estimate a lower bound for the 1-norm of inv(C'). The 1st */
/* and (N+1)th columns of WORK are used to store work vectors. */
sep[ks] = 0.f;
est = 0.f;
kase = 0;
*(unsigned char *)normin = 'N';
L30:
i__2 = *n - 1;
clacn2_(&i__2, &work[(*n + 1) * work_dim1 + 1], &work[work_offset]
, &est, &kase, isave);
if (kase != 0) {
if (kase == 1) {
/* Solve C'*x = scale*b */
i__2 = *n - 1;
clatrs_("Upper", "Conjugate transpose", "Nonunit", normin,
&i__2, &work[(work_dim1 << 1) + 2], ldwork, &
work[work_offset], &scale, &rwork[1], &ierr);
} else {
/* Solve C*x = scale*b */
i__2 = *n - 1;
clatrs_("Upper", "No transpose", "Nonunit", normin, &i__2,
&work[(work_dim1 << 1) + 2], ldwork, &work[
work_offset], &scale, &rwork[1], &ierr);
}
*(unsigned char *)normin = 'Y';
if (scale != 1.f) {
/* Multiply by 1/SCALE if doing so will not cause */
/* overflow. */
i__2 = *n - 1;
ix = icamax_(&i__2, &work[work_offset], &c__1);
i__2 = ix + work_dim1;
xnorm = (r__1 = work[i__2].r, dabs(r__1)) + (r__2 =
r_imag(&work[ix + work_dim1]), dabs(r__2));
if (scale < xnorm * smlnum || scale == 0.f) {
goto L40;
}
csrscl_(n, &scale, &work[work_offset], &c__1);
}
goto L30;
}
sep[ks] = 1.f / dmax(est,smlnum);
}
L40:
++ks;
L50:
;
}
return 0;
/* End of CTRSNA */
} /* ctrsna_ */
/* 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_ */
/* 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 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 ctbcon_(char *norm, char *uplo, char *diag, integer *n,
integer *kd, complex *ab, integer *ldab, real *rcond, complex *work,
real *rwork, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1;
real r__1, r__2;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
integer ix, kase, kase1;
real scale;
extern logical lsame_(char *, char *);
integer isave[3];
real anorm;
logical upper;
extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
*, integer *, integer *);
real xnorm;
extern integer icamax_(integer *, complex *, integer *);
extern doublereal clantb_(char *, char *, char *, integer *, integer *,
complex *, integer *, real *), slamch_(
char *);
extern /* Subroutine */ int clatbs_(char *, char *, char *, char *,
integer *, integer *, complex *, integer *, complex *, real *,
real *, integer *), xerbla_(char *
, integer *);
real ainvnm;
extern /* Subroutine */ int csrscl_(integer *, real *, complex *, integer
*);
logical onenrm;
char normin[1];
real smlnum;
logical nounit;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CTBCON estimates the reciprocal of the condition number of a */
/* triangular band matrix A, in either the 1-norm or the infinity-norm. */
/* The norm of A is computed and an estimate is obtained for */
/* norm(inv(A)), then the reciprocal of the condition number is */
/* computed as */
/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies whether the 1-norm condition number or the */
/* infinity-norm condition number is required: */
/* = '1' or 'O': 1-norm; */
/* = 'I': Infinity-norm. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': A is upper triangular; */
/* = 'L': A is lower triangular. */
/* DIAG (input) CHARACTER*1 */
/* = 'N': A is non-unit triangular; */
/* = 'U': A is unit triangular. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* KD (input) INTEGER */
/* The number of superdiagonals or subdiagonals of the */
/* triangular band matrix A. KD >= 0. */
/* AB (input) COMPLEX array, dimension (LDAB,N) */
/* The upper or lower triangular band matrix A, stored in the */
/* first kd+1 rows of the array. The j-th column of A is stored */
/* in the j-th column of the array AB as follows: */
/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
/* If DIAG = 'U', the diagonal elements of A are not referenced */
/* and are assumed to be 1. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KD+1. */
/* RCOND (output) REAL */
/* The reciprocal of the condition number of the matrix A, */
/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
/* 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 */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--work;
--rwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
nounit = lsame_(diag, "N");
if (! onenrm && ! lsame_(norm, "I")) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*kd < 0) {
*info = -5;
} else if (*ldab < *kd + 1) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTBCON", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*rcond = 1.f;
return 0;
}
*rcond = 0.f;
smlnum = slamch_("Safe minimum") * (real) max(*n,1);
/* Compute the 1-norm of the triangular matrix A or A'. */
anorm = clantb_(norm, uplo, diag, n, kd, &ab[ab_offset], ldab, &rwork[1]);
/* Continue only if ANORM > 0. */
if (anorm > 0.f) {
/* Estimate the 1-norm of the inverse of A. */
ainvnm = 0.f;
*(unsigned char *)normin = 'N';
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kase = 0;
L10:
clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(A). */
clatbs_(uplo, "No transpose", diag, normin, n, kd, &ab[
ab_offset], ldab, &work[1], &scale, &rwork[1], info);
} else {
/* Multiply by inv(A'). */
clatbs_(uplo, "Conjugate transpose", diag, normin, n, kd, &ab[
ab_offset], ldab, &work[1], &scale, &rwork[1], info);
}
*(unsigned char *)normin = 'Y';
/* Multiply by 1/SCALE if doing so will not cause overflow. */
if (scale != 1.f) {
ix = icamax_(n, &work[1], &c__1);
i__1 = ix;
xnorm = (r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
work[ix]), dabs(r__2));
if (scale < xnorm * smlnum || scale == 0.f) {
goto L20;
}
csrscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f) {
*rcond = 1.f / anorm / ainvnm;
}
}
L20:
return 0;
/* End of CTBCON */
} /* ctbcon_ */
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_ */
int icamax( int n, complex *x, int incx)
{
return icamax_(&n, x, &incx);
}
/* Subroutine */
int clasyf_(char *uplo, integer *n, integer *nb, integer *kb, complex *a, integer *lda, integer *ipiv, complex *w, integer *ldw, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, w_dim1, w_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;
/* Builtin functions */
double sqrt(doublereal), r_imag(complex *);
void c_div(complex *, complex *, complex *);
/* Local variables */
integer j, k;
complex t, r1, d11, d21, d22;
integer jb, jj, kk, jp, kp, kw, kkw, imax, jmax;
real alpha;
extern /* Subroutine */
int cscal_(integer *, complex *, complex *, integer *), cgemm_(char *, char *, integer *, integer *, integer * , complex *, complex *, integer *, complex *, integer *, complex * , complex *, integer *);
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 *), cswap_(integer *, complex *, integer *, complex *, integer *);
integer kstep;
real absakk;
extern integer icamax_(integer *, complex *, integer *);
real colmax, rowmax;
/* -- LAPACK computational routine (version 3.5.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2013 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. 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;
--ipiv;
w_dim1 = *ldw;
w_offset = 1 + w_dim1;
w -= w_offset;
/* Function Body */
*info = 0;
/* Initialize ALPHA for use in choosing pivot block size. */
alpha = (sqrt(17.f) + 1.f) / 8.f;
if (lsame_(uplo, "U"))
{
/* Factorize the trailing columns of A using the upper triangle */
/* of A and working backwards, and compute the matrix W = U12*D */
/* for use in updating A11 */
/* K is the main loop index, decreasing from N in steps of 1 or 2 */
/* KW is the column of W which corresponds to column K of A */
k = *n;
L10:
kw = *nb + k - *n;
/* Exit from loop */
if (k <= *n - *nb + 1 && *nb < *n || k < 1)
{
goto L30;
}
/* Copy column K of A to column KW of W and update it */
ccopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1);
if (k < *n)
{
i__1 = *n - k;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
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);
}
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 = k + kw * w_dim1;
absakk = (r__1 = w[i__1].r, f2c_abs(r__1)) + (r__2 = r_imag(&w[k + kw * w_dim1]), f2c_abs(r__2));
/* IMAX is the row-index of the largest off-diagonal element in */
/* column K, and COLMAX is its absolute value. */
/* Determine both COLMAX and IMAX. */
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, f2c_abs(r__1)) + (r__2 = r_imag(&w[imax + kw * w_dim1]), f2c_abs(r__2));
}
else
{
colmax = 0.f;
}
if (max(absakk,colmax) == 0.f)
{
/* Column K is zero or underflow: set INFO and continue */
if (*info == 0)
{
*info = k;
}
kp = k;
}
else
{
if (absakk >= alpha * colmax)
{
/* no interchange, use 1-by-1 pivot block */
kp = k;
}
else
{
/* Copy column IMAX to column KW-1 of W and update it */
ccopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * w_dim1 + 1], &c__1);
i__1 = k - imax;
ccopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &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; // , expr subst
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);
}
/* JMAX is the column-index of the largest off-diagonal */
/* element in row IMAX, and ROWMAX is its absolute value */
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, f2c_abs(r__1)) + (r__2 = r_imag(&w[ jmax + (kw - 1) * w_dim1]), f2c_abs(r__2));
if (imax > 1)
{
i__1 = imax - 1;
jmax = icamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1);
/* Computing MAX */
i__1 = jmax + (kw - 1) * w_dim1;
r__3 = rowmax;
r__4 = (r__1 = w[i__1].r, f2c_abs(r__1)) + ( r__2 = r_imag(&w[jmax + (kw - 1) * w_dim1]), f2c_abs( r__2)); // , expr subst
rowmax = max(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 = imax + (kw - 1) * w_dim1;
if ((r__1 = w[i__1].r, f2c_abs(r__1)) + (r__2 = r_imag(&w[ imax + (kw - 1) * w_dim1]), f2c_abs(r__2)) >= alpha * rowmax)
{
/* interchange rows and columns K and IMAX, use 1-by-1 */
/* pivot block */
kp = imax;
/* copy column KW-1 of W to column KW of W */
ccopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1);
}
else
{
/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
/* pivot block */
kp = imax;
kstep = 2;
}
}
}
/* ============================================================ */
/* KK is the column of A where pivoting step stopped */
kk = k - kstep + 1;
/* KKW is the column of W which corresponds to column KK of A */
kkw = *nb + kk - *n;
/* Interchange rows and columns KP and KK. */
/* Updated column KP is already stored in column KKW of W. */
if (kp != kk)
{
/* Copy non-updated column KK to column KP of submatrix A */
/* at step K. No need to copy element into column K */
/* (or K and K-1 for 2-by-2 pivot) of A, since these columns */
/* will be later overwritten. */
i__1 = kp + kp * a_dim1;
i__2 = kk + kk * a_dim1;
a[i__1].r = a[i__2].r;
a[i__1].i = a[i__2].i; // , expr subst
i__1 = kk - 1 - kp;
ccopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__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);
}
/* Interchange rows KK and KP in last K+1 to N columns of A */
/* (columns K (or K and K-1 for 2-by-2 pivot) of A will be */
/* later overwritten). Interchange rows KK and KP */
/* in last KKW to NB columns of W. */
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)
{
/* 1-by-1 pivot block D(k): column kw of W now holds */
/* W(kw) = U(k)*D(k), */
/* where U(k) is the k-th column of U */
/* Store subdiag. elements of column U(k) */
/* and 1-by-1 block D(k) in column k of A. */
/* NOTE: Diagonal element U(k,k) is a UNIT element */
/* and not stored. */
/* A(k,k) := D(k,k) = W(k,kw) */
/* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k) */
ccopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & c__1);
c_div(&q__1, &c_b1, &a[k + k * a_dim1]);
r1.r = q__1.r;
r1.i = q__1.i; // , expr subst
i__1 = k - 1;
cscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1);
}
else
{
/* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold */
/* ( W(kw-1) W(kw) ) = ( 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 */
/* Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2 */
/* block D(k-1:k,k-1:k) in columns k-1 and k of A. */
/* NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT */
/* block and not stored. */
/* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw) */
/* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) = */
/* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) ) */
if (k > 2)
{
/* Compose the columns of the inverse of 2-by-2 pivot */
/* block D in the following way to reduce the number */
/* of FLOPS when we myltiply panel ( W(kw-1) W(kw) ) by */
/* this inverse */
/* D**(-1) = ( d11 d21 )**(-1) = */
/* ( d21 d22 ) */
/* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) = */
/* ( (-d21 ) ( d11 ) ) */
/* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) * */
/* * ( ( d22/d21 ) ( -1 ) ) = */
/* ( ( -1 ) ( d11/d21 ) ) */
/* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) = */
/* ( ( -1 ) ( D22 ) ) */
/* = 1/d21 * T * ( ( D11 ) ( -1 ) ) */
/* ( ( -1 ) ( D22 ) ) */
/* = D21 * ( ( D11 ) ( -1 ) ) */
/* ( ( -1 ) ( D22 ) ) */
i__1 = k - 1 + kw * w_dim1;
d21.r = w[i__1].r;
d21.i = w[i__1].i; // , expr subst
c_div(&q__1, &w[k + kw * w_dim1], &d21);
d11.r = q__1.r;
d11.i = q__1.i; // , expr subst
c_div(&q__1, &w[k - 1 + (kw - 1) * w_dim1], &d21);
d22.r = q__1.r;
d22.i = q__1.i; // , expr subst
q__3.r = d11.r * d22.r - d11.i * d22.i;
q__3.i = d11.r * d22.i + d11.i * d22.r; // , expr subst
q__2.r = q__3.r - 1.f;
q__2.i = q__3.i - 0.f; // , expr subst
c_div(&q__1, &c_b1, &q__2);
t.r = q__1.r;
t.i = q__1.i; // , expr subst
/* Update elements in columns A(k-1) and A(k) as */
/* dot products of rows of ( W(kw-1) W(kw) ) and columns */
/* of D**(-1) */
c_div(&q__1, &t, &d21);
d21.r = q__1.r;
d21.i = q__1.i; // , expr subst
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__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i;
q__3.i = d11.r * w[i__3].i + d11.i * w[i__3] .r; // , expr subst
i__4 = j + kw * w_dim1;
q__2.r = q__3.r - w[i__4].r;
q__2.i = q__3.i - w[i__4] .i; // , expr subst
q__1.r = d21.r * q__2.r - d21.i * q__2.i;
q__1.i = d21.r * q__2.i + d21.i * q__2.r; // , expr subst
a[i__2].r = q__1.r;
a[i__2].i = q__1.i; // , expr subst
i__2 = j + k * a_dim1;
i__3 = j + kw * w_dim1;
q__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i;
q__3.i = d22.r * w[i__3].i + d22.i * w[i__3] .r; // , expr subst
i__4 = j + (kw - 1) * w_dim1;
q__2.r = q__3.r - w[i__4].r;
q__2.i = q__3.i - w[i__4] .i; // , expr subst
q__1.r = d21.r * q__2.r - d21.i * q__2.i;
q__1.i = d21.r * q__2.i + d21.i * q__2.r; // , expr subst
a[i__2].r = q__1.r;
a[i__2].i = q__1.i; // , expr subst
/* L20: */
}
}
/* Copy D(k) to A */
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; // , expr subst
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; // , expr subst
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; // , expr subst
}
}
/* 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;
goto L10;
L30: /* Update the upper triangle of A11 (= A(1:k,1:k)) as */
/* A11 := A11 - U12*D*U12**T = A11 - U12*W**T */
/* computing blocks of NB columns at a time */
i__1 = -(*nb);
for (j = (k - 1) / *nb * *nb + 1;
i__1 < 0 ? j >= 1 : j <= 1;
j += i__1)
{
/* Computing MIN */
i__2 = *nb;
i__3 = k - j + 1; // , expr subst
jb = min(i__2,i__3);
/* Update the upper triangle of the diagonal block */
i__2 = j + jb - 1;
for (jj = j;
jj <= i__2;
++jj)
{
i__3 = jj - j + 1;
i__4 = *n - k;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemv_("No transpose", &i__3, &i__4, &q__1, &a[j + (k + 1) * a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b1, &a[j + jj * a_dim1], &c__1);
/* L40: */
}
/* Update the rectangular superdiagonal block */
i__2 = j - 1;
i__3 = *n - k;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &q__1, &a[( k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * w_dim1], ldw, &c_b1, &a[j * a_dim1 + 1], lda);
/* L50: */
}
/* Put U12 in standard form by partially undoing the interchanges */
/* in columns k+1:n looping backwards from k+1 to n */
j = k + 1;
L60: /* Undo the interchanges (if any) of rows JJ and JP at each */
/* step J */
/* (Here, J is a diagonal index) */
jj = j;
jp = ipiv[j];
if (jp < 0)
{
jp = -jp;
/* (Here, J is a diagonal index) */
++j;
}
/* (NOTE: Here, J is used to determine row length. Length N-J+1 */
/* of the rows to swap back doesn't include diagonal element) */
++j;
if (jp != jj && j <= *n)
{
i__1 = *n - j + 1;
cswap_(&i__1, &a[jp + j * a_dim1], lda, &a[jj + j * a_dim1], lda);
}
if (j < *n)
{
goto L60;
}
/* Set KB to the number of columns factorized */
*kb = *n - k;
}
else
{
/* Factorize the leading columns of A using the lower triangle */
/* of A and working forwards, and compute the matrix W = L21*D */
/* for use in updating A22 */
/* K is the main loop index, increasing from 1 in steps of 1 or 2 */
k = 1;
L70: /* Exit from loop */
if (k >= *nb && *nb < *n || k > *n)
{
goto L90;
}
/* Copy column K of A to column K of W and update it */
i__1 = *n - k + 1;
ccopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1);
i__1 = *n - k + 1;
i__2 = k - 1;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
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);
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 = k + k * w_dim1;
absakk = (r__1 = w[i__1].r, f2c_abs(r__1)) + (r__2 = r_imag(&w[k + k * w_dim1]), f2c_abs(r__2));
/* IMAX is the row-index of the largest off-diagonal element in */
/* column K, and COLMAX is its absolute value. */
/* Determine both COLMAX and IMAX. */
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, f2c_abs(r__1)) + (r__2 = r_imag(&w[imax + k * w_dim1]), f2c_abs(r__2));
}
else
{
colmax = 0.f;
}
if (max(absakk,colmax) == 0.f)
{
/* Column K is zero or underflow: set INFO and continue */
if (*info == 0)
{
*info = k;
}
kp = k;
}
else
{
if (absakk >= alpha * colmax)
{
/* no interchange, use 1-by-1 pivot block */
kp = k;
}
else
{
/* Copy column IMAX to column K+1 of W and update it */
i__1 = imax - k;
ccopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * w_dim1], &c__1);
i__1 = *n - imax + 1;
ccopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k + 1) * w_dim1], &c__1);
i__1 = *n - k + 1;
i__2 = k - 1;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
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);
/* JMAX is the column-index of the largest off-diagonal */
/* element in row IMAX, and ROWMAX is its absolute value */
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, f2c_abs(r__1)) + (r__2 = r_imag(&w[ jmax + (k + 1) * w_dim1]), f2c_abs(r__2));
if (imax < *n)
{
i__1 = *n - imax;
jmax = imax + icamax_(&i__1, &w[imax + 1 + (k + 1) * w_dim1], &c__1);
/* Computing MAX */
i__1 = jmax + (k + 1) * w_dim1;
r__3 = rowmax;
r__4 = (r__1 = w[i__1].r, f2c_abs(r__1)) + ( r__2 = r_imag(&w[jmax + (k + 1) * w_dim1]), f2c_abs( r__2)); // , expr subst
rowmax = max(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 = imax + (k + 1) * w_dim1;
if ((r__1 = w[i__1].r, f2c_abs(r__1)) + (r__2 = r_imag(&w[ imax + (k + 1) * w_dim1]), f2c_abs(r__2)) >= alpha * rowmax)
{
/* interchange rows and columns K and IMAX, use 1-by-1 */
/* pivot block */
kp = imax;
/* copy column K+1 of W to column K of W */
i__1 = *n - k + 1;
ccopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * w_dim1], &c__1);
}
else
{
/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
/* pivot block */
kp = imax;
kstep = 2;
}
}
}
/* ============================================================ */
/* KK is the column of A where pivoting step stopped */
kk = k + kstep - 1;
/* Interchange rows and columns KP and KK. */
/* Updated column KP is already stored in column KK of W. */
if (kp != kk)
{
/* Copy non-updated column KK to column KP of submatrix A */
/* at step K. No need to copy element into column K */
/* (or K and K+1 for 2-by-2 pivot) of A, since these columns */
/* will be later overwritten. */
i__1 = kp + kp * a_dim1;
i__2 = kk + kk * a_dim1;
a[i__1].r = a[i__2].r;
a[i__1].i = a[i__2].i; // , expr subst
i__1 = kp - kk - 1;
ccopy_(&i__1, &a[kk + 1 + kk * a_dim1], &c__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);
}
/* Interchange rows KK and KP in first K-1 columns of A */
/* (columns K (or K and K+1 for 2-by-2 pivot) of A will be */
/* later overwritten). Interchange rows KK and KP */
/* in first KK columns of W. */
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)
{
/* 1-by-1 pivot block D(k): column k of W now holds */
/* W(k) = L(k)*D(k), */
/* where L(k) is the k-th column of L */
/* Store subdiag. elements of column L(k) */
/* and 1-by-1 block D(k) in column k of A. */
/* (NOTE: Diagonal element L(k,k) is a UNIT element */
/* and not stored) */
/* A(k,k) := D(k,k) = W(k,k) */
/* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k) */
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)
{
c_div(&q__1, &c_b1, &a[k + k * a_dim1]);
r1.r = q__1.r;
r1.i = q__1.i; // , expr subst
i__1 = *n - k;
cscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1);
}
}
else
{
/* 2-by-2 pivot block D(k): columns k and k+1 of W 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 */
/* Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2 */
/* block D(k:k+1,k:k+1) in columns k and k+1 of A. */
/* (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT */
/* block and not stored) */
/* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1) */
/* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) = */
/* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) ) */
if (k < *n - 1)
{
/* Compose the columns of the inverse of 2-by-2 pivot */
/* block D in the following way to reduce the number */
/* of FLOPS when we myltiply panel ( W(k) W(k+1) ) by */
/* this inverse */
/* D**(-1) = ( d11 d21 )**(-1) = */
/* ( d21 d22 ) */
/* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) = */
/* ( (-d21 ) ( d11 ) ) */
/* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) * */
/* * ( ( d22/d21 ) ( -1 ) ) = */
/* ( ( -1 ) ( d11/d21 ) ) */
/* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) = */
/* ( ( -1 ) ( D22 ) ) */
/* = 1/d21 * T * ( ( D11 ) ( -1 ) ) */
/* ( ( -1 ) ( D22 ) ) */
/* = D21 * ( ( D11 ) ( -1 ) ) */
/* ( ( -1 ) ( D22 ) ) */
i__1 = k + 1 + k * w_dim1;
d21.r = w[i__1].r;
d21.i = w[i__1].i; // , expr subst
c_div(&q__1, &w[k + 1 + (k + 1) * w_dim1], &d21);
d11.r = q__1.r;
d11.i = q__1.i; // , expr subst
c_div(&q__1, &w[k + k * w_dim1], &d21);
d22.r = q__1.r;
d22.i = q__1.i; // , expr subst
q__3.r = d11.r * d22.r - d11.i * d22.i;
q__3.i = d11.r * d22.i + d11.i * d22.r; // , expr subst
q__2.r = q__3.r - 1.f;
q__2.i = q__3.i - 0.f; // , expr subst
c_div(&q__1, &c_b1, &q__2);
t.r = q__1.r;
t.i = q__1.i; // , expr subst
c_div(&q__1, &t, &d21);
d21.r = q__1.r;
d21.i = q__1.i; // , expr subst
/* Update elements in columns A(k) and A(k+1) as */
/* dot products of rows of ( W(k) W(k+1) ) and columns */
/* of D**(-1) */
i__1 = *n;
for (j = k + 2;
j <= i__1;
++j)
{
i__2 = j + k * a_dim1;
i__3 = j + k * w_dim1;
q__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i;
q__3.i = d11.r * w[i__3].i + d11.i * w[i__3] .r; // , expr subst
i__4 = j + (k + 1) * w_dim1;
q__2.r = q__3.r - w[i__4].r;
q__2.i = q__3.i - w[i__4] .i; // , expr subst
q__1.r = d21.r * q__2.r - d21.i * q__2.i;
q__1.i = d21.r * q__2.i + d21.i * q__2.r; // , expr subst
a[i__2].r = q__1.r;
a[i__2].i = q__1.i; // , expr subst
i__2 = j + (k + 1) * a_dim1;
i__3 = j + (k + 1) * w_dim1;
q__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i;
q__3.i = d22.r * w[i__3].i + d22.i * w[i__3] .r; // , expr subst
i__4 = j + k * w_dim1;
q__2.r = q__3.r - w[i__4].r;
q__2.i = q__3.i - w[i__4] .i; // , expr subst
q__1.r = d21.r * q__2.r - d21.i * q__2.i;
q__1.i = d21.r * q__2.i + d21.i * q__2.r; // , expr subst
a[i__2].r = q__1.r;
a[i__2].i = q__1.i; // , expr subst
/* L80: */
}
}
/* Copy D(k) to A */
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; // , expr subst
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; // , expr subst
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; // , expr subst
}
}
/* 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;
goto L70;
L90: /* Update the lower triangle of A22 (= A(k:n,k:n)) as */
/* A22 := A22 - L21*D*L21**T = A22 - L21*W**T */
/* computing blocks of NB columns at a time */
i__1 = *n;
i__2 = *nb;
for (j = k;
i__2 < 0 ? j >= i__1 : j <= i__1;
j += i__2)
{
/* Computing MIN */
i__3 = *nb;
i__4 = *n - j + 1; // , expr subst
jb = min(i__3,i__4);
/* Update the lower triangle of the diagonal block */
i__3 = j + jb - 1;
for (jj = j;
jj <= i__3;
++jj)
{
i__4 = j + jb - jj;
i__5 = k - 1;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemv_("No transpose", &i__4, &i__5, &q__1, &a[jj + a_dim1], lda, &w[jj + w_dim1], ldw, &c_b1, &a[jj + jj * a_dim1] , &c__1);
/* L100: */
}
/* Update the rectangular subdiagonal block */
if (j + jb <= *n)
{
i__3 = *n - j - jb + 1;
i__4 = k - 1;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &q__1, &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b1, &a[j + jb + j * a_dim1], lda);
}
/* L110: */
}
/* Put L21 in standard form by partially undoing the interchanges */
/* of rows in columns 1:k-1 looping backwards from k-1 to 1 */
j = k - 1;
L120: /* Undo the interchanges (if any) of rows JJ and JP at each */
/* step J */
/* (Here, J is a diagonal index) */
jj = j;
jp = ipiv[j];
if (jp < 0)
{
jp = -jp;
/* (Here, J is a diagonal index) */
--j;
}
/* (NOTE: Here, J is used to determine row length. Length J */
/* of the rows to swap back doesn't include diagonal element) */
--j;
if (jp != jj && j >= 1)
{
cswap_(&j, &a[jp + a_dim1], lda, &a[jj + a_dim1], lda);
}
if (j > 1)
{
goto L120;
}
/* Set KB to the number of columns factorized */
*kb = k - 1;
}
return 0;
/* End of CLASYF */
}
/** 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 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_ */
/*! \brief
* <pre>
* Purpose
* =======
* ilu_cdrop_row() - Drop some small rows from the previous
* supernode (L-part only).
* </pre>
*/
int ilu_cdrop_row(
superlu_options_t *options, /* options */
int first, /* index of the first column in the supernode */
int last, /* index of the last column in the supernode */
double drop_tol, /* dropping parameter */
int quota, /* maximum nonzero entries allowed */
int *nnzLj, /* in/out number of nonzeros in L(:, 1:last) */
double *fill_tol, /* in/out - on exit, fill_tol=-num_zero_pivots,
* does not change if options->ILU_MILU != SMILU1 */
GlobalLU_t *Glu, /* modified */
float swork[], /* working space
* the length of swork[] should be no less than
* the number of rows in the supernode */
float swork2[], /* working space with the same size as swork[],
* used only by the second dropping rule */
int lastc /* if lastc == 0, there is nothing after the
* working supernode [first:last];
* if lastc == 1, there is one more column after
* the working supernode. */ )
{
register int i, j, k, m1;
register int nzlc; /* number of nonzeros in column last+1 */
register int xlusup_first, xlsub_first;
int m, n; /* m x n is the size of the supernode */
int r = 0; /* number of dropped rows */
register float *temp;
register complex *lusup = (complex *) Glu->lusup;
register int *lsub = Glu->lsub;
register int *xlsub = Glu->xlsub;
register int *xlusup = Glu->xlusup;
register float d_max = 0.0, d_min = 1.0;
int drop_rule = options->ILU_DropRule;
milu_t milu = options->ILU_MILU;
norm_t nrm = options->ILU_Norm;
complex zero = {0.0, 0.0};
complex one = {1.0, 0.0};
complex none = {-1.0, 0.0};
int i_1 = 1;
int inc_diag; /* inc_diag = m + 1 */
int nzp = 0; /* number of zero pivots */
float alpha = pow((double)(Glu->n), -1.0 / options->ILU_MILU_Dim);
xlusup_first = xlusup[first];
xlsub_first = xlsub[first];
m = xlusup[first + 1] - xlusup_first;
n = last - first + 1;
m1 = m - 1;
inc_diag = m + 1;
nzlc = lastc ? (xlusup[last + 2] - xlusup[last + 1]) : 0;
temp = swork - n;
/* Quick return if nothing to do. */
if (m == 0 || m == n || drop_rule == NODROP)
{
*nnzLj += m * n;
return 0;
}
/* basic dropping: ILU(tau) */
for (i = n; i <= m1; )
{
/* the average abs value of ith row */
switch (nrm)
{
case ONE_NORM:
temp[i] = scasum_(&n, &lusup[xlusup_first + i], &m) / (double)n;
break;
case TWO_NORM:
temp[i] = scnrm2_(&n, &lusup[xlusup_first + i], &m)
/ sqrt((double)n);
break;
case INF_NORM:
default:
k = icamax_(&n, &lusup[xlusup_first + i], &m) - 1;
temp[i] = c_abs1(&lusup[xlusup_first + i + m * k]);
break;
}
/* drop small entries due to drop_tol */
if (drop_rule & DROP_BASIC && temp[i] < drop_tol)
{
r++;
/* drop the current row and move the last undropped row here */
if (r > 1) /* add to last row */
{
/* accumulate the sum (for MILU) */
switch (milu)
{
case SMILU_1:
case SMILU_2:
caxpy_(&n, &one, &lusup[xlusup_first + i], &m,
&lusup[xlusup_first + m - 1], &m);
break;
case SMILU_3:
for (j = 0; j < n; j++)
lusup[xlusup_first + (m - 1) + j * m].r +=
c_abs1(&lusup[xlusup_first + i + j * m]);
break;
case SILU:
default:
break;
}
ccopy_(&n, &lusup[xlusup_first + m1], &m,
&lusup[xlusup_first + i], &m);
} /* if (r > 1) */
else /* move to last row */
{
cswap_(&n, &lusup[xlusup_first + m1], &m,
&lusup[xlusup_first + i], &m);
if (milu == SMILU_3)
for (j = 0; j < n; j++) {
lusup[xlusup_first + m1 + j * m].r =
c_abs1(&lusup[xlusup_first + m1 + j * m]);
lusup[xlusup_first + m1 + j * m].i = 0.0;
}
}
lsub[xlsub_first + i] = lsub[xlsub_first + m1];
m1--;
continue;
} /* if dropping */
else
{
if (temp[i] > d_max) d_max = temp[i];
if (temp[i] < d_min) d_min = temp[i];
}
i++;
} /* for */
/* Secondary dropping: drop more rows according to the quota. */
quota = ceil((double)quota / (double)n);
if (drop_rule & DROP_SECONDARY && m - r > quota)
{
register double tol = d_max;
/* Calculate the second dropping tolerance */
if (quota > n)
{
if (drop_rule & DROP_INTERP) /* by interpolation */
{
d_max = 1.0 / d_max; d_min = 1.0 / d_min;
tol = 1.0 / (d_max + (d_min - d_max) * quota / (m - n - r));
}
else /* by quick select */
{
int len = m1 - n + 1;
scopy_(&len, swork, &i_1, swork2, &i_1);
tol = sqselect(len, swork2, quota - n);
#if 0
register int *itemp = iwork - n;
A = temp;
for (i = n; i <= m1; i++) itemp[i] = i;
qsort(iwork, m1 - n + 1, sizeof(int), _compare_);
tol = temp[itemp[quota]];
#endif
}
}
for (i = n; i <= m1; )
{
if (temp[i] <= tol)
{
register int j;
r++;
/* drop the current row and move the last undropped row here */
if (r > 1) /* add to last row */
{
/* accumulate the sum (for MILU) */
switch (milu)
{
case SMILU_1:
case SMILU_2:
caxpy_(&n, &one, &lusup[xlusup_first + i], &m,
&lusup[xlusup_first + m - 1], &m);
break;
case SMILU_3:
for (j = 0; j < n; j++)
lusup[xlusup_first + (m - 1) + j * m].r +=
c_abs1(&lusup[xlusup_first + i + j * m]);
break;
case SILU:
default:
break;
}
ccopy_(&n, &lusup[xlusup_first + m1], &m,
&lusup[xlusup_first + i], &m);
} /* if (r > 1) */
else /* move to last row */
{
cswap_(&n, &lusup[xlusup_first + m1], &m,
&lusup[xlusup_first + i], &m);
if (milu == SMILU_3)
for (j = 0; j < n; j++) {
lusup[xlusup_first + m1 + j * m].r =
c_abs1(&lusup[xlusup_first + m1 + j * m]);
lusup[xlusup_first + m1 + j * m].i = 0.0;
}
}
lsub[xlsub_first + i] = lsub[xlsub_first + m1];
m1--;
temp[i] = temp[m1];
continue;
}
i++;
} /* for */
} /* if secondary dropping */
for (i = n; i < m; i++) temp[i] = 0.0;
if (r == 0)
{
*nnzLj += m * n;
return 0;
}
/* add dropped entries to the diagnal */
if (milu != SILU)
{
register int j;
complex t;
float omega;
for (j = 0; j < n; j++)
{
t = lusup[xlusup_first + (m - 1) + j * m];
if (t.r == 0.0 && t.i == 0.0) continue;
omega = SUPERLU_MIN(2.0 * (1.0 - alpha) / c_abs1(&t), 1.0);
cs_mult(&t, &t, omega);
switch (milu)
{
case SMILU_1:
if ( !(c_eq(&t, &none)) ) {
c_add(&t, &t, &one);
cc_mult(&lusup[xlusup_first + j * inc_diag],
&lusup[xlusup_first + j * inc_diag],
&t);
}
else
{
cs_mult(
&lusup[xlusup_first + j * inc_diag],
&lusup[xlusup_first + j * inc_diag],
*fill_tol);
#ifdef DEBUG
printf("[1] ZERO PIVOT: FILL col %d.\n", first + j);
fflush(stdout);
#endif
nzp++;
}
break;
case SMILU_2:
cs_mult(&lusup[xlusup_first + j * inc_diag],
&lusup[xlusup_first + j * inc_diag],
1.0 + c_abs1(&t));
break;
case SMILU_3:
c_add(&t, &t, &one);
cc_mult(&lusup[xlusup_first + j * inc_diag],
&lusup[xlusup_first + j * inc_diag],
&t);
break;
case SILU:
default:
break;
}
}
if (nzp > 0) *fill_tol = -nzp;
}
/* Remove dropped entries from the memory and fix the pointers. */
m1 = m - r;
for (j = 1; j < n; j++)
{
register int tmp1, tmp2;
tmp1 = xlusup_first + j * m1;
tmp2 = xlusup_first + j * m;
for (i = 0; i < m1; i++)
lusup[i + tmp1] = lusup[i + tmp2];
}
for (i = 0; i < nzlc; i++)
lusup[xlusup_first + i + n * m1] = lusup[xlusup_first + i + n * m];
for (i = 0; i < nzlc; i++)
lsub[xlsub[last + 1] - r + i] = lsub[xlsub[last + 1] + i];
for (i = first + 1; i <= last + 1; i++)
{
xlusup[i] -= r * (i - first);
xlsub[i] -= r;
}
if (lastc)
{
xlusup[last + 2] -= r * n;
xlsub[last + 2] -= r;
}
*nnzLj += (m - r) * n;
return r;
}
/* Subroutine */ int ctpcon_(char *norm, char *uplo, char *diag, integer *n,
complex *ap, real *rcond, complex *work, real *rwork, integer *info,
ftnlen norm_len, ftnlen uplo_len, ftnlen diag_len)
{
/* System generated locals */
integer i__1;
real r__1, r__2;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static integer ix, kase, kase1;
static real scale;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static real anorm;
static logical upper;
static real xnorm;
extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real
*, integer *);
extern integer icamax_(integer *, complex *, integer *);
extern doublereal slamch_(char *, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern doublereal clantp_(char *, char *, char *, integer *, complex *,
real *, ftnlen, ftnlen, ftnlen);
extern /* Subroutine */ int clatps_(char *, char *, char *, char *,
integer *, complex *, complex *, real *, real *, integer *,
ftnlen, ftnlen, ftnlen, ftnlen);
static real ainvnm;
extern /* Subroutine */ int csrscl_(integer *, real *, complex *, integer
*);
static logical onenrm;
static char normin[1];
static real smlnum;
static logical nounit;
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* March 31, 1993 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CTPCON estimates the reciprocal of the condition number of a packed */
/* triangular matrix A, in either the 1-norm or the infinity-norm. */
/* The norm of A is computed and an estimate is obtained for */
/* norm(inv(A)), then the reciprocal of the condition number is */
/* computed as */
/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies whether the 1-norm condition number or the */
/* infinity-norm condition number is required: */
/* = '1' or 'O': 1-norm; */
/* = 'I': Infinity-norm. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': A is upper triangular; */
/* = 'L': A is lower triangular. */
/* DIAG (input) CHARACTER*1 */
/* = 'N': A is non-unit triangular; */
/* = 'U': A is unit triangular. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
/* The upper or lower triangular 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. */
/* If DIAG = 'U', the diagonal elements of A are not referenced */
/* and are assumed to be 1. */
/* RCOND (output) REAL */
/* The reciprocal of the condition number of the matrix A, */
/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
/* 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 */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--rwork;
--work;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O", (ftnlen)1, (
ftnlen)1);
nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
if (! onenrm && ! lsame_(norm, "I", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) {
*info = -3;
} else if (*n < 0) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTPCON", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*rcond = 1.f;
return 0;
}
*rcond = 0.f;
smlnum = slamch_("Safe minimum", (ftnlen)12) * (real) max(1,*n);
/* Compute the norm of the triangular matrix A. */
anorm = clantp_(norm, uplo, diag, n, &ap[1], &rwork[1], (ftnlen)1, (
ftnlen)1, (ftnlen)1);
/* Continue only if ANORM > 0. */
if (anorm > 0.f) {
/* Estimate the norm of the inverse of A. */
ainvnm = 0.f;
*(unsigned char *)normin = 'N';
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kase = 0;
L10:
clacon_(n, &work[*n + 1], &work[1], &ainvnm, &kase);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(A). */
clatps_(uplo, "No transpose", diag, normin, n, &ap[1], &work[
1], &scale, &rwork[1], info, (ftnlen)1, (ftnlen)12, (
ftnlen)1, (ftnlen)1);
} else {
/* Multiply by inv(A'). */
clatps_(uplo, "Conjugate transpose", diag, normin, n, &ap[1],
&work[1], &scale, &rwork[1], info, (ftnlen)1, (ftnlen)
19, (ftnlen)1, (ftnlen)1);
}
*(unsigned char *)normin = 'Y';
/* Multiply by 1/SCALE if doing so will not cause overflow. */
if (scale != 1.f) {
ix = icamax_(n, &work[1], &c__1);
i__1 = ix;
xnorm = (r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
work[ix]), dabs(r__2));
if (scale < xnorm * smlnum || scale == 0.f) {
goto L20;
}
csrscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f) {
*rcond = 1.f / anorm / ainvnm;
}
}
L20:
return 0;
/* End of CTPCON */
} /* ctpcon_ */
/* Subroutine */
int ctpcon_(char *norm, char *uplo, char *diag, integer *n, complex *ap, real *rcond, complex *work, real *rwork, integer *info)
{
/* System generated locals */
integer i__1;
real r__1, r__2;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
integer ix, kase, kase1;
real scale;
extern logical lsame_(char *, char *);
integer isave[3];
real anorm;
logical upper;
extern /* Subroutine */
int clacn2_(integer *, complex *, complex *, real *, integer *, integer *);
real xnorm;
extern integer icamax_(integer *, complex *, integer *);
extern real slamch_(char *);
extern /* Subroutine */
int xerbla_(char *, integer *);
extern real clantp_(char *, char *, char *, integer *, complex *, real *);
extern /* Subroutine */
int clatps_(char *, char *, char *, char *, integer *, complex *, complex *, real *, real *, integer *);
real ainvnm;
extern /* Subroutine */
int csrscl_(integer *, real *, complex *, integer *);
logical onenrm;
char normin[1];
real smlnum;
logical nounit;
/* -- 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 .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--rwork;
--work;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
nounit = lsame_(diag, "N");
if (! onenrm && ! lsame_(norm, "I"))
{
*info = -1;
}
else if (! upper && ! lsame_(uplo, "L"))
{
*info = -2;
}
else if (! nounit && ! lsame_(diag, "U"))
{
*info = -3;
}
else if (*n < 0)
{
*info = -4;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CTPCON", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
*rcond = 1.f;
return 0;
}
*rcond = 0.f;
smlnum = slamch_("Safe minimum") * (real) max(1,*n);
/* Compute the norm of the triangular matrix A. */
anorm = clantp_(norm, uplo, diag, n, &ap[1], &rwork[1]);
/* Continue only if ANORM > 0. */
if (anorm > 0.f)
{
/* Estimate the norm of the inverse of A. */
ainvnm = 0.f;
*(unsigned char *)normin = 'N';
if (onenrm)
{
kase1 = 1;
}
else
{
kase1 = 2;
}
kase = 0;
L10:
clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
if (kase != 0)
{
if (kase == kase1)
{
/* Multiply by inv(A). */
clatps_(uplo, "No transpose", diag, normin, n, &ap[1], &work[ 1], &scale, &rwork[1], info);
}
else
{
/* Multiply by inv(A**H). */
clatps_(uplo, "Conjugate transpose", diag, normin, n, &ap[1], &work[1], &scale, &rwork[1], info);
}
*(unsigned char *)normin = 'Y';
/* Multiply by 1/SCALE if doing so will not cause overflow. */
if (scale != 1.f)
{
ix = icamax_(n, &work[1], &c__1);
i__1 = ix;
xnorm = (r__1 = work[i__1].r, abs(r__1)) + (r__2 = r_imag(& work[ix]), abs(r__2));
if (scale < xnorm * smlnum || scale == 0.f)
{
goto L20;
}
csrscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f)
{
*rcond = 1.f / anorm / ainvnm;
}
}
L20:
return 0;
/* End of CTPCON */
}
/* Subroutine */ int cpbcon_(char *uplo, integer *n, integer *kd, complex *ab,
integer *ldab, real *anorm, real *rcond, complex *work, real *rwork,
integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CPBCON estimates the reciprocal of the condition number (in the
1-norm) of a complex Hermitian positive definite band matrix using
the Cholesky factorization A = U**H*U or A = L*L**H computed by
CPBTRF.
An estimate is obtained for norm(inv(A)), and the reciprocal of the
condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangular factor stored in AB;
= 'L': Lower triangular factor stored in AB.
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 sub-diagonals if UPLO = 'L'. KD >= 0.
AB (input) COMPLEX array, dimension (LDAB,N)
The triangular factor U or L from the Cholesky factorization
A = U**H*U or A = L*L**H of the band matrix A, stored in the
first KD+1 rows of the array. The j-th column of U or L is
stored in the j-th column of the array AB as follows:
if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
ANORM (input) REAL
The 1-norm (or infinity-norm) of the Hermitian band matrix A.
RCOND (output) REAL
The reciprocal of the condition number of the matrix A,
computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
estimate of the 1-norm of inv(A) computed in this routine.
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
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, i__1;
real r__1, r__2;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static integer kase;
static real scale;
extern logical lsame_(char *, char *);
static logical upper;
extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real
*, integer *);
static integer ix;
extern integer icamax_(integer *, complex *, integer *);
static real scalel;
extern doublereal slamch_(char *);
extern /* Subroutine */ int clatbs_(char *, char *, char *, char *,
integer *, integer *, complex *, integer *, complex *, real *,
real *, integer *);
static real scaleu;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real ainvnm;
extern /* Subroutine */ int csrscl_(integer *, real *, complex *, integer
*);
static char normin[1];
static real smlnum;
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
*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;
} else if (*anorm < 0.f) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CPBCON", &i__1);
return 0;
}
/* Quick return if possible */
*rcond = 0.f;
if (*n == 0) {
*rcond = 1.f;
return 0;
} else if (*anorm == 0.f) {
return 0;
}
smlnum = slamch_("Safe minimum");
/* Estimate the 1-norm of the inverse. */
kase = 0;
*(unsigned char *)normin = 'N';
L10:
clacon_(n, &WORK(*n + 1), &WORK(1), &ainvnm, &kase);
if (kase != 0) {
if (upper) {
/* Multiply by inv(U'). */
clatbs_("Upper", "Conjugate transpose", "Non-unit", normin, n, kd,
&AB(1,1), ldab, &WORK(1), &scalel, &RWORK(1), info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(U). */
clatbs_("Upper", "No transpose", "Non-unit", normin, n, kd, &AB(1,1), ldab, &WORK(1), &scaleu, &RWORK(1), info);
} else {
/* Multiply by inv(L). */
clatbs_("Lower", "No transpose", "Non-unit", normin, n, kd, &AB(1,1), ldab, &WORK(1), &scalel, &RWORK(1), info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(L'). */
clatbs_("Lower", "Conjugate transpose", "Non-unit", normin, n, kd,
&AB(1,1), ldab, &WORK(1), &scaleu, &RWORK(1), info);
}
/* Multiply by 1/SCALE if doing so will not cause overflow. */
scale = scalel * scaleu;
if (scale != 1.f) {
ix = icamax_(n, &WORK(1), &c__1);
i__1 = ix;
if (scale < ((r__1 = WORK(ix).r, dabs(r__1)) + (r__2 = r_imag(&
WORK(ix)), dabs(r__2))) * smlnum || scale == 0.f) {
goto L20;
}
csrscl_(n, &scale, &WORK(1), &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f) {
*rcond = 1.f / ainvnm / *anorm;
}
L20:
return 0;
/* End of CPBCON */
} /* cpbcon_ */
/* 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_ */
/* 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_ */
