int
f2c_zdscal(integer* N,
doublereal* alpha,
doublecomplex* X, integer* incX)
{
zdscal_(N, alpha, X, incX);
return 0;
}
/*! double*_zgematrix operator */
inline _zgematrix operator*(const double& d, const _zgematrix& mat)
{
#ifdef CPPL_VERBOSE
std::cerr << "# [MARK] operator*(const double&, const _zgematrix&)"
<< std::endl;
#endif//CPPL_VERBOSE
zdscal_(mat.M*mat.N, d, mat.Array, 1);
return mat;
}
/*! zcovector*=double operator */
inline zcovector& zcovector::operator*=(const double& d)
{
#ifdef CPPL_VERBOSE
std::cerr << "# [MARK] zcovector::operator*=(const double&)"
<< std::endl;
#endif//CPPL_VERBOSE
zdscal_(L, d, Array, 1);
return *this;
}
int zpbtf2_(char *uplo, int *n, int *kd,
doublecomplex *ab, int *ldab, int *info)
{
/* System generated locals */
int ab_dim1, ab_offset, i__1, i__2, i__3;
double d__1;
/* Builtin functions */
double sqrt(double);
/* Local variables */
int j, kn;
double ajj;
int kld;
extern int zher_(char *, int *, double *,
doublecomplex *, int *, doublecomplex *, int *);
extern int lsame_(char *, char *);
int upper;
extern int xerbla_(char *, int *), zdscal_(
int *, double *, doublecomplex *, int *), zlacgv_(
int *, doublecomplex *, int *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZPBTF2 computes the Cholesky factorization of a complex Hermitian */
/* positive definite band matrix A. */
/* The factorization has the form */
/* A = U' * U , if UPLO = 'U', or */
/* A = L * L', if UPLO = 'L', */
/* where U is an upper triangular matrix, U' is the conjugate transpose */
/* of U, and L is lower triangular. */
/* 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. */
/* KD (input) INTEGER */
/* The number of super-diagonals of the matrix A if UPLO = 'U', */
/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
/* AB (input/output) COMPLEX*16 array, dimension (LDAB,N) */
/* On entry, the upper or lower triangle of the Hermitian band */
/* matrix A, stored in the first KD+1 rows of the array. The */
/* j-th column of A is stored in the j-th column of the array AB */
/* as follows: */
/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for MAX(1,j-kd)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=MIN(n,j+kd). */
/* On exit, if INFO = 0, the triangular factor U or L from the */
/* Cholesky factorization A = U'*U or A = L*L' of the band */
/* matrix A, in the same storage format as A. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KD+1. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* > 0: if INFO = k, the leading minor of order k is not */
/* positive definite, and the factorization could not be */
/* completed. */
/* Further Details */
/* =============== */
/* The band storage scheme is illustrated by the following example, when */
/* N = 6, KD = 2, and UPLO = 'U': */
/* On entry: On exit: */
/* * * a13 a24 a35 a46 * * u13 u24 u35 u46 */
/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
/* Similarly, if UPLO = 'L' the format of A is as follows: */
/* On entry: On exit: */
/* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 */
/* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * */
/* a31 a42 a53 a64 * * l31 l42 l53 l64 * * */
/* Array elements marked * are not used by the routine. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kd < 0) {
*info = -3;
} else if (*ldab < *kd + 1) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPBTF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Computing MAX */
i__1 = 1, i__2 = *ldab - 1;
kld = MAX(i__1,i__2);
if (upper) {
/* Compute the Cholesky factorization A = U'*U. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute U(J,J) and test for non-positive-definiteness. */
i__2 = *kd + 1 + j * ab_dim1;
ajj = ab[i__2].r;
if (ajj <= 0.) {
i__2 = *kd + 1 + j * ab_dim1;
ab[i__2].r = ajj, ab[i__2].i = 0.;
goto L30;
}
ajj = sqrt(ajj);
i__2 = *kd + 1 + j * ab_dim1;
ab[i__2].r = ajj, ab[i__2].i = 0.;
/* Compute elements J+1:J+KN of row J and update the */
/* trailing submatrix within the band. */
/* Computing MIN */
i__2 = *kd, i__3 = *n - j;
kn = MIN(i__2,i__3);
if (kn > 0) {
d__1 = 1. / ajj;
zdscal_(&kn, &d__1, &ab[*kd + (j + 1) * ab_dim1], &kld);
zlacgv_(&kn, &ab[*kd + (j + 1) * ab_dim1], &kld);
zher_("Upper", &kn, &c_b8, &ab[*kd + (j + 1) * ab_dim1], &kld,
&ab[*kd + 1 + (j + 1) * ab_dim1], &kld);
zlacgv_(&kn, &ab[*kd + (j + 1) * ab_dim1], &kld);
}
/* L10: */
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute L(J,J) and test for non-positive-definiteness. */
i__2 = j * ab_dim1 + 1;
ajj = ab[i__2].r;
if (ajj <= 0.) {
i__2 = j * ab_dim1 + 1;
ab[i__2].r = ajj, ab[i__2].i = 0.;
goto L30;
}
ajj = sqrt(ajj);
i__2 = j * ab_dim1 + 1;
ab[i__2].r = ajj, ab[i__2].i = 0.;
/* Compute elements J+1:J+KN of column J and update the */
/* trailing submatrix within the band. */
/* Computing MIN */
i__2 = *kd, i__3 = *n - j;
kn = MIN(i__2,i__3);
if (kn > 0) {
d__1 = 1. / ajj;
zdscal_(&kn, &d__1, &ab[j * ab_dim1 + 2], &c__1);
zher_("Lower", &kn, &c_b8, &ab[j * ab_dim1 + 2], &c__1, &ab[(
j + 1) * ab_dim1 + 1], &kld);
}
/* L20: */
}
}
return 0;
L30:
*info = j;
return 0;
/* End of ZPBTF2 */
} /* zpbtf2_ */
/* Subroutine */ int zlarfg_(integer *n, doublecomplex *alpha, doublecomplex *
x, integer *incx, doublecomplex *tau)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZLARFG generates a complex elementary reflector H of order n, such
that
H' * ( alpha ) = ( beta ), H' * H = I.
( x ) ( 0 )
where alpha and beta are scalars, with beta real, and x is an
(n-1)-element complex vector. H is represented in the form
H = I - tau * ( 1 ) * ( 1 v' ) ,
( v )
where tau is a complex scalar and v is a complex (n-1)-element
vector. Note that H is not hermitian.
If the elements of x are all zero and alpha is real, then tau = 0
and H is taken to be the unit matrix.
Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 .
Arguments
=========
N (input) INTEGER
The order of the elementary reflector.
ALPHA (input/output) COMPLEX*16
On entry, the value alpha.
On exit, it is overwritten with the value beta.
X (input/output) COMPLEX*16 array, dimension
(1+(N-2)*abs(INCX))
On entry, the vector x.
On exit, it is overwritten with the vector v.
INCX (input) INTEGER
The increment between elements of X. INCX > 0.
TAU (output) COMPLEX*16
The value tau.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b5 = {1.,0.};
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *), d_sign(doublereal *, doublereal *);
/* Local variables */
static doublereal beta;
static integer j;
static doublereal alphi, alphr;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
static doublereal xnorm;
extern doublereal dlapy3_(doublereal *, doublereal *, doublereal *),
dznrm2_(integer *, doublecomplex *, integer *), dlamch_(char *);
static doublereal safmin;
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *);
static doublereal rsafmn;
extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *,
doublecomplex *);
static integer knt;
--x;
/* Function Body */
if (*n <= 0) {
tau->r = 0., tau->i = 0.;
return 0;
}
i__1 = *n - 1;
xnorm = dznrm2_(&i__1, &x[1], incx);
alphr = alpha->r;
alphi = d_imag(alpha);
if (xnorm == 0. && alphi == 0.) {
/* H = I */
tau->r = 0., tau->i = 0.;
} else {
/* general case */
d__1 = dlapy3_(&alphr, &alphi, &xnorm);
beta = -d_sign(&d__1, &alphr);
safmin = dlamch_("S") / dlamch_("E");
rsafmn = 1. / safmin;
if (abs(beta) < safmin) {
/* XNORM, BETA may be inaccurate; scale X and recompute them */
knt = 0;
L10:
++knt;
i__1 = *n - 1;
zdscal_(&i__1, &rsafmn, &x[1], incx);
beta *= rsafmn;
alphi *= rsafmn;
alphr *= rsafmn;
if (abs(beta) < safmin) {
goto L10;
}
/* New BETA is at most 1, at least SAFMIN */
i__1 = *n - 1;
xnorm = dznrm2_(&i__1, &x[1], incx);
z__1.r = alphr, z__1.i = alphi;
alpha->r = z__1.r, alpha->i = z__1.i;
d__1 = dlapy3_(&alphr, &alphi, &xnorm);
beta = -d_sign(&d__1, &alphr);
d__1 = (beta - alphr) / beta;
d__2 = -alphi / beta;
z__1.r = d__1, z__1.i = d__2;
tau->r = z__1.r, tau->i = z__1.i;
z__2.r = alpha->r - beta, z__2.i = alpha->i;
zladiv_(&z__1, &c_b5, &z__2);
alpha->r = z__1.r, alpha->i = z__1.i;
i__1 = *n - 1;
zscal_(&i__1, alpha, &x[1], incx);
/* If ALPHA is subnormal, it may lose relative accuracy */
alpha->r = beta, alpha->i = 0.;
i__1 = knt;
for (j = 1; j <= i__1; ++j) {
z__1.r = safmin * alpha->r, z__1.i = safmin * alpha->i;
alpha->r = z__1.r, alpha->i = z__1.i;
/* L20: */
}
} else {
d__1 = (beta - alphr) / beta;
d__2 = -alphi / beta;
z__1.r = d__1, z__1.i = d__2;
tau->r = z__1.r, tau->i = z__1.i;
z__2.r = alpha->r - beta, z__2.i = alpha->i;
zladiv_(&z__1, &c_b5, &z__2);
alpha->r = z__1.r, alpha->i = z__1.i;
i__1 = *n - 1;
zscal_(&i__1, alpha, &x[1], incx);
alpha->r = beta, alpha->i = 0.;
}
}
return 0;
/* End of ZLARFG */
} /* zlarfg_ */
/* Subroutine */ int znaitr_(integer *ido, char *bmat, integer *n, integer *k,
integer *np, integer *nb, doublecomplex *resid, doublereal *rnorm,
doublecomplex *v, integer *ldv, doublecomplex *h__, integer *ldh,
integer *ipntr, doublecomplex *workd, integer *info, ftnlen bmat_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer h_dim1, h_offset, v_dim1, v_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1;
/* Builtin functions */
double d_imag(doublecomplex *), sqrt(doublereal);
/* Local variables */
static integer i__, j;
static real t0, t1, t2, t3, t4, t5;
static integer jj, ipj, irj, ivj;
static doublereal ulp, tst1;
static integer ierr, iter;
static doublereal unfl, ovfl;
static integer itry;
static doublereal temp1;
static logical orth1, orth2, step3, step4;
static doublereal betaj;
static integer infol;
static doublecomplex cnorm;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal rtemp[2];
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, ftnlen);
static doublereal wnorm;
extern /* Subroutine */ int dvout_(integer *, integer *, doublereal *,
integer *, char *, ftnlen), zcopy_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *), ivout_(integer *, integer
*, integer *, integer *, char *, ftnlen), zaxpy_(integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *), zmout_(integer *, integer *, integer *, doublecomplex
*, integer *, integer *, char *, ftnlen), zvout_(integer *,
integer *, doublecomplex *, integer *, char *, ftnlen);
extern doublereal dlapy2_(doublereal *, doublereal *);
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
static doublereal rnorm1;
extern /* Subroutine */ int zgetv0_(integer *, char *, integer *, logical
*, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, doublereal *, integer *, doublecomplex *,
integer *, ftnlen);
extern doublereal dlamch_(char *, ftnlen);
extern /* Subroutine */ int second_(real *), zdscal_(integer *,
doublereal *, doublecomplex *, integer *);
static logical rstart;
static integer msglvl;
static doublereal smlnum;
extern doublereal zlanhs_(char *, integer *, doublecomplex *, integer *,
doublecomplex *, ftnlen);
extern /* Subroutine */ int zlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublecomplex *,
integer *, integer *, ftnlen);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %--------------% */
/* | Local Arrays | */
/* %--------------% */
/* %---------------% */
/* | Local Scalars | */
/* %---------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %---------------------% */
/* | Intrinsic Functions | */
/* %---------------------% */
/* %-----------------% */
/* | Data statements | */
/* %-----------------% */
/* Parameter adjustments */
--workd;
--resid;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--ipntr;
/* Function Body */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
if (first) {
/* %-----------------------------------------% */
/* | Set machine-dependent constants for the | */
/* | the splitting and deflation criterion. | */
/* | If norm(H) <= sqrt(OVFL), | */
/* | overflow should not occur. | */
/* | REFERENCE: LAPACK subroutine zlahqr | */
/* %-----------------------------------------% */
unfl = dlamch_("safe minimum", (ftnlen)12);
z__1.r = 1. / unfl, z__1.i = 0. / unfl;
ovfl = z__1.r;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("precision", (ftnlen)9);
smlnum = unfl * (*n / ulp);
first = FALSE_;
}
if (*ido == 0) {
/* %-------------------------------% */
/* | Initialize timing statistics | */
/* | & message level for debugging | */
/* %-------------------------------% */
second_(&t0);
msglvl = debug_1.mcaitr;
/* %------------------------------% */
/* | Initial call to this routine | */
/* %------------------------------% */
*info = 0;
step3 = FALSE_;
step4 = FALSE_;
rstart = FALSE_;
orth1 = FALSE_;
orth2 = FALSE_;
j = *k + 1;
ipj = 1;
irj = ipj + *n;
ivj = irj + *n;
}
/* %-------------------------------------------------% */
/* | When in reverse communication mode one of: | */
/* | STEP3, STEP4, ORTH1, ORTH2, RSTART | */
/* | will be .true. when .... | */
/* | STEP3: return from computing OP*v_{j}. | */
/* | STEP4: return from computing B-norm of OP*v_{j} | */
/* | ORTH1: return from computing B-norm of r_{j+1} | */
/* | ORTH2: return from computing B-norm of | */
/* | correction to the residual vector. | */
/* | RSTART: return from OP computations needed by | */
/* | zgetv0. | */
/* %-------------------------------------------------% */
if (step3) {
goto L50;
}
if (step4) {
goto L60;
}
if (orth1) {
goto L70;
}
if (orth2) {
goto L90;
}
if (rstart) {
goto L30;
}
/* %-----------------------------% */
/* | Else this is the first step | */
/* %-----------------------------% */
/* %--------------------------------------------------------------% */
/* | | */
/* | A R N O L D I I T E R A T I O N L O O P | */
/* | | */
/* | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | */
/* %--------------------------------------------------------------% */
L1000:
if (msglvl > 1) {
ivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: generat"
"ing Arnoldi vector number", (ftnlen)40);
dvout_(&debug_1.logfil, &c__1, rnorm, &debug_1.ndigit, "_naitr: B-no"
"rm of the current residual is", (ftnlen)41);
}
/* %---------------------------------------------------% */
/* | STEP 1: Check if the B norm of j-th residual | */
/* | vector is zero. Equivalent to determine whether | */
/* | an exact j-step Arnoldi factorization is present. | */
/* %---------------------------------------------------% */
betaj = *rnorm;
if (*rnorm > 0.) {
goto L40;
}
/* %---------------------------------------------------% */
/* | Invariant subspace found, generate a new starting | */
/* | vector which is orthogonal to the current Arnoldi | */
/* | basis and continue the iteration. | */
/* %---------------------------------------------------% */
if (msglvl > 0) {
ivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: ****** "
"RESTART AT STEP ******", (ftnlen)37);
}
/* %---------------------------------------------% */
/* | ITRY is the loop variable that controls the | */
/* | maximum amount of times that a restart is | */
/* | attempted. NRSTRT is used by stat.h | */
/* %---------------------------------------------% */
betaj = 0.;
++timing_1.nrstrt;
itry = 1;
L20:
rstart = TRUE_;
*ido = 0;
L30:
/* %--------------------------------------% */
/* | If in reverse communication mode and | */
/* | RSTART = .true. flow returns here. | */
/* %--------------------------------------% */
zgetv0_(ido, bmat, &itry, &c_false, n, &j, &v[v_offset], ldv, &resid[1],
rnorm, &ipntr[1], &workd[1], &ierr, (ftnlen)1);
if (*ido != 99) {
goto L9000;
}
if (ierr < 0) {
++itry;
if (itry <= 3) {
goto L20;
}
/* %------------------------------------------------% */
/* | Give up after several restart attempts. | */
/* | Set INFO to the size of the invariant subspace | */
/* | which spans OP and exit. | */
/* %------------------------------------------------% */
*info = j - 1;
second_(&t1);
timing_1.tcaitr += t1 - t0;
*ido = 99;
goto L9000;
}
L40:
/* %---------------------------------------------------------% */
/* | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | */
/* | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | */
/* | when reciprocating a small RNORM, test against lower | */
/* | machine bound. | */
/* %---------------------------------------------------------% */
zcopy_(n, &resid[1], &c__1, &v[j * v_dim1 + 1], &c__1);
if (*rnorm >= unfl) {
temp1 = 1. / *rnorm;
zdscal_(n, &temp1, &v[j * v_dim1 + 1], &c__1);
zdscal_(n, &temp1, &workd[ipj], &c__1);
} else {
/* %-----------------------------------------% */
/* | To scale both v_{j} and p_{j} carefully | */
/* | use LAPACK routine zlascl | */
/* %-----------------------------------------% */
zlascl_("General", &i__, &i__, rnorm, &c_b27, n, &c__1, &v[j * v_dim1
+ 1], n, &infol, (ftnlen)7);
zlascl_("General", &i__, &i__, rnorm, &c_b27, n, &c__1, &workd[ipj],
n, &infol, (ftnlen)7);
}
/* %------------------------------------------------------% */
/* | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | */
/* | Note that this is not quite yet r_{j}. See STEP 4 | */
/* %------------------------------------------------------% */
step3 = TRUE_;
++timing_1.nopx;
second_(&t2);
zcopy_(n, &v[j * v_dim1 + 1], &c__1, &workd[ivj], &c__1);
ipntr[1] = ivj;
ipntr[2] = irj;
ipntr[3] = ipj;
*ido = 1;
/* %-----------------------------------% */
/* | Exit in order to compute OP*v_{j} | */
/* %-----------------------------------% */
goto L9000;
L50:
/* %----------------------------------% */
/* | Back from reverse communication; | */
/* | WORKD(IRJ:IRJ+N-1) := OP*v_{j} | */
/* | if step3 = .true. | */
/* %----------------------------------% */
second_(&t3);
timing_1.tmvopx += t3 - t2;
step3 = FALSE_;
/* %------------------------------------------% */
/* | Put another copy of OP*v_{j} into RESID. | */
/* %------------------------------------------% */
zcopy_(n, &workd[irj], &c__1, &resid[1], &c__1);
/* %---------------------------------------% */
/* | STEP 4: Finish extending the Arnoldi | */
/* | factorization to length j. | */
/* %---------------------------------------% */
second_(&t2);
if (*(unsigned char *)bmat == 'G') {
++timing_1.nbx;
step4 = TRUE_;
ipntr[1] = irj;
ipntr[2] = ipj;
*ido = 2;
/* %-------------------------------------% */
/* | Exit in order to compute B*OP*v_{j} | */
/* %-------------------------------------% */
goto L9000;
} else if (*(unsigned char *)bmat == 'I') {
zcopy_(n, &resid[1], &c__1, &workd[ipj], &c__1);
}
L60:
/* %----------------------------------% */
/* | Back from reverse communication; | */
/* | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} | */
/* | if step4 = .true. | */
/* %----------------------------------% */
if (*(unsigned char *)bmat == 'G') {
second_(&t3);
timing_1.tmvbx += t3 - t2;
}
step4 = FALSE_;
/* %-------------------------------------% */
/* | The following is needed for STEP 5. | */
/* | Compute the B-norm of OP*v_{j}. | */
/* %-------------------------------------% */
if (*(unsigned char *)bmat == 'G') {
zdotc_(&z__1, n, &resid[1], &c__1, &workd[ipj], &c__1);
cnorm.r = z__1.r, cnorm.i = z__1.i;
d__1 = cnorm.r;
d__2 = d_imag(&cnorm);
wnorm = sqrt(dlapy2_(&d__1, &d__2));
} else if (*(unsigned char *)bmat == 'I') {
wnorm = dznrm2_(n, &resid[1], &c__1);
}
/* %-----------------------------------------% */
/* | Compute the j-th residual corresponding | */
/* | to the j step factorization. | */
/* | Use Classical Gram Schmidt and compute: | */
/* | w_{j} <- V_{j}^T * B * OP * v_{j} | */
/* | r_{j} <- OP*v_{j} - V_{j} * w_{j} | */
/* %-----------------------------------------% */
/* %------------------------------------------% */
/* | Compute the j Fourier coefficients w_{j} | */
/* | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | */
/* %------------------------------------------% */
zgemv_("C", n, &j, &c_b1, &v[v_offset], ldv, &workd[ipj], &c__1, &c_b2, &
h__[j * h_dim1 + 1], &c__1, (ftnlen)1);
/* %--------------------------------------% */
/* | Orthogonalize r_{j} against V_{j}. | */
/* | RESID contains OP*v_{j}. See STEP 3. | */
/* %--------------------------------------% */
z__1.r = -1., z__1.i = -0.;
zgemv_("N", n, &j, &z__1, &v[v_offset], ldv, &h__[j * h_dim1 + 1], &c__1,
&c_b1, &resid[1], &c__1, (ftnlen)1);
if (j > 1) {
i__1 = j + (j - 1) * h_dim1;
z__1.r = betaj, z__1.i = 0.;
h__[i__1].r = z__1.r, h__[i__1].i = z__1.i;
}
second_(&t4);
orth1 = TRUE_;
second_(&t2);
if (*(unsigned char *)bmat == 'G') {
++timing_1.nbx;
zcopy_(n, &resid[1], &c__1, &workd[irj], &c__1);
ipntr[1] = irj;
ipntr[2] = ipj;
*ido = 2;
/* %----------------------------------% */
/* | Exit in order to compute B*r_{j} | */
/* %----------------------------------% */
goto L9000;
} else if (*(unsigned char *)bmat == 'I') {
zcopy_(n, &resid[1], &c__1, &workd[ipj], &c__1);
}
L70:
/* %---------------------------------------------------% */
/* | Back from reverse communication if ORTH1 = .true. | */
/* | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | */
/* %---------------------------------------------------% */
if (*(unsigned char *)bmat == 'G') {
second_(&t3);
timing_1.tmvbx += t3 - t2;
}
orth1 = FALSE_;
/* %------------------------------% */
/* | Compute the B-norm of r_{j}. | */
/* %------------------------------% */
if (*(unsigned char *)bmat == 'G') {
zdotc_(&z__1, n, &resid[1], &c__1, &workd[ipj], &c__1);
cnorm.r = z__1.r, cnorm.i = z__1.i;
d__1 = cnorm.r;
d__2 = d_imag(&cnorm);
*rnorm = sqrt(dlapy2_(&d__1, &d__2));
} else if (*(unsigned char *)bmat == 'I') {
*rnorm = dznrm2_(n, &resid[1], &c__1);
}
/* %-----------------------------------------------------------% */
/* | STEP 5: Re-orthogonalization / Iterative refinement phase | */
/* | Maximum NITER_ITREF tries. | */
/* | | */
/* | s = V_{j}^T * B * r_{j} | */
/* | r_{j} = r_{j} - V_{j}*s | */
/* | alphaj = alphaj + s_{j} | */
/* | | */
/* | The stopping criteria used for iterative refinement is | */
/* | discussed in Parlett's book SEP, page 107 and in Gragg & | */
/* | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | */
/* | Determine if we need to correct the residual. The goal is | */
/* | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | */
/* | The following test determines whether the sine of the | */
/* | angle between OP*x and the computed residual is less | */
/* | than or equal to 0.717. | */
/* %-----------------------------------------------------------% */
if (*rnorm > wnorm * .717f) {
goto L100;
}
iter = 0;
++timing_1.nrorth;
/* %---------------------------------------------------% */
/* | Enter the Iterative refinement phase. If further | */
/* | refinement is necessary, loop back here. The loop | */
/* | variable is ITER. Perform a step of Classical | */
/* | Gram-Schmidt using all the Arnoldi vectors V_{j} | */
/* %---------------------------------------------------% */
L80:
if (msglvl > 2) {
rtemp[0] = wnorm;
rtemp[1] = *rnorm;
dvout_(&debug_1.logfil, &c__2, rtemp, &debug_1.ndigit, "_naitr: re-o"
"rthogonalization; wnorm and rnorm are", (ftnlen)49);
zvout_(&debug_1.logfil, &j, &h__[j * h_dim1 + 1], &debug_1.ndigit,
"_naitr: j-th column of H", (ftnlen)24);
}
/* %----------------------------------------------------% */
/* | Compute V_{j}^T * B * r_{j}. | */
/* | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | */
/* %----------------------------------------------------% */
zgemv_("C", n, &j, &c_b1, &v[v_offset], ldv, &workd[ipj], &c__1, &c_b2, &
workd[irj], &c__1, (ftnlen)1);
/* %---------------------------------------------% */
/* | Compute the correction to the residual: | */
/* | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | */
/* | The correction to H is v(:,1:J)*H(1:J,1:J) | */
/* | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. | */
/* %---------------------------------------------% */
z__1.r = -1., z__1.i = -0.;
zgemv_("N", n, &j, &z__1, &v[v_offset], ldv, &workd[irj], &c__1, &c_b1, &
resid[1], &c__1, (ftnlen)1);
zaxpy_(&j, &c_b1, &workd[irj], &c__1, &h__[j * h_dim1 + 1], &c__1);
orth2 = TRUE_;
second_(&t2);
if (*(unsigned char *)bmat == 'G') {
++timing_1.nbx;
zcopy_(n, &resid[1], &c__1, &workd[irj], &c__1);
ipntr[1] = irj;
ipntr[2] = ipj;
*ido = 2;
/* %-----------------------------------% */
/* | Exit in order to compute B*r_{j}. | */
/* | r_{j} is the corrected residual. | */
/* %-----------------------------------% */
goto L9000;
} else if (*(unsigned char *)bmat == 'I') {
zcopy_(n, &resid[1], &c__1, &workd[ipj], &c__1);
}
L90:
/* %---------------------------------------------------% */
/* | Back from reverse communication if ORTH2 = .true. | */
/* %---------------------------------------------------% */
if (*(unsigned char *)bmat == 'G') {
second_(&t3);
timing_1.tmvbx += t3 - t2;
}
/* %-----------------------------------------------------% */
/* | Compute the B-norm of the corrected residual r_{j}. | */
/* %-----------------------------------------------------% */
if (*(unsigned char *)bmat == 'G') {
zdotc_(&z__1, n, &resid[1], &c__1, &workd[ipj], &c__1);
cnorm.r = z__1.r, cnorm.i = z__1.i;
d__1 = cnorm.r;
d__2 = d_imag(&cnorm);
rnorm1 = sqrt(dlapy2_(&d__1, &d__2));
} else if (*(unsigned char *)bmat == 'I') {
rnorm1 = dznrm2_(n, &resid[1], &c__1);
}
if (msglvl > 0 && iter > 0) {
ivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: Iterati"
"ve refinement for Arnoldi residual", (ftnlen)49);
if (msglvl > 2) {
rtemp[0] = *rnorm;
rtemp[1] = rnorm1;
dvout_(&debug_1.logfil, &c__2, rtemp, &debug_1.ndigit, "_naitr: "
"iterative refinement ; rnorm and rnorm1 are", (ftnlen)51);
}
}
/* %-----------------------------------------% */
/* | Determine if we need to perform another | */
/* | step of re-orthogonalization. | */
/* %-----------------------------------------% */
if (rnorm1 > *rnorm * .717f) {
/* %---------------------------------------% */
/* | No need for further refinement. | */
/* | The cosine of the angle between the | */
/* | corrected residual vector and the old | */
/* | residual vector is greater than 0.717 | */
/* | In other words the corrected residual | */
/* | and the old residual vector share an | */
/* | angle of less than arcCOS(0.717) | */
/* %---------------------------------------% */
*rnorm = rnorm1;
} else {
/* %-------------------------------------------% */
/* | Another step of iterative refinement step | */
/* | is required. NITREF is used by stat.h | */
/* %-------------------------------------------% */
++timing_1.nitref;
*rnorm = rnorm1;
++iter;
if (iter <= 1) {
goto L80;
}
/* %-------------------------------------------------% */
/* | Otherwise RESID is numerically in the span of V | */
/* %-------------------------------------------------% */
i__1 = *n;
for (jj = 1; jj <= i__1; ++jj) {
i__2 = jj;
resid[i__2].r = 0., resid[i__2].i = 0.;
/* L95: */
}
*rnorm = 0.;
}
/* %----------------------------------------------% */
/* | Branch here directly if iterative refinement | */
/* | wasn't necessary or after at most NITER_REF | */
/* | steps of iterative refinement. | */
/* %----------------------------------------------% */
L100:
rstart = FALSE_;
orth2 = FALSE_;
second_(&t5);
timing_1.titref += t5 - t4;
/* %------------------------------------% */
/* | STEP 6: Update j = j+1; Continue | */
/* %------------------------------------% */
++j;
if (j > *k + *np) {
second_(&t1);
timing_1.tcaitr += t1 - t0;
*ido = 99;
i__1 = *k + *np - 1;
for (i__ = max(1,*k); i__ <= i__1; ++i__) {
/* %--------------------------------------------% */
/* | Check for splitting and deflation. | */
/* | Use a standard test as in the QR algorithm | */
/* | REFERENCE: LAPACK subroutine zlahqr | */
/* %--------------------------------------------% */
i__2 = i__ + i__ * h_dim1;
d__1 = h__[i__2].r;
d__2 = d_imag(&h__[i__ + i__ * h_dim1]);
i__3 = i__ + 1 + (i__ + 1) * h_dim1;
d__3 = h__[i__3].r;
d__4 = d_imag(&h__[i__ + 1 + (i__ + 1) * h_dim1]);
tst1 = dlapy2_(&d__1, &d__2) + dlapy2_(&d__3, &d__4);
if (tst1 == 0.) {
i__2 = *k + *np;
tst1 = zlanhs_("1", &i__2, &h__[h_offset], ldh, &workd[*n + 1]
, (ftnlen)1);
}
i__2 = i__ + 1 + i__ * h_dim1;
d__1 = h__[i__2].r;
d__2 = d_imag(&h__[i__ + 1 + i__ * h_dim1]);
/* Computing MAX */
d__3 = ulp * tst1;
if (dlapy2_(&d__1, &d__2) <= max(d__3,smlnum)) {
i__3 = i__ + 1 + i__ * h_dim1;
h__[i__3].r = 0., h__[i__3].i = 0.;
}
/* L110: */
}
if (msglvl > 2) {
i__1 = *k + *np;
i__2 = *k + *np;
zmout_(&debug_1.logfil, &i__1, &i__2, &h__[h_offset], ldh, &
debug_1.ndigit, "_naitr: Final upper Hessenberg matrix H"
" of order K+NP", (ftnlen)53);
}
goto L9000;
}
/* %--------------------------------------------------------% */
/* | Loop back to extend the factorization by another step. | */
/* %--------------------------------------------------------% */
goto L1000;
/* %---------------------------------------------------------------% */
/* | | */
/* | E N D O F M A I N I T E R A T I O N L O O P | */
/* | | */
/* %---------------------------------------------------------------% */
L9000:
return 0;
/* %---------------% */
/* | End of znaitr | */
/* %---------------% */
} /* znaitr_ */
/* Subroutine */ int zlatrs_(char *uplo, char *trans, char *diag, char *
normin, integer *n, doublecomplex *a, integer *lda, doublecomplex *x,
doublereal *scale, doublereal *cnorm, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4;
/* Local variables */
integer i__, j;
doublereal xj, rec, tjj;
integer jinc;
doublereal xbnd;
integer imax;
doublereal tmax;
doublecomplex tjjs;
doublereal xmax, grow;
doublereal tscal;
doublecomplex uscal;
integer jlast;
doublecomplex csumj;
logical upper;
doublereal bignum;
logical notran;
integer jfirst;
doublereal smlnum;
logical nounit;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* ZLATRS solves one of the triangular systems */
/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b, */
/* with scaling to prevent overflow. Here A is an upper or lower */
/* triangular matrix, A**T denotes the transpose of A, A**H denotes the */
/* conjugate transpose of A, x and b are n-element vectors, and s is a */
/* scaling factor, usually less than or equal to 1, chosen so that the */
/* components of x will be less than the overflow threshold. If the */
/* unscaled problem will not cause overflow, the Level 2 BLAS routine */
/* ZTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j), */
/* then s is set to 0 and a non-trivial solution to A*x = 0 is returned. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Specifies the operation applied to A. */
/* = 'N': Solve A * x = s*b (No transpose) */
/* = 'T': Solve A**T * x = s*b (Transpose) */
/* = 'C': Solve A**H * x = s*b (Conjugate transpose) */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* NORMIN (input) CHARACTER*1 */
/* Specifies whether CNORM has been set or not. */
/* = 'Y': CNORM contains the column norms on entry */
/* = 'N': CNORM is not set on entry. On exit, the norms will */
/* be computed and stored in CNORM. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The triangular matrix A. If UPLO = 'U', the leading n by n */
/* upper triangular part of the array A contains the upper */
/* triangular matrix, and the strictly lower triangular part of */
/* A is not referenced. If UPLO = 'L', the leading n by n lower */
/* triangular part of the array A contains the lower triangular */
/* matrix, and the strictly upper triangular part of A is not */
/* referenced. If DIAG = 'U', the diagonal elements of A are */
/* also not referenced and are assumed to be 1. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max (1,N). */
/* X (input/output) COMPLEX*16 array, dimension (N) */
/* On entry, the right hand side b of the triangular system. */
/* On exit, X is overwritten by the solution vector x. */
/* SCALE (output) DOUBLE PRECISION */
/* The scaling factor s for the triangular system */
/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b. */
/* If SCALE = 0, the matrix A is singular or badly scaled, and */
/* the vector x is an exact or approximate solution to A*x = 0. */
/* CNORM (input or output) DOUBLE PRECISION array, dimension (N) */
/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */
/* contains the norm of the off-diagonal part of the j-th column */
/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */
/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */
/* must be greater than or equal to the 1-norm. */
/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */
/* returns the 1-norm of the offdiagonal part of the j-th column */
/* of A. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* Further Details */
/* ======= ======= */
/* A rough bound on x is computed; if that is less than overflow, ZTRSV */
/* is called, otherwise, specific code is used which checks for possible */
/* overflow or divide-by-zero at every operation. */
/* A columnwise scheme is used for solving A*x = b. The basic algorithm */
/* if A is lower triangular is */
/* x[1:n] := b[1:n] */
/* x(j) := x(j) / A(j,j) */
/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */
/* end */
/* Define bounds on the components of x after j iterations of the loop: */
/* M(j) = bound on x[1:j] */
/* G(j) = bound on x[j+1:n] */
/* Then for iteration j+1 we have */
/* M(j+1) <= G(j) / | A(j+1,j+1) | */
/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */
/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */
/* where CNORM(j+1) is greater than or equal to the infinity-norm of */
/* column j+1 of A, not counting the diagonal. Hence */
/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */
/* 1<=i<=j */
/* and */
/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */
/* 1<=i< j */
/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTRSV if the */
/* max(underflow, 1/overflow). */
/* The bound on x(j) is also used to determine when a step in the */
/* columnwise method can be performed without fear of overflow. If */
/* the computed bound is greater than a large constant, x is scaled to */
/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */
/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */
/* Similarly, a row-wise scheme is used to solve A**T *x = b or */
/* A**H *x = b. The basic algorithm for A upper triangular is */
/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */
/* end */
/* We simultaneously compute two bounds */
/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */
/* M(j) = bound on x(i), 1<=i<=j */
/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */
/* Then the bound on x(j) is */
/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */
/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */
/* 1<=i<=j */
/* and we can safely call ZTRSV if 1/M(n) and 1/G(n) are both greater */
/* than max(underflow, 1/overflow). */
/* ===================================================================== */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--x;
--cnorm;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
/* Test the input parameters. */
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && !
lsame_(trans, "C")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (! lsame_(normin, "Y") && ! lsame_(normin,
"N")) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZLATRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine machine dependent parameters to control overflow. */
smlnum = dlamch_("Safe minimum");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum /= dlamch_("Precision");
bignum = 1. / smlnum;
*scale = 1.;
if (lsame_(normin, "N")) {
/* Compute the 1-norm of each column, not including the diagonal. */
if (upper) {
/* A is upper triangular. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
cnorm[j] = dzasum_(&i__2, &a[j * a_dim1 + 1], &c__1);
}
} else {
/* A is lower triangular. */
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j;
cnorm[j] = dzasum_(&i__2, &a[j + 1 + j * a_dim1], &c__1);
}
cnorm[*n] = 0.;
}
}
/* Scale the column norms by TSCAL if the maximum element in CNORM is */
/* greater than BIGNUM/2. */
imax = idamax_(n, &cnorm[1], &c__1);
tmax = cnorm[imax];
if (tmax <= bignum * .5) {
tscal = 1.;
} else {
tscal = .5 / (smlnum * tmax);
dscal_(n, &tscal, &cnorm[1], &c__1);
}
/* Compute a bound on the computed solution vector to see if the */
/* Level 2 BLAS routine ZTRSV can be used. */
xmax = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = j;
d__3 = xmax, d__4 = (d__1 = x[i__2].r / 2., abs(d__1)) + (d__2 =
d_imag(&x[j]) / 2., abs(d__2));
xmax = max(d__3,d__4);
}
xbnd = xmax;
if (notran) {
/* Compute the growth in A * x = b. */
if (upper) {
jfirst = *n;
jlast = 1;
jinc = -1;
} else {
jfirst = 1;
jlast = *n;
jinc = 1;
}
if (tscal != 1.) {
grow = 0.;
goto L60;
}
if (nounit) {
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
grow = .5 / max(xbnd,smlnum);
xbnd = grow;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L60;
}
i__3 = j + j * a_dim1;
tjjs.r = a[i__3].r, tjjs.i = a[i__3].i;
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
d__2));
if (tjj >= smlnum) {
/* M(j) = G(j-1) / abs(A(j,j)) */
/* Computing MIN */
d__1 = xbnd, d__2 = min(1.,tjj) * grow;
xbnd = min(d__1,d__2);
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.;
}
if (tjj + cnorm[j] >= smlnum) {
/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */
grow *= tjj / (tjj + cnorm[j]);
} else {
/* G(j) could overflow, set GROW to 0. */
grow = 0.;
}
}
grow = xbnd;
} else {
/* A is unit triangular. */
/* Computing MIN */
d__1 = 1., d__2 = .5 / max(xbnd,smlnum);
grow = min(d__1,d__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L60;
}
/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
grow *= 1. / (cnorm[j] + 1.);
}
}
L60:
;
} else {
/* Compute the growth in A**T * x = b or A**H * x = b. */
if (upper) {
jfirst = 1;
jlast = *n;
jinc = 1;
} else {
jfirst = *n;
jlast = 1;
jinc = -1;
}
if (tscal != 1.) {
grow = 0.;
goto L90;
}
if (nounit) {
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
grow = .5 / max(xbnd,smlnum);
xbnd = grow;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L90;
}
/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
xj = cnorm[j] + 1.;
/* Computing MIN */
d__1 = grow, d__2 = xbnd / xj;
grow = min(d__1,d__2);
i__3 = j + j * a_dim1;
tjjs.r = a[i__3].r, tjjs.i = a[i__3].i;
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
d__2));
if (tjj >= smlnum) {
/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
if (xj > tjj) {
xbnd *= tjj / xj;
}
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.;
}
}
grow = min(grow,xbnd);
} else {
/* A is unit triangular. */
/* Computing MIN */
d__1 = 1., d__2 = .5 / max(xbnd,smlnum);
grow = min(d__1,d__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L90;
}
/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
xj = cnorm[j] + 1.;
grow /= xj;
}
}
L90:
;
}
if (grow * tscal > smlnum) {
/* Use the Level 2 BLAS solve if the reciprocal of the bound on */
/* elements of X is not too small. */
ztrsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1);
} else {
/* Use a Level 1 BLAS solve, scaling intermediate results. */
if (xmax > bignum * .5) {
/* Scale X so that its components are less than or equal to */
/* BIGNUM in absolute value. */
*scale = bignum * .5 / xmax;
zdscal_(n, scale, &x[1], &c__1);
xmax = bignum;
} else {
xmax *= 2.;
}
if (notran) {
/* Solve A * x = b */
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]),
abs(d__2));
if (nounit) {
i__3 = j + j * a_dim1;
z__1.r = tscal * a[i__3].r, z__1.i = tscal * a[i__3].i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
if (tscal == 1.) {
goto L110;
}
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
d__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale x by 1/b(j). */
rec = 1. / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
, abs(d__2));
} else if (tjj > 0.) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */
/* to avoid overflow when dividing by A(j,j). */
rec = tjj * bignum / xj;
if (cnorm[j] > 1.) {
/* Scale by 1/CNORM(j) to avoid overflow when */
/* multiplying x(j) times column j. */
rec /= cnorm[j];
}
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
, abs(d__2));
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0, and compute a solution to A*x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0., x[i__4].i = 0.;
}
i__3 = j;
x[i__3].r = 1., x[i__3].i = 0.;
xj = 1.;
*scale = 0.;
xmax = 0.;
}
L110:
/* Scale x if necessary to avoid overflow when adding a */
/* multiple of column j of A. */
if (xj > 1.) {
rec = 1. / xj;
if (cnorm[j] > (bignum - xmax) * rec) {
/* Scale x by 1/(2*abs(x(j))). */
rec *= .5;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
} else if (xj * cnorm[j] > bignum - xmax) {
/* Scale x by 1/2. */
zdscal_(n, &c_b36, &x[1], &c__1);
*scale *= .5;
}
if (upper) {
if (j > 1) {
/* Compute the update */
/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */
i__3 = j - 1;
i__4 = j;
z__2.r = -x[i__4].r, z__2.i = -x[i__4].i;
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
zaxpy_(&i__3, &z__1, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
i__3 = j - 1;
i__ = izamax_(&i__3, &x[1], &c__1);
i__3 = i__;
xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
&x[i__]), abs(d__2));
}
} else {
if (j < *n) {
/* Compute the update */
/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */
i__3 = *n - j;
i__4 = j;
z__2.r = -x[i__4].r, z__2.i = -x[i__4].i;
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
zaxpy_(&i__3, &z__1, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
i__3 = *n - j;
i__ = j + izamax_(&i__3, &x[j + 1], &c__1);
i__3 = i__;
xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
&x[i__]), abs(d__2));
}
}
}
} else if (lsame_(trans, "T")) {
/* Solve A**T * x = b */
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
/* k<>j */
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]),
abs(d__2));
uscal.r = tscal, uscal.i = 0.;
rec = 1. / max(xmax,1.);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5;
if (nounit) {
i__3 = j + j * a_dim1;
z__1.r = tscal * a[i__3].r, z__1.i = tscal * a[i__3]
.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > 1.) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
d__1 = 1., d__2 = rec * tjj;
rec = min(d__1,d__2);
zladiv_(&z__1, &uscal, &tjjs);
uscal.r = z__1.r, uscal.i = z__1.i;
}
if (rec < 1.) {
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0., csumj.i = 0.;
if (uscal.r == 1. && uscal.i == 0.) {
/* If the scaling needed for A in the dot product is 1, */
/* call ZDOTU to perform the dot product. */
if (upper) {
i__3 = j - 1;
zdotu_(&z__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
} else if (j < *n) {
i__3 = *n - j;
zdotu_(&z__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
}
} else {
/* Otherwise, use in-line code for the dot product. */
if (upper) {
i__3 = j - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * a_dim1;
z__3.r = a[i__4].r * uscal.r - a[i__4].i *
uscal.i, z__3.i = a[i__4].r * uscal.i + a[
i__4].i * uscal.r;
i__5 = i__;
z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i,
z__2.i = z__3.r * x[i__5].i + z__3.i * x[
i__5].r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
}
} else if (j < *n) {
i__3 = *n;
for (i__ = j + 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * a_dim1;
z__3.r = a[i__4].r * uscal.r - a[i__4].i *
uscal.i, z__3.i = a[i__4].r * uscal.i + a[
i__4].i * uscal.r;
i__5 = i__;
z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i,
z__2.i = z__3.r * x[i__5].i + z__3.i * x[
i__5].r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
}
}
}
z__1.r = tscal, z__1.i = 0.;
if (uscal.r == z__1.r && uscal.i == z__1.i) {
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
/* was not used to scale the dotproduct. */
i__3 = j;
i__4 = j;
z__1.r = x[i__4].r - csumj.r, z__1.i = x[i__4].i -
csumj.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
, abs(d__2));
if (nounit) {
i__3 = j + j * a_dim1;
z__1.r = tscal * a[i__3].r, z__1.i = tscal * a[i__3]
.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
if (tscal == 1.) {
goto L160;
}
}
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale X by 1/abs(x(j)). */
rec = 1. / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
} else if (tjj > 0.) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0 and compute a solution to A**T *x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0., x[i__4].i = 0.;
}
i__3 = j;
x[i__3].r = 1., x[i__3].i = 0.;
*scale = 0.;
xmax = 0.;
}
L160:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
/* product has already been divided by 1/A(j,j). */
i__3 = j;
zladiv_(&z__2, &x[j], &tjjs);
z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
}
/* Computing MAX */
i__3 = j;
d__3 = xmax, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
d_imag(&x[j]), abs(d__2));
xmax = max(d__3,d__4);
}
} else {
/* Solve A**H * x = b */
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
/* k<>j */
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]),
abs(d__2));
uscal.r = tscal, uscal.i = 0.;
rec = 1. / max(xmax,1.);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5;
if (nounit) {
d_cnjg(&z__2, &a[j + j * a_dim1]);
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > 1.) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
d__1 = 1., d__2 = rec * tjj;
rec = min(d__1,d__2);
zladiv_(&z__1, &uscal, &tjjs);
uscal.r = z__1.r, uscal.i = z__1.i;
}
if (rec < 1.) {
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0., csumj.i = 0.;
if (uscal.r == 1. && uscal.i == 0.) {
/* If the scaling needed for A in the dot product is 1, */
/* call ZDOTC to perform the dot product. */
if (upper) {
i__3 = j - 1;
zdotc_(&z__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
} else if (j < *n) {
i__3 = *n - j;
zdotc_(&z__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
}
} else {
/* Otherwise, use in-line code for the dot product. */
if (upper) {
i__3 = j - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
d_cnjg(&z__4, &a[i__ + j * a_dim1]);
z__3.r = z__4.r * uscal.r - z__4.i * uscal.i,
z__3.i = z__4.r * uscal.i + z__4.i *
uscal.r;
i__4 = i__;
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i,
z__2.i = z__3.r * x[i__4].i + z__3.i * x[
i__4].r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
}
} else if (j < *n) {
i__3 = *n;
for (i__ = j + 1; i__ <= i__3; ++i__) {
d_cnjg(&z__4, &a[i__ + j * a_dim1]);
z__3.r = z__4.r * uscal.r - z__4.i * uscal.i,
z__3.i = z__4.r * uscal.i + z__4.i *
uscal.r;
i__4 = i__;
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i,
z__2.i = z__3.r * x[i__4].i + z__3.i * x[
i__4].r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
}
}
}
z__1.r = tscal, z__1.i = 0.;
if (uscal.r == z__1.r && uscal.i == z__1.i) {
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
/* was not used to scale the dotproduct. */
i__3 = j;
i__4 = j;
z__1.r = x[i__4].r - csumj.r, z__1.i = x[i__4].i -
csumj.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
, abs(d__2));
if (nounit) {
d_cnjg(&z__2, &a[j + j * a_dim1]);
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
if (tscal == 1.) {
goto L210;
}
}
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale X by 1/abs(x(j)). */
rec = 1. / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
} else if (tjj > 0.) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0 and compute a solution to A**H *x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0., x[i__4].i = 0.;
}
i__3 = j;
x[i__3].r = 1., x[i__3].i = 0.;
*scale = 0.;
xmax = 0.;
}
L210:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
/* product has already been divided by 1/A(j,j). */
i__3 = j;
zladiv_(&z__2, &x[j], &tjjs);
z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
}
/* Computing MAX */
i__3 = j;
d__3 = xmax, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
d_imag(&x[j]), abs(d__2));
xmax = max(d__3,d__4);
}
}
*scale /= tscal;
}
/* Scale the column norms by 1/TSCAL for return. */
if (tscal != 1.) {
d__1 = 1. / tscal;
dscal_(n, &d__1, &cnorm[1], &c__1);
}
return 0;
/* End of ZLATRS */
} /* zlatrs_ */
/* Subroutine */ int zlauu2_(char *uplo, integer *n, doublecomplex *a,
integer *lda, integer *info)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZLAUU2 computes the product U * U' or L' * L, where the triangular
factor U or L is stored in the upper or lower triangular part of
the array A.
If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
overwriting the factor U in A.
If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
overwriting the factor L in A.
This is the unblocked form of the algorithm, calling Level 2 BLAS.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the triangular factor stored in the array A
is upper or lower triangular:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the triangular factor U or L. N >= 0.
A (input/output) COMPLEX*16 array, dimension (LDA,N)
On entry, the triangular factor U or L.
On exit, if UPLO = 'U', the upper triangle of A is
overwritten with the upper triangle of the product U * U';
if UPLO = 'L', the lower triangle of A is overwritten with
the lower triangle of the product L' * L.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -k, the k-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b1 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1;
/* Local variables */
static integer i__;
extern logical lsame_(char *, char *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static logical upper;
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *), zlacgv_(
integer *, doublecomplex *, integer *);
static doublereal aii;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZLAUU2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (upper) {
/* Compute the product U * U'. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = a_subscr(i__, i__);
aii = a[i__2].r;
if (i__ < *n) {
i__2 = a_subscr(i__, i__);
i__3 = *n - i__;
zdotc_(&z__1, &i__3, &a_ref(i__, i__ + 1), lda, &a_ref(i__,
i__ + 1), lda);
d__1 = aii * aii + z__1.r;
a[i__2].r = d__1, a[i__2].i = 0.;
i__2 = *n - i__;
zlacgv_(&i__2, &a_ref(i__, i__ + 1), lda);
i__2 = i__ - 1;
i__3 = *n - i__;
z__1.r = aii, z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &c_b1, &a_ref(1, i__ + 1)
, lda, &a_ref(i__, i__ + 1), lda, &z__1, &a_ref(1,
i__), &c__1);
i__2 = *n - i__;
zlacgv_(&i__2, &a_ref(i__, i__ + 1), lda);
} else {
zdscal_(&i__, &aii, &a_ref(1, i__), &c__1);
}
/* L10: */
}
} else {
/* Compute the product L' * L. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = a_subscr(i__, i__);
aii = a[i__2].r;
if (i__ < *n) {
i__2 = a_subscr(i__, i__);
i__3 = *n - i__;
zdotc_(&z__1, &i__3, &a_ref(i__ + 1, i__), &c__1, &a_ref(i__
+ 1, i__), &c__1);
d__1 = aii * aii + z__1.r;
a[i__2].r = d__1, a[i__2].i = 0.;
i__2 = i__ - 1;
zlacgv_(&i__2, &a_ref(i__, 1), lda);
i__2 = *n - i__;
i__3 = i__ - 1;
z__1.r = aii, z__1.i = 0.;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b1, &a_ref(i__
+ 1, 1), lda, &a_ref(i__ + 1, i__), &c__1, &z__1, &
a_ref(i__, 1), lda);
i__2 = i__ - 1;
zlacgv_(&i__2, &a_ref(i__, 1), lda);
} else {
zdscal_(&i__, &aii, &a_ref(i__, 1), lda);
}
/* L20: */
}
}
return 0;
/* End of ZLAUU2 */
} /* zlauu2_ */
void zdscal( int n, double alpha, doublecomplex *x, int incx)
{
zdscal_(&n, &alpha, x, &incx);
}
/* Subroutine */ int zhpevx_(char *jobz, char *range, char *uplo, integer *n,
doublecomplex *ap, doublereal *vl, doublereal *vu, integer *il,
integer *iu, doublereal *abstol, integer *m, doublereal *w,
doublecomplex *z__, integer *ldz, doublecomplex *work, doublereal *
rwork, integer *iwork, integer *ifail, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, jj;
doublereal eps, vll, vuu, tmp1;
integer indd, inde;
doublereal anrm;
integer imax;
doublereal rmin, rmax;
logical test;
integer itmp1, indee;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
doublereal sigma;
extern logical lsame_(char *, char *);
integer iinfo;
char order[1];
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
logical wantz;
extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *);
logical alleig, indeig;
integer iscale, indibl;
logical valeig;
doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *);
doublereal abstll, bignum;
integer indiwk, indisp, indtau;
extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
integer *), dstebz_(char *, char *, integer *, doublereal *,
doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *);
extern doublereal zlanhp_(char *, char *, integer *, doublecomplex *,
doublereal *);
integer indrwk, indwrk, nsplit;
doublereal smlnum;
extern /* Subroutine */ int zhptrd_(char *, integer *, doublecomplex *,
doublereal *, doublereal *, doublecomplex *, integer *),
zstein_(integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *, doublecomplex *, integer *,
doublereal *, integer *, integer *, integer *), zsteqr_(char *,
integer *, doublereal *, doublereal *, doublecomplex *, integer *,
doublereal *, integer *), zupgtr_(char *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *), zupmtr_(char *, char *, char
*, integer *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZHPEVX computes selected eigenvalues and, optionally, eigenvectors */
/* of a complex Hermitian matrix A in packed storage. */
/* Eigenvalues/vectors can be selected by specifying either a range of */
/* values or a range of indices for the desired eigenvalues. */
/* Arguments */
/* ========= */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* RANGE (input) CHARACTER*1 */
/* = 'A': all eigenvalues will be found; */
/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
/* will be found; */
/* = 'I': the IL-th through IU-th eigenvalues will be found. */
/* 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 Hermitian matrix */
/* A, packed columnwise in a linear array. The j-th column of A */
/* is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
/* On exit, AP is overwritten by values generated during the */
/* reduction to tridiagonal form. If UPLO = 'U', the diagonal */
/* and first superdiagonal of the tridiagonal matrix T overwrite */
/* the corresponding elements of A, and if UPLO = 'L', the */
/* diagonal and first subdiagonal of T overwrite the */
/* corresponding elements of A. */
/* VL (input) DOUBLE PRECISION */
/* VU (input) DOUBLE PRECISION */
/* If RANGE='V', the lower and upper bounds of the interval to */
/* be searched for eigenvalues. VL < VU. */
/* Not referenced if RANGE = 'A' or 'I'. */
/* IL (input) INTEGER */
/* IU (input) INTEGER */
/* If RANGE='I', the indices (in ascending order) of the */
/* smallest and largest eigenvalues to be returned. */
/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
/* Not referenced if RANGE = 'A' or 'V'. */
/* ABSTOL (input) DOUBLE PRECISION */
/* The absolute error tolerance for the eigenvalues. */
/* An approximate eigenvalue is accepted as converged */
/* when it is determined to lie in an interval [a,b] */
/* of width less than or equal to */
/* ABSTOL + EPS * max( |a|,|b| ) , */
/* where EPS is the machine precision. If ABSTOL is less than */
/* or equal to zero, then EPS*|T| will be used in its place, */
/* where |T| is the 1-norm of the tridiagonal matrix obtained */
/* by reducing AP to tridiagonal form. */
/* Eigenvalues will be computed most accurately when ABSTOL is */
/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */
/* If this routine returns with INFO>0, indicating that some */
/* eigenvectors did not converge, try setting ABSTOL to */
/* 2*DLAMCH('S'). */
/* See "Computing Small Singular Values of Bidiagonal Matrices */
/* with Guaranteed High Relative Accuracy," by Demmel and */
/* Kahan, LAPACK Working Note #3. */
/* M (output) INTEGER */
/* The total number of eigenvalues found. 0 <= M <= N. */
/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
/* W (output) DOUBLE PRECISION array, dimension (N) */
/* If INFO = 0, the selected eigenvalues in ascending order. */
/* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M)) */
/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
/* contain the orthonormal eigenvectors of the matrix A */
/* corresponding to the selected eigenvalues, with the i-th */
/* column of Z holding the eigenvector associated with W(i). */
/* If an eigenvector fails to converge, then that column of Z */
/* contains the latest approximation to the eigenvector, and */
/* the index of the eigenvector is returned in IFAIL. */
/* If JOBZ = 'N', then Z is not referenced. */
/* Note: the user must ensure that at least max(1,M) columns are */
/* supplied in the array Z; if RANGE = 'V', the exact value of M */
/* is not known in advance and an upper bound must be used. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= max(1,N). */
/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N) */
/* IWORK (workspace) INTEGER array, dimension (5*N) */
/* IFAIL (output) INTEGER array, dimension (N) */
/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
/* indices of the eigenvectors that failed to converge. */
/* If JOBZ = 'N', then IFAIL is not referenced. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, then i eigenvectors failed to converge. */
/* Their indices are stored in array IFAIL. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--rwork;
--iwork;
--ifail;
/* Function Body */
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (! (lsame_(uplo, "L") || lsame_(uplo,
"U"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else {
if (valeig) {
if (*n > 0 && *vu <= *vl) {
*info = -7;
}
} else if (indeig) {
if (*il < 1 || *il > max(1,*n)) {
*info = -8;
} else if (*iu < min(*n,*il) || *iu > *n) {
*info = -9;
}
}
}
if (*info == 0) {
if (*ldz < 1 || wantz && *ldz < *n) {
*info = -14;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHPEVX", &i__1);
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (alleig || indeig) {
*m = 1;
w[1] = ap[1].r;
} else {
if (*vl < ap[1].r && *vu >= ap[1].r) {
*m = 1;
w[1] = ap[1].r;
}
}
if (wantz) {
i__1 = z_dim1 + 1;
z__[i__1].r = 1., z__[i__1].i = 0.;
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
rmax = min(d__1,d__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
abstll = *abstol;
if (valeig) {
vll = *vl;
vuu = *vu;
} else {
vll = 0.;
vuu = 0.;
}
anrm = zlanhp_("M", uplo, n, &ap[1], &rwork[1]);
if (anrm > 0. && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
i__1 = *n * (*n + 1) / 2;
zdscal_(&i__1, &sigma, &ap[1], &c__1);
if (*abstol > 0.) {
abstll = *abstol * sigma;
}
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Call ZHPTRD to reduce Hermitian packed matrix to tridiagonal form. */
indd = 1;
inde = indd + *n;
indrwk = inde + *n;
indtau = 1;
indwrk = indtau + *n;
zhptrd_(uplo, n, &ap[1], &rwork[indd], &rwork[inde], &work[indtau], &
iinfo);
/* If all eigenvalues are desired and ABSTOL is less than or equal */
/* to zero, then call DSTERF or ZUPGTR and ZSTEQR. If this fails */
/* for some eigenvalue, then try DSTEBZ. */
test = FALSE_;
if (indeig) {
if (*il == 1 && *iu == *n) {
test = TRUE_;
}
}
if ((alleig || test) && *abstol <= 0.) {
dcopy_(n, &rwork[indd], &c__1, &w[1], &c__1);
indee = indrwk + (*n << 1);
if (! wantz) {
i__1 = *n - 1;
dcopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
dsterf_(n, &w[1], &rwork[indee], info);
} else {
zupgtr_(uplo, n, &ap[1], &work[indtau], &z__[z_offset], ldz, &
work[indwrk], &iinfo);
i__1 = *n - 1;
dcopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
zsteqr_(jobz, n, &w[1], &rwork[indee], &z__[z_offset], ldz, &
rwork[indrwk], info);
if (*info == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
ifail[i__] = 0;
/* L10: */
}
}
}
if (*info == 0) {
*m = *n;
goto L20;
}
*info = 0;
}
/* Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
indibl = 1;
indisp = indibl + *n;
indiwk = indisp + *n;
dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indd], &
rwork[inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &
rwork[indrwk], &iwork[indiwk], info);
if (wantz) {
zstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[indibl], &
iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[
indiwk], &ifail[1], info);
/* Apply unitary matrix used in reduction to tridiagonal */
/* form to eigenvectors returned by ZSTEIN. */
indwrk = indtau + *n;
zupmtr_("L", uplo, "N", n, m, &ap[1], &work[indtau], &z__[z_offset],
ldz, &work[indwrk], &iinfo);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
L20:
if (iscale == 1) {
if (*info == 0) {
imax = *m;
} else {
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__1, &w[1], &c__1);
}
/* If eigenvalues are not in order, then sort them, along with */
/* eigenvectors. */
if (wantz) {
i__1 = *m - 1;
for (j = 1; j <= i__1; ++j) {
i__ = 0;
tmp1 = w[j];
i__2 = *m;
for (jj = j + 1; jj <= i__2; ++jj) {
if (w[jj] < tmp1) {
i__ = jj;
tmp1 = w[jj];
}
/* L30: */
}
if (i__ != 0) {
itmp1 = iwork[indibl + i__ - 1];
w[i__] = w[j];
iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
w[j] = tmp1;
iwork[indibl + j - 1] = itmp1;
zswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
&c__1);
if (*info != 0) {
itmp1 = ifail[i__];
ifail[i__] = ifail[j];
ifail[j] = itmp1;
}
}
/* L40: */
}
}
return 0;
/* End of ZHPEVX */
} /* zhpevx_ */
/* 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 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_ */
int zhpev_(char *jobz, char *uplo, int *n, doublecomplex
*ap, double *w, doublecomplex *z__, int *ldz, doublecomplex *
work, double *rwork, int *info)
{
/* System generated locals */
int z_dim1, z_offset, i__1;
double d__1;
/* Builtin functions */
double sqrt(double);
/* Local variables */
double eps;
int inde;
double anrm;
int imax;
double rmin, rmax;
extern int dscal_(int *, double *, double *,
int *);
double sigma;
extern int lsame_(char *, char *);
int iinfo;
int wantz;
extern double dlamch_(char *);
int iscale;
double safmin;
extern int xerbla_(char *, int *), zdscal_(
int *, double *, doublecomplex *, int *);
double bignum;
int indtau;
extern int dsterf_(int *, double *, double *,
int *);
extern double zlanhp_(char *, char *, int *, doublecomplex *,
double *);
int indrwk, indwrk;
double smlnum;
extern int zhptrd_(char *, int *, doublecomplex *,
double *, double *, doublecomplex *, int *),
zsteqr_(char *, int *, double *, double *,
doublecomplex *, int *, double *, int *),
zupgtr_(char *, int *, doublecomplex *, doublecomplex *,
doublecomplex *, int *, doublecomplex *, int *);
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZHPEV computes all the eigenvalues and, optionally, eigenvectors of a */
/* complex Hermitian matrix in packed storage. */
/* Arguments */
/* ========= */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* 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 Hermitian matrix */
/* A, packed columnwise in a linear array. The j-th column of A */
/* is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
/* On exit, AP is overwritten by values generated during the */
/* reduction to tridiagonal form. If UPLO = 'U', the diagonal */
/* and first superdiagonal of the tridiagonal matrix T overwrite */
/* the corresponding elements of A, and if UPLO = 'L', the */
/* diagonal and first subdiagonal of T overwrite the */
/* corresponding elements of A. */
/* W (output) DOUBLE PRECISION array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* Z (output) COMPLEX*16 array, dimension (LDZ, N) */
/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
/* eigenvectors of the matrix A, with the i-th column of Z */
/* holding the eigenvector associated with W(i). */
/* If JOBZ = 'N', then Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= MAX(1,N). */
/* WORK (workspace) COMPLEX*16 array, dimension (MAX(1, 2*N-1)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (MAX(1, 3*N-2)) */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = i, the algorithm failed to converge; i */
/* off-diagonal elements of an intermediate tridiagonal */
/* form did not converge to zero. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--rwork;
/* Function Body */
wantz = lsame_(jobz, "V");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (lsame_(uplo, "L") || lsame_(uplo,
"U"))) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHPEV ", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
w[1] = ap[1].r;
rwork[1] = 1.;
if (wantz) {
i__1 = z_dim1 + 1;
z__[i__1].r = 1., z__[i__1].i = 0.;
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
rmax = sqrt(bignum);
/* Scale matrix to allowable range, if necessary. */
anrm = zlanhp_("M", uplo, n, &ap[1], &rwork[1]);
iscale = 0;
if (anrm > 0. && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
i__1 = *n * (*n + 1) / 2;
zdscal_(&i__1, &sigma, &ap[1], &c__1);
}
/* Call ZHPTRD to reduce Hermitian packed matrix to tridiagonal form. */
inde = 1;
indtau = 1;
zhptrd_(uplo, n, &ap[1], &w[1], &rwork[inde], &work[indtau], &iinfo);
/* For eigenvalues only, call DSTERF. For eigenvectors, first call */
/* ZUPGTR to generate the orthogonal matrix, then call ZSTEQR. */
if (! wantz) {
dsterf_(n, &w[1], &rwork[inde], info);
} else {
indwrk = indtau + *n;
zupgtr_(uplo, n, &ap[1], &work[indtau], &z__[z_offset], ldz, &work[
indwrk], &iinfo);
indrwk = inde + *n;
zsteqr_(jobz, n, &w[1], &rwork[inde], &z__[z_offset], ldz, &rwork[
indrwk], info);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (iscale == 1) {
if (*info == 0) {
imax = *n;
} else {
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__1, &w[1], &c__1);
}
return 0;
/* End of ZHPEV */
} /* zhpev_ */
/* Subroutine */ int zlarrv_(integer *n, doublereal *vl, doublereal *vu,
doublereal *d__, doublereal *l, doublereal *pivmin, integer *isplit,
integer *m, integer *dol, integer *dou, doublereal *minrgp,
doublereal *rtol1, doublereal *rtol2, doublereal *w, doublereal *werr,
doublereal *wgap, integer *iblock, integer *indexw, doublereal *gers,
doublecomplex *z__, integer *ldz, integer *isuppz, doublereal *work,
integer *iwork, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1, d__2;
doublecomplex z__1;
logical L__1;
/* Builtin functions */
double log(doublereal);
/* Local variables */
integer minwsize, i__, j, k, p, q, miniwsize, ii;
doublereal gl;
integer im, in;
doublereal gu, gap, eps, tau, tol, tmp;
integer zto;
doublereal ztz;
integer iend, jblk;
doublereal lgap;
integer done;
doublereal rgap, left;
integer wend, iter;
doublereal bstw;
integer itmp1, indld;
doublereal fudge;
integer idone;
doublereal sigma;
integer iinfo, iindr;
doublereal resid;
logical eskip;
doublereal right;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
integer nclus, zfrom;
doublereal rqtol;
integer iindc1, iindc2, indin1, indin2;
logical stp2ii;
extern /* Subroutine */ int zlar1v_(integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublecomplex *,
logical *, integer *, doublereal *, doublereal *, integer *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *)
;
doublereal lambda;
extern doublereal dlamch_(char *);
integer ibegin, indeig;
logical needbs;
integer indlld;
doublereal sgndef, mingma;
extern /* Subroutine */ int dlarrb_(integer *, doublereal *, doublereal *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *);
integer oldien, oldncl, wbegin;
doublereal spdiam;
integer negcnt;
extern /* Subroutine */ int dlarrf_(integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *);
integer oldcls;
doublereal savgap;
integer ndepth;
doublereal ssigma;
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *);
logical usedbs;
integer iindwk, offset;
doublereal gaptol;
integer newcls, oldfst, indwrk, windex, oldlst;
logical usedrq;
integer newfst, newftt, parity, windmn, windpl, isupmn, newlst, zusedl;
doublereal bstres;
integer newsiz, zusedu, zusedw;
doublereal nrminv;
logical tryrqc;
integer isupmx;
doublereal rqcorr;
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLARRV computes the eigenvectors of the tridiagonal matrix */
/* T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T. */
/* The input eigenvalues should have been computed by DLARRE. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix. N >= 0. */
/* VL (input) DOUBLE PRECISION */
/* VU (input) DOUBLE PRECISION */
/* Lower and upper bounds of the interval that contains the desired */
/* eigenvalues. VL < VU. Needed to compute gaps on the left or right */
/* end of the extremal eigenvalues in the desired RANGE. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the N diagonal elements of the diagonal matrix D. */
/* On exit, D may be overwritten. */
/* L (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the (N-1) subdiagonal elements of the unit */
/* bidiagonal matrix L are in elements 1 to N-1 of L */
/* (if the matrix is not splitted.) At the end of each block */
/* is stored the corresponding shift as given by DLARRE. */
/* On exit, L is overwritten. */
/* PIVMIN (in) DOUBLE PRECISION */
/* The minimum pivot allowed in the Sturm sequence. */
/* ISPLIT (input) INTEGER array, dimension (N) */
/* The splitting points, at which T breaks up into blocks. */
/* The first block consists of rows/columns 1 to */
/* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 */
/* through ISPLIT( 2 ), etc. */
/* M (input) INTEGER */
/* The total number of input eigenvalues. 0 <= M <= N. */
/* DOL (input) INTEGER */
/* DOU (input) INTEGER */
/* If the user wants to compute only selected eigenvectors from all */
/* the eigenvalues supplied, he can specify an index range DOL:DOU. */
/* Or else the setting DOL=1, DOU=M should be applied. */
/* Note that DOL and DOU refer to the order in which the eigenvalues */
/* are stored in W. */
/* If the user wants to compute only selected eigenpairs, then */
/* the columns DOL-1 to DOU+1 of the eigenvector space Z contain the */
/* computed eigenvectors. All other columns of Z are set to zero. */
/* MINRGP (input) DOUBLE PRECISION */
/* RTOL1 (input) DOUBLE PRECISION */
/* RTOL2 (input) DOUBLE PRECISION */
/* Parameters for bisection. */
/* An interval [LEFT,RIGHT] has converged if */
/* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */
/* W (input/output) DOUBLE PRECISION array, dimension (N) */
/* The first M elements of W contain the APPROXIMATE eigenvalues for */
/* which eigenvectors are to be computed. The eigenvalues */
/* should be grouped by split-off block and ordered from */
/* smallest to largest within the block ( The output array */
/* W from DLARRE is expected here ). Furthermore, they are with */
/* respect to the shift of the corresponding root representation */
/* for their block. On exit, W holds the eigenvalues of the */
/* UNshifted matrix. */
/* WERR (input/output) DOUBLE PRECISION array, dimension (N) */
/* The first M elements contain the semiwidth of the uncertainty */
/* interval of the corresponding eigenvalue in W */
/* WGAP (input/output) DOUBLE PRECISION array, dimension (N) */
/* The separation from the right neighbor eigenvalue in W. */
/* IBLOCK (input) INTEGER array, dimension (N) */
/* The indices of the blocks (submatrices) associated with the */
/* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue */
/* W(i) belongs to the first block from the top, =2 if W(i) */
/* belongs to the second block, etc. */
/* INDEXW (input) INTEGER array, dimension (N) */
/* The indices of the eigenvalues within each block (submatrix); */
/* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the */
/* i-th eigenvalue W(i) is the 10-th eigenvalue in the second block. */
/* GERS (input) DOUBLE PRECISION array, dimension (2*N) */
/* The N Gerschgorin intervals (the i-th Gerschgorin interval */
/* is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should */
/* be computed from the original UNshifted matrix. */
/* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M) ) */
/* If INFO = 0, the first M columns of Z contain the */
/* orthonormal eigenvectors of the matrix T */
/* corresponding to the input eigenvalues, with the i-th */
/* column of Z holding the eigenvector associated with W(i). */
/* Note: the user must ensure that at least max(1,M) columns are */
/* supplied in the array Z. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= max(1,N). */
/* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) ) */
/* The support of the eigenvectors in Z, i.e., the indices */
/* indicating the nonzero elements in Z. The I-th eigenvector */
/* is nonzero only in elements ISUPPZ( 2*I-1 ) through */
/* ISUPPZ( 2*I ). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (12*N) */
/* IWORK (workspace) INTEGER array, dimension (7*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* > 0: A problem occured in ZLARRV. */
/* < 0: One of the called subroutines signaled an internal problem. */
/* Needs inspection of the corresponding parameter IINFO */
/* for further information. */
/* =-1: Problem in DLARRB when refining a child's eigenvalues. */
/* =-2: Problem in DLARRF when computing the RRR of a child. */
/* When a child is inside a tight cluster, it can be difficult */
/* to find an RRR. A partial remedy from the user's point of */
/* view is to make the parameter MINRGP smaller and recompile. */
/* However, as the orthogonality of the computed vectors is */
/* proportional to 1/MINRGP, the user should be aware that */
/* he might be trading in precision when he decreases MINRGP. */
/* =-3: Problem in DLARRB when refining a single eigenvalue */
/* after the Rayleigh correction was rejected. */
/* = 5: The Rayleigh Quotient Iteration failed to converge to */
/* full accuracy in MAXITR steps. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Beresford Parlett, University of California, Berkeley, USA */
/* Jim Demmel, University of California, Berkeley, USA */
/* Inderjit Dhillon, University of Texas, Austin, USA */
/* Osni Marques, LBNL/NERSC, USA */
/* Christof Voemel, University of California, Berkeley, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* .. */
/* The first N entries of WORK are reserved for the eigenvalues */
/* Parameter adjustments */
--d__;
--l;
--isplit;
--w;
--werr;
--wgap;
--iblock;
--indexw;
--gers;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--isuppz;
--work;
--iwork;
/* Function Body */
indld = *n + 1;
indlld = (*n << 1) + 1;
indin1 = *n * 3 + 1;
indin2 = (*n << 2) + 1;
indwrk = *n * 5 + 1;
minwsize = *n * 12;
i__1 = minwsize;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L5: */
}
/* IWORK(IINDR+1:IINDR+N) hold the twist indices R for the */
/* factorization used to compute the FP vector */
iindr = 0;
/* IWORK(IINDC1+1:IINC2+N) are used to store the clusters of the current */
/* layer and the one above. */
iindc1 = *n;
iindc2 = *n << 1;
iindwk = *n * 3 + 1;
miniwsize = *n * 7;
i__1 = miniwsize;
for (i__ = 1; i__ <= i__1; ++i__) {
iwork[i__] = 0;
/* L10: */
}
zusedl = 1;
if (*dol > 1) {
/* Set lower bound for use of Z */
zusedl = *dol - 1;
}
zusedu = *m;
if (*dou < *m) {
/* Set lower bound for use of Z */
zusedu = *dou + 1;
}
/* The width of the part of Z that is used */
zusedw = zusedu - zusedl + 1;
zlaset_("Full", n, &zusedw, &c_b1, &c_b1, &z__[zusedl * z_dim1 + 1], ldz);
eps = dlamch_("Precision");
rqtol = eps * 2.;
/* Set expert flags for standard code. */
tryrqc = TRUE_;
if (*dol == 1 && *dou == *m) {
} else {
/* Only selected eigenpairs are computed. Since the other evalues */
/* are not refined by RQ iteration, bisection has to compute to full */
/* accuracy. */
*rtol1 = eps * 4.;
*rtol2 = eps * 4.;
}
/* The entries WBEGIN:WEND in W, WERR, WGAP correspond to the */
/* desired eigenvalues. The support of the nonzero eigenvector */
/* entries is contained in the interval IBEGIN:IEND. */
/* Remark that if k eigenpairs are desired, then the eigenvectors */
/* are stored in k contiguous columns of Z. */
/* DONE is the number of eigenvectors already computed */
done = 0;
ibegin = 1;
wbegin = 1;
i__1 = iblock[*m];
for (jblk = 1; jblk <= i__1; ++jblk) {
iend = isplit[jblk];
sigma = l[iend];
/* Find the eigenvectors of the submatrix indexed IBEGIN */
/* through IEND. */
wend = wbegin - 1;
L15:
if (wend < *m) {
if (iblock[wend + 1] == jblk) {
++wend;
goto L15;
}
}
if (wend < wbegin) {
ibegin = iend + 1;
goto L170;
} else if (wend < *dol || wbegin > *dou) {
ibegin = iend + 1;
wbegin = wend + 1;
goto L170;
}
/* Find local spectral diameter of the block */
gl = gers[(ibegin << 1) - 1];
gu = gers[ibegin * 2];
i__2 = iend;
for (i__ = ibegin + 1; i__ <= i__2; ++i__) {
/* Computing MIN */
d__1 = gers[(i__ << 1) - 1];
gl = min(d__1,gl);
/* Computing MAX */
d__1 = gers[i__ * 2];
gu = max(d__1,gu);
/* L20: */
}
spdiam = gu - gl;
/* OLDIEN is the last index of the previous block */
oldien = ibegin - 1;
/* Calculate the size of the current block */
in = iend - ibegin + 1;
/* The number of eigenvalues in the current block */
im = wend - wbegin + 1;
/* This is for a 1x1 block */
if (ibegin == iend) {
++done;
i__2 = ibegin + wbegin * z_dim1;
z__[i__2].r = 1., z__[i__2].i = 0.;
isuppz[(wbegin << 1) - 1] = ibegin;
isuppz[wbegin * 2] = ibegin;
w[wbegin] += sigma;
work[wbegin] = w[wbegin];
ibegin = iend + 1;
++wbegin;
goto L170;
}
/* The desired (shifted) eigenvalues are stored in W(WBEGIN:WEND) */
/* Note that these can be approximations, in this case, the corresp. */
/* entries of WERR give the size of the uncertainty interval. */
/* The eigenvalue approximations will be refined when necessary as */
/* high relative accuracy is required for the computation of the */
/* corresponding eigenvectors. */
dcopy_(&im, &w[wbegin], &c__1, &work[wbegin], &c__1);
/* We store in W the eigenvalue approximations w.r.t. the original */
/* matrix T. */
i__2 = im;
for (i__ = 1; i__ <= i__2; ++i__) {
w[wbegin + i__ - 1] += sigma;
/* L30: */
}
/* NDEPTH is the current depth of the representation tree */
ndepth = 0;
/* PARITY is either 1 or 0 */
parity = 1;
/* NCLUS is the number of clusters for the next level of the */
/* representation tree, we start with NCLUS = 1 for the root */
nclus = 1;
iwork[iindc1 + 1] = 1;
iwork[iindc1 + 2] = im;
/* IDONE is the number of eigenvectors already computed in the current */
/* block */
idone = 0;
/* loop while( IDONE.LT.IM ) */
/* generate the representation tree for the current block and */
/* compute the eigenvectors */
L40:
if (idone < im) {
/* This is a crude protection against infinitely deep trees */
if (ndepth > *m) {
*info = -2;
return 0;
}
/* breadth first processing of the current level of the representation */
/* tree: OLDNCL = number of clusters on current level */
oldncl = nclus;
/* reset NCLUS to count the number of child clusters */
nclus = 0;
parity = 1 - parity;
if (parity == 0) {
oldcls = iindc1;
newcls = iindc2;
} else {
oldcls = iindc2;
newcls = iindc1;
}
/* Process the clusters on the current level */
i__2 = oldncl;
for (i__ = 1; i__ <= i__2; ++i__) {
j = oldcls + (i__ << 1);
/* OLDFST, OLDLST = first, last index of current cluster. */
/* cluster indices start with 1 and are relative */
/* to WBEGIN when accessing W, WGAP, WERR, Z */
oldfst = iwork[j - 1];
oldlst = iwork[j];
if (ndepth > 0) {
/* Retrieve relatively robust representation (RRR) of cluster */
/* that has been computed at the previous level */
/* The RRR is stored in Z and overwritten once the eigenvectors */
/* have been computed or when the cluster is refined */
if (*dol == 1 && *dou == *m) {
/* Get representation from location of the leftmost evalue */
/* of the cluster */
j = wbegin + oldfst - 1;
} else {
if (wbegin + oldfst - 1 < *dol) {
/* Get representation from the left end of Z array */
j = *dol - 1;
} else if (wbegin + oldfst - 1 > *dou) {
/* Get representation from the right end of Z array */
j = *dou;
} else {
j = wbegin + oldfst - 1;
}
}
i__3 = in - 1;
for (k = 1; k <= i__3; ++k) {
i__4 = ibegin + k - 1 + j * z_dim1;
d__[ibegin + k - 1] = z__[i__4].r;
i__4 = ibegin + k - 1 + (j + 1) * z_dim1;
l[ibegin + k - 1] = z__[i__4].r;
/* L45: */
}
i__3 = iend + j * z_dim1;
d__[iend] = z__[i__3].r;
i__3 = iend + (j + 1) * z_dim1;
sigma = z__[i__3].r;
/* Set the corresponding entries in Z to zero */
zlaset_("Full", &in, &c__2, &c_b1, &c_b1, &z__[ibegin + j
* z_dim1], ldz);
}
/* Compute DL and DLL of current RRR */
i__3 = iend - 1;
for (j = ibegin; j <= i__3; ++j) {
tmp = d__[j] * l[j];
work[indld - 1 + j] = tmp;
work[indlld - 1 + j] = tmp * l[j];
/* L50: */
}
if (ndepth > 0) {
/* P and Q are index of the first and last eigenvalue to compute */
/* within the current block */
p = indexw[wbegin - 1 + oldfst];
q = indexw[wbegin - 1 + oldlst];
/* Offset for the arrays WORK, WGAP and WERR, i.e., th P-OFFSET */
/* thru' Q-OFFSET elements of these arrays are to be used. */
/* OFFSET = P-OLDFST */
offset = indexw[wbegin] - 1;
/* perform limited bisection (if necessary) to get approximate */
/* eigenvalues to the precision needed. */
dlarrb_(&in, &d__[ibegin], &work[indlld + ibegin - 1], &p,
&q, rtol1, rtol2, &offset, &work[wbegin], &wgap[
wbegin], &werr[wbegin], &work[indwrk], &iwork[
iindwk], pivmin, &spdiam, &in, &iinfo);
if (iinfo != 0) {
*info = -1;
return 0;
}
/* We also recompute the extremal gaps. W holds all eigenvalues */
/* of the unshifted matrix and must be used for computation */
/* of WGAP, the entries of WORK might stem from RRRs with */
/* different shifts. The gaps from WBEGIN-1+OLDFST to */
/* WBEGIN-1+OLDLST are correctly computed in DLARRB. */
/* However, we only allow the gaps to become greater since */
/* this is what should happen when we decrease WERR */
if (oldfst > 1) {
/* Computing MAX */
d__1 = wgap[wbegin + oldfst - 2], d__2 = w[wbegin +
oldfst - 1] - werr[wbegin + oldfst - 1] - w[
wbegin + oldfst - 2] - werr[wbegin + oldfst -
2];
wgap[wbegin + oldfst - 2] = max(d__1,d__2);
}
if (wbegin + oldlst - 1 < wend) {
/* Computing MAX */
d__1 = wgap[wbegin + oldlst - 1], d__2 = w[wbegin +
oldlst] - werr[wbegin + oldlst] - w[wbegin +
oldlst - 1] - werr[wbegin + oldlst - 1];
wgap[wbegin + oldlst - 1] = max(d__1,d__2);
}
/* Each time the eigenvalues in WORK get refined, we store */
/* the newly found approximation with all shifts applied in W */
i__3 = oldlst;
for (j = oldfst; j <= i__3; ++j) {
w[wbegin + j - 1] = work[wbegin + j - 1] + sigma;
/* L53: */
}
}
/* Process the current node. */
newfst = oldfst;
i__3 = oldlst;
for (j = oldfst; j <= i__3; ++j) {
if (j == oldlst) {
/* we are at the right end of the cluster, this is also the */
/* boundary of the child cluster */
newlst = j;
} else if (wgap[wbegin + j - 1] >= *minrgp * (d__1 = work[
wbegin + j - 1], abs(d__1))) {
/* the right relative gap is big enough, the child cluster */
/* (NEWFST,..,NEWLST) is well separated from the following */
newlst = j;
} else {
/* inside a child cluster, the relative gap is not */
/* big enough. */
goto L140;
}
/* Compute size of child cluster found */
newsiz = newlst - newfst + 1;
/* NEWFTT is the place in Z where the new RRR or the computed */
/* eigenvector is to be stored */
if (*dol == 1 && *dou == *m) {
/* Store representation at location of the leftmost evalue */
/* of the cluster */
newftt = wbegin + newfst - 1;
} else {
if (wbegin + newfst - 1 < *dol) {
/* Store representation at the left end of Z array */
newftt = *dol - 1;
} else if (wbegin + newfst - 1 > *dou) {
/* Store representation at the right end of Z array */
newftt = *dou;
} else {
newftt = wbegin + newfst - 1;
}
}
if (newsiz > 1) {
/* Current child is not a singleton but a cluster. */
/* Compute and store new representation of child. */
/* Compute left and right cluster gap. */
/* LGAP and RGAP are not computed from WORK because */
/* the eigenvalue approximations may stem from RRRs */
/* different shifts. However, W hold all eigenvalues */
/* of the unshifted matrix. Still, the entries in WGAP */
/* have to be computed from WORK since the entries */
/* in W might be of the same order so that gaps are not */
/* exhibited correctly for very close eigenvalues. */
if (newfst == 1) {
/* Computing MAX */
d__1 = 0., d__2 = w[wbegin] - werr[wbegin] - *vl;
lgap = max(d__1,d__2);
} else {
lgap = wgap[wbegin + newfst - 2];
}
rgap = wgap[wbegin + newlst - 1];
/* Compute left- and rightmost eigenvalue of child */
/* to high precision in order to shift as close */
/* as possible and obtain as large relative gaps */
/* as possible */
for (k = 1; k <= 2; ++k) {
if (k == 1) {
p = indexw[wbegin - 1 + newfst];
} else {
p = indexw[wbegin - 1 + newlst];
}
offset = indexw[wbegin] - 1;
dlarrb_(&in, &d__[ibegin], &work[indlld + ibegin
- 1], &p, &p, &rqtol, &rqtol, &offset, &
work[wbegin], &wgap[wbegin], &werr[wbegin]
, &work[indwrk], &iwork[iindwk], pivmin, &
spdiam, &in, &iinfo);
/* L55: */
}
if (wbegin + newlst - 1 < *dol || wbegin + newfst - 1
> *dou) {
/* if the cluster contains no desired eigenvalues */
/* skip the computation of that branch of the rep. tree */
/* We could skip before the refinement of the extremal */
/* eigenvalues of the child, but then the representation */
/* tree could be different from the one when nothing is */
/* skipped. For this reason we skip at this place. */
idone = idone + newlst - newfst + 1;
goto L139;
}
/* Compute RRR of child cluster. */
/* Note that the new RRR is stored in Z */
/* DLARRF needs LWORK = 2*N */
dlarrf_(&in, &d__[ibegin], &l[ibegin], &work[indld +
ibegin - 1], &newfst, &newlst, &work[wbegin],
&wgap[wbegin], &werr[wbegin], &spdiam, &lgap,
&rgap, pivmin, &tau, &work[indin1], &work[
indin2], &work[indwrk], &iinfo);
/* In the complex case, DLARRF cannot write */
/* the new RRR directly into Z and needs an intermediate */
/* workspace */
i__4 = in - 1;
for (k = 1; k <= i__4; ++k) {
i__5 = ibegin + k - 1 + newftt * z_dim1;
i__6 = indin1 + k - 1;
z__1.r = work[i__6], z__1.i = 0.;
z__[i__5].r = z__1.r, z__[i__5].i = z__1.i;
i__5 = ibegin + k - 1 + (newftt + 1) * z_dim1;
i__6 = indin2 + k - 1;
z__1.r = work[i__6], z__1.i = 0.;
z__[i__5].r = z__1.r, z__[i__5].i = z__1.i;
/* L56: */
}
i__4 = iend + newftt * z_dim1;
i__5 = indin1 + in - 1;
z__1.r = work[i__5], z__1.i = 0.;
z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
if (iinfo == 0) {
/* a new RRR for the cluster was found by DLARRF */
/* update shift and store it */
ssigma = sigma + tau;
i__4 = iend + (newftt + 1) * z_dim1;
z__1.r = ssigma, z__1.i = 0.;
z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
/* WORK() are the midpoints and WERR() the semi-width */
/* Note that the entries in W are unchanged. */
i__4 = newlst;
for (k = newfst; k <= i__4; ++k) {
fudge = eps * 3. * (d__1 = work[wbegin + k -
1], abs(d__1));
work[wbegin + k - 1] -= tau;
fudge += eps * 4. * (d__1 = work[wbegin + k -
1], abs(d__1));
/* Fudge errors */
werr[wbegin + k - 1] += fudge;
/* Gaps are not fudged. Provided that WERR is small */
/* when eigenvalues are close, a zero gap indicates */
/* that a new representation is needed for resolving */
/* the cluster. A fudge could lead to a wrong decision */
/* of judging eigenvalues 'separated' which in */
/* reality are not. This could have a negative impact */
/* on the orthogonality of the computed eigenvectors. */
/* L116: */
}
++nclus;
k = newcls + (nclus << 1);
iwork[k - 1] = newfst;
iwork[k] = newlst;
} else {
*info = -2;
return 0;
}
} else {
/* Compute eigenvector of singleton */
iter = 0;
tol = log((doublereal) in) * 4. * eps;
k = newfst;
windex = wbegin + k - 1;
/* Computing MAX */
i__4 = windex - 1;
windmn = max(i__4,1);
/* Computing MIN */
i__4 = windex + 1;
windpl = min(i__4,*m);
lambda = work[windex];
++done;
/* Check if eigenvector computation is to be skipped */
if (windex < *dol || windex > *dou) {
eskip = TRUE_;
goto L125;
} else {
eskip = FALSE_;
}
left = work[windex] - werr[windex];
right = work[windex] + werr[windex];
indeig = indexw[windex];
/* Note that since we compute the eigenpairs for a child, */
/* all eigenvalue approximations are w.r.t the same shift. */
/* In this case, the entries in WORK should be used for */
/* computing the gaps since they exhibit even very small */
/* differences in the eigenvalues, as opposed to the */
/* entries in W which might "look" the same. */
if (k == 1) {
/* In the case RANGE='I' and with not much initial */
/* accuracy in LAMBDA and VL, the formula */
/* LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA ) */
/* can lead to an overestimation of the left gap and */
/* thus to inadequately early RQI 'convergence'. */
/* Prevent this by forcing a small left gap. */
/* Computing MAX */
d__1 = abs(left), d__2 = abs(right);
lgap = eps * max(d__1,d__2);
} else {
lgap = wgap[windmn];
}
if (k == im) {
/* In the case RANGE='I' and with not much initial */
/* accuracy in LAMBDA and VU, the formula */
/* can lead to an overestimation of the right gap and */
/* thus to inadequately early RQI 'convergence'. */
/* Prevent this by forcing a small right gap. */
/* Computing MAX */
d__1 = abs(left), d__2 = abs(right);
rgap = eps * max(d__1,d__2);
} else {
rgap = wgap[windex];
}
gap = min(lgap,rgap);
if (k == 1 || k == im) {
/* The eigenvector support can become wrong */
/* because significant entries could be cut off due to a */
/* large GAPTOL parameter in LAR1V. Prevent this. */
gaptol = 0.;
} else {
gaptol = gap * eps;
}
isupmn = in;
isupmx = 1;
/* Update WGAP so that it holds the minimum gap */
/* to the left or the right. This is crucial in the */
/* case where bisection is used to ensure that the */
/* eigenvalue is refined up to the required precision. */
/* The correct value is restored afterwards. */
savgap = wgap[windex];
wgap[windex] = gap;
/* We want to use the Rayleigh Quotient Correction */
/* as often as possible since it converges quadratically */
/* when we are close enough to the desired eigenvalue. */
/* However, the Rayleigh Quotient can have the wrong sign */
/* and lead us away from the desired eigenvalue. In this */
/* case, the best we can do is to use bisection. */
usedbs = FALSE_;
usedrq = FALSE_;
/* Bisection is initially turned off unless it is forced */
needbs = ! tryrqc;
L120:
/* Check if bisection should be used to refine eigenvalue */
if (needbs) {
/* Take the bisection as new iterate */
usedbs = TRUE_;
itmp1 = iwork[iindr + windex];
offset = indexw[wbegin] - 1;
d__1 = eps * 2.;
dlarrb_(&in, &d__[ibegin], &work[indlld + ibegin
- 1], &indeig, &indeig, &c_b28, &d__1, &
offset, &work[wbegin], &wgap[wbegin], &
werr[wbegin], &work[indwrk], &iwork[
iindwk], pivmin, &spdiam, &itmp1, &iinfo);
if (iinfo != 0) {
*info = -3;
return 0;
}
lambda = work[windex];
/* Reset twist index from inaccurate LAMBDA to */
/* force computation of true MINGMA */
iwork[iindr + windex] = 0;
}
/* Given LAMBDA, compute the eigenvector. */
L__1 = ! usedbs;
zlar1v_(&in, &c__1, &in, &lambda, &d__[ibegin], &l[
ibegin], &work[indld + ibegin - 1], &work[
indlld + ibegin - 1], pivmin, &gaptol, &z__[
ibegin + windex * z_dim1], &L__1, &negcnt, &
ztz, &mingma, &iwork[iindr + windex], &isuppz[
(windex << 1) - 1], &nrminv, &resid, &rqcorr,
&work[indwrk]);
if (iter == 0) {
bstres = resid;
bstw = lambda;
} else if (resid < bstres) {
bstres = resid;
bstw = lambda;
}
/* Computing MIN */
i__4 = isupmn, i__5 = isuppz[(windex << 1) - 1];
isupmn = min(i__4,i__5);
/* Computing MAX */
i__4 = isupmx, i__5 = isuppz[windex * 2];
isupmx = max(i__4,i__5);
++iter;
/* sin alpha <= |resid|/gap */
/* Note that both the residual and the gap are */
/* proportional to the matrix, so ||T|| doesn't play */
/* a role in the quotient */
/* Convergence test for Rayleigh-Quotient iteration */
/* (omitted when Bisection has been used) */
if (resid > tol * gap && abs(rqcorr) > rqtol * abs(
lambda) && ! usedbs) {
/* We need to check that the RQCORR update doesn't */
/* move the eigenvalue away from the desired one and */
/* towards a neighbor. -> protection with bisection */
if (indeig <= negcnt) {
/* The wanted eigenvalue lies to the left */
sgndef = -1.;
} else {
/* The wanted eigenvalue lies to the right */
sgndef = 1.;
}
/* We only use the RQCORR if it improves the */
/* the iterate reasonably. */
if (rqcorr * sgndef >= 0. && lambda + rqcorr <=
right && lambda + rqcorr >= left) {
usedrq = TRUE_;
/* Store new midpoint of bisection interval in WORK */
if (sgndef == 1.) {
/* The current LAMBDA is on the left of the true */
/* eigenvalue */
left = lambda;
/* We prefer to assume that the error estimate */
/* is correct. We could make the interval not */
/* as a bracket but to be modified if the RQCORR */
/* chooses to. In this case, the RIGHT side should */
/* be modified as follows: */
/* RIGHT = MAX(RIGHT, LAMBDA + RQCORR) */
} else {
/* The current LAMBDA is on the right of the true */
/* eigenvalue */
right = lambda;
/* See comment about assuming the error estimate is */
/* correct above. */
/* LEFT = MIN(LEFT, LAMBDA + RQCORR) */
}
work[windex] = (right + left) * .5;
/* Take RQCORR since it has the correct sign and */
/* improves the iterate reasonably */
lambda += rqcorr;
/* Update width of error interval */
werr[windex] = (right - left) * .5;
} else {
needbs = TRUE_;
}
if (right - left < rqtol * abs(lambda)) {
/* The eigenvalue is computed to bisection accuracy */
/* compute eigenvector and stop */
usedbs = TRUE_;
goto L120;
} else if (iter < 10) {
goto L120;
} else if (iter == 10) {
needbs = TRUE_;
goto L120;
} else {
*info = 5;
return 0;
}
} else {
stp2ii = FALSE_;
if (usedrq && usedbs && bstres <= resid) {
lambda = bstw;
stp2ii = TRUE_;
}
if (stp2ii) {
/* improve error angle by second step */
L__1 = ! usedbs;
zlar1v_(&in, &c__1, &in, &lambda, &d__[ibegin]
, &l[ibegin], &work[indld + ibegin -
1], &work[indlld + ibegin - 1],
pivmin, &gaptol, &z__[ibegin + windex
* z_dim1], &L__1, &negcnt, &ztz, &
mingma, &iwork[iindr + windex], &
isuppz[(windex << 1) - 1], &nrminv, &
resid, &rqcorr, &work[indwrk]);
}
work[windex] = lambda;
}
/* Compute FP-vector support w.r.t. whole matrix */
isuppz[(windex << 1) - 1] += oldien;
isuppz[windex * 2] += oldien;
zfrom = isuppz[(windex << 1) - 1];
zto = isuppz[windex * 2];
isupmn += oldien;
isupmx += oldien;
/* Ensure vector is ok if support in the RQI has changed */
if (isupmn < zfrom) {
i__4 = zfrom - 1;
for (ii = isupmn; ii <= i__4; ++ii) {
i__5 = ii + windex * z_dim1;
z__[i__5].r = 0., z__[i__5].i = 0.;
/* L122: */
}
}
if (isupmx > zto) {
i__4 = isupmx;
for (ii = zto + 1; ii <= i__4; ++ii) {
i__5 = ii + windex * z_dim1;
z__[i__5].r = 0., z__[i__5].i = 0.;
/* L123: */
}
}
i__4 = zto - zfrom + 1;
zdscal_(&i__4, &nrminv, &z__[zfrom + windex * z_dim1],
&c__1);
L125:
/* Update W */
w[windex] = lambda + sigma;
/* Recompute the gaps on the left and right */
/* But only allow them to become larger and not */
/* smaller (which can only happen through "bad" */
/* cancellation and doesn't reflect the theory */
/* where the initial gaps are underestimated due */
/* to WERR being too crude.) */
if (! eskip) {
if (k > 1) {
/* Computing MAX */
d__1 = wgap[windmn], d__2 = w[windex] - werr[
windex] - w[windmn] - werr[windmn];
wgap[windmn] = max(d__1,d__2);
}
if (windex < wend) {
/* Computing MAX */
d__1 = savgap, d__2 = w[windpl] - werr[windpl]
- w[windex] - werr[windex];
wgap[windex] = max(d__1,d__2);
}
}
++idone;
}
/* here ends the code for the current child */
L139:
/* Proceed to any remaining child nodes */
newfst = j + 1;
L140:
;
}
/* L150: */
}
++ndepth;
goto L40;
}
ibegin = iend + 1;
wbegin = wend + 1;
L170:
;
}
return 0;
/* End of ZLARRV */
} /* zlarrv_ */
/* 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 ztgsja_(char *jobu, char *jobv, char *jobq, integer *m,
integer *p, integer *n, integer *k, integer *l, doublecomplex *a,
integer *lda, doublecomplex *b, integer *ldb, doublereal *tola,
doublereal *tolb, doublereal *alpha, doublereal *beta, doublecomplex *
u, integer *ldu, doublecomplex *v, integer *ldv, doublecomplex *q,
integer *ldq, doublecomplex *work, integer *ncycle, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1,
u_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4;
doublereal d__1;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j;
doublereal a1, b1, a3, b3;
doublecomplex a2, b2;
doublereal csq, csu, csv;
doublecomplex snq;
doublereal rwk;
doublecomplex snu, snv;
extern /* Subroutine */ int zrot_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublecomplex *);
doublereal gamma;
extern logical lsame_(char *, char *);
logical initq, initu, initv, wantq, upper;
doublereal error, ssmin;
logical wantu, wantv;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zlags2_(logical *, doublereal *,
doublecomplex *, doublereal *, doublereal *, doublecomplex *,
doublereal *, doublereal *, doublecomplex *, doublereal *,
doublecomplex *, doublereal *, doublecomplex *);
integer kcycle;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *), xerbla_(char *,
integer *), zdscal_(integer *, doublereal *,
doublecomplex *, integer *), zlapll_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *), zlaset_(
char *, integer *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZTGSJA computes the generalized singular value decomposition (GSVD) */
/* of two complex upper triangular (or trapezoidal) matrices A and B. */
/* On entry, it is assumed that matrices A and B have the following */
/* forms, which may be obtained by the preprocessing subroutine ZGGSVP */
/* from a general M-by-N matrix A and P-by-N matrix B: */
/* N-K-L K L */
/* A = K ( 0 A12 A13 ) if M-K-L >= 0; */
/* L ( 0 0 A23 ) */
/* M-K-L ( 0 0 0 ) */
/* N-K-L K L */
/* A = K ( 0 A12 A13 ) if M-K-L < 0; */
/* M-K ( 0 0 A23 ) */
/* N-K-L K L */
/* B = L ( 0 0 B13 ) */
/* P-L ( 0 0 0 ) */
/* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */
/* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */
/* otherwise A23 is (M-K)-by-L upper trapezoidal. */
/* On exit, */
/* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ), */
/* where U, V and Q are unitary matrices, Z' denotes the conjugate */
/* transpose of Z, R is a nonsingular upper triangular matrix, and D1 */
/* and D2 are ``diagonal'' matrices, which are of the following */
/* structures: */
/* If M-K-L >= 0, */
/* K L */
/* D1 = K ( I 0 ) */
/* L ( 0 C ) */
/* M-K-L ( 0 0 ) */
/* K L */
/* D2 = L ( 0 S ) */
/* P-L ( 0 0 ) */
/* N-K-L K L */
/* ( 0 R ) = K ( 0 R11 R12 ) K */
/* L ( 0 0 R22 ) L */
/* where */
/* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */
/* S = diag( BETA(K+1), ... , BETA(K+L) ), */
/* C**2 + S**2 = I. */
/* R is stored in A(1:K+L,N-K-L+1:N) on exit. */
/* If M-K-L < 0, */
/* K M-K K+L-M */
/* D1 = K ( I 0 0 ) */
/* M-K ( 0 C 0 ) */
/* K M-K K+L-M */
/* D2 = M-K ( 0 S 0 ) */
/* K+L-M ( 0 0 I ) */
/* P-L ( 0 0 0 ) */
/* N-K-L K M-K K+L-M */
/* ( 0 R ) = K ( 0 R11 R12 R13 ) */
/* M-K ( 0 0 R22 R23 ) */
/* K+L-M ( 0 0 0 R33 ) */
/* where */
/* C = diag( ALPHA(K+1), ... , ALPHA(M) ), */
/* S = diag( BETA(K+1), ... , BETA(M) ), */
/* C**2 + S**2 = I. */
/* R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored */
/* ( 0 R22 R23 ) */
/* in B(M-K+1:L,N+M-K-L+1:N) on exit. */
/* The computation of the unitary transformation matrices U, V or Q */
/* is optional. These matrices may either be formed explicitly, or they */
/* may be postmultiplied into input matrices U1, V1, or Q1. */
/* Arguments */
/* ========= */
/* JOBU (input) CHARACTER*1 */
/* = 'U': U must contain a unitary matrix U1 on entry, and */
/* the product U1*U is returned; */
/* = 'I': U is initialized to the unit matrix, and the */
/* unitary matrix U is returned; */
/* = 'N': U is not computed. */
/* JOBV (input) CHARACTER*1 */
/* = 'V': V must contain a unitary matrix V1 on entry, and */
/* the product V1*V is returned; */
/* = 'I': V is initialized to the unit matrix, and the */
/* unitary matrix V is returned; */
/* = 'N': V is not computed. */
/* JOBQ (input) CHARACTER*1 */
/* = 'Q': Q must contain a unitary matrix Q1 on entry, and */
/* the product Q1*Q is returned; */
/* = 'I': Q is initialized to the unit matrix, and the */
/* unitary matrix Q is returned; */
/* = 'N': Q is not computed. */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* P (input) INTEGER */
/* The number of rows of the matrix B. P >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrices A and B. N >= 0. */
/* K (input) INTEGER */
/* L (input) INTEGER */
/* K and L specify the subblocks in the input matrices A and B: */
/* A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,,N-L+1:N) */
/* of A and B, whose GSVD is going to be computed by ZTGSJA. */
/* See Further details. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular */
/* matrix R or part of R. See Purpose for details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* B (input/output) COMPLEX*16 array, dimension (LDB,N) */
/* On entry, the P-by-N matrix B. */
/* On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains */
/* a part of R. See Purpose for details. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,P). */
/* TOLA (input) DOUBLE PRECISION */
/* TOLB (input) DOUBLE PRECISION */
/* TOLA and TOLB are the convergence criteria for the Jacobi- */
/* Kogbetliantz iteration procedure. Generally, they are the */
/* same as used in the preprocessing step, say */
/* TOLA = MAX(M,N)*norm(A)*MAZHEPS, */
/* TOLB = MAX(P,N)*norm(B)*MAZHEPS. */
/* ALPHA (output) DOUBLE PRECISION array, dimension (N) */
/* BETA (output) DOUBLE PRECISION array, dimension (N) */
/* On exit, ALPHA and BETA contain the generalized singular */
/* value pairs of A and B; */
/* ALPHA(1:K) = 1, */
/* BETA(1:K) = 0, */
/* and if M-K-L >= 0, */
/* ALPHA(K+1:K+L) = diag(C), */
/* BETA(K+1:K+L) = diag(S), */
/* or if M-K-L < 0, */
/* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0 */
/* BETA(K+1:M) = S, BETA(M+1:K+L) = 1. */
/* Furthermore, if K+L < N, */
/* ALPHA(K+L+1:N) = 0 */
/* BETA(K+L+1:N) = 0. */
/* U (input/output) COMPLEX*16 array, dimension (LDU,M) */
/* On entry, if JOBU = 'U', U must contain a matrix U1 (usually */
/* the unitary matrix returned by ZGGSVP). */
/* On exit, */
/* if JOBU = 'I', U contains the unitary matrix U; */
/* if JOBU = 'U', U contains the product U1*U. */
/* If JOBU = 'N', U is not referenced. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= max(1,M) if */
/* JOBU = 'U'; LDU >= 1 otherwise. */
/* V (input/output) COMPLEX*16 array, dimension (LDV,P) */
/* On entry, if JOBV = 'V', V must contain a matrix V1 (usually */
/* the unitary matrix returned by ZGGSVP). */
/* On exit, */
/* if JOBV = 'I', V contains the unitary matrix V; */
/* if JOBV = 'V', V contains the product V1*V. */
/* If JOBV = 'N', V is not referenced. */
/* LDV (input) INTEGER */
/* The leading dimension of the array V. LDV >= max(1,P) if */
/* JOBV = 'V'; LDV >= 1 otherwise. */
/* Q (input/output) COMPLEX*16 array, dimension (LDQ,N) */
/* On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually */
/* the unitary matrix returned by ZGGSVP). */
/* On exit, */
/* if JOBQ = 'I', Q contains the unitary matrix Q; */
/* if JOBQ = 'Q', Q contains the product Q1*Q. */
/* If JOBQ = 'N', Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= max(1,N) if */
/* JOBQ = 'Q'; LDQ >= 1 otherwise. */
/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
/* NCYCLE (output) INTEGER */
/* The number of cycles required for convergence. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* = 1: the procedure does not converge after MAXIT cycles. */
/* Internal Parameters */
/* =================== */
/* MAXIT INTEGER */
/* MAXIT specifies the total loops that the iterative procedure */
/* may take. If after MAXIT cycles, the routine fails to */
/* converge, we return INFO = 1. */
/* Further Details */
/* =============== */
/* ZTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce */
/* min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L */
/* matrix B13 to the form: */
/* U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1, */
/* where U1, V1 and Q1 are unitary matrix, and Z' is the conjugate */
/* transpose of Z. C1 and S1 are diagonal matrices satisfying */
/* C1**2 + S1**2 = I, */
/* and R1 is an L-by-L nonsingular upper triangular matrix. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and 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;
--alpha;
--beta;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--work;
/* Function Body */
initu = lsame_(jobu, "I");
wantu = initu || lsame_(jobu, "U");
initv = lsame_(jobv, "I");
wantv = initv || lsame_(jobv, "V");
initq = lsame_(jobq, "I");
wantq = initq || lsame_(jobq, "Q");
*info = 0;
if (! (initu || wantu || lsame_(jobu, "N"))) {
*info = -1;
} else if (! (initv || wantv || lsame_(jobv, "N")))
{
*info = -2;
} else if (! (initq || wantq || lsame_(jobq, "N")))
{
*info = -3;
} else if (*m < 0) {
*info = -4;
} else if (*p < 0) {
*info = -5;
} else if (*n < 0) {
*info = -6;
} else if (*lda < max(1,*m)) {
*info = -10;
} else if (*ldb < max(1,*p)) {
*info = -12;
} else if (*ldu < 1 || wantu && *ldu < *m) {
*info = -18;
} else if (*ldv < 1 || wantv && *ldv < *p) {
*info = -20;
} else if (*ldq < 1 || wantq && *ldq < *n) {
*info = -22;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTGSJA", &i__1);
return 0;
}
/* Initialize U, V and Q, if necessary */
if (initu) {
zlaset_("Full", m, m, &c_b1, &c_b2, &u[u_offset], ldu);
}
if (initv) {
zlaset_("Full", p, p, &c_b1, &c_b2, &v[v_offset], ldv);
}
if (initq) {
zlaset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq);
}
/* Loop until convergence */
upper = FALSE_;
for (kcycle = 1; kcycle <= 40; ++kcycle) {
upper = ! upper;
i__1 = *l - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *l;
for (j = i__ + 1; j <= i__2; ++j) {
a1 = 0.;
a2.r = 0., a2.i = 0.;
a3 = 0.;
if (*k + i__ <= *m) {
i__3 = *k + i__ + (*n - *l + i__) * a_dim1;
a1 = a[i__3].r;
}
if (*k + j <= *m) {
i__3 = *k + j + (*n - *l + j) * a_dim1;
a3 = a[i__3].r;
}
i__3 = i__ + (*n - *l + i__) * b_dim1;
b1 = b[i__3].r;
i__3 = j + (*n - *l + j) * b_dim1;
b3 = b[i__3].r;
if (upper) {
if (*k + i__ <= *m) {
i__3 = *k + i__ + (*n - *l + j) * a_dim1;
a2.r = a[i__3].r, a2.i = a[i__3].i;
}
i__3 = i__ + (*n - *l + j) * b_dim1;
b2.r = b[i__3].r, b2.i = b[i__3].i;
} else {
if (*k + j <= *m) {
i__3 = *k + j + (*n - *l + i__) * a_dim1;
a2.r = a[i__3].r, a2.i = a[i__3].i;
}
i__3 = j + (*n - *l + i__) * b_dim1;
b2.r = b[i__3].r, b2.i = b[i__3].i;
}
zlags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, &
csv, &snv, &csq, &snq);
/* Update (K+I)-th and (K+J)-th rows of matrix A: U'*A */
if (*k + j <= *m) {
d_cnjg(&z__1, &snu);
zrot_(l, &a[*k + j + (*n - *l + 1) * a_dim1], lda, &a[*k
+ i__ + (*n - *l + 1) * a_dim1], lda, &csu, &z__1)
;
}
/* Update I-th and J-th rows of matrix B: V'*B */
d_cnjg(&z__1, &snv);
zrot_(l, &b[j + (*n - *l + 1) * b_dim1], ldb, &b[i__ + (*n - *
l + 1) * b_dim1], ldb, &csv, &z__1);
/* Update (N-L+I)-th and (N-L+J)-th columns of matrices */
/* A and B: A*Q and B*Q */
/* Computing MIN */
i__4 = *k + *l;
i__3 = min(i__4,*m);
zrot_(&i__3, &a[(*n - *l + j) * a_dim1 + 1], &c__1, &a[(*n - *
l + i__) * a_dim1 + 1], &c__1, &csq, &snq);
zrot_(l, &b[(*n - *l + j) * b_dim1 + 1], &c__1, &b[(*n - *l +
i__) * b_dim1 + 1], &c__1, &csq, &snq);
if (upper) {
if (*k + i__ <= *m) {
i__3 = *k + i__ + (*n - *l + j) * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
}
i__3 = i__ + (*n - *l + j) * b_dim1;
b[i__3].r = 0., b[i__3].i = 0.;
} else {
if (*k + j <= *m) {
i__3 = *k + j + (*n - *l + i__) * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
}
i__3 = j + (*n - *l + i__) * b_dim1;
b[i__3].r = 0., b[i__3].i = 0.;
}
/* Ensure that the diagonal elements of A and B are real. */
if (*k + i__ <= *m) {
i__3 = *k + i__ + (*n - *l + i__) * a_dim1;
i__4 = *k + i__ + (*n - *l + i__) * a_dim1;
d__1 = a[i__4].r;
a[i__3].r = d__1, a[i__3].i = 0.;
}
if (*k + j <= *m) {
i__3 = *k + j + (*n - *l + j) * a_dim1;
i__4 = *k + j + (*n - *l + j) * a_dim1;
d__1 = a[i__4].r;
a[i__3].r = d__1, a[i__3].i = 0.;
}
i__3 = i__ + (*n - *l + i__) * b_dim1;
i__4 = i__ + (*n - *l + i__) * b_dim1;
d__1 = b[i__4].r;
b[i__3].r = d__1, b[i__3].i = 0.;
i__3 = j + (*n - *l + j) * b_dim1;
i__4 = j + (*n - *l + j) * b_dim1;
d__1 = b[i__4].r;
b[i__3].r = d__1, b[i__3].i = 0.;
/* Update unitary matrices U, V, Q, if desired. */
if (wantu && *k + j <= *m) {
zrot_(m, &u[(*k + j) * u_dim1 + 1], &c__1, &u[(*k + i__) *
u_dim1 + 1], &c__1, &csu, &snu);
}
if (wantv) {
zrot_(p, &v[j * v_dim1 + 1], &c__1, &v[i__ * v_dim1 + 1],
&c__1, &csv, &snv);
}
if (wantq) {
zrot_(n, &q[(*n - *l + j) * q_dim1 + 1], &c__1, &q[(*n - *
l + i__) * q_dim1 + 1], &c__1, &csq, &snq);
}
/* L10: */
}
/* L20: */
}
if (! upper) {
/* The matrices A13 and B13 were lower triangular at the start */
/* of the cycle, and are now upper triangular. */
/* Convergence test: test the parallelism of the corresponding */
/* rows of A and B. */
error = 0.;
/* Computing MIN */
i__2 = *l, i__3 = *m - *k;
i__1 = min(i__2,i__3);
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *l - i__ + 1;
zcopy_(&i__2, &a[*k + i__ + (*n - *l + i__) * a_dim1], lda, &
work[1], &c__1);
i__2 = *l - i__ + 1;
zcopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &work[*
l + 1], &c__1);
i__2 = *l - i__ + 1;
zlapll_(&i__2, &work[1], &c__1, &work[*l + 1], &c__1, &ssmin);
error = max(error,ssmin);
/* L30: */
}
if (abs(error) <= min(*tola,*tolb)) {
goto L50;
}
}
/* End of cycle loop */
/* L40: */
}
/* The algorithm has not converged after MAXIT cycles. */
*info = 1;
goto L100;
L50:
/* If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged. */
/* Compute the generalized singular value pairs (ALPHA, BETA), and */
/* set the triangular matrix R to array A. */
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
alpha[i__] = 1.;
beta[i__] = 0.;
/* L60: */
}
/* Computing MIN */
i__2 = *l, i__3 = *m - *k;
i__1 = min(i__2,i__3);
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *k + i__ + (*n - *l + i__) * a_dim1;
a1 = a[i__2].r;
i__2 = i__ + (*n - *l + i__) * b_dim1;
b1 = b[i__2].r;
if (a1 != 0.) {
gamma = b1 / a1;
if (gamma < 0.) {
i__2 = *l - i__ + 1;
zdscal_(&i__2, &c_b39, &b[i__ + (*n - *l + i__) * b_dim1],
ldb);
if (wantv) {
zdscal_(p, &c_b39, &v[i__ * v_dim1 + 1], &c__1);
}
}
d__1 = abs(gamma);
dlartg_(&d__1, &c_b42, &beta[*k + i__], &alpha[*k + i__], &rwk);
if (alpha[*k + i__] >= beta[*k + i__]) {
i__2 = *l - i__ + 1;
d__1 = 1. / alpha[*k + i__];
zdscal_(&i__2, &d__1, &a[*k + i__ + (*n - *l + i__) * a_dim1],
lda);
} else {
i__2 = *l - i__ + 1;
d__1 = 1. / beta[*k + i__];
zdscal_(&i__2, &d__1, &b[i__ + (*n - *l + i__) * b_dim1], ldb)
;
i__2 = *l - i__ + 1;
zcopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k
+ i__ + (*n - *l + i__) * a_dim1], lda);
}
} else {
alpha[*k + i__] = 0.;
beta[*k + i__] = 1.;
i__2 = *l - i__ + 1;
zcopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k +
i__ + (*n - *l + i__) * a_dim1], lda);
}
/* L70: */
}
/* Post-assignment */
i__1 = *k + *l;
for (i__ = *m + 1; i__ <= i__1; ++i__) {
alpha[i__] = 0.;
beta[i__] = 1.;
/* L80: */
}
if (*k + *l < *n) {
i__1 = *n;
for (i__ = *k + *l + 1; i__ <= i__1; ++i__) {
alpha[i__] = 0.;
beta[i__] = 0.;
/* L90: */
}
}
L100:
*ncycle = kcycle;
return 0;
/* End of ZTGSJA */
} /* ztgsja_ */
/* Subroutine */
int zheevx_(char *jobz, char *range, char *uplo, integer *n, doublecomplex *a, integer *lda, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer *m, doublereal * w, doublecomplex *z__, integer *ldz, doublecomplex *work, integer * lwork, doublereal *rwork, integer *iwork, integer *ifail, integer * info)
{
/* System generated locals */
integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, nb, jj;
doublereal eps, vll, vuu, tmp1;
integer indd, inde;
doublereal anrm;
integer imax;
doublereal rmin, rmax;
logical test;
integer itmp1, indee;
extern /* Subroutine */
int dscal_(integer *, doublereal *, doublereal *, integer *);
doublereal sigma;
extern logical lsame_(char *, char *);
integer iinfo;
char order[1];
extern /* Subroutine */
int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *);
logical lower, wantz;
extern /* Subroutine */
int zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dlamch_(char *);
logical alleig, indeig;
integer iscale, indibl;
logical valeig;
doublereal safmin;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
extern /* Subroutine */
int xerbla_(char *, integer *), zdscal_( integer *, doublereal *, doublecomplex *, integer *);
doublereal abstll, bignum;
extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *, integer *, doublereal *);
integer indiwk, indisp, indtau;
extern /* Subroutine */
int dsterf_(integer *, doublereal *, doublereal *, integer *), dstebz_(char *, char *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, integer *, doublereal *, integer *, integer *);
integer indrwk, indwrk;
extern /* Subroutine */
int zhetrd_(char *, integer *, doublecomplex *, integer *, doublereal *, doublereal *, doublecomplex *, doublecomplex *, integer *, integer *);
integer lwkmin;
extern /* Subroutine */
int zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *);
integer llwork, nsplit;
doublereal smlnum;
extern /* Subroutine */
int zstein_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, integer *, doublecomplex *, integer *, doublereal *, integer *, integer *, integer *);
integer lwkopt;
logical lquery;
extern /* Subroutine */
int zsteqr_(char *, integer *, doublereal *, doublereal *, doublecomplex *, integer *, doublereal *, integer *), zungtr_(char *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *), zunmtr_(char *, char *, char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer *);
/* -- LAPACK driver routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--rwork;
--iwork;
--ifail;
/* Function Body */
lower = lsame_(uplo, "L");
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
lquery = *lwork == -1;
*info = 0;
if (! (wantz || lsame_(jobz, "N")))
{
*info = -1;
}
else if (! (alleig || valeig || indeig))
{
*info = -2;
}
else if (! (lower || lsame_(uplo, "U")))
{
*info = -3;
}
else if (*n < 0)
{
*info = -4;
}
else if (*lda < max(1,*n))
{
*info = -6;
}
else
{
if (valeig)
{
if (*n > 0 && *vu <= *vl)
{
*info = -8;
}
}
else if (indeig)
{
if (*il < 1 || *il > max(1,*n))
{
*info = -9;
}
else if (*iu < min(*n,*il) || *iu > *n)
{
*info = -10;
}
}
}
if (*info == 0)
{
if (*ldz < 1 || wantz && *ldz < *n)
{
*info = -15;
}
}
if (*info == 0)
{
if (*n <= 1)
{
lwkmin = 1;
work[1].r = (doublereal) lwkmin;
work[1].i = 0.; // , expr subst
}
else
{
lwkmin = *n << 1;
nb = ilaenv_(&c__1, "ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
/* Computing MAX */
i__1 = nb;
i__2 = ilaenv_(&c__1, "ZUNMTR", uplo, n, &c_n1, &c_n1, &c_n1); // , expr subst
nb = max(i__1,i__2);
/* Computing MAX */
i__1 = 1;
i__2 = (nb + 1) * *n; // , expr subst
lwkopt = max(i__1,i__2);
work[1].r = (doublereal) lwkopt;
work[1].i = 0.; // , expr subst
}
if (*lwork < lwkmin && ! lquery)
{
*info = -17;
}
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZHEEVX", &i__1);
return 0;
}
else if (lquery)
{
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0)
{
return 0;
}
if (*n == 1)
{
if (alleig || indeig)
{
*m = 1;
i__1 = a_dim1 + 1;
w[1] = a[i__1].r;
}
else if (valeig)
{
i__1 = a_dim1 + 1;
i__2 = a_dim1 + 1;
if (*vl < a[i__1].r && *vu >= a[i__2].r)
{
*m = 1;
i__1 = a_dim1 + 1;
w[1] = a[i__1].r;
}
}
if (wantz)
{
i__1 = z_dim1 + 1;
z__[i__1].r = 1.;
z__[i__1].i = 0.; // , expr subst
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
d__1 = sqrt(bignum);
d__2 = 1. / sqrt(sqrt(safmin)); // , expr subst
rmax = min(d__1,d__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
abstll = *abstol;
if (valeig)
{
vll = *vl;
vuu = *vu;
}
anrm = zlanhe_("M", uplo, n, &a[a_offset], lda, &rwork[1]);
if (anrm > 0. && anrm < rmin)
{
iscale = 1;
sigma = rmin / anrm;
}
else if (anrm > rmax)
{
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1)
{
if (lower)
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n - j + 1;
zdscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1);
/* L10: */
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
zdscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1);
/* L20: */
}
}
if (*abstol > 0.)
{
abstll = *abstol * sigma;
}
if (valeig)
{
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Call ZHETRD to reduce Hermitian matrix to tridiagonal form. */
indd = 1;
inde = indd + *n;
indrwk = inde + *n;
indtau = 1;
indwrk = indtau + *n;
llwork = *lwork - indwrk + 1;
zhetrd_(uplo, n, &a[a_offset], lda, &rwork[indd], &rwork[inde], &work[ indtau], &work[indwrk], &llwork, &iinfo);
/* If all eigenvalues are desired and ABSTOL is less than or equal to */
/* zero, then call DSTERF or ZUNGTR and ZSTEQR. If this fails for */
/* some eigenvalue, then try DSTEBZ. */
test = FALSE_;
if (indeig)
{
if (*il == 1 && *iu == *n)
{
test = TRUE_;
}
}
if ((alleig || test) && *abstol <= 0.)
{
dcopy_(n, &rwork[indd], &c__1, &w[1], &c__1);
indee = indrwk + (*n << 1);
if (! wantz)
{
i__1 = *n - 1;
dcopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
dsterf_(n, &w[1], &rwork[indee], info);
}
else
{
zlacpy_("A", n, n, &a[a_offset], lda, &z__[z_offset], ldz);
zungtr_(uplo, n, &z__[z_offset], ldz, &work[indtau], &work[indwrk] , &llwork, &iinfo);
i__1 = *n - 1;
dcopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
zsteqr_(jobz, n, &w[1], &rwork[indee], &z__[z_offset], ldz, & rwork[indrwk], info);
if (*info == 0)
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
ifail[i__] = 0;
/* L30: */
}
}
}
if (*info == 0)
{
*m = *n;
goto L40;
}
*info = 0;
}
/* Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN. */
if (wantz)
{
*(unsigned char *)order = 'B';
}
else
{
*(unsigned char *)order = 'E';
}
indibl = 1;
indisp = indibl + *n;
indiwk = indisp + *n;
dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indd], & rwork[inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], & rwork[indrwk], &iwork[indiwk], info);
if (wantz)
{
zstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[indibl], & iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[ indiwk], &ifail[1], info);
/* Apply unitary matrix used in reduction to tridiagonal */
/* form to eigenvectors returned by ZSTEIN. */
zunmtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[ z_offset], ldz, &work[indwrk], &llwork, &iinfo);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
L40:
if (iscale == 1)
{
if (*info == 0)
{
imax = *m;
}
else
{
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__1, &w[1], &c__1);
}
/* If eigenvalues are not in order, then sort them, along with */
/* eigenvectors. */
if (wantz)
{
i__1 = *m - 1;
for (j = 1;
j <= i__1;
++j)
{
i__ = 0;
tmp1 = w[j];
i__2 = *m;
for (jj = j + 1;
jj <= i__2;
++jj)
{
if (w[jj] < tmp1)
{
i__ = jj;
tmp1 = w[jj];
}
/* L50: */
}
if (i__ != 0)
{
itmp1 = iwork[indibl + i__ - 1];
w[i__] = w[j];
iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
w[j] = tmp1;
iwork[indibl + j - 1] = itmp1;
zswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], &c__1);
if (*info != 0)
{
itmp1 = ifail[i__];
ifail[i__] = ifail[j];
ifail[j] = itmp1;
}
}
/* L60: */
}
}
/* Set WORK(1) to optimal complex workspace size. */
work[1].r = (doublereal) lwkopt;
work[1].i = 0.; // , expr subst
return 0;
/* End of ZHEEVX */
}
/*< >*/
/* 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 zchkgt_(logical *dotype, integer *nn, integer *nval,
integer *nns, integer *nsval, doublereal *thresh, logical *tsterr,
doublecomplex *a, doublecomplex *af, doublecomplex *b, doublecomplex *
x, doublecomplex *xact, doublecomplex *work, doublereal *rwork,
integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
static char transs[1*3] = "N" "T" "C";
/* Format strings */
static char fmt_9999[] = "(12x,\002N =\002,i5,\002,\002,10x,\002 type"
" \002,i2,\002, test(\002,i2,\002) = \002,g12.5)";
static char fmt_9997[] = "(\002 NORM ='\002,a1,\002', N =\002,i5,\002"
",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) = \002,g12."
"5)";
static char fmt_9998[] = "(\002 TRANS='\002,a1,\002', N =\002,i5,\002, N"
"RHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) = \002,g"
"12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, j, k, m, n;
doublecomplex z__[3];
integer in, kl, ku, ix, lda;
doublereal cond;
integer mode, koff, imat, info;
char path[3], dist[1];
integer irhs, nrhs;
char norm[1], type__[1];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *);
integer nfail, iseed[4];
extern doublereal dget06_(doublereal *, doublereal *);
doublereal rcond;
integer nimat;
doublereal anorm;
integer itran;
extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *
);
char trans[1];
integer izero, nerrs;
extern /* Subroutine */ int zgtt01_(integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublereal *, doublereal *), zgtt02_(char *, integer *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *), zgtt05_(char *, integer *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *,
doublereal *);
logical zerot;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zlatb4_(char *, integer *, integer *,
integer *, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *), alaerh_(char *,
char *, integer *, integer *, char *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *);
doublereal rcondc, rcondi;
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *), alasum_(char *, integer *, integer *,
integer *, integer *);
doublereal rcondo, ainvnm;
logical trfcon;
extern /* Subroutine */ int zerrge_(char *, integer *);
extern doublereal zlangt_(char *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *);
extern /* Subroutine */ int zlagtm_(char *, integer *, integer *,
doublereal *, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, integer *, doublereal *, doublecomplex *,
integer *), zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dzasum_(integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zgtcon_(char *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublereal *, doublereal *, doublecomplex *, integer *),
zlatms_(integer *, integer *, char *, integer *, char *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *, char *, doublecomplex *, integer *, doublecomplex *,
integer *), zlarnv_(integer *, integer *,
integer *, doublecomplex *);
doublereal result[7];
extern /* Subroutine */ int zgtrfs_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublecomplex *, doublereal *,
integer *), zgttrf_(integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
integer *), zgttrs_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___29 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKGT tests ZGTTRF, -TRS, -RFS, and -CON */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) COMPLEX*16 array, dimension (NMAX*4) */
/* AF (workspace) COMPLEX*16 array, dimension (NMAX*4) */
/* B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* WORK (workspace) COMPLEX*16 array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension */
/* (max(NMAX)+2*NSMAX) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--af;
--a;
--nsval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "GT", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
zerrge_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
/* Computing MAX */
i__2 = n - 1;
m = max(i__2,0);
lda = max(1,n);
nimat = 12;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L100;
}
/* Set up parameters with ZLATB4. */
zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cond, dist);
zerot = imat >= 8 && imat <= 10;
if (imat <= 6) {
/* Types 1-6: generate matrices of known condition number. */
/* Computing MAX */
i__3 = 2 - ku, i__4 = 3 - max(1,n);
koff = max(i__3,i__4);
s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
&anorm, &kl, &ku, "Z", &af[koff], &c__3, &work[1], &
info);
/* Check the error code from ZLATMS. */
if (info != 0) {
alaerh_(path, "ZLATMS", &info, &c__0, " ", &n, &n, &kl, &
ku, &c_n1, &imat, &nfail, &nerrs, nout);
goto L100;
}
izero = 0;
if (n > 1) {
i__3 = n - 1;
zcopy_(&i__3, &af[4], &c__3, &a[1], &c__1);
i__3 = n - 1;
zcopy_(&i__3, &af[3], &c__3, &a[n + m + 1], &c__1);
}
zcopy_(&n, &af[2], &c__3, &a[m + 1], &c__1);
} else {
/* Types 7-12: generate tridiagonal matrices with */
/* unknown condition numbers. */
if (! zerot || ! dotype[7]) {
/* Generate a matrix with elements whose real and */
/* imaginary parts are from [-1,1]. */
i__3 = n + (m << 1);
zlarnv_(&c__2, iseed, &i__3, &a[1]);
if (anorm != 1.) {
i__3 = n + (m << 1);
zdscal_(&i__3, &anorm, &a[1], &c__1);
}
} else if (izero > 0) {
/* Reuse the last matrix by copying back the zeroed out */
/* elements. */
if (izero == 1) {
i__3 = n;
a[i__3].r = z__[1].r, a[i__3].i = z__[1].i;
if (n > 1) {
a[1].r = z__[2].r, a[1].i = z__[2].i;
}
} else if (izero == n) {
i__3 = n * 3 - 2;
a[i__3].r = z__[0].r, a[i__3].i = z__[0].i;
i__3 = (n << 1) - 1;
a[i__3].r = z__[1].r, a[i__3].i = z__[1].i;
} else {
i__3 = (n << 1) - 2 + izero;
a[i__3].r = z__[0].r, a[i__3].i = z__[0].i;
i__3 = n - 1 + izero;
a[i__3].r = z__[1].r, a[i__3].i = z__[1].i;
i__3 = izero;
a[i__3].r = z__[2].r, a[i__3].i = z__[2].i;
}
}
/* If IMAT > 7, set one column of the matrix to 0. */
if (! zerot) {
izero = 0;
} else if (imat == 8) {
izero = 1;
i__3 = n;
z__[1].r = a[i__3].r, z__[1].i = a[i__3].i;
i__3 = n;
a[i__3].r = 0., a[i__3].i = 0.;
if (n > 1) {
z__[2].r = a[1].r, z__[2].i = a[1].i;
a[1].r = 0., a[1].i = 0.;
}
} else if (imat == 9) {
izero = n;
i__3 = n * 3 - 2;
z__[0].r = a[i__3].r, z__[0].i = a[i__3].i;
i__3 = (n << 1) - 1;
z__[1].r = a[i__3].r, z__[1].i = a[i__3].i;
i__3 = n * 3 - 2;
a[i__3].r = 0., a[i__3].i = 0.;
i__3 = (n << 1) - 1;
a[i__3].r = 0., a[i__3].i = 0.;
} else {
izero = (n + 1) / 2;
i__3 = n - 1;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = (n << 1) - 2 + i__;
a[i__4].r = 0., a[i__4].i = 0.;
i__4 = n - 1 + i__;
a[i__4].r = 0., a[i__4].i = 0.;
i__4 = i__;
a[i__4].r = 0., a[i__4].i = 0.;
/* L20: */
}
i__3 = n * 3 - 2;
a[i__3].r = 0., a[i__3].i = 0.;
i__3 = (n << 1) - 1;
a[i__3].r = 0., a[i__3].i = 0.;
}
}
/* + TEST 1 */
/* Factor A as L*U and compute the ratio */
/* norm(L*U - A) / (n * norm(A) * EPS ) */
i__3 = n + (m << 1);
zcopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
s_copy(srnamc_1.srnamt, "ZGTTRF", (ftnlen)32, (ftnlen)6);
zgttrf_(&n, &af[1], &af[m + 1], &af[n + m + 1], &af[n + (m << 1)
+ 1], &iwork[1], &info);
/* Check error code from ZGTTRF. */
if (info != izero) {
alaerh_(path, "ZGTTRF", &info, &izero, " ", &n, &n, &c__1, &
c__1, &c_n1, &imat, &nfail, &nerrs, nout);
}
trfcon = info != 0;
zgtt01_(&n, &a[1], &a[m + 1], &a[n + m + 1], &af[1], &af[m + 1], &
af[n + m + 1], &af[n + (m << 1) + 1], &iwork[1], &work[1],
&lda, &rwork[1], result);
/* Print the test ratio if it is .GE. THRESH. */
if (result[0] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___29.ciunit = *nout;
s_wsfe(&io___29);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
++nrun;
for (itran = 1; itran <= 2; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&transs[itran - 1]
;
if (itran == 1) {
*(unsigned char *)norm = 'O';
} else {
*(unsigned char *)norm = 'I';
}
anorm = zlangt_(norm, &n, &a[1], &a[m + 1], &a[n + m + 1]);
if (! trfcon) {
/* Use ZGTTRS to solve for one column at a time of */
/* inv(A), computing the maximum column sum as we go. */
ainvnm = 0.;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
i__5 = j;
x[i__5].r = 0., x[i__5].i = 0.;
/* L30: */
}
i__4 = i__;
x[i__4].r = 1., x[i__4].i = 0.;
zgttrs_(trans, &n, &c__1, &af[1], &af[m + 1], &af[n +
m + 1], &af[n + (m << 1) + 1], &iwork[1], &x[
1], &lda, &info);
/* Computing MAX */
d__1 = ainvnm, d__2 = dzasum_(&n, &x[1], &c__1);
ainvnm = max(d__1,d__2);
/* L40: */
}
/* Compute RCONDC = 1 / (norm(A) * norm(inv(A)) */
if (anorm <= 0. || ainvnm <= 0.) {
rcondc = 1.;
} else {
rcondc = 1. / anorm / ainvnm;
}
if (itran == 1) {
rcondo = rcondc;
} else {
rcondi = rcondc;
}
} else {
rcondc = 0.;
}
/* + TEST 7 */
/* Estimate the reciprocal of the condition number of the */
/* matrix. */
s_copy(srnamc_1.srnamt, "ZGTCON", (ftnlen)32, (ftnlen)6);
zgtcon_(norm, &n, &af[1], &af[m + 1], &af[n + m + 1], &af[n +
(m << 1) + 1], &iwork[1], &anorm, &rcond, &work[1], &
info);
/* Check error code from ZGTCON. */
if (info != 0) {
alaerh_(path, "ZGTCON", &info, &c__0, norm, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
}
result[6] = dget06_(&rcond, &rcondc);
/* Print the test ratio if it is .GE. THRESH. */
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, norm, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
/* L50: */
}
/* Skip the remaining tests if the matrix is singular. */
if (trfcon) {
goto L100;
}
i__3 = *nns;
for (irhs = 1; irhs <= i__3; ++irhs) {
nrhs = nsval[irhs];
/* Generate NRHS random solution vectors. */
ix = 1;
i__4 = nrhs;
for (j = 1; j <= i__4; ++j) {
zlarnv_(&c__2, iseed, &n, &xact[ix]);
ix += lda;
/* L60: */
}
for (itran = 1; itran <= 3; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&transs[itran
- 1];
if (itran == 1) {
rcondc = rcondo;
} else {
rcondc = rcondi;
}
/* Set the right hand side. */
zlagtm_(trans, &n, &nrhs, &c_b63, &a[1], &a[m + 1], &a[n
+ m + 1], &xact[1], &lda, &c_b64, &b[1], &lda);
/* + TEST 2 */
/* Solve op(A) * X = B and compute the residual. */
zlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "ZGTTRS", (ftnlen)32, (ftnlen)6);
zgttrs_(trans, &n, &nrhs, &af[1], &af[m + 1], &af[n + m +
1], &af[n + (m << 1) + 1], &iwork[1], &x[1], &lda,
&info);
/* Check error code from ZGTTRS. */
if (info != 0) {
alaerh_(path, "ZGTTRS", &info, &c__0, trans, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
zlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
zgtt02_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
&x[1], &lda, &work[1], &lda, &rwork[1], &result[
1]);
/* + TEST 3 */
/* Check solution from generated exact solution. */
zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[2]);
/* + TESTS 4, 5, and 6 */
/* Use iterative refinement to improve the solution. */
s_copy(srnamc_1.srnamt, "ZGTRFS", (ftnlen)32, (ftnlen)6);
zgtrfs_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
&af[1], &af[m + 1], &af[n + m + 1], &af[n + (m <<
1) + 1], &iwork[1], &b[1], &lda, &x[1], &lda, &
rwork[1], &rwork[nrhs + 1], &work[1], &rwork[(
nrhs << 1) + 1], &info);
/* Check error code from ZGTRFS. */
if (info != 0) {
alaerh_(path, "ZGTRFS", &info, &c__0, trans, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[3]);
zgtt05_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
&b[1], &lda, &x[1], &lda, &xact[1], &lda, &rwork[
1], &rwork[nrhs + 1], &result[4]);
/* Print information about the tests that did not pass the */
/* threshold. */
for (k = 2; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___44.ciunit = *nout;
s_wsfe(&io___44);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L70: */
}
nrun += 5;
/* L80: */
}
/* L90: */
}
L100:
;
}
/* L110: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of ZCHKGT */
} /* zchkgt_ */
/* 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 zpbtf2_(char *uplo, integer *n, integer *kd,
doublecomplex *ab, integer *ldab, integer *info)
{
/* -- LAPACK 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
=======
ZPBTF2 computes the Cholesky factorization of a complex Hermitian
positive definite band matrix A.
The factorization has the form
A = U' * U , if UPLO = 'U', or
A = L * L', if UPLO = 'L',
where U is an upper triangular matrix, U' is the conjugate transpose
of U, and L is lower triangular.
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.
KD (input) INTEGER
The number of super-diagonals of the matrix A if UPLO = 'U',
or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
AB (input/output) COMPLEX*16 array, dimension (LDAB,N)
On entry, the upper or lower triangle of the Hermitian band
matrix A, stored in the first KD+1 rows of the array. The
j-th column of A is stored in the j-th column of the array AB
as follows:
if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
On exit, if INFO = 0, the triangular factor U or L from the
Cholesky factorization A = U'*U or A = L*L' of the band
matrix A, in the same storage format as A.
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -k, the k-th argument had an illegal value
> 0: if INFO = k, the leading minor of order k is not
positive definite, and the factorization could not be
completed.
Further Details
===============
The band storage scheme is illustrated by the following example, when
N = 6, KD = 2, and UPLO = 'U':
On entry: On exit:
* * a13 a24 a35 a46 * * u13 u24 u35 u46
* a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
Similarly, if UPLO = 'L' the format of A is as follows:
On entry: On exit:
a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
a31 a42 a53 a64 * * l31 l42 l53 l64 * *
Array elements marked * are not used by the routine.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static doublereal c_b8 = -1.;
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
extern /* Subroutine */ int zher_(char *, integer *, doublereal *,
doublecomplex *, integer *, doublecomplex *, integer *);
static integer j;
extern logical lsame_(char *, char *);
static logical upper;
static integer kn;
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *), zlacgv_(
integer *, doublecomplex *, integer *);
static doublereal ajj;
static integer kld;
#define ab_subscr(a_1,a_2) (a_2)*ab_dim1 + a_1
#define ab_ref(a_1,a_2) ab[ab_subscr(a_1,a_2)]
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kd < 0) {
*info = -3;
} else if (*ldab < *kd + 1) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPBTF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Computing MAX */
i__1 = 1, i__2 = *ldab - 1;
kld = max(i__1,i__2);
if (upper) {
/* Compute the Cholesky factorization A = U'*U. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute U(J,J) and test for non-positive-definiteness. */
i__2 = ab_subscr(*kd + 1, j);
ajj = ab[i__2].r;
if (ajj <= 0.) {
i__2 = ab_subscr(*kd + 1, j);
ab[i__2].r = ajj, ab[i__2].i = 0.;
goto L30;
}
ajj = sqrt(ajj);
i__2 = ab_subscr(*kd + 1, j);
ab[i__2].r = ajj, ab[i__2].i = 0.;
/* Compute elements J+1:J+KN of row J and update the
trailing submatrix within the band.
Computing MIN */
i__2 = *kd, i__3 = *n - j;
kn = min(i__2,i__3);
if (kn > 0) {
d__1 = 1. / ajj;
zdscal_(&kn, &d__1, &ab_ref(*kd, j + 1), &kld);
zlacgv_(&kn, &ab_ref(*kd, j + 1), &kld);
zher_("Upper", &kn, &c_b8, &ab_ref(*kd, j + 1), &kld, &ab_ref(
*kd + 1, j + 1), &kld);
zlacgv_(&kn, &ab_ref(*kd, j + 1), &kld);
}
/* L10: */
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute L(J,J) and test for non-positive-definiteness. */
i__2 = ab_subscr(1, j);
ajj = ab[i__2].r;
if (ajj <= 0.) {
i__2 = ab_subscr(1, j);
ab[i__2].r = ajj, ab[i__2].i = 0.;
goto L30;
}
ajj = sqrt(ajj);
i__2 = ab_subscr(1, j);
ab[i__2].r = ajj, ab[i__2].i = 0.;
/* Compute elements J+1:J+KN of column J and update the
trailing submatrix within the band.
Computing MIN */
i__2 = *kd, i__3 = *n - j;
kn = min(i__2,i__3);
if (kn > 0) {
d__1 = 1. / ajj;
zdscal_(&kn, &d__1, &ab_ref(2, j), &c__1);
zher_("Lower", &kn, &c_b8, &ab_ref(2, j), &c__1, &ab_ref(1, j
+ 1), &kld);
}
/* L20: */
}
}
return 0;
L30:
*info = j;
return 0;
/* End of ZPBTF2 */
} /* zpbtf2_ */
/* Subroutine */ int zneigh_(doublereal *rnorm, integer *n, doublecomplex *
h__, integer *ldh, doublecomplex *ritz, doublecomplex *bounds,
doublecomplex *q, integer *ldq, doublecomplex *workl, doublereal *
rwork, integer *ierr)
{
/* System generated locals */
integer h_dim1, h_offset, q_dim1, q_offset, i__1;
doublereal d__1;
/* Local variables */
static integer j;
static real t0, t1;
static doublecomplex vl[1];
static doublereal temp;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zmout_(integer *, integer *, integer
*, doublecomplex *, integer *, integer *, char *, ftnlen), zvout_(
integer *, integer *, doublecomplex *, integer *, char *, ftnlen);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
extern /* Subroutine */ int second_(real *);
static logical select[1];
static integer msglvl;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen),
zlahqr_(logical *, logical *, integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *,
doublecomplex *, integer *, integer *), ztrevc_(char *, char *,
logical *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, integer *, integer *,
doublecomplex *, doublereal *, integer *, ftnlen, ftnlen),
zdscal_(integer *, doublereal *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *, ftnlen);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %------------------------% */
/* | Local Scalars & Arrays | */
/* %------------------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* %-------------------------------% */
/* | Initialize timing statistics | */
/* | & message level for debugging | */
/* %-------------------------------% */
/* Parameter adjustments */
--rwork;
--workl;
--bounds;
--ritz;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
/* Function Body */
second_(&t0);
msglvl = debug_1.mceigh;
if (msglvl > 2) {
zmout_(&debug_1.logfil, n, n, &h__[h_offset], ldh, &debug_1.ndigit,
"_neigh: Entering upper Hessenberg matrix H ", (ftnlen)43);
}
/* %----------------------------------------------------------% */
/* | 1. Compute the eigenvalues, the last components of the | */
/* | corresponding Schur vectors and the full Schur form T | */
/* | of the current upper Hessenberg matrix H. | */
/* | zlahqr returns the full Schur form of H | */
/* | in WORKL(1:N**2), and the Schur vectors in q. | */
/* %----------------------------------------------------------% */
zlacpy_("All", n, n, &h__[h_offset], ldh, &workl[1], n, (ftnlen)3);
zlaset_("All", n, n, &c_b2, &c_b1, &q[q_offset], ldq, (ftnlen)3);
zlahqr_(&c_true, &c_true, n, &c__1, n, &workl[1], ldh, &ritz[1], &c__1, n,
&q[q_offset], ldq, ierr);
if (*ierr != 0) {
goto L9000;
}
zcopy_(n, &q[*n - 1 + q_dim1], ldq, &bounds[1], &c__1);
if (msglvl > 1) {
zvout_(&debug_1.logfil, n, &bounds[1], &debug_1.ndigit, "_neigh: las"
"t row of the Schur matrix for H", (ftnlen)42);
}
/* %----------------------------------------------------------% */
/* | 2. Compute the eigenvectors of the full Schur form T and | */
/* | apply the Schur vectors to get the corresponding | */
/* | eigenvectors. | */
/* %----------------------------------------------------------% */
ztrevc_("Right", "Back", select, n, &workl[1], n, vl, n, &q[q_offset],
ldq, n, n, &workl[*n * *n + 1], &rwork[1], ierr, (ftnlen)5, (
ftnlen)4);
if (*ierr != 0) {
goto L9000;
}
/* %------------------------------------------------% */
/* | Scale the returning eigenvectors so that their | */
/* | Euclidean norms are all one. LAPACK subroutine | */
/* | ztrevc returns each eigenvector 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|. | */
/* %------------------------------------------------% */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp = dznrm2_(n, &q[j * q_dim1 + 1], &c__1);
d__1 = 1. / temp;
zdscal_(n, &d__1, &q[j * q_dim1 + 1], &c__1);
/* L10: */
}
if (msglvl > 1) {
zcopy_(n, &q[*n + q_dim1], ldq, &workl[1], &c__1);
zvout_(&debug_1.logfil, n, &workl[1], &debug_1.ndigit, "_neigh: Last"
" row of the eigenvector matrix for H", (ftnlen)48);
}
/* %----------------------------% */
/* | Compute the Ritz estimates | */
/* %----------------------------% */
zcopy_(n, &q[*n + q_dim1], n, &bounds[1], &c__1);
zdscal_(n, rnorm, &bounds[1], &c__1);
if (msglvl > 2) {
zvout_(&debug_1.logfil, n, &ritz[1], &debug_1.ndigit, "_neigh: The e"
"igenvalues of H", (ftnlen)28);
zvout_(&debug_1.logfil, n, &bounds[1], &debug_1.ndigit, "_neigh: Rit"
"z estimates for the eigenvalues of H", (ftnlen)47);
}
second_(&t1);
timing_1.tceigh += t1 - t0;
L9000:
return 0;
/* %---------------% */
/* | End of zneigh | */
/* %---------------% */
} /* zneigh_ */
/* Subroutine */ int zdrvpt_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, doublereal *thresh, logical *tsterr, doublecomplex *a,
doublereal *d__, doublecomplex *e, doublecomplex *b, doublecomplex *x,
doublecomplex *xact, doublecomplex *work, doublereal *rwork, integer
*nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002, N =\002,i5,\002, type \002,i2,"
"\002, test \002,i2,\002, ratio = \002,g12.5)";
static char fmt_9998[] = "(1x,a6,\002, FACT='\002,a1,\002', N =\002,i5"
",\002, type \002,i2,\002, test \002,i2,\002, ratio = \002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double z_abs(doublecomplex *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, j, k, n;
doublereal z__[3];
integer k1, ia, in, kl, ku, ix, nt, lda;
char fact[1];
doublereal cond;
integer mode;
doublereal dmax__;
integer imat, info;
char path[3], dist[1], type__[1];
integer nrun, ifact;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
integer nfail, iseed[4];
extern doublereal dget06_(doublereal *, doublereal *);
doublereal rcond;
integer nimat;
doublereal anorm;
extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *
), dcopy_(integer *, doublereal *, integer *, doublereal *,
integer *);
integer izero, nerrs;
extern /* Subroutine */ int zptt01_(integer *, doublereal *,
doublecomplex *, doublereal *, doublecomplex *, doublecomplex *,
doublereal *);
logical zerot;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zptt02_(char *, integer *, integer *,
doublereal *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *), zptt05_(
integer *, integer *, doublereal *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *,
doublereal *), zptsv_(integer *, integer *, doublereal *,
doublecomplex *, doublecomplex *, integer *, integer *), zlatb4_(
char *, integer *, integer *, integer *, char *, integer *,
integer *, doublereal *, integer *, doublereal *, char *), aladhd_(integer *, char *), alaerh_(char
*, char *, integer *, integer *, char *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *);
extern integer idamax_(integer *, doublereal *, integer *);
doublereal rcondc;
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *), alasvm_(char *, integer *, integer *,
integer *, integer *), dlarnv_(integer *, integer *,
integer *, doublereal *);
doublereal ainvnm;
extern doublereal zlanht_(char *, integer *, doublereal *, doublecomplex *
);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dzasum_(integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlaptm_(char *, integer *, integer *, doublereal *,
doublereal *, doublecomplex *, doublecomplex *, integer *,
doublereal *, doublecomplex *, integer *), zlatms_(
integer *, integer *, char *, integer *, char *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *, char
*, doublecomplex *, integer *, doublecomplex *, integer *), zlarnv_(integer *, integer *, integer *,
doublecomplex *);
doublereal result[6];
extern /* Subroutine */ int zpttrf_(integer *, doublereal *,
doublecomplex *, integer *), zerrvx_(char *, integer *),
zpttrs_(char *, integer *, integer *, doublereal *, doublecomplex
*, doublecomplex *, integer *, integer *), zptsvx_(char *,
integer *, integer *, doublereal *, doublecomplex *, doublereal *
, doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublereal *, doublereal *, doublereal *,
doublecomplex *, doublereal *, integer *);
/* Fortran I/O blocks */
static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZDRVPT tests ZPTSV and -SVX. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors to be generated for */
/* each linear system. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) COMPLEX*16 array, dimension (NMAX*2) */
/* D (workspace) DOUBLE PRECISION array, dimension (NMAX*2) */
/* E (workspace) COMPLEX*16 array, dimension (NMAX*2) */
/* B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
/* X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
/* WORK (workspace) COMPLEX*16 array, dimension */
/* (NMAX*max(3,NRHS)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--rwork;
--work;
--xact;
--x;
--b;
--e;
--d__;
--a;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "PT", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
zerrvx_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
lda = max(1,n);
nimat = 12;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (n > 0 && ! dotype[imat]) {
goto L110;
}
/* Set up parameters with ZLATB4. */
zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cond, dist);
zerot = imat >= 8 && imat <= 10;
if (imat <= 6) {
/* Type 1-6: generate a symmetric tridiagonal matrix of */
/* known condition number in lower triangular band storage. */
s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)6, (ftnlen)6);
zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
&anorm, &kl, &ku, "B", &a[1], &c__2, &work[1], &info);
/* Check the error code from ZLATMS. */
if (info != 0) {
alaerh_(path, "ZLATMS", &info, &c__0, " ", &n, &n, &kl, &
ku, &c_n1, &imat, &nfail, &nerrs, nout);
goto L110;
}
izero = 0;
/* Copy the matrix to D and E. */
ia = 1;
i__3 = n - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
i__5 = ia;
d__[i__4] = a[i__5].r;
i__4 = i__;
i__5 = ia + 1;
e[i__4].r = a[i__5].r, e[i__4].i = a[i__5].i;
ia += 2;
/* L20: */
}
if (n > 0) {
i__3 = n;
i__4 = ia;
d__[i__3] = a[i__4].r;
}
} else {
/* Type 7-12: generate a diagonally dominant matrix with */
/* unknown condition number in the vectors D and E. */
if (! zerot || ! dotype[7]) {
/* Let D and E have values from [-1,1]. */
dlarnv_(&c__2, iseed, &n, &d__[1]);
i__3 = n - 1;
zlarnv_(&c__2, iseed, &i__3, &e[1]);
/* Make the tridiagonal matrix diagonally dominant. */
if (n == 1) {
d__[1] = abs(d__[1]);
} else {
d__[1] = abs(d__[1]) + z_abs(&e[1]);
d__[n] = (d__1 = d__[n], abs(d__1)) + z_abs(&e[n - 1])
;
i__3 = n - 1;
for (i__ = 2; i__ <= i__3; ++i__) {
d__[i__] = (d__1 = d__[i__], abs(d__1)) + z_abs(&
e[i__]) + z_abs(&e[i__ - 1]);
/* L30: */
}
}
/* Scale D and E so the maximum element is ANORM. */
ix = idamax_(&n, &d__[1], &c__1);
dmax__ = d__[ix];
d__1 = anorm / dmax__;
dscal_(&n, &d__1, &d__[1], &c__1);
if (n > 1) {
i__3 = n - 1;
d__1 = anorm / dmax__;
zdscal_(&i__3, &d__1, &e[1], &c__1);
}
} else if (izero > 0) {
/* Reuse the last matrix by copying back the zeroed out */
/* elements. */
if (izero == 1) {
d__[1] = z__[1];
if (n > 1) {
e[1].r = z__[2], e[1].i = 0.;
}
} else if (izero == n) {
i__3 = n - 1;
e[i__3].r = z__[0], e[i__3].i = 0.;
d__[n] = z__[1];
} else {
i__3 = izero - 1;
e[i__3].r = z__[0], e[i__3].i = 0.;
d__[izero] = z__[1];
i__3 = izero;
e[i__3].r = z__[2], e[i__3].i = 0.;
}
}
/* For types 8-10, set one row and column of the matrix to */
/* zero. */
izero = 0;
if (imat == 8) {
izero = 1;
z__[1] = d__[1];
d__[1] = 0.;
if (n > 1) {
z__[2] = e[1].r;
e[1].r = 0., e[1].i = 0.;
}
} else if (imat == 9) {
izero = n;
if (n > 1) {
i__3 = n - 1;
z__[0] = e[i__3].r;
i__3 = n - 1;
e[i__3].r = 0., e[i__3].i = 0.;
}
z__[1] = d__[n];
d__[n] = 0.;
} else if (imat == 10) {
izero = (n + 1) / 2;
if (izero > 1) {
i__3 = izero - 1;
z__[0] = e[i__3].r;
i__3 = izero - 1;
e[i__3].r = 0., e[i__3].i = 0.;
i__3 = izero;
z__[2] = e[i__3].r;
i__3 = izero;
e[i__3].r = 0., e[i__3].i = 0.;
}
z__[1] = d__[izero];
d__[izero] = 0.;
}
}
/* Generate NRHS random solution vectors. */
ix = 1;
i__3 = *nrhs;
for (j = 1; j <= i__3; ++j) {
zlarnv_(&c__2, iseed, &n, &xact[ix]);
ix += lda;
/* L40: */
}
/* Set the right hand side. */
zlaptm_("Lower", &n, nrhs, &c_b24, &d__[1], &e[1], &xact[1], &lda,
&c_b25, &b[1], &lda);
for (ifact = 1; ifact <= 2; ++ifact) {
if (ifact == 1) {
*(unsigned char *)fact = 'F';
} else {
*(unsigned char *)fact = 'N';
}
/* Compute the condition number for comparison with */
/* the value returned by ZPTSVX. */
if (zerot) {
if (ifact == 1) {
goto L100;
}
rcondc = 0.;
} else if (ifact == 1) {
/* Compute the 1-norm of A. */
anorm = zlanht_("1", &n, &d__[1], &e[1]);
dcopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
if (n > 1) {
i__3 = n - 1;
zcopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
}
/* Factor the matrix A. */
zpttrf_(&n, &d__[n + 1], &e[n + 1], &info);
/* Use ZPTTRS to solve for one column at a time of */
/* inv(A), computing the maximum column sum as we go. */
ainvnm = 0.;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
i__5 = j;
x[i__5].r = 0., x[i__5].i = 0.;
/* L50: */
}
i__4 = i__;
x[i__4].r = 1., x[i__4].i = 0.;
zpttrs_("Lower", &n, &c__1, &d__[n + 1], &e[n + 1], &
x[1], &lda, &info);
/* Computing MAX */
d__1 = ainvnm, d__2 = dzasum_(&n, &x[1], &c__1);
ainvnm = max(d__1,d__2);
/* L60: */
}
/* Compute the 1-norm condition number of A. */
if (anorm <= 0. || ainvnm <= 0.) {
rcondc = 1.;
} else {
rcondc = 1. / anorm / ainvnm;
}
}
if (ifact == 2) {
/* --- Test ZPTSV -- */
dcopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
if (n > 1) {
i__3 = n - 1;
zcopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
}
zlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
/* Factor A as L*D*L' and solve the system A*X = B. */
s_copy(srnamc_1.srnamt, "ZPTSV ", (ftnlen)6, (ftnlen)6);
zptsv_(&n, nrhs, &d__[n + 1], &e[n + 1], &x[1], &lda, &
info);
/* Check error code from ZPTSV . */
if (info != izero) {
alaerh_(path, "ZPTSV ", &info, &izero, " ", &n, &n, &
c__1, &c__1, nrhs, &imat, &nfail, &nerrs,
nout);
}
nt = 0;
if (izero == 0) {
/* Check the factorization by computing the ratio */
/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
zptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &
work[1], result);
/* Compute the residual in the solution. */
zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
zptt02_("Lower", &n, nrhs, &d__[1], &e[1], &x[1], &
lda, &work[1], &lda, &result[1]);
/* Check solution from generated exact solution. */
zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
}
/* Print information about the tests that did not pass */
/* the threshold. */
i__3 = nt;
for (k = 1; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, "ZPTSV ", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L70: */
}
nrun += nt;
}
/* --- Test ZPTSVX --- */
if (ifact > 1) {
/* Initialize D( N+1:2*N ) and E( N+1:2*N ) to zero. */
i__3 = n - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
d__[n + i__] = 0.;
i__4 = n + i__;
e[i__4].r = 0., e[i__4].i = 0.;
/* L80: */
}
if (n > 0) {
d__[n + n] = 0.;
}
}
zlaset_("Full", &n, nrhs, &c_b62, &c_b62, &x[1], &lda);
/* Solve the system and compute the condition number and */
/* error bounds using ZPTSVX. */
s_copy(srnamc_1.srnamt, "ZPTSVX", (ftnlen)6, (ftnlen)6);
zptsvx_(fact, &n, nrhs, &d__[1], &e[1], &d__[n + 1], &e[n + 1]
, &b[1], &lda, &x[1], &lda, &rcond, &rwork[1], &rwork[
*nrhs + 1], &work[1], &rwork[(*nrhs << 1) + 1], &info);
/* Check the error code from ZPTSVX. */
if (info != izero) {
alaerh_(path, "ZPTSVX", &info, &izero, fact, &n, &n, &
c__1, &c__1, nrhs, &imat, &nfail, &nerrs, nout);
}
if (izero == 0) {
if (ifact == 2) {
/* Check the factorization by computing the ratio */
/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
k1 = 1;
zptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &
work[1], result);
} else {
k1 = 2;
}
/* Compute the residual in the solution. */
zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
zptt02_("Lower", &n, nrhs, &d__[1], &e[1], &x[1], &lda, &
work[1], &lda, &result[1]);
/* Check solution from generated exact solution. */
zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[2]);
/* Check error bounds from iterative refinement. */
zptt05_(&n, nrhs, &d__[1], &e[1], &b[1], &lda, &x[1], &
lda, &xact[1], &lda, &rwork[1], &rwork[*nrhs + 1],
&result[3]);
} else {
k1 = 6;
}
/* Check the reciprocal of the condition number. */
result[5] = dget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = k1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, "ZPTSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
/* L90: */
}
nrun = nrun + 7 - k1;
L100:
;
}
L110:
;
}
/* L120: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of ZDRVPT */
} /* zdrvpt_ */
/* ----------------------------------------------------------------------| */
/* Subroutine */ int zgexpv(integer *n, integer *m, doublereal *t,
doublecomplex *v, doublecomplex *w, doublereal *tol, doublereal *
anorm, doublecomplex *wsp, integer *lwsp, integer *iwsp, integer *
liwsp, S_fp matvec, void *matvecdata, integer *itrace, integer *iflag)
{
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
complex q__1;
doublecomplex z__1;
/* Builtin functions */
/* Subroutine */ int s_stop(char *, ftnlen);
double sqrt(doublereal), d_sign(doublereal *, doublereal *), pow_di(
doublereal *, integer *), pow_dd(doublereal *, doublereal *),
d_lg10(doublereal *);
integer i_dnnt(doublereal *);
double d_int(doublereal *);
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle();
double z_abs(doublecomplex *);
/* Local variables */
static integer ibrkflag;
static doublereal step_min__, step_max__;
static integer i__, j;
static doublereal break_tol__;
static integer k1;
static doublereal p1, p2, p3;
static integer ih, mh, iv, ns, mx;
static doublereal xm;
static integer j1v;
static doublecomplex hij;
static doublereal sgn, eps, hj1j, sqr1, beta, hump;
static integer ifree, lfree;
static doublereal t_old__;
static integer iexph;
static doublereal t_new__;
static integer nexph;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal t_now__;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, ftnlen);
static integer nstep;
static doublereal t_out__;
static integer nmult;
static doublereal vnorm;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
static integer nscale;
static doublereal rndoff;
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *), zgpadm_(integer *, integer *,
doublereal *, doublecomplex *, integer *, doublecomplex *,
integer *, integer *, integer *, integer *, integer *), znchbv_(
integer *, doublereal *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *);
static doublereal t_step__, avnorm;
static integer ireject;
static doublereal err_loc__;
static integer nreject, mbrkdwn;
static doublereal tbrkdwn, s_error__, x_error__;
/* Fortran I/O blocks */
static cilist io___40 = { 0, 6, 0, 0, 0 };
static cilist io___48 = { 0, 6, 0, 0, 0 };
static cilist io___49 = { 0, 6, 0, 0, 0 };
static cilist io___50 = { 0, 6, 0, 0, 0 };
static cilist io___51 = { 0, 6, 0, 0, 0 };
static cilist io___52 = { 0, 6, 0, 0, 0 };
static cilist io___53 = { 0, 6, 0, 0, 0 };
static cilist io___54 = { 0, 6, 0, 0, 0 };
static cilist io___55 = { 0, 6, 0, 0, 0 };
static cilist io___56 = { 0, 6, 0, 0, 0 };
static cilist io___57 = { 0, 6, 0, 0, 0 };
static cilist io___58 = { 0, 6, 0, 0, 0 };
static cilist io___59 = { 0, 6, 0, 0, 0 };
/* -----Purpose----------------------------------------------------------| */
/* --- ZGEXPV computes w = exp(t*A)*v */
/* for a Zomplex (i.e., complex double precision) matrix A */
/* It does not compute the matrix exponential in isolation but */
/* instead, it computes directly the action of the exponential */
/* operator on the operand vector. This way of doing so allows */
/* for addressing large sparse problems. */
/* The method used is based on Krylov subspace projection */
/* techniques and the matrix under consideration interacts only */
/* via the external routine `matvec' performing the matrix-vector */
/* product (matrix-free method). */
/* -----Arguments--------------------------------------------------------| */
/* n : (input) order of the principal matrix A. */
/* m : (input) maximum size for the Krylov basis. */
/* t : (input) time at wich the solution is needed (can be < 0). */
/* v(n) : (input) given operand vector. */
/* w(n) : (output) computed approximation of exp(t*A)*v. */
/* tol : (input/output) the requested accuracy tolerance on w. */
/* If on input tol=0.0d0 or tol is too small (tol.le.eps) */
/* the internal value sqrt(eps) is used, and tol is set to */
/* sqrt(eps) on output (`eps' denotes the machine epsilon). */
/* (`Happy breakdown' is assumed if h(j+1,j) .le. anorm*tol) */
/* anorm : (input) an approximation of some norm of A. */
/* wsp(lwsp): (workspace) lwsp .ge. n*(m+1)+n+(m+2)^2+4*(m+2)^2+ideg+1 */
/* +---------+-------+---------------+ */
/* (actually, ideg=6) V H wsp for PADE */
/* iwsp(liwsp): (workspace) liwsp .ge. m+2 */
/* matvec : external subroutine for matrix-vector multiplication. */
/* synopsis: matvec( x, y ) */
/* complex*16 x(*), y(*) */
/* computes: y(1:n) <- A*x(1:n) */
/* where A is the principal matrix. */
/* itrace : (input) running mode. 0=silent, 1=print step-by-step info */
/* iflag : (output) exit flag. */
/* <0 - bad input arguments */
/* 0 - no problem */
/* 1 - maximum number of steps reached without convergence */
/* 2 - requested tolerance was too high */
/* -----Accounts on the computation--------------------------------------| */
/* Upon exit, an interested user may retrieve accounts on the */
/* computations. They are located in the workspace arrays wsp and */
/* iwsp as indicated below: */
/* location mnemonic description */
/* -----------------------------------------------------------------| */
/* iwsp(1) = nmult, number of matrix-vector multiplications used */
/* iwsp(2) = nexph, number of Hessenberg matrix exponential evaluated */
/* iwsp(3) = nscale, number of repeated squaring involved in Pade */
/* iwsp(4) = nstep, number of integration steps used up to completion */
/* iwsp(5) = nreject, number of rejected step-sizes */
/* iwsp(6) = ibrkflag, set to 1 if `happy breakdown' and 0 otherwise */
/* iwsp(7) = mbrkdwn, if `happy brkdown', basis-size when it occured */
/* -----------------------------------------------------------------| */
/* wsp(1) = step_min, minimum step-size used during integration */
/* wsp(2) = step_max, maximum step-size used during integration */
/* wsp(3) = x_round, maximum among all roundoff errors (lower bound) */
/* wsp(4) = s_round, sum of roundoff errors (lower bound) */
/* wsp(5) = x_error, maximum among all local truncation errors */
/* wsp(6) = s_error, global sum of local truncation errors */
/* wsp(7) = tbrkdwn, if `happy breakdown', time when it occured */
/* wsp(8) = t_now, integration domain successfully covered */
/* wsp(9) = hump, i.e., max||exp(sA)||, s in [0,t] (or [t,0] if t<0) */
/* wsp(10) = ||w||/||v||, scaled norm of the solution w. */
/* -----------------------------------------------------------------| */
/* The `hump' is a measure of the conditioning of the problem. The */
/* matrix exponential is well-conditioned if hump = 1, whereas it is */
/* poorly-conditioned if hump >> 1. However the solution can still be */
/* relatively fairly accurate even when the hump is large (the hump */
/* is an upper bound), especially when the hump and the scaled norm */
/* of w [this is also computed and returned in wsp(10)] are of the */
/* same order of magnitude (further details in reference below). */
/* ----------------------------------------------------------------------| */
/* -----The following parameters may also be adjusted herein-------------| */
/* mxstep : maximum allowable number of integration steps. */
/* The value 0 means an infinite number of steps. */
/* mxreject: maximum allowable number of rejections at each step. */
/* The value 0 means an infinite number of rejections. */
/* ideg : the Pade approximation of type (ideg,ideg) is used as */
/* an approximation to exp(H). The value 0 switches to the */
/* uniform rational Chebyshev approximation of type (14,14) */
/* delta : local truncation error `safety factor' */
/* gamma : stepsize `shrinking factor' */
/* ----------------------------------------------------------------------| */
/* Roger B. Sidje ([email protected]) */
/* EXPOKIT: Software Package for Computing Matrix Exponentials. */
/* ACM - Transactions On Mathematical Software, 24(1):130-156, 1998 */
/* ----------------------------------------------------------------------| */
/* --- check restrictions on input parameters ... */
/* Parameter adjustments */
--w;
--v;
--wsp;
--iwsp;
/* Function Body */
*iflag = 0;
/* Computing 2nd power */
i__1 = *m + 2;
if (*lwsp < *n * (*m + 2) + i__1 * i__1 * 5 + 7) {
*iflag = -1;
}
if (*liwsp < *m + 2) {
*iflag = -2;
}
if (*m >= *n || *m <= 0) {
*iflag = -3;
}
if (*iflag != 0) {
s_stop("bad sizes (in input of ZGEXPV)", (ftnlen)30);
}
/* --- initialisations ... */
k1 = 2;
mh = *m + 2;
iv = 1;
ih = iv + *n * (*m + 1) + *n;
ifree = ih + mh * mh;
lfree = *lwsp - ifree + 1;
ibrkflag = 0;
mbrkdwn = *m;
nmult = 0;
nreject = 0;
nexph = 0;
nscale = 0;
t_out__ = abs(*t);
tbrkdwn = 0.;
step_min__ = t_out__;
step_max__ = 0.;
nstep = 0;
s_error__ = 0.;
x_error__ = 0.;
t_now__ = 0.;
t_new__ = 0.;
p1 = 1.3333333333333333;
L1:
p2 = p1 - 1.;
p3 = p2 + p2 + p2;
eps = (d__1 = p3 - 1., abs(d__1));
if (eps == 0.) {
goto L1;
}
if (*tol <= eps) {
*tol = sqrt(eps);
}
rndoff = eps * *anorm;
break_tol__ = 1e-7;
/* >>> break_tol = tol */
/* >>> break_tol = anorm*tol */
sgn = d_sign(&c_b6, t);
zcopy_(n, &v[1], &c__1, &w[1], &c__1);
beta = dznrm2_(n, &w[1], &c__1);
vnorm = beta;
hump = beta;
/* --- obtain the very first stepsize ... */
sqr1 = sqrt(.1);
xm = 1. / (doublereal) (*m);
d__1 = (*m + 1) / 2.72;
i__1 = *m + 1;
p2 = *tol * pow_di(&d__1, &i__1) * sqrt((*m + 1) * 6.2800000000000002);
d__1 = p2 / (beta * 4. * *anorm);
t_new__ = 1. / *anorm * pow_dd(&d__1, &xm);
d__1 = d_lg10(&t_new__) - sqr1;
i__1 = i_dnnt(&d__1) - 1;
p1 = pow_di(&c_b10, &i__1);
d__1 = t_new__ / p1 + .55;
t_new__ = d_int(&d__1) * p1;
/* --- step-by-step integration ... */
L100:
if (t_now__ >= t_out__) {
goto L500;
}
++nstep;
/* Computing MIN */
d__1 = t_out__ - t_now__;
t_step__ = min(d__1,t_new__);
p1 = 1. / beta;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iv + i__ - 1;
i__3 = i__;
z__1.r = p1 * w[i__3].r, z__1.i = p1 * w[i__3].i;
wsp[i__2].r = z__1.r, wsp[i__2].i = z__1.i;
}
i__1 = mh * mh;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = ih + i__ - 1;
wsp[i__2].r = 0., wsp[i__2].i = 0.;
}
/* --- Arnoldi loop ... */
j1v = iv + *n;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
++nmult;
(*matvec)(matvecdata, &wsp[j1v - *n], &wsp[j1v]);
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
zdotc_(&z__1, n, &wsp[iv + (i__ - 1) * *n], &c__1, &wsp[j1v], &
c__1);
hij.r = z__1.r, hij.i = z__1.i;
z__1.r = -hij.r, z__1.i = -hij.i;
zaxpy_(n, &z__1, &wsp[iv + (i__ - 1) * *n], &c__1, &wsp[j1v], &
c__1);
i__3 = ih + (j - 1) * mh + i__ - 1;
wsp[i__3].r = hij.r, wsp[i__3].i = hij.i;
}
hj1j = dznrm2_(n, &wsp[j1v], &c__1);
/* --- if `happy breakdown' go straightforward at the end ... */
if (hj1j <= break_tol__) {
s_wsle(&io___40);
do_lio(&c__9, &c__1, "happy breakdown: mbrkdwn =", (ftnlen)26);
do_lio(&c__3, &c__1, (char *)&j, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, " h =", (ftnlen)4);
do_lio(&c__5, &c__1, (char *)&hj1j, (ftnlen)sizeof(doublereal));
e_wsle();
k1 = 0;
ibrkflag = 1;
mbrkdwn = j;
tbrkdwn = t_now__;
t_step__ = t_out__ - t_now__;
goto L300;
}
i__2 = ih + (j - 1) * mh + j;
q__1.r = hj1j, q__1.i = (float)0.;
wsp[i__2].r = q__1.r, wsp[i__2].i = q__1.i;
d__1 = 1. / hj1j;
zdscal_(n, &d__1, &wsp[j1v], &c__1);
j1v += *n;
/* L200: */
}
++nmult;
(*matvec)(matvecdata, &wsp[j1v - *n], &wsp[j1v]);
avnorm = dznrm2_(n, &wsp[j1v], &c__1);
/* --- set 1 for the 2-corrected scheme ... */
L300:
i__1 = ih + *m * mh + *m + 1;
wsp[i__1].r = 1., wsp[i__1].i = 0.;
/* --- loop while ireject<mxreject until the tolerance is reached ... */
ireject = 0;
L401:
/* --- compute w = beta*V*exp(t_step*H)*e1 ... */
++nexph;
mx = mbrkdwn + k1;
if (TRUE_) {
/* --- irreducible rational Pade approximation ... */
d__1 = sgn * t_step__;
zgpadm_(&c__6, &mx, &d__1, &wsp[ih], &mh, &wsp[ifree], &lfree, &iwsp[
1], &iexph, &ns, iflag);
iexph = ifree + iexph - 1;
nscale += ns;
} else {
/* --- uniform rational Chebyshev approximation ... */
iexph = ifree;
i__1 = mx;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iexph + i__ - 1;
wsp[i__2].r = 0., wsp[i__2].i = 0.;
}
i__1 = iexph;
wsp[i__1].r = 1., wsp[i__1].i = 0.;
d__1 = sgn * t_step__;
znchbv_(&mx, &d__1, &wsp[ih], &mh, &wsp[iexph], &wsp[ifree + mx]);
}
/* L402: */
/* --- error estimate ... */
if (k1 == 0) {
err_loc__ = *tol;
} else {
p1 = z_abs(&wsp[iexph + *m]) * beta;
p2 = z_abs(&wsp[iexph + *m + 1]) * beta * avnorm;
if (p1 > p2 * 10.) {
err_loc__ = p2;
xm = 1. / (doublereal) (*m);
} else if (p1 > p2) {
err_loc__ = p1 * p2 / (p1 - p2);
xm = 1. / (doublereal) (*m);
} else {
err_loc__ = p1;
xm = 1. / (doublereal) (*m - 1);
}
}
/* --- reject the step-size if the error is not acceptable ... */
if (k1 != 0 && err_loc__ > t_step__ * 1.2 * *tol) {
t_old__ = t_step__;
d__1 = t_step__ * *tol / err_loc__;
t_step__ = t_step__ * .9 * pow_dd(&d__1, &xm);
d__1 = d_lg10(&t_step__) - sqr1;
i__1 = i_dnnt(&d__1) - 1;
p1 = pow_di(&c_b10, &i__1);
d__1 = t_step__ / p1 + .55;
t_step__ = d_int(&d__1) * p1;
if (*itrace != 0) {
s_wsle(&io___48);
do_lio(&c__9, &c__1, "t_step =", (ftnlen)8);
do_lio(&c__5, &c__1, (char *)&t_old__, (ftnlen)sizeof(doublereal))
;
e_wsle();
s_wsle(&io___49);
do_lio(&c__9, &c__1, "err_loc =", (ftnlen)9);
do_lio(&c__5, &c__1, (char *)&err_loc__, (ftnlen)sizeof(
doublereal));
e_wsle();
s_wsle(&io___50);
do_lio(&c__9, &c__1, "err_required =", (ftnlen)14);
d__1 = t_old__ * 1.2 * *tol;
do_lio(&c__5, &c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsle();
s_wsle(&io___51);
do_lio(&c__9, &c__1, "stepsize rejected, stepping down to:", (
ftnlen)36);
do_lio(&c__5, &c__1, (char *)&t_step__, (ftnlen)sizeof(doublereal)
);
e_wsle();
}
++ireject;
++nreject;
if (FALSE_) {
s_wsle(&io___52);
do_lio(&c__9, &c__1, "Failure in ZGEXPV: ---", (ftnlen)22);
e_wsle();
s_wsle(&io___53);
do_lio(&c__9, &c__1, "The requested tolerance is too high.", (
ftnlen)36);
e_wsle();
s_wsle(&io___54);
do_lio(&c__9, &c__1, "Rerun with a smaller value.", (ftnlen)27);
e_wsle();
*iflag = 2;
return 0;
}
goto L401;
}
/* --- now update w = beta*V*exp(t_step*H)*e1 and the hump ... */
/* Computing MAX */
i__1 = 0, i__2 = k1 - 1;
mx = mbrkdwn + max(i__1,i__2);
q__1.r = beta, q__1.i = (float)0.;
hij.r = q__1.r, hij.i = q__1.i;
zgemv_("n", n, &mx, &hij, &wsp[iv], n, &wsp[iexph], &c__1, &c_b1, &w[1], &
c__1, (ftnlen)1);
beta = dznrm2_(n, &w[1], &c__1);
hump = max(hump,beta);
/* --- suggested value for the next stepsize ... */
d__1 = t_step__ * *tol / err_loc__;
t_new__ = t_step__ * .9 * pow_dd(&d__1, &xm);
d__1 = d_lg10(&t_new__) - sqr1;
i__1 = i_dnnt(&d__1) - 1;
p1 = pow_di(&c_b10, &i__1);
d__1 = t_new__ / p1 + .55;
t_new__ = d_int(&d__1) * p1;
err_loc__ = max(err_loc__,rndoff);
/* --- update the time covered ... */
t_now__ += t_step__;
/* --- display and keep some information ... */
if (*itrace != 0) {
s_wsle(&io___55);
do_lio(&c__9, &c__1, "integration", (ftnlen)11);
do_lio(&c__3, &c__1, (char *)&nstep, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, "---------------------------------", (ftnlen)33);
e_wsle();
s_wsle(&io___56);
do_lio(&c__9, &c__1, "scale-square =", (ftnlen)14);
do_lio(&c__3, &c__1, (char *)&ns, (ftnlen)sizeof(integer));
e_wsle();
s_wsle(&io___57);
do_lio(&c__9, &c__1, "step_size =", (ftnlen)11);
do_lio(&c__5, &c__1, (char *)&t_step__, (ftnlen)sizeof(doublereal));
e_wsle();
s_wsle(&io___58);
do_lio(&c__9, &c__1, "err_loc =", (ftnlen)11);
do_lio(&c__5, &c__1, (char *)&err_loc__, (ftnlen)sizeof(doublereal));
e_wsle();
s_wsle(&io___59);
do_lio(&c__9, &c__1, "next_step =", (ftnlen)11);
do_lio(&c__5, &c__1, (char *)&t_new__, (ftnlen)sizeof(doublereal));
e_wsle();
}
step_min__ = min(step_min__,t_step__);
step_max__ = max(step_max__,t_step__);
s_error__ += err_loc__;
x_error__ = max(x_error__,err_loc__);
if (nstep < 500) {
goto L100;
}
*iflag = 1;
L500:
iwsp[1] = nmult;
iwsp[2] = nexph;
iwsp[3] = nscale;
iwsp[4] = nstep;
iwsp[5] = nreject;
iwsp[6] = ibrkflag;
iwsp[7] = mbrkdwn;
q__1.r = step_min__, q__1.i = (float)0.;
wsp[1].r = q__1.r, wsp[1].i = q__1.i;
q__1.r = step_max__, q__1.i = (float)0.;
wsp[2].r = q__1.r, wsp[2].i = q__1.i;
wsp[3].r = (float)0., wsp[3].i = (float)0.;
wsp[4].r = (float)0., wsp[4].i = (float)0.;
q__1.r = x_error__, q__1.i = (float)0.;
wsp[5].r = q__1.r, wsp[5].i = q__1.i;
q__1.r = s_error__, q__1.i = (float)0.;
wsp[6].r = q__1.r, wsp[6].i = q__1.i;
q__1.r = tbrkdwn, q__1.i = (float)0.;
wsp[7].r = q__1.r, wsp[7].i = q__1.i;
d__1 = sgn * t_now__;
q__1.r = d__1, q__1.i = (float)0.;
wsp[8].r = q__1.r, wsp[8].i = q__1.i;
d__1 = hump / vnorm;
q__1.r = d__1, q__1.i = (float)0.;
wsp[9].r = q__1.r, wsp[9].i = q__1.i;
d__1 = beta / vnorm;
q__1.r = d__1, q__1.i = (float)0.;
wsp[10].r = q__1.r, wsp[10].i = q__1.i;
return 0;
} /* zgexpv_ */
/* Subroutine */ int ztrevc_(char *side, char *howmny, logical *select,
integer *n, doublecomplex *t, integer *ldt, doublecomplex *vl,
integer *ldvl, doublecomplex *vr, integer *ldvr, integer *mm, integer
*m, doublecomplex *work, doublereal *rwork, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
ZTREVC computes some or all of the right and/or left eigenvectors of
a complex upper triangular matrix T.
The right eigenvector x and the left eigenvector y of T corresponding
to an eigenvalue w are defined by:
T*x = w*x, y'*T = w*y'
where y' denotes the conjugate transpose of the vector y.
If all eigenvectors are requested, the routine may either return the
matrices X and/or Y of right or left eigenvectors of T, or the
products Q*X and/or Q*Y, where Q is an input unitary
matrix. If T was obtained from the Schur factorization of an
original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of
right or left eigenvectors of A.
Arguments
=========
SIDE (input) CHARACTER*1
= 'R': compute right eigenvectors only;
= 'L': compute left eigenvectors only;
= 'B': compute both right and left eigenvectors.
HOWMNY (input) CHARACTER*1
= 'A': compute all right and/or left eigenvectors;
= 'B': compute all right and/or left eigenvectors,
and backtransform them using the input matrices
supplied in VR and/or VL;
= 'S': compute selected right and/or left eigenvectors,
specified by the logical array SELECT.
SELECT (input) LOGICAL array, dimension (N)
If HOWMNY = 'S', SELECT specifies the eigenvectors to be
computed.
If HOWMNY = 'A' or 'B', SELECT is not referenced.
To select the eigenvector corresponding to the j-th
eigenvalue, SELECT(j) must be set to .TRUE..
N (input) INTEGER
The order of the matrix T. N >= 0.
T (input/output) COMPLEX*16 array, dimension (LDT,N)
The upper triangular matrix T. T is modified, but restored
on exit.
LDT (input) INTEGER
The leading dimension of the array T. LDT >= max(1,N).
VL (input/output) COMPLEX*16 array, dimension (LDVL,MM)
On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
contain an N-by-N matrix Q (usually the unitary matrix Q of
Schur vectors returned by ZHSEQR).
On exit, if SIDE = 'L' or 'B', VL contains:
if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
VL is lower triangular. The i-th column
VL(i) of VL is the eigenvector corresponding
to T(i,i).
if HOWMNY = 'B', the matrix Q*Y;
if HOWMNY = 'S', the left eigenvectors of T specified by
SELECT, stored consecutively in the columns
of VL, in the same order as their
eigenvalues.
If SIDE = 'R', VL is not referenced.
LDVL (input) INTEGER
The leading dimension of the array VL. LDVL >= max(1,N) if
SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
VR (input/output) COMPLEX*16 array, dimension (LDVR,MM)
On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
contain an N-by-N matrix Q (usually the unitary matrix Q of
Schur vectors returned by ZHSEQR).
On exit, if SIDE = 'R' or 'B', VR contains:
if HOWMNY = 'A', the matrix X of right eigenvectors of T;
VR is upper triangular. The i-th column
VR(i) of VR is the eigenvector corresponding
to T(i,i).
if HOWMNY = 'B', the matrix Q*X;
if HOWMNY = 'S', the right eigenvectors of T specified by
SELECT, stored consecutively in the columns
of VR, in the same order as their
eigenvalues.
If SIDE = 'L', VR is not referenced.
LDVR (input) INTEGER
The leading dimension of the array VR. LDVR >= max(1,N) if
SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
MM (input) INTEGER
The number of columns in the arrays VL and/or VR. MM >= M.
M (output) INTEGER
The number of columns in the arrays VL and/or VR actually
used to store the eigenvectors. If HOWMNY = 'A' or 'B', M
is set to N. Each selected eigenvector occupies one
column.
WORK (workspace) COMPLEX*16 array, dimension (2*N)
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Further Details
===============
The algorithm used in this program is basically backward (forward)
substitution, with scaling to make the the code robust against
possible overflow.
Each eigenvector is normalized so that the element of largest
magnitude has magnitude 1; here the magnitude of a complex number
(x,y) is taken to be |x| + |y|.
=====================================================================
Decode and test the input parameters
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b2 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static logical allv;
static doublereal unfl, ovfl, smin;
static logical over;
static integer i__, j, k;
static doublereal scale;
extern logical lsame_(char *, char *);
static doublereal remax;
static logical leftv, bothv;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static logical somev;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
static integer ii, ki;
extern doublereal dlamch_(char *);
static integer is;
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *);
extern integer izamax_(integer *, doublecomplex *, integer *);
static logical rightv;
extern doublereal dzasum_(integer *, doublecomplex *, integer *);
static doublereal smlnum;
extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, doublereal *, integer *);
static doublereal ulp;
#define t_subscr(a_1,a_2) (a_2)*t_dim1 + a_1
#define t_ref(a_1,a_2) t[t_subscr(a_1,a_2)]
#define vl_subscr(a_1,a_2) (a_2)*vl_dim1 + a_1
#define vl_ref(a_1,a_2) vl[vl_subscr(a_1,a_2)]
#define vr_subscr(a_1,a_2) (a_2)*vr_dim1 + a_1
#define vr_ref(a_1,a_2) vr[vr_subscr(a_1,a_2)]
--select;
t_dim1 = *ldt;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1 * 1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1 * 1;
vr -= vr_offset;
--work;
--rwork;
/* Function Body */
bothv = lsame_(side, "B");
rightv = lsame_(side, "R") || bothv;
leftv = lsame_(side, "L") || bothv;
allv = lsame_(howmny, "A");
over = lsame_(howmny, "B");
somev = lsame_(howmny, "S");
/* Set M to the number of columns required to store the selected
eigenvectors. */
if (somev) {
*m = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (select[j]) {
++(*m);
}
/* L10: */
}
} else {
*m = *n;
}
*info = 0;
if (! rightv && ! leftv) {
*info = -1;
} else if (! allv && ! over && ! somev) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*ldt < max(1,*n)) {
*info = -6;
} else if (*ldvl < 1 || leftv && *ldvl < *n) {
*info = -8;
} else if (*ldvr < 1 || rightv && *ldvr < *n) {
*info = -10;
} else if (*mm < *m) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTREVC", &i__1);
return 0;
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
/* Set the constants to control overflow. */
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Precision");
smlnum = unfl * (*n / ulp);
/* Store the diagonal elements of T in working array WORK. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + *n;
i__3 = t_subscr(i__, i__);
work[i__2].r = t[i__3].r, work[i__2].i = t[i__3].i;
/* L20: */
}
/* Compute 1-norm of each column of strictly upper triangular
part of T to control overflow in triangular solver. */
rwork[1] = 0.;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
i__2 = j - 1;
rwork[j] = dzasum_(&i__2, &t_ref(1, j), &c__1);
/* L30: */
}
if (rightv) {
/* Compute right eigenvectors. */
is = *m;
for (ki = *n; ki >= 1; --ki) {
if (somev) {
if (! select[ki]) {
goto L80;
}
}
/* Computing MAX */
i__1 = t_subscr(ki, ki);
d__3 = ulp * ((d__1 = t[i__1].r, abs(d__1)) + (d__2 = d_imag(&
t_ref(ki, ki)), abs(d__2)));
smin = max(d__3,smlnum);
work[1].r = 1., work[1].i = 0.;
/* Form right-hand side. */
i__1 = ki - 1;
for (k = 1; k <= i__1; ++k) {
i__2 = k;
i__3 = t_subscr(k, ki);
z__1.r = -t[i__3].r, z__1.i = -t[i__3].i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L40: */
}
/* Solve the triangular system:
(T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK. */
i__1 = ki - 1;
for (k = 1; k <= i__1; ++k) {
i__2 = t_subscr(k, k);
i__3 = t_subscr(k, k);
i__4 = t_subscr(ki, ki);
z__1.r = t[i__3].r - t[i__4].r, z__1.i = t[i__3].i - t[i__4]
.i;
t[i__2].r = z__1.r, t[i__2].i = z__1.i;
i__2 = t_subscr(k, k);
if ((d__1 = t[i__2].r, abs(d__1)) + (d__2 = d_imag(&t_ref(k,
k)), abs(d__2)) < smin) {
i__3 = t_subscr(k, k);
t[i__3].r = smin, t[i__3].i = 0.;
}
/* L50: */
}
if (ki > 1) {
i__1 = ki - 1;
zlatrs_("Upper", "No transpose", "Non-unit", "Y", &i__1, &t[
t_offset], ldt, &work[1], &scale, &rwork[1], info);
i__1 = ki;
work[i__1].r = scale, work[i__1].i = 0.;
}
/* Copy the vector x or Q*x to VR and normalize. */
if (! over) {
zcopy_(&ki, &work[1], &c__1, &vr_ref(1, is), &c__1);
ii = izamax_(&ki, &vr_ref(1, is), &c__1);
i__1 = vr_subscr(ii, is);
remax = 1. / ((d__1 = vr[i__1].r, abs(d__1)) + (d__2 = d_imag(
&vr_ref(ii, is)), abs(d__2)));
zdscal_(&ki, &remax, &vr_ref(1, is), &c__1);
i__1 = *n;
for (k = ki + 1; k <= i__1; ++k) {
i__2 = vr_subscr(k, is);
vr[i__2].r = 0., vr[i__2].i = 0.;
/* L60: */
}
} else {
if (ki > 1) {
i__1 = ki - 1;
z__1.r = scale, z__1.i = 0.;
zgemv_("N", n, &i__1, &c_b2, &vr[vr_offset], ldvr, &work[
1], &c__1, &z__1, &vr_ref(1, ki), &c__1);
}
ii = izamax_(n, &vr_ref(1, ki), &c__1);
i__1 = vr_subscr(ii, ki);
remax = 1. / ((d__1 = vr[i__1].r, abs(d__1)) + (d__2 = d_imag(
&vr_ref(ii, ki)), abs(d__2)));
zdscal_(n, &remax, &vr_ref(1, ki), &c__1);
}
/* Set back the original diagonal elements of T. */
i__1 = ki - 1;
for (k = 1; k <= i__1; ++k) {
i__2 = t_subscr(k, k);
i__3 = k + *n;
t[i__2].r = work[i__3].r, t[i__2].i = work[i__3].i;
/* L70: */
}
--is;
L80:
;
}
}
if (leftv) {
/* Compute left eigenvectors. */
is = 1;
i__1 = *n;
for (ki = 1; ki <= i__1; ++ki) {
if (somev) {
if (! select[ki]) {
goto L130;
}
}
/* Computing MAX */
i__2 = t_subscr(ki, ki);
d__3 = ulp * ((d__1 = t[i__2].r, abs(d__1)) + (d__2 = d_imag(&
t_ref(ki, ki)), abs(d__2)));
smin = max(d__3,smlnum);
i__2 = *n;
work[i__2].r = 1., work[i__2].i = 0.;
/* Form right-hand side. */
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
i__3 = k;
d_cnjg(&z__2, &t_ref(ki, k));
z__1.r = -z__2.r, z__1.i = -z__2.i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L90: */
}
/* Solve the triangular system:
(T(KI+1:N,KI+1:N) - T(KI,KI))'*X = SCALE*WORK. */
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
i__3 = t_subscr(k, k);
i__4 = t_subscr(k, k);
i__5 = t_subscr(ki, ki);
z__1.r = t[i__4].r - t[i__5].r, z__1.i = t[i__4].i - t[i__5]
.i;
t[i__3].r = z__1.r, t[i__3].i = z__1.i;
i__3 = t_subscr(k, k);
if ((d__1 = t[i__3].r, abs(d__1)) + (d__2 = d_imag(&t_ref(k,
k)), abs(d__2)) < smin) {
i__4 = t_subscr(k, k);
t[i__4].r = smin, t[i__4].i = 0.;
}
/* L100: */
}
if (ki < *n) {
i__2 = *n - ki;
zlatrs_("Upper", "Conjugate transpose", "Non-unit", "Y", &
i__2, &t_ref(ki + 1, ki + 1), ldt, &work[ki + 1], &
scale, &rwork[1], info);
i__2 = ki;
work[i__2].r = scale, work[i__2].i = 0.;
}
/* Copy the vector x or Q*x to VL and normalize. */
if (! over) {
i__2 = *n - ki + 1;
zcopy_(&i__2, &work[ki], &c__1, &vl_ref(ki, is), &c__1);
i__2 = *n - ki + 1;
ii = izamax_(&i__2, &vl_ref(ki, is), &c__1) + ki - 1;
i__2 = vl_subscr(ii, is);
remax = 1. / ((d__1 = vl[i__2].r, abs(d__1)) + (d__2 = d_imag(
&vl_ref(ii, is)), abs(d__2)));
i__2 = *n - ki + 1;
zdscal_(&i__2, &remax, &vl_ref(ki, is), &c__1);
i__2 = ki - 1;
for (k = 1; k <= i__2; ++k) {
i__3 = vl_subscr(k, is);
vl[i__3].r = 0., vl[i__3].i = 0.;
/* L110: */
}
} else {
if (ki < *n) {
i__2 = *n - ki;
z__1.r = scale, z__1.i = 0.;
zgemv_("N", n, &i__2, &c_b2, &vl_ref(1, ki + 1), ldvl, &
work[ki + 1], &c__1, &z__1, &vl_ref(1, ki), &c__1);
}
ii = izamax_(n, &vl_ref(1, ki), &c__1);
i__2 = vl_subscr(ii, ki);
remax = 1. / ((d__1 = vl[i__2].r, abs(d__1)) + (d__2 = d_imag(
&vl_ref(ii, ki)), abs(d__2)));
zdscal_(n, &remax, &vl_ref(1, ki), &c__1);
}
/* Set back the original diagonal elements of T. */
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
i__3 = t_subscr(k, k);
i__4 = k + *n;
t[i__3].r = work[i__4].r, t[i__3].i = work[i__4].i;
/* L120: */
}
++is;
L130:
;
}
}
return 0;
/* End of ZTREVC */
} /* ztrevc_ */
/* Subroutine */ int 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_ */
/* Subroutine */
int zlarfgp_(integer *n, doublecomplex *alpha, doublecomplex *x, integer *incx, doublecomplex *tau)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *), d_sign(doublereal *, doublereal *), z_abs( doublecomplex *);
/* Local variables */
integer j;
doublecomplex savealpha;
integer knt;
doublereal beta, alphi, alphr;
extern /* Subroutine */
int zscal_(integer *, doublecomplex *, doublecomplex *, integer *);
doublereal xnorm;
extern doublereal dlapy2_(doublereal *, doublereal *), dlapy3_(doublereal *, doublereal *, doublereal *), dznrm2_(integer *, doublecomplex * , integer *), dlamch_(char *);
extern /* Subroutine */
int zdscal_(integer *, doublereal *, doublecomplex *, integer *);
doublereal bignum;
extern /* Double Complex */
VOID zladiv_(doublecomplex *, doublecomplex *, doublecomplex *);
doublereal smlnum;
/* -- LAPACK auxiliary routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--x;
/* Function Body */
if (*n <= 0)
{
tau->r = 0., tau->i = 0.;
return 0;
}
i__1 = *n - 1;
xnorm = dznrm2_(&i__1, &x[1], incx);
alphr = alpha->r;
alphi = d_imag(alpha);
if (xnorm == 0.)
{
/* H = [1-alpha/abs(alpha) 0;
0 I], sign chosen so ALPHA >= 0. */
if (alphi == 0.)
{
if (alphr >= 0.)
{
/* When TAU.eq.ZERO, the vector is special-cased to be */
/* all zeros in the application routines. We do not need */
/* to clear it. */
tau->r = 0., tau->i = 0.;
}
else
{
/* However, the application routines rely on explicit */
/* zero checks when TAU.ne.ZERO, and we must clear X. */
tau->r = 2., tau->i = 0.;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.;
x[i__2].i = 0.; // , expr subst
}
z__1.r = -alpha->r;
z__1.i = -alpha->i; // , expr subst
alpha->r = z__1.r, alpha->i = z__1.i;
}
}
else
{
/* Only "reflecting" the diagonal entry to be real and non-negative. */
xnorm = dlapy2_(&alphr, &alphi);
d__1 = 1. - alphr / xnorm;
d__2 = -alphi / xnorm;
z__1.r = d__1;
z__1.i = d__2; // , expr subst
tau->r = z__1.r, tau->i = z__1.i;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.;
x[i__2].i = 0.; // , expr subst
}
alpha->r = xnorm, alpha->i = 0.;
}
}
else
{
/* general case */
d__1 = dlapy3_(&alphr, &alphi, &xnorm);
beta = d_sign(&d__1, &alphr);
smlnum = dlamch_("S") / dlamch_("E");
bignum = 1. / smlnum;
knt = 0;
if (abs(beta) < smlnum)
{
/* XNORM, BETA may be inaccurate;
scale X and recompute them */
L10:
++knt;
i__1 = *n - 1;
zdscal_(&i__1, &bignum, &x[1], incx);
beta *= bignum;
alphi *= bignum;
alphr *= bignum;
if (abs(beta) < smlnum)
{
goto L10;
}
/* New BETA is at most 1, at least SMLNUM */
i__1 = *n - 1;
xnorm = dznrm2_(&i__1, &x[1], incx);
z__1.r = alphr;
z__1.i = alphi; // , expr subst
alpha->r = z__1.r, alpha->i = z__1.i;
d__1 = dlapy3_(&alphr, &alphi, &xnorm);
beta = d_sign(&d__1, &alphr);
}
savealpha.r = alpha->r;
savealpha.i = alpha->i; // , expr subst
z__1.r = alpha->r + beta;
z__1.i = alpha->i; // , expr subst
alpha->r = z__1.r, alpha->i = z__1.i;
if (beta < 0.)
{
beta = -beta;
z__2.r = -alpha->r;
z__2.i = -alpha->i; // , expr subst
z__1.r = z__2.r / beta;
z__1.i = z__2.i / beta; // , expr subst
tau->r = z__1.r, tau->i = z__1.i;
}
else
{
alphr = alphi * (alphi / alpha->r);
alphr += xnorm * (xnorm / alpha->r);
d__1 = alphr / beta;
d__2 = -alphi / beta;
z__1.r = d__1;
z__1.i = d__2; // , expr subst
tau->r = z__1.r, tau->i = z__1.i;
d__1 = -alphr;
z__1.r = d__1;
z__1.i = alphi; // , expr subst
alpha->r = z__1.r, alpha->i = z__1.i;
}
zladiv_(&z__1, &c_b5, alpha);
alpha->r = z__1.r, alpha->i = z__1.i;
if (z_abs(tau) <= smlnum)
{
/* In the case where the computed TAU ends up being a denormalized number, */
/* it loses relative accuracy. This is a BIG problem. Solution: flush TAU */
/* to ZERO (or TWO or whatever makes a nonnegative real number for BETA). */
/* (Bug report provided by Pat Quillen from MathWorks on Jul 29, 2009.) */
/* (Thanks Pat. Thanks MathWorks.) */
alphr = savealpha.r;
alphi = d_imag(&savealpha);
if (alphi == 0.)
{
if (alphr >= 0.)
{
tau->r = 0., tau->i = 0.;
}
else
{
tau->r = 2., tau->i = 0.;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.;
x[i__2].i = 0.; // , expr subst
}
z__1.r = -savealpha.r;
z__1.i = -savealpha.i; // , expr subst
beta = z__1.r;
}
}
else
{
xnorm = dlapy2_(&alphr, &alphi);
d__1 = 1. - alphr / xnorm;
d__2 = -alphi / xnorm;
z__1.r = d__1;
z__1.i = d__2; // , expr subst
tau->r = z__1.r, tau->i = z__1.i;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.;
x[i__2].i = 0.; // , expr subst
}
beta = xnorm;
}
}
else
{
/* This is the general case. */
i__1 = *n - 1;
zscal_(&i__1, alpha, &x[1], incx);
}
/* If BETA is subnormal, it may lose relative accuracy */
i__1 = knt;
for (j = 1;
j <= i__1;
++j)
{
beta *= smlnum;
/* L20: */
}
alpha->r = beta, alpha->i = 0.;
}
return 0;
/* End of ZLARFGP */
}
/* Subroutine */ int 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 zhptrs_(char *uplo, integer *n, integer *nrhs,
doublecomplex *ap, integer *ipiv, doublecomplex *b, integer *ldb,
integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, i__1, i__2;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg(
doublecomplex *, doublecomplex *);
/* Local variables */
integer j, k;
doublereal s;
doublecomplex ak, bk;
integer kc, kp;
doublecomplex akm1, bkm1, akm1k;
extern logical lsame_(char *, char *);
doublecomplex denom;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
logical upper;
extern /* Subroutine */ int zgeru_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *), xerbla_(char *, integer *), zdscal_(integer *, doublereal *, doublecomplex *,
integer *), zlacgv_(integer *, doublecomplex *, integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZHPTRS solves a system of linear equations A*X = B with a complex */
/* Hermitian matrix A stored in packed format using the factorization */
/* A = U*D*U**H or A = L*D*L**H computed by ZHPTRF. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the details of the factorization are stored */
/* as an upper or lower triangular matrix. */
/* = 'U': Upper triangular, form is A = U*D*U**H; */
/* = 'L': Lower triangular, form is A = L*D*L**H. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrix B. NRHS >= 0. */
/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
/* The block diagonal matrix D and the multipliers used to */
/* obtain the factor U or L as computed by ZHPTRF, stored as a */
/* packed triangular matrix. */
/* IPIV (input) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D */
/* as determined by ZHPTRF. */
/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
/* On entry, the right hand side matrix B. */
/* On exit, the solution matrix X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--ap;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHPTRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
return 0;
}
if (upper) {
/* Solve A*X = B, where A = U*D*U'. */
/* First solve U*D*X = B, overwriting B with X. */
/* K is the main loop index, decreasing from N to 1 in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = *n;
kc = *n * (*n + 1) / 2 + 1;
L10:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L30;
}
kc -= k;
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(U(K)), where U(K) is the transformation */
/* stored in column K of A. */
i__1 = k - 1;
z__1.r = -1., z__1.i = -0.;
zgeru_(&i__1, nrhs, &z__1, &ap[kc], &c__1, &b[k + b_dim1], ldb, &
b[b_dim1 + 1], ldb);
/* Multiply by the inverse of the diagonal block. */
i__1 = kc + k - 1;
s = 1. / ap[i__1].r;
zdscal_(nrhs, &s, &b[k + b_dim1], ldb);
--k;
} else {
/* 2 x 2 diagonal block */
/* Interchange rows K-1 and -IPIV(K). */
kp = -ipiv[k];
if (kp != k - 1) {
zswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(U(K)), where U(K) is the transformation */
/* stored in columns K-1 and K of A. */
i__1 = k - 2;
z__1.r = -1., z__1.i = -0.;
zgeru_(&i__1, nrhs, &z__1, &ap[kc], &c__1, &b[k + b_dim1], ldb, &
b[b_dim1 + 1], ldb);
i__1 = k - 2;
z__1.r = -1., z__1.i = -0.;
zgeru_(&i__1, nrhs, &z__1, &ap[kc - (k - 1)], &c__1, &b[k - 1 +
b_dim1], ldb, &b[b_dim1 + 1], ldb);
/* Multiply by the inverse of the diagonal block. */
i__1 = kc + k - 2;
akm1k.r = ap[i__1].r, akm1k.i = ap[i__1].i;
z_div(&z__1, &ap[kc - 1], &akm1k);
akm1.r = z__1.r, akm1.i = z__1.i;
d_cnjg(&z__2, &akm1k);
z_div(&z__1, &ap[kc + k - 1], &z__2);
ak.r = z__1.r, ak.i = z__1.i;
z__2.r = akm1.r * ak.r - akm1.i * ak.i, z__2.i = akm1.r * ak.i +
akm1.i * ak.r;
z__1.r = z__2.r - 1., z__1.i = z__2.i - 0.;
denom.r = z__1.r, denom.i = z__1.i;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
z_div(&z__1, &b[k - 1 + j * b_dim1], &akm1k);
bkm1.r = z__1.r, bkm1.i = z__1.i;
d_cnjg(&z__2, &akm1k);
z_div(&z__1, &b[k + j * b_dim1], &z__2);
bk.r = z__1.r, bk.i = z__1.i;
i__2 = k - 1 + j * b_dim1;
z__3.r = ak.r * bkm1.r - ak.i * bkm1.i, z__3.i = ak.r *
bkm1.i + ak.i * bkm1.r;
z__2.r = z__3.r - bk.r, z__2.i = z__3.i - bk.i;
z_div(&z__1, &z__2, &denom);
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = k + j * b_dim1;
z__3.r = akm1.r * bk.r - akm1.i * bk.i, z__3.i = akm1.r *
bk.i + akm1.i * bk.r;
z__2.r = z__3.r - bkm1.r, z__2.i = z__3.i - bkm1.i;
z_div(&z__1, &z__2, &denom);
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
/* L20: */
}
kc = kc - k + 1;
k += -2;
}
goto L10;
L30:
/* Next solve U'*X = B, overwriting B with X. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = 1;
kc = 1;
L40:
/* If K > N, exit from loop. */
if (k > *n) {
goto L50;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Multiply by inv(U'(K)), where U(K) is the transformation */
/* stored in column K of A. */
if (k > 1) {
zlacgv_(nrhs, &b[k + b_dim1], ldb);
i__1 = k - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset]
, ldb, &ap[kc], &c__1, &c_b1, &b[k + b_dim1], ldb);
zlacgv_(nrhs, &b[k + b_dim1], ldb);
}
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
kc += k;
++k;
} else {
/* 2 x 2 diagonal block */
/* Multiply by inv(U'(K+1)), where U(K+1) is the transformation */
/* stored in columns K and K+1 of A. */
if (k > 1) {
zlacgv_(nrhs, &b[k + b_dim1], ldb);
i__1 = k - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset]
, ldb, &ap[kc], &c__1, &c_b1, &b[k + b_dim1], ldb);
zlacgv_(nrhs, &b[k + b_dim1], ldb);
zlacgv_(nrhs, &b[k + 1 + b_dim1], ldb);
i__1 = k - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset]
, ldb, &ap[kc + k], &c__1, &c_b1, &b[k + 1 + b_dim1],
ldb);
zlacgv_(nrhs, &b[k + 1 + b_dim1], ldb);
}
/* Interchange rows K and -IPIV(K). */
kp = -ipiv[k];
if (kp != k) {
zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
kc = kc + (k << 1) + 1;
k += 2;
}
goto L40;
L50:
;
} else {
/* Solve A*X = B, where A = L*D*L'. */
/* First solve L*D*X = B, overwriting B with X. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = 1;
kc = 1;
L60:
/* If K > N, exit from loop. */
if (k > *n) {
goto L80;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(L(K)), where L(K) is the transformation */
/* stored in column K of A. */
if (k < *n) {
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zgeru_(&i__1, nrhs, &z__1, &ap[kc + 1], &c__1, &b[k + b_dim1],
ldb, &b[k + 1 + b_dim1], ldb);
}
/* Multiply by the inverse of the diagonal block. */
i__1 = kc;
s = 1. / ap[i__1].r;
zdscal_(nrhs, &s, &b[k + b_dim1], ldb);
kc = kc + *n - k + 1;
++k;
} else {
/* 2 x 2 diagonal block */
/* Interchange rows K+1 and -IPIV(K). */
kp = -ipiv[k];
if (kp != k + 1) {
zswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(L(K)), where L(K) is the transformation */
/* stored in columns K and K+1 of A. */
if (k < *n - 1) {
i__1 = *n - k - 1;
z__1.r = -1., z__1.i = -0.;
zgeru_(&i__1, nrhs, &z__1, &ap[kc + 2], &c__1, &b[k + b_dim1],
ldb, &b[k + 2 + b_dim1], ldb);
i__1 = *n - k - 1;
z__1.r = -1., z__1.i = -0.;
zgeru_(&i__1, nrhs, &z__1, &ap[kc + *n - k + 2], &c__1, &b[k
+ 1 + b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
}
/* Multiply by the inverse of the diagonal block. */
i__1 = kc + 1;
akm1k.r = ap[i__1].r, akm1k.i = ap[i__1].i;
d_cnjg(&z__2, &akm1k);
z_div(&z__1, &ap[kc], &z__2);
akm1.r = z__1.r, akm1.i = z__1.i;
z_div(&z__1, &ap[kc + *n - k + 1], &akm1k);
ak.r = z__1.r, ak.i = z__1.i;
z__2.r = akm1.r * ak.r - akm1.i * ak.i, z__2.i = akm1.r * ak.i +
akm1.i * ak.r;
z__1.r = z__2.r - 1., z__1.i = z__2.i - 0.;
denom.r = z__1.r, denom.i = z__1.i;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
d_cnjg(&z__2, &akm1k);
z_div(&z__1, &b[k + j * b_dim1], &z__2);
bkm1.r = z__1.r, bkm1.i = z__1.i;
z_div(&z__1, &b[k + 1 + j * b_dim1], &akm1k);
bk.r = z__1.r, bk.i = z__1.i;
i__2 = k + j * b_dim1;
z__3.r = ak.r * bkm1.r - ak.i * bkm1.i, z__3.i = ak.r *
bkm1.i + ak.i * bkm1.r;
z__2.r = z__3.r - bk.r, z__2.i = z__3.i - bk.i;
z_div(&z__1, &z__2, &denom);
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = k + 1 + j * b_dim1;
z__3.r = akm1.r * bk.r - akm1.i * bk.i, z__3.i = akm1.r *
bk.i + akm1.i * bk.r;
z__2.r = z__3.r - bkm1.r, z__2.i = z__3.i - bkm1.i;
z_div(&z__1, &z__2, &denom);
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
/* L70: */
}
kc = kc + (*n - k << 1) + 1;
k += 2;
}
goto L60;
L80:
/* Next solve L'*X = B, overwriting B with X. */
/* K is the main loop index, decreasing from N to 1 in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = *n;
kc = *n * (*n + 1) / 2 + 1;
L90:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L100;
}
kc -= *n - k + 1;
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Multiply by inv(L'(K)), where L(K) is the transformation */
/* stored in column K of A. */
if (k < *n) {
zlacgv_(nrhs, &b[k + b_dim1], ldb);
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 +
b_dim1], ldb, &ap[kc + 1], &c__1, &c_b1, &b[k +
b_dim1], ldb);
zlacgv_(nrhs, &b[k + b_dim1], ldb);
}
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
--k;
} else {
/* 2 x 2 diagonal block */
/* Multiply by inv(L'(K-1)), where L(K-1) is the transformation */
/* stored in columns K-1 and K of A. */
if (k < *n) {
zlacgv_(nrhs, &b[k + b_dim1], ldb);
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 +
b_dim1], ldb, &ap[kc + 1], &c__1, &c_b1, &b[k +
b_dim1], ldb);
zlacgv_(nrhs, &b[k + b_dim1], ldb);
zlacgv_(nrhs, &b[k - 1 + b_dim1], ldb);
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 +
b_dim1], ldb, &ap[kc - (*n - k)], &c__1, &c_b1, &b[k
- 1 + b_dim1], ldb);
zlacgv_(nrhs, &b[k - 1 + b_dim1], ldb);
}
/* Interchange rows K and -IPIV(K). */
kp = -ipiv[k];
if (kp != k) {
zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
kc -= *n - k + 2;
k += -2;
}
goto L90;
L100:
;
}
return 0;
/* End of ZHPTRS */
} /* zhptrs_ */
/* Subroutine */ int zhpev_(char *jobz, char *uplo, integer *n, doublecomplex
*ap, doublereal *w, doublecomplex *z__, integer *ldz, doublecomplex *
work, doublereal *rwork, integer *info)
{
/* -- LAPACK driver 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
=======
ZHPEV computes all the eigenvalues and, optionally, eigenvectors of a
complex Hermitian matrix in packed storage.
Arguments
=========
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
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 Hermitian matrix
A, packed columnwise in a linear array. The j-th column of A
is stored in the array AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
On exit, AP is overwritten by values generated during the
reduction to tridiagonal form. If UPLO = 'U', the diagonal
and first superdiagonal of the tridiagonal matrix T overwrite
the corresponding elements of A, and if UPLO = 'L', the
diagonal and first subdiagonal of T overwrite the
corresponding elements of A.
W (output) DOUBLE PRECISION array, dimension (N)
If INFO = 0, the eigenvalues in ascending order.
Z (output) COMPLEX*16 array, dimension (LDZ, N)
If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
eigenvectors of the matrix A, with the i-th column of Z
holding the eigenvector associated with W(i).
If JOBZ = 'N', then Z is not referenced.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1, and if
JOBZ = 'V', LDZ >= max(1,N).
WORK (workspace) COMPLEX*16 array, dimension (max(1, 2*N-1))
RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2))
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: if INFO = i, the algorithm failed to converge; i
off-diagonal elements of an intermediate tridiagonal
form did not converge to zero.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer z_dim1, z_offset, i__1;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer inde;
static doublereal anrm;
static integer imax;
static doublereal rmin, rmax;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static doublereal sigma;
extern logical lsame_(char *, char *);
static integer iinfo;
static logical wantz;
extern doublereal dlamch_(char *);
static integer iscale;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *);
static doublereal bignum;
static integer indtau;
extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
integer *);
extern doublereal zlanhp_(char *, char *, integer *, doublecomplex *,
doublereal *);
static integer indrwk, indwrk;
static doublereal smlnum;
extern /* Subroutine */ int zhptrd_(char *, integer *, doublecomplex *,
doublereal *, doublereal *, doublecomplex *, integer *),
zsteqr_(char *, integer *, doublereal *, doublereal *,
doublecomplex *, integer *, doublereal *, integer *),
zupgtr_(char *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal eps;
#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)]
--ap;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
--rwork;
/* Function Body */
wantz = lsame_(jobz, "V");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (lsame_(uplo, "L") || lsame_(uplo,
"U"))) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHPEV ", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
w[1] = ap[1].r;
rwork[1] = 1.;
if (wantz) {
i__1 = z___subscr(1, 1);
z__[i__1].r = 1., z__[i__1].i = 0.;
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
rmax = sqrt(bignum);
/* Scale matrix to allowable range, if necessary. */
anrm = zlanhp_("M", uplo, n, &ap[1], &rwork[1]);
iscale = 0;
if (anrm > 0. && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
i__1 = *n * (*n + 1) / 2;
zdscal_(&i__1, &sigma, &ap[1], &c__1);
}
/* Call ZHPTRD to reduce Hermitian packed matrix to tridiagonal form. */
inde = 1;
indtau = 1;
zhptrd_(uplo, n, &ap[1], &w[1], &rwork[inde], &work[indtau], &iinfo);
/* For eigenvalues only, call DSTERF. For eigenvectors, first call
ZUPGTR to generate the orthogonal matrix, then call ZSTEQR. */
if (! wantz) {
dsterf_(n, &w[1], &rwork[inde], info);
} else {
indwrk = indtau + *n;
zupgtr_(uplo, n, &ap[1], &work[indtau], &z__[z_offset], ldz, &work[
indwrk], &iinfo);
indrwk = inde + *n;
zsteqr_(jobz, n, &w[1], &rwork[inde], &z__[z_offset], ldz, &rwork[
indrwk], info);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (iscale == 1) {
if (*info == 0) {
imax = *n;
} else {
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__1, &w[1], &c__1);
}
return 0;
/* End of ZHPEV */
} /* zhpev_ */
