int ztrevc_(char *side, char *howmny, int *select,
int *n, doublecomplex *t, int *ldt, doublecomplex *vl,
int *ldvl, doublecomplex *vr, int *ldvr, int *mm, int
*m, doublecomplex *work, double *rwork, int *info)
{
/* System generated locals */
int t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3, i__4, i__5;
double d__1, d__2, d__3;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
int i__, j, k, ii, ki, is;
double ulp;
int allv;
double unfl, ovfl, smin;
int over;
double scale;
extern int lsame_(char *, char *);
double remax;
int leftv, bothv;
extern int zgemv_(char *, int *, int *,
doublecomplex *, doublecomplex *, int *, doublecomplex *,
int *, doublecomplex *, doublecomplex *, int *);
int somev;
extern int zcopy_(int *, doublecomplex *, int *,
doublecomplex *, int *), dlabad_(double *, double *);
extern double dlamch_(char *);
extern int xerbla_(char *, int *), zdscal_(
int *, double *, doublecomplex *, int *);
extern int izamax_(int *, doublecomplex *, int *);
int rightv;
extern double dzasum_(int *, doublecomplex *, int *);
double smlnum;
extern int zlatrs_(char *, char *, char *, char *,
int *, doublecomplex *, int *, doublecomplex *,
double *, double *, int *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZTREVC 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 ZHSEQR. */
/* 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 int 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*16 array, dimension (LDT,N) */
/* The upper triangular matrix T. T is modified, but restored */
/* on exit. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= MAX(1,N). */
/* VL (input/output) COMPLEX*16 array, dimension (LDVL,MM) */
/* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */
/* contain an N-by-N matrix Q (usually the unitary matrix Q of */
/* Schur vectors returned by ZHSEQR). */
/* On exit, if SIDE = 'L' or 'B', VL contains: */
/* if HOWMNY = 'A', the matrix Y of left eigenvectors of T; */
/* 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*16 array, dimension (LDVR,MM) */
/* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */
/* contain an N-by-N matrix Q (usually the unitary matrix Q of */
/* Schur vectors returned by ZHSEQR). */
/* On exit, if SIDE = 'R' or 'B', VR contains: */
/* if HOWMNY = 'A', the matrix X of right eigenvectors of T; */
/* 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*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* The algorithm used in this program is basically backward (forward) */
/* substitution, with scaling to make the the code robust against */
/* possible overflow. */
/* Each eigenvector is normalized so that the element of largest */
/* magnitude has magnitude 1; here the magnitude of a complex number */
/* (x,y) is taken to be |x| + |y|. */
/* ===================================================================== */
/* .. 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_("ZTREVC", &i__1);
return 0;
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
/* Set the constants to control overflow. */
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Precision");
smlnum = unfl * (*n / ulp);
/* Store the diagonal elements of T in working array WORK. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + *n;
i__3 = 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.;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
i__2 = j - 1;
rwork[j] = dzasum_(&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;
d__3 = ulp * ((d__1 = t[i__1].r, ABS(d__1)) + (d__2 = d_imag(&t[
ki + ki * t_dim1]), ABS(d__2)));
smin = MAX(d__3,smlnum);
work[1].r = 1., work[1].i = 0.;
/* Form right-hand side. */
i__1 = ki - 1;
for (k = 1; k <= i__1; ++k) {
i__2 = k;
i__3 = k + ki * t_dim1;
z__1.r = -t[i__3].r, z__1.i = -t[i__3].i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L40: */
}
/* Solve the triangular system: */
/* (T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK. */
i__1 = ki - 1;
for (k = 1; k <= i__1; ++k) {
i__2 = k + k * t_dim1;
i__3 = k + k * t_dim1;
i__4 = ki + ki * t_dim1;
z__1.r = t[i__3].r - t[i__4].r, z__1.i = t[i__3].i - t[i__4]
.i;
t[i__2].r = z__1.r, t[i__2].i = z__1.i;
i__2 = k + k * t_dim1;
if ((d__1 = t[i__2].r, ABS(d__1)) + (d__2 = d_imag(&t[k + k *
t_dim1]), ABS(d__2)) < smin) {
i__3 = k + k * t_dim1;
t[i__3].r = smin, t[i__3].i = 0.;
}
/* L50: */
}
if (ki > 1) {
i__1 = ki - 1;
zlatrs_("Upper", "No transpose", "Non-unit", "Y", &i__1, &t[
t_offset], ldt, &work[1], &scale, &rwork[1], info);
i__1 = ki;
work[i__1].r = scale, work[i__1].i = 0.;
}
/* Copy the vector x or Q*x to VR and normalize. */
if (! over) {
zcopy_(&ki, &work[1], &c__1, &vr[is * vr_dim1 + 1], &c__1);
ii = izamax_(&ki, &vr[is * vr_dim1 + 1], &c__1);
i__1 = ii + is * vr_dim1;
remax = 1. / ((d__1 = vr[i__1].r, ABS(d__1)) + (d__2 = d_imag(
&vr[ii + is * vr_dim1]), ABS(d__2)));
zdscal_(&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., vr[i__2].i = 0.;
/* L60: */
}
} else {
if (ki > 1) {
i__1 = ki - 1;
z__1.r = scale, z__1.i = 0.;
zgemv_("N", n, &i__1, &c_b2, &vr[vr_offset], ldvr, &work[
1], &c__1, &z__1, &vr[ki * vr_dim1 + 1], &c__1);
}
ii = izamax_(n, &vr[ki * vr_dim1 + 1], &c__1);
i__1 = ii + ki * vr_dim1;
remax = 1. / ((d__1 = vr[i__1].r, ABS(d__1)) + (d__2 = d_imag(
&vr[ii + ki * vr_dim1]), ABS(d__2)));
zdscal_(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;
d__3 = ulp * ((d__1 = t[i__2].r, ABS(d__1)) + (d__2 = d_imag(&t[
ki + ki * t_dim1]), ABS(d__2)));
smin = MAX(d__3,smlnum);
i__2 = *n;
work[i__2].r = 1., work[i__2].i = 0.;
/* Form right-hand side. */
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
i__3 = k;
d_cnjg(&z__2, &t[ki + k * t_dim1]);
z__1.r = -z__2.r, z__1.i = -z__2.i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L90: */
}
/* Solve the triangular system: */
/* (T(KI+1:N,KI+1:N) - T(KI,KI))'*X = SCALE*WORK. */
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
i__3 = k + k * t_dim1;
i__4 = k + k * t_dim1;
i__5 = ki + ki * t_dim1;
z__1.r = t[i__4].r - t[i__5].r, z__1.i = t[i__4].i - t[i__5]
.i;
t[i__3].r = z__1.r, t[i__3].i = z__1.i;
i__3 = k + k * t_dim1;
if ((d__1 = t[i__3].r, ABS(d__1)) + (d__2 = d_imag(&t[k + k *
t_dim1]), ABS(d__2)) < smin) {
i__4 = k + k * t_dim1;
t[i__4].r = smin, t[i__4].i = 0.;
}
/* L100: */
}
if (ki < *n) {
i__2 = *n - ki;
zlatrs_("Upper", "Conjugate transpose", "Non-unit", "Y", &
i__2, &t[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.;
}
/* Copy the vector x or Q*x to VL and normalize. */
if (! over) {
i__2 = *n - ki + 1;
zcopy_(&i__2, &work[ki], &c__1, &vl[ki + is * vl_dim1], &c__1)
;
i__2 = *n - ki + 1;
ii = izamax_(&i__2, &vl[ki + is * vl_dim1], &c__1) + ki - 1;
i__2 = ii + is * vl_dim1;
remax = 1. / ((d__1 = vl[i__2].r, ABS(d__1)) + (d__2 = d_imag(
&vl[ii + is * vl_dim1]), ABS(d__2)));
i__2 = *n - ki + 1;
zdscal_(&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., vl[i__3].i = 0.;
/* L110: */
}
} else {
if (ki < *n) {
i__2 = *n - ki;
z__1.r = scale, z__1.i = 0.;
zgemv_("N", n, &i__2, &c_b2, &vl[(ki + 1) * vl_dim1 + 1],
ldvl, &work[ki + 1], &c__1, &z__1, &vl[ki *
vl_dim1 + 1], &c__1);
}
ii = izamax_(n, &vl[ki * vl_dim1 + 1], &c__1);
i__2 = ii + ki * vl_dim1;
remax = 1. / ((d__1 = vl[i__2].r, ABS(d__1)) + (d__2 = d_imag(
&vl[ii + ki * vl_dim1]), ABS(d__2)));
zdscal_(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 ZTREVC */
} /* ztrevc_ */
int izamax( int n, doublecomplex *x, int incx)
{
return izamax_(&n, x, &incx);
}
/* Subroutine */
int zgecon_(char *norm, integer *n, doublecomplex *a, integer *lda, doublereal *anorm, doublereal *rcond, doublecomplex * work, doublereal *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1;
doublereal d__1, d__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
doublereal sl;
integer ix;
doublereal su;
integer kase, kase1;
doublereal scale;
extern logical lsame_(char *, char *);
integer isave[3];
extern /* Subroutine */
int zlacn2_(integer *, doublecomplex *, doublecomplex *, doublereal *, integer *, integer *);
extern doublereal dlamch_(char *);
extern /* Subroutine */
int xerbla_(char *, integer *);
doublereal ainvnm;
extern integer izamax_(integer *, doublecomplex *, integer *);
logical onenrm;
extern /* Subroutine */
int zdrscl_(integer *, doublereal *, doublecomplex *, integer *);
char normin[1];
doublereal smlnum;
extern /* Subroutine */
int zlatrs_(char *, char *, char *, char *, integer *, doublecomplex *, integer *, doublecomplex *, doublereal *, doublereal *, integer *);
/* -- LAPACK 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 */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--work;
--rwork;
/* Function Body */
*info = 0;
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
if (! onenrm && ! lsame_(norm, "I"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*lda < max(1,*n))
{
*info = -4;
}
else if (*anorm < 0.)
{
*info = -5;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZGECON", &i__1);
return 0;
}
/* Quick return if possible */
*rcond = 0.;
if (*n == 0)
{
*rcond = 1.;
return 0;
}
else if (*anorm == 0.)
{
return 0;
}
smlnum = dlamch_("Safe minimum");
/* Estimate the norm of inv(A). */
ainvnm = 0.;
*(unsigned char *)normin = 'N';
if (onenrm)
{
kase1 = 1;
}
else
{
kase1 = 2;
}
kase = 0;
L10:
zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
if (kase != 0)
{
if (kase == kase1)
{
/* Multiply by inv(L). */
zlatrs_("Lower", "No transpose", "Unit", normin, n, &a[a_offset], lda, &work[1], &sl, &rwork[1], info);
/* Multiply by inv(U). */
zlatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[ a_offset], lda, &work[1], &su, &rwork[*n + 1], info);
}
else
{
/* Multiply by inv(U**H). */
zlatrs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &a[ a_offset], lda, &work[1], &su, &rwork[*n + 1], info);
/* Multiply by inv(L**H). */
zlatrs_("Lower", "Conjugate transpose", "Unit", normin, n, &a[ a_offset], lda, &work[1], &sl, &rwork[1], info);
}
/* Divide X by 1/(SL*SU) if doing so will not cause overflow. */
scale = sl * su;
*(unsigned char *)normin = 'Y';
if (scale != 1.)
{
ix = izamax_(n, &work[1], &c__1);
i__1 = ix;
if (scale < ((d__1 = work[i__1].r, f2c_abs(d__1)) + (d__2 = d_imag(& work[ix]), f2c_abs(d__2))) * smlnum || scale == 0.)
{
goto L20;
}
zdrscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.)
{
*rcond = 1. / ainvnm / *anorm;
}
L20:
return 0;
/* End of ZGECON */
}
/* Subroutine */ int zlahef_(char *uplo, integer *n, integer *nb, integer *kb,
doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *w,
integer *ldw, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZLAHEF computes a partial factorization of a complex Hermitian
matrix A using the Bunch-Kaufman diagonal pivoting method. The
partial factorization has the form:
A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
( 0 U22 ) ( 0 D ) ( U12' U22' )
A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L'
( L21 I ) ( 0 A22 ) ( 0 I )
where the order of D is at most NB. The actual order is returned in
the argument KB, and is either NB or NB-1, or N if N <= NB.
Note that U' denotes the conjugate transpose of U.
ZLAHEF is an auxiliary routine called by ZHETRF. It uses blocked code
(calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or
A22 (if UPLO = 'L').
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the upper or lower triangular part of the
Hermitian matrix A is stored:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrix A. N >= 0.
NB (input) INTEGER
The maximum number of columns of the matrix A that should be
factored. NB should be at least 2 to allow for 2-by-2 pivot
blocks.
KB (output) INTEGER
The number of columns of A that were actually factored.
KB is either NB-1 or NB, or N if N <= NB.
A (input/output) COMPLEX*16 array, dimension (LDA,N)
On entry, the Hermitian matrix A. If UPLO = 'U', the leading
n-by-n upper triangular part of A contains the upper
triangular part of the matrix A, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading n-by-n lower triangular part of A contains the lower
triangular part of the matrix A, and the strictly upper
triangular part of A is not referenced.
On exit, A contains details of the partial factorization.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
IPIV (output) INTEGER array, dimension (N)
Details of the interchanges and the block structure of D.
If UPLO = 'U', only the last KB elements of IPIV are set;
if UPLO = 'L', only the first KB elements are set.
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.
W (workspace) COMPLEX*16 array, dimension (LDW,NB)
LDW (input) INTEGER
The leading dimension of the array W. LDW >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
> 0: if INFO = k, D(k,k) is exactly zero. The factorization
has been completed, but the block diagonal matrix D is
exactly singular.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b1 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double sqrt(doublereal), d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *), z_div(doublecomplex *,
doublecomplex *, doublecomplex *);
/* Local variables */
static integer imax, jmax, j, k;
static doublereal t, alpha;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
static integer kstep;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static doublereal r1;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *);
static doublecomplex d11, d21, d22;
static integer jb, jj, kk, jp, kp;
static doublereal absakk;
static integer kw;
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *);
static doublereal colmax;
extern /* Subroutine */ int zlacgv_(integer *, doublecomplex *, integer *)
;
extern integer izamax_(integer *, doublecomplex *, integer *);
static doublereal rowmax;
static integer kkw;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define w_subscr(a_1,a_2) (a_2)*w_dim1 + a_1
#define w_ref(a_1,a_2) w[w_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--ipiv;
w_dim1 = *ldw;
w_offset = 1 + w_dim1 * 1;
w -= w_offset;
/* Function Body */
*info = 0;
/* Initialize ALPHA for use in choosing pivot block size. */
alpha = (sqrt(17.) + 1.) / 8.;
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 (note that conjg(W) is actually stored)
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 */
i__1 = k - 1;
zcopy_(&i__1, &a_ref(1, k), &c__1, &w_ref(1, kw), &c__1);
i__1 = w_subscr(k, kw);
i__2 = a_subscr(k, k);
d__1 = a[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
if (k < *n) {
i__1 = *n - k;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &k, &i__1, &z__1, &a_ref(1, k + 1), lda, &
w_ref(k, kw + 1), ldw, &c_b1, &w_ref(1, kw), &c__1);
i__1 = w_subscr(k, kw);
i__2 = w_subscr(k, kw);
d__1 = w[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
}
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 = w_subscr(k, kw);
absakk = (d__1 = w[i__1].r, abs(d__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 = izamax_(&i__1, &w_ref(1, kw), &c__1);
i__1 = w_subscr(imax, kw);
colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w_ref(
imax, kw)), abs(d__2));
} else {
colmax = 0.;
}
if (max(absakk,colmax) == 0.) {
/* Column K is zero: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = a_subscr(k, k);
i__2 = a_subscr(k, k);
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
} 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 */
i__1 = imax - 1;
zcopy_(&i__1, &a_ref(1, imax), &c__1, &w_ref(1, kw - 1), &
c__1);
i__1 = w_subscr(imax, kw - 1);
i__2 = a_subscr(imax, imax);
d__1 = a[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
i__1 = k - imax;
zcopy_(&i__1, &a_ref(imax, imax + 1), lda, &w_ref(imax + 1,
kw - 1), &c__1);
i__1 = k - imax;
zlacgv_(&i__1, &w_ref(imax + 1, kw - 1), &c__1);
if (k < *n) {
i__1 = *n - k;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &k, &i__1, &z__1, &a_ref(1, k + 1),
lda, &w_ref(imax, kw + 1), ldw, &c_b1, &w_ref(1,
kw - 1), &c__1);
i__1 = w_subscr(imax, kw - 1);
i__2 = w_subscr(imax, kw - 1);
d__1 = w[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
}
/* 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 + izamax_(&i__1, &w_ref(imax + 1, kw - 1), &c__1);
i__1 = w_subscr(jmax, kw - 1);
rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&
w_ref(jmax, kw - 1)), abs(d__2));
if (imax > 1) {
i__1 = imax - 1;
jmax = izamax_(&i__1, &w_ref(1, kw - 1), &c__1);
/* Computing MAX */
i__1 = w_subscr(jmax, kw - 1);
d__3 = rowmax, d__4 = (d__1 = w[i__1].r, abs(d__1)) + (
d__2 = d_imag(&w_ref(jmax, kw - 1)), abs(d__2));
rowmax = max(d__3,d__4);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else /* if(complicated condition) */ {
i__1 = w_subscr(imax, kw - 1);
if ((d__1 = w[i__1].r, abs(d__1)) >= 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 */
zcopy_(&k, &w_ref(1, kw - 1), &c__1, &w_ref(1, kw), &
c__1);
} else {
/* interchange rows and columns K-1 and IMAX, use 2-by-2
pivot block */
kp = imax;
kstep = 2;
}
}
}
kk = k - kstep + 1;
kkw = *nb + kk - *n;
/* Updated column KP is already stored in column KKW of W */
if (kp != kk) {
/* Copy non-updated column KK to column KP */
i__1 = a_subscr(kp, kp);
i__2 = a_subscr(kk, kk);
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = kk - 1 - kp;
zcopy_(&i__1, &a_ref(kp + 1, kk), &c__1, &a_ref(kp, kp + 1),
lda);
i__1 = kk - 1 - kp;
zlacgv_(&i__1, &a_ref(kp, kp + 1), lda);
i__1 = kp - 1;
zcopy_(&i__1, &a_ref(1, kk), &c__1, &a_ref(1, kp), &c__1);
/* Interchange rows KK and KP in last KK columns of A and W */
if (kk < *n) {
i__1 = *n - kk;
zswap_(&i__1, &a_ref(kk, kk + 1), lda, &a_ref(kp, kk + 1),
lda);
}
i__1 = *n - kk + 1;
zswap_(&i__1, &w_ref(kk, kkw), ldw, &w_ref(kp, kkw), ldw);
}
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column KW of W now holds
W(k) = U(k)*D(k)
where U(k) is the k-th column of U
Store U(k) in column k of A */
zcopy_(&k, &w_ref(1, kw), &c__1, &a_ref(1, k), &c__1);
i__1 = a_subscr(k, k);
r1 = 1. / a[i__1].r;
i__1 = k - 1;
zdscal_(&i__1, &r1, &a_ref(1, k), &c__1);
/* Conjugate W(k) */
i__1 = k - 1;
zlacgv_(&i__1, &w_ref(1, kw), &c__1);
} else {
/* 2-by-2 pivot block D(k): columns KW and KW-1 of W 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 */
if (k > 2) {
/* Store U(k) and U(k-1) in columns k and k-1 of A */
i__1 = w_subscr(k - 1, kw);
d21.r = w[i__1].r, d21.i = w[i__1].i;
d_cnjg(&z__2, &d21);
z_div(&z__1, &w_ref(k, kw), &z__2);
d11.r = z__1.r, d11.i = z__1.i;
z_div(&z__1, &w_ref(k - 1, kw - 1), &d21);
d22.r = z__1.r, d22.i = z__1.i;
z__1.r = d11.r * d22.r - d11.i * d22.i, z__1.i = d11.r *
d22.i + d11.i * d22.r;
t = 1. / (z__1.r - 1.);
z__2.r = t, z__2.i = 0.;
z_div(&z__1, &z__2, &d21);
d21.r = z__1.r, d21.i = z__1.i;
i__1 = k - 2;
for (j = 1; j <= i__1; ++j) {
i__2 = a_subscr(j, k - 1);
i__3 = w_subscr(j, kw - 1);
z__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i,
z__3.i = d11.r * w[i__3].i + d11.i * w[i__3]
.r;
i__4 = w_subscr(j, kw);
z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4]
.i;
z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i =
d21.r * z__2.i + d21.i * z__2.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = a_subscr(j, k);
d_cnjg(&z__2, &d21);
i__3 = w_subscr(j, kw);
z__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i,
z__4.i = d22.r * w[i__3].i + d22.i * w[i__3]
.r;
i__4 = w_subscr(j, kw - 1);
z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4]
.i;
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i =
z__2.r * z__3.i + z__2.i * z__3.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L20: */
}
}
/* Copy D(k) to A */
i__1 = a_subscr(k - 1, k - 1);
i__2 = w_subscr(k - 1, kw - 1);
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = a_subscr(k - 1, k);
i__2 = w_subscr(k - 1, kw);
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = a_subscr(k, k);
i__2 = w_subscr(k, kw);
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
/* Conjugate W(k) and W(k-1) */
i__1 = k - 1;
zlacgv_(&i__1, &w_ref(1, kw), &c__1);
i__1 = k - 2;
zlacgv_(&i__1, &w_ref(1, kw - 1), &c__1);
}
}
/* 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' = A11 - U12*W'
computing blocks of NB columns at a time (note that conjg(W) is
actually stored) */
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;
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 = a_subscr(jj, jj);
i__4 = a_subscr(jj, jj);
d__1 = a[i__4].r;
a[i__3].r = d__1, a[i__3].i = 0.;
i__3 = jj - j + 1;
i__4 = *n - k;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__3, &i__4, &z__1, &a_ref(j, k + 1),
lda, &w_ref(jj, kw + 1), ldw, &c_b1, &a_ref(j, jj), &
c__1);
i__3 = a_subscr(jj, jj);
i__4 = a_subscr(jj, jj);
d__1 = a[i__4].r;
a[i__3].r = d__1, a[i__3].i = 0.;
/* L40: */
}
/* Update the rectangular superdiagonal block */
i__2 = j - 1;
i__3 = *n - k;
z__1.r = -1., z__1.i = 0.;
zgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &z__1, &
a_ref(1, k + 1), lda, &w_ref(j, kw + 1), ldw, &c_b1, &
a_ref(1, j), lda);
/* L50: */
}
/* Put U12 in standard form by partially undoing the interchanges
in columns k+1:n */
j = k + 1;
L60:
jj = j;
jp = ipiv[j];
if (jp < 0) {
jp = -jp;
++j;
}
++j;
if (jp != jj && j <= *n) {
i__1 = *n - j + 1;
zswap_(&i__1, &a_ref(jp, j), lda, &a_ref(jj, j), 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 (note that conjg(W) is actually stored)
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 = w_subscr(k, k);
i__2 = a_subscr(k, k);
d__1 = a[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
if (k < *n) {
i__1 = *n - k;
zcopy_(&i__1, &a_ref(k + 1, k), &c__1, &w_ref(k + 1, k), &c__1);
}
i__1 = *n - k + 1;
i__2 = k - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__1, &i__2, &z__1, &a_ref(k, 1), lda, &w_ref(
k, 1), ldw, &c_b1, &w_ref(k, k), &c__1);
i__1 = w_subscr(k, k);
i__2 = w_subscr(k, k);
d__1 = w[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
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 = w_subscr(k, k);
absakk = (d__1 = w[i__1].r, abs(d__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 + izamax_(&i__1, &w_ref(k + 1, k), &c__1);
i__1 = w_subscr(imax, k);
colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w_ref(
imax, k)), abs(d__2));
} else {
colmax = 0.;
}
if (max(absakk,colmax) == 0.) {
/* Column K is zero: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = a_subscr(k, k);
i__2 = a_subscr(k, k);
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
} 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;
zcopy_(&i__1, &a_ref(imax, k), lda, &w_ref(k, k + 1), &c__1);
i__1 = imax - k;
zlacgv_(&i__1, &w_ref(k, k + 1), &c__1);
i__1 = w_subscr(imax, k + 1);
i__2 = a_subscr(imax, imax);
d__1 = a[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
if (imax < *n) {
i__1 = *n - imax;
zcopy_(&i__1, &a_ref(imax + 1, imax), &c__1, &w_ref(imax
+ 1, k + 1), &c__1);
}
i__1 = *n - k + 1;
i__2 = k - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__1, &i__2, &z__1, &a_ref(k, 1), lda,
&w_ref(imax, 1), ldw, &c_b1, &w_ref(k, k + 1), &c__1);
i__1 = w_subscr(imax, k + 1);
i__2 = w_subscr(imax, k + 1);
d__1 = w[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
/* 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 + izamax_(&i__1, &w_ref(k, k + 1), &c__1);
i__1 = w_subscr(jmax, k + 1);
rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&
w_ref(jmax, k + 1)), abs(d__2));
if (imax < *n) {
i__1 = *n - imax;
jmax = imax + izamax_(&i__1, &w_ref(imax + 1, k + 1), &
c__1);
/* Computing MAX */
i__1 = w_subscr(jmax, k + 1);
d__3 = rowmax, d__4 = (d__1 = w[i__1].r, abs(d__1)) + (
d__2 = d_imag(&w_ref(jmax, k + 1)), abs(d__2));
rowmax = max(d__3,d__4);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else /* if(complicated condition) */ {
i__1 = w_subscr(imax, k + 1);
if ((d__1 = w[i__1].r, abs(d__1)) >= 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 */
i__1 = *n - k + 1;
zcopy_(&i__1, &w_ref(k, k + 1), &c__1, &w_ref(k, k), &
c__1);
} else {
/* interchange rows and columns K+1 and IMAX, use 2-by-2
pivot block */
kp = imax;
kstep = 2;
}
}
}
kk = k + kstep - 1;
/* Updated column KP is already stored in column KK of W */
if (kp != kk) {
/* Copy non-updated column KK to column KP */
i__1 = a_subscr(kp, kp);
i__2 = a_subscr(kk, kk);
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = kp - kk - 1;
zcopy_(&i__1, &a_ref(kk + 1, kk), &c__1, &a_ref(kp, kk + 1),
lda);
i__1 = kp - kk - 1;
zlacgv_(&i__1, &a_ref(kp, kk + 1), lda);
if (kp < *n) {
i__1 = *n - kp;
zcopy_(&i__1, &a_ref(kp + 1, kk), &c__1, &a_ref(kp + 1,
kp), &c__1);
}
/* Interchange rows KK and KP in first KK columns of A and W */
i__1 = kk - 1;
zswap_(&i__1, &a_ref(kk, 1), lda, &a_ref(kp, 1), lda);
zswap_(&kk, &w_ref(kk, 1), ldw, &w_ref(kp, 1), 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 L(k) in column k of A */
i__1 = *n - k + 1;
zcopy_(&i__1, &w_ref(k, k), &c__1, &a_ref(k, k), &c__1);
if (k < *n) {
i__1 = a_subscr(k, k);
r1 = 1. / a[i__1].r;
i__1 = *n - k;
zdscal_(&i__1, &r1, &a_ref(k + 1, k), &c__1);
/* Conjugate W(k) */
i__1 = *n - k;
zlacgv_(&i__1, &w_ref(k + 1, k), &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 */
if (k < *n - 1) {
/* Store L(k) and L(k+1) in columns k and k+1 of A */
i__1 = w_subscr(k + 1, k);
d21.r = w[i__1].r, d21.i = w[i__1].i;
z_div(&z__1, &w_ref(k + 1, k + 1), &d21);
d11.r = z__1.r, d11.i = z__1.i;
d_cnjg(&z__2, &d21);
z_div(&z__1, &w_ref(k, k), &z__2);
d22.r = z__1.r, d22.i = z__1.i;
z__1.r = d11.r * d22.r - d11.i * d22.i, z__1.i = d11.r *
d22.i + d11.i * d22.r;
t = 1. / (z__1.r - 1.);
z__2.r = t, z__2.i = 0.;
z_div(&z__1, &z__2, &d21);
d21.r = z__1.r, d21.i = z__1.i;
i__1 = *n;
for (j = k + 2; j <= i__1; ++j) {
i__2 = a_subscr(j, k);
d_cnjg(&z__2, &d21);
i__3 = w_subscr(j, k);
z__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i,
z__4.i = d11.r * w[i__3].i + d11.i * w[i__3]
.r;
i__4 = w_subscr(j, k + 1);
z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4]
.i;
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i =
z__2.r * z__3.i + z__2.i * z__3.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = a_subscr(j, k + 1);
i__3 = w_subscr(j, k + 1);
z__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i,
z__3.i = d22.r * w[i__3].i + d22.i * w[i__3]
.r;
i__4 = w_subscr(j, k);
z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4]
.i;
z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i =
d21.r * z__2.i + d21.i * z__2.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L80: */
}
}
/* Copy D(k) to A */
i__1 = a_subscr(k, k);
i__2 = w_subscr(k, k);
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = a_subscr(k + 1, k);
i__2 = w_subscr(k + 1, k);
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = a_subscr(k + 1, k + 1);
i__2 = w_subscr(k + 1, k + 1);
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
/* Conjugate W(k) and W(k+1) */
i__1 = *n - k;
zlacgv_(&i__1, &w_ref(k + 1, k), &c__1);
i__1 = *n - k - 1;
zlacgv_(&i__1, &w_ref(k + 2, k + 1), &c__1);
}
}
/* 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' = A22 - L21*W'
computing blocks of NB columns at a time (note that conjg(W) is
actually stored) */
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;
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 = a_subscr(jj, jj);
i__5 = a_subscr(jj, jj);
d__1 = a[i__5].r;
a[i__4].r = d__1, a[i__4].i = 0.;
i__4 = j + jb - jj;
i__5 = k - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__4, &i__5, &z__1, &a_ref(jj, 1),
lda, &w_ref(jj, 1), ldw, &c_b1, &a_ref(jj, jj), &c__1);
i__4 = a_subscr(jj, jj);
i__5 = a_subscr(jj, jj);
d__1 = a[i__5].r;
a[i__4].r = d__1, a[i__4].i = 0.;
/* L100: */
}
/* Update the rectangular subdiagonal block */
if (j + jb <= *n) {
i__3 = *n - j - jb + 1;
i__4 = k - 1;
z__1.r = -1., z__1.i = 0.;
zgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &z__1,
&a_ref(j + jb, 1), lda, &w_ref(j, 1), ldw, &c_b1, &
a_ref(j + jb, j), lda);
}
/* L110: */
}
/* Put L21 in standard form by partially undoing the interchanges
in columns 1:k-1 */
j = k - 1;
L120:
jj = j;
jp = ipiv[j];
if (jp < 0) {
jp = -jp;
--j;
}
--j;
if (jp != jj && j >= 1) {
zswap_(&j, &a_ref(jp, 1), lda, &a_ref(jj, 1), lda);
}
if (j >= 1) {
goto L120;
}
/* Set KB to the number of columns factorized */
*kb = k - 1;
}
return 0;
/* End of ZLAHEF */
} /* zlahef_ */
int zgst04(int n, int nrhs, doublecomplex *x, int ldx, doublecomplex *xact,
int ldxact, double rcond, double *resid)
{
/*
Purpose
=======
ZGST04 computes the difference between a computed solution and the
true solution to a system of linear equations.
RESID = ( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS ),
where RCOND is the reciprocal of the condition number and EPS is the
machine epsilon.
Arguments
=========
N (input) INT
The number of rows of the matrices X and XACT. N >= 0.
NRHS (input) INT
The number of columns of the matrices X and XACT. NRHS >= 0.
X (input) DOUBLE COMPLEX PRECISION array, dimension (LDX,NRHS)
The computed solution vectors. Each vector is stored as a
column of the matrix X.
LDX (input) INT
The leading dimension of the array X. LDX >= max(1,N).
XACT (input) DOUBLE COMPLEX PRECISION array, dimension( LDX, NRHS )
The exact solution vectors. Each vector is stored as a
column of the matrix XACT.
LDXACT (input) INT
The leading dimension of the array XACT. LDXACT >= max(1,N).
RCOND (input) DOUBLE COMPLEX PRECISION
The reciprocal of the condition number of the coefficient
matrix in the system of equations.
RESID (output) DOUBLE PRECISION
The maximum over the NRHS solution vectors of
( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS )
=====================================================================
*/
/* Table of constant values */
int c__1 = 1;
/* System generated locals */
double d__1, d__2, d__3, d__4;
/* Local variables */
int i, j, n__1;
int ix;
double xnorm;
double eps;
double diffnm;
/* Function prototypes */
extern int izamax_(int *, doublecomplex *, int *);
/* Quick exit if N = 0 or NRHS = 0. */
if ( n <= 0 || nrhs <= 0 ) {
*resid = 0.;
return 0;
}
/* Exit with RESID = 1/EPS if RCOND is invalid. */
eps = dlamch_("Epsilon");
if ( rcond < 0. ) {
*resid = 1. / eps;
return 0;
}
/* Compute the maximum of norm(X - XACT) / ( norm(XACT) * EPS )
over all the vectors X and XACT . */
*resid = 0.;
for (j = 0; j < nrhs; ++j) {
n__1 = n;
ix = izamax_(&n__1, &xact[j*ldxact], &c__1);
xnorm = (d__1 = xact[ix-1 + j*ldxact].r, fabs(d__1)) +
(d__2 = xact[ix-1 + j*ldxact].i, fabs(d__2));
diffnm = 0.;
for (i = 0; i < n; ++i) {
/* Computing MAX */
d__3 = diffnm;
d__4 = (d__1 = x[i+j*ldx].r-xact[i+j*ldxact].r, fabs(d__1)) +
(d__2 = x[i+j*ldx].i-xact[i+j*ldxact].i, fabs(d__2));
diffnm = SUPERLU_MAX(d__3,d__4);
}
if (xnorm <= 0.) {
if (diffnm > 0.) {
*resid = 1. / eps;
}
} else {
/* Computing MAX */
d__1 = *resid, d__2 = diffnm / xnorm * rcond;
*resid = SUPERLU_MAX(d__1,d__2);
}
}
if (*resid * eps < 1.) {
*resid /= eps;
}
return 0;
} /* zgst04_ */
/*< >*/
/* Subroutine */ int ztrevc_(char *side, char *howmny, logical *select,
integer *n, doublecomplex *t, integer *ldt, doublecomplex *vl,
integer *ldvl, doublecomplex *vr, integer *ldvr, integer *mm, integer
*m, doublecomplex *work, doublereal *rwork, integer *info, ftnlen
side_len, ftnlen howmny_len)
{
/* System generated locals */
integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j, k, ii, ki, is;
doublereal ulp;
logical allv;
doublereal unfl, ovfl, smin;
logical over;
doublereal scale;
extern logical lsame_(const char *, const char *, ftnlen, ftnlen);
doublereal remax;
logical leftv, bothv;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, ftnlen);
logical somev;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zdscal_(
integer *, doublereal *, doublecomplex *, integer *);
extern integer izamax_(integer *, doublecomplex *, integer *);
logical rightv;
extern doublereal dzasum_(integer *, doublecomplex *, integer *);
doublereal smlnum;
extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, doublereal *, integer *, ftnlen, ftnlen, ftnlen,
ftnlen);
(void)side_len;
(void)howmny_len;
/* -- 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 .. */
/*< CHARACTER HOWMNY, SIDE >*/
/*< INTEGER INFO, LDT, LDVL, LDVR, M, MM, N >*/
/* .. */
/* .. Array Arguments .. */
/*< LOGICAL SELECT( * ) >*/
/*< DOUBLE PRECISION RWORK( * ) >*/
/*< >*/
/* .. */
/* Purpose */
/* ======= */
/* ZTREVC computes some or all of the right and/or left eigenvectors of */
/* a complex upper triangular matrix T. */
/* The right eigenvector x and the left eigenvector y of T corresponding */
/* to an eigenvalue w are defined by: */
/* T*x = w*x, y'*T = w*y' */
/* where y' denotes the conjugate transpose of the vector y. */
/* If all eigenvectors are requested, the routine may either return the */
/* matrices X and/or Y of right or left eigenvectors of T, or the */
/* products Q*X and/or Q*Y, where Q is an input unitary */
/* matrix. If T was obtained from the Schur factorization of an */
/* original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of */
/* right or left eigenvectors of A. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'R': compute right eigenvectors only; */
/* = 'L': compute left eigenvectors only; */
/* = 'B': compute both right and left eigenvectors. */
/* HOWMNY (input) CHARACTER*1 */
/* = 'A': compute all right and/or left eigenvectors; */
/* = 'B': compute all right and/or left eigenvectors, */
/* and backtransform them using the input matrices */
/* supplied in VR and/or VL; */
/* = 'S': compute selected right and/or left eigenvectors, */
/* specified by the logical array SELECT. */
/* SELECT (input) LOGICAL array, dimension (N) */
/* If HOWMNY = 'S', SELECT specifies the eigenvectors to be */
/* computed. */
/* If HOWMNY = 'A' or 'B', SELECT is not referenced. */
/* To select the eigenvector corresponding to the j-th */
/* eigenvalue, SELECT(j) must be set to .TRUE.. */
/* N (input) INTEGER */
/* The order of the matrix T. N >= 0. */
/* T (input/output) COMPLEX*16 array, dimension (LDT,N) */
/* The upper triangular matrix T. T is modified, but restored */
/* on exit. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= max(1,N). */
/* VL (input/output) COMPLEX*16 array, dimension (LDVL,MM) */
/* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */
/* contain an N-by-N matrix Q (usually the unitary matrix Q of */
/* Schur vectors returned by ZHSEQR). */
/* On exit, if SIDE = 'L' or 'B', VL contains: */
/* if HOWMNY = 'A', the matrix Y of left eigenvectors of T; */
/* VL is lower triangular. The i-th column */
/* VL(i) of VL is the eigenvector corresponding */
/* to T(i,i). */
/* if HOWMNY = 'B', the matrix Q*Y; */
/* if HOWMNY = 'S', the left eigenvectors of T specified by */
/* SELECT, stored consecutively in the columns */
/* of VL, in the same order as their */
/* eigenvalues. */
/* If SIDE = 'R', VL is not referenced. */
/* LDVL (input) INTEGER */
/* The leading dimension of the array VL. LDVL >= max(1,N) if */
/* SIDE = 'L' or 'B'; LDVL >= 1 otherwise. */
/* VR (input/output) COMPLEX*16 array, dimension (LDVR,MM) */
/* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */
/* contain an N-by-N matrix Q (usually the unitary matrix Q of */
/* Schur vectors returned by ZHSEQR). */
/* On exit, if SIDE = 'R' or 'B', VR contains: */
/* if HOWMNY = 'A', the matrix X of right eigenvectors of T; */
/* VR is upper triangular. The i-th column */
/* VR(i) of VR is the eigenvector corresponding */
/* to T(i,i). */
/* if HOWMNY = 'B', the matrix Q*X; */
/* if HOWMNY = 'S', the right eigenvectors of T specified by */
/* SELECT, stored consecutively in the columns */
/* of VR, in the same order as their */
/* eigenvalues. */
/* If SIDE = 'L', VR is not referenced. */
/* LDVR (input) INTEGER */
/* The leading dimension of the array VR. LDVR >= max(1,N) if */
/* SIDE = 'R' or 'B'; LDVR >= 1 otherwise. */
/* MM (input) INTEGER */
/* The number of columns in the arrays VL and/or VR. MM >= M. */
/* M (output) INTEGER */
/* The number of columns in the arrays VL and/or VR actually */
/* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M */
/* is set to N. Each selected eigenvector occupies one */
/* column. */
/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* The algorithm used in this program is basically backward (forward) */
/* substitution, with scaling to make the the code robust against */
/* possible overflow. */
/* Each eigenvector is normalized so that the element of largest */
/* magnitude has magnitude 1; here the magnitude of a complex number */
/* (x,y) is taken to be |x| + |y|. */
/* ===================================================================== */
/* .. Parameters .. */
/*< DOUBLE PRECISION ZERO, ONE >*/
/*< PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) >*/
/*< COMPLEX*16 CMZERO, CMONE >*/
/*< >*/
/* .. */
/* .. Local Scalars .. */
/*< LOGICAL ALLV, BOTHV, LEFTV, OVER, RIGHTV, SOMEV >*/
/*< INTEGER I, II, IS, J, K, KI >*/
/*< DOUBLE PRECISION OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL >*/
/*< COMPLEX*16 CDUM >*/
/* .. */
/* .. External Functions .. */
/*< LOGICAL LSAME >*/
/*< INTEGER IZAMAX >*/
/*< DOUBLE PRECISION DLAMCH, DZASUM >*/
/*< EXTERNAL LSAME, IZAMAX, DLAMCH, DZASUM >*/
/* .. */
/* .. External Subroutines .. */
/*< EXTERNAL XERBLA, ZCOPY, ZDSCAL, ZGEMV, ZLATRS >*/
/* .. */
/* .. Intrinsic Functions .. */
/*< INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX >*/
/* .. */
/* .. Statement Functions .. */
/*< DOUBLE PRECISION CABS1 >*/
/* .. */
/* .. Statement Function definitions .. */
/*< CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) >*/
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters */
/*< BOTHV = LSAME( SIDE, 'B' ) >*/
/* 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", (ftnlen)1, (ftnlen)1);
/*< RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV >*/
rightv = lsame_(side, "R", (ftnlen)1, (ftnlen)1) || bothv;
/*< LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV >*/
leftv = lsame_(side, "L", (ftnlen)1, (ftnlen)1) || bothv;
/*< ALLV = LSAME( HOWMNY, 'A' ) >*/
allv = lsame_(howmny, "A", (ftnlen)1, (ftnlen)1);
/*< OVER = LSAME( HOWMNY, 'B' ) >*/
over = lsame_(howmny, "B", (ftnlen)1, (ftnlen)1);
/*< SOMEV = LSAME( HOWMNY, 'S' ) >*/
somev = lsame_(howmny, "S", (ftnlen)1, (ftnlen)1);
/* Set M to the number of columns required to store the selected */
/* eigenvectors. */
/*< IF( SOMEV ) THEN >*/
if (somev) {
/*< M = 0 >*/
*m = 0;
/*< DO 10 J = 1, N >*/
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/*< >*/
if (select[j]) {
++(*m);
}
/*< 10 CONTINUE >*/
/* L10: */
}
/*< ELSE >*/
} else {
/*< M = N >*/
*m = *n;
/*< END IF >*/
}
/*< INFO = 0 >*/
*info = 0;
/*< IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN >*/
if (! rightv && ! leftv) {
/*< INFO = -1 >*/
*info = -1;
/*< ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN >*/
} else if (! allv && ! over && ! somev) {
/*< INFO = -2 >*/
*info = -2;
/*< ELSE IF( N.LT.0 ) THEN >*/
} else if (*n < 0) {
/*< INFO = -4 >*/
*info = -4;
/*< ELSE IF( LDT.LT.MAX( 1, N ) ) THEN >*/
} else if (*ldt < max(1,*n)) {
/*< INFO = -6 >*/
*info = -6;
/*< ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN >*/
} else if (*ldvl < 1 || (leftv && *ldvl < *n)) {
/*< INFO = -8 >*/
*info = -8;
/*< ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN >*/
} else if (*ldvr < 1 || (rightv && *ldvr < *n)) {
/*< INFO = -10 >*/
*info = -10;
/*< ELSE IF( MM.LT.M ) THEN >*/
} else if (*mm < *m) {
/*< INFO = -11 >*/
*info = -11;
/*< END IF >*/
}
/*< IF( INFO.NE.0 ) THEN >*/
if (*info != 0) {
/*< CALL XERBLA( 'ZTREVC', -INFO ) >*/
i__1 = -(*info);
xerbla_("ZTREVC", &i__1, (ftnlen)6);
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/* Quick return if possible. */
/*< >*/
if (*n == 0) {
return 0;
}
/* Set the constants to control overflow. */
/*< UNFL = DLAMCH( 'Safe minimum' ) >*/
unfl = dlamch_("Safe minimum", (ftnlen)12);
/*< OVFL = ONE / UNFL >*/
ovfl = 1. / unfl;
/*< CALL DLABAD( UNFL, OVFL ) >*/
dlabad_(&unfl, &ovfl);
/*< ULP = DLAMCH( 'Precision' ) >*/
ulp = dlamch_("Precision", (ftnlen)9);
/*< SMLNUM = UNFL*( N / ULP ) >*/
smlnum = unfl * (*n / ulp);
/* Store the diagonal elements of T in working array WORK. */
/*< DO 20 I = 1, N >*/
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< WORK( I+N ) = T( I, 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;
/*< 20 CONTINUE >*/
/* L20: */
}
/* Compute 1-norm of each column of strictly upper triangular */
/* part of T to control overflow in triangular solver. */
/*< RWORK( 1 ) = ZERO >*/
rwork[1] = 0.;
/*< DO 30 J = 2, N >*/
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
/*< RWORK( J ) = DZASUM( J-1, T( 1, J ), 1 ) >*/
i__2 = j - 1;
rwork[j] = dzasum_(&i__2, &t[j * t_dim1 + 1], &c__1);
/*< 30 CONTINUE >*/
/* L30: */
}
/*< IF( RIGHTV ) THEN >*/
if (rightv) {
/* Compute right eigenvectors. */
/*< IS = M >*/
is = *m;
/*< DO 80 KI = N, 1, -1 >*/
for (ki = *n; ki >= 1; --ki) {
/*< IF( SOMEV ) THEN >*/
if (somev) {
/*< >*/
if (! select[ki]) {
goto L80;
}
/*< END IF >*/
}
/*< SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM ) >*/
/* Computing MAX */
i__1 = ki + ki * t_dim1;
d__3 = ulp * ((d__1 = t[i__1].r, abs(d__1)) + (d__2 = d_imag(&t[
ki + ki * t_dim1]), abs(d__2)));
smin = max(d__3,smlnum);
/*< WORK( 1 ) = CMONE >*/
work[1].r = 1., work[1].i = 0.;
/* Form right-hand side. */
/*< DO 40 K = 1, KI - 1 >*/
i__1 = ki - 1;
for (k = 1; k <= i__1; ++k) {
/*< WORK( K ) = -T( K, KI ) >*/
i__2 = k;
i__3 = k + ki * t_dim1;
z__1.r = -t[i__3].r, z__1.i = -t[i__3].i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/*< 40 CONTINUE >*/
/* L40: */
}
/* Solve the triangular system: */
/* (T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK. */
/*< DO 50 K = 1, KI - 1 >*/
i__1 = ki - 1;
for (k = 1; k <= i__1; ++k) {
/*< T( K, K ) = T( K, K ) - T( KI, KI ) >*/
i__2 = k + k * t_dim1;
i__3 = k + k * t_dim1;
i__4 = ki + ki * t_dim1;
z__1.r = t[i__3].r - t[i__4].r, z__1.i = t[i__3].i - t[i__4]
.i;
t[i__2].r = z__1.r, t[i__2].i = z__1.i;
/*< >*/
i__2 = k + k * t_dim1;
if ((d__1 = t[i__2].r, abs(d__1)) + (d__2 = d_imag(&t[k + k *
t_dim1]), abs(d__2)) < smin) {
i__3 = k + k * t_dim1;
t[i__3].r = smin, t[i__3].i = 0.;
}
/*< 50 CONTINUE >*/
/* L50: */
}
/*< IF( KI.GT.1 ) THEN >*/
if (ki > 1) {
/*< >*/
i__1 = ki - 1;
zlatrs_("Upper", "No transpose", "Non-unit", "Y", &i__1, &t[
t_offset], ldt, &work[1], &scale, &rwork[1], info, (
ftnlen)5, (ftnlen)12, (ftnlen)8, (ftnlen)1);
/*< WORK( KI ) = SCALE >*/
i__1 = ki;
work[i__1].r = scale, work[i__1].i = 0.;
/*< END IF >*/
}
/* Copy the vector x or Q*x to VR and normalize. */
/*< IF( .NOT.OVER ) THEN >*/
if (! over) {
/*< CALL ZCOPY( KI, WORK( 1 ), 1, VR( 1, IS ), 1 ) >*/
zcopy_(&ki, &work[1], &c__1, &vr[is * vr_dim1 + 1], &c__1);
/*< II = IZAMAX( KI, VR( 1, IS ), 1 ) >*/
ii = izamax_(&ki, &vr[is * vr_dim1 + 1], &c__1);
/*< REMAX = ONE / CABS1( VR( II, IS ) ) >*/
i__1 = ii + is * vr_dim1;
remax = 1. / ((d__1 = vr[i__1].r, abs(d__1)) + (d__2 = d_imag(
&vr[ii + is * vr_dim1]), abs(d__2)));
/*< CALL ZDSCAL( KI, REMAX, VR( 1, IS ), 1 ) >*/
zdscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1);
/*< DO 60 K = KI + 1, N >*/
i__1 = *n;
for (k = ki + 1; k <= i__1; ++k) {
/*< VR( K, IS ) = CMZERO >*/
i__2 = k + is * vr_dim1;
vr[i__2].r = 0., vr[i__2].i = 0.;
/*< 60 CONTINUE >*/
/* L60: */
}
/*< ELSE >*/
} else {
/*< >*/
if (ki > 1) {
i__1 = ki - 1;
z__1.r = scale, z__1.i = 0.;
zgemv_("N", n, &i__1, &c_b2, &vr[vr_offset], ldvr, &work[
1], &c__1, &z__1, &vr[ki * vr_dim1 + 1], &c__1, (
ftnlen)1);
}
/*< II = IZAMAX( N, VR( 1, KI ), 1 ) >*/
ii = izamax_(n, &vr[ki * vr_dim1 + 1], &c__1);
/*< REMAX = ONE / CABS1( VR( II, KI ) ) >*/
i__1 = ii + ki * vr_dim1;
remax = 1. / ((d__1 = vr[i__1].r, abs(d__1)) + (d__2 = d_imag(
&vr[ii + ki * vr_dim1]), abs(d__2)));
/*< CALL ZDSCAL( N, REMAX, VR( 1, KI ), 1 ) >*/
zdscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1);
/*< END IF >*/
}
/* Set back the original diagonal elements of T. */
/*< DO 70 K = 1, KI - 1 >*/
i__1 = ki - 1;
for (k = 1; k <= i__1; ++k) {
/*< T( K, K ) = WORK( K+N ) >*/
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;
/*< 70 CONTINUE >*/
/* L70: */
}
/*< IS = IS - 1 >*/
--is;
/*< 80 CONTINUE >*/
L80:
;
}
/*< END IF >*/
}
/*< IF( LEFTV ) THEN >*/
if (leftv) {
/* Compute left eigenvectors. */
/*< IS = 1 >*/
is = 1;
/*< DO 130 KI = 1, N >*/
i__1 = *n;
for (ki = 1; ki <= i__1; ++ki) {
/*< IF( SOMEV ) THEN >*/
if (somev) {
/*< >*/
if (! select[ki]) {
goto L130;
}
/*< END IF >*/
}
/*< SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM ) >*/
/* Computing MAX */
i__2 = ki + ki * t_dim1;
d__3 = ulp * ((d__1 = t[i__2].r, abs(d__1)) + (d__2 = d_imag(&t[
ki + ki * t_dim1]), abs(d__2)));
smin = max(d__3,smlnum);
/*< WORK( N ) = CMONE >*/
i__2 = *n;
work[i__2].r = 1., work[i__2].i = 0.;
/* Form right-hand side. */
/*< DO 90 K = KI + 1, N >*/
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
/*< WORK( K ) = -DCONJG( T( KI, K ) ) >*/
i__3 = k;
d_cnjg(&z__2, &t[ki + k * t_dim1]);
z__1.r = -z__2.r, z__1.i = -z__2.i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/*< 90 CONTINUE >*/
/* L90: */
}
/* Solve the triangular system: */
/* (T(KI+1:N,KI+1:N) - T(KI,KI))'*X = SCALE*WORK. */
/*< DO 100 K = KI + 1, N >*/
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
/*< T( K, K ) = T( K, K ) - T( KI, KI ) >*/
i__3 = k + k * t_dim1;
i__4 = k + k * t_dim1;
i__5 = ki + ki * t_dim1;
z__1.r = t[i__4].r - t[i__5].r, z__1.i = t[i__4].i - t[i__5]
.i;
t[i__3].r = z__1.r, t[i__3].i = z__1.i;
/*< >*/
i__3 = k + k * t_dim1;
if ((d__1 = t[i__3].r, abs(d__1)) + (d__2 = d_imag(&t[k + k *
t_dim1]), abs(d__2)) < smin) {
i__4 = k + k * t_dim1;
t[i__4].r = smin, t[i__4].i = 0.;
}
/*< 100 CONTINUE >*/
/* L100: */
}
/*< IF( KI.LT.N ) THEN >*/
if (ki < *n) {
/*< >*/
i__2 = *n - ki;
zlatrs_("Upper", "Conjugate transpose", "Non-unit", "Y", &
i__2, &t[ki + 1 + (ki + 1) * t_dim1], ldt, &work[ki +
1], &scale, &rwork[1], info, (ftnlen)5, (ftnlen)19, (
ftnlen)8, (ftnlen)1);
/*< WORK( KI ) = SCALE >*/
i__2 = ki;
work[i__2].r = scale, work[i__2].i = 0.;
/*< END IF >*/
}
/* Copy the vector x or Q*x to VL and normalize. */
/*< IF( .NOT.OVER ) THEN >*/
if (! over) {
/*< CALL ZCOPY( N-KI+1, WORK( KI ), 1, VL( KI, IS ), 1 ) >*/
i__2 = *n - ki + 1;
zcopy_(&i__2, &work[ki], &c__1, &vl[ki + is * vl_dim1], &c__1)
;
/*< II = IZAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1 >*/
i__2 = *n - ki + 1;
ii = izamax_(&i__2, &vl[ki + is * vl_dim1], &c__1) + ki - 1;
/*< REMAX = ONE / CABS1( VL( II, IS ) ) >*/
i__2 = ii + is * vl_dim1;
remax = 1. / ((d__1 = vl[i__2].r, abs(d__1)) + (d__2 = d_imag(
&vl[ii + is * vl_dim1]), abs(d__2)));
/*< CALL ZDSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) >*/
i__2 = *n - ki + 1;
zdscal_(&i__2, &remax, &vl[ki + is * vl_dim1], &c__1);
/*< DO 110 K = 1, KI - 1 >*/
i__2 = ki - 1;
for (k = 1; k <= i__2; ++k) {
/*< VL( K, IS ) = CMZERO >*/
i__3 = k + is * vl_dim1;
vl[i__3].r = 0., vl[i__3].i = 0.;
/*< 110 CONTINUE >*/
/* L110: */
}
/*< ELSE >*/
} else {
/*< >*/
if (ki < *n) {
i__2 = *n - ki;
z__1.r = scale, z__1.i = 0.;
zgemv_("N", n, &i__2, &c_b2, &vl[(ki + 1) * vl_dim1 + 1],
ldvl, &work[ki + 1], &c__1, &z__1, &vl[ki *
vl_dim1 + 1], &c__1, (ftnlen)1);
}
/*< II = IZAMAX( N, VL( 1, KI ), 1 ) >*/
ii = izamax_(n, &vl[ki * vl_dim1 + 1], &c__1);
/*< REMAX = ONE / CABS1( VL( II, KI ) ) >*/
i__2 = ii + ki * vl_dim1;
remax = 1. / ((d__1 = vl[i__2].r, abs(d__1)) + (d__2 = d_imag(
&vl[ii + ki * vl_dim1]), abs(d__2)));
/*< CALL ZDSCAL( N, REMAX, VL( 1, KI ), 1 ) >*/
zdscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1);
/*< END IF >*/
}
/* Set back the original diagonal elements of T. */
/*< DO 120 K = KI + 1, N >*/
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
/*< T( K, K ) = WORK( K+N ) >*/
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;
/*< 120 CONTINUE >*/
/* L120: */
}
/*< IS = IS + 1 >*/
++is;
/*< 130 CONTINUE >*/
L130:
;
}
/*< END IF >*/
}
/*< RETURN >*/
return 0;
/* End of ZTREVC */
/*< END >*/
} /* ztrevc_ */
/* Subroutine */ int ztrcon_(char *norm, char *uplo, char *diag, integer *n,
doublecomplex *a, integer *lda, doublereal *rcond, doublecomplex *
work, doublereal *rwork, integer *info, ftnlen norm_len, ftnlen
uplo_len, ftnlen diag_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1;
doublereal d__1, d__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer ix, kase, kase1;
static doublereal scale;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static doublereal anorm;
static logical upper;
static doublereal xnorm;
extern doublereal dlamch_(char *, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zlacon_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *);
static doublereal ainvnm;
extern integer izamax_(integer *, doublecomplex *, integer *);
static logical onenrm;
extern /* Subroutine */ int zdrscl_(integer *, doublereal *,
doublecomplex *, integer *);
static char normin[1];
extern doublereal zlantr_(char *, char *, char *, integer *, integer *,
doublecomplex *, integer *, doublereal *, ftnlen, ftnlen, ftnlen);
static doublereal smlnum;
static logical nounit;
extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, doublereal *, integer *, ftnlen, ftnlen, ftnlen,
ftnlen);
/* -- 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 */
/* ======= */
/* ZTRCON 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*16 array, dimension (LDA,N) */
/* The triangular matrix A. If UPLO = 'U', the leading N-by-N */
/* upper triangular part of the array A contains the upper */
/* triangular matrix, and the strictly lower triangular part of */
/* A is not referenced. If UPLO = 'L', the leading N-by-N lower */
/* triangular part of the array A contains the lower triangular */
/* matrix, and the strictly upper triangular part of A is not */
/* referenced. If DIAG = 'U', the diagonal elements of A are */
/* also not referenced and are assumed to be 1. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* RCOND (output) DOUBLE PRECISION */
/* The reciprocal of the condition number of the matrix A, */
/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. 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);
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;
} else if (*lda < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTRCON", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*rcond = 1.;
return 0;
}
*rcond = 0.;
smlnum = dlamch_("Safe minimum", (ftnlen)12) * (doublereal) max(1,*n);
/* Compute the norm of the triangular matrix A. */
anorm = zlantr_(norm, uplo, diag, n, n, &a[a_offset], lda, &rwork[1], (
ftnlen)1, (ftnlen)1, (ftnlen)1);
/* Continue only if ANORM > 0. */
if (anorm > 0.) {
/* Estimate the norm of the inverse of A. */
ainvnm = 0.;
*(unsigned char *)normin = 'N';
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kase = 0;
L10:
zlacon_(n, &work[*n + 1], &work[1], &ainvnm, &kase);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(A). */
zlatrs_(uplo, "No transpose", diag, normin, n, &a[a_offset],
lda, &work[1], &scale, &rwork[1], info, (ftnlen)1, (
ftnlen)12, (ftnlen)1, (ftnlen)1);
} else {
/* Multiply by inv(A'). */
zlatrs_(uplo, "Conjugate transpose", diag, normin, n, &a[
a_offset], lda, &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.) {
ix = izamax_(n, &work[1], &c__1);
i__1 = ix;
xnorm = (d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(&
work[ix]), abs(d__2));
if (scale < xnorm * smlnum || scale == 0.) {
goto L20;
}
zdrscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) {
*rcond = 1. / anorm / ainvnm;
}
}
L20:
return 0;
/* End of ZTRCON */
} /* ztrcon_ */
/* Subroutine */ int zlatps_(char *uplo, char *trans, char *diag, char *
normin, integer *n, doublecomplex *ap, doublecomplex *x, doublereal *
scale, doublereal *cnorm, integer *info)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
ZLATPS 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, where A is an upper or lower
triangular matrix stored in packed form. Here 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 ZTPSV 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.
AP (input) COMPLEX*16 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.
X (input/output) COMPLEX*16 array, dimension (N)
On entry, the right hand side b of the triangular system.
On exit, X is overwritten by the solution vector x.
SCALE (output) DOUBLE PRECISION
The scaling factor s for the triangular system
A * x = s*b, A**T * x = s*b, or A**H * x = s*b.
If SCALE = 0, the matrix A is singular or badly scaled, and
the vector x is an exact or approximate solution to A*x = 0.
CNORM (input or output) DOUBLE PRECISION array, dimension (N)
If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
contains the norm of the off-diagonal part of the j-th column
of A. If TRANS = 'N', CNORM(j) must be greater than or equal
to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
must be greater than or equal to the 1-norm.
If NORMIN = 'N', CNORM is an output argument and CNORM(j)
returns the 1-norm of the offdiagonal part of the j-th column
of A.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -k, the k-th argument had an illegal value
Further Details
======= =======
A rough bound on x is computed; if that is less than overflow, ZTPSV
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 ZTPSV 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 ZTPSV if 1/M(n) and 1/G(n) are both greater
than max(underflow, 1/overflow).
=====================================================================
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b36 = .5;
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static integer jinc, jlen;
static doublereal xbnd;
static integer imax;
static doublereal tmax;
static doublecomplex tjjs;
static doublereal xmax, grow;
static integer i, j;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
static doublereal tscal;
static doublecomplex uscal;
static integer jlast;
static doublecomplex csumj;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static logical upper;
extern /* Double Complex */ VOID zdotu_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *), ztpsv_(
char *, char *, char *, integer *, doublecomplex *, doublecomplex
*, integer *), dlabad_(doublereal *,
doublereal *);
extern doublereal dlamch_(char *);
static integer ip;
static doublereal xj;
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *);
static doublereal bignum;
extern integer izamax_(integer *, doublecomplex *, integer *);
extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *,
doublecomplex *);
static logical notran;
static integer jfirst;
extern doublereal dzasum_(integer *, doublecomplex *, integer *);
static doublereal smlnum;
static logical nounit;
static doublereal rec, tjj;
#define CNORM(I) cnorm[(I)-1]
#define X(I) x[(I)-1]
#define AP(I) ap[(I)-1]
*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;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZLATPS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine machine dependent parameters to control overflow. */
smlnum = dlamch_("Safe minimum");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum /= dlamch_("Precision");
bignum = 1. / smlnum;
*scale = 1.;
if (lsame_(normin, "N")) {
/* Compute the 1-norm of each column, not including the diagona
l. */
if (upper) {
/* A is upper triangular. */
ip = 1;
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = j - 1;
CNORM(j) = dzasum_(&i__2, &AP(ip), &c__1);
ip += j;
/* L10: */
}
} else {
/* A is lower triangular. */
ip = 1;
i__1 = *n - 1;
for (j = 1; j <= *n-1; ++j) {
i__2 = *n - j;
CNORM(j) = dzasum_(&i__2, &AP(ip + 1), &c__1);
ip = ip + *n - j + 1;
/* L20: */
}
CNORM(*n) = 0.;
}
}
/* Scale the column norms by TSCAL if the maximum element in CNORM is
greater than BIGNUM/2. */
imax = idamax_(n, &CNORM(1), &c__1);
tmax = CNORM(imax);
if (tmax <= bignum * .5) {
tscal = 1.;
} else {
tscal = .5 / (smlnum * tmax);
dscal_(n, &tscal, &CNORM(1), &c__1);
}
/* Compute a bound on the computed solution vector to see if the
Level 2 BLAS routine ZTPSV can be used. */
xmax = 0.;
i__1 = *n;
for (j = 1; j <= *n; ++j) {
/* Computing MAX */
i__2 = j;
d__3 = xmax, d__4 = (d__1 = X(j).r / 2., abs(d__1)) + (d__2 =
d_imag(&X(j)) / 2., abs(d__2));
xmax = max(d__3,d__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.) {
grow = 0.;
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 = .5 / max(xbnd,smlnum);
xbnd = grow;
ip = jfirst * (jfirst + 1) / 2;
jlen = *n;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) {
/* Exit the loop if the growth factor is too smal
l. */
if (grow <= smlnum) {
goto L60;
}
i__3 = ip;
tjjs.r = AP(ip).r, tjjs.i = AP(ip).i;
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
d__2));
if (tjj >= smlnum) {
/* M(j) = G(j-1) / abs(A(j,j))
Computing MIN */
d__1 = xbnd, d__2 = min(1.,tjj) * grow;
xbnd = min(d__1,d__2);
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.;
}
if (tjj + CNORM(j) >= smlnum) {
/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,
j)) ) */
grow *= tjj / (tjj + CNORM(j));
} else {
/* G(j) could overflow, set GROW to 0. */
grow = 0.;
}
ip += jinc * jlen;
--jlen;
/* L40: */
}
grow = xbnd;
} else {
/* A is unit triangular.
Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...
,n}.
Computing MIN */
d__1 = 1., d__2 = .5 / max(xbnd,smlnum);
grow = min(d__1,d__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) {
/* Exit the loop if the growth factor is too smal
l. */
if (grow <= smlnum) {
goto L60;
}
/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
grow *= 1. / (CNORM(j) + 1.);
/* 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.) {
grow = 0.;
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 = .5 / max(xbnd,smlnum);
xbnd = grow;
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) {
/* Exit the loop if the growth factor is too smal
l. */
if (grow <= smlnum) {
goto L90;
}
/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
*/
xj = CNORM(j) + 1.;
/* Computing MIN */
d__1 = grow, d__2 = xbnd / xj;
grow = min(d__1,d__2);
i__3 = ip;
tjjs.r = AP(ip).r, tjjs.i = AP(ip).i;
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
d__2));
if (tjj >= smlnum) {
/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(
j,j)) */
if (xj > tjj) {
xbnd *= tjj / xj;
}
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.;
}
++jlen;
ip += jinc * jlen;
/* L70: */
}
grow = min(grow,xbnd);
} else {
/* A is unit triangular.
Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...
,n}.
Computing MIN */
d__1 = 1., d__2 = .5 / max(xbnd,smlnum);
grow = min(d__1,d__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) {
/* Exit the loop if the growth factor is too smal
l. */
if (grow <= smlnum) {
goto L90;
}
/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
xj = CNORM(j) + 1.;
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. */
ztpsv_(uplo, trans, diag, n, &AP(1), &X(1), &c__1);
} else {
/* Use a Level 1 BLAS solve, scaling intermediate results. */
if (xmax > bignum * .5) {
/* Scale X so that its components are less than or equal
to
BIGNUM in absolute value. */
*scale = bignum * .5 / xmax;
zdscal_(n, scale, &X(1), &c__1);
xmax = bignum;
} else {
xmax *= 2.;
}
if (notran) {
/* Solve A * x = b */
ip = jfirst * (jfirst + 1) / 2;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) {
/* Compute x(j) = b(j) / A(j,j), scaling x if nec
essary. */
i__3 = j;
xj = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j)),
abs(d__2));
if (nounit) {
i__3 = ip;
z__1.r = tscal * AP(ip).r, z__1.i = tscal * AP(ip).i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
if (tscal == 1.) {
goto L110;
}
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
d__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale x by 1/b(j). */
rec = 1. / xj;
zdscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &X(j), &tjjs);
X(j).r = z__1.r, X(j).i = z__1.i;
i__3 = j;
xj = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j))
, abs(d__2));
} else if (tjj > 0.) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(
A(j,j))*BIGNUM
to avoid overflow when dividi
ng by A(j,j). */
rec = tjj * bignum / xj;
if (CNORM(j) > 1.) {
/* Scale by 1/CNORM(j) to
avoid overflow when
multiplying x(j) times
column j. */
rec /= CNORM(j);
}
zdscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &X(j), &tjjs);
X(j).r = z__1.r, X(j).i = z__1.i;
i__3 = j;
xj = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j))
, abs(d__2));
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) =
1, and
scale = 0, and compute a solution to
A*x = 0. */
i__3 = *n;
for (i = 1; i <= *n; ++i) {
i__4 = i;
X(i).r = 0., X(i).i = 0.;
/* L100: */
}
i__3 = j;
X(j).r = 1., X(j).i = 0.;
xj = 1.;
*scale = 0.;
xmax = 0.;
}
L110:
/* Scale x if necessary to avoid overflow when ad
ding a
multiple of column j of A. */
if (xj > 1.) {
rec = 1. / xj;
if (CNORM(j) > (bignum - xmax) * rec) {
/* Scale x by 1/(2*abs(x(j))). */
rec *= .5;
zdscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
}
} else if (xj * CNORM(j) > bignum - xmax) {
/* Scale x by 1/2. */
zdscal_(n, &c_b36, &X(1), &c__1);
*scale *= .5;
}
if (upper) {
if (j > 1) {
/* Compute the update
x(1:j-1) := x(1:j-1) - x(j) *
A(1:j-1,j) */
i__3 = j - 1;
i__4 = j;
z__2.r = -X(j).r, z__2.i = -X(j).i;
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
zaxpy_(&i__3, &z__1, &AP(ip - j + 1), &c__1, &X(1), &
c__1);
i__3 = j - 1;
i = izamax_(&i__3, &X(1), &c__1);
i__3 = i;
xmax = (d__1 = X(i).r, abs(d__1)) + (d__2 = d_imag(
&X(i)), abs(d__2));
}
ip -= j;
} else {
if (j < *n) {
/* Compute the update
x(j+1:n) := x(j+1:n) - x(j) *
A(j+1:n,j) */
i__3 = *n - j;
i__4 = j;
z__2.r = -X(j).r, z__2.i = -X(j).i;
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
zaxpy_(&i__3, &z__1, &AP(ip + 1), &c__1, &X(j + 1), &
c__1);
i__3 = *n - j;
i = j + izamax_(&i__3, &X(j + 1), &c__1);
i__3 = i;
xmax = (d__1 = X(i).r, abs(d__1)) + (d__2 = d_imag(
&X(i)), abs(d__2));
}
ip = ip + *n - j + 1;
}
/* L120: */
}
} else if (lsame_(trans, "T")) {
/* Solve A**T * x = b */
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k).
k<>j */
i__3 = j;
xj = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j)),
abs(d__2));
uscal.r = tscal, uscal.i = 0.;
rec = 1. / max(xmax,1.);
if (CNORM(j) > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2
*XMAX). */
rec *= .5;
if (nounit) {
i__3 = ip;
z__1.r = tscal * AP(ip).r, z__1.i = tscal * AP(ip)
.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > 1.) {
/* Divide by A(j,j) when scaling
x if A(j,j) > 1.
Computing MIN */
d__1 = 1., d__2 = rec * tjj;
rec = min(d__1,d__2);
zladiv_(&z__1, &uscal, &tjjs);
uscal.r = z__1.r, uscal.i = z__1.i;
}
if (rec < 1.) {
zdscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0., csumj.i = 0.;
if (uscal.r == 1. && uscal.i == 0.) {
/* If the scaling needed for A in the dot
product is 1,
call ZDOTU to perform the dot product.
*/
if (upper) {
i__3 = j - 1;
zdotu_(&z__1, &i__3, &AP(ip - j + 1), &c__1, &X(1), &
c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
} else if (j < *n) {
i__3 = *n - j;
zdotu_(&z__1, &i__3, &AP(ip + 1), &c__1, &X(j + 1), &
c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
}
} else {
/* Otherwise, use in-line code for the dot
product. */
if (upper) {
i__3 = j - 1;
for (i = 1; i <= j-1; ++i) {
i__4 = ip - j + i;
z__3.r = AP(ip-j+i).r * uscal.r - AP(ip-j+i).i *
uscal.i, z__3.i = AP(ip-j+i).r * uscal.i +
AP(ip-j+i).i * uscal.r;
i__5 = i;
z__2.r = z__3.r * X(i).r - z__3.i * X(i).i,
z__2.i = z__3.r * X(i).i + z__3.i * X(
i).r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
/* L130: */
}
} else if (j < *n) {
i__3 = *n - j;
for (i = 1; i <= *n-j; ++i) {
i__4 = ip + i;
z__3.r = AP(ip+i).r * uscal.r - AP(ip+i).i *
uscal.i, z__3.i = AP(ip+i).r * uscal.i +
AP(ip+i).i * uscal.r;
i__5 = j + i;
z__2.r = z__3.r * X(j+i).r - z__3.i * X(j+i).i,
z__2.i = z__3.r * X(j+i).i + z__3.i * X(
j+i).r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
/* L140: */
}
}
}
z__1.r = tscal, z__1.i = 0.;
if (uscal.r == z__1.r && uscal.i == z__1.i) {
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,
j) if 1/A(j,j)
was not used to scale the dotproduct.
*/
i__3 = j;
i__4 = j;
z__1.r = X(j).r - csumj.r, z__1.i = X(j).i -
csumj.i;
X(j).r = z__1.r, X(j).i = z__1.i;
i__3 = j;
xj = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j))
, abs(d__2));
if (nounit) {
/* Compute x(j) = x(j) / A(j,j), sc
aling if necessary. */
i__3 = ip;
z__1.r = tscal * AP(ip).r, z__1.i = tscal * AP(ip)
.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
if (tscal == 1.) {
goto L160;
}
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale X by 1/ab
s(x(j)). */
rec = 1. / xj;
zdscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &X(j), &tjjs);
X(j).r = z__1.r, X(j).i = z__1.i;
} else if (tjj > 0.) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)
))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
zdscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &X(j), &tjjs);
X(j).r = z__1.r, X(j).i = z__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0,
x(j) = 1, and
scale = 0 and compute a solut
ion to A**T *x = 0. */
i__3 = *n;
for (i = 1; i <= *n; ++i) {
i__4 = i;
X(i).r = 0., X(i).i = 0.;
/* L150: */
}
i__3 = j;
X(j).r = 1., X(j).i = 0.;
*scale = 0.;
xmax = 0.;
}
L160:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ i
f the dot
product has already been divided by 1/A
(j,j). */
i__3 = j;
zladiv_(&z__2, &X(j), &tjjs);
z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i;
X(j).r = z__1.r, X(j).i = z__1.i;
}
/* Computing MAX */
i__3 = j;
d__3 = xmax, d__4 = (d__1 = X(j).r, abs(d__1)) + (d__2 =
d_imag(&X(j)), abs(d__2));
xmax = max(d__3,d__4);
++jlen;
ip += jinc * jlen;
/* L170: */
}
} else {
/* Solve A**H * x = b */
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k).
k<>j */
i__3 = j;
xj = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j)),
abs(d__2));
uscal.r = tscal, uscal.i = 0.;
rec = 1. / max(xmax,1.);
if (CNORM(j) > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2
*XMAX). */
rec *= .5;
if (nounit) {
d_cnjg(&z__2, &AP(ip));
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > 1.) {
/* Divide by A(j,j) when scaling
x if A(j,j) > 1.
Computing MIN */
d__1 = 1., d__2 = rec * tjj;
rec = min(d__1,d__2);
zladiv_(&z__1, &uscal, &tjjs);
uscal.r = z__1.r, uscal.i = z__1.i;
}
if (rec < 1.) {
zdscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0., csumj.i = 0.;
if (uscal.r == 1. && uscal.i == 0.) {
/* If the scaling needed for A in the dot
product is 1,
call ZDOTC to perform the dot product.
*/
if (upper) {
i__3 = j - 1;
zdotc_(&z__1, &i__3, &AP(ip - j + 1), &c__1, &X(1), &
c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
} else if (j < *n) {
i__3 = *n - j;
zdotc_(&z__1, &i__3, &AP(ip + 1), &c__1, &X(j + 1), &
c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
}
} else {
/* Otherwise, use in-line code for the dot
product. */
if (upper) {
i__3 = j - 1;
for (i = 1; i <= j-1; ++i) {
d_cnjg(&z__4, &AP(ip - j + i));
z__3.r = z__4.r * uscal.r - z__4.i * uscal.i,
z__3.i = z__4.r * uscal.i + z__4.i *
uscal.r;
i__4 = i;
z__2.r = z__3.r * X(i).r - z__3.i * X(i).i,
z__2.i = z__3.r * X(i).i + z__3.i * X(
i).r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
/* L180: */
}
} else if (j < *n) {
i__3 = *n - j;
for (i = 1; i <= *n-j; ++i) {
d_cnjg(&z__4, &AP(ip + i));
z__3.r = z__4.r * uscal.r - z__4.i * uscal.i,
z__3.i = z__4.r * uscal.i + z__4.i *
uscal.r;
i__4 = j + i;
z__2.r = z__3.r * X(j+i).r - z__3.i * X(j+i).i,
z__2.i = z__3.r * X(j+i).i + z__3.i * X(
j+i).r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
/* L190: */
}
}
}
z__1.r = tscal, z__1.i = 0.;
if (uscal.r == z__1.r && uscal.i == z__1.i) {
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,
j) if 1/A(j,j)
was not used to scale the dotproduct.
*/
i__3 = j;
i__4 = j;
z__1.r = X(j).r - csumj.r, z__1.i = X(j).i -
csumj.i;
X(j).r = z__1.r, X(j).i = z__1.i;
i__3 = j;
xj = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j))
, abs(d__2));
if (nounit) {
/* Compute x(j) = x(j) / A(j,j), sc
aling if necessary. */
d_cnjg(&z__2, &AP(ip));
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
if (tscal == 1.) {
goto L210;
}
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale X by 1/ab
s(x(j)). */
rec = 1. / xj;
zdscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &X(j), &tjjs);
X(j).r = z__1.r, X(j).i = z__1.i;
} else if (tjj > 0.) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)
))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
zdscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &X(j), &tjjs);
X(j).r = z__1.r, X(j).i = z__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0,
x(j) = 1, and
scale = 0 and compute a solut
ion to A**H *x = 0. */
i__3 = *n;
for (i = 1; i <= *n; ++i) {
i__4 = i;
X(i).r = 0., X(i).i = 0.;
/* L200: */
}
i__3 = j;
X(j).r = 1., X(j).i = 0.;
*scale = 0.;
xmax = 0.;
}
L210:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ i
f the dot
product has already been divided by 1/A
(j,j). */
i__3 = j;
zladiv_(&z__2, &X(j), &tjjs);
z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i;
X(j).r = z__1.r, X(j).i = z__1.i;
}
/* Computing MAX */
i__3 = j;
d__3 = xmax, d__4 = (d__1 = X(j).r, abs(d__1)) + (d__2 =
d_imag(&X(j)), abs(d__2));
xmax = max(d__3,d__4);
++jlen;
ip += jinc * jlen;
/* L220: */
}
}
*scale /= tscal;
}
/* Scale the column norms by 1/TSCAL for return. */
if (tscal != 1.) {
d__1 = 1. / tscal;
dscal_(n, &d__1, &CNORM(1), &c__1);
}
return 0;
/* End of ZLATPS */
} /* zlatps_ */
int zgebal_(char *job, int *n, doublecomplex *a, int
*lda, int *ilo, int *ihi, double *scale, int *info)
{
/* System generated locals */
int a_dim1, a_offset, i__1, i__2, i__3;
double d__1, d__2;
/* Builtin functions */
double d_imag(doublecomplex *), z_abs(doublecomplex *);
/* Local variables */
double c__, f, g;
int i__, j, k, l, m;
double r__, s, ca, ra;
int ica, ira, iexc;
extern int lsame_(char *, char *);
extern int zswap_(int *, doublecomplex *, int *,
doublecomplex *, int *);
double sfmin1, sfmin2, sfmax1, sfmax2;
extern double dlamch_(char *);
extern int xerbla_(char *, int *), zdscal_(
int *, double *, doublecomplex *, int *);
extern int izamax_(int *, doublecomplex *, int *);
int noconv;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGEBAL balances a general complex matrix A. This involves, first, */
/* permuting A by a similarity transformation 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 matrix, and improve the */
/* accuracy of the computed eigenvalues and/or eigenvectors. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* Specifies the operations to be performed on A: */
/* = 'N': none: simply set ILO = 1, IHI = N, SCALE(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 matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 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. */
/* See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* ILO (output) INTEGER */
/* IHI (output) INTEGER */
/* ILO and IHI are set to ints such that on exit */
/* A(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. */
/* SCALE (output) DOUBLE PRECISION array, dimension (N) */
/* Details of the permutations and scaling factors applied to */
/* A. If P(j) is the index of the row and column interchanged */
/* with row and column j and D(j) is the scaling factor */
/* applied to row and column j, then */
/* SCALE(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. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* The permutations consist of row and column interchanges which put */
/* the matrix in the form */
/* ( T1 X Y ) */
/* P A P = ( 0 B Z ) */
/* ( 0 0 T2 ) */
/* where T1 and T2 are upper triangular matrices whose eigenvalues lie */
/* along the diagonal. The column indices ILO and IHI mark the starting */
/* and ending columns of the submatrix B. Balancing consists of applying */
/* a diagonal similarity transformation inv(D) * B * D to make the */
/* 1-norms of each row of B and its corresponding column nearly equal. */
/* The output matrix is */
/* ( T1 X*D Y ) */
/* ( 0 inv(D)*B*D inv(D)*Z ). */
/* ( 0 0 T2 ) */
/* Information about the permutations P and the diagonal matrix D is */
/* returned in the vector SCALE. */
/* This subroutine is based on the EISPACK routine CBAL. */
/* Modified by Tzu-Yi Chen, Computer Science Division, University of */
/* California at Berkeley, USA */
/* ===================================================================== */
/* .. 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;
--scale;
/* 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;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEBAL", &i__1);
return 0;
}
k = 1;
l = *n;
if (*n == 0) {
goto L210;
}
if (lsame_(job, "N")) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
scale[i__] = 1.;
/* L10: */
}
goto L210;
}
if (lsame_(job, "S")) {
goto L120;
}
/* Permutation to isolate eigenvalues if possible */
goto L50;
/* Row and column exchange. */
L20:
scale[m] = (double) j;
if (j == m) {
goto L30;
}
zswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
i__1 = *n - k + 1;
zswap_(&i__1, &a[j + k * a_dim1], lda, &a[m + k * a_dim1], lda);
L30:
switch (iexc) {
case 1:
goto L40;
case 2:
goto L80;
}
/* Search for rows isolating an eigenvalue and push them down. */
L40:
if (l == 1) {
goto L210;
}
--l;
L50:
for (j = l; j >= 1; --j) {
i__1 = l;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ == j) {
goto L60;
}
i__2 = j + i__ * a_dim1;
if (a[i__2].r != 0. || d_imag(&a[j + i__ * a_dim1]) != 0.) {
goto L70;
}
L60:
;
}
m = l;
iexc = 1;
goto L20;
L70:
;
}
goto L90;
/* Search for columns isolating an eigenvalue and push them left. */
L80:
++k;
L90:
i__1 = l;
for (j = k; j <= i__1; ++j) {
i__2 = l;
for (i__ = k; i__ <= i__2; ++i__) {
if (i__ == j) {
goto L100;
}
i__3 = i__ + j * a_dim1;
if (a[i__3].r != 0. || d_imag(&a[i__ + j * a_dim1]) != 0.) {
goto L110;
}
L100:
;
}
m = k;
iexc = 2;
goto L20;
L110:
;
}
L120:
i__1 = l;
for (i__ = k; i__ <= i__1; ++i__) {
scale[i__] = 1.;
/* L130: */
}
if (lsame_(job, "P")) {
goto L210;
}
/* Balance the submatrix in rows K to L. */
/* Iterative loop for norm reduction */
sfmin1 = dlamch_("S") / dlamch_("P");
sfmax1 = 1. / sfmin1;
sfmin2 = sfmin1 * 2.;
sfmax2 = 1. / sfmin2;
L140:
noconv = FALSE;
i__1 = l;
for (i__ = k; i__ <= i__1; ++i__) {
c__ = 0.;
r__ = 0.;
i__2 = l;
for (j = k; j <= i__2; ++j) {
if (j == i__) {
goto L150;
}
i__3 = j + i__ * a_dim1;
c__ += (d__1 = a[i__3].r, ABS(d__1)) + (d__2 = d_imag(&a[j + i__ *
a_dim1]), ABS(d__2));
i__3 = i__ + j * a_dim1;
r__ += (d__1 = a[i__3].r, ABS(d__1)) + (d__2 = d_imag(&a[i__ + j *
a_dim1]), ABS(d__2));
L150:
;
}
ica = izamax_(&l, &a[i__ * a_dim1 + 1], &c__1);
ca = z_abs(&a[ica + i__ * a_dim1]);
i__2 = *n - k + 1;
ira = izamax_(&i__2, &a[i__ + k * a_dim1], lda);
ra = z_abs(&a[i__ + (ira + k - 1) * a_dim1]);
/* Guard against zero C or R due to underflow. */
if (c__ == 0. || r__ == 0.) {
goto L200;
}
g = r__ / 2.;
f = 1.;
s = c__ + r__;
L160:
/* Computing MAX */
d__1 = MAX(f,c__);
/* Computing MIN */
d__2 = MIN(r__,g);
if (c__ >= g || MAX(d__1,ca) >= sfmax2 || MIN(d__2,ra) <= sfmin2) {
goto L170;
}
f *= 2.;
c__ *= 2.;
ca *= 2.;
r__ /= 2.;
g /= 2.;
ra /= 2.;
goto L160;
L170:
g = c__ / 2.;
L180:
/* Computing MIN */
d__1 = MIN(f,c__), d__1 = MIN(d__1,g);
if (g < r__ || MAX(r__,ra) >= sfmax2 || MIN(d__1,ca) <= sfmin2) {
goto L190;
}
f /= 2.;
c__ /= 2.;
g /= 2.;
ca /= 2.;
r__ *= 2.;
ra *= 2.;
goto L180;
/* Now balance. */
L190:
if (c__ + r__ >= s * .95) {
goto L200;
}
if (f < 1. && scale[i__] < 1.) {
if (f * scale[i__] <= sfmin1) {
goto L200;
}
}
if (f > 1. && scale[i__] > 1.) {
if (scale[i__] >= sfmax1 / f) {
goto L200;
}
}
g = 1. / f;
scale[i__] *= f;
noconv = TRUE;
i__2 = *n - k + 1;
zdscal_(&i__2, &g, &a[i__ + k * a_dim1], lda);
zdscal_(&l, &f, &a[i__ * a_dim1 + 1], &c__1);
L200:
;
}
if (noconv) {
goto L140;
}
L210:
*ilo = k;
*ihi = l;
return 0;
/* End of ZGEBAL */
} /* zgebal_ */
/* Subroutine */ int ztpt03_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, doublecomplex *ap, doublereal *scale, doublereal *
cnorm, doublereal *tscal, doublecomplex *x, integer *ldx,
doublecomplex *b, integer *ldb, doublecomplex *work, doublereal *
resid)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1;
doublereal d__1, d__2;
doublecomplex z__1;
/* Local variables */
integer j, jj, ix;
doublereal eps, err;
doublereal xscal, tnorm, xnorm;
doublereal smlnum;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZTPT03 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 the triangular matrix A is stored in packed format. 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. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices X and B. NRHS >= 0. */
/* AP (input) COMPLEX*16 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((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', */
/* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */
/* SCALE (input) DOUBLE PRECISION */
/* The scaling factor s used in solving the triangular system. */
/* CNORM (input) DOUBLE PRECISION array, dimension (N) */
/* The 1-norms of the columns of A, not counting the diagonal. */
/* TSCAL (input) DOUBLE PRECISION */
/* The scaling factor used in computing the 1-norms in CNORM. */
/* CNORM actually contains the column norms of TSCAL*A. */
/* X (input) COMPLEX*16 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*16 array, dimension (LDB,NRHS) */
/* The right hand side vectors for the system of linear */
/* equations. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* WORK (workspace) COMPLEX*16 array, dimension (N) */
/* RESID (output) DOUBLE PRECISION */
/* 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 */
--ap;
--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.;
return 0;
}
eps = dlamch_("Epsilon");
smlnum = dlamch_("Safe minimum");
/* Compute the norm of the triangular matrix A using the column */
/* norms already computed by ZLATPS. */
tnorm = 0.;
if (lsame_(diag, "N")) {
if (lsame_(uplo, "U")) {
jj = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
d__1 = tnorm, d__2 = *tscal * z_abs(&ap[jj]) + cnorm[j];
tnorm = max(d__1,d__2);
jj += j;
/* L10: */
}
} else {
jj = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
d__1 = tnorm, d__2 = *tscal * z_abs(&ap[jj]) + cnorm[j];
tnorm = max(d__1,d__2);
jj = jj + *n - j + 1;
/* L20: */
}
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
d__1 = tnorm, d__2 = *tscal + cnorm[j];
tnorm = max(d__1,d__2);
/* L30: */
}
}
/* Compute the maximum over the number of right hand sides of */
/* norm(op(A)*x - s*b) / ( norm(A) * norm(x) * EPS ). */
*resid = 0.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
zcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
ix = izamax_(n, &work[1], &c__1);
/* Computing MAX */
d__1 = 1., d__2 = z_abs(&x[ix + j * x_dim1]);
xnorm = max(d__1,d__2);
xscal = 1. / xnorm / (doublereal) (*n);
zdscal_(n, &xscal, &work[1], &c__1);
ztpmv_(uplo, trans, diag, n, &ap[1], &work[1], &c__1);
d__1 = -(*scale) * xscal;
z__1.r = d__1, z__1.i = 0.;
zaxpy_(n, &z__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
ix = izamax_(n, &work[1], &c__1);
err = *tscal * z_abs(&work[ix]);
ix = izamax_(n, &x[j * x_dim1 + 1], &c__1);
xnorm = z_abs(&x[ix + j * x_dim1]);
if (err * smlnum <= xnorm) {
if (xnorm > 0.) {
err /= xnorm;
}
} else {
if (err > 0.) {
err = 1. / eps;
}
}
if (err * smlnum <= tnorm) {
if (tnorm > 0.) {
err /= tnorm;
}
} else {
if (err > 0.) {
err = 1. / eps;
}
}
*resid = max(*resid,err);
/* L40: */
}
return 0;
/* End of ZTPT03 */
} /* ztpt03_ */
/*< SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) >*/
/* Subroutine */ int zgebal_(char *job, integer *n, doublecomplex *a, integer
*lda, integer *ilo, integer *ihi, doublereal *scale, integer *info,
ftnlen job_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1, d__2;
/* Builtin functions */
double d_imag(doublecomplex *), z_abs(doublecomplex *);
/* Local variables */
doublereal c__, f, g;
integer i__, j, k, l, m;
doublereal r__, s, ca, ra;
integer ica, ira, iexc;
extern logical lsame_(const char *, const char *, ftnlen, ftnlen);
extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
doublereal sfmin1, sfmin2, sfmax1, sfmax2;
extern doublereal dlamch_(char *, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zdscal_(
integer *, doublereal *, doublecomplex *, integer *);
extern integer izamax_(integer *, doublecomplex *, integer *);
logical noconv;
(void)job_len;
/* -- 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 .. */
/*< CHARACTER JOB >*/
/*< INTEGER IHI, ILO, INFO, LDA, N >*/
/* .. */
/* .. Array Arguments .. */
/*< DOUBLE PRECISION SCALE( * ) >*/
/*< COMPLEX*16 A( LDA, * ) >*/
/* .. */
/* Purpose */
/* ======= */
/* ZGEBAL balances a general complex matrix A. This involves, first, */
/* permuting A by a similarity transformation 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 matrix, and improve the */
/* accuracy of the computed eigenvalues and/or eigenvectors. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* Specifies the operations to be performed on A: */
/* = 'N': none: simply set ILO = 1, IHI = N, SCALE(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 matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 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. */
/* See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* ILO (output) INTEGER */
/* IHI (output) INTEGER */
/* ILO and IHI are set to integers such that on exit */
/* A(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. */
/* SCALE (output) DOUBLE PRECISION array, dimension (N) */
/* Details of the permutations and scaling factors applied to */
/* A. If P(j) is the index of the row and column interchanged */
/* with row and column j and D(j) is the scaling factor */
/* applied to row and column j, then */
/* SCALE(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. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* The permutations consist of row and column interchanges which put */
/* the matrix in the form */
/* ( T1 X Y ) */
/* P A P = ( 0 B Z ) */
/* ( 0 0 T2 ) */
/* where T1 and T2 are upper triangular matrices whose eigenvalues lie */
/* along the diagonal. The column indices ILO and IHI mark the starting */
/* and ending columns of the submatrix B. Balancing consists of applying */
/* a diagonal similarity transformation inv(D) * B * D to make the */
/* 1-norms of each row of B and its corresponding column nearly equal. */
/* The output matrix is */
/* ( T1 X*D Y ) */
/* ( 0 inv(D)*B*D inv(D)*Z ). */
/* ( 0 0 T2 ) */
/* Information about the permutations P and the diagonal matrix D is */
/* returned in the vector SCALE. */
/* This subroutine is based on the EISPACK routine CBAL. */
/* Modified by Tzu-Yi Chen, Computer Science Division, University of */
/* California at Berkeley, USA */
/* ===================================================================== */
/* .. Parameters .. */
/*< DOUBLE PRECISION ZERO, ONE >*/
/*< PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) >*/
/*< DOUBLE PRECISION SCLFAC >*/
/*< PARAMETER ( SCLFAC = 0.8D+1 ) >*/
/*< DOUBLE PRECISION FACTOR >*/
/*< PARAMETER ( FACTOR = 0.95D+0 ) >*/
/* .. */
/* .. Local Scalars .. */
/*< LOGICAL NOCONV >*/
/*< INTEGER I, ICA, IEXC, IRA, J, K, L, M >*/
/*< >*/
/*< COMPLEX*16 CDUM >*/
/* .. */
/* .. External Functions .. */
/*< LOGICAL LSAME >*/
/*< INTEGER IZAMAX >*/
/*< DOUBLE PRECISION DLAMCH >*/
/*< EXTERNAL LSAME, IZAMAX, DLAMCH >*/
/* .. */
/* .. External Subroutines .. */
/*< EXTERNAL XERBLA, ZDSCAL, ZSWAP >*/
/* .. */
/* .. Intrinsic Functions .. */
/*< INTRINSIC ABS, DBLE, DIMAG, MAX, MIN >*/
/* .. */
/* .. Statement Functions .. */
/*< DOUBLE PRECISION CABS1 >*/
/* .. */
/* .. Statement Function definitions .. */
/*< CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) >*/
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/*< INFO = 0 >*/
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--scale;
/* Function Body */
*info = 0;
/*< >*/
if (! lsame_(job, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(job, "P", (
ftnlen)1, (ftnlen)1) && ! lsame_(job, "S", (ftnlen)1, (ftnlen)1)
&& ! lsame_(job, "B", (ftnlen)1, (ftnlen)1)) {
/*< INFO = -1 >*/
*info = -1;
/*< ELSE IF( N.LT.0 ) THEN >*/
} else if (*n < 0) {
/*< INFO = -2 >*/
*info = -2;
/*< ELSE IF( LDA.LT.MAX( 1, N ) ) THEN >*/
} else if (*lda < max(1,*n)) {
/*< INFO = -4 >*/
*info = -4;
/*< END IF >*/
}
/*< IF( INFO.NE.0 ) THEN >*/
if (*info != 0) {
/*< CALL XERBLA( 'ZGEBAL', -INFO ) >*/
i__1 = -(*info);
xerbla_("ZGEBAL", &i__1, (ftnlen)6);
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/*< K = 1 >*/
k = 1;
/*< L = N >*/
l = *n;
/*< >*/
if (*n == 0) {
goto L210;
}
/*< IF( LSAME( JOB, 'N' ) ) THEN >*/
if (lsame_(job, "N", (ftnlen)1, (ftnlen)1)) {
/*< DO 10 I = 1, N >*/
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< SCALE( I ) = ONE >*/
scale[i__] = 1.;
/*< 10 CONTINUE >*/
/* L10: */
}
/*< GO TO 210 >*/
goto L210;
/*< END IF >*/
}
/*< >*/
if (lsame_(job, "S", (ftnlen)1, (ftnlen)1)) {
goto L120;
}
/* Permutation to isolate eigenvalues if possible */
/*< GO TO 50 >*/
goto L50;
/* Row and column exchange. */
/*< 20 CONTINUE >*/
L20:
/*< SCALE( M ) = J >*/
scale[m] = (doublereal) j;
/*< >*/
if (j == m) {
goto L30;
}
/*< CALL ZSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) >*/
zswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
/*< CALL ZSWAP( N-K+1, A( J, K ), LDA, A( M, K ), LDA ) >*/
i__1 = *n - k + 1;
zswap_(&i__1, &a[j + k * a_dim1], lda, &a[m + k * a_dim1], lda);
/*< 30 CONTINUE >*/
L30:
/*< GO TO ( 40, 80 )IEXC >*/
switch (iexc) {
case 1: goto L40;
case 2: goto L80;
}
/* Search for rows isolating an eigenvalue and push them down. */
/*< 40 CONTINUE >*/
L40:
/*< >*/
if (l == 1) {
goto L210;
}
/*< L = L - 1 >*/
--l;
/*< 50 CONTINUE >*/
L50:
/*< DO 70 J = L, 1, -1 >*/
for (j = l; j >= 1; --j) {
/*< DO 60 I = 1, L >*/
i__1 = l;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< >*/
if (i__ == j) {
goto L60;
}
/*< >*/
i__2 = j + i__ * a_dim1;
if (a[i__2].r != 0. || d_imag(&a[j + i__ * a_dim1]) != 0.) {
goto L70;
}
/*< 60 CONTINUE >*/
L60:
;
}
/*< M = L >*/
m = l;
/*< IEXC = 1 >*/
iexc = 1;
/*< GO TO 20 >*/
goto L20;
/*< 70 CONTINUE >*/
L70:
;
}
/*< GO TO 90 >*/
goto L90;
/* Search for columns isolating an eigenvalue and push them left. */
/*< 80 CONTINUE >*/
L80:
/*< K = K + 1 >*/
++k;
/*< 90 CONTINUE >*/
L90:
/*< DO 110 J = K, L >*/
i__1 = l;
for (j = k; j <= i__1; ++j) {
/*< DO 100 I = K, L >*/
i__2 = l;
for (i__ = k; i__ <= i__2; ++i__) {
/*< >*/
if (i__ == j) {
goto L100;
}
/*< >*/
i__3 = i__ + j * a_dim1;
if (a[i__3].r != 0. || d_imag(&a[i__ + j * a_dim1]) != 0.) {
goto L110;
}
/*< 100 CONTINUE >*/
L100:
;
}
/*< M = K >*/
m = k;
/*< IEXC = 2 >*/
iexc = 2;
/*< GO TO 20 >*/
goto L20;
/*< 110 CONTINUE >*/
L110:
;
}
/*< 120 CONTINUE >*/
L120:
/*< DO 130 I = K, L >*/
i__1 = l;
for (i__ = k; i__ <= i__1; ++i__) {
/*< SCALE( I ) = ONE >*/
scale[i__] = 1.;
/*< 130 CONTINUE >*/
/* L130: */
}
/*< >*/
if (lsame_(job, "P", (ftnlen)1, (ftnlen)1)) {
goto L210;
}
/* Balance the submatrix in rows K to L. */
/* Iterative loop for norm reduction */
/*< SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) >*/
sfmin1 = dlamch_("S", (ftnlen)1) / dlamch_("P", (ftnlen)1);
/*< SFMAX1 = ONE / SFMIN1 >*/
sfmax1 = 1. / sfmin1;
/*< SFMIN2 = SFMIN1*SCLFAC >*/
sfmin2 = sfmin1 * 8.;
/*< SFMAX2 = ONE / SFMIN2 >*/
sfmax2 = 1. / sfmin2;
/*< 140 CONTINUE >*/
L140:
/*< NOCONV = .FALSE. >*/
noconv = FALSE_;
/*< DO 200 I = K, L >*/
i__1 = l;
for (i__ = k; i__ <= i__1; ++i__) {
/*< C = ZERO >*/
c__ = 0.;
/*< R = ZERO >*/
r__ = 0.;
/*< DO 150 J = K, L >*/
i__2 = l;
for (j = k; j <= i__2; ++j) {
/*< >*/
if (j == i__) {
goto L150;
}
/*< C = C + CABS1( A( J, I ) ) >*/
i__3 = j + i__ * a_dim1;
c__ += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[j + i__ *
a_dim1]), abs(d__2));
/*< R = R + CABS1( A( I, J ) ) >*/
i__3 = i__ + j * a_dim1;
r__ += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + j *
a_dim1]), abs(d__2));
/*< 150 CONTINUE >*/
L150:
;
}
/*< ICA = IZAMAX( L, A( 1, I ), 1 ) >*/
ica = izamax_(&l, &a[i__ * a_dim1 + 1], &c__1);
/*< CA = ABS( A( ICA, I ) ) >*/
ca = z_abs(&a[ica + i__ * a_dim1]);
/*< IRA = IZAMAX( N-K+1, A( I, K ), LDA ) >*/
i__2 = *n - k + 1;
ira = izamax_(&i__2, &a[i__ + k * a_dim1], lda);
/*< RA = ABS( A( I, IRA+K-1 ) ) >*/
ra = z_abs(&a[i__ + (ira + k - 1) * a_dim1]);
/* Guard against zero C or R due to underflow. */
/*< >*/
if (c__ == 0. || r__ == 0.) {
goto L200;
}
/*< G = R / SCLFAC >*/
g = r__ / 8.;
/*< F = ONE >*/
f = 1.;
/*< S = C + R >*/
s = c__ + r__;
/*< 160 CONTINUE >*/
L160:
/*< >*/
/* Computing MAX */
d__1 = max(f,c__);
/* Computing MIN */
d__2 = min(r__,g);
if (c__ >= g || max(d__1,ca) >= sfmax2 || min(d__2,ra) <= sfmin2) {
goto L170;
}
/*< F = F*SCLFAC >*/
f *= 8.;
/*< C = C*SCLFAC >*/
c__ *= 8.;
/*< CA = CA*SCLFAC >*/
ca *= 8.;
/*< R = R / SCLFAC >*/
r__ /= 8.;
/*< G = G / SCLFAC >*/
g /= 8.;
/*< RA = RA / SCLFAC >*/
ra /= 8.;
/*< GO TO 160 >*/
goto L160;
/*< 170 CONTINUE >*/
L170:
/*< G = C / SCLFAC >*/
g = c__ / 8.;
/*< 180 CONTINUE >*/
L180:
/*< >*/
/* Computing MIN */
d__1 = min(f,c__), d__1 = min(d__1,g);
if (g < r__ || max(r__,ra) >= sfmax2 || min(d__1,ca) <= sfmin2) {
goto L190;
}
/*< F = F / SCLFAC >*/
f /= 8.;
/*< C = C / SCLFAC >*/
c__ /= 8.;
/*< G = G / SCLFAC >*/
g /= 8.;
/*< CA = CA / SCLFAC >*/
ca /= 8.;
/*< R = R*SCLFAC >*/
r__ *= 8.;
/*< RA = RA*SCLFAC >*/
ra *= 8.;
/*< GO TO 180 >*/
goto L180;
/* Now balance. */
/*< 190 CONTINUE >*/
L190:
/*< >*/
if (c__ + r__ >= s * .95) {
goto L200;
}
/*< IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN >*/
if (f < 1. && scale[i__] < 1.) {
/*< >*/
if (f * scale[i__] <= sfmin1) {
goto L200;
}
/*< END IF >*/
}
/*< IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN >*/
if (f > 1. && scale[i__] > 1.) {
/*< >*/
if (scale[i__] >= sfmax1 / f) {
goto L200;
}
/*< END IF >*/
}
/*< G = ONE / F >*/
g = 1. / f;
/*< SCALE( I ) = SCALE( I )*F >*/
scale[i__] *= f;
/*< NOCONV = .TRUE. >*/
noconv = TRUE_;
/*< CALL ZDSCAL( N-K+1, G, A( I, K ), LDA ) >*/
i__2 = *n - k + 1;
zdscal_(&i__2, &g, &a[i__ + k * a_dim1], lda);
/*< CALL ZDSCAL( L, F, A( 1, I ), 1 ) >*/
zdscal_(&l, &f, &a[i__ * a_dim1 + 1], &c__1);
/*< 200 CONTINUE >*/
L200:
;
}
/*< >*/
if (noconv) {
goto L140;
}
/*< 210 CONTINUE >*/
L210:
/*< ILO = K >*/
*ilo = k;
/*< IHI = L >*/
*ihi = l;
/*< RETURN >*/
return 0;
/* End of ZGEBAL */
/*< END >*/
} /* zgebal_ */
/* Subroutine */ int ztpt05_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, doublecomplex *ap, doublecomplex *b, integer *ldb,
doublecomplex *x, integer *ldx, doublecomplex *xact, integer *ldxact,
doublereal *ferr, doublereal *berr, doublereal *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;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static doublereal diff, axbi;
static integer imax;
static doublereal unfl, ovfl;
static logical unit;
static integer i__, j, k;
extern logical lsame_(char *, char *);
static logical upper;
static doublereal xnorm;
static integer jc;
extern doublereal dlamch_(char *);
static doublereal errbnd;
extern integer izamax_(integer *, doublecomplex *, integer *);
static logical notran;
static integer ifu;
static doublereal 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)]
/* -- 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
=======
ZTPT05 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*16 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*16 array, dimension (LDB,NRHS)
The right hand side vectors for the system of linear
equations.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input) COMPLEX*16 array, dimension (LDX,NRHS)
The computed solution vectors. Each vector is stored as a
column of the matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
XACT (input) COMPLEX*16 array, dimension (LDX,NRHS)
The exact solution vectors. Each vector is stored as a
column of the matrix XACT.
LDXACT (input) INTEGER
The leading dimension of the array XACT. LDXACT >= max(1,N).
FERR (input) DOUBLE PRECISION array, dimension (NRHS)
The estimated forward error bounds for each solution vector
X. If XTRUE is the true solution, FERR bounds the magnitude
of the largest entry in (X - XTRUE) divided by the magnitude
of the largest entry in X.
BERR (input) DOUBLE PRECISION array, dimension (NRHS)
The componentwise relative backward error of each solution
vector (i.e., the smallest relative change in any entry of A
or B that makes X an exact solution).
RESLTS (output) DOUBLE PRECISION array, dimension (2)
The maximum over the NRHS solution vectors of the ratios:
RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
RESLTS(2) = BERR / ( (n+1)*EPS + (*) )
=====================================================================
Quick exit if N = 0 or NRHS = 0.
Parameter adjustments */
--ap;
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.;
reslts[2] = 0.;
return 0;
}
eps = dlamch_("Epsilon");
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
unit = lsame_(diag, "U");
/* Test 1: Compute the maximum of
norm(X - XACT) / ( norm(X) * FERR )
over all the vectors X and XACT using the infinity-norm. */
errbnd = 0.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
imax = izamax_(n, &x_ref(1, j), &c__1);
/* Computing MAX */
i__2 = x_subscr(imax, j);
d__3 = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x_ref(imax, j))
, abs(d__2));
xnorm = max(d__3,unfl);
diff = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = x_subscr(i__, j);
i__4 = xact_subscr(i__, j);
z__2.r = x[i__3].r - xact[i__4].r, z__2.i = x[i__3].i - xact[i__4]
.i;
z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MAX */
d__3 = diff, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
z__1), abs(d__2));
diff = max(d__3,d__4);
/* L10: */
}
if (xnorm > 1.) {
goto L20;
} else if (diff <= ovfl * xnorm) {
goto L20;
} else {
errbnd = 1. / eps;
goto L30;
}
L20:
if (diff / xnorm <= ferr[j]) {
/* Computing MAX */
d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
errbnd = max(d__1,d__2);
} else {
errbnd = 1. / eps;
}
L30:
;
}
reslts[1] = errbnd;
/* Test 2: Compute the maximum of BERR / ( (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 = b_subscr(i__, k);
tmp = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b_ref(i__,
k)), abs(d__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 = x_subscr(j, k);
tmp += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 =
d_imag(&ap[jc + j]), abs(d__2))) * ((d__3 = x[
i__5].r, abs(d__3)) + (d__4 = d_imag(&x_ref(j,
k)), abs(d__4)));
/* L40: */
}
if (unit) {
i__3 = x_subscr(i__, k);
tmp += (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
&x_ref(i__, k)), abs(d__2));
}
} else {
jc += i__;
if (unit) {
i__3 = x_subscr(i__, k);
tmp += (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
&x_ref(i__, k)), abs(d__2));
jc += i__;
}
i__3 = *n;
for (j = i__ + ifu; j <= i__3; ++j) {
i__4 = jc;
i__5 = x_subscr(j, k);
tmp += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 =
d_imag(&ap[jc]), abs(d__2))) * ((d__3 = x[
i__5].r, abs(d__3)) + (d__4 = d_imag(&x_ref(j,
k)), abs(d__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 = x_subscr(j, k);
tmp += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 =
d_imag(&ap[jc]), abs(d__2))) * ((d__3 = x[
i__5].r, abs(d__3)) + (d__4 = d_imag(&x_ref(j,
k)), abs(d__4)));
jc = jc + *n - j;
/* L60: */
}
if (unit) {
i__3 = x_subscr(i__, k);
tmp += (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
&x_ref(i__, k)), abs(d__2));
}
} else {
jc = (i__ - 1) * (*n - i__) + i__ * (i__ + 1) / 2;
if (unit) {
i__3 = x_subscr(i__, k);
tmp += (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
&x_ref(i__, k)), abs(d__2));
}
i__3 = *n;
for (j = i__ + ifu; j <= i__3; ++j) {
i__4 = jc + j - i__;
i__5 = x_subscr(j, k);
tmp += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 =
d_imag(&ap[jc + j - i__]), abs(d__2))) * ((
d__3 = x[i__5].r, abs(d__3)) + (d__4 = d_imag(
&x_ref(j, k)), abs(d__4)));
/* L70: */
}
}
}
if (i__ == 1) {
axbi = tmp;
} else {
axbi = min(axbi,tmp);
}
/* L80: */
}
/* Computing MAX */
d__1 = axbi, d__2 = (*n + 1) * unfl;
tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / max(d__1,d__2));
if (k == 1) {
reslts[2] = tmp;
} else {
reslts[2] = max(reslts[2],tmp);
}
/* L90: */
}
return 0;
/* End of ZTPT05 */
} /* ztpt05_ */
/* Subroutine */ int zlattr_(integer *imat, char *uplo, char *trans, char *
diag, integer *iseed, integer *n, doublecomplex *a, integer *lda,
doublecomplex *b, doublecomplex *work, doublereal *rwork, integer *
info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
double pow_dd(doublereal *, doublereal *), sqrt(doublereal);
void d_cnjg(doublecomplex *, doublecomplex *);
double z_abs(doublecomplex *);
/* Local variables */
doublereal c__;
integer i__, j;
doublecomplex s;
doublereal x, y, z__;
doublecomplex ra, rb;
integer kl, ku, iy;
doublereal ulp, sfac;
integer mode;
char path[3], dist[1];
doublereal unfl, rexp;
char type__[1];
doublereal texp;
extern /* Subroutine */ int zrot_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublecomplex *);
doublecomplex star1, plus1, plus2;
doublereal bscal;
extern logical lsame_(char *, char *);
doublereal tscal, anorm, bnorm, tleft;
logical upper;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zrotg_(doublecomplex *,
doublecomplex *, doublereal *, doublecomplex *), zswap_(integer *,
doublecomplex *, integer *, doublecomplex *, integer *), zlatb4_(
char *, integer *, integer *, integer *, char *, integer *,
integer *, doublereal *, integer *, doublereal *, char *), dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *), dlarnd_(integer *, integer *);
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *);
doublereal bignum, cndnum;
extern /* Subroutine */ int dlarnv_(integer *, integer *, integer *,
doublereal *);
extern integer izamax_(integer *, doublecomplex *, integer *);
extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
integer *);
integer jcount;
extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublecomplex *, integer *,
doublecomplex *, integer *);
doublereal smlnum;
extern /* Subroutine */ int zlarnv_(integer *, integer *, integer *,
doublecomplex *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLATTR generates a triangular test matrix in 2-dimensional storage. */
/* IMAT and UPLO uniquely specify the properties of the test matrix, */
/* which is returned in the array A. */
/* Arguments */
/* ========= */
/* IMAT (input) INTEGER */
/* An integer key describing which matrix to generate for this */
/* path. */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A will be upper or lower */
/* triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Specifies whether the matrix or its transpose will be used. */
/* = 'N': No transpose */
/* = 'T': Transpose */
/* = 'C': Conjugate transpose */
/* DIAG (output) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* The seed vector for the random number generator (used in */
/* ZLATMS). Modified on exit. */
/* N (input) INTEGER */
/* The order of the matrix to be generated. */
/* A (output) COMPLEX*16 array, dimension (LDA,N) */
/* The triangular matrix A. If UPLO = 'U', the leading N x 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 x N lower */
/* triangular part of the array A contains the lower triangular */
/* matrix and the strictly upper triangular part of A is not */
/* referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (output) COMPLEX*16 array, dimension (N) */
/* The right hand side vector, if IMAT > 10. */
/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--iseed;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--b;
--work;
--rwork;
/* Function Body */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "TR", (ftnlen)2, (ftnlen)2);
unfl = dlamch_("Safe minimum");
ulp = dlamch_("Epsilon") * dlamch_("Base");
smlnum = unfl;
bignum = (1. - ulp) / smlnum;
dlabad_(&smlnum, &bignum);
if (*imat >= 7 && *imat <= 10 || *imat == 18) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
*info = 0;
/* Quick return if N.LE.0. */
if (*n <= 0) {
return 0;
}
/* Call ZLATB4 to set parameters for CLATMS. */
upper = lsame_(uplo, "U");
if (upper) {
zlatb4_(path, imat, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
dist);
} else {
i__1 = -(*imat);
zlatb4_(path, &i__1, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
dist);
}
/* IMAT <= 6: Non-unit triangular matrix */
if (*imat <= 6) {
zlatms_(n, n, dist, &iseed[1], type__, &rwork[1], &mode, &cndnum, &
anorm, &kl, &ku, "No packing", &a[a_offset], lda, &work[1],
info);
/* IMAT > 6: Unit triangular matrix */
/* The diagonal is deliberately set to something other than 1. */
/* IMAT = 7: Matrix is the identity */
} else if (*imat == 7) {
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L10: */
}
i__2 = j + j * a_dim1;
a[i__2].r = (doublereal) j, a[i__2].i = 0.;
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j + j * a_dim1;
a[i__2].r = (doublereal) j, a[i__2].i = 0.;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L30: */
}
/* L40: */
}
}
/* IMAT > 7: Non-trivial unit triangular matrix */
/* Generate a unit triangular matrix T with condition CNDNUM by */
/* forming a triangular matrix with known singular values and */
/* filling in the zero entries with Givens rotations. */
} else if (*imat <= 10) {
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L50: */
}
i__2 = j + j * a_dim1;
a[i__2].r = (doublereal) j, a[i__2].i = 0.;
/* L60: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j + j * a_dim1;
a[i__2].r = (doublereal) j, a[i__2].i = 0.;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L70: */
}
/* L80: */
}
}
/* Since the trace of a unit triangular matrix is 1, the product */
/* of its singular values must be 1. Let s = sqrt(CNDNUM), */
/* x = sqrt(s) - 1/sqrt(s), y = sqrt(2/(n-2))*x, and z = x**2. */
/* The following triangular matrix has singular values s, 1, 1, */
/* ..., 1, 1/s: */
/* 1 y y y ... y y z */
/* 1 0 0 ... 0 0 y */
/* 1 0 ... 0 0 y */
/* . ... . . . */
/* . . . . */
/* 1 0 y */
/* 1 y */
/* 1 */
/* To fill in the zeros, we first multiply by a matrix with small */
/* condition number of the form */
/* 1 0 0 0 0 ... */
/* 1 + * 0 0 ... */
/* 1 + 0 0 0 */
/* 1 + * 0 0 */
/* 1 + 0 0 */
/* ... */
/* 1 + 0 */
/* 1 0 */
/* 1 */
/* Each element marked with a '*' is formed by taking the product */
/* of the adjacent elements marked with '+'. The '*'s can be */
/* chosen freely, and the '+'s are chosen so that the inverse of */
/* T will have elements of the same magnitude as T. If the *'s in */
/* both T and inv(T) have small magnitude, T is well conditioned. */
/* The two offdiagonals of T are stored in WORK. */
/* The product of these two matrices has the form */
/* 1 y y y y y . y y z */
/* 1 + * 0 0 . 0 0 y */
/* 1 + 0 0 . 0 0 y */
/* 1 + * . . . . */
/* 1 + . . . . */
/* . . . . . */
/* . . . . */
/* 1 + y */
/* 1 y */
/* 1 */
/* Now we multiply by Givens rotations, using the fact that */
/* [ c s ] [ 1 w ] [ -c -s ] = [ 1 -w ] */
/* [ -s c ] [ 0 1 ] [ s -c ] [ 0 1 ] */
/* and */
/* [ -c -s ] [ 1 0 ] [ c s ] = [ 1 0 ] */
/* [ s -c ] [ w 1 ] [ -s c ] [ -w 1 ] */
/* where c = w / sqrt(w**2+4) and s = 2 / sqrt(w**2+4). */
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = z__2.r * .25, z__1.i = z__2.i * .25;
star1.r = z__1.r, star1.i = z__1.i;
sfac = .5;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = sfac * z__2.r, z__1.i = sfac * z__2.i;
plus1.r = z__1.r, plus1.i = z__1.i;
i__1 = *n;
for (j = 1; j <= i__1; j += 2) {
z_div(&z__1, &star1, &plus1);
plus2.r = z__1.r, plus2.i = z__1.i;
i__2 = j;
work[i__2].r = plus1.r, work[i__2].i = plus1.i;
i__2 = *n + j;
work[i__2].r = star1.r, work[i__2].i = star1.i;
if (j + 1 <= *n) {
i__2 = j + 1;
work[i__2].r = plus2.r, work[i__2].i = plus2.i;
i__2 = *n + j + 1;
work[i__2].r = 0., work[i__2].i = 0.;
z_div(&z__1, &star1, &plus2);
plus1.r = z__1.r, plus1.i = z__1.i;
rexp = dlarnd_(&c__2, &iseed[1]);
if (rexp < 0.) {
d__2 = 1. - rexp;
d__1 = -pow_dd(&sfac, &d__2);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
star1.r = z__1.r, star1.i = z__1.i;
} else {
d__2 = rexp + 1.;
d__1 = pow_dd(&sfac, &d__2);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
star1.r = z__1.r, star1.i = z__1.i;
}
}
/* L90: */
}
x = sqrt(cndnum) - 1 / sqrt(cndnum);
if (*n > 2) {
y = sqrt(2. / (*n - 2)) * x;
} else {
y = 0.;
}
z__ = x * x;
if (upper) {
if (*n > 3) {
i__1 = *n - 3;
i__2 = *lda + 1;
zcopy_(&i__1, &work[1], &c__1, &a[a_dim1 * 3 + 2], &i__2);
if (*n > 4) {
i__1 = *n - 4;
i__2 = *lda + 1;
zcopy_(&i__1, &work[*n + 1], &c__1, &a[(a_dim1 << 2) + 2],
&i__2);
}
}
i__1 = *n - 1;
for (j = 2; j <= i__1; ++j) {
i__2 = j * a_dim1 + 1;
a[i__2].r = y, a[i__2].i = 0.;
i__2 = j + *n * a_dim1;
a[i__2].r = y, a[i__2].i = 0.;
/* L100: */
}
i__1 = *n * a_dim1 + 1;
a[i__1].r = z__, a[i__1].i = 0.;
} else {
if (*n > 3) {
i__1 = *n - 3;
i__2 = *lda + 1;
zcopy_(&i__1, &work[1], &c__1, &a[(a_dim1 << 1) + 3], &i__2);
if (*n > 4) {
i__1 = *n - 4;
i__2 = *lda + 1;
zcopy_(&i__1, &work[*n + 1], &c__1, &a[(a_dim1 << 1) + 4],
&i__2);
}
}
i__1 = *n - 1;
for (j = 2; j <= i__1; ++j) {
i__2 = j + a_dim1;
a[i__2].r = y, a[i__2].i = 0.;
i__2 = *n + j * a_dim1;
a[i__2].r = y, a[i__2].i = 0.;
/* L110: */
}
i__1 = *n + a_dim1;
a[i__1].r = z__, a[i__1].i = 0.;
}
/* Fill in the zeros using Givens rotations. */
if (upper) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = j + (j + 1) * a_dim1;
ra.r = a[i__2].r, ra.i = a[i__2].i;
rb.r = 2., rb.i = 0.;
zrotg_(&ra, &rb, &c__, &s);
/* Multiply by [ c s; -conjg(s) c] on the left. */
if (*n > j + 1) {
i__2 = *n - j - 1;
zrot_(&i__2, &a[j + (j + 2) * a_dim1], lda, &a[j + 1 + (j
+ 2) * a_dim1], lda, &c__, &s);
}
/* Multiply by [-c -s; conjg(s) -c] on the right. */
if (j > 1) {
i__2 = j - 1;
d__1 = -c__;
z__1.r = -s.r, z__1.i = -s.i;
zrot_(&i__2, &a[(j + 1) * a_dim1 + 1], &c__1, &a[j *
a_dim1 + 1], &c__1, &d__1, &z__1);
}
/* Negate A(J,J+1). */
i__2 = j + (j + 1) * a_dim1;
i__3 = j + (j + 1) * a_dim1;
z__1.r = -a[i__3].r, z__1.i = -a[i__3].i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L120: */
}
} else {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = j + 1 + j * a_dim1;
ra.r = a[i__2].r, ra.i = a[i__2].i;
rb.r = 2., rb.i = 0.;
zrotg_(&ra, &rb, &c__, &s);
d_cnjg(&z__1, &s);
s.r = z__1.r, s.i = z__1.i;
/* Multiply by [ c -s; conjg(s) c] on the right. */
if (*n > j + 1) {
i__2 = *n - j - 1;
z__1.r = -s.r, z__1.i = -s.i;
zrot_(&i__2, &a[j + 2 + (j + 1) * a_dim1], &c__1, &a[j +
2 + j * a_dim1], &c__1, &c__, &z__1);
}
/* Multiply by [-c s; -conjg(s) -c] on the left. */
if (j > 1) {
i__2 = j - 1;
d__1 = -c__;
zrot_(&i__2, &a[j + a_dim1], lda, &a[j + 1 + a_dim1], lda,
&d__1, &s);
}
/* Negate A(J+1,J). */
i__2 = j + 1 + j * a_dim1;
i__3 = j + 1 + j * a_dim1;
z__1.r = -a[i__3].r, z__1.i = -a[i__3].i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L130: */
}
}
/* IMAT > 10: Pathological test cases. These triangular matrices */
/* are badly scaled or badly conditioned, so when used in solving a */
/* triangular system they may cause overflow in the solution vector. */
} else if (*imat == 11) {
/* Type 11: Generate a triangular matrix with elements between */
/* -1 and 1. Give the diagonal norm 2 to make it well-conditioned. */
/* Make the right hand side large so that it requires scaling. */
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j * a_dim1 + 1]);
i__2 = j + j * a_dim1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L140: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (j < *n) {
i__2 = *n - j;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j + 1 + j * a_dim1]);
}
i__2 = j + j * a_dim1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L150: */
}
}
/* Set the right hand side so that the largest value is BIGNUM. */
zlarnv_(&c__2, &iseed[1], n, &b[1]);
iy = izamax_(n, &b[1], &c__1);
bnorm = z_abs(&b[iy]);
bscal = bignum / max(1.,bnorm);
zdscal_(n, &bscal, &b[1], &c__1);
} else if (*imat == 12) {
/* Type 12: Make the first diagonal element in the solve small to */
/* cause immediate overflow when dividing by T(j,j). */
/* In type 12, the offdiagonal elements are small (CNORM(j) < 1). */
zlarnv_(&c__2, &iseed[1], n, &b[1]);
/* Computing MAX */
d__1 = 1., d__2 = (doublereal) (*n - 1);
tscal = 1. / max(d__1,d__2);
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j * a_dim1 + 1]);
i__2 = j - 1;
zdscal_(&i__2, &tscal, &a[j * a_dim1 + 1], &c__1);
i__2 = j + j * a_dim1;
zlarnd_(&z__1, &c__5, &iseed[1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L160: */
}
i__1 = *n + *n * a_dim1;
i__2 = *n + *n * a_dim1;
z__1.r = smlnum * a[i__2].r, z__1.i = smlnum * a[i__2].i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (j < *n) {
i__2 = *n - j;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j + 1 + j * a_dim1]);
i__2 = *n - j;
zdscal_(&i__2, &tscal, &a[j + 1 + j * a_dim1], &c__1);
}
i__2 = j + j * a_dim1;
zlarnd_(&z__1, &c__5, &iseed[1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L170: */
}
i__1 = a_dim1 + 1;
i__2 = a_dim1 + 1;
z__1.r = smlnum * a[i__2].r, z__1.i = smlnum * a[i__2].i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
}
} else if (*imat == 13) {
/* Type 13: Make the first diagonal element in the solve small to */
/* cause immediate overflow when dividing by T(j,j). */
/* In type 13, the offdiagonal elements are O(1) (CNORM(j) > 1). */
zlarnv_(&c__2, &iseed[1], n, &b[1]);
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j * a_dim1 + 1]);
i__2 = j + j * a_dim1;
zlarnd_(&z__1, &c__5, &iseed[1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L180: */
}
i__1 = *n + *n * a_dim1;
i__2 = *n + *n * a_dim1;
z__1.r = smlnum * a[i__2].r, z__1.i = smlnum * a[i__2].i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (j < *n) {
i__2 = *n - j;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j + 1 + j * a_dim1]);
}
i__2 = j + j * a_dim1;
zlarnd_(&z__1, &c__5, &iseed[1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L190: */
}
i__1 = a_dim1 + 1;
i__2 = a_dim1 + 1;
z__1.r = smlnum * a[i__2].r, z__1.i = smlnum * a[i__2].i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
}
} else if (*imat == 14) {
/* Type 14: T is diagonal with small numbers on the diagonal to */
/* make the growth factor underflow, but a small right hand side */
/* chosen so that the solution does not overflow. */
if (upper) {
jcount = 1;
for (j = *n; j >= 1; --j) {
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + j * a_dim1;
a[i__2].r = 0., a[i__2].i = 0.;
/* L200: */
}
if (jcount <= 2) {
i__1 = j + j * a_dim1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
} else {
i__1 = j + j * a_dim1;
zlarnd_(&z__1, &c__5, &iseed[1]);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
}
++jcount;
if (jcount > 4) {
jcount = 1;
}
/* L210: */
}
} else {
jcount = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L220: */
}
if (jcount <= 2) {
i__2 = j + j * a_dim1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
} else {
i__2 = j + j * a_dim1;
zlarnd_(&z__1, &c__5, &iseed[1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
++jcount;
if (jcount > 4) {
jcount = 1;
}
/* L230: */
}
}
/* Set the right hand side alternately zero and small. */
if (upper) {
b[1].r = 0., b[1].i = 0.;
for (i__ = *n; i__ >= 2; i__ += -2) {
i__1 = i__;
b[i__1].r = 0., b[i__1].i = 0.;
i__1 = i__ - 1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
b[i__1].r = z__1.r, b[i__1].i = z__1.i;
/* L240: */
}
} else {
i__1 = *n;
b[i__1].r = 0., b[i__1].i = 0.;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; i__ += 2) {
i__2 = i__;
b[i__2].r = 0., b[i__2].i = 0.;
i__2 = i__ + 1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
/* L250: */
}
}
} else if (*imat == 15) {
/* Type 15: Make the diagonal elements small to cause gradual */
/* overflow when dividing by T(j,j). To control the amount of */
/* scaling needed, the matrix is bidiagonal. */
/* Computing MAX */
d__1 = 1., d__2 = (doublereal) (*n - 1);
texp = 1. / max(d__1,d__2);
tscal = pow_dd(&smlnum, &texp);
zlarnv_(&c__4, &iseed[1], n, &b[1]);
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 2;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L260: */
}
if (j > 1) {
i__2 = j - 1 + j * a_dim1;
a[i__2].r = -1., a[i__2].i = -1.;
}
i__2 = j + j * a_dim1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L270: */
}
i__1 = *n;
b[i__1].r = 1., b[i__1].i = 1.;
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 2; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L280: */
}
if (j < *n) {
i__2 = j + 1 + j * a_dim1;
a[i__2].r = -1., a[i__2].i = -1.;
}
i__2 = j + j * a_dim1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L290: */
}
b[1].r = 1., b[1].i = 1.;
}
} else if (*imat == 16) {
/* Type 16: One zero diagonal element. */
iy = *n / 2 + 1;
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j * a_dim1 + 1]);
if (j != iy) {
i__2 = j + j * a_dim1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
} else {
i__2 = j + j * a_dim1;
a[i__2].r = 0., a[i__2].i = 0.;
}
/* L300: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (j < *n) {
i__2 = *n - j;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j + 1 + j * a_dim1]);
}
if (j != iy) {
i__2 = j + j * a_dim1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
} else {
i__2 = j + j * a_dim1;
a[i__2].r = 0., a[i__2].i = 0.;
}
/* L310: */
}
}
zlarnv_(&c__2, &iseed[1], n, &b[1]);
zdscal_(n, &c_b92, &b[1], &c__1);
} else if (*imat == 17) {
/* Type 17: Make the offdiagonal elements large to cause overflow */
/* when adding a column of T. In the non-transposed case, the */
/* matrix is constructed to cause overflow when adding a column in */
/* every other step. */
tscal = unfl / ulp;
tscal = (1. - ulp) / tscal;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L320: */
}
/* L330: */
}
texp = 1.;
if (upper) {
for (j = *n; j >= 2; j += -2) {
i__1 = j * a_dim1 + 1;
d__1 = -tscal / (doublereal) (*n + 1);
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = j + j * a_dim1;
a[i__1].r = 1., a[i__1].i = 0.;
i__1 = j;
d__1 = texp * (1. - ulp);
b[i__1].r = d__1, b[i__1].i = 0.;
i__1 = (j - 1) * a_dim1 + 1;
d__1 = -(tscal / (doublereal) (*n + 1)) / (doublereal) (*n +
2);
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = j - 1 + (j - 1) * a_dim1;
a[i__1].r = 1., a[i__1].i = 0.;
i__1 = j - 1;
d__1 = texp * (doublereal) (*n * *n + *n - 1);
b[i__1].r = d__1, b[i__1].i = 0.;
texp *= 2.;
/* L340: */
}
d__1 = (doublereal) (*n + 1) / (doublereal) (*n + 2) * tscal;
b[1].r = d__1, b[1].i = 0.;
} else {
i__1 = *n - 1;
for (j = 1; j <= i__1; j += 2) {
i__2 = *n + j * a_dim1;
d__1 = -tscal / (doublereal) (*n + 1);
a[i__2].r = d__1, a[i__2].i = 0.;
i__2 = j + j * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
i__2 = j;
d__1 = texp * (1. - ulp);
b[i__2].r = d__1, b[i__2].i = 0.;
i__2 = *n + (j + 1) * a_dim1;
d__1 = -(tscal / (doublereal) (*n + 1)) / (doublereal) (*n +
2);
a[i__2].r = d__1, a[i__2].i = 0.;
i__2 = j + 1 + (j + 1) * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
i__2 = j + 1;
d__1 = texp * (doublereal) (*n * *n + *n - 1);
b[i__2].r = d__1, b[i__2].i = 0.;
texp *= 2.;
/* L350: */
}
i__1 = *n;
d__1 = (doublereal) (*n + 1) / (doublereal) (*n + 2) * tscal;
b[i__1].r = d__1, b[i__1].i = 0.;
}
} else if (*imat == 18) {
/* Type 18: Generate a unit triangular matrix with elements */
/* between -1 and 1, and make the right hand side large so that it */
/* requires scaling. */
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j * a_dim1 + 1]);
i__2 = j + j * a_dim1;
a[i__2].r = 0., a[i__2].i = 0.;
/* L360: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (j < *n) {
i__2 = *n - j;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j + 1 + j * a_dim1]);
}
i__2 = j + j * a_dim1;
a[i__2].r = 0., a[i__2].i = 0.;
/* L370: */
}
}
/* Set the right hand side so that the largest value is BIGNUM. */
zlarnv_(&c__2, &iseed[1], n, &b[1]);
iy = izamax_(n, &b[1], &c__1);
bnorm = z_abs(&b[iy]);
bscal = bignum / max(1.,bnorm);
zdscal_(n, &bscal, &b[1], &c__1);
} else if (*imat == 19) {
/* Type 19: Generate a triangular matrix with elements between */
/* BIGNUM/(n-1) and BIGNUM so that at least one of the column */
/* norms will exceed BIGNUM. */
/* 1/3/91: ZLATRS no longer can handle this case */
/* Computing MAX */
d__1 = 1., d__2 = (doublereal) (*n - 1);
tleft = bignum / max(d__1,d__2);
/* Computing MAX */
d__1 = 1., d__2 = (doublereal) (*n);
tscal = bignum * ((doublereal) (*n - 1) / max(d__1,d__2));
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
zlarnv_(&c__5, &iseed[1], &j, &a[j * a_dim1 + 1]);
dlarnv_(&c__1, &iseed[1], &j, &rwork[1]);
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
d__1 = tleft + rwork[i__] * tscal;
z__1.r = d__1 * a[i__4].r, z__1.i = d__1 * a[i__4].i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L380: */
}
/* L390: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j + 1;
zlarnv_(&c__5, &iseed[1], &i__2, &a[j + j * a_dim1]);
i__2 = *n - j + 1;
dlarnv_(&c__1, &iseed[1], &i__2, &rwork[1]);
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
d__1 = tleft + rwork[i__ - j + 1] * tscal;
z__1.r = d__1 * a[i__4].r, z__1.i = d__1 * a[i__4].i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L400: */
}
/* L410: */
}
}
zlarnv_(&c__2, &iseed[1], n, &b[1]);
zdscal_(n, &c_b92, &b[1], &c__1);
}
/* Flip the matrix if the transpose will be used. */
if (! lsame_(trans, "N")) {
if (upper) {
i__1 = *n / 2;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - (j << 1) + 1;
zswap_(&i__2, &a[j + j * a_dim1], lda, &a[j + 1 + (*n - j + 1)
* a_dim1], &c_n1);
/* L420: */
}
} else {
i__1 = *n / 2;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - (j << 1) + 1;
i__3 = -(*lda);
zswap_(&i__2, &a[j + j * a_dim1], &c__1, &a[*n - j + 1 + (j +
1) * a_dim1], &i__3);
/* L430: */
}
}
}
return 0;
/* End of ZLATTR */
} /* zlattr_ */
/* Subroutine */
int ztrsna_(char *job, char *howmny, logical *select, integer *n, doublecomplex *t, integer *ldt, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr, doublereal *s, doublereal *sep, integer *mm, integer *m, doublecomplex *work, integer *ldwork, doublereal *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;
doublereal d__1, d__2;
doublecomplex z__1;
/* Builtin functions */
double z_abs(doublecomplex *), d_imag(doublecomplex *);
/* Local variables */
integer i__, j, k, ks, ix;
doublereal eps, est;
integer kase, ierr;
doublecomplex prod;
doublereal lnrm, rnrm, scale;
extern logical lsame_(char *, char *);
integer isave[3];
extern /* Double Complex */
VOID zdotc_f2c_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *);
doublecomplex dummy[1];
logical wants;
doublereal xnorm;
extern /* Subroutine */
int zlacn2_(integer *, doublecomplex *, doublecomplex *, doublereal *, integer *, integer *), dlabad_( doublereal *, doublereal *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_( char *);
extern /* Subroutine */
int xerbla_(char *, integer *);
doublereal bignum;
logical wantbh;
extern integer izamax_(integer *, doublecomplex *, integer *);
logical somcon;
extern /* Subroutine */
int zdrscl_(integer *, doublereal *, doublecomplex *, integer *);
char normin[1];
extern /* Subroutine */
int zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *);
doublereal smlnum;
logical wantsp;
extern /* Subroutine */
int zlatrs_(char *, char *, char *, char *, integer *, doublecomplex *, integer *, doublecomplex *, doublereal *, doublereal *, integer *), ztrexc_(char *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, integer *, integer *);
/* -- 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 .. */
/* 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_("ZTRSNA", &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.;
}
if (wantsp)
{
sep[1] = z_abs(&t[t_dim1 + 1]);
}
return 0;
}
/* Get machine constants */
eps = dlamch_("P");
smlnum = dlamch_("S") / eps;
bignum = 1. / smlnum;
dlabad_(&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. */
zdotc_f2c_(&z__1, n, &vr[ks * vr_dim1 + 1], &c__1, &vl[ks * vl_dim1 + 1], &c__1);
prod.r = z__1.r;
prod.i = z__1.i; // , expr subst
rnrm = dznrm2_(n, &vr[ks * vr_dim1 + 1], &c__1);
lnrm = dznrm2_(n, &vl[ks * vl_dim1 + 1], &c__1);
s[ks] = z_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. */
zlacpy_("Full", n, n, &t[t_offset], ldt, &work[work_offset], ldwork);
ztrexc_("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;
z__1.r = work[i__4].r - work[i__5].r;
z__1.i = work[i__4].i - work[i__5].i; // , expr subst
work[i__3].r = z__1.r;
work[i__3].i = z__1.i; // , expr subst
/* L20: */
}
/* Estimate a lower bound for the 1-norm of inv(C**H). The 1st */
/* and (N+1)th columns of WORK are used to store work vectors. */
sep[ks] = 0.;
est = 0.;
kase = 0;
*(unsigned char *)normin = 'N';
L30:
i__2 = *n - 1;
zlacn2_(&i__2, &work[(*n + 1) * work_dim1 + 1], &work[work_offset] , &est, &kase, isave);
if (kase != 0)
{
if (kase == 1)
{
/* Solve C**H*x = scale*b */
i__2 = *n - 1;
zlatrs_("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;
zlatrs_("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.)
{
/* Multiply by 1/SCALE if doing so will not cause */
/* overflow. */
i__2 = *n - 1;
ix = izamax_(&i__2, &work[work_offset], &c__1);
i__2 = ix + work_dim1;
xnorm = (d__1 = work[i__2].r, f2c_abs(d__1)) + (d__2 = d_imag( &work[ix + work_dim1]), f2c_abs(d__2));
if (scale < xnorm * smlnum || scale == 0.)
{
goto L40;
}
zdrscl_(n, &scale, &work[work_offset], &c__1);
}
goto L30;
}
sep[ks] = 1. / max(est,smlnum);
}
L40:
++ks;
L50:
;
}
return 0;
/* End of ZTRSNA */
}
/* Subroutine */ int zgbt05_(char *trans, integer *n, integer *kl, integer *
ku, integer *nrhs, doublecomplex *ab, integer *ldab, doublecomplex *b,
integer *ldb, doublecomplex *x, integer *ldx, doublecomplex *xact,
integer *ldxact, doublereal *ferr, doublereal *berr, doublereal *
reslts)
{
/* System generated locals */
integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
xact_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
integer i__, j, k, nz;
doublereal eps, tmp, diff, axbi;
integer imax;
doublereal unfl, ovfl;
extern logical lsame_(char *, char *);
doublereal xnorm;
extern doublereal dlamch_(char *);
doublereal errbnd;
extern integer izamax_(integer *, doublecomplex *, integer *);
logical notran;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGBT05 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*16 array, dimension (LDAB,N) */
/* The original band matrix A, stored in rows 1 to KL+KU+1. */
/* The j-th column of A is stored in the j-th column of the */
/* array AB as follows: */
/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
/* The right hand side vectors for the system of linear */
/* equations. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
/* The computed solution vectors. Each vector is stored as a */
/* column of the matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* XACT (input) COMPLEX*16 array, dimension (LDX,NRHS) */
/* The exact solution vectors. Each vector is stored as a */
/* column of the matrix XACT. */
/* LDXACT (input) INTEGER */
/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
/* FERR (input) DOUBLE PRECISION array, dimension (NRHS) */
/* The estimated forward error bounds for each solution vector */
/* X. If XTRUE is the true solution, FERR bounds the magnitude */
/* of the largest entry in (X - XTRUE) divided by the magnitude */
/* of the largest entry in X. */
/* BERR (input) DOUBLE PRECISION array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector (i.e., the smallest relative change in any entry of A */
/* or B that makes X an exact solution). */
/* RESLTS (output) DOUBLE PRECISION array, dimension (2) */
/* The maximum over the NRHS solution vectors of the ratios: */
/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
/* RESLTS(2) = BERR / ( NZ*EPS + (*) ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 or NRHS = 0. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
xact_dim1 = *ldxact;
xact_offset = 1 + xact_dim1;
xact -= xact_offset;
--ferr;
--berr;
--reslts;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
reslts[1] = 0.;
reslts[2] = 0.;
return 0;
}
eps = dlamch_("Epsilon");
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
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.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
imax = izamax_(n, &x[j * x_dim1 + 1], &c__1);
/* Computing MAX */
i__2 = imax + j * x_dim1;
d__3 = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x[imax + j *
x_dim1]), abs(d__2));
xnorm = max(d__3,unfl);
diff = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * x_dim1;
i__4 = i__ + j * xact_dim1;
z__2.r = x[i__3].r - xact[i__4].r, z__2.i = x[i__3].i - xact[i__4]
.i;
z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MAX */
d__3 = diff, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
z__1), abs(d__2));
diff = max(d__3,d__4);
/* L10: */
}
if (xnorm > 1.) {
goto L20;
} else if (diff <= ovfl * xnorm) {
goto L20;
} else {
errbnd = 1. / eps;
goto L30;
}
L20:
if (diff / xnorm <= ferr[j]) {
/* Computing MAX */
d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
errbnd = max(d__1,d__2);
} else {
errbnd = 1. / eps;
}
L30:
;
}
reslts[1] = errbnd;
/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where */
/* (*) = NZ*UNFL / (min_i (abs(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 = i__ + k * b_dim1;
tmp = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[i__ + k *
b_dim1]), abs(d__2));
if (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 = *ku + 1 + i__ - j + j * ab_dim1;
i__5 = j + k * x_dim1;
tmp += ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 = d_imag(&
ab[*ku + 1 + i__ - j + j * ab_dim1]), abs(d__2)))
* ((d__3 = x[i__5].r, abs(d__3)) + (d__4 = d_imag(
&x[j + k * x_dim1]), abs(d__4)));
/* 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 = *ku + 1 + j - i__ + i__ * ab_dim1;
i__5 = j + k * x_dim1;
tmp += ((d__1 = ab[i__4].r, abs(d__1)) + (d__2 = d_imag(&
ab[*ku + 1 + j - i__ + i__ * ab_dim1]), abs(d__2))
) * ((d__3 = x[i__5].r, abs(d__3)) + (d__4 =
d_imag(&x[j + k * x_dim1]), abs(d__4)));
/* L50: */
}
}
if (i__ == 1) {
axbi = tmp;
} else {
axbi = min(axbi,tmp);
}
/* L60: */
}
/* Computing MAX */
d__1 = axbi, d__2 = nz * unfl;
tmp = berr[k] / (nz * eps + nz * unfl / max(d__1,d__2));
if (k == 1) {
reslts[2] = tmp;
} else {
reslts[2] = max(reslts[2],tmp);
}
/* L70: */
}
return 0;
/* End of ZGBT05 */
} /* zgbt05_ */
/* Subroutine */
int zsytf2_rook_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *ipiv, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
/* Builtin functions */
double sqrt(doublereal), d_imag(doublecomplex *);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j, k, p;
doublecomplex t, d11, d12, d21, d22;
integer ii, kk, kp;
doublecomplex wk, wkm1, wkp1;
logical done;
integer imax, jmax;
extern /* Subroutine */
int zsyr_(char *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *);
doublereal alpha;
extern logical lsame_(char *, char *);
doublereal dtemp, sfmin;
extern /* Subroutine */
int zscal_(integer *, doublecomplex *, doublecomplex *, integer *);
integer itemp, kstep;
logical upper;
extern /* Subroutine */
int zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dlamch_(char *);
doublereal absakk;
extern /* Subroutine */
int xerbla_(char *, integer *);
doublereal colmax;
extern integer izamax_(integer *, doublecomplex *, integer *);
doublereal 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 .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*lda < max(1,*n))
{
*info = -4;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZSYTF2_ROOK", &i__1);
return 0;
}
/* Initialize ALPHA for use in choosing pivot block size. */
alpha = (sqrt(17.) + 1.) / 8.;
/* Compute machine safe minimum */
sfmin = dlamch_("S");
if (upper)
{
/* Factorize A as U*D*U**T 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;
L10: /* If K < 1, exit from loop */
if (k < 1)
{
goto L70;
}
kstep = 1;
p = k;
/* 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 * a_dim1;
absakk = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[k + k * a_dim1]), abs(d__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 = izamax_(&i__1, &a[k * a_dim1 + 1], &c__1);
i__1 = imax + k * a_dim1;
colmax = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[imax + k * a_dim1]), abs(d__2));
}
else
{
colmax = 0.;
}
if (max(absakk,colmax) == 0.)
{
/* Column K is zero or underflow: set INFO and continue */
if (*info == 0)
{
*info = k;
}
kp = k;
}
else
{
/* Test for interchange */
/* Equivalent to testing for (used to handle NaN and Inf) */
/* ABSAKK.GE.ALPHA*COLMAX */
if (! (absakk < alpha * colmax))
{
/* no interchange, */
/* use 1-by-1 pivot block */
kp = k;
}
else
{
done = FALSE_;
/* Loop until pivot found */
L12: /* Begin pivot search loop body */
/* JMAX is the column-index of the largest off-diagonal */
/* element in row IMAX, and ROWMAX is its absolute value. */
/* Determine both ROWMAX and JMAX. */
if (imax != k)
{
i__1 = k - imax;
jmax = imax + izamax_(&i__1, &a[imax + (imax + 1) * a_dim1], lda);
i__1 = imax + jmax * a_dim1;
rowmax = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(& a[imax + jmax * a_dim1]), abs(d__2));
}
else
{
rowmax = 0.;
}
if (imax > 1)
{
i__1 = imax - 1;
itemp = izamax_(&i__1, &a[imax * a_dim1 + 1], &c__1);
i__1 = itemp + imax * a_dim1;
dtemp = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[ itemp + imax * a_dim1]), abs(d__2));
if (dtemp > rowmax)
{
rowmax = dtemp;
jmax = itemp;
}
}
/* Equivalent to testing for (used to handle NaN and Inf) */
/* CABS1( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX */
i__1 = imax + imax * a_dim1;
if (! ((d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[imax + imax * a_dim1]), abs(d__2)) < alpha * rowmax))
{
/* interchange rows and columns K and IMAX, */
/* use 1-by-1 pivot block */
kp = imax;
done = TRUE_;
/* Equivalent to testing for ROWMAX .EQ. COLMAX, */
/* used to handle NaN and Inf */
}
else if (p == jmax || rowmax <= colmax)
{
/* interchange rows and columns K+1 and IMAX, */
/* use 2-by-2 pivot block */
kp = imax;
kstep = 2;
done = TRUE_;
}
else
{
/* Pivot NOT found, set variables and repeat */
p = imax;
colmax = rowmax;
imax = jmax;
}
/* End pivot search loop body */
if (! done)
{
goto L12;
}
}
/* Swap TWO rows and TWO columns */
/* First swap */
if (kstep == 2 && p != k)
{
/* Interchange rows and column K and P in the leading */
/* submatrix A(1:k,1:k) if we have a 2-by-2 pivot */
if (p > 1)
{
i__1 = p - 1;
zswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[p * a_dim1 + 1], &c__1);
}
if (p < k - 1)
{
i__1 = k - p - 1;
zswap_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + (p + 1) * a_dim1], lda);
}
i__1 = k + k * a_dim1;
t.r = a[i__1].r;
t.i = a[i__1].i; // , expr subst
i__1 = k + k * a_dim1;
i__2 = p + p * a_dim1;
a[i__1].r = a[i__2].r;
a[i__1].i = a[i__2].i; // , expr subst
i__1 = p + p * a_dim1;
a[i__1].r = t.r;
a[i__1].i = t.i; // , expr subst
}
/* Second swap */
kk = k - kstep + 1;
if (kp != kk)
{
/* Interchange rows and columns KK and KP in the leading */
/* submatrix A(1:k,1:k) */
if (kp > 1)
{
i__1 = kp - 1;
zswap_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], &c__1);
}
if (kk > 1 && kp < kk - 1)
{
i__1 = kk - kp - 1;
zswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + ( kp + 1) * a_dim1], lda);
}
i__1 = kk + kk * a_dim1;
t.r = a[i__1].r;
t.i = a[i__1].i; // , expr subst
i__1 = kk + kk * a_dim1;
i__2 = kp + kp * a_dim1;
a[i__1].r = a[i__2].r;
a[i__1].i = a[i__2].i; // , expr subst
i__1 = kp + kp * a_dim1;
a[i__1].r = t.r;
a[i__1].i = t.i; // , expr subst
if (kstep == 2)
{
i__1 = k - 1 + k * a_dim1;
t.r = a[i__1].r;
t.i = a[i__1].i; // , expr subst
i__1 = k - 1 + k * a_dim1;
i__2 = kp + k * a_dim1;
a[i__1].r = a[i__2].r;
a[i__1].i = a[i__2].i; // , expr subst
i__1 = kp + k * a_dim1;
a[i__1].r = t.r;
a[i__1].i = t.i; // , expr subst
}
}
/* 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 */
if (k > 1)
{
/* Perform a rank-1 update of A(1:k-1,1:k-1) and */
/* store U(k) in column k */
i__1 = k + k * a_dim1;
if ((d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[k + k * a_dim1]), abs(d__2)) >= sfmin)
{
/* Perform a rank-1 update of A(1:k-1,1:k-1) as */
/* A := A - U(k)*D(k)*U(k)**T */
/* = A - W(k)*1/D(k)*W(k)**T */
z_div(&z__1, &c_b1, &a[k + k * a_dim1]);
d11.r = z__1.r;
d11.i = z__1.i; // , expr subst
i__1 = k - 1;
z__1.r = -d11.r;
z__1.i = -d11.i; // , expr subst
zsyr_(uplo, &i__1, &z__1, &a[k * a_dim1 + 1], &c__1, & a[a_offset], lda);
/* Store U(k) in column k */
i__1 = k - 1;
zscal_(&i__1, &d11, &a[k * a_dim1 + 1], &c__1);
}
else
{
/* Store L(k) in column K */
i__1 = k + k * a_dim1;
d11.r = a[i__1].r;
d11.i = a[i__1].i; // , expr subst
i__1 = k - 1;
for (ii = 1;
ii <= i__1;
++ii)
{
i__2 = ii + k * a_dim1;
z_div(&z__1, &a[ii + k * a_dim1], &d11);
a[i__2].r = z__1.r;
a[i__2].i = z__1.i; // , expr subst
/* L16: */
}
/* Perform a rank-1 update of A(k+1:n,k+1:n) as */
/* A := A - U(k)*D(k)*U(k)**T */
/* = A - W(k)*(1/D(k))*W(k)**T */
/* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T */
i__1 = k - 1;
z__1.r = -d11.r;
z__1.i = -d11.i; // , expr subst
zsyr_(uplo, &i__1, &z__1, &a[k * a_dim1 + 1], &c__1, & a[a_offset], lda);
}
}
}
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) )**T */
/* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T */
/* and store L(k) and L(k+1) in columns k and k+1 */
if (k > 2)
{
i__1 = k - 1 + k * a_dim1;
d12.r = a[i__1].r;
d12.i = a[i__1].i; // , expr subst
z_div(&z__1, &a[k - 1 + (k - 1) * a_dim1], &d12);
d22.r = z__1.r;
d22.i = z__1.i; // , expr subst
z_div(&z__1, &a[k + k * a_dim1], &d12);
d11.r = z__1.r;
d11.i = z__1.i; // , expr subst
z__3.r = d11.r * d22.r - d11.i * d22.i;
z__3.i = d11.r * d22.i + d11.i * d22.r; // , expr subst
z__2.r = z__3.r - 1.;
z__2.i = z__3.i - 0.; // , expr subst
z_div(&z__1, &c_b1, &z__2);
t.r = z__1.r;
t.i = z__1.i; // , expr subst
for (j = k - 2;
j >= 1;
--j)
{
i__1 = j + (k - 1) * a_dim1;
z__3.r = d11.r * a[i__1].r - d11.i * a[i__1].i;
z__3.i = d11.r * a[i__1].i + d11.i * a[i__1] .r; // , expr subst
i__2 = j + k * a_dim1;
z__2.r = z__3.r - a[i__2].r;
z__2.i = z__3.i - a[i__2] .i; // , expr subst
z__1.r = t.r * z__2.r - t.i * z__2.i;
z__1.i = t.r * z__2.i + t.i * z__2.r; // , expr subst
wkm1.r = z__1.r;
wkm1.i = z__1.i; // , expr subst
i__1 = j + k * a_dim1;
z__3.r = d22.r * a[i__1].r - d22.i * a[i__1].i;
z__3.i = d22.r * a[i__1].i + d22.i * a[i__1] .r; // , expr subst
i__2 = j + (k - 1) * a_dim1;
z__2.r = z__3.r - a[i__2].r;
z__2.i = z__3.i - a[i__2] .i; // , expr subst
z__1.r = t.r * z__2.r - t.i * z__2.i;
z__1.i = t.r * z__2.i + t.i * z__2.r; // , expr subst
wk.r = z__1.r;
wk.i = z__1.i; // , expr subst
for (i__ = j;
i__ >= 1;
--i__)
{
i__1 = i__ + j * a_dim1;
i__2 = i__ + j * a_dim1;
z_div(&z__4, &a[i__ + k * a_dim1], &d12);
z__3.r = z__4.r * wk.r - z__4.i * wk.i;
z__3.i = z__4.r * wk.i + z__4.i * wk.r; // , expr subst
z__2.r = a[i__2].r - z__3.r;
z__2.i = a[i__2].i - z__3.i; // , expr subst
z_div(&z__6, &a[i__ + (k - 1) * a_dim1], &d12);
z__5.r = z__6.r * wkm1.r - z__6.i * wkm1.i;
z__5.i = z__6.r * wkm1.i + z__6.i * wkm1.r; // , expr subst
z__1.r = z__2.r - z__5.r;
z__1.i = z__2.i - z__5.i; // , expr subst
a[i__1].r = z__1.r;
a[i__1].i = z__1.i; // , expr subst
/* L20: */
}
/* Store U(k) and U(k-1) in cols k and k-1 for row J */
i__1 = j + k * a_dim1;
z_div(&z__1, &wk, &d12);
a[i__1].r = z__1.r;
a[i__1].i = z__1.i; // , expr subst
i__1 = j + (k - 1) * a_dim1;
z_div(&z__1, &wkm1, &d12);
a[i__1].r = z__1.r;
a[i__1].i = z__1.i; // , expr subst
/* L30: */
}
}
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1)
{
ipiv[k] = kp;
}
else
{
ipiv[k] = -p;
ipiv[k - 1] = -kp;
}
/* Decrease K and return to the start of the main loop */
k -= kstep;
goto L10;
}
else
{
/* Factorize A as L*D*L**T 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;
L40: /* If K > N, exit from loop */
if (k > *n)
{
goto L70;
}
kstep = 1;
p = k;
/* 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 * a_dim1;
absakk = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[k + k * a_dim1]), abs(d__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 + izamax_(&i__1, &a[k + 1 + k * a_dim1], &c__1);
i__1 = imax + k * a_dim1;
colmax = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[imax + k * a_dim1]), abs(d__2));
}
else
{
colmax = 0.;
}
if (max(absakk,colmax) == 0.)
{
/* Column K is zero or underflow: set INFO and continue */
if (*info == 0)
{
*info = k;
}
kp = k;
}
else
{
/* Test for interchange */
/* Equivalent to testing for (used to handle NaN and Inf) */
/* ABSAKK.GE.ALPHA*COLMAX */
if (! (absakk < alpha * colmax))
{
/* no interchange, use 1-by-1 pivot block */
kp = k;
}
else
{
done = FALSE_;
/* Loop until pivot found */
L42: /* Begin pivot search loop body */
/* JMAX is the column-index of the largest off-diagonal */
/* element in row IMAX, and ROWMAX is its absolute value. */
/* Determine both ROWMAX and JMAX. */
if (imax != k)
{
i__1 = imax - k;
jmax = k - 1 + izamax_(&i__1, &a[imax + k * a_dim1], lda);
i__1 = imax + jmax * a_dim1;
rowmax = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(& a[imax + jmax * a_dim1]), abs(d__2));
}
else
{
rowmax = 0.;
}
if (imax < *n)
{
i__1 = *n - imax;
itemp = imax + izamax_(&i__1, &a[imax + 1 + imax * a_dim1] , &c__1);
i__1 = itemp + imax * a_dim1;
dtemp = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[ itemp + imax * a_dim1]), abs(d__2));
if (dtemp > rowmax)
{
rowmax = dtemp;
jmax = itemp;
}
}
/* Equivalent to testing for (used to handle NaN and Inf) */
/* CABS1( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX */
i__1 = imax + imax * a_dim1;
if (! ((d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[imax + imax * a_dim1]), abs(d__2)) < alpha * rowmax))
{
/* interchange rows and columns K and IMAX, */
/* use 1-by-1 pivot block */
kp = imax;
done = TRUE_;
/* Equivalent to testing for ROWMAX .EQ. COLMAX, */
/* used to handle NaN and Inf */
}
else if (p == jmax || rowmax <= colmax)
{
/* interchange rows and columns K+1 and IMAX, */
/* use 2-by-2 pivot block */
kp = imax;
kstep = 2;
done = TRUE_;
}
else
{
/* Pivot NOT found, set variables and repeat */
p = imax;
colmax = rowmax;
imax = jmax;
}
/* End pivot search loop body */
if (! done)
{
goto L42;
}
}
/* Swap TWO rows and TWO columns */
/* First swap */
if (kstep == 2 && p != k)
{
/* Interchange rows and column K and P in the trailing */
/* submatrix A(k:n,k:n) if we have a 2-by-2 pivot */
if (p < *n)
{
i__1 = *n - p;
zswap_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + 1 + p * a_dim1], &c__1);
}
if (p > k + 1)
{
i__1 = p - k - 1;
zswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[p + (k + 1) * a_dim1], lda);
}
i__1 = k + k * a_dim1;
t.r = a[i__1].r;
t.i = a[i__1].i; // , expr subst
i__1 = k + k * a_dim1;
i__2 = p + p * a_dim1;
a[i__1].r = a[i__2].r;
a[i__1].i = a[i__2].i; // , expr subst
i__1 = p + p * a_dim1;
a[i__1].r = t.r;
a[i__1].i = t.i; // , expr subst
}
/* Second swap */
kk = k + kstep - 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;
zswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 + kp * a_dim1], &c__1);
}
if (kk < *n && kp > kk + 1)
{
i__1 = kp - kk - 1;
zswap_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + ( kk + 1) * a_dim1], lda);
}
i__1 = kk + kk * a_dim1;
t.r = a[i__1].r;
t.i = a[i__1].i; // , expr subst
i__1 = kk + kk * a_dim1;
i__2 = kp + kp * a_dim1;
a[i__1].r = a[i__2].r;
a[i__1].i = a[i__2].i; // , expr subst
i__1 = kp + kp * a_dim1;
a[i__1].r = t.r;
a[i__1].i = t.i; // , expr subst
if (kstep == 2)
{
i__1 = k + 1 + k * a_dim1;
t.r = a[i__1].r;
t.i = a[i__1].i; // , expr subst
i__1 = k + 1 + k * a_dim1;
i__2 = kp + k * a_dim1;
a[i__1].r = a[i__2].r;
a[i__1].i = a[i__2].i; // , expr subst
i__1 = kp + k * a_dim1;
a[i__1].r = t.r;
a[i__1].i = t.i; // , expr subst
}
}
/* 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) and */
/* store L(k) in column k */
i__1 = k + k * a_dim1;
if ((d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[k + k * a_dim1]), abs(d__2)) >= sfmin)
{
/* Perform a rank-1 update of A(k+1:n,k+1:n) as */
/* A := A - L(k)*D(k)*L(k)**T */
/* = A - W(k)*(1/D(k))*W(k)**T */
z_div(&z__1, &c_b1, &a[k + k * a_dim1]);
d11.r = z__1.r;
d11.i = z__1.i; // , expr subst
i__1 = *n - k;
z__1.r = -d11.r;
z__1.i = -d11.i; // , expr subst
zsyr_(uplo, &i__1, &z__1, &a[k + 1 + k * a_dim1], & c__1, &a[k + 1 + (k + 1) * a_dim1], lda);
/* Store L(k) in column k */
i__1 = *n - k;
zscal_(&i__1, &d11, &a[k + 1 + k * a_dim1], &c__1);
}
else
{
/* Store L(k) in column k */
i__1 = k + k * a_dim1;
d11.r = a[i__1].r;
d11.i = a[i__1].i; // , expr subst
i__1 = *n;
for (ii = k + 1;
ii <= i__1;
++ii)
{
i__2 = ii + k * a_dim1;
z_div(&z__1, &a[ii + k * a_dim1], &d11);
a[i__2].r = z__1.r;
a[i__2].i = z__1.i; // , expr subst
/* L46: */
}
/* Perform a rank-1 update of A(k+1:n,k+1:n) as */
/* A := A - L(k)*D(k)*L(k)**T */
/* = A - W(k)*(1/D(k))*W(k)**T */
/* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T */
i__1 = *n - k;
z__1.r = -d11.r;
z__1.i = -d11.i; // , expr subst
zsyr_(uplo, &i__1, &z__1, &a[k + 1 + k * a_dim1], & c__1, &a[k + 1 + (k + 1) * a_dim1], lda);
}
}
}
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 */
/* 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) )**T */
/* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T */
/* and store L(k) and L(k+1) in columns k and k+1 */
if (k < *n - 1)
{
i__1 = k + 1 + k * a_dim1;
d21.r = a[i__1].r;
d21.i = a[i__1].i; // , expr subst
z_div(&z__1, &a[k + 1 + (k + 1) * a_dim1], &d21);
d11.r = z__1.r;
d11.i = z__1.i; // , expr subst
z_div(&z__1, &a[k + k * a_dim1], &d21);
d22.r = z__1.r;
d22.i = z__1.i; // , expr subst
z__3.r = d11.r * d22.r - d11.i * d22.i;
z__3.i = d11.r * d22.i + d11.i * d22.r; // , expr subst
z__2.r = z__3.r - 1.;
z__2.i = z__3.i - 0.; // , expr subst
z_div(&z__1, &c_b1, &z__2);
t.r = z__1.r;
t.i = z__1.i; // , expr subst
i__1 = *n;
for (j = k + 2;
j <= i__1;
++j)
{
/* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J */
i__2 = j + k * a_dim1;
z__3.r = d11.r * a[i__2].r - d11.i * a[i__2].i;
z__3.i = d11.r * a[i__2].i + d11.i * a[i__2] .r; // , expr subst
i__3 = j + (k + 1) * a_dim1;
z__2.r = z__3.r - a[i__3].r;
z__2.i = z__3.i - a[i__3] .i; // , expr subst
z__1.r = t.r * z__2.r - t.i * z__2.i;
z__1.i = t.r * z__2.i + t.i * z__2.r; // , expr subst
wk.r = z__1.r;
wk.i = z__1.i; // , expr subst
i__2 = j + (k + 1) * a_dim1;
z__3.r = d22.r * a[i__2].r - d22.i * a[i__2].i;
z__3.i = d22.r * a[i__2].i + d22.i * a[i__2] .r; // , expr subst
i__3 = j + k * a_dim1;
z__2.r = z__3.r - a[i__3].r;
z__2.i = z__3.i - a[i__3] .i; // , expr subst
z__1.r = t.r * z__2.r - t.i * z__2.i;
z__1.i = t.r * z__2.i + t.i * z__2.r; // , expr subst
wkp1.r = z__1.r;
wkp1.i = z__1.i; // , expr subst
/* Perform a rank-2 update of A(k+2:n,k+2:n) */
i__2 = *n;
for (i__ = j;
i__ <= i__2;
++i__)
{
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
z_div(&z__4, &a[i__ + k * a_dim1], &d21);
z__3.r = z__4.r * wk.r - z__4.i * wk.i;
z__3.i = z__4.r * wk.i + z__4.i * wk.r; // , expr subst
z__2.r = a[i__4].r - z__3.r;
z__2.i = a[i__4].i - z__3.i; // , expr subst
z_div(&z__6, &a[i__ + (k + 1) * a_dim1], &d21);
z__5.r = z__6.r * wkp1.r - z__6.i * wkp1.i;
z__5.i = z__6.r * wkp1.i + z__6.i * wkp1.r; // , expr subst
z__1.r = z__2.r - z__5.r;
z__1.i = z__2.i - z__5.i; // , expr subst
a[i__3].r = z__1.r;
a[i__3].i = z__1.i; // , expr subst
/* L50: */
}
/* Store L(k) and L(k+1) in cols k and k+1 for row J */
i__2 = j + k * a_dim1;
z_div(&z__1, &wk, &d21);
a[i__2].r = z__1.r;
a[i__2].i = z__1.i; // , expr subst
i__2 = j + (k + 1) * a_dim1;
z_div(&z__1, &wkp1, &d21);
a[i__2].r = z__1.r;
a[i__2].i = z__1.i; // , expr subst
/* L60: */
}
}
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1)
{
ipiv[k] = kp;
}
else
{
ipiv[k] = -p;
ipiv[k + 1] = -kp;
}
/* Increase K and return to the start of the main loop */
k += kstep;
goto L40;
}
L70:
return 0;
/* End of ZSYTF2_ROOK */
}
int ztbcon_(char *norm, char *uplo, char *diag, int *n,
int *kd, doublecomplex *ab, int *ldab, double *rcond,
doublecomplex *work, double *rwork, int *info)
{
/* System generated locals */
int ab_dim1, ab_offset, i__1;
double d__1, d__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
int ix, kase, kase1;
double scale;
extern int lsame_(char *, char *);
int isave[3];
double anorm;
int upper;
double xnorm;
extern int zlacn2_(int *, doublecomplex *,
doublecomplex *, double *, int *, int *);
extern double dlamch_(char *);
extern int xerbla_(char *, int *);
double ainvnm;
extern int izamax_(int *, doublecomplex *, int *);
extern double zlantb_(char *, char *, char *, int *, int *,
doublecomplex *, int *, double *);
int onenrm;
extern int zlatbs_(char *, char *, char *, char *,
int *, int *, doublecomplex *, int *, doublecomplex *,
double *, double *, int *), zdrscl_(int *, double *, doublecomplex *,
int *);
char normin[1];
double smlnum;
int nounit;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZTBCON estimates the reciprocal of the condition number of a */
/* triangular band matrix A, in either the 1-norm or the infinity-norm. */
/* The norm of A is computed and an estimate is obtained for */
/* norm(inv(A)), then the reciprocal of the condition number is */
/* computed as */
/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies whether the 1-norm condition number or the */
/* infinity-norm condition number is required: */
/* = '1' or 'O': 1-norm; */
/* = 'I': Infinity-norm. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': A is upper triangular; */
/* = 'L': A is lower triangular. */
/* DIAG (input) CHARACTER*1 */
/* = 'N': A is non-unit triangular; */
/* = 'U': A is unit triangular. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* KD (input) INTEGER */
/* The number of superdiagonals or subdiagonals of the */
/* triangular band matrix A. KD >= 0. */
/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
/* The upper or lower triangular band matrix A, stored in the */
/* first kd+1 rows of the array. The j-th column of A is stored */
/* in the j-th column of the array AB as follows: */
/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for MAX(1,j-kd)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=MIN(n,j+kd). */
/* If DIAG = 'U', the diagonal elements of A are not referenced */
/* and are assumed to be 1. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KD+1. */
/* RCOND (output) DOUBLE PRECISION */
/* The reciprocal of the condition number of the matrix A, */
/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. 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_("ZTBCON", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*rcond = 1.;
return 0;
}
*rcond = 0.;
smlnum = dlamch_("Safe minimum") * (double) MAX(*n,1);
/* Compute the 1-norm of the triangular matrix A or A'. */
anorm = zlantb_(norm, uplo, diag, n, kd, &ab[ab_offset], ldab, &rwork[1]);
/* Continue only if ANORM > 0. */
if (anorm > 0.) {
/* Estimate the 1-norm of the inverse of A. */
ainvnm = 0.;
*(unsigned char *)normin = 'N';
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kase = 0;
L10:
zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(A). */
zlatbs_(uplo, "No transpose", diag, normin, n, kd, &ab[
ab_offset], ldab, &work[1], &scale, &rwork[1], info);
} else {
/* Multiply by inv(A'). */
zlatbs_(uplo, "Conjugate transpose", diag, normin, n, kd, &ab[
ab_offset], ldab, &work[1], &scale, &rwork[1], info);
}
*(unsigned char *)normin = 'Y';
/* Multiply by 1/SCALE if doing so will not cause overflow. */
if (scale != 1.) {
ix = izamax_(n, &work[1], &c__1);
i__1 = ix;
xnorm = (d__1 = work[i__1].r, ABS(d__1)) + (d__2 = d_imag(&
work[ix]), ABS(d__2));
if (scale < xnorm * smlnum || scale == 0.) {
goto L20;
}
zdrscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) {
*rcond = 1. / anorm / ainvnm;
}
}
L20:
return 0;
/* End of ZTBCON */
} /* ztbcon_ */
/* Subroutine */ int zgbcon_(char *norm, integer *n, integer *kl, integer *ku,
doublecomplex *ab, integer *ldab, integer *ipiv, doublereal *anorm,
doublereal *rcond, doublecomplex *work, doublereal *rwork, integer *
info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
integer j;
doublecomplex t;
integer kd, lm, jp, ix, kase, kase1;
doublereal scale;
extern logical lsame_(char *, char *);
integer isave[3];
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
logical lnoti;
extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *), zlacn2_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *, integer *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal ainvnm;
extern integer izamax_(integer *, doublecomplex *, integer *);
logical onenrm;
extern /* Subroutine */ int zlatbs_(char *, char *, char *, char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, doublereal *, integer *), zdrscl_(integer *, doublereal *, doublecomplex *,
integer *);
char normin[1];
doublereal smlnum;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGBCON 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 ZGBTRF. */
/* 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*16 array, dimension (LDAB,N) */
/* Details of the LU factorization of the band matrix A, as */
/* computed by ZGBTRF. U is stored as an upper triangular band */
/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
/* the multipliers used during the factorization are stored in */
/* rows KL+KU+2 to 2*KL+KU+1. */
/* 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) DOUBLE PRECISION */
/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */
/* If NORM = 'I', the infinity-norm of the original matrix A. */
/* RCOND (output) DOUBLE PRECISION */
/* The reciprocal of the condition number of the matrix A, */
/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (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;
--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.) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGBCON", &i__1);
return 0;
}
/* Quick return if possible */
*rcond = 0.;
if (*n == 0) {
*rcond = 1.;
return 0;
} else if (*anorm == 0.) {
return 0;
}
smlnum = dlamch_("Safe minimum");
/* Estimate the norm of inv(A). */
ainvnm = 0.;
*(unsigned char *)normin = 'N';
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kd = *kl + *ku + 1;
lnoti = *kl > 0;
kase = 0;
L10:
zlacn2_(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;
}
z__1.r = -t.r, z__1.i = -t.i;
zaxpy_(&lm, &z__1, &ab[kd + 1 + j * ab_dim1], &c__1, &
work[j + 1], &c__1);
/* L20: */
}
}
/* Multiply by inv(U). */
i__1 = *kl + *ku;
zlatbs_("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;
zlatbs_("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;
zdotc_(&z__2, &lm, &ab[kd + 1 + j * ab_dim1], &c__1, &
work[j + 1], &c__1);
z__1.r = work[i__2].r - z__2.r, z__1.i = work[i__2].i -
z__2.i;
work[i__1].r = z__1.r, work[i__1].i = z__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;
}
/* L30: */
}
}
}
/* Divide X by 1/SCALE if doing so will not cause overflow. */
*(unsigned char *)normin = 'Y';
if (scale != 1.) {
ix = izamax_(n, &work[1], &c__1);
i__1 = ix;
if (scale < ((d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(&
work[ix]), abs(d__2))) * smlnum || scale == 0.) {
goto L40;
}
zdrscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) {
*rcond = 1. / ainvnm / *anorm;
}
L40:
return 0;
/* End of ZGBCON */
} /* zgbcon_ */
/* Subroutine */ int zhetf2_(char *uplo, integer *n, doublecomplex *a,
integer *lda, integer *ipiv, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
/* Builtin functions */
double sqrt(doublereal), d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
doublereal d__;
integer i__, j, k;
doublecomplex t;
doublereal r1, d11;
doublecomplex d12;
doublereal d22;
doublecomplex d21;
integer kk, kp;
doublecomplex wk;
doublereal tt;
doublecomplex wkm1, wkp1;
integer imax, jmax;
extern /* Subroutine */ int zher_(char *, integer *, doublereal *,
doublecomplex *, integer *, doublecomplex *, integer *);
doublereal alpha;
extern logical lsame_(char *, char *);
integer kstep;
logical upper;
extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern doublereal dlapy2_(doublereal *, doublereal *);
doublereal absakk;
extern logical disnan_(doublereal *);
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *);
doublereal colmax;
extern integer izamax_(integer *, doublecomplex *, integer *);
doublereal rowmax;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZHETF2 computes the factorization of a complex Hermitian matrix A */
/* using the Bunch-Kaufman diagonal pivoting method: */
/* A = U*D*U' or A = L*D*L' */
/* where U (or L) is a product of permutation and unit upper (lower) */
/* triangular matrices, U' is the conjugate transpose of U, and D is */
/* Hermitian and block diagonal with 1-by-1 and 2-by-2 diagonal blocks. */
/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the Hermitian matrix A. If UPLO = 'U', the leading */
/* n-by-n upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading n-by-n lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* On exit, the block diagonal matrix D and the multipliers used */
/* to obtain the factor U or L (see below for further details). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* 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 = -k, the k-th argument had an illegal value */
/* > 0: if INFO = k, D(k,k) 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 */
/* =============== */
/* 09-29-06 - patch from */
/* Bobby Cheng, MathWorks */
/* Replace l.210 and l.393 */
/* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN */
/* by */
/* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN */
/* 01-01-96 - Based on modifications by */
/* J. Lewis, Boeing Computer Services Company */
/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
/* 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 */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHETF2", &i__1);
return 0;
}
/* Initialize ALPHA for use in choosing pivot block size. */
alpha = (sqrt(17.) + 1.) / 8.;
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;
L10:
/* If K < 1, exit from loop */
if (k < 1) {
goto L90;
}
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 * a_dim1;
absakk = (d__1 = a[i__1].r, abs(d__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 = izamax_(&i__1, &a[k * a_dim1 + 1], &c__1);
i__1 = imax + k * a_dim1;
colmax = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[imax +
k * a_dim1]), abs(d__2));
} else {
colmax = 0.;
}
if (max(absakk,colmax) == 0. || disnan_(&absakk)) {
/* Column K is zero or contains a NaN: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
} 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 */
i__1 = k - imax;
jmax = imax + izamax_(&i__1, &a[imax + (imax + 1) * a_dim1],
lda);
i__1 = imax + jmax * a_dim1;
rowmax = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[
imax + jmax * a_dim1]), abs(d__2));
if (imax > 1) {
i__1 = imax - 1;
jmax = izamax_(&i__1, &a[imax * a_dim1 + 1], &c__1);
/* Computing MAX */
i__1 = jmax + imax * a_dim1;
d__3 = rowmax, d__4 = (d__1 = a[i__1].r, abs(d__1)) + (
d__2 = d_imag(&a[jmax + imax * a_dim1]), abs(d__2)
);
rowmax = max(d__3,d__4);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else /* if(complicated condition) */ {
i__1 = imax + imax * a_dim1;
if ((d__1 = a[i__1].r, abs(d__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 (kp != kk) {
/* Interchange rows and columns KK and KP in the leading */
/* submatrix A(1:k,1:k) */
i__1 = kp - 1;
zswap_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1],
&c__1);
i__1 = kk - 1;
for (j = kp + 1; j <= i__1; ++j) {
d_cnjg(&z__1, &a[j + kk * a_dim1]);
t.r = z__1.r, t.i = z__1.i;
i__2 = j + kk * a_dim1;
d_cnjg(&z__1, &a[kp + j * a_dim1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = kp + j * a_dim1;
a[i__2].r = t.r, a[i__2].i = t.i;
/* L20: */
}
i__1 = kp + kk * a_dim1;
d_cnjg(&z__1, &a[kp + kk * a_dim1]);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = kk + kk * a_dim1;
r1 = a[i__1].r;
i__1 = kk + kk * a_dim1;
i__2 = kp + kp * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = kp + kp * a_dim1;
a[i__1].r = r1, a[i__1].i = 0.;
if (kstep == 2) {
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = k - 1 + k * a_dim1;
t.r = a[i__1].r, t.i = a[i__1].i;
i__1 = k - 1 + k * a_dim1;
i__2 = kp + k * a_dim1;
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = kp + k * a_dim1;
a[i__1].r = t.r, a[i__1].i = t.i;
}
} else {
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
if (kstep == 2) {
i__1 = k - 1 + (k - 1) * a_dim1;
i__2 = k - 1 + (k - 1) * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
}
}
/* 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 = k + k * a_dim1;
r1 = 1. / a[i__1].r;
i__1 = k - 1;
d__1 = -r1;
zher_(uplo, &i__1, &d__1, &a[k * a_dim1 + 1], &c__1, &a[
a_offset], lda);
/* Store U(k) in column k */
i__1 = k - 1;
zdscal_(&i__1, &r1, &a[k * a_dim1 + 1], &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 * a_dim1;
d__1 = a[i__1].r;
d__2 = d_imag(&a[k - 1 + k * a_dim1]);
d__ = dlapy2_(&d__1, &d__2);
i__1 = k - 1 + (k - 1) * a_dim1;
d22 = a[i__1].r / d__;
i__1 = k + k * a_dim1;
d11 = a[i__1].r / d__;
tt = 1. / (d11 * d22 - 1.);
i__1 = k - 1 + k * a_dim1;
z__1.r = a[i__1].r / d__, z__1.i = a[i__1].i / d__;
d12.r = z__1.r, d12.i = z__1.i;
d__ = tt / d__;
for (j = k - 2; j >= 1; --j) {
i__1 = j + (k - 1) * a_dim1;
z__3.r = d11 * a[i__1].r, z__3.i = d11 * a[i__1].i;
d_cnjg(&z__5, &d12);
i__2 = j + k * a_dim1;
z__4.r = z__5.r * a[i__2].r - z__5.i * a[i__2].i,
z__4.i = z__5.r * a[i__2].i + z__5.i * a[i__2]
.r;
z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i;
wkm1.r = z__1.r, wkm1.i = z__1.i;
i__1 = j + k * a_dim1;
z__3.r = d22 * a[i__1].r, z__3.i = d22 * a[i__1].i;
i__2 = j + (k - 1) * a_dim1;
z__4.r = d12.r * a[i__2].r - d12.i * a[i__2].i,
z__4.i = d12.r * a[i__2].i + d12.i * a[i__2]
.r;
z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i;
wk.r = z__1.r, wk.i = z__1.i;
for (i__ = j; i__ >= 1; --i__) {
i__1 = i__ + j * a_dim1;
i__2 = i__ + j * a_dim1;
i__3 = i__ + k * a_dim1;
d_cnjg(&z__4, &wk);
z__3.r = a[i__3].r * z__4.r - a[i__3].i * z__4.i,
z__3.i = a[i__3].r * z__4.i + a[i__3].i *
z__4.r;
z__2.r = a[i__2].r - z__3.r, z__2.i = a[i__2].i -
z__3.i;
i__4 = i__ + (k - 1) * a_dim1;
d_cnjg(&z__6, &wkm1);
z__5.r = a[i__4].r * z__6.r - a[i__4].i * z__6.i,
z__5.i = a[i__4].r * z__6.i + a[i__4].i *
z__6.r;
z__1.r = z__2.r - z__5.r, z__1.i = z__2.i -
z__5.i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
/* L30: */
}
i__1 = j + k * a_dim1;
a[i__1].r = wk.r, a[i__1].i = wk.i;
i__1 = j + (k - 1) * a_dim1;
a[i__1].r = wkm1.r, a[i__1].i = wkm1.i;
i__1 = j + j * a_dim1;
i__2 = j + j * a_dim1;
d__1 = a[i__2].r;
z__1.r = d__1, z__1.i = 0.;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
/* L40: */
}
}
}
}
/* 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;
} 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;
L50:
/* If K > N, exit from loop */
if (k > *n) {
goto L90;
}
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 * a_dim1;
absakk = (d__1 = a[i__1].r, abs(d__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 + izamax_(&i__1, &a[k + 1 + k * a_dim1], &c__1);
i__1 = imax + k * a_dim1;
colmax = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[imax +
k * a_dim1]), abs(d__2));
} else {
colmax = 0.;
}
if (max(absakk,colmax) == 0. || disnan_(&absakk)) {
/* Column K is zero or contains a NaN: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
} 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 */
i__1 = imax - k;
jmax = k - 1 + izamax_(&i__1, &a[imax + k * a_dim1], lda);
i__1 = imax + jmax * a_dim1;
rowmax = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[
imax + jmax * a_dim1]), abs(d__2));
if (imax < *n) {
i__1 = *n - imax;
jmax = imax + izamax_(&i__1, &a[imax + 1 + imax * a_dim1],
&c__1);
/* Computing MAX */
i__1 = jmax + imax * a_dim1;
d__3 = rowmax, d__4 = (d__1 = a[i__1].r, abs(d__1)) + (
d__2 = d_imag(&a[jmax + imax * a_dim1]), abs(d__2)
);
rowmax = max(d__3,d__4);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else /* if(complicated condition) */ {
i__1 = imax + imax * a_dim1;
if ((d__1 = a[i__1].r, abs(d__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 (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;
zswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1
+ kp * a_dim1], &c__1);
}
i__1 = kp - 1;
for (j = kk + 1; j <= i__1; ++j) {
d_cnjg(&z__1, &a[j + kk * a_dim1]);
t.r = z__1.r, t.i = z__1.i;
i__2 = j + kk * a_dim1;
d_cnjg(&z__1, &a[kp + j * a_dim1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = kp + j * a_dim1;
a[i__2].r = t.r, a[i__2].i = t.i;
/* L60: */
}
i__1 = kp + kk * a_dim1;
d_cnjg(&z__1, &a[kp + kk * a_dim1]);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = kk + kk * a_dim1;
r1 = a[i__1].r;
i__1 = kk + kk * a_dim1;
i__2 = kp + kp * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = kp + kp * a_dim1;
a[i__1].r = r1, a[i__1].i = 0.;
if (kstep == 2) {
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = k + 1 + k * a_dim1;
t.r = a[i__1].r, t.i = a[i__1].i;
i__1 = k + 1 + k * a_dim1;
i__2 = kp + k * a_dim1;
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = kp + k * a_dim1;
a[i__1].r = t.r, a[i__1].i = t.i;
}
} else {
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
if (kstep == 2) {
i__1 = k + 1 + (k + 1) * a_dim1;
i__2 = k + 1 + (k + 1) * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
}
}
/* 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 = k + k * a_dim1;
r1 = 1. / a[i__1].r;
i__1 = *n - k;
d__1 = -r1;
zher_(uplo, &i__1, &d__1, &a[k + 1 + k * a_dim1], &c__1, &
a[k + 1 + (k + 1) * a_dim1], lda);
/* Store L(k) in column K */
i__1 = *n - k;
zdscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1);
}
} else {
/* 2-by-2 pivot block D(k) */
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 * a_dim1;
d__1 = a[i__1].r;
d__2 = d_imag(&a[k + 1 + k * a_dim1]);
d__ = dlapy2_(&d__1, &d__2);
i__1 = k + 1 + (k + 1) * a_dim1;
d11 = a[i__1].r / d__;
i__1 = k + k * a_dim1;
d22 = a[i__1].r / d__;
tt = 1. / (d11 * d22 - 1.);
i__1 = k + 1 + k * a_dim1;
z__1.r = a[i__1].r / d__, z__1.i = a[i__1].i / d__;
d21.r = z__1.r, d21.i = z__1.i;
d__ = tt / d__;
i__1 = *n;
for (j = k + 2; j <= i__1; ++j) {
i__2 = j + k * a_dim1;
z__3.r = d11 * a[i__2].r, z__3.i = d11 * a[i__2].i;
i__3 = j + (k + 1) * a_dim1;
z__4.r = d21.r * a[i__3].r - d21.i * a[i__3].i,
z__4.i = d21.r * a[i__3].i + d21.i * a[i__3]
.r;
z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i;
wk.r = z__1.r, wk.i = z__1.i;
i__2 = j + (k + 1) * a_dim1;
z__3.r = d22 * a[i__2].r, z__3.i = d22 * a[i__2].i;
d_cnjg(&z__5, &d21);
i__3 = j + k * a_dim1;
z__4.r = z__5.r * a[i__3].r - z__5.i * a[i__3].i,
z__4.i = z__5.r * a[i__3].i + z__5.i * a[i__3]
.r;
z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i;
wkp1.r = z__1.r, wkp1.i = z__1.i;
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
i__5 = i__ + k * a_dim1;
d_cnjg(&z__4, &wk);
z__3.r = a[i__5].r * z__4.r - a[i__5].i * z__4.i,
z__3.i = a[i__5].r * z__4.i + a[i__5].i *
z__4.r;
z__2.r = a[i__4].r - z__3.r, z__2.i = a[i__4].i -
z__3.i;
i__6 = i__ + (k + 1) * a_dim1;
d_cnjg(&z__6, &wkp1);
z__5.r = a[i__6].r * z__6.r - a[i__6].i * z__6.i,
z__5.i = a[i__6].r * z__6.i + a[i__6].i *
z__6.r;
z__1.r = z__2.r - z__5.r, z__1.i = z__2.i -
z__5.i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L70: */
}
i__2 = j + k * a_dim1;
a[i__2].r = wk.r, a[i__2].i = wk.i;
i__2 = j + (k + 1) * a_dim1;
a[i__2].r = wkp1.r, a[i__2].i = wkp1.i;
i__2 = j + j * a_dim1;
i__3 = j + j * a_dim1;
d__1 = a[i__3].r;
z__1.r = d__1, z__1.i = 0.;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L80: */
}
}
}
}
/* 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 L50;
}
L90:
return 0;
/* End of ZHETF2 */
} /* zhetf2_ */
/* Subroutine */ int zgtt05_(char *trans, integer *n, integer *nrhs,
doublecomplex *dl, doublecomplex *d__, doublecomplex *du,
doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
doublecomplex *xact, integer *ldxact, doublereal *ferr, doublereal *
berr, doublereal *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, i__6, i__7, i__8, i__9;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10,
d__11, d__12, d__13, d__14;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
integer i__, j, k, nz;
doublereal eps, tmp, diff, axbi;
integer imax;
doublereal unfl, ovfl;
extern logical lsame_(char *, char *);
doublereal xnorm;
extern doublereal dlamch_(char *);
doublereal errbnd;
extern integer izamax_(integer *, doublecomplex *, integer *);
logical notran;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGTT05 tests the error bounds from iterative refinement for the */
/* computed solution to a system of equations A*X = B, where A is a */
/* general tridiagonal matrix of order n 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 and XACT. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of columns of the matrices X and XACT. NRHS >= 0. */
/* DL (input) COMPLEX*16 array, dimension (N-1) */
/* The (n-1) sub-diagonal elements of A. */
/* D (input) COMPLEX*16 array, dimension (N) */
/* The diagonal elements of A. */
/* DU (input) COMPLEX*16 array, dimension (N-1) */
/* The (n-1) super-diagonal elements of A. */
/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
/* The right hand side vectors for the system of linear */
/* equations. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
/* The computed solution vectors. Each vector is stored as a */
/* column of the matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* XACT (input) COMPLEX*16 array, dimension (LDX,NRHS) */
/* The exact solution vectors. Each vector is stored as a */
/* column of the matrix XACT. */
/* LDXACT (input) INTEGER */
/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
/* FERR (input) DOUBLE PRECISION array, dimension (NRHS) */
/* The estimated forward error bounds for each solution vector */
/* X. If XTRUE is the true solution, FERR bounds the magnitude */
/* of the largest entry in (X - XTRUE) divided by the magnitude */
/* of the largest entry in X. */
/* BERR (input) DOUBLE PRECISION array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector (i.e., the smallest relative change in any entry of A */
/* or B that makes X an exact solution). */
/* RESLTS (output) DOUBLE PRECISION array, dimension (2) */
/* The maximum over the NRHS solution vectors of the ratios: */
/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
/* RESLTS(2) = BERR / ( NZ*EPS + (*) ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 or NRHS = 0. */
/* Parameter adjustments */
--dl;
--d__;
--du;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
xact_dim1 = *ldxact;
xact_offset = 1 + xact_dim1;
xact -= xact_offset;
--ferr;
--berr;
--reslts;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
reslts[1] = 0.;
reslts[2] = 0.;
return 0;
}
eps = dlamch_("Epsilon");
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
notran = lsame_(trans, "N");
nz = 4;
/* Test 1: Compute the maximum of */
/* norm(X - XACT) / ( norm(X) * FERR ) */
/* over all the vectors X and XACT using the infinity-norm. */
errbnd = 0.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
imax = izamax_(n, &x[j * x_dim1 + 1], &c__1);
/* Computing MAX */
i__2 = imax + j * x_dim1;
d__3 = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x[imax + j *
x_dim1]), abs(d__2));
xnorm = max(d__3,unfl);
diff = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * x_dim1;
i__4 = i__ + j * xact_dim1;
z__2.r = x[i__3].r - xact[i__4].r, z__2.i = x[i__3].i - xact[i__4]
.i;
z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MAX */
d__3 = diff, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
z__1), abs(d__2));
diff = max(d__3,d__4);
/* L10: */
}
if (xnorm > 1.) {
goto L20;
} else if (diff <= ovfl * xnorm) {
goto L20;
} else {
errbnd = 1. / eps;
goto L30;
}
L20:
if (diff / xnorm <= ferr[j]) {
/* Computing MAX */
d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
errbnd = max(d__1,d__2);
} else {
errbnd = 1. / eps;
}
L30:
;
}
reslts[1] = errbnd;
/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where */
/* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
i__1 = *nrhs;
for (k = 1; k <= i__1; ++k) {
if (notran) {
if (*n == 1) {
i__2 = k * b_dim1 + 1;
i__3 = k * x_dim1 + 1;
axbi = (d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[k *
b_dim1 + 1]), abs(d__2)) + ((d__3 = d__[1].r, abs(
d__3)) + (d__4 = d_imag(&d__[1]), abs(d__4))) * ((
d__5 = x[i__3].r, abs(d__5)) + (d__6 = d_imag(&x[k *
x_dim1 + 1]), abs(d__6)));
} else {
i__2 = k * b_dim1 + 1;
i__3 = k * x_dim1 + 1;
i__4 = k * x_dim1 + 2;
axbi = (d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[k *
b_dim1 + 1]), abs(d__2)) + ((d__3 = d__[1].r, abs(
d__3)) + (d__4 = d_imag(&d__[1]), abs(d__4))) * ((
d__5 = x[i__3].r, abs(d__5)) + (d__6 = d_imag(&x[k *
x_dim1 + 1]), abs(d__6))) + ((d__7 = du[1].r, abs(
d__7)) + (d__8 = d_imag(&du[1]), abs(d__8))) * ((d__9
= x[i__4].r, abs(d__9)) + (d__10 = d_imag(&x[k *
x_dim1 + 2]), abs(d__10)));
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = i__ + k * b_dim1;
i__4 = i__ - 1;
i__5 = i__ - 1 + k * x_dim1;
i__6 = i__;
i__7 = i__ + k * x_dim1;
i__8 = i__;
i__9 = i__ + 1 + k * x_dim1;
tmp = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[
i__ + k * b_dim1]), abs(d__2)) + ((d__3 = dl[i__4]
.r, abs(d__3)) + (d__4 = d_imag(&dl[i__ - 1]),
abs(d__4))) * ((d__5 = x[i__5].r, abs(d__5)) + (
d__6 = d_imag(&x[i__ - 1 + k * x_dim1]), abs(d__6)
)) + ((d__7 = d__[i__6].r, abs(d__7)) + (d__8 =
d_imag(&d__[i__]), abs(d__8))) * ((d__9 = x[i__7]
.r, abs(d__9)) + (d__10 = d_imag(&x[i__ + k *
x_dim1]), abs(d__10))) + ((d__11 = du[i__8].r,
abs(d__11)) + (d__12 = d_imag(&du[i__]), abs(
d__12))) * ((d__13 = x[i__9].r, abs(d__13)) + (
d__14 = d_imag(&x[i__ + 1 + k * x_dim1]), abs(
d__14)));
axbi = min(axbi,tmp);
/* L40: */
}
i__2 = *n + k * b_dim1;
i__3 = *n - 1;
i__4 = *n - 1 + k * x_dim1;
i__5 = *n;
i__6 = *n + k * x_dim1;
tmp = (d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[*n +
k * b_dim1]), abs(d__2)) + ((d__3 = dl[i__3].r, abs(
d__3)) + (d__4 = d_imag(&dl[*n - 1]), abs(d__4))) * ((
d__5 = x[i__4].r, abs(d__5)) + (d__6 = d_imag(&x[*n -
1 + k * x_dim1]), abs(d__6))) + ((d__7 = d__[i__5].r,
abs(d__7)) + (d__8 = d_imag(&d__[*n]), abs(d__8))) * (
(d__9 = x[i__6].r, abs(d__9)) + (d__10 = d_imag(&x[*n
+ k * x_dim1]), abs(d__10)));
axbi = min(axbi,tmp);
}
} else {
if (*n == 1) {
i__2 = k * b_dim1 + 1;
i__3 = k * x_dim1 + 1;
axbi = (d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[k *
b_dim1 + 1]), abs(d__2)) + ((d__3 = d__[1].r, abs(
d__3)) + (d__4 = d_imag(&d__[1]), abs(d__4))) * ((
d__5 = x[i__3].r, abs(d__5)) + (d__6 = d_imag(&x[k *
x_dim1 + 1]), abs(d__6)));
} else {
i__2 = k * b_dim1 + 1;
i__3 = k * x_dim1 + 1;
i__4 = k * x_dim1 + 2;
axbi = (d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[k *
b_dim1 + 1]), abs(d__2)) + ((d__3 = d__[1].r, abs(
d__3)) + (d__4 = d_imag(&d__[1]), abs(d__4))) * ((
d__5 = x[i__3].r, abs(d__5)) + (d__6 = d_imag(&x[k *
x_dim1 + 1]), abs(d__6))) + ((d__7 = dl[1].r, abs(
d__7)) + (d__8 = d_imag(&dl[1]), abs(d__8))) * ((d__9
= x[i__4].r, abs(d__9)) + (d__10 = d_imag(&x[k *
x_dim1 + 2]), abs(d__10)));
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = i__ + k * b_dim1;
i__4 = i__ - 1;
i__5 = i__ - 1 + k * x_dim1;
i__6 = i__;
i__7 = i__ + k * x_dim1;
i__8 = i__;
i__9 = i__ + 1 + k * x_dim1;
tmp = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[
i__ + k * b_dim1]), abs(d__2)) + ((d__3 = du[i__4]
.r, abs(d__3)) + (d__4 = d_imag(&du[i__ - 1]),
abs(d__4))) * ((d__5 = x[i__5].r, abs(d__5)) + (
d__6 = d_imag(&x[i__ - 1 + k * x_dim1]), abs(d__6)
)) + ((d__7 = d__[i__6].r, abs(d__7)) + (d__8 =
d_imag(&d__[i__]), abs(d__8))) * ((d__9 = x[i__7]
.r, abs(d__9)) + (d__10 = d_imag(&x[i__ + k *
x_dim1]), abs(d__10))) + ((d__11 = dl[i__8].r,
abs(d__11)) + (d__12 = d_imag(&dl[i__]), abs(
d__12))) * ((d__13 = x[i__9].r, abs(d__13)) + (
d__14 = d_imag(&x[i__ + 1 + k * x_dim1]), abs(
d__14)));
axbi = min(axbi,tmp);
/* L50: */
}
i__2 = *n + k * b_dim1;
i__3 = *n - 1;
i__4 = *n - 1 + k * x_dim1;
i__5 = *n;
i__6 = *n + k * x_dim1;
tmp = (d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[*n +
k * b_dim1]), abs(d__2)) + ((d__3 = du[i__3].r, abs(
d__3)) + (d__4 = d_imag(&du[*n - 1]), abs(d__4))) * ((
d__5 = x[i__4].r, abs(d__5)) + (d__6 = d_imag(&x[*n -
1 + k * x_dim1]), abs(d__6))) + ((d__7 = d__[i__5].r,
abs(d__7)) + (d__8 = d_imag(&d__[*n]), abs(d__8))) * (
(d__9 = x[i__6].r, abs(d__9)) + (d__10 = d_imag(&x[*n
+ k * x_dim1]), abs(d__10)));
axbi = min(axbi,tmp);
}
}
/* Computing MAX */
d__1 = axbi, d__2 = nz * unfl;
tmp = berr[k] / (nz * eps + nz * unfl / max(d__1,d__2));
if (k == 1) {
reslts[2] = tmp;
} else {
reslts[2] = max(reslts[2],tmp);
}
/* L60: */
}
return 0;
/* End of ZGTT05 */
} /* zgtt05_ */
int zgst07(trans_t trans, int n, int nrhs, SuperMatrix *A, doublecomplex *b,
int ldb, doublecomplex *x, int ldx, doublecomplex *xact,
int ldxact, double *ferr, double *berr, double *reslts)
{
/*
Purpose
=======
ZGST07 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 n by n matrix 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 / ( (n+1)*EPS + (*) ), where
(*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
Arguments
=========
TRANS (input) trans_t
Specifies the form of the system of equations.
= NOTRANS: A *x = b
= TRANS : A'*x = b, where A' is the transpose of A
= CONJ : A'*x = b, where A' is the transpose of A
N (input) INT
The number of rows of the matrices X and XACT. N >= 0.
NRHS (input) INT
The number of columns of the matrices X and XACT. NRHS >= 0.
A (input) SuperMatrix *, dimension (A->nrow, A->ncol)
The original n by n matrix A.
B (input) DOUBLE COMPLEX PRECISION array, dimension (LDB,NRHS)
The right hand side vectors for the system of linear
equations.
LDB (input) INT
The leading dimension of the array B. LDB >= max(1,N).
X (input) DOUBLE COMPLEX PRECISION array, dimension (LDX,NRHS)
The computed solution vectors. Each vector is stored as a
column of the matrix X.
LDX (input) INT
The leading dimension of the array X. LDX >= max(1,N).
XACT (input) DOUBLE COMPLEX PRECISION array, dimension (LDX,NRHS)
The exact solution vectors. Each vector is stored as a
column of the matrix XACT.
LDXACT (input) INT
The leading dimension of the array XACT. LDXACT >= max(1,N).
FERR (input) DOUBLE COMPLEX PRECISION array, dimension (NRHS)
The estimated forward error bounds for each solution vector
X. If XTRUE is the true solution, FERR bounds the magnitude
of the largest entry in (X - XTRUE) divided by the magnitude
of the largest entry in X.
BERR (input) DOUBLE COMPLEX PRECISION array, dimension (NRHS)
The componentwise relative backward error of each solution
vector (i.e., the smallest relative change in any entry of A
or B that makes X an exact solution).
RESLTS (output) DOUBLE PRECISION array, dimension (2)
The maximum over the NRHS solution vectors of the ratios:
RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
RESLTS(2) = BERR / ( (n+1)*EPS + (*) )
=====================================================================
*/
/* Table of constant values */
int c__1 = 1;
/* System generated locals */
double d__1, d__2;
double d__3, d__4;
/* Local variables */
double diff, axbi;
int imax, irow, n__1;
int i, j, k;
double unfl, ovfl;
double xnorm;
double errbnd;
int notran;
double eps, tmp;
double *rwork;
doublecomplex *Aval;
NCformat *Astore;
/* Function prototypes */
extern int lsame_(char *, char *);
extern int izamax_(int *, doublecomplex *, int *);
/* Quick exit if N = 0 or NRHS = 0. */
if ( n <= 0 || nrhs <= 0 ) {
reslts[0] = 0.;
reslts[1] = 0.;
return 0;
}
eps = dlamch_("Epsilon");
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
notran = (trans == NOTRANS);
rwork = (double *) SUPERLU_MALLOC(n*sizeof(double));
if ( !rwork ) ABORT("SUPERLU_MALLOC fails for rwork");
Astore = A->Store;
Aval = (doublecomplex *) Astore->nzval;
/* 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.;
for (j = 0; j < nrhs; ++j) {
n__1 = n;
imax = izamax_(&n__1, &x[j*ldx], &c__1);
d__1 = (d__2 = x[imax-1 + j*ldx].r, fabs(d__2)) +
(d__3 = x[imax-1 + j*ldx].i, fabs(d__3));
xnorm = SUPERLU_MAX(d__1,unfl);
diff = 0.;
for (i = 0; i < n; ++i) {
d__1 = (d__2 = x[i+j*ldx].r - xact[i+j*ldxact].r, fabs(d__2)) +
(d__3 = x[i+j*ldx].i - xact[i+j*ldxact].i, fabs(d__3));
diff = SUPERLU_MAX(diff, d__1);
}
if (xnorm > 1.) {
goto L20;
} else if (diff <= ovfl * xnorm) {
goto L20;
} else {
errbnd = 1. / eps;
goto L30;
}
L20:
#if 0
if (diff / xnorm <= ferr[j]) {
d__1 = diff / xnorm / ferr[j];
errbnd = SUPERLU_MAX(errbnd,d__1);
} else {
errbnd = 1. / eps;
}
#endif
d__1 = diff / xnorm / ferr[j];
errbnd = SUPERLU_MAX(errbnd,d__1);
/*printf("Ferr: %f\n", errbnd);*/
L30:
;
}
reslts[0] = errbnd;
/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where
(*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) + abs(b))_i ) */
for (k = 0; k < nrhs; ++k) {
for (i = 0; i < n; ++i)
rwork[i] = (d__1 = b[i + k*ldb].r, fabs(d__1)) +
(d__2 = b[i + k*ldb].i, fabs(d__2));
if ( notran ) {
for (j = 0; j < n; ++j) {
tmp = (d__1 = x[j + k*ldx].r, fabs(d__1)) +
(d__2 = x[j + k*ldx].i, fabs(d__2));
for (i = Astore->colptr[j]; i < Astore->colptr[j+1]; ++i) {
d__1 = (d__2 = Aval[i].r, fabs(d__2)) +
(d__3 = Aval[i].i, fabs(d__3));
rwork[Astore->rowind[i]] += d__1 * tmp;
}
}
} else {
for (j = 0; j < n; ++j) {
tmp = 0.;
for (i = Astore->colptr[j]; i < Astore->colptr[j+1]; ++i) {
irow = Astore->rowind[i];
d__1 = (d__2 = x[irow + k*ldx].r, fabs(d__2)) +
(d__3 = x[irow + k*ldx].i, fabs(d__3));
d__2 = (d__3 = Aval[i].r, fabs(d__3)) +
(d__4 = Aval[i].i, fabs(d__4));
tmp += d__2 * d__1;
}
rwork[j] += tmp;
}
}
axbi = rwork[0];
for (i = 1; i < n; ++i) axbi = SUPERLU_MIN(axbi, rwork[i]);
/* Computing MAX */
d__1 = axbi, d__2 = (n + 1) * unfl;
tmp = berr[k] / ((n + 1) * eps + (n + 1) * unfl / SUPERLU_MAX(d__1,d__2));
if (k == 0) {
reslts[1] = tmp;
} else {
reslts[1] = SUPERLU_MAX(reslts[1],tmp);
}
}
SUPERLU_FREE(rwork);
return 0;
} /* zgst07 */
/* Subroutine */
int zlatps_(char *uplo, char *trans, char *diag, char * normin, integer *n, doublecomplex *ap, doublecomplex *x, doublereal * scale, doublereal *cnorm, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j, ip;
doublereal xj, rec, tjj;
integer jinc, jlen;
doublereal xbnd;
integer imax;
doublereal tmax;
doublecomplex tjjs;
doublereal xmax, grow;
extern /* Subroutine */
int dscal_(integer *, doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *);
doublereal tscal;
doublecomplex uscal;
integer jlast;
doublecomplex csumj;
extern /* Double Complex */
VOID zdotc_f2c_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *);
logical upper;
extern /* Double Complex */
VOID zdotu_f2c_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */
int zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), ztpsv_( char *, char *, char *, integer *, doublecomplex *, doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */
int xerbla_(char *, integer *), zdscal_( integer *, doublereal *, doublecomplex *, integer *);
doublereal bignum;
extern integer izamax_(integer *, doublecomplex *, integer *);
extern /* Double Complex */
VOID zladiv_(doublecomplex *, doublecomplex *, doublecomplex *);
logical notran;
integer jfirst;
extern doublereal dzasum_(integer *, doublecomplex *, integer *);
doublereal smlnum;
logical nounit;
/* -- LAPACK auxiliary routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--cnorm;
--x;
--ap;
/* 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;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZLATPS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
/* Determine machine dependent parameters to control overflow. */
smlnum = dlamch_("Safe minimum");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum /= dlamch_("Precision");
bignum = 1. / smlnum;
*scale = 1.;
if (lsame_(normin, "N"))
{
/* Compute the 1-norm of each column, not including the diagonal. */
if (upper)
{
/* A is upper triangular. */
ip = 1;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = j - 1;
cnorm[j] = dzasum_(&i__2, &ap[ip], &c__1);
ip += j;
/* L10: */
}
}
else
{
/* A is lower triangular. */
ip = 1;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n - j;
cnorm[j] = dzasum_(&i__2, &ap[ip + 1], &c__1);
ip = ip + *n - j + 1;
/* L20: */
}
cnorm[*n] = 0.;
}
}
/* Scale the column norms by TSCAL if the maximum element in CNORM is */
/* greater than BIGNUM/2. */
imax = idamax_(n, &cnorm[1], &c__1);
tmax = cnorm[imax];
if (tmax <= bignum * .5)
{
tscal = 1.;
}
else
{
tscal = .5 / (smlnum * tmax);
dscal_(n, &tscal, &cnorm[1], &c__1);
}
/* Compute a bound on the computed solution vector to see if the */
/* Level 2 BLAS routine ZTPSV can be used. */
xmax = 0.;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MAX */
i__2 = j;
d__3 = xmax;
d__4 = (d__1 = x[i__2].r / 2., abs(d__1)) + (d__2 = d_imag(&x[j]) / 2., abs(d__2)); // , expr subst
xmax = max(d__3,d__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.)
{
grow = 0.;
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 = .5 / max(xbnd,smlnum);
xbnd = grow;
ip = jfirst * (jfirst + 1) / 2;
jlen = *n;
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 = ip;
tjjs.r = ap[i__3].r;
tjjs.i = ap[i__3].i; // , expr subst
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs( d__2));
if (tjj >= smlnum)
{
/* M(j) = G(j-1) / abs(A(j,j)) */
/* Computing MIN */
d__1 = xbnd;
d__2 = min(1.,tjj) * grow; // , expr subst
xbnd = min(d__1,d__2);
}
else
{
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.;
}
if (tjj + cnorm[j] >= smlnum)
{
/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */
grow *= tjj / (tjj + cnorm[j]);
}
else
{
/* G(j) could overflow, set GROW to 0. */
grow = 0.;
}
ip += jinc * jlen;
--jlen;
/* L40: */
}
grow = xbnd;
}
else
{
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{
x(i), i=1,...,n}
. */
/* Computing MIN */
d__1 = 1.;
d__2 = .5 / max(xbnd,smlnum); // , expr subst
grow = min(d__1,d__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst;
i__1 < 0 ? j >= i__2 : j <= i__2;
j += i__1)
{
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum)
{
goto L60;
}
/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
grow *= 1. / (cnorm[j] + 1.);
/* 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.)
{
grow = 0.;
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 = .5 / max(xbnd,smlnum);
xbnd = grow;
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst;
i__2 < 0 ? j >= i__1 : j <= i__1;
j += i__2)
{
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum)
{
goto L90;
}
/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
xj = cnorm[j] + 1.;
/* Computing MIN */
d__1 = grow;
d__2 = xbnd / xj; // , expr subst
grow = min(d__1,d__2);
i__3 = ip;
tjjs.r = ap[i__3].r;
tjjs.i = ap[i__3].i; // , expr subst
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs( d__2));
if (tjj >= smlnum)
{
/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
if (xj > tjj)
{
xbnd *= tjj / xj;
}
}
else
{
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.;
}
++jlen;
ip += jinc * jlen;
/* L70: */
}
grow = min(grow,xbnd);
}
else
{
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{
x(i), i=1,...,n}
. */
/* Computing MIN */
d__1 = 1.;
d__2 = .5 / max(xbnd,smlnum); // , expr subst
grow = min(d__1,d__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst;
i__1 < 0 ? j >= i__2 : j <= i__2;
j += i__1)
{
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum)
{
goto L90;
}
/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
xj = cnorm[j] + 1.;
grow /= xj;
/* 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. */
ztpsv_(uplo, trans, diag, n, &ap[1], &x[1], &c__1);
}
else
{
/* Use a Level 1 BLAS solve, scaling intermediate results. */
if (xmax > bignum * .5)
{
/* Scale X so that its components are less than or equal to */
/* BIGNUM in absolute value. */
*scale = bignum * .5 / xmax;
zdscal_(n, scale, &x[1], &c__1);
xmax = bignum;
}
else
{
xmax *= 2.;
}
if (notran)
{
/* Solve A * x = b */
ip = jfirst * (jfirst + 1) / 2;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst;
i__2 < 0 ? j >= i__1 : j <= i__1;
j += i__2)
{
/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]), abs(d__2));
if (nounit)
{
i__3 = ip;
z__1.r = tscal * ap[i__3].r;
z__1.i = tscal * ap[i__3].i; // , expr subst
tjjs.r = z__1.r;
tjjs.i = z__1.i; // , expr subst
}
else
{
tjjs.r = tscal;
tjjs.i = 0.; // , expr subst
if (tscal == 1.)
{
goto L110;
}
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs( d__2));
if (tjj > smlnum)
{
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.)
{
if (xj > tjj * bignum)
{
/* Scale x by 1/b(j). */
rec = 1. / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r;
x[i__3].i = z__1.i; // , expr subst
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]) , abs(d__2));
}
else if (tjj > 0.)
{
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum)
{
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */
/* to avoid overflow when dividing by A(j,j). */
rec = tjj * bignum / xj;
if (cnorm[j] > 1.)
{
/* Scale by 1/CNORM(j) to avoid overflow when */
/* multiplying x(j) times column j. */
rec /= cnorm[j];
}
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r;
x[i__3].i = z__1.i; // , expr subst
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]) , abs(d__2));
}
else
{
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0, and compute a solution to A*x = 0. */
i__3 = *n;
for (i__ = 1;
i__ <= i__3;
++i__)
{
i__4 = i__;
x[i__4].r = 0.;
x[i__4].i = 0.; // , expr subst
/* L100: */
}
i__3 = j;
x[i__3].r = 1.;
x[i__3].i = 0.; // , expr subst
xj = 1.;
*scale = 0.;
xmax = 0.;
}
L110: /* Scale x if necessary to avoid overflow when adding a */
/* multiple of column j of A. */
if (xj > 1.)
{
rec = 1. / xj;
if (cnorm[j] > (bignum - xmax) * rec)
{
/* Scale x by 1/(2*abs(x(j))). */
rec *= .5;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
}
else if (xj * cnorm[j] > bignum - xmax)
{
/* Scale x by 1/2. */
zdscal_(n, &c_b36, &x[1], &c__1);
*scale *= .5;
}
if (upper)
{
if (j > 1)
{
/* Compute the update */
/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */
i__3 = j - 1;
i__4 = j;
z__2.r = -x[i__4].r;
z__2.i = -x[i__4].i; // , expr subst
z__1.r = tscal * z__2.r;
z__1.i = tscal * z__2.i; // , expr subst
zaxpy_(&i__3, &z__1, &ap[ip - j + 1], &c__1, &x[1], & c__1);
i__3 = j - 1;
i__ = izamax_(&i__3, &x[1], &c__1);
i__3 = i__;
xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag( &x[i__]), abs(d__2));
}
ip -= j;
}
else
{
if (j < *n)
{
/* Compute the update */
/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */
i__3 = *n - j;
i__4 = j;
z__2.r = -x[i__4].r;
z__2.i = -x[i__4].i; // , expr subst
z__1.r = tscal * z__2.r;
z__1.i = tscal * z__2.i; // , expr subst
zaxpy_(&i__3, &z__1, &ap[ip + 1], &c__1, &x[j + 1], & c__1);
i__3 = *n - j;
i__ = j + izamax_(&i__3, &x[j + 1], &c__1);
i__3 = i__;
xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag( &x[i__]), abs(d__2));
}
ip = ip + *n - j + 1;
}
/* L120: */
}
}
else if (lsame_(trans, "T"))
{
/* Solve A**T * x = b */
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
i__2 = jlast;
i__1 = jinc;
for (j = jfirst;
i__1 < 0 ? j >= i__2 : j <= i__2;
j += i__1)
{
/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
/* k<>j */
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]), abs(d__2));
uscal.r = tscal;
uscal.i = 0.; // , expr subst
rec = 1. / max(xmax,1.);
if (cnorm[j] > (bignum - xj) * rec)
{
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5;
if (nounit)
{
i__3 = ip;
z__1.r = tscal * ap[i__3].r;
z__1.i = tscal * ap[i__3] .i; // , expr subst
tjjs.r = z__1.r;
tjjs.i = z__1.i; // , expr subst
}
else
{
tjjs.r = tscal;
tjjs.i = 0.; // , expr subst
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(d__2));
if (tjj > 1.)
{
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
d__1 = 1.;
d__2 = rec * tjj; // , expr subst
rec = min(d__1,d__2);
zladiv_(&z__1, &uscal, &tjjs);
uscal.r = z__1.r;
uscal.i = z__1.i; // , expr subst
}
if (rec < 1.)
{
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0.;
csumj.i = 0.; // , expr subst
if (uscal.r == 1. && uscal.i == 0.)
{
/* If the scaling needed for A in the dot product is 1, */
/* call ZDOTU to perform the dot product. */
if (upper)
{
i__3 = j - 1;
zdotu_f2c_(&z__1, &i__3, &ap[ip - j + 1], &c__1, &x[1], & c__1);
csumj.r = z__1.r;
csumj.i = z__1.i; // , expr subst
}
else if (j < *n)
{
i__3 = *n - j;
zdotu_f2c_(&z__1, &i__3, &ap[ip + 1], &c__1, &x[j + 1], & c__1);
csumj.r = z__1.r;
csumj.i = z__1.i; // , expr subst
}
}
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 = ip - j + i__;
z__3.r = ap[i__4].r * uscal.r - ap[i__4].i * uscal.i;
z__3.i = ap[i__4].r * uscal.i + ap[i__4].i * uscal.r; // , expr subst
i__5 = i__;
z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i;
z__2.i = z__3.r * x[i__5].i + z__3.i * x[ i__5].r; // , expr subst
z__1.r = csumj.r + z__2.r;
z__1.i = csumj.i + z__2.i; // , expr subst
csumj.r = z__1.r;
csumj.i = z__1.i; // , expr subst
/* L130: */
}
}
else if (j < *n)
{
i__3 = *n - j;
for (i__ = 1;
i__ <= i__3;
++i__)
{
i__4 = ip + i__;
z__3.r = ap[i__4].r * uscal.r - ap[i__4].i * uscal.i;
z__3.i = ap[i__4].r * uscal.i + ap[i__4].i * uscal.r; // , expr subst
i__5 = j + i__;
z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i;
z__2.i = z__3.r * x[i__5].i + z__3.i * x[ i__5].r; // , expr subst
z__1.r = csumj.r + z__2.r;
z__1.i = csumj.i + z__2.i; // , expr subst
csumj.r = z__1.r;
csumj.i = z__1.i; // , expr subst
/* L140: */
}
}
}
z__1.r = tscal;
z__1.i = 0.; // , expr subst
if (uscal.r == z__1.r && uscal.i == z__1.i)
{
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
/* was not used to scale the dotproduct. */
i__3 = j;
i__4 = j;
z__1.r = x[i__4].r - csumj.r;
z__1.i = x[i__4].i - csumj.i; // , expr subst
x[i__3].r = z__1.r;
x[i__3].i = z__1.i; // , expr subst
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]) , abs(d__2));
if (nounit)
{
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
i__3 = ip;
z__1.r = tscal * ap[i__3].r;
z__1.i = tscal * ap[i__3] .i; // , expr subst
tjjs.r = z__1.r;
tjjs.i = z__1.i; // , expr subst
}
else
{
tjjs.r = tscal;
tjjs.i = 0.; // , expr subst
if (tscal == 1.)
{
goto L160;
}
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(d__2));
if (tjj > smlnum)
{
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.)
{
if (xj > tjj * bignum)
{
/* Scale X by 1/abs(x(j)). */
rec = 1. / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r;
x[i__3].i = z__1.i; // , expr subst
}
else if (tjj > 0.)
{
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum)
{
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r;
x[i__3].i = z__1.i; // , expr subst
}
else
{
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0 and compute a solution to A**T *x = 0. */
i__3 = *n;
for (i__ = 1;
i__ <= i__3;
++i__)
{
i__4 = i__;
x[i__4].r = 0.;
x[i__4].i = 0.; // , expr subst
/* L150: */
}
i__3 = j;
x[i__3].r = 1.;
x[i__3].i = 0.; // , expr subst
*scale = 0.;
xmax = 0.;
}
L160:
;
}
else
{
/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
/* product has already been divided by 1/A(j,j). */
i__3 = j;
zladiv_(&z__2, &x[j], &tjjs);
z__1.r = z__2.r - csumj.r;
z__1.i = z__2.i - csumj.i; // , expr subst
x[i__3].r = z__1.r;
x[i__3].i = z__1.i; // , expr subst
}
/* Computing MAX */
i__3 = j;
d__3 = xmax;
d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]), abs(d__2)); // , expr subst
xmax = max(d__3,d__4);
++jlen;
ip += jinc * jlen;
/* L170: */
}
}
else
{
/* Solve A**H * x = b */
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst;
i__2 < 0 ? j >= i__1 : j <= i__1;
j += i__2)
{
/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
/* k<>j */
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]), abs(d__2));
uscal.r = tscal;
uscal.i = 0.; // , expr subst
rec = 1. / max(xmax,1.);
if (cnorm[j] > (bignum - xj) * rec)
{
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5;
if (nounit)
{
d_cnjg(&z__2, &ap[ip]);
z__1.r = tscal * z__2.r;
z__1.i = tscal * z__2.i; // , expr subst
tjjs.r = z__1.r;
tjjs.i = z__1.i; // , expr subst
}
else
{
tjjs.r = tscal;
tjjs.i = 0.; // , expr subst
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(d__2));
if (tjj > 1.)
{
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
d__1 = 1.;
d__2 = rec * tjj; // , expr subst
rec = min(d__1,d__2);
zladiv_(&z__1, &uscal, &tjjs);
uscal.r = z__1.r;
uscal.i = z__1.i; // , expr subst
}
if (rec < 1.)
{
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0.;
csumj.i = 0.; // , expr subst
if (uscal.r == 1. && uscal.i == 0.)
{
/* If the scaling needed for A in the dot product is 1, */
/* call ZDOTC to perform the dot product. */
if (upper)
{
i__3 = j - 1;
zdotc_f2c_(&z__1, &i__3, &ap[ip - j + 1], &c__1, &x[1], & c__1);
csumj.r = z__1.r;
csumj.i = z__1.i; // , expr subst
}
else if (j < *n)
{
i__3 = *n - j;
zdotc_f2c_(&z__1, &i__3, &ap[ip + 1], &c__1, &x[j + 1], & c__1);
csumj.r = z__1.r;
csumj.i = z__1.i; // , expr subst
}
}
else
{
/* Otherwise, use in-line code for the dot product. */
if (upper)
{
i__3 = j - 1;
for (i__ = 1;
i__ <= i__3;
++i__)
{
d_cnjg(&z__4, &ap[ip - j + i__]);
z__3.r = z__4.r * uscal.r - z__4.i * uscal.i;
z__3.i = z__4.r * uscal.i + z__4.i * uscal.r; // , expr subst
i__4 = i__;
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i;
z__2.i = z__3.r * x[i__4].i + z__3.i * x[ i__4].r; // , expr subst
z__1.r = csumj.r + z__2.r;
z__1.i = csumj.i + z__2.i; // , expr subst
csumj.r = z__1.r;
csumj.i = z__1.i; // , expr subst
/* L180: */
}
}
else if (j < *n)
{
i__3 = *n - j;
for (i__ = 1;
i__ <= i__3;
++i__)
{
d_cnjg(&z__4, &ap[ip + i__]);
z__3.r = z__4.r * uscal.r - z__4.i * uscal.i;
z__3.i = z__4.r * uscal.i + z__4.i * uscal.r; // , expr subst
i__4 = j + i__;
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i;
z__2.i = z__3.r * x[i__4].i + z__3.i * x[ i__4].r; // , expr subst
z__1.r = csumj.r + z__2.r;
z__1.i = csumj.i + z__2.i; // , expr subst
csumj.r = z__1.r;
csumj.i = z__1.i; // , expr subst
/* L190: */
}
}
}
z__1.r = tscal;
z__1.i = 0.; // , expr subst
if (uscal.r == z__1.r && uscal.i == z__1.i)
{
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
/* was not used to scale the dotproduct. */
i__3 = j;
i__4 = j;
z__1.r = x[i__4].r - csumj.r;
z__1.i = x[i__4].i - csumj.i; // , expr subst
x[i__3].r = z__1.r;
x[i__3].i = z__1.i; // , expr subst
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]) , abs(d__2));
if (nounit)
{
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
d_cnjg(&z__2, &ap[ip]);
z__1.r = tscal * z__2.r;
z__1.i = tscal * z__2.i; // , expr subst
tjjs.r = z__1.r;
tjjs.i = z__1.i; // , expr subst
}
else
{
tjjs.r = tscal;
tjjs.i = 0.; // , expr subst
if (tscal == 1.)
{
goto L210;
}
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(d__2));
if (tjj > smlnum)
{
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.)
{
if (xj > tjj * bignum)
{
/* Scale X by 1/abs(x(j)). */
rec = 1. / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r;
x[i__3].i = z__1.i; // , expr subst
}
else if (tjj > 0.)
{
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum)
{
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r;
x[i__3].i = z__1.i; // , expr subst
}
else
{
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0 and compute a solution to A**H *x = 0. */
i__3 = *n;
for (i__ = 1;
i__ <= i__3;
++i__)
{
i__4 = i__;
x[i__4].r = 0.;
x[i__4].i = 0.; // , expr subst
/* L200: */
}
i__3 = j;
x[i__3].r = 1.;
x[i__3].i = 0.; // , expr subst
*scale = 0.;
xmax = 0.;
}
L210:
;
}
else
{
/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
/* product has already been divided by 1/A(j,j). */
i__3 = j;
zladiv_(&z__2, &x[j], &tjjs);
z__1.r = z__2.r - csumj.r;
z__1.i = z__2.i - csumj.i; // , expr subst
x[i__3].r = z__1.r;
x[i__3].i = z__1.i; // , expr subst
}
/* Computing MAX */
i__3 = j;
d__3 = xmax;
d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]), abs(d__2)); // , expr subst
xmax = max(d__3,d__4);
++jlen;
ip += jinc * jlen;
/* L220: */
}
}
*scale /= tscal;
}
/* Scale the column norms by 1/TSCAL for return. */
if (tscal != 1.)
{
d__1 = 1. / tscal;
dscal_(n, &d__1, &cnorm[1], &c__1);
}
return 0;
/* End of ZLATPS */
}
/* Subroutine */ int zggbal_(char *job, integer *n, doublecomplex *a, integer
*lda, doublecomplex *b, integer *ldb, integer *ilo, integer *ihi,
doublereal *lscale, doublereal *rscale, doublereal *work, integer *
info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double d_lg10(doublereal *), d_imag(doublecomplex *), z_abs(doublecomplex
*), d_sign(doublereal *, doublereal *), pow_di(doublereal *,
integer *);
/* Local variables */
integer i__, j, k, l, m;
doublereal t;
integer jc;
doublereal ta, tb, tc;
integer ir;
doublereal ew;
integer it, nr, ip1, jp1, lm1;
doublereal cab, rab, ewc, cor, sum;
integer nrp2, icab, lcab;
doublereal beta, coef;
integer irab, lrab;
doublereal basl, cmax;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
doublereal coef2, coef5, gamma, alpha;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
doublereal sfmin, sfmax;
integer iflow;
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
integer kount;
extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *);
doublereal pgamma;
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *);
integer lsfmin;
extern integer izamax_(integer *, doublecomplex *, integer *);
integer lsfmax;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGGBAL 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*16 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*16 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 integers 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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_("ZGGBAL", &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.;
rscale[1] = 1.;
return 0;
}
if (lsame_(job, "N")) {
*ilo = 1;
*ihi = *n;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
lscale[i__] = 1.;
rscale[i__] = 1.;
/* 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.;
lscale[1] = 1.;
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. || a[i__2].i != 0. || (b[i__3].r != 0. || b[
i__3].i != 0.)) {
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. || a[i__2].i != 0. || (b[i__3].r != 0. || b[
i__3].i != 0.)) {
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. || a[i__3].i != 0. || (b[i__4].r != 0. || b[
i__4].i != 0.)) {
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. || a[i__3].i != 0. || (b[i__4].r != 0. || b[
i__4].i != 0.)) {
goto L150;
}
/* L130: */
}
i__ = ip1 - 1;
L140:
m = k;
iflow = 2;
goto L160;
L150:
;
}
goto L190;
/* Permute rows M and I */
L160:
lscale[m] = (doublereal) i__;
if (i__ == m) {
goto L170;
}
i__1 = *n - k + 1;
zswap_(&i__1, &a[i__ + k * a_dim1], lda, &a[m + k * a_dim1], lda);
i__1 = *n - k + 1;
zswap_(&i__1, &b[i__ + k * b_dim1], ldb, &b[m + k * b_dim1], ldb);
/* Permute columns M and J */
L170:
rscale[m] = (doublereal) j;
if (j == m) {
goto L180;
}
zswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
zswap_(&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.;
rscale[i__] = 1.;
/* 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.;
lscale[i__] = 0.;
work[i__] = 0.;
work[i__ + *n] = 0.;
work[i__ + (*n << 1)] = 0.;
work[i__ + *n * 3] = 0.;
work[i__ + (*n << 2)] = 0.;
work[i__ + *n * 5] = 0.;
/* L200: */
}
/* Compute right side vector in resulting linear equations */
basl = d_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. && a[i__3].i == 0.) {
ta = 0.;
goto L210;
}
i__3 = i__ + j * a_dim1;
d__3 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + j *
a_dim1]), abs(d__2));
ta = d_lg10(&d__3) / basl;
L210:
i__3 = i__ + j * b_dim1;
if (b[i__3].r == 0. && b[i__3].i == 0.) {
tb = 0.;
goto L220;
}
i__3 = i__ + j * b_dim1;
d__3 = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[i__ + j *
b_dim1]), abs(d__2));
tb = d_lg10(&d__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. / (doublereal) (nr << 1);
coef2 = coef * coef;
coef5 = coef2 * .5;
nrp2 = nr + 2;
beta = 0.;
it = 1;
/* Start generalized conjugate gradient iteration */
L250:
gamma = ddot_(&nr, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + (*n << 2)]
, &c__1) + ddot_(&nr, &work[*ilo + *n * 5], &c__1, &work[*ilo + *
n * 5], &c__1);
ew = 0.;
ewc = 0.;
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
ew += work[i__ + (*n << 2)];
ewc += work[i__ + *n * 5];
/* L260: */
}
/* Computing 2nd power */
d__1 = ew;
/* Computing 2nd power */
d__2 = ewc;
/* Computing 2nd power */
d__3 = ew - ewc;
gamma = coef * gamma - coef2 * (d__1 * d__1 + d__2 * d__2) - coef5 * (
d__3 * d__3);
if (gamma == 0.) {
goto L350;
}
if (it != 1) {
beta = gamma / pgamma;
}
t = coef5 * (ewc - ew * 3.);
tc = coef5 * (ew - ewc * 3.);
dscal_(&nr, &beta, &work[*ilo], &c__1);
dscal_(&nr, &beta, &work[*ilo + *n], &c__1);
daxpy_(&nr, &coef, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + *n], &
c__1);
daxpy_(&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.;
i__2 = *ihi;
for (j = *ilo; j <= i__2; ++j) {
i__3 = i__ + j * a_dim1;
if (a[i__3].r == 0. && a[i__3].i == 0.) {
goto L280;
}
++kount;
sum += work[j];
L280:
i__3 = i__ + j * b_dim1;
if (b[i__3].r == 0. && b[i__3].i == 0.) {
goto L290;
}
++kount;
sum += work[j];
L290:
;
}
work[i__ + (*n << 1)] = (doublereal) kount * work[i__ + *n] + sum;
/* L300: */
}
i__1 = *ihi;
for (j = *ilo; j <= i__1; ++j) {
kount = 0;
sum = 0.;
i__2 = *ihi;
for (i__ = *ilo; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
if (a[i__3].r == 0. && a[i__3].i == 0.) {
goto L310;
}
++kount;
sum += work[i__ + *n];
L310:
i__3 = i__ + j * b_dim1;
if (b[i__3].r == 0. && b[i__3].i == 0.) {
goto L320;
}
++kount;
sum += work[i__ + *n];
L320:
;
}
work[j + *n * 3] = (doublereal) kount * work[j] + sum;
/* L330: */
}
sum = ddot_(&nr, &work[*ilo + *n], &c__1, &work[*ilo + (*n << 1)], &c__1)
+ ddot_(&nr, &work[*ilo], &c__1, &work[*ilo + *n * 3], &c__1);
alpha = gamma / sum;
/* Determine correction to current iteration */
cmax = 0.;
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 < .5) {
goto L350;
}
d__1 = -alpha;
daxpy_(&nr, &d__1, &work[*ilo + (*n << 1)], &c__1, &work[*ilo + (*n << 2)]
, &c__1);
d__1 = -alpha;
daxpy_(&nr, &d__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 = dlamch_("S");
sfmax = 1. / sfmin;
lsfmin = (integer) (d_lg10(&sfmin) / basl + 1.);
lsfmax = (integer) (d_lg10(&sfmax) / basl);
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
i__2 = *n - *ilo + 1;
irab = izamax_(&i__2, &a[i__ + *ilo * a_dim1], lda);
rab = z_abs(&a[i__ + (irab + *ilo - 1) * a_dim1]);
i__2 = *n - *ilo + 1;
irab = izamax_(&i__2, &b[i__ + *ilo * b_dim1], ldb);
/* Computing MAX */
d__1 = rab, d__2 = z_abs(&b[i__ + (irab + *ilo - 1) * b_dim1]);
rab = max(d__1,d__2);
d__1 = rab + sfmin;
lrab = (integer) (d_lg10(&d__1) / basl + 1.);
ir = (integer) (lscale[i__] + d_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_di(&c_b36, &ir);
icab = izamax_(ihi, &a[i__ * a_dim1 + 1], &c__1);
cab = z_abs(&a[icab + i__ * a_dim1]);
icab = izamax_(ihi, &b[i__ * b_dim1 + 1], &c__1);
/* Computing MAX */
d__1 = cab, d__2 = z_abs(&b[icab + i__ * b_dim1]);
cab = max(d__1,d__2);
d__1 = cab + sfmin;
lcab = (integer) (d_lg10(&d__1) / basl + 1.);
jc = (integer) (rscale[i__] + d_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_di(&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;
zdscal_(&i__2, &lscale[i__], &a[i__ + *ilo * a_dim1], lda);
i__2 = *n - *ilo + 1;
zdscal_(&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) {
zdscal_(ihi, &rscale[j], &a[j * a_dim1 + 1], &c__1);
zdscal_(ihi, &rscale[j], &b[j * b_dim1 + 1], &c__1);
/* L380: */
}
return 0;
/* End of ZGGBAL */
} /* zggbal_ */
/* Subroutine */ int ztpcon_(char *norm, char *uplo, char *diag, integer *n,
doublecomplex *ap, doublereal *rcond, doublecomplex *work, doublereal
*rwork, integer *info)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
/* Local variables */
integer ix, kase, kase1;
doublereal scale;
integer isave[3];
doublereal anorm;
logical upper;
doublereal xnorm;
doublereal ainvnm;
logical onenrm;
char normin[1];
doublereal smlnum;
logical nounit;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
/* Purpose */
/* ======= */
/* ZTPCON 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*16 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) DOUBLE PRECISION */
/* The reciprocal of the condition number of the matrix A, */
/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
--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_("ZTPCON", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*rcond = 1.;
return 0;
}
*rcond = 0.;
smlnum = dlamch_("Safe minimum") * (doublereal) max(1,*n);
/* Compute the norm of the triangular matrix A. */
anorm = zlantp_(norm, uplo, diag, n, &ap[1], &rwork[1]);
/* Continue only if ANORM > 0. */
if (anorm > 0.) {
/* Estimate the norm of the inverse of A. */
ainvnm = 0.;
*(unsigned char *)normin = 'N';
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kase = 0;
L10:
zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(A). */
zlatps_(uplo, "No transpose", diag, normin, n, &ap[1], &work[
1], &scale, &rwork[1], info);
} else {
/* Multiply by inv(A'). */
zlatps_(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.) {
ix = izamax_(n, &work[1], &c__1);
i__1 = ix;
xnorm = (d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(&
work[ix]), abs(d__2));
if (scale < xnorm * smlnum || scale == 0.) {
goto L20;
}
zdrscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) {
*rcond = 1. / anorm / ainvnm;
}
}
L20:
return 0;
/* End of ZTPCON */
} /* ztpcon_ */
/* Subroutine */ int zppcon_(char *uplo, integer *n, doublecomplex *ap,
doublereal *anorm, doublereal *rcond, doublecomplex *work, doublereal
*rwork, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
ZPPCON 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
ZPPTRF.
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*16 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) DOUBLE PRECISION
The 1-norm (or infinity-norm) of the Hermitian matrix A.
RCOND (output) DOUBLE PRECISION
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*16 array, dimension (2*N)
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer kase;
static doublereal scale;
extern logical lsame_(char *, char *);
static logical upper;
extern doublereal dlamch_(char *);
static integer ix;
static doublereal scalel, scaleu;
extern /* Subroutine */ int xerbla_(char *, integer *), zlacon_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *);
static doublereal ainvnm;
extern integer izamax_(integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zdrscl_(integer *, doublereal *,
doublecomplex *, integer *);
static char normin[1];
static doublereal smlnum;
extern /* Subroutine */ int zlatps_(char *, char *, char *, char *,
integer *, doublecomplex *, doublecomplex *, doublereal *,
doublereal *, integer *);
--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.) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPPCON", &i__1);
return 0;
}
/* Quick return if possible */
*rcond = 0.;
if (*n == 0) {
*rcond = 1.;
return 0;
} else if (*anorm == 0.) {
return 0;
}
smlnum = dlamch_("Safe minimum");
/* Estimate the 1-norm of the inverse. */
kase = 0;
*(unsigned char *)normin = 'N';
L10:
zlacon_(n, &work[*n + 1], &work[1], &ainvnm, &kase);
if (kase != 0) {
if (upper) {
/* Multiply by inv(U'). */
zlatps_("Upper", "Conjugate transpose", "Non-unit", normin, n, &
ap[1], &work[1], &scalel, &rwork[1], info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(U). */
zlatps_("Upper", "No transpose", "Non-unit", normin, n, &ap[1], &
work[1], &scaleu, &rwork[1], info);
} else {
/* Multiply by inv(L). */
zlatps_("Lower", "No transpose", "Non-unit", normin, n, &ap[1], &
work[1], &scalel, &rwork[1], info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(L'). */
zlatps_("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.) {
ix = izamax_(n, &work[1], &c__1);
i__1 = ix;
if (scale < ((d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(&
work[ix]), abs(d__2))) * smlnum || scale == 0.) {
goto L20;
}
zdrscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) {
*rcond = 1. / ainvnm / *anorm;
}
L20:
return 0;
/* End of ZPPCON */
} /* zppcon_ */
/* Subroutine */ int check1_(doublereal *sfac)
{
/* Initialized data */
static doublereal strue2[5] = { 0.,.5,.6,.7,.7 };
static doublereal strue4[5] = { 0.,.7,1.,1.3,1.7 };
static doublecomplex ctrue5[80] /* was [8][5][2] */ = { {.1,.1},{
1.,
2.
},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{-.16,-.37},{
3.,4.
},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{-.17,-.19}
,{.13,-.39},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{
.11,
-.03
},{-.17,.46},{-.17,-.19},{7.,8.},{7.,8.},{7.,8.},{7.,8.},{
7.,
8.
},{.19,-.17},{.32,.09},{.23,-.24},{.18,.01},{2.,3.},{2.,3.},{
2.,
3.
},{2.,3.},{.1,.1},{4.,5.},{4.,5.},{4.,5.},{4.,5.},{4.,5.},{
4.,
5.
},{4.,5.},{-.16,-.37},{6.,7.},{6.,7.},{6.,7.},{6.,7.},{6.,7.},{
6.,7.
},{6.,7.},{-.17,-.19},{8.,9.},{.13,-.39},{2.,5.},{2.,5.},{
2.,
5.
},{2.,5.},{2.,5.},{.11,-.03},{3.,6.},{-.17,.46},{4.,7.},{
-.17,
-.19
},{7.,2.},{7.,2.},{7.,2.},{.19,-.17},{5.,8.},{.32,.09},{6.,9.}
,{.23,-.24},{8.,3.},{.18,.01},{9.,4.}
};
static doublecomplex ctrue6[80] /* was [8][5][2] */ = { {.1,.1},{
1.,
2.
},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{.09,-.12},{
3.,4.
},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{.03,-.09},
{.15,-.03},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{.03,
.03
},{-.18,.03},{.03,-.09},{7.,8.},{7.,8.},{7.,8.},{7.,8.},{7.,8.}
,{.09,.03},{.03,.12},{.12,.03},{.03,.06},{2.,3.},{2.,3.},{2.,3.},{
2.,3.
},{.1,.1},{4.,5.},{4.,5.},{4.,5.},{4.,5.},{4.,5.},{4.,5.},{
4.,5.
},{.09,-.12},{6.,7.},{6.,7.},{6.,7.},{6.,7.},{6.,7.},{6.,7.},
{6.,7.},{.03,-.09},{8.,9.},{.15,-.03},{2.,5.},{2.,5.},{2.,5.},{2.,
5.
},{2.,5.},{.03,.03},{3.,6.},{-.18,.03},{4.,7.},{.03,-.09},{
7.,
2.
},{7.,2.},{7.,2.},{.09,.03},{5.,8.},{.03,.12},{6.,9.},{.12,.03},
{8.,3.},{.03,.06},{9.,4.}
};
static integer itrue3[5] = { 0,1,2,2,2 };
static doublereal sa = .3;
static doublecomplex ca = {.4,-.7};
static doublecomplex cv[80] /* was [8][5][2] */ = { {.1,.1},{1.,2.},{
1.,
2.
},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{.3,-.4},{3.,4.},{
3.,
4.
},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{.1,-.3},{.5,-.1},{
5.,
6.
},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{.1,.1},{-.6,.1},{
.1,
-.3
},{7.,8.},{7.,8.},{7.,8.},{7.,8.},{7.,8.},{.3,.1},{.1,.4},{
.4,
.1
},{.1,.2},{2.,3.},{2.,3.},{2.,3.},{2.,3.},{.1,.1},{4.,5.},{
4.,
5.
},{4.,5.},{4.,5.},{4.,5.},{4.,5.},{4.,5.},{.3,-.4},{6.,7.},{
6.,
7.
},{6.,7.},{6.,7.},{6.,7.},{6.,7.},{6.,7.},{.1,-.3},{8.,9.},{
.5,
-.1
},{2.,5.},{2.,5.},{2.,5.},{2.,5.},{2.,5.},{.1,.1},{3.,6.},{
-.6,
.1
},{4.,7.},{.1,-.3},{7.,2.},{7.,2.},{7.,2.},{.3,.1},{5.,8.},{
.1,
.4
},{6.,9.},{.4,.1},{8.,3.},{.1,.2},{9.,4.}
};
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1;
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Subroutine */ int s_stop(char *, ftnlen);
/* Local variables */
static integer i__;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *), ctest_(integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublereal *);
static doublecomplex mwpcs[5], mwpct[5];
extern /* Subroutine */ int itest1_(integer *, integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
extern /* Subroutine */ int stest1_(doublereal *, doublereal *,
doublereal *, doublereal *);
static doublecomplex cx[8];
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *);
extern integer izamax_(integer *, doublecomplex *, integer *);
extern doublereal dzasum_(integer *, doublecomplex *, integer *);
static integer np1, len;
/* Fortran I/O blocks */
static cilist io___19 = { 0, 6, 0, 0, 0 };
#define ctrue5_subscr(a_1,a_2,a_3) ((a_3)*5 + (a_2))*8 + a_1 - 49
#define ctrue5_ref(a_1,a_2,a_3) ctrue5[ctrue5_subscr(a_1,a_2,a_3)]
#define ctrue6_subscr(a_1,a_2,a_3) ((a_3)*5 + (a_2))*8 + a_1 - 49
#define ctrue6_ref(a_1,a_2,a_3) ctrue6[ctrue6_subscr(a_1,a_2,a_3)]
#define cv_subscr(a_1,a_2,a_3) ((a_3)*5 + (a_2))*8 + a_1 - 49
#define cv_ref(a_1,a_2,a_3) cv[cv_subscr(a_1,a_2,a_3)]
for (combla_1.incx = 1; combla_1.incx <= 2; ++combla_1.incx) {
for (np1 = 1; np1 <= 5; ++np1) {
combla_1.n = np1 - 1;
len = max(combla_1.n,1) << 1;
i__1 = len;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ - 1;
i__3 = cv_subscr(i__, np1, combla_1.incx);
cx[i__2].r = cv[i__3].r, cx[i__2].i = cv[i__3].i;
/* L20: */
}
if (combla_1.icase == 6) {
d__1 = dznrm2_(&combla_1.n, cx, &combla_1.incx);
stest1_(&d__1, &strue2[np1 - 1], &strue2[np1 - 1], sfac);
} else if (combla_1.icase == 7) {
d__1 = dzasum_(&combla_1.n, cx, &combla_1.incx);
stest1_(&d__1, &strue4[np1 - 1], &strue4[np1 - 1], sfac);
} else if (combla_1.icase == 8) {
zscal_(&combla_1.n, &ca, cx, &combla_1.incx);
ctest_(&len, cx, &ctrue5_ref(1, np1, combla_1.incx), &
ctrue5_ref(1, np1, combla_1.incx), sfac);
} else if (combla_1.icase == 9) {
zdscal_(&combla_1.n, &sa, cx, &combla_1.incx);
ctest_(&len, cx, &ctrue6_ref(1, np1, combla_1.incx), &
ctrue6_ref(1, np1, combla_1.incx), sfac);
} else if (combla_1.icase == 10) {
i__1 = izamax_(&combla_1.n, cx, &combla_1.incx);
itest1_(&i__1, &itrue3[np1 - 1]);
} else {
s_wsle(&io___19);
do_lio(&c__9, &c__1, " Shouldn't be here in CHECK1", (ftnlen)
28);
e_wsle();
s_stop("", (ftnlen)0);
}
/* L40: */
}
/* L60: */
}
combla_1.incx = 1;
if (combla_1.icase == 8) {
/* ZSCAL
Add a test for alpha equal to zero. */
ca.r = 0., ca.i = 0.;
for (i__ = 1; i__ <= 5; ++i__) {
i__1 = i__ - 1;
mwpct[i__1].r = 0., mwpct[i__1].i = 0.;
i__1 = i__ - 1;
mwpcs[i__1].r = 1., mwpcs[i__1].i = 1.;
/* L80: */
}
zscal_(&c__5, &ca, cx, &combla_1.incx);
ctest_(&c__5, cx, mwpct, mwpcs, sfac);
} else if (combla_1.icase == 9) {
/* ZDSCAL
Add a test for alpha equal to zero. */
sa = 0.;
for (i__ = 1; i__ <= 5; ++i__) {
i__1 = i__ - 1;
mwpct[i__1].r = 0., mwpct[i__1].i = 0.;
i__1 = i__ - 1;
mwpcs[i__1].r = 1., mwpcs[i__1].i = 1.;
/* L100: */
}
zdscal_(&c__5, &sa, cx, &combla_1.incx);
ctest_(&c__5, cx, mwpct, mwpcs, sfac);
/* Add a test for alpha equal to one. */
sa = 1.;
for (i__ = 1; i__ <= 5; ++i__) {
i__1 = i__ - 1;
i__2 = i__ - 1;
mwpct[i__1].r = cx[i__2].r, mwpct[i__1].i = cx[i__2].i;
i__1 = i__ - 1;
i__2 = i__ - 1;
mwpcs[i__1].r = cx[i__2].r, mwpcs[i__1].i = cx[i__2].i;
/* L120: */
}
zdscal_(&c__5, &sa, cx, &combla_1.incx);
ctest_(&c__5, cx, mwpct, mwpcs, sfac);
/* Add a test for alpha equal to minus one. */
sa = -1.;
for (i__ = 1; i__ <= 5; ++i__) {
i__1 = i__ - 1;
i__2 = i__ - 1;
z__1.r = -cx[i__2].r, z__1.i = -cx[i__2].i;
mwpct[i__1].r = z__1.r, mwpct[i__1].i = z__1.i;
i__1 = i__ - 1;
i__2 = i__ - 1;
z__1.r = -cx[i__2].r, z__1.i = -cx[i__2].i;
mwpcs[i__1].r = z__1.r, mwpcs[i__1].i = z__1.i;
/* L140: */
}
zdscal_(&c__5, &sa, cx, &combla_1.incx);
ctest_(&c__5, cx, mwpct, mwpcs, sfac);
}
return 0;
} /* check1_ */
/* Subroutine */ int zsptrf_(char *uplo, integer *n, doublecomplex *ap,
integer *ipiv, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double sqrt(doublereal), d_imag(doublecomplex *);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j, k;
doublecomplex t, r1, d11, d12, d21, d22;
integer kc, kk, kp;
doublecomplex wk;
integer kx, knc, kpc, npp;
doublecomplex wkm1, wkp1;
integer imax, jmax;
extern /* Subroutine */ int zspr_(char *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *);
doublereal alpha;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
integer kstep;
logical upper;
extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
doublereal absakk;
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal colmax;
extern integer izamax_(integer *, doublecomplex *, integer *);
doublereal rowmax;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZSPTRF computes the factorization of a complex symmetric matrix A */
/* stored in packed format using the Bunch-Kaufman diagonal pivoting */
/* method: */
/* A = U*D*U**T or A = L*D*L**T */
/* where U (or L) is a product of permutation and unit upper (lower) */
/* triangular matrices, and D is symmetric 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*16 array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the symmetric 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");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZSPTRF", &i__1);
return 0;
}
/* Initialize ALPHA for use in choosing pivot block size. */
alpha = (sqrt(17.) + 1.) / 8.;
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 = (d__1 = ap[i__1].r, abs(d__1)) + (d__2 = d_imag(&ap[kc + k -
1]), abs(d__2));
/* 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 = izamax_(&i__1, &ap[kc], &c__1);
i__1 = kc + imax - 1;
colmax = (d__1 = ap[i__1].r, abs(d__1)) + (d__2 = d_imag(&ap[kc +
imax - 1]), abs(d__2));
} else {
colmax = 0.;
}
if (max(absakk,colmax) == 0.) {
/* Column K is zero: 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 {
/* JMAX is the column-index of the largest off-diagonal */
/* element in row IMAX, and ROWMAX is its absolute value */
rowmax = 0.;
jmax = imax;
kx = imax * (imax + 1) / 2 + imax;
i__1 = k;
for (j = imax + 1; j <= i__1; ++j) {
i__2 = kx;
if ((d__1 = ap[i__2].r, abs(d__1)) + (d__2 = d_imag(&ap[
kx]), abs(d__2)) > rowmax) {
i__2 = kx;
rowmax = (d__1 = ap[i__2].r, abs(d__1)) + (d__2 =
d_imag(&ap[kx]), abs(d__2));
jmax = j;
}
kx += j;
/* L20: */
}
kpc = (imax - 1) * imax / 2 + 1;
if (imax > 1) {
i__1 = imax - 1;
jmax = izamax_(&i__1, &ap[kpc], &c__1);
/* Computing MAX */
i__1 = kpc + jmax - 1;
d__3 = rowmax, d__4 = (d__1 = ap[i__1].r, abs(d__1)) + (
d__2 = d_imag(&ap[kpc + jmax - 1]), abs(d__2));
rowmax = max(d__3,d__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 ((d__1 = ap[i__1].r, abs(d__1)) + (d__2 = d_imag(&ap[
kpc + imax - 1]), abs(d__2)) >= 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;
zswap_(&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;
i__2 = knc + j - 1;
t.r = ap[i__2].r, t.i = ap[i__2].i;
i__2 = knc + j - 1;
i__3 = kx;
ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i;
i__2 = kx;
ap[i__2].r = t.r, ap[i__2].i = t.i;
/* L30: */
}
i__1 = knc + kk - 1;
t.r = ap[i__1].r, t.i = ap[i__1].i;
i__1 = knc + kk - 1;
i__2 = kpc + kp - 1;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kpc + kp - 1;
ap[i__1].r = t.r, ap[i__1].i = t.i;
if (kstep == 2) {
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;
}
}
/* 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)' */
z_div(&z__1, &c_b1, &ap[kc + k - 1]);
r1.r = z__1.r, r1.i = z__1.i;
i__1 = k - 1;
z__1.r = -r1.r, z__1.i = -r1.i;
zspr_(uplo, &i__1, &z__1, &ap[kc], &c__1, &ap[1]);
/* Store U(k) in column k */
i__1 = k - 1;
zscal_(&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;
d12.r = ap[i__1].r, d12.i = ap[i__1].i;
z_div(&z__1, &ap[k - 1 + (k - 2) * (k - 1) / 2], &d12);
d22.r = z__1.r, d22.i = z__1.i;
z_div(&z__1, &ap[k + (k - 1) * k / 2], &d12);
d11.r = z__1.r, d11.i = z__1.i;
z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r *
d22.i + d11.i * d22.r;
z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.;
z_div(&z__1, &c_b1, &z__2);
t.r = z__1.r, t.i = z__1.i;
z_div(&z__1, &t, &d12);
d12.r = z__1.r, d12.i = z__1.i;
for (j = k - 2; j >= 1; --j) {
i__1 = j + (k - 2) * (k - 1) / 2;
z__3.r = d11.r * ap[i__1].r - d11.i * ap[i__1].i,
z__3.i = d11.r * ap[i__1].i + d11.i * ap[i__1]
.r;
i__2 = j + (k - 1) * k / 2;
z__2.r = z__3.r - ap[i__2].r, z__2.i = z__3.i - ap[
i__2].i;
z__1.r = d12.r * z__2.r - d12.i * z__2.i, z__1.i =
d12.r * z__2.i + d12.i * z__2.r;
wkm1.r = z__1.r, wkm1.i = z__1.i;
i__1 = j + (k - 1) * k / 2;
z__3.r = d22.r * ap[i__1].r - d22.i * ap[i__1].i,
z__3.i = d22.r * ap[i__1].i + d22.i * ap[i__1]
.r;
i__2 = j + (k - 2) * (k - 1) / 2;
z__2.r = z__3.r - ap[i__2].r, z__2.i = z__3.i - ap[
i__2].i;
z__1.r = d12.r * z__2.r - d12.i * z__2.i, z__1.i =
d12.r * z__2.i + d12.i * z__2.r;
wk.r = z__1.r, wk.i = z__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;
z__3.r = ap[i__3].r * wk.r - ap[i__3].i * wk.i,
z__3.i = ap[i__3].r * wk.i + ap[i__3].i *
wk.r;
z__2.r = ap[i__2].r - z__3.r, z__2.i = ap[i__2].i
- z__3.i;
i__4 = i__ + (k - 2) * (k - 1) / 2;
z__4.r = ap[i__4].r * wkm1.r - ap[i__4].i *
wkm1.i, z__4.i = ap[i__4].r * wkm1.i + ap[
i__4].i * wkm1.r;
z__1.r = z__2.r - z__4.r, z__1.i = z__2.i -
z__4.i;
ap[i__1].r = z__1.r, ap[i__1].i = z__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;
/* 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 = (d__1 = ap[i__1].r, abs(d__1)) + (d__2 = d_imag(&ap[kc]),
abs(d__2));
/* 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 + izamax_(&i__1, &ap[kc + 1], &c__1);
i__1 = kc + imax - k;
colmax = (d__1 = ap[i__1].r, abs(d__1)) + (d__2 = d_imag(&ap[kc +
imax - k]), abs(d__2));
} else {
colmax = 0.;
}
if (max(absakk,colmax) == 0.) {
/* Column K is zero: 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 {
/* JMAX is the column-index of the largest off-diagonal */
/* element in row IMAX, and ROWMAX is its absolute value */
rowmax = 0.;
kx = kc + imax - k;
i__1 = imax - 1;
for (j = k; j <= i__1; ++j) {
i__2 = kx;
if ((d__1 = ap[i__2].r, abs(d__1)) + (d__2 = d_imag(&ap[
kx]), abs(d__2)) > rowmax) {
i__2 = kx;
rowmax = (d__1 = ap[i__2].r, abs(d__1)) + (d__2 =
d_imag(&ap[kx]), abs(d__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 + izamax_(&i__1, &ap[kpc + 1], &c__1);
/* Computing MAX */
i__1 = kpc + jmax - imax;
d__3 = rowmax, d__4 = (d__1 = ap[i__1].r, abs(d__1)) + (
d__2 = d_imag(&ap[kpc + jmax - imax]), abs(d__2));
rowmax = max(d__3,d__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 ((d__1 = ap[i__1].r, abs(d__1)) + (d__2 = d_imag(&ap[
kpc]), abs(d__2)) >= 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;
zswap_(&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;
i__2 = knc + j - kk;
t.r = ap[i__2].r, t.i = ap[i__2].i;
i__2 = knc + j - kk;
i__3 = kx;
ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i;
i__2 = kx;
ap[i__2].r = t.r, ap[i__2].i = t.i;
/* L80: */
}
i__1 = knc;
t.r = ap[i__1].r, t.i = ap[i__1].i;
i__1 = knc;
i__2 = kpc;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kpc;
ap[i__1].r = t.r, ap[i__1].i = t.i;
if (kstep == 2) {
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;
}
}
/* 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)' */
z_div(&z__1, &c_b1, &ap[kc]);
r1.r = z__1.r, r1.i = z__1.i;
i__1 = *n - k;
z__1.r = -r1.r, z__1.i = -r1.i;
zspr_(uplo, &i__1, &z__1, &ap[kc + 1], &c__1, &ap[kc + *n
- k + 1]);
/* Store L(k) in column K */
i__1 = *n - k;
zscal_(&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;
d21.r = ap[i__1].r, d21.i = ap[i__1].i;
z_div(&z__1, &ap[k + 1 + k * ((*n << 1) - k - 1) / 2], &
d21);
d11.r = z__1.r, d11.i = z__1.i;
z_div(&z__1, &ap[k + (k - 1) * ((*n << 1) - k) / 2], &d21)
;
d22.r = z__1.r, d22.i = z__1.i;
z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r *
d22.i + d11.i * d22.r;
z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.;
z_div(&z__1, &c_b1, &z__2);
t.r = z__1.r, t.i = z__1.i;
z_div(&z__1, &t, &d21);
d21.r = z__1.r, d21.i = z__1.i;
i__1 = *n;
for (j = k + 2; j <= i__1; ++j) {
i__2 = j + (k - 1) * ((*n << 1) - k) / 2;
z__3.r = d11.r * ap[i__2].r - d11.i * ap[i__2].i,
z__3.i = d11.r * ap[i__2].i + d11.i * ap[i__2]
.r;
i__3 = j + k * ((*n << 1) - k - 1) / 2;
z__2.r = z__3.r - ap[i__3].r, z__2.i = z__3.i - ap[
i__3].i;
z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i =
d21.r * z__2.i + d21.i * z__2.r;
wk.r = z__1.r, wk.i = z__1.i;
i__2 = j + k * ((*n << 1) - k - 1) / 2;
z__3.r = d22.r * ap[i__2].r - d22.i * ap[i__2].i,
z__3.i = d22.r * ap[i__2].i + d22.i * ap[i__2]
.r;
i__3 = j + (k - 1) * ((*n << 1) - k) / 2;
z__2.r = z__3.r - ap[i__3].r, z__2.i = z__3.i - ap[
i__3].i;
z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i =
d21.r * z__2.i + d21.i * z__2.r;
wkp1.r = z__1.r, wkp1.i = z__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;
z__3.r = ap[i__5].r * wk.r - ap[i__5].i * wk.i,
z__3.i = ap[i__5].r * wk.i + ap[i__5].i *
wk.r;
z__2.r = ap[i__4].r - z__3.r, z__2.i = ap[i__4].i
- z__3.i;
i__6 = i__ + k * ((*n << 1) - k - 1) / 2;
z__4.r = ap[i__6].r * wkp1.r - ap[i__6].i *
wkp1.i, z__4.i = ap[i__6].r * wkp1.i + ap[
i__6].i * wkp1.r;
z__1.r = z__2.r - z__4.r, z__1.i = z__2.i -
z__4.i;
ap[i__3].r = z__1.r, ap[i__3].i = z__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;
/* 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 ZSPTRF */
} /* zsptrf_ */
/* Subroutine */ int zgebal_(char *job, integer *n, doublecomplex *a, integer
*lda, integer *ilo, integer *ihi, doublereal *scale, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
ZGEBAL balances a general complex matrix A. This involves, first,
permuting A by a similarity transformation 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 matrix, and improve the
accuracy of the computed eigenvalues and/or eigenvectors.
Arguments
=========
JOB (input) CHARACTER*1
Specifies the operations to be performed on A:
= 'N': none: simply set ILO = 1, IHI = N, SCALE(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 matrix A. N >= 0.
A (input/output) COMPLEX*16 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.
See Further Details.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
ILO (output) INTEGER
IHI (output) INTEGER
ILO and IHI are set to integers such that on exit
A(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.
SCALE (output) DOUBLE PRECISION array, dimension (N)
Details of the permutations and scaling factors applied to
A. If P(j) is the index of the row and column interchanged
with row and column j and D(j) is the scaling factor
applied to row and column j, then
SCALE(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.
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
Further Details
===============
The permutations consist of row and column interchanges which put
the matrix in the form
( T1 X Y )
P A P = ( 0 B Z )
( 0 0 T2 )
where T1 and T2 are upper triangular matrices whose eigenvalues lie
along the diagonal. The column indices ILO and IHI mark the starting
and ending columns of the submatrix B. Balancing consists of applying
a diagonal similarity transformation inv(D) * B * D to make the
1-norms of each row of B and its corresponding column nearly equal.
The output matrix is
( T1 X*D Y )
( 0 inv(D)*B*D inv(D)*Z ).
( 0 0 T2 )
Information about the permutations P and the diagonal matrix D is
returned in the vector SCALE.
This subroutine is based on the EISPACK routine CBAL.
Modified by Tzu-Yi Chen, Computer Science Division, University of
California at Berkeley, USA
=====================================================================
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, i__2, i__3;
doublereal d__1, d__2;
/* Builtin functions */
double d_imag(doublecomplex *), z_abs(doublecomplex *);
/* Local variables */
static integer iexc;
static doublereal c__, f, g;
static integer i__, j, k, l, m;
static doublereal r__, s;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
static doublereal sfmin1, sfmin2, sfmax1, sfmax2, ca, ra;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *);
extern integer izamax_(integer *, doublecomplex *, integer *);
static logical noconv;
static integer ica, ira;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--scale;
/* 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;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEBAL", &i__1);
return 0;
}
k = 1;
l = *n;
if (*n == 0) {
goto L210;
}
if (lsame_(job, "N")) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
scale[i__] = 1.;
/* L10: */
}
goto L210;
}
if (lsame_(job, "S")) {
goto L120;
}
/* Permutation to isolate eigenvalues if possible */
goto L50;
/* Row and column exchange. */
L20:
scale[m] = (doublereal) j;
if (j == m) {
goto L30;
}
zswap_(&l, &a_ref(1, j), &c__1, &a_ref(1, m), &c__1);
i__1 = *n - k + 1;
zswap_(&i__1, &a_ref(j, k), lda, &a_ref(m, k), lda);
L30:
switch (iexc) {
case 1: goto L40;
case 2: goto L80;
}
/* Search for rows isolating an eigenvalue and push them down. */
L40:
if (l == 1) {
goto L210;
}
--l;
L50:
for (j = l; j >= 1; --j) {
i__1 = l;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ == j) {
goto L60;
}
i__2 = a_subscr(j, i__);
if (a[i__2].r != 0. || d_imag(&a_ref(j, i__)) != 0.) {
goto L70;
}
L60:
;
}
m = l;
iexc = 1;
goto L20;
L70:
;
}
goto L90;
/* Search for columns isolating an eigenvalue and push them left. */
L80:
++k;
L90:
i__1 = l;
for (j = k; j <= i__1; ++j) {
i__2 = l;
for (i__ = k; i__ <= i__2; ++i__) {
if (i__ == j) {
goto L100;
}
i__3 = a_subscr(i__, j);
if (a[i__3].r != 0. || d_imag(&a_ref(i__, j)) != 0.) {
goto L110;
}
L100:
;
}
m = k;
iexc = 2;
goto L20;
L110:
;
}
L120:
i__1 = l;
for (i__ = k; i__ <= i__1; ++i__) {
scale[i__] = 1.;
/* L130: */
}
if (lsame_(job, "P")) {
goto L210;
}
/* Balance the submatrix in rows K to L.
Iterative loop for norm reduction */
sfmin1 = dlamch_("S") / dlamch_("P");
sfmax1 = 1. / sfmin1;
sfmin2 = sfmin1 * 8.;
sfmax2 = 1. / sfmin2;
L140:
noconv = FALSE_;
i__1 = l;
for (i__ = k; i__ <= i__1; ++i__) {
c__ = 0.;
r__ = 0.;
i__2 = l;
for (j = k; j <= i__2; ++j) {
if (j == i__) {
goto L150;
}
i__3 = a_subscr(j, i__);
c__ += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a_ref(j,
i__)), abs(d__2));
i__3 = a_subscr(i__, j);
r__ += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a_ref(i__,
j)), abs(d__2));
L150:
;
}
ica = izamax_(&l, &a_ref(1, i__), &c__1);
ca = z_abs(&a_ref(ica, i__));
i__2 = *n - k + 1;
ira = izamax_(&i__2, &a_ref(i__, k), lda);
ra = z_abs(&a_ref(i__, ira + k - 1));
/* Guard against zero C or R due to underflow. */
if (c__ == 0. || r__ == 0.) {
goto L200;
}
g = r__ / 8.;
f = 1.;
s = c__ + r__;
L160:
/* Computing MAX */
d__1 = max(f,c__);
/* Computing MIN */
d__2 = min(r__,g);
if (c__ >= g || max(d__1,ca) >= sfmax2 || min(d__2,ra) <= sfmin2) {
goto L170;
}
f *= 8.;
c__ *= 8.;
ca *= 8.;
r__ /= 8.;
g /= 8.;
ra /= 8.;
goto L160;
L170:
g = c__ / 8.;
L180:
/* Computing MIN */
d__1 = min(f,c__), d__1 = min(d__1,g);
if (g < r__ || max(r__,ra) >= sfmax2 || min(d__1,ca) <= sfmin2) {
goto L190;
}
f /= 8.;
c__ /= 8.;
g /= 8.;
ca /= 8.;
r__ *= 8.;
ra *= 8.;
goto L180;
/* Now balance. */
L190:
if (c__ + r__ >= s * .95) {
goto L200;
}
if (f < 1. && scale[i__] < 1.) {
if (f * scale[i__] <= sfmin1) {
goto L200;
}
}
if (f > 1. && scale[i__] > 1.) {
if (scale[i__] >= sfmax1 / f) {
goto L200;
}
}
g = 1. / f;
scale[i__] *= f;
noconv = TRUE_;
i__2 = *n - k + 1;
zdscal_(&i__2, &g, &a_ref(i__, k), lda);
zdscal_(&l, &f, &a_ref(1, i__), &c__1);
L200:
;
}
if (noconv) {
goto L140;
}
L210:
*ilo = k;
*ihi = l;
return 0;
/* End of ZGEBAL */
} /* zgebal_ */
/* Subroutine */ int ztbcon_(char *norm, char *uplo, char *diag, integer *n,
integer *kd, doublecomplex *ab, integer *ldab, doublereal *rcond,
doublecomplex *work, doublereal *rwork, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
ZTBCON estimates the reciprocal of the condition number of a
triangular band matrix A, in either the 1-norm or the infinity-norm.
The norm of A is computed and an estimate is obtained for
norm(inv(A)), then the reciprocal of the condition number is
computed as
RCOND = 1 / ( norm(A) * norm(inv(A)) ).
Arguments
=========
NORM (input) CHARACTER*1
Specifies whether the 1-norm condition number or the
infinity-norm condition number is required:
= '1' or 'O': 1-norm;
= 'I': Infinity-norm.
UPLO (input) CHARACTER*1
= 'U': A is upper triangular;
= 'L': A is lower triangular.
DIAG (input) CHARACTER*1
= 'N': A is non-unit triangular;
= 'U': A is unit triangular.
N (input) INTEGER
The order of the matrix A. N >= 0.
KD (input) INTEGER
The number of superdiagonals or subdiagonals of the
triangular band matrix A. KD >= 0.
AB (input) COMPLEX*16 array, dimension (LDAB,N)
The upper or lower triangular band matrix A, stored in the
first kd+1 rows of the array. The j-th column of A is stored
in the j-th column of the array AB as follows:
if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
If DIAG = 'U', the diagonal elements of A are not referenced
and are assumed to be 1.
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
RCOND (output) DOUBLE PRECISION
The reciprocal of the condition number of the matrix A,
computed as RCOND = 1/(norm(A) * norm(inv(A))).
WORK (workspace) COMPLEX*16 array, dimension (2*N)
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, i__1;
doublereal d__1, d__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer kase, kase1;
static doublereal scale;
extern logical lsame_(char *, char *);
static doublereal anorm;
static logical upper;
static doublereal xnorm;
extern doublereal dlamch_(char *);
static integer ix;
extern /* Subroutine */ int xerbla_(char *, integer *), zlacon_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *);
static doublereal ainvnm;
extern integer izamax_(integer *, doublecomplex *, integer *);
extern doublereal zlantb_(char *, char *, char *, integer *, integer *,
doublecomplex *, integer *, doublereal *);
static logical onenrm;
extern /* Subroutine */ int zlatbs_(char *, char *, char *, char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, doublereal *, integer *), zdrscl_(integer *, doublereal *, doublecomplex *,
integer *);
static char normin[1];
static doublereal smlnum;
static logical nounit;
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
--work;
--rwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
nounit = lsame_(diag, "N");
if (! onenrm && ! lsame_(norm, "I")) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*kd < 0) {
*info = -5;
} else if (*ldab < *kd + 1) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTBCON", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*rcond = 1.;
return 0;
}
*rcond = 0.;
smlnum = dlamch_("Safe minimum") * (doublereal) max(*n,1);
/* Compute the 1-norm of the triangular matrix A or A'. */
anorm = zlantb_(norm, uplo, diag, n, kd, &ab[ab_offset], ldab, &rwork[1]);
/* Continue only if ANORM > 0. */
if (anorm > 0.) {
/* Estimate the 1-norm of the inverse of A. */
ainvnm = 0.;
*(unsigned char *)normin = 'N';
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kase = 0;
L10:
zlacon_(n, &work[*n + 1], &work[1], &ainvnm, &kase);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(A). */
zlatbs_(uplo, "No transpose", diag, normin, n, kd, &ab[
ab_offset], ldab, &work[1], &scale, &rwork[1], info);
} else {
/* Multiply by inv(A'). */
zlatbs_(uplo, "Conjugate transpose", diag, normin, n, kd, &ab[
ab_offset], ldab, &work[1], &scale, &rwork[1], info);
}
*(unsigned char *)normin = 'Y';
/* Multiply by 1/SCALE if doing so will not cause overflow. */
if (scale != 1.) {
ix = izamax_(n, &work[1], &c__1);
i__1 = ix;
xnorm = (d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(&
work[ix]), abs(d__2));
if (scale < xnorm * smlnum || scale == 0.) {
goto L20;
}
zdrscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) {
*rcond = 1. / anorm / ainvnm;
}
}
L20:
return 0;
/* End of ZTBCON */
} /* ztbcon_ */
/* Subroutine */ int zhseqr_(char *job, char *compz, integer *n, integer *ilo,
integer *ihi, doublecomplex *h__, integer *ldh, doublecomplex *w,
doublecomplex *z__, integer *ldz, doublecomplex *work, integer *lwork,
integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
ZHSEQR 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 ZGEBAL, and then passed to CGEHRD
when the matrix output by ZGEBAL 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*16 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*16 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*16 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 ZUNGHR after
the call to ZGEHRD 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*16 array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= max(1,N).
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, ZHSEQR 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 */
/* Table of constant values */
static doublecomplex c_b1 = {0.,0.};
static doublecomplex c_b2 = {1.,0.};
static integer c__1 = 1;
static integer c__4 = 4;
static integer c_n1 = -1;
static integer c__2 = 2;
static integer c__8 = 8;
static integer c__15 = 15;
static logical c_false = FALSE_;
/* 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;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1;
char ch__1[2];
/* Builtin functions */
double d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static integer maxb, ierr;
static doublereal unfl;
static doublecomplex temp;
static doublereal ovfl;
static integer i__, j, k, l;
static doublecomplex s[225] /* was [15][15] */, v[16];
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
static integer itemp;
static doublereal rtemp;
static integer i1, i2;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static logical initz, wantt, wantz;
static doublereal rwork[1];
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern doublereal dlapy2_(doublereal *, doublereal *);
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
static integer ii, nh;
extern doublereal dlamch_(char *);
static integer nr, ns, nv;
static doublecomplex vv[16];
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *), zlarfg_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *);
extern integer izamax_(integer *, doublecomplex *, integer *);
extern doublereal zlanhs_(char *, integer *, doublecomplex *, integer *,
doublereal *);
extern /* Subroutine */ int zlahqr_(logical *, logical *, integer *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, integer *, doublecomplex *, integer *, integer *),
zlacpy_(char *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zlaset_(char *, integer *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
integer *), zlarfx_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *);
static doublereal smlnum;
static logical lquery;
static integer itn;
static doublecomplex tau;
static integer its;
static doublereal 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)]
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 = (doublereal) i__1, work[1].i = 0.;
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_("ZHSEQR", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Initialize Z, if necessary */
if (initz) {
zlaset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
}
/* Store the eigenvalues isolated by ZGEBAL. */
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., h__[i__3].i = 0.;
/* 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 (d_imag(&temp) != 0.) {
d__1 = temp.r;
d__2 = d_imag(&temp);
rtemp = dlapy2_(&d__1, &d__2);
i__2 = h___subscr(i__, i__ - 1);
h__[i__2].r = rtemp, h__[i__2].i = 0.;
z__1.r = temp.r / rtemp, z__1.i = temp.i / rtemp;
temp.r = z__1.r, temp.i = z__1.i;
if (i2 > i__) {
i__2 = i2 - i__;
d_cnjg(&z__1, &temp);
zscal_(&i__2, &z__1, &h___ref(i__, i__ + 1), ldh);
}
i__2 = i__ - i1;
zscal_(&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__);
z__1.r = temp.r * h__[i__3].r - temp.i * h__[i__3].i, z__1.i =
temp.r * h__[i__3].i + temp.i * h__[i__3].r;
h__[i__2].r = z__1.r, h__[i__2].i = z__1.i;
}
if (wantz) {
zscal_(&nh, &temp, &z___ref(*ilo, i__), &c__1);
}
}
/* 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, "ZHSEQR", 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, "ZHSEQR", ch__1, n, ilo, ihi, &c_n1, (ftnlen)6, (
ftnlen)2);
if (ns <= 1 || ns > nh || maxb >= nh) {
/* Use the standard double-shift algorithm */
zlahqr_(&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 = dlamch_("Safe minimum");
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("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 = (d__1 = h__[i__3].r, abs(d__1)) + (d__2 = d_imag(&h___ref(
k - 1, k - 1)), abs(d__2)) + ((d__3 = h__[i__5].r, abs(
d__3)) + (d__4 = d_imag(&h___ref(k, k)), abs(d__4)));
if (tst1 == 0.) {
i__3 = i__ - l + 1;
tst1 = zlanhs_("1", &i__3, &h___ref(l, l), ldh, rwork);
}
i__3 = h___subscr(k, k - 1);
/* Computing MAX */
d__2 = ulp * tst1;
if ((d__1 = h__[i__3].r, abs(d__1)) <= max(d__2,smlnum)) {
goto L80;
}
/* L70: */
}
L80:
l = k;
if (l > *ilo) {
/* H(L,L-1) is negligible. */
i__2 = h___subscr(l, l - 1);
h__[i__2].r = 0., h__[i__2].i = 0.;
}
/* 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);
d__3 = ((d__1 = h__[i__5].r, abs(d__1)) + (d__2 = h__[i__6].r,
abs(d__2))) * 1.5;
w[i__3].r = d__3, w[i__3].i = 0.;
/* L90: */
}
} else {
/* Use eigenvalues of trailing submatrix of order NS as shifts. */
zlacpy_("Full", &ns, &ns, &h___ref(i__ - ns + 1, i__ - ns + 1),
ldh, s, &c__15);
zlahqr_(&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 ZLAHQR 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., v[0].i = 0.;
i__2 = ns + 1;
for (ii = 2; ii <= i__2; ++ii) {
i__3 = ii - 1;
v[i__3].r = 0., v[i__3].i = 0.;
/* L110: */
}
nv = 1;
i__2 = i__;
for (j = i__ - ns + 1; j <= i__2; ++j) {
i__3 = nv + 1;
zcopy_(&i__3, v, &c__1, vv, &c__1);
i__3 = nv + 1;
i__5 = j;
z__1.r = -w[i__5].r, z__1.i = -w[i__5].i;
zgemv_("No transpose", &i__3, &nv, &c_b2, &h___ref(l, l), ldh, vv,
&c__1, &z__1, v, &c__1);
++nv;
/* Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero,
reset it to the unit vector. */
itemp = izamax_(&nv, v, &c__1);
i__3 = itemp - 1;
rtemp = (d__1 = v[i__3].r, abs(d__1)) + (d__2 = d_imag(&v[itemp -
1]), abs(d__2));
if (rtemp == 0.) {
v[0].r = 1., v[0].i = 0.;
i__3 = nv;
for (ii = 2; ii <= i__3; ++ii) {
i__5 = ii - 1;
v[i__5].r = 0., v[i__5].i = 0.;
/* L120: */
}
} else {
rtemp = max(rtemp,smlnum);
d__1 = 1. / rtemp;
zdscal_(&nv, &d__1, v, &c__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) {
zcopy_(&nr, &h___ref(k, k - 1), &c__1, v, &c__1);
}
zlarfg_(&nr, v, &v[1], &c__1, &tau);
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., h__[i__5].i = 0.;
/* L140: */
}
}
v[0].r = 1., v[0].i = 0.;
/* Apply G' from the left to transform the rows of the matrix
in columns K to I2. */
i__3 = i2 - k + 1;
d_cnjg(&z__1, &tau);
zlarfx_("Left", &nr, &i__3, v, &z__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;
zlarfx_("Right", &i__3, &nr, v, &tau, &h___ref(i1, k), ldh, &work[
1]);
if (wantz) {
/* Accumulate transformations in the matrix Z */
zlarfx_("Right", &nh, &nr, v, &tau, &z___ref(*ilo, k), ldz, &
work[1]);
}
/* 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 (d_imag(&temp) != 0.) {
d__1 = temp.r;
d__2 = d_imag(&temp);
rtemp = dlapy2_(&d__1, &d__2);
i__2 = h___subscr(i__, i__ - 1);
h__[i__2].r = rtemp, h__[i__2].i = 0.;
z__1.r = temp.r / rtemp, z__1.i = temp.i / rtemp;
temp.r = z__1.r, temp.i = z__1.i;
if (i2 > i__) {
i__2 = i2 - i__;
d_cnjg(&z__1, &temp);
zscal_(&i__2, &z__1, &h___ref(i__, i__ + 1), ldh);
}
i__2 = i__ - i1;
zscal_(&i__2, &temp, &h___ref(i1, i__), &c__1);
if (wantz) {
zscal_(&nh, &temp, &z___ref(*ilo, i__), &c__1);
}
}
/* 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. */
zlahqr_(&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:
i__1 = max(1,*n);
work[1].r = (doublereal) i__1, work[1].i = 0.;
return 0;
/* End of ZHSEQR */
} /* zhseqr_ */
