/* Subroutine */
int zlaev2_(doublecomplex *a, doublecomplex *b, doublecomplex *c__, doublereal *rt1, doublereal *rt2, doublereal *cs1, doublecomplex *sn1)
{
/* System generated locals */
doublereal d__1, d__2, d__3;
doublecomplex z__1, z__2;
/* Builtin functions */
double z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
doublereal t;
doublecomplex w;
extern /* Subroutine */
int dlaev2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *);
/* -- 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 .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
if (z_abs(b) == 0.)
{
w.r = 1.;
w.i = 0.; // , expr subst
}
else
{
d_cnjg(&z__2, b);
d__1 = z_abs(b);
z__1.r = z__2.r / d__1;
z__1.i = z__2.i / d__1; // , expr subst
w.r = z__1.r;
w.i = z__1.i; // , expr subst
}
d__1 = a->r;
d__2 = z_abs(b);
d__3 = c__->r;
dlaev2_(&d__1, &d__2, &d__3, rt1, rt2, cs1, &t);
z__1.r = t * w.r;
z__1.i = t * w.i; // , expr subst
sn1->r = z__1.r, sn1->i = z__1.i;
return 0;
/* End of ZLAEV2 */
}
/* Subroutine */ int zrotg_(doublecomplex *ca, doublecomplex *cb, doublereal *
c, doublecomplex *s)
{
/* System generated locals */
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
double sqrt(doublereal);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static doublereal norm;
extern doublereal cdabs_(doublecomplex *);
static doublecomplex alpha;
static doublereal scale;
if (cdabs_(ca) != 0.) {
goto L10;
}
*c = 0.;
s->r = 1., s->i = 0.;
ca->r = cb->r, ca->i = cb->i;
goto L20;
L10:
scale = cdabs_(ca) + cdabs_(cb);
z__2.r = scale, z__2.i = 0.;
z_div(&z__1, ca, &z__2);
/* Computing 2nd power */
d__1 = cdabs_(&z__1);
z__4.r = scale, z__4.i = 0.;
z_div(&z__3, cb, &z__4);
/* Computing 2nd power */
d__2 = cdabs_(&z__3);
norm = scale * sqrt(d__1 * d__1 + d__2 * d__2);
d__1 = cdabs_(ca);
z__1.r = ca->r / d__1, z__1.i = ca->i / d__1;
alpha.r = z__1.r, alpha.i = z__1.i;
*c = cdabs_(ca) / norm;
d_cnjg(&z__3, cb);
z__2.r = alpha.r * z__3.r - alpha.i * z__3.i, z__2.i = alpha.r * z__3.i +
alpha.i * z__3.r;
z__1.r = z__2.r / norm, z__1.i = z__2.i / norm;
s->r = z__1.r, s->i = z__1.i;
z__1.r = norm * alpha.r, z__1.i = norm * alpha.i;
ca->r = z__1.r, ca->i = z__1.i;
L20:
return 0;
} /* zrotg_ */
/* Subroutine */ int zget22_(char *transa, char *transe, char *transw,
integer *n, doublecomplex *a, integer *lda, doublecomplex *e, integer
*lde, doublecomplex *w, doublecomplex *work, doublereal *rwork,
doublereal *result)
{
/* System generated locals */
integer a_dim1, a_offset, e_dim1, e_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer j;
doublereal ulp;
integer joff, jcol, jvec;
doublereal unfl;
integer jrow;
doublereal temp1;
extern logical lsame_(char *, char *);
char norma[1];
doublereal anorm;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
char norme[1];
doublereal enorm;
doublecomplex wtemp;
extern doublereal dlamch_(char *), zlange_(char *, integer *,
integer *, doublecomplex *, integer *, doublereal *);
doublereal enrmin, enrmax;
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
integer itrnse;
doublereal errnrm;
integer itrnsw;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGET22 does an eigenvector check. */
/* The basic test is: */
/* RESULT(1) = | A E - E W | / ( |A| |E| ulp ) */
/* using the 1-norm. It also tests the normalization of E: */
/* RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp ) */
/* j */
/* where E(j) is the j-th eigenvector, and m-norm is the max-norm of a */
/* vector. The max-norm of a complex n-vector x in this case is the */
/* maximum of |re(x(i)| + |im(x(i)| over i = 1, ..., n. */
/* Arguments */
/* ========== */
/* TRANSA (input) CHARACTER*1 */
/* Specifies whether or not A is transposed. */
/* = 'N': No transpose */
/* = 'T': Transpose */
/* = 'C': Conjugate transpose */
/* TRANSE (input) CHARACTER*1 */
/* Specifies whether or not E is transposed. */
/* = 'N': No transpose, eigenvectors are in columns of E */
/* = 'T': Transpose, eigenvectors are in rows of E */
/* = 'C': Conjugate transpose, eigenvectors are in rows of E */
/* TRANSW (input) CHARACTER*1 */
/* Specifies whether or not W is transposed. */
/* = 'N': No transpose */
/* = 'T': Transpose, same as TRANSW = 'N' */
/* = 'C': Conjugate transpose, use -WI(j) instead of WI(j) */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The matrix whose eigenvectors are in E. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* E (input) COMPLEX*16 array, dimension (LDE,N) */
/* The matrix of eigenvectors. If TRANSE = 'N', the eigenvectors */
/* are stored in the columns of E, if TRANSE = 'T' or 'C', the */
/* eigenvectors are stored in the rows of E. */
/* LDE (input) INTEGER */
/* The leading dimension of the array E. LDE >= max(1,N). */
/* W (input) COMPLEX*16 array, dimension (N) */
/* The eigenvalues of A. */
/* WORK (workspace) COMPLEX*16 array, dimension (N*N) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
/* RESULT(1) = | A E - E W | / ( |A| |E| ulp ) */
/* RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp ) */
/* j */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Initialize RESULT (in case N=0) */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
e_dim1 = *lde;
e_offset = 1 + e_dim1;
e -= e_offset;
--w;
--work;
--rwork;
--result;
/* Function Body */
result[1] = 0.;
result[2] = 0.;
if (*n <= 0) {
return 0;
}
unfl = dlamch_("Safe minimum");
ulp = dlamch_("Precision");
itrnse = 0;
itrnsw = 0;
*(unsigned char *)norma = 'O';
*(unsigned char *)norme = 'O';
if (lsame_(transa, "T") || lsame_(transa, "C")) {
*(unsigned char *)norma = 'I';
}
if (lsame_(transe, "T")) {
itrnse = 1;
*(unsigned char *)norme = 'I';
} else if (lsame_(transe, "C")) {
itrnse = 2;
*(unsigned char *)norme = 'I';
}
if (lsame_(transw, "C")) {
itrnsw = 1;
}
/* Normalization of E: */
enrmin = 1. / ulp;
enrmax = 0.;
if (itrnse == 0) {
i__1 = *n;
for (jvec = 1; jvec <= i__1; ++jvec) {
temp1 = 0.;
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
/* Computing MAX */
i__3 = j + jvec * e_dim1;
d__3 = temp1, d__4 = (d__1 = e[i__3].r, abs(d__1)) + (d__2 =
d_imag(&e[j + jvec * e_dim1]), abs(d__2));
temp1 = max(d__3,d__4);
/* L10: */
}
enrmin = min(enrmin,temp1);
enrmax = max(enrmax,temp1);
/* L20: */
}
} else {
i__1 = *n;
for (jvec = 1; jvec <= i__1; ++jvec) {
rwork[jvec] = 0.;
/* L30: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (jvec = 1; jvec <= i__2; ++jvec) {
/* Computing MAX */
i__3 = jvec + j * e_dim1;
d__3 = rwork[jvec], d__4 = (d__1 = e[i__3].r, abs(d__1)) + (
d__2 = d_imag(&e[jvec + j * e_dim1]), abs(d__2));
rwork[jvec] = max(d__3,d__4);
/* L40: */
}
/* L50: */
}
i__1 = *n;
for (jvec = 1; jvec <= i__1; ++jvec) {
/* Computing MIN */
d__1 = enrmin, d__2 = rwork[jvec];
enrmin = min(d__1,d__2);
/* Computing MAX */
d__1 = enrmax, d__2 = rwork[jvec];
enrmax = max(d__1,d__2);
/* L60: */
}
}
/* Norm of A: */
/* Computing MAX */
d__1 = zlange_(norma, n, n, &a[a_offset], lda, &rwork[1]);
anorm = max(d__1,unfl);
/* Norm of E: */
/* Computing MAX */
d__1 = zlange_(norme, n, n, &e[e_offset], lde, &rwork[1]);
enorm = max(d__1,ulp);
/* Norm of error: */
/* Error = AE - EW */
zlaset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
joff = 0;
i__1 = *n;
for (jcol = 1; jcol <= i__1; ++jcol) {
if (itrnsw == 0) {
i__2 = jcol;
wtemp.r = w[i__2].r, wtemp.i = w[i__2].i;
} else {
d_cnjg(&z__1, &w[jcol]);
wtemp.r = z__1.r, wtemp.i = z__1.i;
}
if (itrnse == 0) {
i__2 = *n;
for (jrow = 1; jrow <= i__2; ++jrow) {
i__3 = joff + jrow;
i__4 = jrow + jcol * e_dim1;
z__1.r = e[i__4].r * wtemp.r - e[i__4].i * wtemp.i, z__1.i =
e[i__4].r * wtemp.i + e[i__4].i * wtemp.r;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L70: */
}
} else if (itrnse == 1) {
i__2 = *n;
for (jrow = 1; jrow <= i__2; ++jrow) {
i__3 = joff + jrow;
i__4 = jcol + jrow * e_dim1;
z__1.r = e[i__4].r * wtemp.r - e[i__4].i * wtemp.i, z__1.i =
e[i__4].r * wtemp.i + e[i__4].i * wtemp.r;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L80: */
}
} else {
i__2 = *n;
for (jrow = 1; jrow <= i__2; ++jrow) {
i__3 = joff + jrow;
d_cnjg(&z__2, &e[jcol + jrow * e_dim1]);
z__1.r = z__2.r * wtemp.r - z__2.i * wtemp.i, z__1.i = z__2.r
* wtemp.i + z__2.i * wtemp.r;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L90: */
}
}
joff += *n;
/* L100: */
}
z__1.r = -1., z__1.i = -0.;
zgemm_(transa, transe, n, n, n, &c_b2, &a[a_offset], lda, &e[e_offset],
lde, &z__1, &work[1], n);
errnrm = zlange_("One", n, n, &work[1], n, &rwork[1]) / enorm;
/* Compute RESULT(1) (avoiding under/overflow) */
if (anorm > errnrm) {
result[1] = errnrm / anorm / ulp;
} else {
if (anorm < 1.) {
result[1] = min(errnrm,anorm) / anorm / ulp;
} else {
/* Computing MIN */
d__1 = errnrm / anorm;
result[1] = min(d__1,1.) / ulp;
}
}
/* Compute RESULT(2) : the normalization error in E. */
/* Computing MAX */
d__3 = (d__1 = enrmax - 1., abs(d__1)), d__4 = (d__2 = enrmin - 1., abs(
d__2));
result[2] = max(d__3,d__4) / ((doublereal) (*n) * ulp);
return 0;
/* End of ZGET22 */
} /* zget22_ */
/* Double Complex */ VOID zlatm2_(doublecomplex * ret_val, integer *m,
integer *n, integer *i, integer *j, integer *kl, integer *ku, integer
*idist, integer *iseed, doublecomplex *d, integer *igrade,
doublecomplex *dl, doublecomplex *dr, integer *ipvtng, integer *iwork,
doublereal *sparse)
{
/* System generated locals */
integer 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 */
static integer isub, jsub;
static doublecomplex ctemp;
extern doublereal dlaran_(integer *);
extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
integer *);
/* -- LAPACK auxiliary test routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
ZLATM2 returns the (I,J) entry of a random matrix of dimension
(M, N) described by the other paramters. It is called by the
ZLATMR routine in order to build random test matrices. No error
checking on parameters is done, because this routine is called in
a tight loop by ZLATMR which has already checked the parameters.
Use of ZLATM2 differs from CLATM3 in the order in which the random
number generator is called to fill in random matrix entries.
With ZLATM2, the generator is called to fill in the pivoted matrix
columnwise. With ZLATM3, the generator is called to fill in the
matrix columnwise, after which it is pivoted. Thus, ZLATM3 can
be used to construct random matrices which differ only in their
order of rows and/or columns. ZLATM2 is used to construct band
matrices while avoiding calling the random number generator for
entries outside the band (and therefore generating random numbers
The matrix whose (I,J) entry is returned is constructed as
follows (this routine only computes one entry):
If I is outside (1..M) or J is outside (1..N), return zero
(this is convenient for generating matrices in band format).
Generate a matrix A with random entries of distribution IDIST.
Set the diagonal to D.
Grade the matrix, if desired, from the left (by DL) and/or
from the right (by DR or DL) as specified by IGRADE.
Permute, if desired, the rows and/or columns as specified by
IPVTNG and IWORK.
Band the matrix to have lower bandwidth KL and upper
bandwidth KU.
Set random entries to zero as specified by SPARSE.
Arguments
=========
M - INTEGER
Number of rows of matrix. Not modified.
N - INTEGER
Number of columns of matrix. Not modified.
I - INTEGER
Row of entry to be returned. Not modified.
J - INTEGER
Column of entry to be returned. Not modified.
KL - INTEGER
Lower bandwidth. Not modified.
KU - INTEGER
Upper bandwidth. Not modified.
IDIST - INTEGER
On entry, IDIST specifies the type of distribution to be
used to generate a random matrix .
1 => real and imaginary parts each UNIFORM( 0, 1 )
2 => real and imaginary parts each UNIFORM( -1, 1 )
3 => real and imaginary parts each NORMAL( 0, 1 )
4 => complex number uniform in DISK( 0 , 1 )
Not modified.
ISEED - INTEGER array of dimension ( 4 )
Seed for random number generator.
Changed on exit.
D - COMPLEX*16 array of dimension ( MIN( I , J ) )
Diagonal entries of matrix. Not modified.
IGRADE - INTEGER
Specifies grading of matrix as follows:
0 => no grading
1 => matrix premultiplied by diag( DL )
2 => matrix postmultiplied by diag( DR )
3 => matrix premultiplied by diag( DL ) and
postmultiplied by diag( DR )
4 => matrix premultiplied by diag( DL ) and
postmultiplied by inv( diag( DL ) )
5 => matrix premultiplied by diag( DL ) and
postmultiplied by diag( CONJG(DL) )
6 => matrix premultiplied by diag( DL ) and
postmultiplied by diag( DL )
Not modified.
DL - COMPLEX*16 array ( I or J, as appropriate )
Left scale factors for grading matrix. Not modified.
DR - COMPLEX*16 array ( I or J, as appropriate )
Right scale factors for grading matrix. Not modified.
IPVTNG - INTEGER
On entry specifies pivoting permutations as follows:
0 => none.
1 => row pivoting.
2 => column pivoting.
3 => full pivoting, i.e., on both sides.
Not modified.
IWORK - INTEGER array ( I or J, as appropriate )
This array specifies the permutation used. The
row (or column) in position K was originally in
position IWORK( K ).
This differs from IWORK for ZLATM3. Not modified.
SPARSE - DOUBLE PRECISION between 0. and 1.
On entry specifies the sparsity of the matrix
if sparse matix is to be generated.
SPARSE should lie between 0 and 1.
A uniform ( 0, 1 ) random number x is generated and
compared to SPARSE; if x is larger the matrix entry
is unchanged and if x is smaller the entry is set
to zero. Thus on the average a fraction SPARSE of the
entries will be set to zero.
Not modified.
=====================================================================
-----------------------------------------------------------------------
Check for I and J in range
Parameter adjustments */
--iwork;
--dr;
--dl;
--d;
--iseed;
/* Function Body */
if (*i < 1 || *i > *m || *j < 1 || *j > *n) {
ret_val->r = 0., ret_val->i = 0.;
return ;
}
/* Check for banding */
if (*j > *i + *ku || *j < *i - *kl) {
ret_val->r = 0., ret_val->i = 0.;
return ;
}
/* Check for sparsity */
if (*sparse > 0.) {
if (dlaran_(&iseed[1]) < *sparse) {
ret_val->r = 0., ret_val->i = 0.;
return ;
}
}
/* Compute subscripts depending on IPVTNG */
if (*ipvtng == 0) {
isub = *i;
jsub = *j;
} else if (*ipvtng == 1) {
isub = iwork[*i];
jsub = *j;
} else if (*ipvtng == 2) {
isub = *i;
jsub = iwork[*j];
} else if (*ipvtng == 3) {
isub = iwork[*i];
jsub = iwork[*j];
}
/* Compute entry and grade it according to IGRADE */
if (isub == jsub) {
i__1 = isub;
ctemp.r = d[i__1].r, ctemp.i = d[i__1].i;
} else {
zlarnd_(&z__1, idist, &iseed[1]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
}
if (*igrade == 1) {
i__1 = isub;
z__1.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__1.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
ctemp.r = z__1.r, ctemp.i = z__1.i;
} else if (*igrade == 2) {
i__1 = jsub;
z__1.r = ctemp.r * dr[i__1].r - ctemp.i * dr[i__1].i, z__1.i =
ctemp.r * dr[i__1].i + ctemp.i * dr[i__1].r;
ctemp.r = z__1.r, ctemp.i = z__1.i;
} else if (*igrade == 3) {
i__1 = isub;
z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
i__2 = jsub;
z__1.r = z__2.r * dr[i__2].r - z__2.i * dr[i__2].i, z__1.i = z__2.r *
dr[i__2].i + z__2.i * dr[i__2].r;
ctemp.r = z__1.r, ctemp.i = z__1.i;
} else if (*igrade == 4 && isub != jsub) {
i__1 = isub;
z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
z_div(&z__1, &z__2, &dl[jsub]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
} else if (*igrade == 5) {
i__1 = isub;
z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
d_cnjg(&z__3, &dl[jsub]);
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;
ctemp.r = z__1.r, ctemp.i = z__1.i;
} else if (*igrade == 6) {
i__1 = isub;
z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
i__2 = jsub;
z__1.r = z__2.r * dl[i__2].r - z__2.i * dl[i__2].i, z__1.i = z__2.r *
dl[i__2].i + z__2.i * dl[i__2].r;
ctemp.r = z__1.r, ctemp.i = z__1.i;
}
ret_val->r = ctemp.r, ret_val->i = ctemp.i;
return ;
/* End of ZLATM2 */
} /* zlatm2_ */
/* Subroutine */ int zlatm6_(integer *type__, integer *n, doublecomplex *a,
integer *lda, doublecomplex *b, doublecomplex *x, integer *ldx,
doublecomplex *y, integer *ldy, doublecomplex *alpha, doublecomplex *
beta, doublecomplex *wx, doublecomplex *wy, doublereal *s, doublereal
*dif)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, y_dim1,
y_offset, i__1, i__2, i__3;
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
integer i__, j;
doublecomplex z__[64] /* was [8][8] */;
integer info;
doublecomplex work[26];
doublereal rwork[50];
extern /* Subroutine */ int zlakf2_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, integer *), zgesvd_(char *, char *, integer *,
integer *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLATM6 generates test matrices for the generalized eigenvalue */
/* problem, their corresponding right and left eigenvector matrices, */
/* and also reciprocal condition numbers for all eigenvalues and */
/* the reciprocal condition numbers of eigenvectors corresponding to */
/* the 1th and 5th eigenvalues. */
/* Test Matrices */
/* ============= */
/* Two kinds of test matrix pairs */
/* (A, B) = inverse(YH) * (Da, Db) * inverse(X) */
/* are used in the tests: */
/* Type 1: */
/* Da = 1+a 0 0 0 0 Db = 1 0 0 0 0 */
/* 0 2+a 0 0 0 0 1 0 0 0 */
/* 0 0 3+a 0 0 0 0 1 0 0 */
/* 0 0 0 4+a 0 0 0 0 1 0 */
/* 0 0 0 0 5+a , 0 0 0 0 1 */
/* and Type 2: */
/* Da = 1+i 0 0 0 0 Db = 1 0 0 0 0 */
/* 0 1-i 0 0 0 0 1 0 0 0 */
/* 0 0 1 0 0 0 0 1 0 0 */
/* 0 0 0 (1+a)+(1+b)i 0 0 0 0 1 0 */
/* 0 0 0 0 (1+a)-(1+b)i, 0 0 0 0 1 . */
/* In both cases the same inverse(YH) and inverse(X) are used to compute */
/* (A, B), giving the exact eigenvectors to (A,B) as (YH, X): */
/* YH: = 1 0 -y y -y X = 1 0 -x -x x */
/* 0 1 -y y -y 0 1 x -x -x */
/* 0 0 1 0 0 0 0 1 0 0 */
/* 0 0 0 1 0 0 0 0 1 0 */
/* 0 0 0 0 1, 0 0 0 0 1 , where */
/* a, b, x and y will have all values independently of each other. */
/* Arguments */
/* ========= */
/* TYPE (input) INTEGER */
/* Specifies the problem type (see futher details). */
/* N (input) INTEGER */
/* Size of the matrices A and B. */
/* A (output) COMPLEX*16 array, dimension (LDA, N). */
/* On exit A N-by-N is initialized according to TYPE. */
/* LDA (input) INTEGER */
/* The leading dimension of A and of B. */
/* B (output) COMPLEX*16 array, dimension (LDA, N). */
/* On exit B N-by-N is initialized according to TYPE. */
/* X (output) COMPLEX*16 array, dimension (LDX, N). */
/* On exit X is the N-by-N matrix of right eigenvectors. */
/* LDX (input) INTEGER */
/* The leading dimension of X. */
/* Y (output) COMPLEX*16 array, dimension (LDY, N). */
/* On exit Y is the N-by-N matrix of left eigenvectors. */
/* LDY (input) INTEGER */
/* The leading dimension of Y. */
/* ALPHA (input) COMPLEX*16 */
/* BETA (input) COMPLEX*16 */
/* Weighting constants for matrix A. */
/* WX (input) COMPLEX*16 */
/* Constant for right eigenvector matrix. */
/* WY (input) COMPLEX*16 */
/* Constant for left eigenvector matrix. */
/* S (output) DOUBLE PRECISION array, dimension (N) */
/* S(i) is the reciprocal condition number for eigenvalue i. */
/* DIF (output) DOUBLE PRECISION array, dimension (N) */
/* DIF(i) is the reciprocal condition number for eigenvector i. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Generate test problem ... */
/* (Da, Db) ... */
/* Parameter adjustments */
b_dim1 = *lda;
b_offset = 1 + b_dim1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1;
y -= y_offset;
--s;
--dif;
/* Function Body */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
if (i__ == j) {
i__3 = i__ + i__ * a_dim1;
z__2.r = (doublereal) i__, z__2.i = 0.;
z__1.r = z__2.r + alpha->r, z__1.i = z__2.i + alpha->i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
i__3 = i__ + i__ * b_dim1;
b[i__3].r = 1., b[i__3].i = 0.;
} else {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
i__3 = i__ + j * b_dim1;
b[i__3].r = 0., b[i__3].i = 0.;
}
/* L10: */
}
/* L20: */
}
if (*type__ == 2) {
i__1 = a_dim1 + 1;
a[i__1].r = 1., a[i__1].i = 1.;
i__1 = (a_dim1 << 1) + 2;
d_cnjg(&z__1, &a[a_dim1 + 1]);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = a_dim1 * 3 + 3;
a[i__1].r = 1., a[i__1].i = 0.;
i__1 = (a_dim1 << 2) + 4;
z__2.r = alpha->r + 1., z__2.i = alpha->i + 0.;
d__1 = z__2.r;
z__3.r = beta->r + 1., z__3.i = beta->i + 0.;
d__2 = z__3.r;
z__1.r = d__1, z__1.i = d__2;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = a_dim1 * 5 + 5;
d_cnjg(&z__1, &a[(a_dim1 << 2) + 4]);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
}
/* Form X and Y */
zlacpy_("F", n, n, &b[b_offset], lda, &y[y_offset], ldy);
i__1 = y_dim1 + 3;
d_cnjg(&z__2, wy);
z__1.r = -z__2.r, z__1.i = -z__2.i;
y[i__1].r = z__1.r, y[i__1].i = z__1.i;
i__1 = y_dim1 + 4;
d_cnjg(&z__1, wy);
y[i__1].r = z__1.r, y[i__1].i = z__1.i;
i__1 = y_dim1 + 5;
d_cnjg(&z__2, wy);
z__1.r = -z__2.r, z__1.i = -z__2.i;
y[i__1].r = z__1.r, y[i__1].i = z__1.i;
i__1 = (y_dim1 << 1) + 3;
d_cnjg(&z__2, wy);
z__1.r = -z__2.r, z__1.i = -z__2.i;
y[i__1].r = z__1.r, y[i__1].i = z__1.i;
i__1 = (y_dim1 << 1) + 4;
d_cnjg(&z__1, wy);
y[i__1].r = z__1.r, y[i__1].i = z__1.i;
i__1 = (y_dim1 << 1) + 5;
d_cnjg(&z__2, wy);
z__1.r = -z__2.r, z__1.i = -z__2.i;
y[i__1].r = z__1.r, y[i__1].i = z__1.i;
zlacpy_("F", n, n, &b[b_offset], lda, &x[x_offset], ldx);
i__1 = x_dim1 * 3 + 1;
z__1.r = -wx->r, z__1.i = -wx->i;
x[i__1].r = z__1.r, x[i__1].i = z__1.i;
i__1 = (x_dim1 << 2) + 1;
z__1.r = -wx->r, z__1.i = -wx->i;
x[i__1].r = z__1.r, x[i__1].i = z__1.i;
i__1 = x_dim1 * 5 + 1;
x[i__1].r = wx->r, x[i__1].i = wx->i;
i__1 = x_dim1 * 3 + 2;
x[i__1].r = wx->r, x[i__1].i = wx->i;
i__1 = (x_dim1 << 2) + 2;
z__1.r = -wx->r, z__1.i = -wx->i;
x[i__1].r = z__1.r, x[i__1].i = z__1.i;
i__1 = x_dim1 * 5 + 2;
z__1.r = -wx->r, z__1.i = -wx->i;
x[i__1].r = z__1.r, x[i__1].i = z__1.i;
/* Form (A, B) */
i__1 = b_dim1 * 3 + 1;
z__1.r = wx->r + wy->r, z__1.i = wx->i + wy->i;
b[i__1].r = z__1.r, b[i__1].i = z__1.i;
i__1 = b_dim1 * 3 + 2;
z__2.r = -wx->r, z__2.i = -wx->i;
z__1.r = z__2.r + wy->r, z__1.i = z__2.i + wy->i;
b[i__1].r = z__1.r, b[i__1].i = z__1.i;
i__1 = (b_dim1 << 2) + 1;
z__1.r = wx->r - wy->r, z__1.i = wx->i - wy->i;
b[i__1].r = z__1.r, b[i__1].i = z__1.i;
i__1 = (b_dim1 << 2) + 2;
z__1.r = wx->r - wy->r, z__1.i = wx->i - wy->i;
b[i__1].r = z__1.r, b[i__1].i = z__1.i;
i__1 = b_dim1 * 5 + 1;
z__2.r = -wx->r, z__2.i = -wx->i;
z__1.r = z__2.r + wy->r, z__1.i = z__2.i + wy->i;
b[i__1].r = z__1.r, b[i__1].i = z__1.i;
i__1 = b_dim1 * 5 + 2;
z__1.r = wx->r + wy->r, z__1.i = wx->i + wy->i;
b[i__1].r = z__1.r, b[i__1].i = z__1.i;
i__1 = a_dim1 * 3 + 1;
i__2 = a_dim1 + 1;
z__2.r = wx->r * a[i__2].r - wx->i * a[i__2].i, z__2.i = wx->r * a[i__2]
.i + wx->i * a[i__2].r;
i__3 = a_dim1 * 3 + 3;
z__3.r = wy->r * a[i__3].r - wy->i * a[i__3].i, z__3.i = wy->r * a[i__3]
.i + wy->i * a[i__3].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = a_dim1 * 3 + 2;
z__3.r = -wx->r, z__3.i = -wx->i;
i__2 = (a_dim1 << 1) + 2;
z__2.r = z__3.r * a[i__2].r - z__3.i * a[i__2].i, z__2.i = z__3.r * a[
i__2].i + z__3.i * a[i__2].r;
i__3 = a_dim1 * 3 + 3;
z__4.r = wy->r * a[i__3].r - wy->i * a[i__3].i, z__4.i = wy->r * a[i__3]
.i + wy->i * a[i__3].r;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = (a_dim1 << 2) + 1;
i__2 = a_dim1 + 1;
z__2.r = wx->r * a[i__2].r - wx->i * a[i__2].i, z__2.i = wx->r * a[i__2]
.i + wx->i * a[i__2].r;
i__3 = (a_dim1 << 2) + 4;
z__3.r = wy->r * a[i__3].r - wy->i * a[i__3].i, z__3.i = wy->r * a[i__3]
.i + wy->i * a[i__3].r;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = (a_dim1 << 2) + 2;
i__2 = (a_dim1 << 1) + 2;
z__2.r = wx->r * a[i__2].r - wx->i * a[i__2].i, z__2.i = wx->r * a[i__2]
.i + wx->i * a[i__2].r;
i__3 = (a_dim1 << 2) + 4;
z__3.r = wy->r * a[i__3].r - wy->i * a[i__3].i, z__3.i = wy->r * a[i__3]
.i + wy->i * a[i__3].r;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = a_dim1 * 5 + 1;
z__3.r = -wx->r, z__3.i = -wx->i;
i__2 = a_dim1 + 1;
z__2.r = z__3.r * a[i__2].r - z__3.i * a[i__2].i, z__2.i = z__3.r * a[
i__2].i + z__3.i * a[i__2].r;
i__3 = a_dim1 * 5 + 5;
z__4.r = wy->r * a[i__3].r - wy->i * a[i__3].i, z__4.i = wy->r * a[i__3]
.i + wy->i * a[i__3].r;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = a_dim1 * 5 + 2;
i__2 = (a_dim1 << 1) + 2;
z__2.r = wx->r * a[i__2].r - wx->i * a[i__2].i, z__2.i = wx->r * a[i__2]
.i + wx->i * a[i__2].r;
i__3 = a_dim1 * 5 + 5;
z__3.r = wy->r * a[i__3].r - wy->i * a[i__3].i, z__3.i = wy->r * a[i__3]
.i + wy->i * a[i__3].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
/* Compute condition numbers */
s[1] = 1. / sqrt((z_abs(wy) * 3. * z_abs(wy) + 1.) / (z_abs(&a[a_dim1 + 1]
) * z_abs(&a[a_dim1 + 1]) + 1.));
s[2] = 1. / sqrt((z_abs(wy) * 3. * z_abs(wy) + 1.) / (z_abs(&a[(a_dim1 <<
1) + 2]) * z_abs(&a[(a_dim1 << 1) + 2]) + 1.));
s[3] = 1. / sqrt((z_abs(wx) * 2. * z_abs(wx) + 1.) / (z_abs(&a[a_dim1 * 3
+ 3]) * z_abs(&a[a_dim1 * 3 + 3]) + 1.));
s[4] = 1. / sqrt((z_abs(wx) * 2. * z_abs(wx) + 1.) / (z_abs(&a[(a_dim1 <<
2) + 4]) * z_abs(&a[(a_dim1 << 2) + 4]) + 1.));
s[5] = 1. / sqrt((z_abs(wx) * 2. * z_abs(wx) + 1.) / (z_abs(&a[a_dim1 * 5
+ 5]) * z_abs(&a[a_dim1 * 5 + 5]) + 1.));
zlakf2_(&c__1, &c__4, &a[a_offset], lda, &a[(a_dim1 << 1) + 2], &b[
b_offset], &b[(b_dim1 << 1) + 2], z__, &c__8);
zgesvd_("N", "N", &c__8, &c__8, z__, &c__8, rwork, work, &c__1, &work[1],
&c__1, &work[2], &c__24, &rwork[8], &info);
dif[1] = rwork[7];
zlakf2_(&c__4, &c__1, &a[a_offset], lda, &a[a_dim1 * 5 + 5], &b[b_offset],
&b[b_dim1 * 5 + 5], z__, &c__8);
zgesvd_("N", "N", &c__8, &c__8, z__, &c__8, rwork, work, &c__1, &work[1],
&c__1, &work[2], &c__24, &rwork[8], &info);
dif[5] = rwork[7];
return 0;
/* End of ZLATM6 */
} /* zlatm6_ */
/* Subroutine */
int zhptri_(char *uplo, integer *n, doublecomplex *ap, integer *ipiv, doublecomplex *work, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2;
/* Builtin functions */
double z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
doublereal d__;
integer j, k;
doublereal t, ak;
integer kc, kp, kx, kpc, npp;
doublereal akp1;
doublecomplex temp, akkp1;
extern logical lsame_(char *, char *);
extern /* Double Complex */
VOID zdotc_f2c_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *);
integer kstep;
logical upper;
extern /* Subroutine */
int zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), zhpmv_(char *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zswap_( integer *, doublecomplex *, integer *, doublecomplex *, integer *) , xerbla_(char *, integer *);
integer kcnext;
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--work;
--ipiv;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZHPTRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
/* Check that the diagonal matrix D is nonsingular. */
if (upper)
{
/* Upper triangular storage: examine D from bottom to top */
kp = *n * (*n + 1) / 2;
for (*info = *n;
*info >= 1;
--(*info))
{
i__1 = kp;
if (ipiv[*info] > 0 && (ap[i__1].r == 0. && ap[i__1].i == 0.))
{
return 0;
}
kp -= *info;
/* L10: */
}
}
else
{
/* Lower triangular storage: examine D from top to bottom. */
kp = 1;
i__1 = *n;
for (*info = 1;
*info <= i__1;
++(*info))
{
i__2 = kp;
if (ipiv[*info] > 0 && (ap[i__2].r == 0. && ap[i__2].i == 0.))
{
return 0;
}
kp = kp + *n - *info + 1;
/* L20: */
}
}
*info = 0;
if (upper)
{
/* Compute inv(A) from the factorization A = U*D*U**H. */
/* 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;
L30: /* If K > N, exit from loop. */
if (k > *n)
{
goto L50;
}
kcnext = kc + k;
if (ipiv[k] > 0)
{
/* 1 x 1 diagonal block */
/* Invert the diagonal block. */
i__1 = kc + k - 1;
i__2 = kc + k - 1;
d__1 = 1. / ap[i__2].r;
ap[i__1].r = d__1;
ap[i__1].i = 0.; // , expr subst
/* Compute column K of the inverse. */
if (k > 1)
{
i__1 = k - 1;
zcopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
i__1 = k - 1;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zhpmv_(uplo, &i__1, &z__1, &ap[1], &work[1], &c__1, &c_b2, & ap[kc], &c__1);
i__1 = kc + k - 1;
i__2 = kc + k - 1;
i__3 = k - 1;
zdotc_f2c_(&z__2, &i__3, &work[1], &c__1, &ap[kc], &c__1);
d__1 = z__2.r;
z__1.r = ap[i__2].r - d__1;
z__1.i = ap[i__2].i; // , expr subst
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
}
kstep = 1;
}
else
{
/* 2 x 2 diagonal block */
/* Invert the diagonal block. */
t = z_abs(&ap[kcnext + k - 1]);
i__1 = kc + k - 1;
ak = ap[i__1].r / t;
i__1 = kcnext + k;
akp1 = ap[i__1].r / t;
i__1 = kcnext + k - 1;
z__1.r = ap[i__1].r / t;
z__1.i = ap[i__1].i / t; // , expr subst
akkp1.r = z__1.r;
akkp1.i = z__1.i; // , expr subst
d__ = t * (ak * akp1 - 1.);
i__1 = kc + k - 1;
d__1 = akp1 / d__;
ap[i__1].r = d__1;
ap[i__1].i = 0.; // , expr subst
i__1 = kcnext + k;
d__1 = ak / d__;
ap[i__1].r = d__1;
ap[i__1].i = 0.; // , expr subst
i__1 = kcnext + k - 1;
z__2.r = -akkp1.r;
z__2.i = -akkp1.i; // , expr subst
z__1.r = z__2.r / d__;
z__1.i = z__2.i / d__; // , expr subst
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
/* Compute columns K and K+1 of the inverse. */
if (k > 1)
{
i__1 = k - 1;
zcopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
i__1 = k - 1;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zhpmv_(uplo, &i__1, &z__1, &ap[1], &work[1], &c__1, &c_b2, & ap[kc], &c__1);
i__1 = kc + k - 1;
i__2 = kc + k - 1;
i__3 = k - 1;
zdotc_f2c_(&z__2, &i__3, &work[1], &c__1, &ap[kc], &c__1);
d__1 = z__2.r;
z__1.r = ap[i__2].r - d__1;
z__1.i = ap[i__2].i; // , expr subst
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
i__1 = kcnext + k - 1;
i__2 = kcnext + k - 1;
i__3 = k - 1;
zdotc_f2c_(&z__2, &i__3, &ap[kc], &c__1, &ap[kcnext], &c__1);
z__1.r = ap[i__2].r - z__2.r;
z__1.i = ap[i__2].i - z__2.i; // , expr subst
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
i__1 = k - 1;
zcopy_(&i__1, &ap[kcnext], &c__1, &work[1], &c__1);
i__1 = k - 1;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zhpmv_(uplo, &i__1, &z__1, &ap[1], &work[1], &c__1, &c_b2, & ap[kcnext], &c__1);
i__1 = kcnext + k;
i__2 = kcnext + k;
i__3 = k - 1;
zdotc_f2c_(&z__2, &i__3, &work[1], &c__1, &ap[kcnext], &c__1);
d__1 = z__2.r;
z__1.r = ap[i__2].r - d__1;
z__1.i = ap[i__2].i; // , expr subst
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
}
kstep = 2;
kcnext = kcnext + k + 1;
}
kp = (i__1 = ipiv[k], f2c_abs(i__1));
if (kp != k)
{
/* Interchange rows and columns K and KP in the leading */
/* submatrix A(1:k+1,1:k+1) */
kpc = (kp - 1) * kp / 2 + 1;
i__1 = kp - 1;
zswap_(&i__1, &ap[kc], &c__1, &ap[kpc], &c__1);
kx = kpc + kp - 1;
i__1 = k - 1;
for (j = kp + 1;
j <= i__1;
++j)
{
kx = kx + j - 1;
d_cnjg(&z__1, &ap[kc + j - 1]);
temp.r = z__1.r;
temp.i = z__1.i; // , expr subst
i__2 = kc + j - 1;
d_cnjg(&z__1, &ap[kx]);
ap[i__2].r = z__1.r;
ap[i__2].i = z__1.i; // , expr subst
i__2 = kx;
ap[i__2].r = temp.r;
ap[i__2].i = temp.i; // , expr subst
/* L40: */
}
i__1 = kc + kp - 1;
d_cnjg(&z__1, &ap[kc + kp - 1]);
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
i__1 = kc + k - 1;
temp.r = ap[i__1].r;
temp.i = ap[i__1].i; // , expr subst
i__1 = kc + k - 1;
i__2 = kpc + kp - 1;
ap[i__1].r = ap[i__2].r;
ap[i__1].i = ap[i__2].i; // , expr subst
i__1 = kpc + kp - 1;
ap[i__1].r = temp.r;
ap[i__1].i = temp.i; // , expr subst
if (kstep == 2)
{
i__1 = kc + k + k - 1;
temp.r = ap[i__1].r;
temp.i = ap[i__1].i; // , expr subst
i__1 = kc + k + k - 1;
i__2 = kc + k + kp - 1;
ap[i__1].r = ap[i__2].r;
ap[i__1].i = ap[i__2].i; // , expr subst
i__1 = kc + k + kp - 1;
ap[i__1].r = temp.r;
ap[i__1].i = temp.i; // , expr subst
}
}
k += kstep;
kc = kcnext;
goto L30;
L50:
;
}
else
{
/* Compute inv(A) from the factorization A = L*D*L**H. */
/* 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. */
npp = *n * (*n + 1) / 2;
k = *n;
kc = npp;
L60: /* If K < 1, exit from loop. */
if (k < 1)
{
goto L80;
}
kcnext = kc - (*n - k + 2);
if (ipiv[k] > 0)
{
/* 1 x 1 diagonal block */
/* Invert the diagonal block. */
i__1 = kc;
i__2 = kc;
d__1 = 1. / ap[i__2].r;
ap[i__1].r = d__1;
ap[i__1].i = 0.; // , expr subst
/* Compute column K of the inverse. */
if (k < *n)
{
i__1 = *n - k;
zcopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
i__1 = *n - k;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zhpmv_(uplo, &i__1, &z__1, &ap[kc + *n - k + 1], &work[1], & c__1, &c_b2, &ap[kc + 1], &c__1);
i__1 = kc;
i__2 = kc;
i__3 = *n - k;
zdotc_f2c_(&z__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1);
d__1 = z__2.r;
z__1.r = ap[i__2].r - d__1;
z__1.i = ap[i__2].i; // , expr subst
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
}
kstep = 1;
}
else
{
/* 2 x 2 diagonal block */
/* Invert the diagonal block. */
t = z_abs(&ap[kcnext + 1]);
i__1 = kcnext;
ak = ap[i__1].r / t;
i__1 = kc;
akp1 = ap[i__1].r / t;
i__1 = kcnext + 1;
z__1.r = ap[i__1].r / t;
z__1.i = ap[i__1].i / t; // , expr subst
akkp1.r = z__1.r;
akkp1.i = z__1.i; // , expr subst
d__ = t * (ak * akp1 - 1.);
i__1 = kcnext;
d__1 = akp1 / d__;
ap[i__1].r = d__1;
ap[i__1].i = 0.; // , expr subst
i__1 = kc;
d__1 = ak / d__;
ap[i__1].r = d__1;
ap[i__1].i = 0.; // , expr subst
i__1 = kcnext + 1;
z__2.r = -akkp1.r;
z__2.i = -akkp1.i; // , expr subst
z__1.r = z__2.r / d__;
z__1.i = z__2.i / d__; // , expr subst
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
/* Compute columns K-1 and K of the inverse. */
if (k < *n)
{
i__1 = *n - k;
zcopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
i__1 = *n - k;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zhpmv_(uplo, &i__1, &z__1, &ap[kc + (*n - k + 1)], &work[1], & c__1, &c_b2, &ap[kc + 1], &c__1);
i__1 = kc;
i__2 = kc;
i__3 = *n - k;
zdotc_f2c_(&z__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1);
d__1 = z__2.r;
z__1.r = ap[i__2].r - d__1;
z__1.i = ap[i__2].i; // , expr subst
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
i__1 = kcnext + 1;
i__2 = kcnext + 1;
i__3 = *n - k;
zdotc_f2c_(&z__2, &i__3, &ap[kc + 1], &c__1, &ap[kcnext + 2], & c__1);
z__1.r = ap[i__2].r - z__2.r;
z__1.i = ap[i__2].i - z__2.i; // , expr subst
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
i__1 = *n - k;
zcopy_(&i__1, &ap[kcnext + 2], &c__1, &work[1], &c__1);
i__1 = *n - k;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zhpmv_(uplo, &i__1, &z__1, &ap[kc + (*n - k + 1)], &work[1], & c__1, &c_b2, &ap[kcnext + 2], &c__1);
i__1 = kcnext;
i__2 = kcnext;
i__3 = *n - k;
zdotc_f2c_(&z__2, &i__3, &work[1], &c__1, &ap[kcnext + 2], &c__1);
d__1 = z__2.r;
z__1.r = ap[i__2].r - d__1;
z__1.i = ap[i__2].i; // , expr subst
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
}
kstep = 2;
kcnext -= *n - k + 3;
}
kp = (i__1 = ipiv[k], f2c_abs(i__1));
if (kp != k)
{
/* Interchange rows and columns K and KP in the trailing */
/* submatrix A(k-1:n,k-1:n) */
kpc = npp - (*n - kp + 1) * (*n - kp + 2) / 2 + 1;
if (kp < *n)
{
i__1 = *n - kp;
zswap_(&i__1, &ap[kc + kp - k + 1], &c__1, &ap[kpc + 1], & c__1);
}
kx = kc + kp - k;
i__1 = kp - 1;
for (j = k + 1;
j <= i__1;
++j)
{
kx = kx + *n - j + 1;
d_cnjg(&z__1, &ap[kc + j - k]);
temp.r = z__1.r;
temp.i = z__1.i; // , expr subst
i__2 = kc + j - k;
d_cnjg(&z__1, &ap[kx]);
ap[i__2].r = z__1.r;
ap[i__2].i = z__1.i; // , expr subst
i__2 = kx;
ap[i__2].r = temp.r;
ap[i__2].i = temp.i; // , expr subst
/* L70: */
}
i__1 = kc + kp - k;
d_cnjg(&z__1, &ap[kc + kp - k]);
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
i__1 = kc;
temp.r = ap[i__1].r;
temp.i = ap[i__1].i; // , expr subst
i__1 = kc;
i__2 = kpc;
ap[i__1].r = ap[i__2].r;
ap[i__1].i = ap[i__2].i; // , expr subst
i__1 = kpc;
ap[i__1].r = temp.r;
ap[i__1].i = temp.i; // , expr subst
if (kstep == 2)
{
i__1 = kc - *n + k - 1;
temp.r = ap[i__1].r;
temp.i = ap[i__1].i; // , expr subst
i__1 = kc - *n + k - 1;
i__2 = kc - *n + kp - 1;
ap[i__1].r = ap[i__2].r;
ap[i__1].i = ap[i__2].i; // , expr subst
i__1 = kc - *n + kp - 1;
ap[i__1].r = temp.r;
ap[i__1].i = temp.i; // , expr subst
}
}
k -= kstep;
kc = kcnext;
goto L60;
L80:
;
}
return 0;
/* End of ZHPTRI */
}
/* Subroutine */ int zlaptm_(char *uplo, integer *n, integer *nrhs,
doublereal *alpha, doublereal *d__, doublecomplex *e, doublecomplex *
x, integer *ldx, doublereal *beta, doublecomplex *b, integer *ldb)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5,
i__6, i__7, i__8, i__9;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static integer i__, j;
extern logical lsame_(char *, char *);
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define x_subscr(a_1,a_2) (a_2)*x_dim1 + a_1
#define x_ref(a_1,a_2) x[x_subscr(a_1,a_2)]
/* -- LAPACK auxiliary 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
=======
ZLAPTM multiplies an N by NRHS matrix X by a Hermitian tridiagonal
matrix A and stores the result in a matrix B. The operation has the
form
B := alpha * A * X + beta * B
where alpha may be either 1. or -1. and beta may be 0., 1., or -1.
Arguments
=========
UPLO (input) CHARACTER
Specifies whether the superdiagonal or the subdiagonal of the
tridiagonal matrix A is stored.
= 'U': Upper, E is the superdiagonal of A.
= 'L': Lower, E is the subdiagonal of A.
N (input) INTEGER
The order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices X and B.
ALPHA (input) DOUBLE PRECISION
The scalar alpha. ALPHA must be 1. or -1.; otherwise,
it is assumed to be 0.
D (input) DOUBLE PRECISION array, dimension (N)
The n diagonal elements of the tridiagonal matrix A.
E (input) COMPLEX*16 array, dimension (N-1)
The (n-1) subdiagonal or superdiagonal elements of A.
X (input) COMPLEX*16 array, dimension (LDX,NRHS)
The N by NRHS matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(N,1).
BETA (input) DOUBLE PRECISION
The scalar beta. BETA must be 0., 1., or -1.; otherwise,
it is assumed to be 1.
B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
On entry, the N by NRHS matrix B.
On exit, B is overwritten by the matrix expression
B := alpha * A * X + beta * B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(N,1).
=====================================================================
Parameter adjustments */
--d__;
--e;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
/* Function Body */
if (*n == 0) {
return 0;
}
if (*beta == 0.) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
b[i__3].r = 0., b[i__3].i = 0.;
/* L10: */
}
/* L20: */
}
} else if (*beta == -1.) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = b_subscr(i__, j);
z__1.r = -b[i__4].r, z__1.i = -b[i__4].i;
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
/* L30: */
}
/* L40: */
}
}
if (*alpha == 1.) {
if (lsame_(uplo, "U")) {
/* Compute B := B + A*X, where E is the superdiagonal of A. */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
if (*n == 1) {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
i__4 = x_subscr(1, j);
z__2.r = d__[1] * x[i__4].r, z__2.i = d__[1] * x[i__4].i;
z__1.r = b[i__3].r + z__2.r, z__1.i = b[i__3].i + z__2.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
} else {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
i__4 = x_subscr(1, j);
z__3.r = d__[1] * x[i__4].r, z__3.i = d__[1] * x[i__4].i;
z__2.r = b[i__3].r + z__3.r, z__2.i = b[i__3].i + z__3.i;
i__5 = x_subscr(2, j);
z__4.r = e[1].r * x[i__5].r - e[1].i * x[i__5].i, z__4.i =
e[1].r * x[i__5].i + e[1].i * x[i__5].r;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = b_subscr(*n, j);
i__3 = b_subscr(*n, j);
d_cnjg(&z__4, &e[*n - 1]);
i__4 = x_subscr(*n - 1, j);
z__3.r = z__4.r * x[i__4].r - z__4.i * x[i__4].i, z__3.i =
z__4.r * x[i__4].i + z__4.i * x[i__4].r;
z__2.r = b[i__3].r + z__3.r, z__2.i = b[i__3].i + z__3.i;
i__5 = *n;
i__6 = x_subscr(*n, j);
z__5.r = d__[i__5] * x[i__6].r, z__5.i = d__[i__5] * x[
i__6].i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = b_subscr(i__, j);
d_cnjg(&z__5, &e[i__ - 1]);
i__5 = x_subscr(i__ - 1, j);
z__4.r = z__5.r * x[i__5].r - z__5.i * x[i__5].i,
z__4.i = z__5.r * x[i__5].i + z__5.i * x[i__5]
.r;
z__3.r = b[i__4].r + z__4.r, z__3.i = b[i__4].i +
z__4.i;
i__6 = i__;
i__7 = x_subscr(i__, j);
z__6.r = d__[i__6] * x[i__7].r, z__6.i = d__[i__6] *
x[i__7].i;
z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
i__8 = i__;
i__9 = x_subscr(i__ + 1, j);
z__7.r = e[i__8].r * x[i__9].r - e[i__8].i * x[i__9]
.i, z__7.i = e[i__8].r * x[i__9].i + e[i__8]
.i * x[i__9].r;
z__1.r = z__2.r + z__7.r, z__1.i = z__2.i + z__7.i;
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
/* L50: */
}
}
/* L60: */
}
} else {
/* Compute B := B + A*X, where E is the subdiagonal of A. */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
if (*n == 1) {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
i__4 = x_subscr(1, j);
z__2.r = d__[1] * x[i__4].r, z__2.i = d__[1] * x[i__4].i;
z__1.r = b[i__3].r + z__2.r, z__1.i = b[i__3].i + z__2.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
} else {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
i__4 = x_subscr(1, j);
z__3.r = d__[1] * x[i__4].r, z__3.i = d__[1] * x[i__4].i;
z__2.r = b[i__3].r + z__3.r, z__2.i = b[i__3].i + z__3.i;
d_cnjg(&z__5, &e[1]);
i__5 = x_subscr(2, j);
z__4.r = z__5.r * x[i__5].r - z__5.i * x[i__5].i, z__4.i =
z__5.r * x[i__5].i + z__5.i * x[i__5].r;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = b_subscr(*n, j);
i__3 = b_subscr(*n, j);
i__4 = *n - 1;
i__5 = x_subscr(*n - 1, j);
z__3.r = e[i__4].r * x[i__5].r - e[i__4].i * x[i__5].i,
z__3.i = e[i__4].r * x[i__5].i + e[i__4].i * x[
i__5].r;
z__2.r = b[i__3].r + z__3.r, z__2.i = b[i__3].i + z__3.i;
i__6 = *n;
i__7 = x_subscr(*n, j);
z__4.r = d__[i__6] * x[i__7].r, z__4.i = d__[i__6] * x[
i__7].i;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = b_subscr(i__, j);
i__5 = i__ - 1;
i__6 = x_subscr(i__ - 1, j);
z__4.r = e[i__5].r * x[i__6].r - e[i__5].i * x[i__6]
.i, z__4.i = e[i__5].r * x[i__6].i + e[i__5]
.i * x[i__6].r;
z__3.r = b[i__4].r + z__4.r, z__3.i = b[i__4].i +
z__4.i;
i__7 = i__;
i__8 = x_subscr(i__, j);
z__5.r = d__[i__7] * x[i__8].r, z__5.i = d__[i__7] *
x[i__8].i;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
d_cnjg(&z__7, &e[i__]);
i__9 = x_subscr(i__ + 1, j);
z__6.r = z__7.r * x[i__9].r - z__7.i * x[i__9].i,
z__6.i = z__7.r * x[i__9].i + z__7.i * x[i__9]
.r;
z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
/* L70: */
}
}
/* L80: */
}
}
} else if (*alpha == -1.) {
if (lsame_(uplo, "U")) {
/* Compute B := B - A*X, where E is the superdiagonal of A. */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
if (*n == 1) {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
i__4 = x_subscr(1, j);
z__2.r = d__[1] * x[i__4].r, z__2.i = d__[1] * x[i__4].i;
z__1.r = b[i__3].r - z__2.r, z__1.i = b[i__3].i - z__2.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
} else {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
i__4 = x_subscr(1, j);
z__3.r = d__[1] * x[i__4].r, z__3.i = d__[1] * x[i__4].i;
z__2.r = b[i__3].r - z__3.r, z__2.i = b[i__3].i - z__3.i;
i__5 = x_subscr(2, j);
z__4.r = e[1].r * x[i__5].r - e[1].i * x[i__5].i, z__4.i =
e[1].r * x[i__5].i + e[1].i * x[i__5].r;
z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - z__4.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = b_subscr(*n, j);
i__3 = b_subscr(*n, j);
d_cnjg(&z__4, &e[*n - 1]);
i__4 = x_subscr(*n - 1, j);
z__3.r = z__4.r * x[i__4].r - z__4.i * x[i__4].i, z__3.i =
z__4.r * x[i__4].i + z__4.i * x[i__4].r;
z__2.r = b[i__3].r - z__3.r, z__2.i = b[i__3].i - z__3.i;
i__5 = *n;
i__6 = x_subscr(*n, j);
z__5.r = d__[i__5] * x[i__6].r, z__5.i = d__[i__5] * x[
i__6].i;
z__1.r = z__2.r - z__5.r, z__1.i = z__2.i - z__5.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = b_subscr(i__, j);
d_cnjg(&z__5, &e[i__ - 1]);
i__5 = x_subscr(i__ - 1, j);
z__4.r = z__5.r * x[i__5].r - z__5.i * x[i__5].i,
z__4.i = z__5.r * x[i__5].i + z__5.i * x[i__5]
.r;
z__3.r = b[i__4].r - z__4.r, z__3.i = b[i__4].i -
z__4.i;
i__6 = i__;
i__7 = x_subscr(i__, j);
z__6.r = d__[i__6] * x[i__7].r, z__6.i = d__[i__6] *
x[i__7].i;
z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i;
i__8 = i__;
i__9 = x_subscr(i__ + 1, j);
z__7.r = e[i__8].r * x[i__9].r - e[i__8].i * x[i__9]
.i, z__7.i = e[i__8].r * x[i__9].i + e[i__8]
.i * x[i__9].r;
z__1.r = z__2.r - z__7.r, z__1.i = z__2.i - z__7.i;
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
/* L90: */
}
}
/* L100: */
}
} else {
/* Compute B := B - A*X, where E is the subdiagonal of A. */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
if (*n == 1) {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
i__4 = x_subscr(1, j);
z__2.r = d__[1] * x[i__4].r, z__2.i = d__[1] * x[i__4].i;
z__1.r = b[i__3].r - z__2.r, z__1.i = b[i__3].i - z__2.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
} else {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
i__4 = x_subscr(1, j);
z__3.r = d__[1] * x[i__4].r, z__3.i = d__[1] * x[i__4].i;
z__2.r = b[i__3].r - z__3.r, z__2.i = b[i__3].i - z__3.i;
d_cnjg(&z__5, &e[1]);
i__5 = x_subscr(2, j);
z__4.r = z__5.r * x[i__5].r - z__5.i * x[i__5].i, z__4.i =
z__5.r * x[i__5].i + z__5.i * x[i__5].r;
z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - z__4.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = b_subscr(*n, j);
i__3 = b_subscr(*n, j);
i__4 = *n - 1;
i__5 = x_subscr(*n - 1, j);
z__3.r = e[i__4].r * x[i__5].r - e[i__4].i * x[i__5].i,
z__3.i = e[i__4].r * x[i__5].i + e[i__4].i * x[
i__5].r;
z__2.r = b[i__3].r - z__3.r, z__2.i = b[i__3].i - z__3.i;
i__6 = *n;
i__7 = x_subscr(*n, j);
z__4.r = d__[i__6] * x[i__7].r, z__4.i = d__[i__6] * x[
i__7].i;
z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - z__4.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = b_subscr(i__, j);
i__5 = i__ - 1;
i__6 = x_subscr(i__ - 1, j);
z__4.r = e[i__5].r * x[i__6].r - e[i__5].i * x[i__6]
.i, z__4.i = e[i__5].r * x[i__6].i + e[i__5]
.i * x[i__6].r;
z__3.r = b[i__4].r - z__4.r, z__3.i = b[i__4].i -
z__4.i;
i__7 = i__;
i__8 = x_subscr(i__, j);
z__5.r = d__[i__7] * x[i__8].r, z__5.i = d__[i__7] *
x[i__8].i;
z__2.r = z__3.r - z__5.r, z__2.i = z__3.i - z__5.i;
d_cnjg(&z__7, &e[i__]);
i__9 = x_subscr(i__ + 1, j);
z__6.r = z__7.r * x[i__9].r - z__7.i * x[i__9].i,
z__6.i = z__7.r * x[i__9].i + z__7.i * x[i__9]
.r;
z__1.r = z__2.r - z__6.r, z__1.i = z__2.i - z__6.i;
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
/* L110: */
}
}
/* L120: */
}
}
}
return 0;
/* End of ZLAPTM */
} /* zlaptm_ */
/* Subroutine */ int zgehd2_(integer *n, integer *ilo, integer *ihi,
doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__;
doublecomplex alpha;
extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *), xerbla_(char *, integer *), zlarfg_(integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGEHD2 reduces a complex general matrix A to upper Hessenberg form H */
/* by a unitary similarity transformation: Q' * A * Q = H . */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that A is already upper triangular in rows */
/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
/* set by a previous call to ZGEBAL; otherwise they should be */
/* set to 1 and N respectively. See Further Details. */
/* 1 <= ILO <= IHI <= max(1,N). */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the n by n general matrix to be reduced. */
/* On exit, the upper triangle and the first subdiagonal of A */
/* are overwritten with the upper Hessenberg matrix H, and the */
/* elements below the first subdiagonal, with the array TAU, */
/* represent the unitary matrix Q as a product of elementary */
/* reflectors. See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* TAU (output) COMPLEX*16 array, dimension (N-1) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* WORK (workspace) COMPLEX*16 array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of (ihi-ilo) elementary */
/* reflectors */
/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a complex scalar, and v is a complex vector with */
/* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on */
/* exit in A(i+2:ihi,i), and tau in TAU(i). */
/* The contents of A are illustrated by the following example, with */
/* n = 7, ilo = 2 and ihi = 6: */
/* on entry, on exit, */
/* ( a a a a a a a ) ( a a h h h h a ) */
/* ( a a a a a a ) ( a h h h h a ) */
/* ( a a a a a a ) ( h h h h h h ) */
/* ( a a a a a a ) ( v2 h h h h h ) */
/* ( a a a a a a ) ( v2 v3 h h h h ) */
/* ( a a a a a a ) ( v2 v3 v4 h h h ) */
/* ( a ) ( a ) */
/* where a denotes an element of the original matrix A, h denotes a */
/* modified element of the upper Hessenberg matrix H, and vi denotes an */
/* element of the vector defining H(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*ilo < 1 || *ilo > max(1,*n)) {
*info = -2;
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEHD2", &i__1);
return 0;
}
i__1 = *ihi - 1;
for (i__ = *ilo; i__ <= i__1; ++i__) {
/* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) */
i__2 = i__ + 1 + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *ihi - i__;
/* Computing MIN */
i__3 = i__ + 2;
zlarfg_(&i__2, &alpha, &a[min(i__3, *n)+ i__ * a_dim1], &c__1, &tau[
i__]);
i__2 = i__ + 1 + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Apply H(i) to A(1:ihi,i+1:ihi) from the right */
i__2 = *ihi - i__;
zlarf_("Right", ihi, &i__2, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[
i__], &a[(i__ + 1) * a_dim1 + 1], lda, &work[1]);
/* Apply H(i)' to A(i+1:ihi,i+1:n) from the left */
i__2 = *ihi - i__;
i__3 = *n - i__;
d_cnjg(&z__1, &tau[i__]);
zlarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &c__1, &z__1,
&a[i__ + 1 + (i__ + 1) * a_dim1], lda, &work[1]);
i__2 = i__ + 1 + i__ * a_dim1;
a[i__2].r = alpha.r, a[i__2].i = alpha.i;
/* L10: */
}
return 0;
/* End of ZGEHD2 */
} /* zgehd2_ */
/* Subroutine */ int zhpr_(char *uplo, integer *n, doublereal *alpha,
doublecomplex *x, integer *incx, doublecomplex *ap, ftnlen uplo_len)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
doublereal d__1;
doublecomplex z__1, z__2;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static integer i__, j, k, kk, ix, jx, kx, info;
static doublecomplex temp;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
/* .. Scalar Arguments .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZHPR performs the hermitian rank 1 operation */
/* A := alpha*x*conjg( x' ) + A, */
/* where alpha is a real scalar, x is an n element vector and A is an */
/* n by n hermitian matrix, supplied in packed form. */
/* Parameters */
/* ========== */
/* UPLO - CHARACTER*1. */
/* On entry, UPLO specifies whether the upper or lower */
/* triangular part of the matrix A is supplied in the packed */
/* array AP as follows: */
/* UPLO = 'U' or 'u' The upper triangular part of A is */
/* supplied in AP. */
/* UPLO = 'L' or 'l' The lower triangular part of A is */
/* supplied in AP. */
/* Unchanged on exit. */
/* N - INTEGER. */
/* On entry, N specifies the order of the matrix A. */
/* N must be at least zero. */
/* Unchanged on exit. */
/* ALPHA - DOUBLE PRECISION. */
/* On entry, ALPHA specifies the scalar alpha. */
/* Unchanged on exit. */
/* X - COMPLEX*16 array of dimension at least */
/* ( 1 + ( n - 1 )*abs( INCX ) ). */
/* Before entry, the incremented array X must contain the n */
/* element vector x. */
/* Unchanged on exit. */
/* INCX - INTEGER. */
/* On entry, INCX specifies the increment for the elements of */
/* X. INCX must not be zero. */
/* Unchanged on exit. */
/* AP - COMPLEX*16 array of DIMENSION at least */
/* ( ( n*( n + 1 ) )/2 ). */
/* Before entry with UPLO = 'U' or 'u', the array AP must */
/* contain the upper triangular part of the hermitian matrix */
/* packed sequentially, column by column, so that AP( 1 ) */
/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
/* and a( 2, 2 ) respectively, and so on. On exit, the array */
/* AP is overwritten by the upper triangular part of the */
/* updated matrix. */
/* Before entry with UPLO = 'L' or 'l', the array AP must */
/* contain the lower triangular part of the hermitian matrix */
/* packed sequentially, column by column, so that AP( 1 ) */
/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
/* and a( 3, 1 ) respectively, and so on. On exit, the array */
/* AP is overwritten by the lower triangular part of the */
/* updated matrix. */
/* Note that the imaginary parts of the diagonal elements need */
/* not be set, they are assumed to be zero, and on exit they */
/* are set to zero. */
/* Level 2 Blas routine. */
/* -- Written on 22-October-1986. */
/* Jack Dongarra, Argonne National Lab. */
/* Jeremy Du Croz, Nag Central Office. */
/* Sven Hammarling, Nag Central Office. */
/* Richard Hanson, Sandia National Labs. */
/* .. Parameters .. */
/* .. Local Scalars .. */
/* .. External Functions .. */
/* .. External Subroutines .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
--x;
/* Function Body */
info = 0;
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (*n < 0) {
info = 2;
} else if (*incx == 0) {
info = 5;
}
if (info != 0) {
xerbla_("ZHPR ", &info, (ftnlen)6);
return 0;
}
/* Quick return if possible. */
if (*n == 0 || *alpha == 0.) {
return 0;
}
/* Set the start point in X if the increment is not unity. */
if (*incx <= 0) {
kx = 1 - (*n - 1) * *incx;
} else if (*incx != 1) {
kx = 1;
}
/* Start the operations. In this version the elements of the array AP */
/* are accessed sequentially with one pass through AP. */
kk = 1;
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/* Form A when upper triangle is stored in AP. */
if (*incx == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
if (x[i__2].r != 0. || x[i__2].i != 0.) {
d_cnjg(&z__2, &x[j]);
z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
k = kk;
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = k;
i__4 = k;
i__5 = i__;
z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
z__2.i = x[i__5].r * temp.i + x[i__5].i *
temp.r;
z__1.r = ap[i__4].r + z__2.r, z__1.i = ap[i__4].i +
z__2.i;
ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
++k;
/* L10: */
}
i__2 = kk + j - 1;
i__3 = kk + j - 1;
i__4 = j;
z__1.r = x[i__4].r * temp.r - x[i__4].i * temp.i, z__1.i =
x[i__4].r * temp.i + x[i__4].i * temp.r;
d__1 = ap[i__3].r + z__1.r;
ap[i__2].r = d__1, ap[i__2].i = 0.;
} else {
i__2 = kk + j - 1;
i__3 = kk + j - 1;
d__1 = ap[i__3].r;
ap[i__2].r = d__1, ap[i__2].i = 0.;
}
kk += j;
/* L20: */
}
} else {
jx = kx;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = jx;
if (x[i__2].r != 0. || x[i__2].i != 0.) {
d_cnjg(&z__2, &x[jx]);
z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
ix = kx;
i__2 = kk + j - 2;
for (k = kk; k <= i__2; ++k) {
i__3 = k;
i__4 = k;
i__5 = ix;
z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
z__2.i = x[i__5].r * temp.i + x[i__5].i *
temp.r;
z__1.r = ap[i__4].r + z__2.r, z__1.i = ap[i__4].i +
z__2.i;
ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
ix += *incx;
/* L30: */
}
i__2 = kk + j - 1;
i__3 = kk + j - 1;
i__4 = jx;
z__1.r = x[i__4].r * temp.r - x[i__4].i * temp.i, z__1.i =
x[i__4].r * temp.i + x[i__4].i * temp.r;
d__1 = ap[i__3].r + z__1.r;
ap[i__2].r = d__1, ap[i__2].i = 0.;
} else {
i__2 = kk + j - 1;
i__3 = kk + j - 1;
d__1 = ap[i__3].r;
ap[i__2].r = d__1, ap[i__2].i = 0.;
}
jx += *incx;
kk += j;
/* L40: */
}
}
} else {
/* Form A when lower triangle is stored in AP. */
if (*incx == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
if (x[i__2].r != 0. || x[i__2].i != 0.) {
d_cnjg(&z__2, &x[j]);
z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
i__2 = kk;
i__3 = kk;
i__4 = j;
z__1.r = temp.r * x[i__4].r - temp.i * x[i__4].i, z__1.i =
temp.r * x[i__4].i + temp.i * x[i__4].r;
d__1 = ap[i__3].r + z__1.r;
ap[i__2].r = d__1, ap[i__2].i = 0.;
k = kk + 1;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = k;
i__4 = k;
i__5 = i__;
z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
z__2.i = x[i__5].r * temp.i + x[i__5].i *
temp.r;
z__1.r = ap[i__4].r + z__2.r, z__1.i = ap[i__4].i +
z__2.i;
ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
++k;
/* L50: */
}
} else {
i__2 = kk;
i__3 = kk;
d__1 = ap[i__3].r;
ap[i__2].r = d__1, ap[i__2].i = 0.;
}
kk = kk + *n - j + 1;
/* L60: */
}
} else {
jx = kx;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = jx;
if (x[i__2].r != 0. || x[i__2].i != 0.) {
d_cnjg(&z__2, &x[jx]);
z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
i__2 = kk;
i__3 = kk;
i__4 = jx;
z__1.r = temp.r * x[i__4].r - temp.i * x[i__4].i, z__1.i =
temp.r * x[i__4].i + temp.i * x[i__4].r;
d__1 = ap[i__3].r + z__1.r;
ap[i__2].r = d__1, ap[i__2].i = 0.;
ix = jx;
i__2 = kk + *n - j;
for (k = kk + 1; k <= i__2; ++k) {
ix += *incx;
i__3 = k;
i__4 = k;
i__5 = ix;
z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
z__2.i = x[i__5].r * temp.i + x[i__5].i *
temp.r;
z__1.r = ap[i__4].r + z__2.r, z__1.i = ap[i__4].i +
z__2.i;
ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
/* L70: */
}
} else {
i__2 = kk;
i__3 = kk;
d__1 = ap[i__3].r;
ap[i__2].r = d__1, ap[i__2].i = 0.;
}
jx += *incx;
kk = kk + *n - j + 1;
/* L80: */
}
}
}
return 0;
/* End of ZHPR . */
} /* zhpr_ */
/* Subroutine */
int zhpmv_(char *uplo, integer *n, doublecomplex *alpha, doublecomplex *ap, doublecomplex *x, integer *incx, doublecomplex * beta, doublecomplex *y, integer *incy)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
doublereal d__1;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer info;
doublecomplex temp1, temp2;
integer i__, j, k;
extern logical lsame_(char *, char *);
integer kk, ix, iy, jx, jy, kx, ky;
extern /* Subroutine */
int xerbla_(char *, integer *);
/* .. Scalar Arguments .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZHPMV performs the matrix-vector operation */
/* y := alpha*A*x + beta*y, */
/* where alpha and beta are scalars, x and y are n element vectors and */
/* A is an n by n hermitian matrix, supplied in packed form. */
/* Parameters */
/* ========== */
/* UPLO - CHARACTER*1. */
/* On entry, UPLO specifies whether the upper or lower */
/* triangular part of the matrix A is supplied in the packed */
/* array AP as follows: */
/* UPLO = 'U' or 'u' The upper triangular part of A is */
/* supplied in AP. */
/* UPLO = 'L' or 'l' The lower triangular part of A is */
/* supplied in AP. */
/* Unchanged on exit. */
/* N - INTEGER. */
/* On entry, N specifies the order of the matrix A. */
/* N must be at least zero. */
/* Unchanged on exit. */
/* ALPHA - COMPLEX*16 . */
/* On entry, ALPHA specifies the scalar alpha. */
/* Unchanged on exit. */
/* AP - COMPLEX*16 array of DIMENSION at least */
/* ( ( n*( n + 1 ) )/2 ). */
/* Before entry with UPLO = 'U' or 'u', the array AP must */
/* contain the upper triangular part of the hermitian matrix */
/* packed sequentially, column by column, so that AP( 1 ) */
/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
/* and a( 2, 2 ) respectively, and so on. */
/* Before entry with UPLO = 'L' or 'l', the array AP must */
/* contain the lower triangular part of the hermitian matrix */
/* packed sequentially, column by column, so that AP( 1 ) */
/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
/* and a( 3, 1 ) respectively, and so on. */
/* Note that the imaginary parts of the diagonal elements need */
/* not be set and are assumed to be zero. */
/* Unchanged on exit. */
/* X - COMPLEX*16 array of dimension at least */
/* ( 1 + ( n - 1 )*f2c_abs( INCX ) ). */
/* Before entry, the incremented array X must contain the n */
/* element vector x. */
/* Unchanged on exit. */
/* INCX - INTEGER. */
/* On entry, INCX specifies the increment for the elements of */
/* X. INCX must not be zero. */
/* Unchanged on exit. */
/* BETA - COMPLEX*16 . */
/* On entry, BETA specifies the scalar beta. When BETA is */
/* supplied as zero then Y need not be set on input. */
/* Unchanged on exit. */
/* Y - COMPLEX*16 array of dimension at least */
/* ( 1 + ( n - 1 )*f2c_abs( INCY ) ). */
/* Before entry, the incremented array Y must contain the n */
/* element vector y. On exit, Y is overwritten by the updated */
/* vector y. */
/* INCY - INTEGER. */
/* On entry, INCY specifies the increment for the elements of */
/* Y. INCY must not be zero. */
/* Unchanged on exit. */
/* Level 2 Blas routine. */
/* -- Written on 22-October-1986. */
/* Jack Dongarra, Argonne National Lab. */
/* Jeremy Du Croz, Nag Central Office. */
/* Sven Hammarling, Nag Central Office. */
/* Richard Hanson, Sandia National Labs. */
/* .. Parameters .. */
/* .. Local Scalars .. */
/* .. External Functions .. */
/* .. External Subroutines .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--y;
--x;
--ap;
/* Function Body */
info = 0;
if (! lsame_(uplo, "U") && ! lsame_(uplo, "L"))
{
info = 1;
}
else if (*n < 0)
{
info = 2;
}
else if (*incx == 0)
{
info = 6;
}
else if (*incy == 0)
{
info = 9;
}
if (info != 0)
{
xerbla_("ZHPMV ", &info);
return 0;
}
/* Quick return if possible. */
if (*n == 0 || alpha->r == 0. && alpha->i == 0. && (beta->r == 1. && beta->i == 0.))
{
return 0;
}
/* Set up the start points in X and Y. */
if (*incx > 0)
{
kx = 1;
}
else
{
kx = 1 - (*n - 1) * *incx;
}
if (*incy > 0)
{
ky = 1;
}
else
{
ky = 1 - (*n - 1) * *incy;
}
/* Start the operations. In this version the elements of the array AP */
/* are accessed sequentially with one pass through AP. */
/* First form y := beta*y. */
if (beta->r != 1. || beta->i != 0.)
{
if (*incy == 1)
{
if (beta->r == 0. && beta->i == 0.)
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
i__2 = i__;
y[i__2].r = 0., y[i__2].i = 0.;
/* L10: */
}
}
else
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
i__2 = i__;
i__3 = i__;
z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, z__1.i = beta->r * y[i__3].i + beta->i * y[i__3] .r;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
/* L20: */
}
}
}
else
{
iy = ky;
if (beta->r == 0. && beta->i == 0.)
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
i__2 = iy;
y[i__2].r = 0., y[i__2].i = 0.;
iy += *incy;
/* L30: */
}
}
else
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
i__2 = iy;
i__3 = iy;
z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, z__1.i = beta->r * y[i__3].i + beta->i * y[i__3] .r;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
iy += *incy;
/* L40: */
}
}
}
}
if (alpha->r == 0. && alpha->i == 0.)
{
return 0;
}
kk = 1;
if (lsame_(uplo, "U"))
{
/* Form y when AP contains the upper triangle. */
if (*incx == 1 && *incy == 1)
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = j;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.;
k = kk;
i__2 = j - 1;
for (i__ = 1;
i__ <= i__2;
++i__)
{
i__3 = i__;
i__4 = i__;
i__5 = k;
z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5] .r;
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
d_cnjg(&z__3, &ap[k]);
i__3 = i__;
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3].r;
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
temp2.r = z__1.r, temp2.i = z__1.i;
++k;
/* L50: */
}
i__2 = j;
i__3 = j;
i__4 = kk + j - 1;
d__1 = ap[i__4].r;
z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i;
z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i;
z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i = alpha->r * temp2.i + alpha->i * temp2.r;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
kk += j;
/* L60: */
}
}
else
{
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = jx;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.;
ix = kx;
iy = ky;
i__2 = kk + j - 2;
for (k = kk;
k <= i__2;
++k)
{
i__3 = iy;
i__4 = iy;
i__5 = k;
z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5] .r;
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
d_cnjg(&z__3, &ap[k]);
i__3 = ix;
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3].r;
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
temp2.r = z__1.r, temp2.i = z__1.i;
ix += *incx;
iy += *incy;
/* L70: */
}
i__2 = jy;
i__3 = jy;
i__4 = kk + j - 1;
d__1 = ap[i__4].r;
z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i;
z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i;
z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i = alpha->r * temp2.i + alpha->i * temp2.r;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
jx += *incx;
jy += *incy;
kk += j;
/* L80: */
}
}
}
else
{
/* Form y when AP contains the lower triangle. */
if (*incx == 1 && *incy == 1)
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = j;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.;
i__2 = j;
i__3 = j;
i__4 = kk;
d__1 = ap[i__4].r;
z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i;
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
k = kk + 1;
i__2 = *n;
for (i__ = j + 1;
i__ <= i__2;
++i__)
{
i__3 = i__;
i__4 = i__;
i__5 = k;
z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5] .r;
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
d_cnjg(&z__3, &ap[k]);
i__3 = i__;
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3].r;
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
temp2.r = z__1.r, temp2.i = z__1.i;
++k;
/* L90: */
}
i__2 = j;
i__3 = j;
z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i = alpha->r * temp2.i + alpha->i * temp2.r;
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
kk += *n - j + 1;
/* L100: */
}
}
else
{
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = jx;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.;
i__2 = jy;
i__3 = jy;
i__4 = kk;
d__1 = ap[i__4].r;
z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i;
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
ix = jx;
iy = jy;
i__2 = kk + *n - j;
for (k = kk + 1;
k <= i__2;
++k)
{
ix += *incx;
iy += *incy;
i__3 = iy;
i__4 = iy;
i__5 = k;
z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5] .r;
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
d_cnjg(&z__3, &ap[k]);
i__3 = ix;
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3].r;
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
temp2.r = z__1.r, temp2.i = z__1.i;
/* L110: */
}
i__2 = jy;
i__3 = jy;
z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i = alpha->r * temp2.i + alpha->i * temp2.r;
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
jx += *incx;
jy += *incy;
kk += *n - j + 1;
/* L120: */
}
}
}
return 0;
/* End of ZHPMV . */
}
/* Subroutine */ int zgbbrd_(char *vect, integer *m, integer *n, integer *ncc,
integer *kl, integer *ku, doublecomplex *ab, integer *ldab,
doublereal *d__, doublereal *e, doublecomplex *q, integer *ldq,
doublecomplex *pt, integer *ldpt, doublecomplex *c__, integer *ldc,
doublecomplex *work, doublereal *rwork, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, c_dim1, c_offset, pt_dim1, pt_offset, q_dim1,
q_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
doublecomplex z__1, z__2, z__3;
/* Local variables */
integer i__, j, l;
doublecomplex t;
integer j1, j2, kb;
doublecomplex ra, rb;
doublereal rc;
integer kk, ml, nr, mu;
doublecomplex rs;
integer kb1, ml0, mu0, klm, kun, nrt, klu1, inca;
doublereal abst;
logical wantb, wantc;
integer minmn;
logical wantq;
logical wantpt;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* ZGBBRD reduces a complex general m-by-n band matrix A to real upper */
/* bidiagonal form B by a unitary transformation: Q' * A * P = B. */
/* The routine computes B, and optionally forms Q or P', or computes */
/* Q'*C for a given matrix C. */
/* Arguments */
/* ========= */
/* VECT (input) CHARACTER*1 */
/* Specifies whether or not the matrices Q and P' are to be */
/* formed. */
/* = 'N': do not form Q or P'; */
/* = 'Q': form Q only; */
/* = 'P': form P' only; */
/* = 'B': form both. */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* NCC (input) INTEGER */
/* The number of columns of the matrix C. NCC >= 0. */
/* KL (input) INTEGER */
/* The number of subdiagonals of the matrix A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of superdiagonals of the matrix A. KU >= 0. */
/* AB (input/output) COMPLEX*16 array, dimension (LDAB,N) */
/* On entry, the m-by-n band matrix A, stored in rows 1 to */
/* KL+KU+1. The j-th column of A is stored in the j-th column of */
/* the array AB as follows: */
/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl). */
/* On exit, A is overwritten by values generated during the */
/* reduction. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array A. LDAB >= KL+KU+1. */
/* D (output) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The diagonal elements of the bidiagonal matrix B. */
/* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) */
/* The superdiagonal elements of the bidiagonal matrix B. */
/* Q (output) COMPLEX*16 array, dimension (LDQ,M) */
/* If VECT = 'Q' or 'B', the m-by-m unitary matrix Q. */
/* If VECT = 'N' or 'P', the array Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. */
/* LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise. */
/* PT (output) COMPLEX*16 array, dimension (LDPT,N) */
/* If VECT = 'P' or 'B', the n-by-n unitary matrix P'. */
/* If VECT = 'N' or 'Q', the array PT is not referenced. */
/* LDPT (input) INTEGER */
/* The leading dimension of the array PT. */
/* LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise. */
/* C (input/output) COMPLEX*16 array, dimension (LDC,NCC) */
/* On entry, an m-by-ncc matrix C. */
/* On exit, C is overwritten by Q'*C. */
/* C is not referenced if NCC = 0. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. */
/* LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0. */
/* WORK (workspace) COMPLEX*16 array, dimension (max(M,N)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (max(M,N)) */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* ===================================================================== */
/* Test the input parameters */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--d__;
--e;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
pt_dim1 = *ldpt;
pt_offset = 1 + pt_dim1;
pt -= pt_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
--rwork;
/* Function Body */
wantb = lsame_(vect, "B");
wantq = lsame_(vect, "Q") || wantb;
wantpt = lsame_(vect, "P") || wantb;
wantc = *ncc > 0;
klu1 = *kl + *ku + 1;
*info = 0;
if (! wantq && ! wantpt && ! lsame_(vect, "N")) {
*info = -1;
} else if (*m < 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ncc < 0) {
*info = -4;
} else if (*kl < 0) {
*info = -5;
} else if (*ku < 0) {
*info = -6;
} else if (*ldab < klu1) {
*info = -8;
} else if (*ldq < 1 || wantq && *ldq < max(1,*m)) {
*info = -12;
} else if (*ldpt < 1 || wantpt && *ldpt < max(1,*n)) {
*info = -14;
} else if (*ldc < 1 || wantc && *ldc < max(1,*m)) {
*info = -16;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGBBRD", &i__1);
return 0;
}
/* Initialize Q and P' to the unit matrix, if needed */
if (wantq) {
zlaset_("Full", m, m, &c_b1, &c_b2, &q[q_offset], ldq);
}
if (wantpt) {
zlaset_("Full", n, n, &c_b1, &c_b2, &pt[pt_offset], ldpt);
}
/* Quick return if possible. */
if (*m == 0 || *n == 0) {
return 0;
}
minmn = min(*m,*n);
if (*kl + *ku > 1) {
/* Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce */
/* first to lower bidiagonal form and then transform to upper */
/* bidiagonal */
if (*ku > 0) {
ml0 = 1;
mu0 = 2;
} else {
ml0 = 2;
mu0 = 1;
}
/* Wherever possible, plane rotations are generated and applied in */
/* vector operations of length NR over the index set J1:J2:KLU1. */
/* The complex sines of the plane rotations are stored in WORK, */
/* and the real cosines in RWORK. */
/* Computing MIN */
i__1 = *m - 1;
klm = min(i__1,*kl);
/* Computing MIN */
i__1 = *n - 1;
kun = min(i__1,*ku);
kb = klm + kun;
kb1 = kb + 1;
inca = kb1 * *ldab;
nr = 0;
j1 = klm + 2;
j2 = 1 - kun;
i__1 = minmn;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Reduce i-th column and i-th row of matrix to bidiagonal form */
ml = klm + 1;
mu = kun + 1;
i__2 = kb;
for (kk = 1; kk <= i__2; ++kk) {
j1 += kb;
j2 += kb;
/* generate plane rotations to annihilate nonzero elements */
/* which have been created below the band */
if (nr > 0) {
zlargv_(&nr, &ab[klu1 + (j1 - klm - 1) * ab_dim1], &inca,
&work[j1], &kb1, &rwork[j1], &kb1);
}
/* apply plane rotations from the left */
i__3 = kb;
for (l = 1; l <= i__3; ++l) {
if (j2 - klm + l - 1 > *n) {
nrt = nr - 1;
} else {
nrt = nr;
}
if (nrt > 0) {
zlartv_(&nrt, &ab[klu1 - l + (j1 - klm + l - 1) *
ab_dim1], &inca, &ab[klu1 - l + 1 + (j1 - klm
+ l - 1) * ab_dim1], &inca, &rwork[j1], &work[
j1], &kb1);
}
}
if (ml > ml0) {
if (ml <= *m - i__ + 1) {
/* generate plane rotation to annihilate a(i+ml-1,i) */
/* within the band, and apply rotation from the left */
zlartg_(&ab[*ku + ml - 1 + i__ * ab_dim1], &ab[*ku +
ml + i__ * ab_dim1], &rwork[i__ + ml - 1], &
work[i__ + ml - 1], &ra);
i__3 = *ku + ml - 1 + i__ * ab_dim1;
ab[i__3].r = ra.r, ab[i__3].i = ra.i;
if (i__ < *n) {
/* Computing MIN */
i__4 = *ku + ml - 2, i__5 = *n - i__;
i__3 = min(i__4,i__5);
i__6 = *ldab - 1;
i__7 = *ldab - 1;
zrot_(&i__3, &ab[*ku + ml - 2 + (i__ + 1) *
ab_dim1], &i__6, &ab[*ku + ml - 1 + (i__
+ 1) * ab_dim1], &i__7, &rwork[i__ + ml -
1], &work[i__ + ml - 1]);
}
}
++nr;
j1 -= kb1;
}
if (wantq) {
/* accumulate product of plane rotations in Q */
i__3 = j2;
i__4 = kb1;
for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4)
{
d_cnjg(&z__1, &work[j]);
zrot_(m, &q[(j - 1) * q_dim1 + 1], &c__1, &q[j *
q_dim1 + 1], &c__1, &rwork[j], &z__1);
}
}
if (wantc) {
/* apply plane rotations to C */
i__4 = j2;
i__3 = kb1;
for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3)
{
zrot_(ncc, &c__[j - 1 + c_dim1], ldc, &c__[j + c_dim1]
, ldc, &rwork[j], &work[j]);
}
}
if (j2 + kun > *n) {
/* adjust J2 to keep within the bounds of the matrix */
--nr;
j2 -= kb1;
}
i__3 = j2;
i__4 = kb1;
for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
/* create nonzero element a(j-1,j+ku) above the band */
/* and store it in WORK(n+1:2*n) */
i__5 = j + kun;
i__6 = j;
i__7 = (j + kun) * ab_dim1 + 1;
z__1.r = work[i__6].r * ab[i__7].r - work[i__6].i * ab[
i__7].i, z__1.i = work[i__6].r * ab[i__7].i +
work[i__6].i * ab[i__7].r;
work[i__5].r = z__1.r, work[i__5].i = z__1.i;
i__5 = (j + kun) * ab_dim1 + 1;
i__6 = j;
i__7 = (j + kun) * ab_dim1 + 1;
z__1.r = rwork[i__6] * ab[i__7].r, z__1.i = rwork[i__6] *
ab[i__7].i;
ab[i__5].r = z__1.r, ab[i__5].i = z__1.i;
}
/* generate plane rotations to annihilate nonzero elements */
/* which have been generated above the band */
if (nr > 0) {
zlargv_(&nr, &ab[(j1 + kun - 1) * ab_dim1 + 1], &inca, &
work[j1 + kun], &kb1, &rwork[j1 + kun], &kb1);
}
/* apply plane rotations from the right */
i__4 = kb;
for (l = 1; l <= i__4; ++l) {
if (j2 + l - 1 > *m) {
nrt = nr - 1;
} else {
nrt = nr;
}
if (nrt > 0) {
zlartv_(&nrt, &ab[l + 1 + (j1 + kun - 1) * ab_dim1], &
inca, &ab[l + (j1 + kun) * ab_dim1], &inca, &
rwork[j1 + kun], &work[j1 + kun], &kb1);
}
}
if (ml == ml0 && mu > mu0) {
if (mu <= *n - i__ + 1) {
/* generate plane rotation to annihilate a(i,i+mu-1) */
/* within the band, and apply rotation from the right */
zlartg_(&ab[*ku - mu + 3 + (i__ + mu - 2) * ab_dim1],
&ab[*ku - mu + 2 + (i__ + mu - 1) * ab_dim1],
&rwork[i__ + mu - 1], &work[i__ + mu - 1], &
ra);
i__4 = *ku - mu + 3 + (i__ + mu - 2) * ab_dim1;
ab[i__4].r = ra.r, ab[i__4].i = ra.i;
/* Computing MIN */
i__3 = *kl + mu - 2, i__5 = *m - i__;
i__4 = min(i__3,i__5);
zrot_(&i__4, &ab[*ku - mu + 4 + (i__ + mu - 2) *
ab_dim1], &c__1, &ab[*ku - mu + 3 + (i__ + mu
- 1) * ab_dim1], &c__1, &rwork[i__ + mu - 1],
&work[i__ + mu - 1]);
}
++nr;
j1 -= kb1;
}
if (wantpt) {
/* accumulate product of plane rotations in P' */
i__4 = j2;
i__3 = kb1;
for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3)
{
d_cnjg(&z__1, &work[j + kun]);
zrot_(n, &pt[j + kun - 1 + pt_dim1], ldpt, &pt[j +
kun + pt_dim1], ldpt, &rwork[j + kun], &z__1);
}
}
if (j2 + kb > *m) {
/* adjust J2 to keep within the bounds of the matrix */
--nr;
j2 -= kb1;
}
i__3 = j2;
i__4 = kb1;
for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
/* create nonzero element a(j+kl+ku,j+ku-1) below the */
/* band and store it in WORK(1:n) */
i__5 = j + kb;
i__6 = j + kun;
i__7 = klu1 + (j + kun) * ab_dim1;
z__1.r = work[i__6].r * ab[i__7].r - work[i__6].i * ab[
i__7].i, z__1.i = work[i__6].r * ab[i__7].i +
work[i__6].i * ab[i__7].r;
work[i__5].r = z__1.r, work[i__5].i = z__1.i;
i__5 = klu1 + (j + kun) * ab_dim1;
i__6 = j + kun;
i__7 = klu1 + (j + kun) * ab_dim1;
z__1.r = rwork[i__6] * ab[i__7].r, z__1.i = rwork[i__6] *
ab[i__7].i;
ab[i__5].r = z__1.r, ab[i__5].i = z__1.i;
}
if (ml > ml0) {
--ml;
} else {
--mu;
}
}
}
}
if (*ku == 0 && *kl > 0) {
/* A has been reduced to complex lower bidiagonal form */
/* Transform lower bidiagonal form to upper bidiagonal by applying */
/* plane rotations from the left, overwriting superdiagonal */
/* elements on subdiagonal elements */
/* Computing MIN */
i__2 = *m - 1;
i__1 = min(i__2,*n);
for (i__ = 1; i__ <= i__1; ++i__) {
zlartg_(&ab[i__ * ab_dim1 + 1], &ab[i__ * ab_dim1 + 2], &rc, &rs,
&ra);
i__2 = i__ * ab_dim1 + 1;
ab[i__2].r = ra.r, ab[i__2].i = ra.i;
if (i__ < *n) {
i__2 = i__ * ab_dim1 + 2;
i__4 = (i__ + 1) * ab_dim1 + 1;
z__1.r = rs.r * ab[i__4].r - rs.i * ab[i__4].i, z__1.i = rs.r
* ab[i__4].i + rs.i * ab[i__4].r;
ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
i__2 = (i__ + 1) * ab_dim1 + 1;
i__4 = (i__ + 1) * ab_dim1 + 1;
z__1.r = rc * ab[i__4].r, z__1.i = rc * ab[i__4].i;
ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
}
if (wantq) {
d_cnjg(&z__1, &rs);
zrot_(m, &q[i__ * q_dim1 + 1], &c__1, &q[(i__ + 1) * q_dim1 +
1], &c__1, &rc, &z__1);
}
if (wantc) {
zrot_(ncc, &c__[i__ + c_dim1], ldc, &c__[i__ + 1 + c_dim1],
ldc, &rc, &rs);
}
}
} else {
/* A has been reduced to complex upper bidiagonal form or is */
/* diagonal */
if (*ku > 0 && *m < *n) {
/* Annihilate a(m,m+1) by applying plane rotations from the */
/* right */
i__1 = *ku + (*m + 1) * ab_dim1;
rb.r = ab[i__1].r, rb.i = ab[i__1].i;
for (i__ = *m; i__ >= 1; --i__) {
zlartg_(&ab[*ku + 1 + i__ * ab_dim1], &rb, &rc, &rs, &ra);
i__1 = *ku + 1 + i__ * ab_dim1;
ab[i__1].r = ra.r, ab[i__1].i = ra.i;
if (i__ > 1) {
d_cnjg(&z__3, &rs);
z__2.r = -z__3.r, z__2.i = -z__3.i;
i__1 = *ku + i__ * ab_dim1;
z__1.r = z__2.r * ab[i__1].r - z__2.i * ab[i__1].i,
z__1.i = z__2.r * ab[i__1].i + z__2.i * ab[i__1]
.r;
rb.r = z__1.r, rb.i = z__1.i;
i__1 = *ku + i__ * ab_dim1;
i__2 = *ku + i__ * ab_dim1;
z__1.r = rc * ab[i__2].r, z__1.i = rc * ab[i__2].i;
ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
}
if (wantpt) {
d_cnjg(&z__1, &rs);
zrot_(n, &pt[i__ + pt_dim1], ldpt, &pt[*m + 1 + pt_dim1],
ldpt, &rc, &z__1);
}
}
}
}
/* Make diagonal and superdiagonal elements real, storing them in D */
/* and E */
i__1 = *ku + 1 + ab_dim1;
t.r = ab[i__1].r, t.i = ab[i__1].i;
i__1 = minmn;
for (i__ = 1; i__ <= i__1; ++i__) {
abst = z_abs(&t);
d__[i__] = abst;
if (abst != 0.) {
z__1.r = t.r / abst, z__1.i = t.i / abst;
t.r = z__1.r, t.i = z__1.i;
} else {
t.r = 1., t.i = 0.;
}
if (wantq) {
zscal_(m, &t, &q[i__ * q_dim1 + 1], &c__1);
}
if (wantc) {
d_cnjg(&z__1, &t);
zscal_(ncc, &z__1, &c__[i__ + c_dim1], ldc);
}
if (i__ < minmn) {
if (*ku == 0 && *kl == 0) {
e[i__] = 0.;
i__2 = (i__ + 1) * ab_dim1 + 1;
t.r = ab[i__2].r, t.i = ab[i__2].i;
} else {
if (*ku == 0) {
i__2 = i__ * ab_dim1 + 2;
d_cnjg(&z__2, &t);
z__1.r = ab[i__2].r * z__2.r - ab[i__2].i * z__2.i,
z__1.i = ab[i__2].r * z__2.i + ab[i__2].i *
z__2.r;
t.r = z__1.r, t.i = z__1.i;
} else {
i__2 = *ku + (i__ + 1) * ab_dim1;
d_cnjg(&z__2, &t);
z__1.r = ab[i__2].r * z__2.r - ab[i__2].i * z__2.i,
z__1.i = ab[i__2].r * z__2.i + ab[i__2].i *
z__2.r;
t.r = z__1.r, t.i = z__1.i;
}
abst = z_abs(&t);
e[i__] = abst;
if (abst != 0.) {
z__1.r = t.r / abst, z__1.i = t.i / abst;
t.r = z__1.r, t.i = z__1.i;
} else {
t.r = 1., t.i = 0.;
}
if (wantpt) {
zscal_(n, &t, &pt[i__ + 1 + pt_dim1], ldpt);
}
i__2 = *ku + 1 + (i__ + 1) * ab_dim1;
d_cnjg(&z__2, &t);
z__1.r = ab[i__2].r * z__2.r - ab[i__2].i * z__2.i, z__1.i =
ab[i__2].r * z__2.i + ab[i__2].i * z__2.r;
t.r = z__1.r, t.i = z__1.i;
}
}
}
return 0;
/* End of ZGBBRD */
} /* zgbbrd_ */
/* Subroutine */ int ztrsv_(char *uplo, char *trans, char *diag, integer *n,
doublecomplex *a, integer *lda, doublecomplex *x, integer *incx)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg(
doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j, ix, jx, kx, info;
doublecomplex temp;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
logical noconj, nounit;
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZTRSV solves one of the systems of equations */
/* A*x = b, or A'*x = b, or conjg( A' )*x = b, */
/* where b and x are n element vectors and A is an n by n unit, or */
/* non-unit, upper or lower triangular matrix. */
/* No test for singularity or near-singularity is included in this */
/* routine. Such tests must be performed before calling this routine. */
/* Arguments */
/* ========== */
/* UPLO - CHARACTER*1. */
/* On entry, UPLO specifies whether the matrix is an upper or */
/* lower triangular matrix as follows: */
/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
/* Unchanged on exit. */
/* TRANS - CHARACTER*1. */
/* On entry, TRANS specifies the equations to be solved as */
/* follows: */
/* TRANS = 'N' or 'n' A*x = b. */
/* TRANS = 'T' or 't' A'*x = b. */
/* TRANS = 'C' or 'c' conjg( A' )*x = b. */
/* Unchanged on exit. */
/* DIAG - CHARACTER*1. */
/* On entry, DIAG specifies whether or not A is unit */
/* triangular as follows: */
/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
/* DIAG = 'N' or 'n' A is not assumed to be unit */
/* triangular. */
/* Unchanged on exit. */
/* N - INTEGER. */
/* On entry, N specifies the order of the matrix A. */
/* N must be at least zero. */
/* Unchanged on exit. */
/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */
/* Before entry with UPLO = 'U' or 'u', the leading n by n */
/* upper triangular part of the array A must contain the upper */
/* triangular matrix and the strictly lower triangular part of */
/* A is not referenced. */
/* Before entry with UPLO = 'L' or 'l', the leading n by n */
/* lower triangular part of the array A must contain the lower */
/* triangular matrix and the strictly upper triangular part of */
/* A is not referenced. */
/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
/* A are not referenced either, but are assumed to be unity. */
/* Unchanged on exit. */
/* LDA - INTEGER. */
/* On entry, LDA specifies the first dimension of A as declared */
/* in the calling (sub) program. LDA must be at least */
/* max( 1, n ). */
/* Unchanged on exit. */
/* X - COMPLEX*16 array of dimension at least */
/* ( 1 + ( n - 1 )*abs( INCX ) ). */
/* Before entry, the incremented array X must contain the n */
/* element right-hand side vector b. On exit, X is overwritten */
/* with the solution vector x. */
/* INCX - INTEGER. */
/* On entry, INCX specifies the increment for the elements of */
/* X. INCX must not be zero. */
/* Unchanged on exit. */
/* Level 2 Blas routine. */
/* -- Written on 22-October-1986. */
/* Jack Dongarra, Argonne National Lab. */
/* Jeremy Du Croz, Nag Central Office. */
/* Sven Hammarling, Nag Central Office. */
/* Richard Hanson, Sandia National Labs. */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--x;
/* Function Body */
info = 0;
if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
info = 1;
} else if (! lsame_(trans, "N") && ! lsame_(trans,
"T") && ! lsame_(trans, "C")) {
info = 2;
} else if (! lsame_(diag, "U") && ! lsame_(diag,
"N")) {
info = 3;
} else if (*n < 0) {
info = 4;
} else if (*lda < max(1,*n)) {
info = 6;
} else if (*incx == 0) {
info = 8;
}
if (info != 0) {
xerbla_("ZTRSV ", &info);
return 0;
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
noconj = lsame_(trans, "T");
nounit = lsame_(diag, "N");
/* Set up the start point in X if the increment is not unity. This */
/* will be ( N - 1 )*INCX too small for descending loops. */
if (*incx <= 0) {
kx = 1 - (*n - 1) * *incx;
} else if (*incx != 1) {
kx = 1;
}
/* Start the operations. In this version the elements of A are */
/* accessed sequentially with one pass through A. */
if (lsame_(trans, "N")) {
/* Form x := inv( A )*x. */
if (lsame_(uplo, "U")) {
if (*incx == 1) {
for (j = *n; j >= 1; --j) {
i__1 = j;
if (x[i__1].r != 0. || x[i__1].i != 0.) {
if (nounit) {
i__1 = j;
z_div(&z__1, &x[j], &a[j + j * a_dim1]);
x[i__1].r = z__1.r, x[i__1].i = z__1.i;
}
i__1 = j;
temp.r = x[i__1].r, temp.i = x[i__1].i;
for (i__ = j - 1; i__ >= 1; --i__) {
i__1 = i__;
i__2 = i__;
i__3 = i__ + j * a_dim1;
z__2.r = temp.r * a[i__3].r - temp.i * a[i__3].i,
z__2.i = temp.r * a[i__3].i + temp.i * a[
i__3].r;
z__1.r = x[i__2].r - z__2.r, z__1.i = x[i__2].i -
z__2.i;
x[i__1].r = z__1.r, x[i__1].i = z__1.i;
/* L10: */
}
}
/* L20: */
}
} else {
jx = kx + (*n - 1) * *incx;
for (j = *n; j >= 1; --j) {
i__1 = jx;
if (x[i__1].r != 0. || x[i__1].i != 0.) {
if (nounit) {
i__1 = jx;
z_div(&z__1, &x[jx], &a[j + j * a_dim1]);
x[i__1].r = z__1.r, x[i__1].i = z__1.i;
}
i__1 = jx;
temp.r = x[i__1].r, temp.i = x[i__1].i;
ix = jx;
for (i__ = j - 1; i__ >= 1; --i__) {
ix -= *incx;
i__1 = ix;
i__2 = ix;
i__3 = i__ + j * a_dim1;
z__2.r = temp.r * a[i__3].r - temp.i * a[i__3].i,
z__2.i = temp.r * a[i__3].i + temp.i * a[
i__3].r;
z__1.r = x[i__2].r - z__2.r, z__1.i = x[i__2].i -
z__2.i;
x[i__1].r = z__1.r, x[i__1].i = z__1.i;
/* L30: */
}
}
jx -= *incx;
/* L40: */
}
}
} else {
if (*incx == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
if (x[i__2].r != 0. || x[i__2].i != 0.) {
if (nounit) {
i__2 = j;
z_div(&z__1, &x[j], &a[j + j * a_dim1]);
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
}
i__2 = j;
temp.r = x[i__2].r, temp.i = x[i__2].i;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__ + j * a_dim1;
z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
z__2.i = temp.r * a[i__5].i + temp.i * a[
i__5].r;
z__1.r = x[i__4].r - z__2.r, z__1.i = x[i__4].i -
z__2.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
/* L50: */
}
}
/* L60: */
}
} else {
jx = kx;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = jx;
if (x[i__2].r != 0. || x[i__2].i != 0.) {
if (nounit) {
i__2 = jx;
z_div(&z__1, &x[jx], &a[j + j * a_dim1]);
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
}
i__2 = jx;
temp.r = x[i__2].r, temp.i = x[i__2].i;
ix = jx;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
ix += *incx;
i__3 = ix;
i__4 = ix;
i__5 = i__ + j * a_dim1;
z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
z__2.i = temp.r * a[i__5].i + temp.i * a[
i__5].r;
z__1.r = x[i__4].r - z__2.r, z__1.i = x[i__4].i -
z__2.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
/* L70: */
}
}
jx += *incx;
/* L80: */
}
}
}
} else {
/* Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. */
if (lsame_(uplo, "U")) {
if (*incx == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
temp.r = x[i__2].r, temp.i = x[i__2].i;
if (noconj) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__;
z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[
i__4].i, z__2.i = a[i__3].r * x[i__4].i +
a[i__3].i * x[i__4].r;
z__1.r = temp.r - z__2.r, z__1.i = temp.i -
z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
/* L90: */
}
if (nounit) {
z_div(&z__1, &temp, &a[j + j * a_dim1]);
temp.r = z__1.r, temp.i = z__1.i;
}
} else {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
d_cnjg(&z__3, &a[i__ + j * a_dim1]);
i__3 = i__;
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i,
z__2.i = z__3.r * x[i__3].i + z__3.i * x[
i__3].r;
z__1.r = temp.r - z__2.r, z__1.i = temp.i -
z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
/* L100: */
}
if (nounit) {
d_cnjg(&z__2, &a[j + j * a_dim1]);
z_div(&z__1, &temp, &z__2);
temp.r = z__1.r, temp.i = z__1.i;
}
}
i__2 = j;
x[i__2].r = temp.r, x[i__2].i = temp.i;
/* L110: */
}
} else {
jx = kx;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
ix = kx;
i__2 = jx;
temp.r = x[i__2].r, temp.i = x[i__2].i;
if (noconj) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = ix;
z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[
i__4].i, z__2.i = a[i__3].r * x[i__4].i +
a[i__3].i * x[i__4].r;
z__1.r = temp.r - z__2.r, z__1.i = temp.i -
z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
ix += *incx;
/* L120: */
}
if (nounit) {
z_div(&z__1, &temp, &a[j + j * a_dim1]);
temp.r = z__1.r, temp.i = z__1.i;
}
} else {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
d_cnjg(&z__3, &a[i__ + j * a_dim1]);
i__3 = ix;
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i,
z__2.i = z__3.r * x[i__3].i + z__3.i * x[
i__3].r;
z__1.r = temp.r - z__2.r, z__1.i = temp.i -
z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
ix += *incx;
/* L130: */
}
if (nounit) {
d_cnjg(&z__2, &a[j + j * a_dim1]);
z_div(&z__1, &temp, &z__2);
temp.r = z__1.r, temp.i = z__1.i;
}
}
i__2 = jx;
x[i__2].r = temp.r, x[i__2].i = temp.i;
jx += *incx;
/* L140: */
}
}
} else {
if (*incx == 1) {
for (j = *n; j >= 1; --j) {
i__1 = j;
temp.r = x[i__1].r, temp.i = x[i__1].i;
if (noconj) {
i__1 = j + 1;
for (i__ = *n; i__ >= i__1; --i__) {
i__2 = i__ + j * a_dim1;
i__3 = i__;
z__2.r = a[i__2].r * x[i__3].r - a[i__2].i * x[
i__3].i, z__2.i = a[i__2].r * x[i__3].i +
a[i__2].i * x[i__3].r;
z__1.r = temp.r - z__2.r, z__1.i = temp.i -
z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
/* L150: */
}
if (nounit) {
z_div(&z__1, &temp, &a[j + j * a_dim1]);
temp.r = z__1.r, temp.i = z__1.i;
}
} else {
i__1 = j + 1;
for (i__ = *n; i__ >= i__1; --i__) {
d_cnjg(&z__3, &a[i__ + j * a_dim1]);
i__2 = i__;
z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i,
z__2.i = z__3.r * x[i__2].i + z__3.i * x[
i__2].r;
z__1.r = temp.r - z__2.r, z__1.i = temp.i -
z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
/* L160: */
}
if (nounit) {
d_cnjg(&z__2, &a[j + j * a_dim1]);
z_div(&z__1, &temp, &z__2);
temp.r = z__1.r, temp.i = z__1.i;
}
}
i__1 = j;
x[i__1].r = temp.r, x[i__1].i = temp.i;
/* L170: */
}
} else {
kx += (*n - 1) * *incx;
jx = kx;
for (j = *n; j >= 1; --j) {
ix = kx;
i__1 = jx;
temp.r = x[i__1].r, temp.i = x[i__1].i;
if (noconj) {
i__1 = j + 1;
for (i__ = *n; i__ >= i__1; --i__) {
i__2 = i__ + j * a_dim1;
i__3 = ix;
z__2.r = a[i__2].r * x[i__3].r - a[i__2].i * x[
i__3].i, z__2.i = a[i__2].r * x[i__3].i +
a[i__2].i * x[i__3].r;
z__1.r = temp.r - z__2.r, z__1.i = temp.i -
z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
ix -= *incx;
/* L180: */
}
if (nounit) {
z_div(&z__1, &temp, &a[j + j * a_dim1]);
temp.r = z__1.r, temp.i = z__1.i;
}
} else {
i__1 = j + 1;
for (i__ = *n; i__ >= i__1; --i__) {
d_cnjg(&z__3, &a[i__ + j * a_dim1]);
i__2 = ix;
z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i,
z__2.i = z__3.r * x[i__2].i + z__3.i * x[
i__2].r;
z__1.r = temp.r - z__2.r, z__1.i = temp.i -
z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
ix -= *incx;
/* L190: */
}
if (nounit) {
d_cnjg(&z__2, &a[j + j * a_dim1]);
z_div(&z__1, &temp, &z__2);
temp.r = z__1.r, temp.i = z__1.i;
}
}
i__1 = jx;
x[i__1].r = temp.r, x[i__1].i = temp.i;
jx -= *incx;
/* L200: */
}
}
}
}
return 0;
/* End of ZTRSV . */
} /* ztrsv_ */
/* Subroutine */ int zptrfs_(char *uplo, integer *n, integer *nrhs,
doublereal *d__, doublecomplex *e, doublereal *df, doublecomplex *ef,
doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *
rwork, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5,
i__6;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10,
d__11, d__12;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
double d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
double z_abs(doublecomplex *);
/* Local variables */
integer i__, j;
doublereal s;
doublecomplex bi, cx, dx, ex;
integer ix, nz;
doublereal eps, safe1, safe2;
extern logical lsame_(char *, char *);
integer count;
logical upper;
extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dlamch_(char *);
extern integer idamax_(integer *, doublereal *, integer *);
doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal lstres;
extern /* Subroutine */ int zpttrs_(char *, integer *, integer *,
doublereal *, doublecomplex *, doublecomplex *, integer *,
integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZPTRFS improves the computed solution to a system of linear */
/* equations when the coefficient matrix is Hermitian positive definite */
/* and tridiagonal, and provides error bounds and backward error */
/* estimates for the solution. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the superdiagonal or the subdiagonal of the */
/* tridiagonal matrix A is stored and the form of the */
/* factorization: */
/* = 'U': E is the superdiagonal of A, and A = U**H*D*U; */
/* = 'L': E is the subdiagonal of A, and A = L*D*L**H. */
/* (The two forms are equivalent if A is real.) */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrix B. NRHS >= 0. */
/* D (input) DOUBLE PRECISION array, dimension (N) */
/* The n real diagonal elements of the tridiagonal matrix A. */
/* E (input) COMPLEX*16 array, dimension (N-1) */
/* The (n-1) off-diagonal elements of the tridiagonal matrix A */
/* (see UPLO). */
/* DF (input) DOUBLE PRECISION array, dimension (N) */
/* The n diagonal elements of the diagonal matrix D from */
/* the factorization computed by ZPTTRF. */
/* EF (input) COMPLEX*16 array, dimension (N-1) */
/* The (n-1) off-diagonal elements of the unit bidiagonal */
/* factor U or L from the factorization computed by ZPTTRF */
/* (see UPLO). */
/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
/* The right hand side matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS) */
/* On entry, the solution matrix X, as computed by ZPTTRS. */
/* On exit, the improved solution matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
/* The forward error bound for each solution vector */
/* X(j) (the j-th column of the solution matrix X). */
/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
/* is an estimated upper bound for the magnitude of the largest */
/* element in (X(j) - XTRUE) divided by the magnitude of the */
/* largest element in X(j). */
/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector X(j) (i.e., the smallest relative change in */
/* any element of A or B that makes X(j) an exact solution). */
/* WORK (workspace) COMPLEX*16 array, dimension (N) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Internal Parameters */
/* =================== */
/* ITMAX is the maximum number of steps of iterative refinement. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
--df;
--ef;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--rwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldx < max(1,*n)) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPTRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] = 0.;
berr[j] = 0.;
/* L10: */
}
return 0;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = 4;
eps = dlamch_("Epsilon");
safmin = dlamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
count = 1;
lstres = 3.;
L20:
/* Loop until stopping criterion is satisfied. */
/* Compute residual R = B - A * X. Also compute */
/* abs(A)*abs(x) + abs(b) for use in the backward error bound. */
if (upper) {
if (*n == 1) {
i__2 = j * b_dim1 + 1;
bi.r = b[i__2].r, bi.i = b[i__2].i;
i__2 = j * x_dim1 + 1;
z__1.r = d__[1] * x[i__2].r, z__1.i = d__[1] * x[i__2].i;
dx.r = z__1.r, dx.i = z__1.i;
z__1.r = bi.r - dx.r, z__1.i = bi.i - dx.i;
work[1].r = z__1.r, work[1].i = z__1.i;
rwork[1] = (d__1 = bi.r, abs(d__1)) + (d__2 = d_imag(&bi),
abs(d__2)) + ((d__3 = dx.r, abs(d__3)) + (d__4 =
d_imag(&dx), abs(d__4)));
} else {
i__2 = j * b_dim1 + 1;
bi.r = b[i__2].r, bi.i = b[i__2].i;
i__2 = j * x_dim1 + 1;
z__1.r = d__[1] * x[i__2].r, z__1.i = d__[1] * x[i__2].i;
dx.r = z__1.r, dx.i = z__1.i;
i__2 = j * x_dim1 + 2;
z__1.r = e[1].r * x[i__2].r - e[1].i * x[i__2].i, z__1.i = e[
1].r * x[i__2].i + e[1].i * x[i__2].r;
ex.r = z__1.r, ex.i = z__1.i;
z__2.r = bi.r - dx.r, z__2.i = bi.i - dx.i;
z__1.r = z__2.r - ex.r, z__1.i = z__2.i - ex.i;
work[1].r = z__1.r, work[1].i = z__1.i;
i__2 = j * x_dim1 + 2;
rwork[1] = (d__1 = bi.r, abs(d__1)) + (d__2 = d_imag(&bi),
abs(d__2)) + ((d__3 = dx.r, abs(d__3)) + (d__4 =
d_imag(&dx), abs(d__4))) + ((d__5 = e[1].r, abs(d__5))
+ (d__6 = d_imag(&e[1]), abs(d__6))) * ((d__7 = x[
i__2].r, abs(d__7)) + (d__8 = d_imag(&x[j * x_dim1 +
2]), abs(d__8)));
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
bi.r = b[i__3].r, bi.i = b[i__3].i;
d_cnjg(&z__2, &e[i__ - 1]);
i__3 = i__ - 1 + j * x_dim1;
z__1.r = z__2.r * x[i__3].r - z__2.i * x[i__3].i, z__1.i =
z__2.r * x[i__3].i + z__2.i * x[i__3].r;
cx.r = z__1.r, cx.i = z__1.i;
i__3 = i__;
i__4 = i__ + j * x_dim1;
z__1.r = d__[i__3] * x[i__4].r, z__1.i = d__[i__3] * x[
i__4].i;
dx.r = z__1.r, dx.i = z__1.i;
i__3 = i__;
i__4 = i__ + 1 + j * x_dim1;
z__1.r = e[i__3].r * x[i__4].r - e[i__3].i * x[i__4].i,
z__1.i = e[i__3].r * x[i__4].i + e[i__3].i * x[
i__4].r;
ex.r = z__1.r, ex.i = z__1.i;
i__3 = i__;
z__3.r = bi.r - cx.r, z__3.i = bi.i - cx.i;
z__2.r = z__3.r - dx.r, z__2.i = z__3.i - dx.i;
z__1.r = z__2.r - ex.r, z__1.i = z__2.i - ex.i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
i__3 = i__ - 1;
i__4 = i__ - 1 + j * x_dim1;
i__5 = i__;
i__6 = i__ + 1 + j * x_dim1;
rwork[i__] = (d__1 = bi.r, abs(d__1)) + (d__2 = d_imag(&
bi), abs(d__2)) + ((d__3 = e[i__3].r, abs(d__3))
+ (d__4 = d_imag(&e[i__ - 1]), abs(d__4))) * ((
d__5 = x[i__4].r, abs(d__5)) + (d__6 = d_imag(&x[
i__ - 1 + j * x_dim1]), abs(d__6))) + ((d__7 =
dx.r, abs(d__7)) + (d__8 = d_imag(&dx), abs(d__8))
) + ((d__9 = e[i__5].r, abs(d__9)) + (d__10 =
d_imag(&e[i__]), abs(d__10))) * ((d__11 = x[i__6]
.r, abs(d__11)) + (d__12 = d_imag(&x[i__ + 1 + j *
x_dim1]), abs(d__12)));
/* L30: */
}
i__2 = *n + j * b_dim1;
bi.r = b[i__2].r, bi.i = b[i__2].i;
d_cnjg(&z__2, &e[*n - 1]);
i__2 = *n - 1 + j * x_dim1;
z__1.r = z__2.r * x[i__2].r - z__2.i * x[i__2].i, z__1.i =
z__2.r * x[i__2].i + z__2.i * x[i__2].r;
cx.r = z__1.r, cx.i = z__1.i;
i__2 = *n;
i__3 = *n + j * x_dim1;
z__1.r = d__[i__2] * x[i__3].r, z__1.i = d__[i__2] * x[i__3]
.i;
dx.r = z__1.r, dx.i = z__1.i;
i__2 = *n;
z__2.r = bi.r - cx.r, z__2.i = bi.i - cx.i;
z__1.r = z__2.r - dx.r, z__1.i = z__2.i - dx.i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
i__2 = *n - 1;
i__3 = *n - 1 + j * x_dim1;
rwork[*n] = (d__1 = bi.r, abs(d__1)) + (d__2 = d_imag(&bi),
abs(d__2)) + ((d__3 = e[i__2].r, abs(d__3)) + (d__4 =
d_imag(&e[*n - 1]), abs(d__4))) * ((d__5 = x[i__3].r,
abs(d__5)) + (d__6 = d_imag(&x[*n - 1 + j * x_dim1]),
abs(d__6))) + ((d__7 = dx.r, abs(d__7)) + (d__8 =
d_imag(&dx), abs(d__8)));
}
} else {
if (*n == 1) {
i__2 = j * b_dim1 + 1;
bi.r = b[i__2].r, bi.i = b[i__2].i;
i__2 = j * x_dim1 + 1;
z__1.r = d__[1] * x[i__2].r, z__1.i = d__[1] * x[i__2].i;
dx.r = z__1.r, dx.i = z__1.i;
z__1.r = bi.r - dx.r, z__1.i = bi.i - dx.i;
work[1].r = z__1.r, work[1].i = z__1.i;
rwork[1] = (d__1 = bi.r, abs(d__1)) + (d__2 = d_imag(&bi),
abs(d__2)) + ((d__3 = dx.r, abs(d__3)) + (d__4 =
d_imag(&dx), abs(d__4)));
} else {
i__2 = j * b_dim1 + 1;
bi.r = b[i__2].r, bi.i = b[i__2].i;
i__2 = j * x_dim1 + 1;
z__1.r = d__[1] * x[i__2].r, z__1.i = d__[1] * x[i__2].i;
dx.r = z__1.r, dx.i = z__1.i;
d_cnjg(&z__2, &e[1]);
i__2 = j * x_dim1 + 2;
z__1.r = z__2.r * x[i__2].r - z__2.i * x[i__2].i, z__1.i =
z__2.r * x[i__2].i + z__2.i * x[i__2].r;
ex.r = z__1.r, ex.i = z__1.i;
z__2.r = bi.r - dx.r, z__2.i = bi.i - dx.i;
z__1.r = z__2.r - ex.r, z__1.i = z__2.i - ex.i;
work[1].r = z__1.r, work[1].i = z__1.i;
i__2 = j * x_dim1 + 2;
rwork[1] = (d__1 = bi.r, abs(d__1)) + (d__2 = d_imag(&bi),
abs(d__2)) + ((d__3 = dx.r, abs(d__3)) + (d__4 =
d_imag(&dx), abs(d__4))) + ((d__5 = e[1].r, abs(d__5))
+ (d__6 = d_imag(&e[1]), abs(d__6))) * ((d__7 = x[
i__2].r, abs(d__7)) + (d__8 = d_imag(&x[j * x_dim1 +
2]), abs(d__8)));
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
bi.r = b[i__3].r, bi.i = b[i__3].i;
i__3 = i__ - 1;
i__4 = i__ - 1 + j * x_dim1;
z__1.r = e[i__3].r * x[i__4].r - e[i__3].i * x[i__4].i,
z__1.i = e[i__3].r * x[i__4].i + e[i__3].i * x[
i__4].r;
cx.r = z__1.r, cx.i = z__1.i;
i__3 = i__;
i__4 = i__ + j * x_dim1;
z__1.r = d__[i__3] * x[i__4].r, z__1.i = d__[i__3] * x[
i__4].i;
dx.r = z__1.r, dx.i = z__1.i;
d_cnjg(&z__2, &e[i__]);
i__3 = i__ + 1 + j * x_dim1;
z__1.r = z__2.r * x[i__3].r - z__2.i * x[i__3].i, z__1.i =
z__2.r * x[i__3].i + z__2.i * x[i__3].r;
ex.r = z__1.r, ex.i = z__1.i;
i__3 = i__;
z__3.r = bi.r - cx.r, z__3.i = bi.i - cx.i;
z__2.r = z__3.r - dx.r, z__2.i = z__3.i - dx.i;
z__1.r = z__2.r - ex.r, z__1.i = z__2.i - ex.i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
i__3 = i__ - 1;
i__4 = i__ - 1 + j * x_dim1;
i__5 = i__;
i__6 = i__ + 1 + j * x_dim1;
rwork[i__] = (d__1 = bi.r, abs(d__1)) + (d__2 = d_imag(&
bi), abs(d__2)) + ((d__3 = e[i__3].r, abs(d__3))
+ (d__4 = d_imag(&e[i__ - 1]), abs(d__4))) * ((
d__5 = x[i__4].r, abs(d__5)) + (d__6 = d_imag(&x[
i__ - 1 + j * x_dim1]), abs(d__6))) + ((d__7 =
dx.r, abs(d__7)) + (d__8 = d_imag(&dx), abs(d__8))
) + ((d__9 = e[i__5].r, abs(d__9)) + (d__10 =
d_imag(&e[i__]), abs(d__10))) * ((d__11 = x[i__6]
.r, abs(d__11)) + (d__12 = d_imag(&x[i__ + 1 + j *
x_dim1]), abs(d__12)));
/* L40: */
}
i__2 = *n + j * b_dim1;
bi.r = b[i__2].r, bi.i = b[i__2].i;
i__2 = *n - 1;
i__3 = *n - 1 + j * x_dim1;
z__1.r = e[i__2].r * x[i__3].r - e[i__2].i * x[i__3].i,
z__1.i = e[i__2].r * x[i__3].i + e[i__2].i * x[i__3]
.r;
cx.r = z__1.r, cx.i = z__1.i;
i__2 = *n;
i__3 = *n + j * x_dim1;
z__1.r = d__[i__2] * x[i__3].r, z__1.i = d__[i__2] * x[i__3]
.i;
dx.r = z__1.r, dx.i = z__1.i;
i__2 = *n;
z__2.r = bi.r - cx.r, z__2.i = bi.i - cx.i;
z__1.r = z__2.r - dx.r, z__1.i = z__2.i - dx.i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
i__2 = *n - 1;
i__3 = *n - 1 + j * x_dim1;
rwork[*n] = (d__1 = bi.r, abs(d__1)) + (d__2 = d_imag(&bi),
abs(d__2)) + ((d__3 = e[i__2].r, abs(d__3)) + (d__4 =
d_imag(&e[*n - 1]), abs(d__4))) * ((d__5 = x[i__3].r,
abs(d__5)) + (d__6 = d_imag(&x[*n - 1 + j * x_dim1]),
abs(d__6))) + ((d__7 = dx.r, abs(d__7)) + (d__8 =
d_imag(&dx), abs(d__8)));
}
}
/* Compute componentwise relative backward error from formula */
/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
/* where abs(Z) is the componentwise absolute value of the matrix */
/* or vector Z. If the i-th component of the denominator is less */
/* than SAFE2, then SAFE1 is added to the i-th components of the */
/* numerator and denominator before dividing. */
s = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
/* Computing MAX */
i__3 = i__;
d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2))) / rwork[i__];
s = max(d__3,d__4);
} else {
/* Computing MAX */
i__3 = i__;
d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__]
+ safe1);
s = max(d__3,d__4);
}
/* L50: */
}
berr[j] = s;
/* Test stopping criterion. Continue iterating if */
/* 1) The residual BERR(J) is larger than machine epsilon, and */
/* 2) BERR(J) decreased by at least a factor of 2 during the */
/* last iteration, and */
/* 3) At most ITMAX iterations tried. */
if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
/* Update solution and try again. */
zpttrs_(uplo, n, &c__1, &df[1], &ef[1], &work[1], n, info);
zaxpy_(n, &c_b16, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
lstres = berr[j];
++count;
goto L20;
}
/* Bound error from formula */
/* norm(X - XTRUE) / norm(X) .le. FERR = */
/* norm( abs(inv(A))* */
/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
/* where */
/* norm(Z) is the magnitude of the largest component of Z */
/* inv(A) is the inverse of A */
/* abs(Z) is the componentwise absolute value of the matrix or */
/* vector Z */
/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
/* EPS is machine epsilon */
/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
/* is incremented by SAFE1 if the i-th component of */
/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
i__3 = i__;
rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
;
} else {
i__3 = i__;
rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ safe1;
}
/* L60: */
}
ix = idamax_(n, &rwork[1], &c__1);
ferr[j] = rwork[ix];
/* Estimate the norm of inv(A). */
/* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by */
/* m(i,j) = abs(A(i,j)), i = j, */
/* m(i,j) = -abs(A(i,j)), i .ne. j, */
/* and e = [ 1, 1, ..., 1 ]'. Note M(A) = M(L)*D*M(L)'. */
/* Solve M(L) * x = e. */
rwork[1] = 1.;
i__2 = *n;
for (i__ = 2; i__ <= i__2; ++i__) {
rwork[i__] = rwork[i__ - 1] * z_abs(&ef[i__ - 1]) + 1.;
/* L70: */
}
/* Solve D * M(L)' * x = b. */
rwork[*n] /= df[*n];
for (i__ = *n - 1; i__ >= 1; --i__) {
rwork[i__] = rwork[i__] / df[i__] + rwork[i__ + 1] * z_abs(&ef[
i__]);
/* L80: */
}
/* Compute norm(inv(A)) = max(x(i)), 1<=i<=n. */
ix = idamax_(n, &rwork[1], &c__1);
ferr[j] *= (d__1 = rwork[ix], abs(d__1));
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__1 = lstres, d__2 = z_abs(&x[i__ + j * x_dim1]);
lstres = max(d__1,d__2);
/* L90: */
}
if (lstres != 0.) {
ferr[j] /= lstres;
}
/* L100: */
}
return 0;
/* End of ZPTRFS */
} /* zptrfs_ */
/* Subroutine */ int zgemv_(char *trans, integer *m, integer *n,
doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex *
x, integer *incx, doublecomplex *beta, doublecomplex *y, integer *
incy, ftnlen trans_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static integer i__, j, ix, iy, jx, jy, kx, ky, info;
static doublecomplex temp;
static integer lenx, leny;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
static logical noconj;
/* .. Scalar Arguments .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGEMV performs one of the matrix-vector operations */
/* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or */
/* y := alpha*conjg( A' )*x + beta*y, */
/* where alpha and beta are scalars, x and y are vectors and A is an */
/* m by n matrix. */
/* Parameters */
/* ========== */
/* TRANS - CHARACTER*1. */
/* On entry, TRANS specifies the operation to be performed as */
/* follows: */
/* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. */
/* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. */
/* TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y. */
/* Unchanged on exit. */
/* M - INTEGER. */
/* On entry, M specifies the number of rows of the matrix A. */
/* M must be at least zero. */
/* Unchanged on exit. */
/* N - INTEGER. */
/* On entry, N specifies the number of columns of the matrix A. */
/* N must be at least zero. */
/* Unchanged on exit. */
/* ALPHA - COMPLEX*16 . */
/* On entry, ALPHA specifies the scalar alpha. */
/* Unchanged on exit. */
/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */
/* Before entry, the leading m by n part of the array A must */
/* contain the matrix of coefficients. */
/* Unchanged on exit. */
/* LDA - INTEGER. */
/* On entry, LDA specifies the first dimension of A as declared */
/* in the calling (sub) program. LDA must be at least */
/* max( 1, m ). */
/* Unchanged on exit. */
/* X - COMPLEX*16 array of DIMENSION at least */
/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
/* and at least */
/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
/* Before entry, the incremented array X must contain the */
/* vector x. */
/* Unchanged on exit. */
/* INCX - INTEGER. */
/* On entry, INCX specifies the increment for the elements of */
/* X. INCX must not be zero. */
/* Unchanged on exit. */
/* BETA - COMPLEX*16 . */
/* On entry, BETA specifies the scalar beta. When BETA is */
/* supplied as zero then Y need not be set on input. */
/* Unchanged on exit. */
/* Y - COMPLEX*16 array of DIMENSION at least */
/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
/* and at least */
/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
/* Before entry with BETA non-zero, the incremented array Y */
/* must contain the vector y. On exit, Y is overwritten by the */
/* updated vector y. */
/* INCY - INTEGER. */
/* On entry, INCY specifies the increment for the elements of */
/* Y. INCY must not be zero. */
/* Unchanged on exit. */
/* Level 2 Blas routine. */
/* -- Written on 22-October-1986. */
/* Jack Dongarra, Argonne National Lab. */
/* Jeremy Du Croz, Nag Central Office. */
/* Sven Hammarling, Nag Central Office. */
/* Richard Hanson, Sandia National Labs. */
/* .. 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;
--x;
--y;
/* Function Body */
info = 0;
if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "T", (
ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (ftnlen)1)
) {
info = 1;
} else if (*m < 0) {
info = 2;
} else if (*n < 0) {
info = 3;
} else if (*lda < max(1,*m)) {
info = 6;
} else if (*incx == 0) {
info = 8;
} else if (*incy == 0) {
info = 11;
}
if (info != 0) {
xerbla_("ZGEMV ", &info, (ftnlen)6);
return 0;
}
/* Quick return if possible. */
if (*m == 0 || *n == 0 || alpha->r == 0. && alpha->i == 0. && (beta->r ==
1. && beta->i == 0.)) {
return 0;
}
noconj = lsame_(trans, "T", (ftnlen)1, (ftnlen)1);
/* Set LENX and LENY, the lengths of the vectors x and y, and set */
/* up the start points in X and Y. */
if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
lenx = *n;
leny = *m;
} else {
lenx = *m;
leny = *n;
}
if (*incx > 0) {
kx = 1;
} else {
kx = 1 - (lenx - 1) * *incx;
}
if (*incy > 0) {
ky = 1;
} else {
ky = 1 - (leny - 1) * *incy;
}
/* Start the operations. In this version the elements of A are */
/* accessed sequentially with one pass through A. */
/* First form y := beta*y. */
if (beta->r != 1. || beta->i != 0.) {
if (*incy == 1) {
if (beta->r == 0. && beta->i == 0.) {
i__1 = leny;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
y[i__2].r = 0., y[i__2].i = 0.;
/* L10: */
}
} else {
i__1 = leny;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__;
z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
.r;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
/* L20: */
}
}
} else {
iy = ky;
if (beta->r == 0. && beta->i == 0.) {
i__1 = leny;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iy;
y[i__2].r = 0., y[i__2].i = 0.;
iy += *incy;
/* L30: */
}
} else {
i__1 = leny;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iy;
i__3 = iy;
z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
.r;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
iy += *incy;
/* L40: */
}
}
}
}
if (alpha->r == 0. && alpha->i == 0.) {
return 0;
}
if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
/* Form y := alpha*A*x + y. */
jx = kx;
if (*incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = jx;
if (x[i__2].r != 0. || x[i__2].i != 0.) {
i__2 = jx;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
.r;
temp.r = z__1.r, temp.i = z__1.i;
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__ + j * a_dim1;
z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
z__2.i = temp.r * a[i__5].i + temp.i * a[i__5]
.r;
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i +
z__2.i;
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
/* L50: */
}
}
jx += *incx;
/* L60: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = jx;
if (x[i__2].r != 0. || x[i__2].i != 0.) {
i__2 = jx;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
.r;
temp.r = z__1.r, temp.i = z__1.i;
iy = ky;
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = iy;
i__4 = iy;
i__5 = i__ + j * a_dim1;
z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
z__2.i = temp.r * a[i__5].i + temp.i * a[i__5]
.r;
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i +
z__2.i;
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
iy += *incy;
/* L70: */
}
}
jx += *incx;
/* L80: */
}
}
} else {
/* Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. */
jy = ky;
if (*incx == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp.r = 0., temp.i = 0.;
if (noconj) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__;
z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4]
.i, z__2.i = a[i__3].r * x[i__4].i + a[i__3]
.i * x[i__4].r;
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
/* L90: */
}
} else {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
d_cnjg(&z__3, &a[i__ + j * a_dim1]);
i__3 = i__;
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i,
z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3]
.r;
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
/* L100: */
}
}
i__2 = jy;
i__3 = jy;
z__2.r = alpha->r * temp.r - alpha->i * temp.i, z__2.i =
alpha->r * temp.i + alpha->i * temp.r;
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
jy += *incy;
/* L110: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp.r = 0., temp.i = 0.;
ix = kx;
if (noconj) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = ix;
z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4]
.i, z__2.i = a[i__3].r * x[i__4].i + a[i__3]
.i * x[i__4].r;
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
ix += *incx;
/* L120: */
}
} else {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
d_cnjg(&z__3, &a[i__ + j * a_dim1]);
i__3 = ix;
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i,
z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3]
.r;
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
ix += *incx;
/* L130: */
}
}
i__2 = jy;
i__3 = jy;
z__2.r = alpha->r * temp.r - alpha->i * temp.i, z__2.i =
alpha->r * temp.i + alpha->i * temp.r;
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
jy += *incy;
/* L140: */
}
}
}
return 0;
/* End of ZGEMV . */
} /* zgemv_ */
/* Subroutine */ int zunmr3_(char *side, char *trans, integer *m, integer *n,
integer *k, integer *l, doublecomplex *a, integer *lda, doublecomplex
*tau, doublecomplex *c__, integer *ldc, doublecomplex *work, 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
=======
ZUNMR3 overwrites the general complex m by n matrix C with
Q * C if SIDE = 'L' and TRANS = 'N', or
Q'* C if SIDE = 'L' and TRANS = 'C', or
C * Q if SIDE = 'R' and TRANS = 'N', or
C * Q' if SIDE = 'R' and TRANS = 'C',
where Q is a complex unitary matrix defined as the product of k
elementary reflectors
Q = H(1) H(2) . . . H(k)
as returned by ZTZRZF. Q is of order m if SIDE = 'L' and of order n
if SIDE = 'R'.
Arguments
=========
SIDE (input) CHARACTER*1
= 'L': apply Q or Q' from the Left
= 'R': apply Q or Q' from the Right
TRANS (input) CHARACTER*1
= 'N': apply Q (No transpose)
= 'C': apply Q' (Conjugate transpose)
M (input) INTEGER
The number of rows of the matrix C. M >= 0.
N (input) INTEGER
The number of columns of the matrix C. N >= 0.
K (input) INTEGER
The number of elementary reflectors whose product defines
the matrix Q.
If SIDE = 'L', M >= K >= 0;
if SIDE = 'R', N >= K >= 0.
L (input) INTEGER
The number of columns of the matrix A containing
the meaningful part of the Householder reflectors.
If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
A (input) COMPLEX*16 array, dimension
(LDA,M) if SIDE = 'L',
(LDA,N) if SIDE = 'R'
The i-th row must contain the vector which defines the
elementary reflector H(i), for i = 1,2,...,k, as returned by
ZTZRZF in the last k rows of its array argument A.
A is modified by the routine but restored on exit.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,K).
TAU (input) COMPLEX*16 array, dimension (K)
TAU(i) must contain the scalar factor of the elementary
reflector H(i), as returned by ZTZRZF.
C (input/output) COMPLEX*16 array, dimension (LDC,N)
On entry, the m-by-n matrix C.
On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
LDC (input) INTEGER
The leading dimension of the array C. LDC >= max(1,M).
WORK (workspace) COMPLEX*16 array, dimension
(N) if SIDE = 'L',
(M) if SIDE = 'R'
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Further Details
===============
Based on contributions by
A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
=====================================================================
Test the input arguments
Parameter adjustments */
/* System generated locals */
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static logical left;
static doublecomplex taui;
static integer i__;
extern logical lsame_(char *, char *);
static integer i1, i2, i3;
extern /* Subroutine */ int zlarz_(char *, integer *, integer *, integer *
, doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *);
static integer ja, ic, jc, mi, ni, nq;
extern /* Subroutine */ int xerbla_(char *, integer *);
static logical notran;
#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 c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1
#define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--tau;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = lsame_(side, "L");
notran = lsame_(trans, "N");
/* NQ is the order of Q */
if (left) {
nq = *m;
} else {
nq = *n;
}
if (! left && ! lsame_(side, "R")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "C")) {
*info = -2;
} else if (*m < 0) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*k < 0 || *k > nq) {
*info = -5;
} else if (*l < 0 || left && *l > *m || ! left && *l > *n) {
*info = -6;
} else if (*lda < max(1,*k)) {
*info = -8;
} else if (*ldc < max(1,*m)) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZUNMR3", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0 || *k == 0) {
return 0;
}
if (left && ! notran || ! left && notran) {
i1 = 1;
i2 = *k;
i3 = 1;
} else {
i1 = *k;
i2 = 1;
i3 = -1;
}
if (left) {
ni = *n;
ja = *m - *l + 1;
jc = 1;
} else {
mi = *m;
ja = *n - *l + 1;
ic = 1;
}
i__1 = i2;
i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
if (left) {
/* H(i) or H(i)' is applied to C(i:m,1:n) */
mi = *m - i__ + 1;
ic = i__;
} else {
/* H(i) or H(i)' is applied to C(1:m,i:n) */
ni = *n - i__ + 1;
jc = i__;
}
/* Apply H(i) or H(i)' */
if (notran) {
i__3 = i__;
taui.r = tau[i__3].r, taui.i = tau[i__3].i;
} else {
d_cnjg(&z__1, &tau[i__]);
taui.r = z__1.r, taui.i = z__1.i;
}
zlarz_(side, &mi, &ni, l, &a_ref(i__, ja), lda, &taui, &c___ref(ic,
jc), ldc, &work[1]);
/* L10: */
}
return 0;
/* End of ZUNMR3 */
} /* zunmr3_ */
/* Subroutine */ int zdrges_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
doublecomplex *a, integer *lda, doublecomplex *b, doublecomplex *s,
doublecomplex *t, doublecomplex *q, integer *ldq, doublecomplex *z__,
doublecomplex *alpha, doublecomplex *beta, doublecomplex *work,
integer *lwork, doublereal *rwork, doublereal *result, logical *bwork,
integer *info)
{
/* Initialized data */
static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
2,2,2,3 };
static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
2,3,2,1 };
static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
1,1,1,1 };
static logical lasign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
TRUE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,FALSE_,
TRUE_,FALSE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,FALSE_ };
static logical lbsign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,FALSE_,
TRUE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_ };
static integer kz1[6] = { 0,1,2,1,3,3 };
static integer kz2[6] = { 0,0,1,2,1,1 };
static integer kadd[6] = { 0,0,0,0,3,2 };
static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
4,4,4,0 };
static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
8,8,8,8,8,0 };
static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
3,3,3,1 };
static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
4,4,4,1 };
static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
3,3,2,1 };
/* Format strings */
static char fmt_9999[] = "(\002 ZDRGES: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,4(i4,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 ZDRGES: S not in Schur form at eigenvalu"
"e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, "
"ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9997[] = "(/1x,a3,\002 -- Complex Generalized Schur from"
" problem \002,\002driver\002)";
static char fmt_9996[] = "(\002 Matrix types (see ZDRGES for details):"
" \002)";
static char fmt_9995[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
"osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
"onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
"I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
"arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
"(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
"=(D, reversed D)\002)";
static char fmt_9994[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
"atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
" 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
"ha&beta \002,\002 20=arithmetic alpha, beta=0,"
"1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
"=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
"/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
"l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
".\002)";
static char fmt_9993[] = "(/\002 Tests performed: (S is Schur, T is tri"
"angular, \002,\002Q and Z are \002,a,\002,\002,/19x,\002l and r "
"are the appropriate left and right\002,/19x,\002eigenvectors, re"
"sp., a is alpha, b is beta, and\002,/19x,a,\002 means \002,a,"
"\002.)\002,/\002 Without ordering: \002,/\002 1 = | A - Q S "
"Z\002,a,\002 | / ( |A| n ulp ) 2 = | B - Q T Z\002,a,\002 |"
" / ( |B| n ulp )\002,/\002 3 = | I - QQ\002,a,\002 | / ( n ulp "
") 4 = | I - ZZ\002,a,\002 | / ( n ulp )\002,/\002 5"
" = A is in Schur form S\002,/\002 6 = difference between (alpha"
",beta)\002,\002 and diagonals of (S,T)\002,/\002 With ordering:"
" \002,/\002 7 = | (A,B) - Q (S,T) Z\002,a,\002 | / ( |(A,B)| n "
"ulp )\002,/\002 8 = | I - QQ\002,a,\002 | / ( n ulp ) "
" 9 = | I - ZZ\002,a,\002 | / ( n ulp )\002,/\002 10 = A is in "
"Schur form S\002,/\002 11 = difference between (alpha,beta) and "
"diagonals\002,\002 of (S,T)\002,/\002 12 = SDIM is the correct n"
"umber of \002,\002selected eigenvalues\002,/)";
static char fmt_9992[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
",0p,f8.2)";
static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
",1p,d10.3)";
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, s_dim1,
s_offset, t_dim1, t_offset, z_dim1, z_offset, i__1, i__2, i__3,
i__4, i__5, i__6, i__7, i__8, i__9, i__10, i__11;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10,
d__11, d__12, d__13, d__14, d__15, d__16;
doublecomplex z__1, z__2, z__3, z__4;
/* Local variables */
integer i__, j, n, n1, jc, nb, in, jr;
doublereal ulp;
integer iadd, sdim, nmax, rsub;
char sort[1];
doublereal temp1, temp2;
logical badnn;
integer iinfo;
doublereal rmagn[4];
doublecomplex ctemp;
extern /* Subroutine */ int zget51_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *
, doublecomplex *, integer *, doublecomplex *, doublereal *,
doublereal *), zgges_(char *, char *, char *, L_fp, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, logical *, integer *);
integer nmats, jsize;
extern /* Subroutine */ int zget54_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublereal *);
integer nerrs, jtype, ntest, isort;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), zlatm4_(
integer *, integer *, integer *, integer *, logical *, doublereal
*, doublereal *, doublereal *, integer *, integer *,
doublecomplex *, integer *);
logical ilabad;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
doublereal safmin, safmax;
integer knteig, ioldsd[4];
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *), xerbla_(char *, integer *),
zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *);
extern /* Double Complex */ void zlarnd_(doublecomplex *, integer *,
integer *);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *);
extern logical zlctes_(doublecomplex *, doublecomplex *);
integer minwrk, maxwrk;
doublereal ulpinv;
integer mtypes, ntestt;
/* Fortran I/O blocks */
static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9991, 0 };
/* -- LAPACK test routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* February 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZDRGES checks the nonsymmetric generalized eigenvalue (Schur form) */
/* problem driver ZGGES. */
/* ZGGES factors A and B as Q*S*Z' and Q*T*Z' , where ' means conjugate */
/* transpose, S and T are upper triangular (i.e., in generalized Schur */
/* form), and Q and Z are unitary. It also computes the generalized */
/* eigenvalues (alpha(j),beta(j)), j=1,...,n. Thus, */
/* w(j) = alpha(j)/beta(j) is a root of the characteristic equation */
/* det( A - w(j) B ) = 0 */
/* Optionally it also reorder the eigenvalues so that a selected */
/* cluster of eigenvalues appears in the leading diagonal block of the */
/* Schur forms. */
/* When ZDRGES is called, a number of matrix "sizes" ("N's") and a */
/* number of matrix "TYPES" are specified. For each size ("N") */
/* and each TYPE of matrix, a pair of matrices (A, B) will be generated */
/* and used for testing. For each matrix pair, the following 13 tests */
/* will be performed and compared with the threshhold THRESH except */
/* the tests (5), (11) and (13). */
/* (1) | A - Q S Z' | / ( |A| n ulp ) (no sorting of eigenvalues) */
/* (2) | B - Q T Z' | / ( |B| n ulp ) (no sorting of eigenvalues) */
/* (3) | I - QQ' | / ( n ulp ) (no sorting of eigenvalues) */
/* (4) | I - ZZ' | / ( n ulp ) (no sorting of eigenvalues) */
/* (5) if A is in Schur form (i.e. triangular form) (no sorting of */
/* eigenvalues) */
/* (6) if eigenvalues = diagonal elements of the Schur form (S, T), */
/* i.e., test the maximum over j of D(j) where: */
/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
/* D(j) = ------------------------ + ----------------------- */
/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
/* (no sorting of eigenvalues) */
/* (7) | (A,B) - Q (S,T) Z' | / ( |(A,B)| n ulp ) */
/* (with sorting of eigenvalues). */
/* (8) | I - QQ' | / ( n ulp ) (with sorting of eigenvalues). */
/* (9) | I - ZZ' | / ( n ulp ) (with sorting of eigenvalues). */
/* (10) if A is in Schur form (i.e. quasi-triangular form) */
/* (with sorting of eigenvalues). */
/* (11) if eigenvalues = diagonal elements of the Schur form (S, T), */
/* i.e. test the maximum over j of D(j) where: */
/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
/* D(j) = ------------------------ + ----------------------- */
/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
/* (with sorting of eigenvalues). */
/* (12) if sorting worked and SDIM is the number of eigenvalues */
/* which were CELECTed. */
/* Test Matrices */
/* ============= */
/* The sizes of the test matrices are specified by an array */
/* NN(1:NSIZES); the value of each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if */
/* DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) ( 0, 0 ) (a pair of zero matrices) */
/* (2) ( I, 0 ) (an identity and a zero matrix) */
/* (3) ( 0, I ) (an identity and a zero matrix) */
/* (4) ( I, I ) (a pair of identity matrices) */
/* t t */
/* (5) ( J , J ) (a pair of transposed Jordan blocks) */
/* t ( I 0 ) */
/* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) */
/* ( 0 I ) ( 0 J ) */
/* and I is a k x k identity and J a (k+1)x(k+1) */
/* Jordan block; k=(N-1)/2 */
/* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal */
/* matrix with those diagonal entries.) */
/* (8) ( I, D ) */
/* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big */
/* (10) ( small*D, big*I ) */
/* (11) ( big*I, small*D ) */
/* (12) ( small*I, big*D ) */
/* (13) ( big*D, big*I ) */
/* (14) ( small*D, small*I ) */
/* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and */
/* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) */
/* t t */
/* (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. */
/* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices */
/* with random O(1) entries above the diagonal */
/* and diagonal entries diag(T1) = */
/* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = */
/* ( 0, N-3, N-4,..., 1, 0, 0 ) */
/* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) */
/* s = machine precision. */
/* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) */
/* N-5 */
/* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
/* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
/* where r1,..., r(N-4) are random. */
/* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular */
/* matrices. */
/* Arguments */
/* ========= */
/* NSIZES (input) INTEGER */
/* The number of sizes of matrices to use. If it is zero, */
/* DDRGES does nothing. NSIZES >= 0. */
/* NN (input) INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. NN >= 0. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. If it is zero, DDRGES */
/* does nothing. It must be at least zero. If it is MAXTYP+1 */
/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
/* defined, which is to use whatever matrix is in A on input. */
/* This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/* DOTYPE(MAXTYP+1) is .TRUE. . */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The random number generator uses a linear */
/* congruential sequence limited to small integers, and so */
/* should produce machine independent random numbers. The */
/* values of ISEED are changed on exit, and can be used in the */
/* next call to DDRGES to continue the same random number */
/* sequence. */
/* THRESH (input) DOUBLE PRECISION */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error is */
/* scaled to be O(1), so THRESH should be a reasonably small */
/* multiple of 1, e.g., 10 or 100. In particular, it should */
/* not depend on the precision (single vs. double) or the size */
/* of the matrix. THRESH >= 0. */
/* NOUNIT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* A (input/workspace) COMPLEX*16 array, dimension(LDA, max(NN)) */
/* Used to hold the original A matrix. Used as input only */
/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
/* DOTYPE(MAXTYP+1)=.TRUE. */
/* LDA (input) INTEGER */
/* The leading dimension of A, B, S, and T. */
/* It must be at least 1 and at least max( NN ). */
/* B (input/workspace) COMPLEX*16 array, dimension(LDA, max(NN)) */
/* Used to hold the original B matrix. Used as input only */
/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
/* DOTYPE(MAXTYP+1)=.TRUE. */
/* S (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
/* The Schur form matrix computed from A by ZGGES. On exit, S */
/* contains the Schur form matrix corresponding to the matrix */
/* in A. */
/* T (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
/* The upper triangular matrix computed from B by ZGGES. */
/* Q (workspace) COMPLEX*16 array, dimension (LDQ, max(NN)) */
/* The (left) orthogonal matrix computed by ZGGES. */
/* LDQ (input) INTEGER */
/* The leading dimension of Q and Z. It must */
/* be at least 1 and at least max( NN ). */
/* Z (workspace) COMPLEX*16 array, dimension( LDQ, max(NN) ) */
/* The (right) orthogonal matrix computed by ZGGES. */
/* ALPHA (workspace) COMPLEX*16 array, dimension (max(NN)) */
/* BETA (workspace) COMPLEX*16 array, dimension (max(NN)) */
/* The generalized eigenvalues of (A,B) computed by ZGGES. */
/* ALPHA(k) / BETA(k) is the k-th generalized eigenvalue of A */
/* and B. */
/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= 3*N*N. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension ( 8*N ) */
/* Real workspace. */
/* RESULT (output) DOUBLE PRECISION array, dimension (15) */
/* The values computed by the tests described above. */
/* The values are currently limited to 1/ulp, to avoid overflow. */
/* BWORK (workspace) LOGICAL array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: A routine returned an error code. INFO is the */
/* absolute value of the INFO value returned. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--dotype;
--iseed;
t_dim1 = *lda;
t_offset = 1 + t_dim1;
t -= t_offset;
s_dim1 = *lda;
s_offset = 1 + s_dim1;
s -= s_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
z_dim1 = *ldq;
z_offset = 1 + z_dim1;
z__ -= z_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--alpha;
--beta;
--work;
--rwork;
--result;
--bwork;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
*info = 0;
badnn = FALSE_;
nmax = 1;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.) {
*info = -6;
} else if (*lda <= 1 || *lda < nmax) {
*info = -9;
} else if (*ldq <= 1 || *ldq < nmax) {
*info = -14;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* NB refers to the optimal block size for the immediately */
/* following subroutine, as returned by ILAENV. */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
minwrk = nmax * 3 * nmax;
/* Computing MAX */
i__1 = 1, i__2 = ilaenv_(&c__1, "ZGEQRF", " ", &nmax, &nmax, &c_n1, &
c_n1), i__1 = max(i__1,i__2), i__2 =
ilaenv_(&c__1, "ZUNMQR", "LC", &nmax, &nmax, &nmax, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
c__1, "ZUNGQR", " ", &nmax, &nmax, &nmax, &c_n1);
nb = max(i__1,i__2);
/* Computing MAX */
i__1 = nmax + nmax * nb, i__2 = nmax * 3 * nmax;
maxwrk = max(i__1,i__2);
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
}
if (*lwork < minwrk) {
*info = -19;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZDRGES", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
ulp = dlamch_("Precision");
safmin = dlamch_("Safe minimum");
safmin /= ulp;
safmax = 1. / safmin;
dlabad_(&safmin, &safmax);
ulpinv = 1. / ulp;
/* The values RMAGN(2:3) depend on N, see below. */
rmagn[0] = 0.;
rmagn[1] = 1.;
/* Loop over matrix sizes */
ntestt = 0;
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
n1 = max(1,n);
rmagn[2] = safmax * ulp / (doublereal) n1;
rmagn[3] = safmin * ulpinv * (doublereal) n1;
if (*nsizes != 1) {
mtypes = min(26,*ntypes);
} else {
mtypes = min(27,*ntypes);
}
/* Loop over matrix types */
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L180;
}
++nmats;
ntest = 0;
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Initialize RESULT */
for (j = 1; j <= 13; ++j) {
result[j] = 0.;
/* L30: */
}
/* Generate test matrices A and B */
/* Description of control parameters: */
/* KZLASS: =1 means w/o rotation, =2 means w/ rotation, */
/* =3 means random. */
/* KATYPE: the "type" to be passed to ZLATM4 for computing A. */
/* KAZERO: the pattern of zeros on the diagonal for A: */
/* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), */
/* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), */
/* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of */
/* non-zero entries.) */
/* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), */
/* =2: large, =3: small. */
/* LASIGN: .TRUE. if the diagonal elements of A are to be */
/* multiplied by a random magnitude 1 number. */
/* KBTYPE, KBZERO, KBMAGN, LBSIGN: the same, but for B. */
/* KTRIAN: =0: don't fill in the upper triangle, =1: do. */
/* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. */
/* RMAGN: used to implement KAMAGN and KBMAGN. */
if (mtypes > 26) {
goto L110;
}
iinfo = 0;
if (kclass[jtype - 1] < 3) {
/* Generate A (w/o rotation) */
if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
zlaset_("Full", &n, &n, &c_b1, &c_b1, &a[a_offset],
lda);
}
} else {
in = n;
}
zlatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
&kz2[kazero[jtype - 1] - 1], &lasign[jtype - 1], &
rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
a_offset], lda);
iadd = kadd[kazero[jtype - 1] - 1];
if (iadd > 0 && iadd <= n) {
i__3 = iadd + iadd * a_dim1;
i__4 = kamagn[jtype - 1];
a[i__3].r = rmagn[i__4], a[i__3].i = 0.;
}
/* Generate B (w/o rotation) */
if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
zlaset_("Full", &n, &n, &c_b1, &c_b1, &b[b_offset],
lda);
}
} else {
in = n;
}
zlatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
&kz2[kbzero[jtype - 1] - 1], &lbsign[jtype - 1], &
rmagn[kbmagn[jtype - 1]], &c_b29, &rmagn[ktrian[jtype
- 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
b_offset], lda);
iadd = kadd[kbzero[jtype - 1] - 1];
if (iadd != 0 && iadd <= n) {
i__3 = iadd + iadd * b_dim1;
i__4 = kbmagn[jtype - 1];
b[i__3].r = rmagn[i__4], b[i__3].i = 0.;
}
if (kclass[jtype - 1] == 2 && n > 0) {
/* Include rotations */
/* Generate Q, Z as Householder transformations times */
/* a diagonal matrix. */
i__3 = n - 1;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = jc; jr <= i__4; ++jr) {
i__5 = jr + jc * q_dim1;
zlarnd_(&z__1, &c__3, &iseed[1]);
q[i__5].r = z__1.r, q[i__5].i = z__1.i;
i__5 = jr + jc * z_dim1;
zlarnd_(&z__1, &c__3, &iseed[1]);
z__[i__5].r = z__1.r, z__[i__5].i = z__1.i;
/* L40: */
}
i__4 = n + 1 - jc;
zlarfg_(&i__4, &q[jc + jc * q_dim1], &q[jc + 1 + jc *
q_dim1], &c__1, &work[jc]);
i__4 = (n << 1) + jc;
i__5 = jc + jc * q_dim1;
d__2 = q[i__5].r;
d__1 = d_sign(&c_b29, &d__2);
work[i__4].r = d__1, work[i__4].i = 0.;
i__4 = jc + jc * q_dim1;
q[i__4].r = 1., q[i__4].i = 0.;
i__4 = n + 1 - jc;
zlarfg_(&i__4, &z__[jc + jc * z_dim1], &z__[jc + 1 +
jc * z_dim1], &c__1, &work[n + jc]);
i__4 = n * 3 + jc;
i__5 = jc + jc * z_dim1;
d__2 = z__[i__5].r;
d__1 = d_sign(&c_b29, &d__2);
work[i__4].r = d__1, work[i__4].i = 0.;
i__4 = jc + jc * z_dim1;
z__[i__4].r = 1., z__[i__4].i = 0.;
/* L50: */
}
zlarnd_(&z__1, &c__3, &iseed[1]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__3 = n + n * q_dim1;
q[i__3].r = 1., q[i__3].i = 0.;
i__3 = n;
work[i__3].r = 0., work[i__3].i = 0.;
i__3 = n * 3;
d__1 = z_abs(&ctemp);
z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
zlarnd_(&z__1, &c__3, &iseed[1]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__3 = n + n * z_dim1;
z__[i__3].r = 1., z__[i__3].i = 0.;
i__3 = n << 1;
work[i__3].r = 0., work[i__3].i = 0.;
i__3 = n << 2;
d__1 = z_abs(&ctemp);
z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* Apply the diagonal matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
i__5 = jr + jc * a_dim1;
i__6 = (n << 1) + jr;
d_cnjg(&z__3, &work[n * 3 + jc]);
z__2.r = work[i__6].r * z__3.r - work[i__6].i *
z__3.i, z__2.i = work[i__6].r * z__3.i +
work[i__6].i * z__3.r;
i__7 = jr + jc * a_dim1;
z__1.r = z__2.r * a[i__7].r - z__2.i * a[i__7].i,
z__1.i = z__2.r * a[i__7].i + z__2.i * a[
i__7].r;
a[i__5].r = z__1.r, a[i__5].i = z__1.i;
i__5 = jr + jc * b_dim1;
i__6 = (n << 1) + jr;
d_cnjg(&z__3, &work[n * 3 + jc]);
z__2.r = work[i__6].r * z__3.r - work[i__6].i *
z__3.i, z__2.i = work[i__6].r * z__3.i +
work[i__6].i * z__3.r;
i__7 = jr + jc * b_dim1;
z__1.r = z__2.r * b[i__7].r - z__2.i * b[i__7].i,
z__1.i = z__2.r * b[i__7].i + z__2.i * b[
i__7].r;
b[i__5].r = z__1.r, b[i__5].i = z__1.i;
/* L60: */
}
/* L70: */
}
i__3 = n - 1;
zunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &a[a_offset], lda, &work[(n << 1) + 1], &
iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
zunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &a[a_offset], lda, &work[(n << 1) +
1], &iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
zunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &b[b_offset], lda, &work[(n << 1) + 1], &
iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
zunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &b[b_offset], lda, &work[(n << 1) +
1], &iinfo);
if (iinfo != 0) {
goto L100;
}
}
} else {
/* Random matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
i__5 = jr + jc * a_dim1;
i__6 = kamagn[jtype - 1];
zlarnd_(&z__2, &c__4, &iseed[1]);
z__1.r = rmagn[i__6] * z__2.r, z__1.i = rmagn[i__6] *
z__2.i;
a[i__5].r = z__1.r, a[i__5].i = z__1.i;
i__5 = jr + jc * b_dim1;
i__6 = kbmagn[jtype - 1];
zlarnd_(&z__2, &c__4, &iseed[1]);
z__1.r = rmagn[i__6] * z__2.r, z__1.i = rmagn[i__6] *
z__2.i;
b[i__5].r = z__1.r, b[i__5].i = z__1.i;
/* L80: */
}
/* L90: */
}
}
L100:
if (iinfo != 0) {
io___41.ciunit = *nounit;
s_wsfe(&io___41);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L110:
for (i__ = 1; i__ <= 13; ++i__) {
result[i__] = -1.;
/* L120: */
}
/* Test with and without sorting of eigenvalues */
for (isort = 0; isort <= 1; ++isort) {
if (isort == 0) {
*(unsigned char *)sort = 'N';
rsub = 0;
} else {
*(unsigned char *)sort = 'S';
rsub = 5;
}
/* Call ZGGES to compute H, T, Q, Z, alpha, and beta. */
zlacpy_("Full", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
zlacpy_("Full", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
ntest = rsub + 1 + isort;
result[rsub + 1 + isort] = ulpinv;
zgges_("V", "V", sort, (L_fp)zlctes_, &n, &s[s_offset], lda, &
t[t_offset], lda, &sdim, &alpha[1], &beta[1], &q[
q_offset], ldq, &z__[z_offset], ldq, &work[1], lwork,
&rwork[1], &bwork[1], &iinfo);
if (iinfo != 0 && iinfo != n + 2) {
result[rsub + 1 + isort] = ulpinv;
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, "ZGGES", (ftnlen)5);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
goto L160;
}
ntest = rsub + 4;
/* Do tests 1--4 (or tests 7--9 when reordering ) */
if (isort == 0) {
zget51_(&c__1, &n, &a[a_offset], lda, &s[s_offset], lda, &
q[q_offset], ldq, &z__[z_offset], ldq, &work[1], &
rwork[1], &result[1]);
zget51_(&c__1, &n, &b[b_offset], lda, &t[t_offset], lda, &
q[q_offset], ldq, &z__[z_offset], ldq, &work[1], &
rwork[1], &result[2]);
} else {
zget54_(&n, &a[a_offset], lda, &b[b_offset], lda, &s[
s_offset], lda, &t[t_offset], lda, &q[q_offset],
ldq, &z__[z_offset], ldq, &work[1], &result[rsub
+ 2]);
}
zget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &q[
q_offset], ldq, &q[q_offset], ldq, &work[1], &rwork[1]
, &result[rsub + 3]);
zget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &z__[
z_offset], ldq, &z__[z_offset], ldq, &work[1], &rwork[
1], &result[rsub + 4]);
/* Do test 5 and 6 (or Tests 10 and 11 when reordering): */
/* check Schur form of A and compare eigenvalues with */
/* diagonals. */
ntest = rsub + 6;
temp1 = 0.;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
ilabad = FALSE_;
i__4 = j;
i__5 = j + j * s_dim1;
z__2.r = alpha[i__4].r - s[i__5].r, z__2.i = alpha[i__4]
.i - s[i__5].i;
z__1.r = z__2.r, z__1.i = z__2.i;
i__6 = j;
i__7 = j + j * t_dim1;
z__4.r = beta[i__6].r - t[i__7].r, z__4.i = beta[i__6].i
- t[i__7].i;
z__3.r = z__4.r, z__3.i = z__4.i;
/* Computing MAX */
i__8 = j;
i__9 = j + j * s_dim1;
d__13 = safmin, d__14 = (d__1 = alpha[i__8].r, abs(d__1))
+ (d__2 = d_imag(&alpha[j]), abs(d__2)), d__13 =
max(d__13,d__14), d__14 = (d__3 = s[i__9].r, abs(
d__3)) + (d__4 = d_imag(&s[j + j * s_dim1]), abs(
d__4));
/* Computing MAX */
i__10 = j;
i__11 = j + j * t_dim1;
d__15 = safmin, d__16 = (d__5 = beta[i__10].r, abs(d__5))
+ (d__6 = d_imag(&beta[j]), abs(d__6)), d__15 =
max(d__15,d__16), d__16 = (d__7 = t[i__11].r, abs(
d__7)) + (d__8 = d_imag(&t[j + j * t_dim1]), abs(
d__8));
temp2 = (((d__9 = z__1.r, abs(d__9)) + (d__10 = d_imag(&
z__1), abs(d__10))) / max(d__13,d__14) + ((d__11 =
z__3.r, abs(d__11)) + (d__12 = d_imag(&z__3),
abs(d__12))) / max(d__15,d__16)) / ulp;
if (j < n) {
i__4 = j + 1 + j * s_dim1;
if (s[i__4].r != 0. || s[i__4].i != 0.) {
ilabad = TRUE_;
result[rsub + 5] = ulpinv;
}
}
if (j > 1) {
i__4 = j + (j - 1) * s_dim1;
if (s[i__4].r != 0. || s[i__4].i != 0.) {
ilabad = TRUE_;
result[rsub + 5] = ulpinv;
}
}
temp1 = max(temp1,temp2);
if (ilabad) {
io___51.ciunit = *nounit;
s_wsfe(&io___51);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
e_wsfe();
}
/* L130: */
}
result[rsub + 6] = temp1;
if (isort >= 1) {
/* Do test 12 */
ntest = 12;
result[12] = 0.;
knteig = 0;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
if (zlctes_(&alpha[i__], &beta[i__])) {
++knteig;
}
/* L140: */
}
if (sdim != knteig) {
result[13] = ulpinv;
}
}
/* L150: */
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L160:
ntestt += ntest;
/* Print out tests which fail. */
i__3 = ntest;
for (jr = 1; jr <= i__3; ++jr) {
if (result[jr] >= *thresh) {
/* If this is the first test to fail, */
/* print a header to the data file. */
if (nerrs == 0) {
io___53.ciunit = *nounit;
s_wsfe(&io___53);
do_fio(&c__1, "ZGS", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___54.ciunit = *nounit;
s_wsfe(&io___54);
e_wsfe();
io___55.ciunit = *nounit;
s_wsfe(&io___55);
e_wsfe();
io___56.ciunit = *nounit;
s_wsfe(&io___56);
do_fio(&c__1, "Unitary", (ftnlen)7);
e_wsfe();
/* Tests performed */
io___57.ciunit = *nounit;
s_wsfe(&io___57);
do_fio(&c__1, "unitary", (ftnlen)7);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
for (j = 1; j <= 8; ++j) {
do_fio(&c__1, "'", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
if (result[jr] < 1e4) {
io___58.ciunit = *nounit;
s_wsfe(&io___58);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
doublereal));
e_wsfe();
} else {
io___59.ciunit = *nounit;
s_wsfe(&io___59);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
}
/* L170: */
}
L180:
;
}
/* L190: */
}
/* Summary */
alasvm_("ZGS", nounit, &nerrs, &ntestt, &c__0);
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
return 0;
/* End of ZDRGES */
} /* zdrges_ */
/* Subroutine */ int ztrevc_(char *side, char *howmny, logical *select,
integer *n, doublecomplex *t, integer *ldt, doublecomplex *vl,
integer *ldvl, doublecomplex *vr, integer *ldvr, integer *mm, integer
*m, doublecomplex *work, doublereal *rwork, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
ZTREVC computes some or all of the right and/or left eigenvectors of
a complex upper triangular matrix T.
The right eigenvector x and the left eigenvector y of T corresponding
to an eigenvalue w are defined by:
T*x = w*x, y'*T = w*y'
where y' denotes the conjugate transpose of the vector y.
If all eigenvectors are requested, the routine may either return the
matrices X and/or Y of right or left eigenvectors of T, or the
products Q*X and/or Q*Y, where Q is an input unitary
matrix. If T was obtained from the Schur factorization of an
original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of
right or left eigenvectors of A.
Arguments
=========
SIDE (input) CHARACTER*1
= 'R': compute right eigenvectors only;
= 'L': compute left eigenvectors only;
= 'B': compute both right and left eigenvectors.
HOWMNY (input) CHARACTER*1
= 'A': compute all right and/or left eigenvectors;
= 'B': compute all right and/or left eigenvectors,
and backtransform them using the input matrices
supplied in VR and/or VL;
= 'S': compute selected right and/or left eigenvectors,
specified by the logical array SELECT.
SELECT (input) LOGICAL array, dimension (N)
If HOWMNY = 'S', SELECT specifies the eigenvectors to be
computed.
If HOWMNY = 'A' or 'B', SELECT is not referenced.
To select the eigenvector corresponding to the j-th
eigenvalue, SELECT(j) must be set to .TRUE..
N (input) INTEGER
The order of the matrix T. N >= 0.
T (input/output) COMPLEX*16 array, dimension (LDT,N)
The upper triangular matrix T. T is modified, but restored
on exit.
LDT (input) INTEGER
The leading dimension of the array T. LDT >= max(1,N).
VL (input/output) COMPLEX*16 array, dimension (LDVL,MM)
On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
contain an N-by-N matrix Q (usually the unitary matrix Q of
Schur vectors returned by ZHSEQR).
On exit, if SIDE = 'L' or 'B', VL contains:
if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
VL is lower triangular. The i-th column
VL(i) of VL is the eigenvector corresponding
to T(i,i).
if HOWMNY = 'B', the matrix Q*Y;
if HOWMNY = 'S', the left eigenvectors of T specified by
SELECT, stored consecutively in the columns
of VL, in the same order as their
eigenvalues.
If SIDE = 'R', VL is not referenced.
LDVL (input) INTEGER
The leading dimension of the array VL. LDVL >= max(1,N) if
SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
VR (input/output) COMPLEX*16 array, dimension (LDVR,MM)
On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
contain an N-by-N matrix Q (usually the unitary matrix Q of
Schur vectors returned by ZHSEQR).
On exit, if SIDE = 'R' or 'B', VR contains:
if HOWMNY = 'A', the matrix X of right eigenvectors of T;
VR is upper triangular. The i-th column
VR(i) of VR is the eigenvector corresponding
to T(i,i).
if HOWMNY = 'B', the matrix Q*X;
if HOWMNY = 'S', the right eigenvectors of T specified by
SELECT, stored consecutively in the columns
of VR, in the same order as their
eigenvalues.
If SIDE = 'L', VR is not referenced.
LDVR (input) INTEGER
The leading dimension of the array VR. LDVR >= max(1,N) if
SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
MM (input) INTEGER
The number of columns in the arrays VL and/or VR. MM >= M.
M (output) INTEGER
The number of columns in the arrays VL and/or VR actually
used to store the eigenvectors. If HOWMNY = 'A' or 'B', M
is set to N. Each selected eigenvector occupies one
column.
WORK (workspace) COMPLEX*16 array, dimension (2*N)
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Further Details
===============
The algorithm used in this program is basically backward (forward)
substitution, with scaling to make the the code robust against
possible overflow.
Each eigenvector is normalized so that the element of largest
magnitude has magnitude 1; here the magnitude of a complex number
(x,y) is taken to be |x| + |y|.
=====================================================================
Decode and test the input parameters
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b2 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static logical allv;
static doublereal unfl, ovfl, smin;
static logical over;
static integer i__, j, k;
static doublereal scale;
extern logical lsame_(char *, char *);
static doublereal remax;
static logical leftv, bothv;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static logical somev;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
static integer ii, ki;
extern doublereal dlamch_(char *);
static integer is;
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *);
extern integer izamax_(integer *, doublecomplex *, integer *);
static logical rightv;
extern doublereal dzasum_(integer *, doublecomplex *, integer *);
static doublereal smlnum;
extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, doublereal *, integer *);
static doublereal ulp;
#define t_subscr(a_1,a_2) (a_2)*t_dim1 + a_1
#define t_ref(a_1,a_2) t[t_subscr(a_1,a_2)]
#define vl_subscr(a_1,a_2) (a_2)*vl_dim1 + a_1
#define vl_ref(a_1,a_2) vl[vl_subscr(a_1,a_2)]
#define vr_subscr(a_1,a_2) (a_2)*vr_dim1 + a_1
#define vr_ref(a_1,a_2) vr[vr_subscr(a_1,a_2)]
--select;
t_dim1 = *ldt;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1 * 1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1 * 1;
vr -= vr_offset;
--work;
--rwork;
/* Function Body */
bothv = lsame_(side, "B");
rightv = lsame_(side, "R") || bothv;
leftv = lsame_(side, "L") || bothv;
allv = lsame_(howmny, "A");
over = lsame_(howmny, "B");
somev = lsame_(howmny, "S");
/* Set M to the number of columns required to store the selected
eigenvectors. */
if (somev) {
*m = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (select[j]) {
++(*m);
}
/* L10: */
}
} else {
*m = *n;
}
*info = 0;
if (! rightv && ! leftv) {
*info = -1;
} else if (! allv && ! over && ! somev) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*ldt < max(1,*n)) {
*info = -6;
} else if (*ldvl < 1 || leftv && *ldvl < *n) {
*info = -8;
} else if (*ldvr < 1 || rightv && *ldvr < *n) {
*info = -10;
} else if (*mm < *m) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTREVC", &i__1);
return 0;
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
/* Set the constants to control overflow. */
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Precision");
smlnum = unfl * (*n / ulp);
/* Store the diagonal elements of T in working array WORK. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + *n;
i__3 = t_subscr(i__, i__);
work[i__2].r = t[i__3].r, work[i__2].i = t[i__3].i;
/* L20: */
}
/* Compute 1-norm of each column of strictly upper triangular
part of T to control overflow in triangular solver. */
rwork[1] = 0.;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
i__2 = j - 1;
rwork[j] = dzasum_(&i__2, &t_ref(1, j), &c__1);
/* L30: */
}
if (rightv) {
/* Compute right eigenvectors. */
is = *m;
for (ki = *n; ki >= 1; --ki) {
if (somev) {
if (! select[ki]) {
goto L80;
}
}
/* Computing MAX */
i__1 = t_subscr(ki, ki);
d__3 = ulp * ((d__1 = t[i__1].r, abs(d__1)) + (d__2 = d_imag(&
t_ref(ki, ki)), abs(d__2)));
smin = max(d__3,smlnum);
work[1].r = 1., work[1].i = 0.;
/* Form right-hand side. */
i__1 = ki - 1;
for (k = 1; k <= i__1; ++k) {
i__2 = k;
i__3 = t_subscr(k, ki);
z__1.r = -t[i__3].r, z__1.i = -t[i__3].i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L40: */
}
/* Solve the triangular system:
(T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK. */
i__1 = ki - 1;
for (k = 1; k <= i__1; ++k) {
i__2 = t_subscr(k, k);
i__3 = t_subscr(k, k);
i__4 = t_subscr(ki, ki);
z__1.r = t[i__3].r - t[i__4].r, z__1.i = t[i__3].i - t[i__4]
.i;
t[i__2].r = z__1.r, t[i__2].i = z__1.i;
i__2 = t_subscr(k, k);
if ((d__1 = t[i__2].r, abs(d__1)) + (d__2 = d_imag(&t_ref(k,
k)), abs(d__2)) < smin) {
i__3 = t_subscr(k, k);
t[i__3].r = smin, t[i__3].i = 0.;
}
/* L50: */
}
if (ki > 1) {
i__1 = ki - 1;
zlatrs_("Upper", "No transpose", "Non-unit", "Y", &i__1, &t[
t_offset], ldt, &work[1], &scale, &rwork[1], info);
i__1 = ki;
work[i__1].r = scale, work[i__1].i = 0.;
}
/* Copy the vector x or Q*x to VR and normalize. */
if (! over) {
zcopy_(&ki, &work[1], &c__1, &vr_ref(1, is), &c__1);
ii = izamax_(&ki, &vr_ref(1, is), &c__1);
i__1 = vr_subscr(ii, is);
remax = 1. / ((d__1 = vr[i__1].r, abs(d__1)) + (d__2 = d_imag(
&vr_ref(ii, is)), abs(d__2)));
zdscal_(&ki, &remax, &vr_ref(1, is), &c__1);
i__1 = *n;
for (k = ki + 1; k <= i__1; ++k) {
i__2 = vr_subscr(k, is);
vr[i__2].r = 0., vr[i__2].i = 0.;
/* L60: */
}
} else {
if (ki > 1) {
i__1 = ki - 1;
z__1.r = scale, z__1.i = 0.;
zgemv_("N", n, &i__1, &c_b2, &vr[vr_offset], ldvr, &work[
1], &c__1, &z__1, &vr_ref(1, ki), &c__1);
}
ii = izamax_(n, &vr_ref(1, ki), &c__1);
i__1 = vr_subscr(ii, ki);
remax = 1. / ((d__1 = vr[i__1].r, abs(d__1)) + (d__2 = d_imag(
&vr_ref(ii, ki)), abs(d__2)));
zdscal_(n, &remax, &vr_ref(1, ki), &c__1);
}
/* Set back the original diagonal elements of T. */
i__1 = ki - 1;
for (k = 1; k <= i__1; ++k) {
i__2 = t_subscr(k, k);
i__3 = k + *n;
t[i__2].r = work[i__3].r, t[i__2].i = work[i__3].i;
/* L70: */
}
--is;
L80:
;
}
}
if (leftv) {
/* Compute left eigenvectors. */
is = 1;
i__1 = *n;
for (ki = 1; ki <= i__1; ++ki) {
if (somev) {
if (! select[ki]) {
goto L130;
}
}
/* Computing MAX */
i__2 = t_subscr(ki, ki);
d__3 = ulp * ((d__1 = t[i__2].r, abs(d__1)) + (d__2 = d_imag(&
t_ref(ki, ki)), abs(d__2)));
smin = max(d__3,smlnum);
i__2 = *n;
work[i__2].r = 1., work[i__2].i = 0.;
/* Form right-hand side. */
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
i__3 = k;
d_cnjg(&z__2, &t_ref(ki, k));
z__1.r = -z__2.r, z__1.i = -z__2.i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L90: */
}
/* Solve the triangular system:
(T(KI+1:N,KI+1:N) - T(KI,KI))'*X = SCALE*WORK. */
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
i__3 = t_subscr(k, k);
i__4 = t_subscr(k, k);
i__5 = t_subscr(ki, ki);
z__1.r = t[i__4].r - t[i__5].r, z__1.i = t[i__4].i - t[i__5]
.i;
t[i__3].r = z__1.r, t[i__3].i = z__1.i;
i__3 = t_subscr(k, k);
if ((d__1 = t[i__3].r, abs(d__1)) + (d__2 = d_imag(&t_ref(k,
k)), abs(d__2)) < smin) {
i__4 = t_subscr(k, k);
t[i__4].r = smin, t[i__4].i = 0.;
}
/* L100: */
}
if (ki < *n) {
i__2 = *n - ki;
zlatrs_("Upper", "Conjugate transpose", "Non-unit", "Y", &
i__2, &t_ref(ki + 1, ki + 1), ldt, &work[ki + 1], &
scale, &rwork[1], info);
i__2 = ki;
work[i__2].r = scale, work[i__2].i = 0.;
}
/* Copy the vector x or Q*x to VL and normalize. */
if (! over) {
i__2 = *n - ki + 1;
zcopy_(&i__2, &work[ki], &c__1, &vl_ref(ki, is), &c__1);
i__2 = *n - ki + 1;
ii = izamax_(&i__2, &vl_ref(ki, is), &c__1) + ki - 1;
i__2 = vl_subscr(ii, is);
remax = 1. / ((d__1 = vl[i__2].r, abs(d__1)) + (d__2 = d_imag(
&vl_ref(ii, is)), abs(d__2)));
i__2 = *n - ki + 1;
zdscal_(&i__2, &remax, &vl_ref(ki, is), &c__1);
i__2 = ki - 1;
for (k = 1; k <= i__2; ++k) {
i__3 = vl_subscr(k, is);
vl[i__3].r = 0., vl[i__3].i = 0.;
/* L110: */
}
} else {
if (ki < *n) {
i__2 = *n - ki;
z__1.r = scale, z__1.i = 0.;
zgemv_("N", n, &i__2, &c_b2, &vl_ref(1, ki + 1), ldvl, &
work[ki + 1], &c__1, &z__1, &vl_ref(1, ki), &c__1);
}
ii = izamax_(n, &vl_ref(1, ki), &c__1);
i__2 = vl_subscr(ii, ki);
remax = 1. / ((d__1 = vl[i__2].r, abs(d__1)) + (d__2 = d_imag(
&vl_ref(ii, ki)), abs(d__2)));
zdscal_(n, &remax, &vl_ref(1, ki), &c__1);
}
/* Set back the original diagonal elements of T. */
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
i__3 = t_subscr(k, k);
i__4 = k + *n;
t[i__3].r = work[i__4].r, t[i__3].i = work[i__4].i;
/* L120: */
}
++is;
L130:
;
}
}
return 0;
/* End of ZTREVC */
} /* ztrevc_ */
/*< SUBROUTINE ZTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) >*/
/* Subroutine */ int ztrmv_(char *uplo, char *trans, char *diag, integer *n,
doublecomplex *a, integer *lda, doublecomplex *x, integer *incx,
ftnlen uplo_len, ftnlen trans_len, ftnlen diag_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j, ix, jx, kx=0, info;
doublecomplex temp;
extern logical lsame_(const char *, const char *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
logical noconj, nounit;
(void)uplo_len;
(void)trans_len;
(void)diag_len;
/* .. Scalar Arguments .. */
/*< INTEGER INCX, LDA, N >*/
/*< CHARACTER*1 DIAG, TRANS, UPLO >*/
/* .. Array Arguments .. */
/*< COMPLEX*16 A( LDA, * ), X( * ) >*/
/* .. */
/* Purpose */
/* ======= */
/* ZTRMV performs one of the matrix-vector operations */
/* x := A*x, or x := A'*x, or x := conjg( A' )*x, */
/* where x is an n element vector and A is an n by n unit, or non-unit, */
/* upper or lower triangular matrix. */
/* Parameters */
/* ========== */
/* UPLO - CHARACTER*1. */
/* On entry, UPLO specifies whether the matrix is an upper or */
/* lower triangular matrix as follows: */
/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
/* Unchanged on exit. */
/* TRANS - CHARACTER*1. */
/* On entry, TRANS specifies the operation to be performed as */
/* follows: */
/* TRANS = 'N' or 'n' x := A*x. */
/* TRANS = 'T' or 't' x := A'*x. */
/* TRANS = 'C' or 'c' x := conjg( A' )*x. */
/* Unchanged on exit. */
/* DIAG - CHARACTER*1. */
/* On entry, DIAG specifies whether or not A is unit */
/* triangular as follows: */
/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
/* DIAG = 'N' or 'n' A is not assumed to be unit */
/* triangular. */
/* Unchanged on exit. */
/* N - INTEGER. */
/* On entry, N specifies the order of the matrix A. */
/* N must be at least zero. */
/* Unchanged on exit. */
/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */
/* Before entry with UPLO = 'U' or 'u', the leading n by n */
/* upper triangular part of the array A must contain the upper */
/* triangular matrix and the strictly lower triangular part of */
/* A is not referenced. */
/* Before entry with UPLO = 'L' or 'l', the leading n by n */
/* lower triangular part of the array A must contain the lower */
/* triangular matrix and the strictly upper triangular part of */
/* A is not referenced. */
/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
/* A are not referenced either, but are assumed to be unity. */
/* Unchanged on exit. */
/* LDA - INTEGER. */
/* On entry, LDA specifies the first dimension of A as declared */
/* in the calling (sub) program. LDA must be at least */
/* max( 1, n ). */
/* Unchanged on exit. */
/* X - COMPLEX*16 array of dimension at least */
/* ( 1 + ( n - 1 )*abs( INCX ) ). */
/* Before entry, the incremented array X must contain the n */
/* element vector x. On exit, X is overwritten with the */
/* transformed vector x. */
/* INCX - INTEGER. */
/* On entry, INCX specifies the increment for the elements of */
/* X. INCX must not be zero. */
/* Unchanged on exit. */
/* Level 2 Blas routine. */
/* -- Written on 22-October-1986. */
/* Jack Dongarra, Argonne National Lab. */
/* Jeremy Du Croz, Nag Central Office. */
/* Sven Hammarling, Nag Central Office. */
/* Richard Hanson, Sandia National Labs. */
/* .. Parameters .. */
/*< COMPLEX*16 ZERO >*/
/*< PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) >*/
/* .. Local Scalars .. */
/*< COMPLEX*16 TEMP >*/
/*< INTEGER I, INFO, IX, J, JX, KX >*/
/*< LOGICAL NOCONJ, NOUNIT >*/
/* .. External Functions .. */
/*< LOGICAL LSAME >*/
/*< EXTERNAL LSAME >*/
/* .. External Subroutines .. */
/*< EXTERNAL XERBLA >*/
/* .. Intrinsic Functions .. */
/*< INTRINSIC DCONJG, MAX >*/
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/*< INFO = 0 >*/
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--x;
/* Function Body */
info = 0;
/*< >*/
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
ftnlen)1, (ftnlen)1)) {
/*< INFO = 1 >*/
info = 1;
/*< >*/
} else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
"T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (
ftnlen)1)) {
/*< INFO = 2 >*/
info = 2;
/*< >*/
} else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag,
"N", (ftnlen)1, (ftnlen)1)) {
/*< INFO = 3 >*/
info = 3;
/*< ELSE IF( N.LT.0 )THEN >*/
} else if (*n < 0) {
/*< INFO = 4 >*/
info = 4;
/*< ELSE IF( LDA.LT.MAX( 1, N ) )THEN >*/
} else if (*lda < max(1,*n)) {
/*< INFO = 6 >*/
info = 6;
/*< ELSE IF( INCX.EQ.0 )THEN >*/
} else if (*incx == 0) {
/*< INFO = 8 >*/
info = 8;
/*< END IF >*/
}
/*< IF( INFO.NE.0 )THEN >*/
if (info != 0) {
/*< CALL XERBLA( 'ZTRMV ', INFO ) >*/
xerbla_("ZTRMV ", &info, (ftnlen)6);
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/* Quick return if possible. */
/*< >*/
if (*n == 0) {
return 0;
}
/*< NOCONJ = LSAME( TRANS, 'T' ) >*/
noconj = lsame_(trans, "T", (ftnlen)1, (ftnlen)1);
/*< NOUNIT = LSAME( DIAG , 'N' ) >*/
nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
/* Set up the start point in X if the increment is not unity. This */
/* will be ( N - 1 )*INCX too small for descending loops. */
/*< IF( INCX.LE.0 )THEN >*/
if (*incx <= 0) {
/*< KX = 1 - ( N - 1 )*INCX >*/
kx = 1 - (*n - 1) * *incx;
/*< ELSE IF( INCX.NE.1 )THEN >*/
} else if (*incx != 1) {
/*< KX = 1 >*/
kx = 1;
/*< END IF >*/
}
/* Start the operations. In this version the elements of A are */
/* accessed sequentially with one pass through A. */
/*< IF( LSAME( TRANS, 'N' ) )THEN >*/
if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
/* Form x := A*x. */
/*< IF( LSAME( UPLO, 'U' ) )THEN >*/
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/*< IF( INCX.EQ.1 )THEN >*/
if (*incx == 1) {
/*< DO 20, J = 1, N >*/
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/*< IF( X( J ).NE.ZERO )THEN >*/
i__2 = j;
if (x[i__2].r != 0. || x[i__2].i != 0.) {
/*< TEMP = X( J ) >*/
i__2 = j;
temp.r = x[i__2].r, temp.i = x[i__2].i;
/*< DO 10, I = 1, J - 1 >*/
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
/*< X( I ) = X( I ) + TEMP*A( I, J ) >*/
i__3 = i__;
i__4 = i__;
i__5 = i__ + j * a_dim1;
z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
z__2.i = temp.r * a[i__5].i + temp.i * a[
i__5].r;
z__1.r = x[i__4].r + z__2.r, z__1.i = x[i__4].i +
z__2.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
/*< 10 CONTINUE >*/
/* L10: */
}
/*< >*/
if (nounit) {
i__2 = j;
i__3 = j;
i__4 = j + j * a_dim1;
z__1.r = x[i__3].r * a[i__4].r - x[i__3].i * a[
i__4].i, z__1.i = x[i__3].r * a[i__4].i +
x[i__3].i * a[i__4].r;
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
}
/*< END IF >*/
}
/*< 20 CONTINUE >*/
/* L20: */
}
/*< ELSE >*/
} else {
/*< JX = KX >*/
jx = kx;
/*< DO 40, J = 1, N >*/
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/*< IF( X( JX ).NE.ZERO )THEN >*/
i__2 = jx;
if (x[i__2].r != 0. || x[i__2].i != 0.) {
/*< TEMP = X( JX ) >*/
i__2 = jx;
temp.r = x[i__2].r, temp.i = x[i__2].i;
/*< IX = KX >*/
ix = kx;
/*< DO 30, I = 1, J - 1 >*/
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
/*< X( IX ) = X( IX ) + TEMP*A( I, J ) >*/
i__3 = ix;
i__4 = ix;
i__5 = i__ + j * a_dim1;
z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
z__2.i = temp.r * a[i__5].i + temp.i * a[
i__5].r;
z__1.r = x[i__4].r + z__2.r, z__1.i = x[i__4].i +
z__2.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
/*< IX = IX + INCX >*/
ix += *incx;
/*< 30 CONTINUE >*/
/* L30: */
}
/*< >*/
if (nounit) {
i__2 = jx;
i__3 = jx;
i__4 = j + j * a_dim1;
z__1.r = x[i__3].r * a[i__4].r - x[i__3].i * a[
i__4].i, z__1.i = x[i__3].r * a[i__4].i +
x[i__3].i * a[i__4].r;
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
}
/*< END IF >*/
}
/*< JX = JX + INCX >*/
jx += *incx;
/*< 40 CONTINUE >*/
/* L40: */
}
/*< END IF >*/
}
/*< ELSE >*/
} else {
/*< IF( INCX.EQ.1 )THEN >*/
if (*incx == 1) {
/*< DO 60, J = N, 1, -1 >*/
for (j = *n; j >= 1; --j) {
/*< IF( X( J ).NE.ZERO )THEN >*/
i__1 = j;
if (x[i__1].r != 0. || x[i__1].i != 0.) {
/*< TEMP = X( J ) >*/
i__1 = j;
temp.r = x[i__1].r, temp.i = x[i__1].i;
/*< DO 50, I = N, J + 1, -1 >*/
i__1 = j + 1;
for (i__ = *n; i__ >= i__1; --i__) {
/*< X( I ) = X( I ) + TEMP*A( I, J ) >*/
i__2 = i__;
i__3 = i__;
i__4 = i__ + j * a_dim1;
z__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i,
z__2.i = temp.r * a[i__4].i + temp.i * a[
i__4].r;
z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i +
z__2.i;
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
/*< 50 CONTINUE >*/
/* L50: */
}
/*< >*/
if (nounit) {
i__1 = j;
i__2 = j;
i__3 = j + j * a_dim1;
z__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[
i__3].i, z__1.i = x[i__2].r * a[i__3].i +
x[i__2].i * a[i__3].r;
x[i__1].r = z__1.r, x[i__1].i = z__1.i;
}
/*< END IF >*/
}
/*< 60 CONTINUE >*/
/* L60: */
}
/*< ELSE >*/
} else {
/*< KX = KX + ( N - 1 )*INCX >*/
kx += (*n - 1) * *incx;
/*< JX = KX >*/
jx = kx;
/*< DO 80, J = N, 1, -1 >*/
for (j = *n; j >= 1; --j) {
/*< IF( X( JX ).NE.ZERO )THEN >*/
i__1 = jx;
if (x[i__1].r != 0. || x[i__1].i != 0.) {
/*< TEMP = X( JX ) >*/
i__1 = jx;
temp.r = x[i__1].r, temp.i = x[i__1].i;
/*< IX = KX >*/
ix = kx;
/*< DO 70, I = N, J + 1, -1 >*/
i__1 = j + 1;
for (i__ = *n; i__ >= i__1; --i__) {
/*< X( IX ) = X( IX ) + TEMP*A( I, J ) >*/
i__2 = ix;
i__3 = ix;
i__4 = i__ + j * a_dim1;
z__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i,
z__2.i = temp.r * a[i__4].i + temp.i * a[
i__4].r;
z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i +
z__2.i;
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
/*< IX = IX - INCX >*/
ix -= *incx;
/*< 70 CONTINUE >*/
/* L70: */
}
/*< >*/
if (nounit) {
i__1 = jx;
i__2 = jx;
i__3 = j + j * a_dim1;
z__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[
i__3].i, z__1.i = x[i__2].r * a[i__3].i +
x[i__2].i * a[i__3].r;
x[i__1].r = z__1.r, x[i__1].i = z__1.i;
}
/*< END IF >*/
}
/*< JX = JX - INCX >*/
jx -= *incx;
/*< 80 CONTINUE >*/
/* L80: */
}
/*< END IF >*/
}
/*< END IF >*/
}
/*< ELSE >*/
} else {
/* Form x := A'*x or x := conjg( A' )*x. */
/*< IF( LSAME( UPLO, 'U' ) )THEN >*/
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/*< IF( INCX.EQ.1 )THEN >*/
if (*incx == 1) {
/*< DO 110, J = N, 1, -1 >*/
for (j = *n; j >= 1; --j) {
/*< TEMP = X( J ) >*/
i__1 = j;
temp.r = x[i__1].r, temp.i = x[i__1].i;
/*< IF( NOCONJ )THEN >*/
if (noconj) {
/*< >*/
if (nounit) {
i__1 = j + j * a_dim1;
z__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i,
z__1.i = temp.r * a[i__1].i + temp.i * a[
i__1].r;
temp.r = z__1.r, temp.i = z__1.i;
}
/*< DO 90, I = J - 1, 1, -1 >*/
for (i__ = j - 1; i__ >= 1; --i__) {
/*< TEMP = TEMP + A( I, J )*X( I ) >*/
i__1 = i__ + j * a_dim1;
i__2 = i__;
z__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[
i__2].i, z__2.i = a[i__1].r * x[i__2].i +
a[i__1].i * x[i__2].r;
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
/*< 90 CONTINUE >*/
/* L90: */
}
/*< ELSE >*/
} else {
/*< >*/
if (nounit) {
d_cnjg(&z__2, &a[j + j * a_dim1]);
z__1.r = temp.r * z__2.r - temp.i * z__2.i,
z__1.i = temp.r * z__2.i + temp.i *
z__2.r;
temp.r = z__1.r, temp.i = z__1.i;
}
/*< DO 100, I = J - 1, 1, -1 >*/
for (i__ = j - 1; i__ >= 1; --i__) {
/*< TEMP = TEMP + DCONJG( A( I, J ) )*X( I ) >*/
d_cnjg(&z__3, &a[i__ + j * a_dim1]);
i__1 = i__;
z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i,
z__2.i = z__3.r * x[i__1].i + z__3.i * x[
i__1].r;
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
/*< 100 CONTINUE >*/
/* L100: */
}
/*< END IF >*/
}
/*< X( J ) = TEMP >*/
i__1 = j;
x[i__1].r = temp.r, x[i__1].i = temp.i;
/*< 110 CONTINUE >*/
/* L110: */
}
/*< ELSE >*/
} else {
/*< JX = KX + ( N - 1 )*INCX >*/
jx = kx + (*n - 1) * *incx;
/*< DO 140, J = N, 1, -1 >*/
for (j = *n; j >= 1; --j) {
/*< TEMP = X( JX ) >*/
i__1 = jx;
temp.r = x[i__1].r, temp.i = x[i__1].i;
/*< IX = JX >*/
ix = jx;
/*< IF( NOCONJ )THEN >*/
if (noconj) {
/*< >*/
if (nounit) {
i__1 = j + j * a_dim1;
z__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i,
z__1.i = temp.r * a[i__1].i + temp.i * a[
i__1].r;
temp.r = z__1.r, temp.i = z__1.i;
}
/*< DO 120, I = J - 1, 1, -1 >*/
for (i__ = j - 1; i__ >= 1; --i__) {
/*< IX = IX - INCX >*/
ix -= *incx;
/*< TEMP = TEMP + A( I, J )*X( IX ) >*/
i__1 = i__ + j * a_dim1;
i__2 = ix;
z__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[
i__2].i, z__2.i = a[i__1].r * x[i__2].i +
a[i__1].i * x[i__2].r;
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
/*< 120 CONTINUE >*/
/* L120: */
}
/*< ELSE >*/
} else {
/*< >*/
if (nounit) {
d_cnjg(&z__2, &a[j + j * a_dim1]);
z__1.r = temp.r * z__2.r - temp.i * z__2.i,
z__1.i = temp.r * z__2.i + temp.i *
z__2.r;
temp.r = z__1.r, temp.i = z__1.i;
}
/*< DO 130, I = J - 1, 1, -1 >*/
for (i__ = j - 1; i__ >= 1; --i__) {
/*< IX = IX - INCX >*/
ix -= *incx;
/*< TEMP = TEMP + DCONJG( A( I, J ) )*X( IX ) >*/
d_cnjg(&z__3, &a[i__ + j * a_dim1]);
i__1 = ix;
z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i,
z__2.i = z__3.r * x[i__1].i + z__3.i * x[
i__1].r;
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
/*< 130 CONTINUE >*/
/* L130: */
}
/*< END IF >*/
}
/*< X( JX ) = TEMP >*/
i__1 = jx;
x[i__1].r = temp.r, x[i__1].i = temp.i;
/*< JX = JX - INCX >*/
jx -= *incx;
/*< 140 CONTINUE >*/
/* L140: */
}
/*< END IF >*/
}
/*< ELSE >*/
} else {
/*< IF( INCX.EQ.1 )THEN >*/
if (*incx == 1) {
/*< DO 170, J = 1, N >*/
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/*< TEMP = X( J ) >*/
i__2 = j;
temp.r = x[i__2].r, temp.i = x[i__2].i;
/*< IF( NOCONJ )THEN >*/
if (noconj) {
/*< >*/
if (nounit) {
i__2 = j + j * a_dim1;
z__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
z__1.i = temp.r * a[i__2].i + temp.i * a[
i__2].r;
temp.r = z__1.r, temp.i = z__1.i;
}
/*< DO 150, I = J + 1, N >*/
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
/*< TEMP = TEMP + A( I, J )*X( I ) >*/
i__3 = i__ + j * a_dim1;
i__4 = i__;
z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[
i__4].i, z__2.i = a[i__3].r * x[i__4].i +
a[i__3].i * x[i__4].r;
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
/*< 150 CONTINUE >*/
/* L150: */
}
/*< ELSE >*/
} else {
/*< >*/
if (nounit) {
d_cnjg(&z__2, &a[j + j * a_dim1]);
z__1.r = temp.r * z__2.r - temp.i * z__2.i,
z__1.i = temp.r * z__2.i + temp.i *
z__2.r;
temp.r = z__1.r, temp.i = z__1.i;
}
/*< DO 160, I = J + 1, N >*/
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
/*< TEMP = TEMP + DCONJG( A( I, J ) )*X( I ) >*/
d_cnjg(&z__3, &a[i__ + j * a_dim1]);
i__3 = i__;
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i,
z__2.i = z__3.r * x[i__3].i + z__3.i * x[
i__3].r;
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
/*< 160 CONTINUE >*/
/* L160: */
}
/*< END IF >*/
}
/*< X( J ) = TEMP >*/
i__2 = j;
x[i__2].r = temp.r, x[i__2].i = temp.i;
/*< 170 CONTINUE >*/
/* L170: */
}
/*< ELSE >*/
} else {
/*< JX = KX >*/
jx = kx;
/*< DO 200, J = 1, N >*/
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/*< TEMP = X( JX ) >*/
i__2 = jx;
temp.r = x[i__2].r, temp.i = x[i__2].i;
/*< IX = JX >*/
ix = jx;
/*< IF( NOCONJ )THEN >*/
if (noconj) {
/*< >*/
if (nounit) {
i__2 = j + j * a_dim1;
z__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
z__1.i = temp.r * a[i__2].i + temp.i * a[
i__2].r;
temp.r = z__1.r, temp.i = z__1.i;
}
/*< DO 180, I = J + 1, N >*/
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
/*< IX = IX + INCX >*/
ix += *incx;
/*< TEMP = TEMP + A( I, J )*X( IX ) >*/
i__3 = i__ + j * a_dim1;
i__4 = ix;
z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[
i__4].i, z__2.i = a[i__3].r * x[i__4].i +
a[i__3].i * x[i__4].r;
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
/*< 180 CONTINUE >*/
/* L180: */
}
/*< ELSE >*/
} else {
/*< >*/
if (nounit) {
d_cnjg(&z__2, &a[j + j * a_dim1]);
z__1.r = temp.r * z__2.r - temp.i * z__2.i,
z__1.i = temp.r * z__2.i + temp.i *
z__2.r;
temp.r = z__1.r, temp.i = z__1.i;
}
/*< DO 190, I = J + 1, N >*/
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
/*< IX = IX + INCX >*/
ix += *incx;
/*< TEMP = TEMP + DCONJG( A( I, J ) )*X( IX ) >*/
d_cnjg(&z__3, &a[i__ + j * a_dim1]);
i__3 = ix;
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i,
z__2.i = z__3.r * x[i__3].i + z__3.i * x[
i__3].r;
z__1.r = temp.r + z__2.r, z__1.i = temp.i +
z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
/*< 190 CONTINUE >*/
/* L190: */
}
/*< END IF >*/
}
/*< X( JX ) = TEMP >*/
i__2 = jx;
x[i__2].r = temp.r, x[i__2].i = temp.i;
/*< JX = JX + INCX >*/
jx += *incx;
/*< 200 CONTINUE >*/
/* L200: */
}
/*< END IF >*/
}
/*< END IF >*/
}
/*< END IF >*/
}
/*< RETURN >*/
return 0;
/* End of ZTRMV . */
/*< END >*/
} /* ztrmv_ */
/* Subroutine */ int zlarfb_(char *side, char *trans, char *direct, char *
storev, integer *m, integer *n, integer *k, doublecomplex *v, integer
*ldv, doublecomplex *t, integer *ldt, doublecomplex *c__, integer *
ldc, doublecomplex *work, integer *ldwork)
{
/* System generated locals */
integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1,
work_offset, i__1, i__2, i__3, i__4, i__5;
doublecomplex z__1, z__2;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j;
extern logical lsame_(char *, char *);
integer lastc;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
integer lastv;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), ztrmm_(char *, char *, char *, char *
, integer *, integer *, doublecomplex *, doublecomplex *, integer
*, doublecomplex *, integer *);
extern integer ilazlc_(integer *, integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zlacgv_(integer *, doublecomplex *, integer *)
;
extern integer ilazlr_(integer *, integer *, doublecomplex *, integer *);
char transt[1];
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLARFB applies a complex block reflector H or its transpose H' to a */
/* complex M-by-N matrix C, from either the left or the right. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'L': apply H or H' from the Left */
/* = 'R': apply H or H' from the Right */
/* TRANS (input) CHARACTER*1 */
/* = 'N': apply H (No transpose) */
/* = 'C': apply H' (Conjugate transpose) */
/* DIRECT (input) CHARACTER*1 */
/* Indicates how H is formed from a product of elementary */
/* reflectors */
/* = 'F': H = H(1) H(2) . . . H(k) (Forward) */
/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
/* STOREV (input) CHARACTER*1 */
/* Indicates how the vectors which define the elementary */
/* reflectors are stored: */
/* = 'C': Columnwise */
/* = 'R': Rowwise */
/* M (input) INTEGER */
/* The number of rows of the matrix C. */
/* N (input) INTEGER */
/* The number of columns of the matrix C. */
/* K (input) INTEGER */
/* The order of the matrix T (= the number of elementary */
/* reflectors whose product defines the block reflector). */
/* V (input) COMPLEX*16 array, dimension */
/* (LDV,K) if STOREV = 'C' */
/* (LDV,M) if STOREV = 'R' and SIDE = 'L' */
/* (LDV,N) if STOREV = 'R' and SIDE = 'R' */
/* The matrix V. See further details. */
/* LDV (input) INTEGER */
/* The leading dimension of the array V. */
/* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); */
/* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); */
/* if STOREV = 'R', LDV >= K. */
/* T (input) COMPLEX*16 array, dimension (LDT,K) */
/* The triangular K-by-K matrix T in the representation of the */
/* block reflector. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= K. */
/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
/* On entry, the M-by-N matrix C. */
/* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M). */
/* WORK (workspace) COMPLEX*16 array, dimension (LDWORK,K) */
/* LDWORK (input) INTEGER */
/* The leading dimension of the array WORK. */
/* If SIDE = 'L', LDWORK >= max(1,N); */
/* if SIDE = 'R', LDWORK >= max(1,M). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
work_dim1 = *ldwork;
work_offset = 1 + work_dim1;
work -= work_offset;
/* Function Body */
if (*m <= 0 || *n <= 0) {
return 0;
}
if (lsame_(trans, "N")) {
*(unsigned char *)transt = 'C';
} else {
*(unsigned char *)transt = 'N';
}
if (lsame_(storev, "C")) {
if (lsame_(direct, "F")) {
/* Let V = ( V1 ) (first K rows) */
/* ( V2 ) */
/* where V1 is unit lower triangular. */
if (lsame_(side, "L")) {
/* Form H * C or H' * C where C = ( C1 ) */
/* ( C2 ) */
/* Computing MAX */
i__1 = *k, i__2 = ilazlr_(m, k, &v[v_offset], ldv);
lastv = max(i__1,i__2);
lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc);
/* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */
/* W := C1' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1
+ 1], &c__1);
zlacgv_(&lastc, &work[j * work_dim1 + 1], &c__1);
/* L10: */
}
/* W := W * V1 */
ztrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
if (lastv > *k) {
/* W := W + C2'*V2 */
i__1 = lastv - *k;
zgemm_("Conjugate transpose", "No transpose", &lastc, k, &
i__1, &c_b1, &c__[*k + 1 + c_dim1], ldc, &v[*k +
1 + v_dim1], ldv, &c_b1, &work[work_offset],
ldwork);
}
/* W := W * T' or W * T */
ztrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &c_b1,
&t[t_offset], ldt, &work[work_offset], ldwork);
/* C := C - V * W' */
if (*m > *k) {
/* C2 := C2 - V2 * W' */
i__1 = lastv - *k;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "Conjugate transpose", &i__1, &
lastc, k, &z__1, &v[*k + 1 + v_dim1], ldv, &work[
work_offset], ldwork, &c_b1, &c__[*k + 1 + c_dim1]
, ldc);
}
/* W := W * V1' */
ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", &
lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset]
, ldwork)
;
/* C1 := C1 - W' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = lastc;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = j + i__ * c_dim1;
i__4 = j + i__ * c_dim1;
d_cnjg(&z__2, &work[i__ + j * work_dim1]);
z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i -
z__2.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L20: */
}
/* L30: */
}
} else if (lsame_(side, "R")) {
/* Form C * H or C * H' where C = ( C1 C2 ) */
/* Computing MAX */
i__1 = *k, i__2 = ilazlr_(n, k, &v[v_offset], ldv);
lastv = max(i__1,i__2);
lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc);
/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */
/* W := C1 */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j *
work_dim1 + 1], &c__1);
/* L40: */
}
/* W := W * V1 */
ztrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
if (lastv > *k) {
/* W := W + C2 * V2 */
i__1 = lastv - *k;
zgemm_("No transpose", "No transpose", &lastc, k, &i__1, &
c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k + 1
+ v_dim1], ldv, &c_b1, &work[work_offset], ldwork);
}
/* W := W * T or W * T' */
ztrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b1,
&t[t_offset], ldt, &work[work_offset], ldwork);
/* C := C - W * V' */
if (lastv > *k) {
/* C2 := C2 - W * V2' */
i__1 = lastv - *k;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "Conjugate transpose", &lastc, &
i__1, k, &z__1, &work[work_offset], ldwork, &v[*k
+ 1 + v_dim1], ldv, &c_b1, &c__[(*k + 1) * c_dim1
+ 1], ldc);
}
/* W := W * V1' */
ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", &
lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset]
, ldwork)
;
/* C1 := C1 - W */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = lastc;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
i__5 = i__ + j * work_dim1;
z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[
i__4].i - work[i__5].i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L50: */
}
/* L60: */
}
}
} else {
/* Let V = ( V1 ) */
/* ( V2 ) (last K rows) */
/* where V2 is unit upper triangular. */
if (lsame_(side, "L")) {
/* Form H * C or H' * C where C = ( C1 ) */
/* ( C2 ) */
/* Computing MAX */
i__1 = *k, i__2 = ilazlr_(m, k, &v[v_offset], ldv);
lastv = max(i__1,i__2);
lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc);
/* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */
/* W := C2' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[
j * work_dim1 + 1], &c__1);
zlacgv_(&lastc, &work[j * work_dim1 + 1], &c__1);
/* L70: */
}
/* W := W * V2 */
ztrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
c_b1, &v[lastv - *k + 1 + v_dim1], ldv, &work[
work_offset], ldwork);
if (lastv > *k) {
/* W := W + C1'*V1 */
i__1 = lastv - *k;
zgemm_("Conjugate transpose", "No transpose", &lastc, k, &
i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset],
ldv, &c_b1, &work[work_offset], ldwork);
}
/* W := W * T' or W * T */
ztrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &c_b1,
&t[t_offset], ldt, &work[work_offset], ldwork);
/* C := C - V * W' */
if (lastv > *k) {
/* C1 := C1 - V1 * W' */
i__1 = lastv - *k;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "Conjugate transpose", &i__1, &
lastc, k, &z__1, &v[v_offset], ldv, &work[
work_offset], ldwork, &c_b1, &c__[c_offset], ldc);
}
/* W := W * V2' */
ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", &
lastc, k, &c_b1, &v[lastv - *k + 1 + v_dim1], ldv, &
work[work_offset], ldwork);
/* C2 := C2 - W' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = lastc;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = lastv - *k + j + i__ * c_dim1;
i__4 = lastv - *k + j + i__ * c_dim1;
d_cnjg(&z__2, &work[i__ + j * work_dim1]);
z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i -
z__2.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L80: */
}
/* L90: */
}
} else if (lsame_(side, "R")) {
/* Form C * H or C * H' where C = ( C1 C2 ) */
/* Computing MAX */
i__1 = *k, i__2 = ilazlr_(n, k, &v[v_offset], ldv);
lastv = max(i__1,i__2);
lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc);
/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */
/* W := C2 */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1,
&work[j * work_dim1 + 1], &c__1);
/* L100: */
}
/* W := W * V2 */
ztrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
c_b1, &v[lastv - *k + 1 + v_dim1], ldv, &work[
work_offset], ldwork);
if (lastv > *k) {
/* W := W + C1 * V1 */
i__1 = lastv - *k;
zgemm_("No transpose", "No transpose", &lastc, k, &i__1, &
c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, &
c_b1, &work[work_offset], ldwork);
}
/* W := W * T or W * T' */
ztrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b1,
&t[t_offset], ldt, &work[work_offset], ldwork);
/* C := C - W * V' */
if (lastv > *k) {
/* C1 := C1 - W * V1' */
i__1 = lastv - *k;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "Conjugate transpose", &lastc, &
i__1, k, &z__1, &work[work_offset], ldwork, &v[
v_offset], ldv, &c_b1, &c__[c_offset], ldc);
}
/* W := W * V2' */
ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", &
lastc, k, &c_b1, &v[lastv - *k + 1 + v_dim1], ldv, &
work[work_offset], ldwork);
/* C2 := C2 - W */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = lastc;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + (lastv - *k + j) * c_dim1;
i__4 = i__ + (lastv - *k + j) * c_dim1;
i__5 = i__ + j * work_dim1;
z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[
i__4].i - work[i__5].i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L110: */
}
/* L120: */
}
}
}
} else if (lsame_(storev, "R")) {
if (lsame_(direct, "F")) {
/* Let V = ( V1 V2 ) (V1: first K columns) */
/* where V1 is unit upper triangular. */
if (lsame_(side, "L")) {
/* Form H * C or H' * C where C = ( C1 ) */
/* ( C2 ) */
/* Computing MAX */
i__1 = *k, i__2 = ilazlc_(k, m, &v[v_offset], ldv);
lastv = max(i__1,i__2);
lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc);
/* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */
/* W := C1' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1
+ 1], &c__1);
zlacgv_(&lastc, &work[j * work_dim1 + 1], &c__1);
/* L130: */
}
/* W := W * V1' */
ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", &
lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset]
, ldwork)
;
if (lastv > *k) {
/* W := W + C2'*V2' */
i__1 = lastv - *k;
zgemm_("Conjugate transpose", "Conjugate transpose", &
lastc, k, &i__1, &c_b1, &c__[*k + 1 + c_dim1],
ldc, &v[(*k + 1) * v_dim1 + 1], ldv, &c_b1, &work[
work_offset], ldwork);
}
/* W := W * T' or W * T */
ztrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &c_b1,
&t[t_offset], ldt, &work[work_offset], ldwork);
/* C := C - V' * W' */
if (lastv > *k) {
/* C2 := C2 - V2' * W' */
i__1 = lastv - *k;
z__1.r = -1., z__1.i = -0.;
zgemm_("Conjugate transpose", "Conjugate transpose", &
i__1, &lastc, k, &z__1, &v[(*k + 1) * v_dim1 + 1],
ldv, &work[work_offset], ldwork, &c_b1, &c__[*k
+ 1 + c_dim1], ldc);
}
/* W := W * V1 */
ztrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
/* C1 := C1 - W' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = lastc;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = j + i__ * c_dim1;
i__4 = j + i__ * c_dim1;
d_cnjg(&z__2, &work[i__ + j * work_dim1]);
z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i -
z__2.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L140: */
}
/* L150: */
}
} else if (lsame_(side, "R")) {
/* Form C * H or C * H' where C = ( C1 C2 ) */
/* Computing MAX */
i__1 = *k, i__2 = ilazlc_(k, n, &v[v_offset], ldv);
lastv = max(i__1,i__2);
lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc);
/* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */
/* W := C1 */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j *
work_dim1 + 1], &c__1);
/* L160: */
}
/* W := W * V1' */
ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", &
lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset]
, ldwork)
;
if (lastv > *k) {
/* W := W + C2 * V2' */
i__1 = lastv - *k;
zgemm_("No transpose", "Conjugate transpose", &lastc, k, &
i__1, &c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[
(*k + 1) * v_dim1 + 1], ldv, &c_b1, &work[
work_offset], ldwork);
}
/* W := W * T or W * T' */
ztrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b1,
&t[t_offset], ldt, &work[work_offset], ldwork);
/* C := C - W * V */
if (lastv > *k) {
/* C2 := C2 - W * V2 */
i__1 = lastv - *k;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "No transpose", &lastc, &i__1, k, &
z__1, &work[work_offset], ldwork, &v[(*k + 1) *
v_dim1 + 1], ldv, &c_b1, &c__[(*k + 1) * c_dim1 +
1], ldc);
}
/* W := W * V1 */
ztrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
/* C1 := C1 - W */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = lastc;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
i__5 = i__ + j * work_dim1;
z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[
i__4].i - work[i__5].i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L170: */
}
/* L180: */
}
}
} else {
/* Let V = ( V1 V2 ) (V2: last K columns) */
/* where V2 is unit lower triangular. */
if (lsame_(side, "L")) {
/* Form H * C or H' * C where C = ( C1 ) */
/* ( C2 ) */
/* Computing MAX */
i__1 = *k, i__2 = ilazlc_(k, m, &v[v_offset], ldv);
lastv = max(i__1,i__2);
lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc);
/* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */
/* W := C2' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[
j * work_dim1 + 1], &c__1);
zlacgv_(&lastc, &work[j * work_dim1 + 1], &c__1);
/* L190: */
}
/* W := W * V2' */
ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", &
lastc, k, &c_b1, &v[(lastv - *k + 1) * v_dim1 + 1],
ldv, &work[work_offset], ldwork);
if (lastv > *k) {
/* W := W + C1'*V1' */
i__1 = lastv - *k;
zgemm_("Conjugate transpose", "Conjugate transpose", &
lastc, k, &i__1, &c_b1, &c__[c_offset], ldc, &v[
v_offset], ldv, &c_b1, &work[work_offset], ldwork);
}
/* W := W * T' or W * T */
ztrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &c_b1,
&t[t_offset], ldt, &work[work_offset], ldwork);
/* C := C - V' * W' */
if (lastv > *k) {
/* C1 := C1 - V1' * W' */
i__1 = lastv - *k;
z__1.r = -1., z__1.i = -0.;
zgemm_("Conjugate transpose", "Conjugate transpose", &
i__1, &lastc, k, &z__1, &v[v_offset], ldv, &work[
work_offset], ldwork, &c_b1, &c__[c_offset], ldc);
}
/* W := W * V2 */
ztrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
c_b1, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
work_offset], ldwork);
/* C2 := C2 - W' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = lastc;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = lastv - *k + j + i__ * c_dim1;
i__4 = lastv - *k + j + i__ * c_dim1;
d_cnjg(&z__2, &work[i__ + j * work_dim1]);
z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i -
z__2.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L200: */
}
/* L210: */
}
} else if (lsame_(side, "R")) {
/* Form C * H or C * H' where C = ( C1 C2 ) */
/* Computing MAX */
i__1 = *k, i__2 = ilazlc_(k, n, &v[v_offset], ldv);
lastv = max(i__1,i__2);
lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc);
/* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */
/* W := C2 */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
zcopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1,
&work[j * work_dim1 + 1], &c__1);
/* L220: */
}
/* W := W * V2' */
ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", &
lastc, k, &c_b1, &v[(lastv - *k + 1) * v_dim1 + 1],
ldv, &work[work_offset], ldwork);
if (lastv > *k) {
/* W := W + C1 * V1' */
i__1 = lastv - *k;
zgemm_("No transpose", "Conjugate transpose", &lastc, k, &
i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset],
ldv, &c_b1, &work[work_offset], ldwork);
}
/* W := W * T or W * T' */
ztrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b1,
&t[t_offset], ldt, &work[work_offset], ldwork);
/* C := C - W * V */
if (lastv > *k) {
/* C1 := C1 - W * V1 */
i__1 = lastv - *k;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "No transpose", &lastc, &i__1, k, &
z__1, &work[work_offset], ldwork, &v[v_offset],
ldv, &c_b1, &c__[c_offset], ldc);
}
/* W := W * V2 */
ztrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
c_b1, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
work_offset], ldwork);
/* C1 := C1 - W */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = lastc;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + (lastv - *k + j) * c_dim1;
i__4 = i__ + (lastv - *k + j) * c_dim1;
i__5 = i__ + j * work_dim1;
z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[
i__4].i - work[i__5].i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L230: */
}
/* L240: */
}
}
}
}
return 0;
/* End of ZLARFB */
} /* zlarfb_ */
/* Subroutine */ int zlaqps_(integer *m, integer *n, integer *offset, integer
*nb, integer *kb, doublecomplex *a, integer *lda, integer *jpvt,
doublecomplex *tau, doublereal *vn1, doublereal *vn2, doublecomplex *
auxv, doublecomplex *f, integer *ldf)
{
/* System generated locals */
integer a_dim1, a_offset, f_dim1, f_offset, i__1, i__2, i__3;
doublereal d__1, d__2;
doublecomplex z__1;
/* Builtin functions */
double sqrt(doublereal);
void d_cnjg(doublecomplex *, doublecomplex *);
double z_abs(doublecomplex *);
integer i_dnnt(doublereal *);
/* Local variables */
integer j, k, rk;
doublecomplex akk;
integer pvt;
doublereal temp, temp2, tol3z;
integer itemp;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *),
zswap_(integer *, doublecomplex *, integer *, doublecomplex *,
integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
char *);
extern integer idamax_(integer *, doublereal *, integer *);
integer lsticc;
extern /* Subroutine */ int zlarfp_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *);
integer lastrk;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLAQPS computes a step of QR factorization with column pivoting */
/* of a complex M-by-N matrix A by using Blas-3. It tries to factorize */
/* NB columns from A starting from the row OFFSET+1, and updates all */
/* of the matrix with Blas-3 xGEMM. */
/* In some cases, due to catastrophic cancellations, it cannot */
/* factorize NB columns. Hence, the actual number of factorized */
/* columns is returned in KB. */
/* Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0 */
/* OFFSET (input) INTEGER */
/* The number of rows of A that have been factorized in */
/* previous steps. */
/* NB (input) INTEGER */
/* The number of columns to factorize. */
/* KB (output) INTEGER */
/* The number of columns actually factorized. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, block A(OFFSET+1:M,1:KB) is the triangular */
/* factor obtained and block A(1:OFFSET,1:N) has been */
/* accordingly pivoted, but no factorized. */
/* The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has */
/* been updated. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* JPVT (input/output) INTEGER array, dimension (N) */
/* JPVT(I) = K <==> Column K of the full matrix A has been */
/* permuted into position I in AP. */
/* TAU (output) COMPLEX*16 array, dimension (KB) */
/* The scalar factors of the elementary reflectors. */
/* VN1 (input/output) DOUBLE PRECISION array, dimension (N) */
/* The vector with the partial column norms. */
/* VN2 (input/output) DOUBLE PRECISION array, dimension (N) */
/* The vector with the exact column norms. */
/* AUXV (input/output) COMPLEX*16 array, dimension (NB) */
/* Auxiliar vector. */
/* F (input/output) COMPLEX*16 array, dimension (LDF,NB) */
/* Matrix F' = L*Y'*A. */
/* LDF (input) INTEGER */
/* The leading dimension of the array F. LDF >= max(1,N). */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
/* X. Sun, Computer Science Dept., Duke University, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--jpvt;
--tau;
--vn1;
--vn2;
--auxv;
f_dim1 = *ldf;
f_offset = 1 + f_dim1;
f -= f_offset;
/* Function Body */
/* Computing MIN */
i__1 = *m, i__2 = *n + *offset;
lastrk = min(i__1,i__2);
lsticc = 0;
k = 0;
tol3z = sqrt(dlamch_("Epsilon"));
/* Beginning of while loop. */
L10:
if (k < *nb && lsticc == 0) {
++k;
rk = *offset + k;
/* Determine ith pivot column and swap if necessary */
i__1 = *n - k + 1;
pvt = k - 1 + idamax_(&i__1, &vn1[k], &c__1);
if (pvt != k) {
zswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1);
i__1 = k - 1;
zswap_(&i__1, &f[pvt + f_dim1], ldf, &f[k + f_dim1], ldf);
itemp = jpvt[pvt];
jpvt[pvt] = jpvt[k];
jpvt[k] = itemp;
vn1[pvt] = vn1[k];
vn2[pvt] = vn2[k];
}
/* Apply previous Householder reflectors to column K: */
/* A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)'. */
if (k > 1) {
i__1 = k - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = k + j * f_dim1;
d_cnjg(&z__1, &f[k + j * f_dim1]);
f[i__2].r = z__1.r, f[i__2].i = z__1.i;
/* L20: */
}
i__1 = *m - rk + 1;
i__2 = k - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__1, &i__2, &z__1, &a[rk + a_dim1], lda,
&f[k + f_dim1], ldf, &c_b2, &a[rk + k * a_dim1], &c__1);
i__1 = k - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = k + j * f_dim1;
d_cnjg(&z__1, &f[k + j * f_dim1]);
f[i__2].r = z__1.r, f[i__2].i = z__1.i;
/* L30: */
}
}
/* Generate elementary reflector H(k). */
if (rk < *m) {
i__1 = *m - rk + 1;
zlarfp_(&i__1, &a[rk + k * a_dim1], &a[rk + 1 + k * a_dim1], &
c__1, &tau[k]);
} else {
zlarfp_(&c__1, &a[rk + k * a_dim1], &a[rk + k * a_dim1], &c__1, &
tau[k]);
}
i__1 = rk + k * a_dim1;
akk.r = a[i__1].r, akk.i = a[i__1].i;
i__1 = rk + k * a_dim1;
a[i__1].r = 1., a[i__1].i = 0.;
/* Compute Kth column of F: */
/* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)'*A(RK:M,K). */
if (k < *n) {
i__1 = *m - rk + 1;
i__2 = *n - k;
zgemv_("Conjugate transpose", &i__1, &i__2, &tau[k], &a[rk + (k +
1) * a_dim1], lda, &a[rk + k * a_dim1], &c__1, &c_b1, &f[
k + 1 + k * f_dim1], &c__1);
}
/* Padding F(1:K,K) with zeros. */
i__1 = k;
for (j = 1; j <= i__1; ++j) {
i__2 = j + k * f_dim1;
f[i__2].r = 0., f[i__2].i = 0.;
/* L40: */
}
/* Incremental updating of F: */
/* F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)' */
/* *A(RK:M,K). */
if (k > 1) {
i__1 = *m - rk + 1;
i__2 = k - 1;
i__3 = k;
z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i;
zgemv_("Conjugate transpose", &i__1, &i__2, &z__1, &a[rk + a_dim1]
, lda, &a[rk + k * a_dim1], &c__1, &c_b1, &auxv[1], &c__1);
i__1 = k - 1;
zgemv_("No transpose", n, &i__1, &c_b2, &f[f_dim1 + 1], ldf, &
auxv[1], &c__1, &c_b2, &f[k * f_dim1 + 1], &c__1);
}
/* Update the current row of A: */
/* A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)'. */
if (k < *n) {
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "Conjugate transpose", &c__1, &i__1, &k, &
z__1, &a[rk + a_dim1], lda, &f[k + 1 + f_dim1], ldf, &
c_b2, &a[rk + (k + 1) * a_dim1], lda);
}
/* Update partial column norms. */
if (rk < lastrk) {
i__1 = *n;
for (j = k + 1; j <= i__1; ++j) {
if (vn1[j] != 0.) {
/* NOTE: The following 4 lines follow from the analysis in */
/* Lapack Working Note 176. */
temp = z_abs(&a[rk + j * a_dim1]) / vn1[j];
/* Computing MAX */
d__1 = 0., d__2 = (temp + 1.) * (1. - temp);
temp = max(d__1,d__2);
/* Computing 2nd power */
d__1 = vn1[j] / vn2[j];
temp2 = temp * (d__1 * d__1);
if (temp2 <= tol3z) {
vn2[j] = (doublereal) lsticc;
lsticc = j;
} else {
vn1[j] *= sqrt(temp);
}
}
/* L50: */
}
}
i__1 = rk + k * a_dim1;
a[i__1].r = akk.r, a[i__1].i = akk.i;
/* End of while loop. */
goto L10;
}
*kb = k;
rk = *offset + *kb;
/* Apply the block reflector to the rest of the matrix: */
/* A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - */
/* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)'. */
/* Computing MIN */
i__1 = *n, i__2 = *m - *offset;
if (*kb < min(i__1,i__2)) {
i__1 = *m - rk;
i__2 = *n - *kb;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "Conjugate transpose", &i__1, &i__2, kb, &z__1,
&a[rk + 1 + a_dim1], lda, &f[*kb + 1 + f_dim1], ldf, &c_b2, &
a[rk + 1 + (*kb + 1) * a_dim1], lda);
}
/* Recomputation of difficult columns. */
L60:
if (lsticc > 0) {
itemp = i_dnnt(&vn2[lsticc]);
i__1 = *m - rk;
vn1[lsticc] = dznrm2_(&i__1, &a[rk + 1 + lsticc * a_dim1], &c__1);
/* NOTE: The computation of VN1( LSTICC ) relies on the fact that */
/* SNRM2 does not fail on vectors with norm below the value of */
/* SQRT(DLAMCH('S')) */
vn2[lsticc] = vn1[lsticc];
lsticc = itemp;
goto L60;
}
return 0;
/* End of ZLAQPS */
} /* zlaqps_ */
/* Subroutine */ int zlacgv_(integer *n, doublecomplex *x, integer *incx)
{
/* System generated locals */
integer i__1, i__2;
doublecomplex z__1;
/* Local variables */
integer i__, ioff;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* ZLACGV conjugates a complex vector of length N. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The length of the vector X. N >= 0. */
/* X (input/output) COMPLEX*16 array, dimension */
/* (1+(N-1)*abs(INCX)) */
/* On entry, the vector of length N to be conjugated. */
/* On exit, X is overwritten with conjg(X). */
/* INCX (input) INTEGER */
/* The spacing between successive elements of X. */
/* ===================================================================== */
/* Parameter adjustments */
--x;
/* Function Body */
if (*incx == 1) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
d_cnjg(&z__1, &x[i__]);
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
}
} else {
ioff = 1;
if (*incx < 0) {
ioff = 1 - (*n - 1) * *incx;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = ioff;
d_cnjg(&z__1, &x[ioff]);
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
ioff += *incx;
}
}
return 0;
/* End of ZLACGV */
} /* zlacgv_ */
/* Subroutine */ int zgeqr2_(integer *m, integer *n, doublecomplex *a,
integer *lda, doublecomplex *tau, doublecomplex *work, 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
=======
ZGEQR2 computes a QR factorization of a complex m by n matrix A:
A = Q * R.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0.
A (input/output) COMPLEX*16 array, dimension (LDA,N)
On entry, the m by n matrix A.
On exit, the elements on and above the diagonal of the array
contain the min(m,n) by n upper trapezoidal matrix R (R is
upper triangular if m >= n); the elements below the diagonal,
with the array TAU, represent the unitary matrix Q as a
product of elementary reflectors (see Further Details).
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
TAU (output) COMPLEX*16 array, dimension (min(M,N))
The scalar factors of the elementary reflectors (see Further
Details).
WORK (workspace) COMPLEX*16 array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Further Details
===============
The matrix Q is represented as a product of elementary reflectors
Q = H(1) H(2) . . . H(k), where k = min(m,n).
Each H(i) has the form
H(i) = I - tau * v * v'
where tau is a complex scalar, and v is a complex vector with
v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
and tau in TAU(i).
=====================================================================
Test the input arguments
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;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static integer i__, k;
static doublecomplex alpha;
extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *), xerbla_(char *, integer *), zlarfg_(integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *);
#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;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEQR2", &i__1);
return 0;
}
k = min(*m,*n);
i__1 = k;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector H(i) to annihilate A(i+1:m,i)
Computing MIN */
i__2 = i__ + 1;
i__3 = *m - i__ + 1;
zlarfg_(&i__3, &a_ref(i__, i__), &a_ref(min(i__2,*m), i__), &c__1, &
tau[i__]);
if (i__ < *n) {
/* Apply H(i)' to A(i:m,i+1:n) from the left */
i__2 = a_subscr(i__, i__);
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = a_subscr(i__, i__);
a[i__2].r = 1., a[i__2].i = 0.;
i__2 = *m - i__ + 1;
i__3 = *n - i__;
d_cnjg(&z__1, &tau[i__]);
zlarf_("Left", &i__2, &i__3, &a_ref(i__, i__), &c__1, &z__1, &
a_ref(i__, i__ + 1), lda, &work[1]);
i__2 = a_subscr(i__, i__);
a[i__2].r = alpha.r, a[i__2].i = alpha.i;
}
/* L10: */
}
return 0;
/* End of ZGEQR2 */
} /* zgeqr2_ */
/* 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 zhgeqz_(char *job, char *compq, char *compz, integer *n,
integer *ilo, integer *ihi, doublecomplex *a, integer *lda,
doublecomplex *b, integer *ldb, doublecomplex *alpha, doublecomplex *
beta, doublecomplex *q, integer *ldq, doublecomplex *z__, integer *
ldz, doublecomplex *work, integer *lwork, doublereal *rwork, integer *
info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
z_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
/* Builtin functions */
double z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
double d_imag(doublecomplex *);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *), pow_zi(
doublecomplex *, doublecomplex *, integer *), z_sqrt(
doublecomplex *, doublecomplex *);
/* Local variables */
static doublereal absb, atol, btol, temp, opst;
extern /* Subroutine */ int zrot_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublecomplex *);
static doublereal temp2, c__;
static integer j;
static doublecomplex s, t;
extern logical lsame_(char *, char *);
static doublecomplex ctemp;
static integer iiter, ilast, jiter;
static doublereal anorm;
static integer maxit;
static doublereal bnorm;
static doublecomplex shift;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
static doublereal tempr;
static doublecomplex ctemp2, ctemp3;
static logical ilazr2;
static integer jc, in;
static doublereal ascale, bscale;
static doublecomplex u12;
extern doublereal dlamch_(char *);
static integer jr, nq;
static doublecomplex signbc;
static integer nz;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublecomplex eshift;
static logical ilschr;
static integer icompq, ilastm;
static doublecomplex rtdisc;
static integer ischur;
extern doublereal zlanhs_(char *, integer *, doublecomplex *, integer *,
doublereal *);
static logical ilazro;
static integer icompz, ifirst;
extern /* Subroutine */ int zlartg_(doublecomplex *, doublecomplex *,
doublereal *, doublecomplex *, doublecomplex *);
static integer ifrstm;
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
static integer istart;
static logical lquery;
static doublecomplex ad11, ad12, ad21, ad22;
static integer jch;
static logical ilq, ilz;
static doublereal ulp;
static doublecomplex abi22;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1
#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]
#define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1
#define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)]
/* -- LAPACK routine (instrumented to count operations, version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
----------------------- Begin Timing Code ------------------------
Common block to return operation count and iteration count
ITCNT is initialized to 0, OPS is only incremented
OPST is used to accumulate small contributions to OPS
to avoid roundoff error
------------------------ End Timing Code -------------------------
Purpose
=======
ZHGEQZ implements a single-shift version of the QZ
method for finding the generalized eigenvalues w(i)=ALPHA(i)/BETA(i)
of the equation
det( A - w(i) B ) = 0
If JOB='S', then the pair (A,B) is simultaneously
reduced to Schur form (i.e., A and B are both upper triangular) by
applying one unitary tranformation (usually called Q) on the left and
another (usually called Z) on the right. The diagonal elements of
A are then ALPHA(1),...,ALPHA(N), and of B are BETA(1),...,BETA(N).
If JOB='S' and COMPQ and COMPZ are 'V' or 'I', then the unitary
transformations used to reduce (A,B) are accumulated into the arrays
Q and Z s.t.:
Q(in) A(in) Z(in)* = Q(out) A(out) Z(out)*
Q(in) B(in) Z(in)* = Q(out) B(out) Z(out)*
Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix
Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973),
pp. 241--256.
Arguments
=========
JOB (input) CHARACTER*1
= 'E': compute only ALPHA and BETA. A and B will not
necessarily be put into generalized Schur form.
= 'S': put A and B into generalized Schur form, as well
as computing ALPHA and BETA.
COMPQ (input) CHARACTER*1
= 'N': do not modify Q.
= 'V': multiply the array Q on the right by the conjugate
transpose of the unitary tranformation that is
applied to the left side of A and B to reduce them
to Schur form.
= 'I': like COMPQ='V', except that Q will be initialized to
the identity first.
COMPZ (input) CHARACTER*1
= 'N': do not modify Z.
= 'V': multiply the array Z on the right by the unitary
tranformation that is applied to the right side of
A and B to reduce them to Schur form.
= 'I': like COMPZ='V', except that Z will be initialized to
the identity first.
N (input) INTEGER
The order of the matrices A, B, Q, and Z. N >= 0.
ILO (input) INTEGER
IHI (input) INTEGER
It is assumed that A is already upper triangular in rows and
columns 1:ILO-1 and IHI+1:N.
1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
A (input/output) COMPLEX*16 array, dimension (LDA, N)
On entry, the N-by-N upper Hessenberg matrix A. Elements
below the subdiagonal must be zero.
If JOB='S', then on exit A and B will have been
simultaneously reduced to upper triangular form.
If JOB='E', then on exit A will have been destroyed.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max( 1, N ).
B (input/output) COMPLEX*16 array, dimension (LDB, N)
On entry, the N-by-N upper triangular matrix B. Elements
below the diagonal must be zero.
If JOB='S', then on exit A and B will have been
simultaneously reduced to upper triangular form.
If JOB='E', then on exit B will have been destroyed.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max( 1, N ).
ALPHA (output) COMPLEX*16 array, dimension (N)
The diagonal elements of A when the pair (A,B) has been
reduced to Schur form. ALPHA(i)/BETA(i) i=1,...,N
are the generalized eigenvalues.
BETA (output) COMPLEX*16 array, dimension (N)
The diagonal elements of B when the pair (A,B) has been
reduced to Schur form. ALPHA(i)/BETA(i) i=1,...,N
are the generalized eigenvalues. A and B are normalized
so that BETA(1),...,BETA(N) are non-negative real numbers.
Q (input/output) COMPLEX*16 array, dimension (LDQ, N)
If COMPQ='N', then Q will not be referenced.
If COMPQ='V' or 'I', then the conjugate transpose of the
unitary transformations which are applied to A and B on
the left will be applied to the array Q on the right.
LDQ (input) INTEGER
The leading dimension of the array Q. LDQ >= 1.
If COMPQ='V' or 'I', then LDQ >= N.
Z (input/output) COMPLEX*16 array, dimension (LDZ, N)
If COMPZ='N', then Z will not be referenced.
If COMPZ='V' or 'I', then the unitary transformations which
are applied to A and B on the right will be applied to the
array Z on the right.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1.
If COMPZ='V' or 'I', then LDZ >= N.
WORK (workspace/output) COMPLEX*16 array, dimension (LWORK)
On exit, if INFO >= 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= max(1,N).
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
= 1,...,N: the QZ iteration did not converge. (A,B) is not
in Schur form, but ALPHA(i) and BETA(i),
i=INFO+1,...,N should be correct.
= N+1,...,2*N: the shift calculation failed. (A,B) is not
in Schur form, but ALPHA(i) and BETA(i),
i=INFO-N+1,...,N should be correct.
> 2*N: various "impossible" errors.
Further Details
===============
We assume that complex ABS works as long as its value is less than
overflow.
=====================================================================
----------------------- Begin Timing Code ------------------------
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--alpha;
--beta;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
--rwork;
/* Function Body */
latime_1.itcnt = 0.;
/* ------------------------ End Timing Code -------------------------
Decode JOB, COMPQ, COMPZ */
if (lsame_(job, "E")) {
ilschr = FALSE_;
ischur = 1;
} else if (lsame_(job, "S")) {
ilschr = TRUE_;
ischur = 2;
} else {
ischur = 0;
}
if (lsame_(compq, "N")) {
ilq = FALSE_;
icompq = 1;
nq = 0;
} else if (lsame_(compq, "V")) {
ilq = TRUE_;
icompq = 2;
nq = *n;
} else if (lsame_(compq, "I")) {
ilq = TRUE_;
icompq = 3;
nq = *n;
} else {
icompq = 0;
}
if (lsame_(compz, "N")) {
ilz = FALSE_;
icompz = 1;
nz = 0;
} else if (lsame_(compz, "V")) {
ilz = TRUE_;
icompz = 2;
nz = *n;
} else if (lsame_(compz, "I")) {
ilz = TRUE_;
icompz = 3;
nz = *n;
} else {
icompz = 0;
}
/* Check Argument Values */
*info = 0;
i__1 = max(1,*n);
work[1].r = (doublereal) i__1, work[1].i = 0.;
lquery = *lwork == -1;
if (ischur == 0) {
*info = -1;
} else if (icompq == 0) {
*info = -2;
} else if (icompz == 0) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*ilo < 1) {
*info = -5;
} else if (*ihi > *n || *ihi < *ilo - 1) {
*info = -6;
} else if (*lda < *n) {
*info = -8;
} else if (*ldb < *n) {
*info = -10;
} else if (*ldq < 1 || ilq && *ldq < *n) {
*info = -14;
} else if (*ldz < 1 || ilz && *ldz < *n) {
*info = -16;
} else if (*lwork < max(1,*n) && ! lquery) {
*info = -18;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHGEQZ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible
WORK( 1 ) = CMPLX( 1 ) */
if (*n <= 0) {
work[1].r = 1., work[1].i = 0.;
return 0;
}
/* Initialize Q and Z */
if (icompq == 3) {
zlaset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq);
}
if (icompz == 3) {
zlaset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
}
/* Machine Constants */
in = *ihi + 1 - *ilo;
safmin = dlamch_("S");
ulp = dlamch_("E") * dlamch_("B");
anorm = zlanhs_("F", &in, &a_ref(*ilo, *ilo), lda, &rwork[1]);
bnorm = zlanhs_("F", &in, &b_ref(*ilo, *ilo), ldb, &rwork[1]);
/* Computing MAX */
d__1 = safmin, d__2 = ulp * anorm;
atol = max(d__1,d__2);
/* Computing MAX */
d__1 = safmin, d__2 = ulp * bnorm;
btol = max(d__1,d__2);
ascale = 1. / max(safmin,anorm);
bscale = 1. / max(safmin,bnorm);
/* ---------------------- Begin Timing Code -------------------------
Count ops for norms, etc. */
opst = 0.;
/* Computing 2nd power */
i__1 = *n;
latime_1.ops += (doublereal) ((i__1 * i__1 << 2) + *n * 12 - 5);
/* ----------------------- End Timing Code --------------------------
Set Eigenvalues IHI+1:N */
i__1 = *n;
for (j = *ihi + 1; j <= i__1; ++j) {
absb = z_abs(&b_ref(j, j));
if (absb > safmin) {
i__2 = b_subscr(j, j);
z__2.r = b[i__2].r / absb, z__2.i = b[i__2].i / absb;
d_cnjg(&z__1, &z__2);
signbc.r = z__1.r, signbc.i = z__1.i;
i__2 = b_subscr(j, j);
b[i__2].r = absb, b[i__2].i = 0.;
if (ilschr) {
i__2 = j - 1;
zscal_(&i__2, &signbc, &b_ref(1, j), &c__1);
zscal_(&j, &signbc, &a_ref(1, j), &c__1);
/* ----------------- Begin Timing Code --------------------- */
opst += (doublereal) ((j - 1) * 12);
/* ------------------ End Timing Code ---------------------- */
} else {
i__2 = a_subscr(j, j);
i__3 = a_subscr(j, j);
z__1.r = a[i__3].r * signbc.r - a[i__3].i * signbc.i, z__1.i =
a[i__3].r * signbc.i + a[i__3].i * signbc.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
if (ilz) {
zscal_(n, &signbc, &z___ref(1, j), &c__1);
}
/* ------------------- Begin Timing Code ---------------------- */
opst += (doublereal) (nz * 6 + 13);
/* -------------------- End Timing Code ----------------------- */
} else {
i__2 = b_subscr(j, j);
b[i__2].r = 0., b[i__2].i = 0.;
}
i__2 = j;
i__3 = a_subscr(j, j);
alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i;
i__2 = j;
i__3 = b_subscr(j, j);
beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i;
/* L10: */
}
/* If IHI < ILO, skip QZ steps */
if (*ihi < *ilo) {
goto L190;
}
/* MAIN QZ ITERATION LOOP
Initialize dynamic indices
Eigenvalues ILAST+1:N have been found.
Column operations modify rows IFRSTM:whatever
Row operations modify columns whatever:ILASTM
If only eigenvalues are being computed, then
IFRSTM is the row of the last splitting row above row ILAST;
this is always at least ILO.
IITER counts iterations since the last eigenvalue was found,
to tell when to use an extraordinary shift.
MAXIT is the maximum number of QZ sweeps allowed. */
ilast = *ihi;
if (ilschr) {
ifrstm = 1;
ilastm = *n;
} else {
ifrstm = *ilo;
ilastm = *ihi;
}
iiter = 0;
eshift.r = 0., eshift.i = 0.;
maxit = (*ihi - *ilo + 1) * 30;
i__1 = maxit;
for (jiter = 1; jiter <= i__1; ++jiter) {
/* Check for too many iterations. */
if (jiter > maxit) {
goto L180;
}
/* Split the matrix if possible.
Two tests:
1: A(j,j-1)=0 or j=ILO
2: B(j,j)=0
Special case: j=ILAST */
if (ilast == *ilo) {
goto L60;
} else {
i__2 = a_subscr(ilast, ilast - 1);
if ((d__1 = a[i__2].r, abs(d__1)) + (d__2 = d_imag(&a_ref(ilast,
ilast - 1)), abs(d__2)) <= atol) {
i__2 = a_subscr(ilast, ilast - 1);
a[i__2].r = 0., a[i__2].i = 0.;
goto L60;
}
}
if (z_abs(&b_ref(ilast, ilast)) <= btol) {
i__2 = b_subscr(ilast, ilast);
b[i__2].r = 0., b[i__2].i = 0.;
goto L50;
}
/* General case: j<ILAST */
i__2 = *ilo;
for (j = ilast - 1; j >= i__2; --j) {
/* Test 1: for A(j,j-1)=0 or j=ILO */
if (j == *ilo) {
ilazro = TRUE_;
} else {
i__3 = a_subscr(j, j - 1);
if ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a_ref(j,
j - 1)), abs(d__2)) <= atol) {
i__3 = a_subscr(j, j - 1);
a[i__3].r = 0., a[i__3].i = 0.;
ilazro = TRUE_;
} else {
ilazro = FALSE_;
}
}
/* Test 2: for B(j,j)=0 */
if (z_abs(&b_ref(j, j)) < btol) {
i__3 = b_subscr(j, j);
b[i__3].r = 0., b[i__3].i = 0.;
/* Test 1a: Check for 2 consecutive small subdiagonals in A */
ilazr2 = FALSE_;
if (! ilazro) {
i__3 = a_subscr(j, j - 1);
i__4 = a_subscr(j + 1, j);
i__5 = a_subscr(j, j);
if (((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&
a_ref(j, j - 1)), abs(d__2))) * (ascale * ((d__3 =
a[i__4].r, abs(d__3)) + (d__4 = d_imag(&a_ref(j
+ 1, j)), abs(d__4)))) <= ((d__5 = a[i__5].r, abs(
d__5)) + (d__6 = d_imag(&a_ref(j, j)), abs(d__6)))
* (ascale * atol)) {
ilazr2 = TRUE_;
}
}
/* If both tests pass (1 & 2), i.e., the leading diagonal
element of B in the block is zero, split a 1x1 block off
at the top. (I.e., at the J-th row/column) The leading
diagonal element of the remainder can also be zero, so
this may have to be done repeatedly. */
if (ilazro || ilazr2) {
i__3 = ilast - 1;
for (jch = j; jch <= i__3; ++jch) {
i__4 = a_subscr(jch, jch);
ctemp.r = a[i__4].r, ctemp.i = a[i__4].i;
zlartg_(&ctemp, &a_ref(jch + 1, jch), &c__, &s, &
a_ref(jch, jch));
i__4 = a_subscr(jch + 1, jch);
a[i__4].r = 0., a[i__4].i = 0.;
i__4 = ilastm - jch;
zrot_(&i__4, &a_ref(jch, jch + 1), lda, &a_ref(jch +
1, jch + 1), lda, &c__, &s);
i__4 = ilastm - jch;
zrot_(&i__4, &b_ref(jch, jch + 1), ldb, &b_ref(jch +
1, jch + 1), ldb, &c__, &s);
if (ilq) {
d_cnjg(&z__1, &s);
zrot_(n, &q_ref(1, jch), &c__1, &q_ref(1, jch + 1)
, &c__1, &c__, &z__1);
}
if (ilazr2) {
i__4 = a_subscr(jch, jch - 1);
i__5 = a_subscr(jch, jch - 1);
z__1.r = c__ * a[i__5].r, z__1.i = c__ * a[i__5]
.i;
a[i__4].r = z__1.r, a[i__4].i = z__1.i;
}
ilazr2 = FALSE_;
/* --------------- Begin Timing Code ----------------- */
opst += (doublereal) ((ilastm - jch) * 40 + 32 + nq *
20);
/* ---------------- End Timing Code ------------------ */
i__4 = b_subscr(jch + 1, jch + 1);
if ((d__1 = b[i__4].r, abs(d__1)) + (d__2 = d_imag(&
b_ref(jch + 1, jch + 1)), abs(d__2)) >= btol)
{
if (jch + 1 >= ilast) {
goto L60;
} else {
ifirst = jch + 1;
goto L70;
}
}
i__4 = b_subscr(jch + 1, jch + 1);
b[i__4].r = 0., b[i__4].i = 0.;
/* L20: */
}
goto L50;
} else {
/* Only test 2 passed -- chase the zero to B(ILAST,ILAST)
Then process as in the case B(ILAST,ILAST)=0 */
i__3 = ilast - 1;
for (jch = j; jch <= i__3; ++jch) {
i__4 = b_subscr(jch, jch + 1);
ctemp.r = b[i__4].r, ctemp.i = b[i__4].i;
zlartg_(&ctemp, &b_ref(jch + 1, jch + 1), &c__, &s, &
b_ref(jch, jch + 1));
i__4 = b_subscr(jch + 1, jch + 1);
b[i__4].r = 0., b[i__4].i = 0.;
if (jch < ilastm - 1) {
i__4 = ilastm - jch - 1;
zrot_(&i__4, &b_ref(jch, jch + 2), ldb, &b_ref(
jch + 1, jch + 2), ldb, &c__, &s);
}
i__4 = ilastm - jch + 2;
zrot_(&i__4, &a_ref(jch, jch - 1), lda, &a_ref(jch +
1, jch - 1), lda, &c__, &s);
if (ilq) {
d_cnjg(&z__1, &s);
zrot_(n, &q_ref(1, jch), &c__1, &q_ref(1, jch + 1)
, &c__1, &c__, &z__1);
}
i__4 = a_subscr(jch + 1, jch);
ctemp.r = a[i__4].r, ctemp.i = a[i__4].i;
zlartg_(&ctemp, &a_ref(jch + 1, jch - 1), &c__, &s, &
a_ref(jch + 1, jch));
i__4 = a_subscr(jch + 1, jch - 1);
a[i__4].r = 0., a[i__4].i = 0.;
i__4 = jch + 1 - ifrstm;
zrot_(&i__4, &a_ref(ifrstm, jch), &c__1, &a_ref(
ifrstm, jch - 1), &c__1, &c__, &s);
i__4 = jch - ifrstm;
zrot_(&i__4, &b_ref(ifrstm, jch), &c__1, &b_ref(
ifrstm, jch - 1), &c__1, &c__, &s);
if (ilz) {
zrot_(n, &z___ref(1, jch), &c__1, &z___ref(1, jch
- 1), &c__1, &c__, &s);
}
/* L30: */
}
/* ---------------- Begin Timing Code ------------------- */
opst += (doublereal) ((ilastm + 1 - ifrstm) * 40 + 64 + (
nq + nz) * 20) * (doublereal) (ilast - j);
/* ----------------- End Timing Code -------------------- */
goto L50;
}
} else if (ilazro) {
/* Only test 1 passed -- work on J:ILAST */
ifirst = j;
goto L70;
}
/* Neither test passed -- try next J
L40: */
}
/* (Drop-through is "impossible") */
*info = (*n << 1) + 1;
goto L210;
/* B(ILAST,ILAST)=0 -- clear A(ILAST,ILAST-1) to split off a
1x1 block. */
L50:
i__2 = a_subscr(ilast, ilast);
ctemp.r = a[i__2].r, ctemp.i = a[i__2].i;
zlartg_(&ctemp, &a_ref(ilast, ilast - 1), &c__, &s, &a_ref(ilast,
ilast));
i__2 = a_subscr(ilast, ilast - 1);
a[i__2].r = 0., a[i__2].i = 0.;
i__2 = ilast - ifrstm;
zrot_(&i__2, &a_ref(ifrstm, ilast), &c__1, &a_ref(ifrstm, ilast - 1),
&c__1, &c__, &s);
i__2 = ilast - ifrstm;
zrot_(&i__2, &b_ref(ifrstm, ilast), &c__1, &b_ref(ifrstm, ilast - 1),
&c__1, &c__, &s);
if (ilz) {
zrot_(n, &z___ref(1, ilast), &c__1, &z___ref(1, ilast - 1), &c__1,
&c__, &s);
}
/* --------------------- Begin Timing Code ----------------------- */
opst += (doublereal) ((ilast - ifrstm) * 40 + 32 + nz * 20);
/* ---------------------- End Timing Code ------------------------
A(ILAST,ILAST-1)=0 -- Standardize B, set ALPHA and BETA */
L60:
absb = z_abs(&b_ref(ilast, ilast));
if (absb > safmin) {
i__2 = b_subscr(ilast, ilast);
z__2.r = b[i__2].r / absb, z__2.i = b[i__2].i / absb;
d_cnjg(&z__1, &z__2);
signbc.r = z__1.r, signbc.i = z__1.i;
i__2 = b_subscr(ilast, ilast);
b[i__2].r = absb, b[i__2].i = 0.;
if (ilschr) {
i__2 = ilast - ifrstm;
zscal_(&i__2, &signbc, &b_ref(ifrstm, ilast), &c__1);
i__2 = ilast + 1 - ifrstm;
zscal_(&i__2, &signbc, &a_ref(ifrstm, ilast), &c__1);
/* ----------------- Begin Timing Code --------------------- */
opst += (doublereal) ((ilast - ifrstm) * 12);
/* ------------------ End Timing Code ---------------------- */
} else {
i__2 = a_subscr(ilast, ilast);
i__3 = a_subscr(ilast, ilast);
z__1.r = a[i__3].r * signbc.r - a[i__3].i * signbc.i, z__1.i =
a[i__3].r * signbc.i + a[i__3].i * signbc.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
if (ilz) {
zscal_(n, &signbc, &z___ref(1, ilast), &c__1);
}
/* ------------------- Begin Timing Code ---------------------- */
opst += (doublereal) (nz * 6 + 13);
/* -------------------- End Timing Code ----------------------- */
} else {
i__2 = b_subscr(ilast, ilast);
b[i__2].r = 0., b[i__2].i = 0.;
}
i__2 = ilast;
i__3 = a_subscr(ilast, ilast);
alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i;
i__2 = ilast;
i__3 = b_subscr(ilast, ilast);
beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i;
/* Go to next block -- exit if finished. */
--ilast;
if (ilast < *ilo) {
goto L190;
}
/* Reset counters */
iiter = 0;
eshift.r = 0., eshift.i = 0.;
if (! ilschr) {
ilastm = ilast;
if (ifrstm > ilast) {
ifrstm = *ilo;
}
}
goto L160;
/* QZ step
This iteration only involves rows/columns IFIRST:ILAST. We
assume IFIRST < ILAST, and that the diagonal of B is non-zero. */
L70:
++iiter;
if (! ilschr) {
ifrstm = ifirst;
}
/* Compute the Shift.
At this point, IFIRST < ILAST, and the diagonal elements of
B(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in
magnitude) */
if (iiter / 10 * 10 != iiter) {
/* The Wilkinson shift (AEP p.512), i.e., the eigenvalue of
the bottom-right 2x2 block of A inv(B) which is nearest to
the bottom-right element.
We factor B as U*D, where U has unit diagonals, and
compute (A*inv(D))*inv(U). */
i__2 = b_subscr(ilast - 1, ilast);
z__2.r = bscale * b[i__2].r, z__2.i = bscale * b[i__2].i;
i__3 = b_subscr(ilast, ilast);
z__3.r = bscale * b[i__3].r, z__3.i = bscale * b[i__3].i;
z_div(&z__1, &z__2, &z__3);
u12.r = z__1.r, u12.i = z__1.i;
i__2 = a_subscr(ilast - 1, ilast - 1);
z__2.r = ascale * a[i__2].r, z__2.i = ascale * a[i__2].i;
i__3 = b_subscr(ilast - 1, ilast - 1);
z__3.r = bscale * b[i__3].r, z__3.i = bscale * b[i__3].i;
z_div(&z__1, &z__2, &z__3);
ad11.r = z__1.r, ad11.i = z__1.i;
i__2 = a_subscr(ilast, ilast - 1);
z__2.r = ascale * a[i__2].r, z__2.i = ascale * a[i__2].i;
i__3 = b_subscr(ilast - 1, ilast - 1);
z__3.r = bscale * b[i__3].r, z__3.i = bscale * b[i__3].i;
z_div(&z__1, &z__2, &z__3);
ad21.r = z__1.r, ad21.i = z__1.i;
i__2 = a_subscr(ilast - 1, ilast);
z__2.r = ascale * a[i__2].r, z__2.i = ascale * a[i__2].i;
i__3 = b_subscr(ilast, ilast);
z__3.r = bscale * b[i__3].r, z__3.i = bscale * b[i__3].i;
z_div(&z__1, &z__2, &z__3);
ad12.r = z__1.r, ad12.i = z__1.i;
i__2 = a_subscr(ilast, ilast);
z__2.r = ascale * a[i__2].r, z__2.i = ascale * a[i__2].i;
i__3 = b_subscr(ilast, ilast);
z__3.r = bscale * b[i__3].r, z__3.i = bscale * b[i__3].i;
z_div(&z__1, &z__2, &z__3);
ad22.r = z__1.r, ad22.i = z__1.i;
z__2.r = u12.r * ad21.r - u12.i * ad21.i, z__2.i = u12.r * ad21.i
+ u12.i * ad21.r;
z__1.r = ad22.r - z__2.r, z__1.i = ad22.i - z__2.i;
abi22.r = z__1.r, abi22.i = z__1.i;
z__2.r = ad11.r + abi22.r, z__2.i = ad11.i + abi22.i;
z__1.r = z__2.r * .5, z__1.i = z__2.i * .5;
t.r = z__1.r, t.i = z__1.i;
pow_zi(&z__4, &t, &c__2);
z__5.r = ad12.r * ad21.r - ad12.i * ad21.i, z__5.i = ad12.r *
ad21.i + ad12.i * ad21.r;
z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
z__6.r = ad11.r * ad22.r - ad11.i * ad22.i, z__6.i = ad11.r *
ad22.i + ad11.i * ad22.r;
z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i;
z_sqrt(&z__1, &z__2);
rtdisc.r = z__1.r, rtdisc.i = z__1.i;
z__1.r = t.r - abi22.r, z__1.i = t.i - abi22.i;
z__2.r = t.r - abi22.r, z__2.i = t.i - abi22.i;
temp = z__1.r * rtdisc.r + d_imag(&z__2) * d_imag(&rtdisc);
if (temp <= 0.) {
z__1.r = t.r + rtdisc.r, z__1.i = t.i + rtdisc.i;
shift.r = z__1.r, shift.i = z__1.i;
} else {
z__1.r = t.r - rtdisc.r, z__1.i = t.i - rtdisc.i;
shift.r = z__1.r, shift.i = z__1.i;
}
/* ------------------- Begin Timing Code ---------------------- */
opst += 116.;
/* -------------------- End Timing Code ----------------------- */
} else {
/* Exceptional shift. Chosen for no particularly good reason. */
i__2 = a_subscr(ilast - 1, ilast);
z__4.r = ascale * a[i__2].r, z__4.i = ascale * a[i__2].i;
i__3 = b_subscr(ilast - 1, ilast - 1);
z__5.r = bscale * b[i__3].r, z__5.i = bscale * b[i__3].i;
z_div(&z__3, &z__4, &z__5);
d_cnjg(&z__2, &z__3);
z__1.r = eshift.r + z__2.r, z__1.i = eshift.i + z__2.i;
eshift.r = z__1.r, eshift.i = z__1.i;
shift.r = eshift.r, shift.i = eshift.i;
/* ------------------- Begin Timing Code ---------------------- */
opst += 15.;
/* -------------------- End Timing Code ----------------------- */
}
/* Now check for two consecutive small subdiagonals. */
i__2 = ifirst + 1;
for (j = ilast - 1; j >= i__2; --j) {
istart = j;
i__3 = a_subscr(j, j);
z__2.r = ascale * a[i__3].r, z__2.i = ascale * a[i__3].i;
i__4 = b_subscr(j, j);
z__4.r = bscale * b[i__4].r, z__4.i = bscale * b[i__4].i;
z__3.r = shift.r * z__4.r - shift.i * z__4.i, z__3.i = shift.r *
z__4.i + shift.i * z__4.r;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
temp = (d__1 = ctemp.r, abs(d__1)) + (d__2 = d_imag(&ctemp), abs(
d__2));
i__3 = a_subscr(j + 1, j);
temp2 = ascale * ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&
a_ref(j + 1, j)), abs(d__2)));
tempr = max(temp,temp2);
if (tempr < 1. && tempr != 0.) {
temp /= tempr;
temp2 /= tempr;
}
i__3 = a_subscr(j, j - 1);
if (((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a_ref(j, j -
1)), abs(d__2))) * temp2 <= temp * atol) {
goto L90;
}
/* L80: */
}
istart = ifirst;
i__2 = a_subscr(ifirst, ifirst);
z__2.r = ascale * a[i__2].r, z__2.i = ascale * a[i__2].i;
i__3 = b_subscr(ifirst, ifirst);
z__4.r = bscale * b[i__3].r, z__4.i = bscale * b[i__3].i;
z__3.r = shift.r * z__4.r - shift.i * z__4.i, z__3.i = shift.r *
z__4.i + shift.i * z__4.r;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
/* --------------------- Begin Timing Code ----------------------- */
opst += -6.;
/* ---------------------- End Timing Code ------------------------ */
L90:
/* Do an implicit-shift QZ sweep.
Initial Q */
i__2 = a_subscr(istart + 1, istart);
z__1.r = ascale * a[i__2].r, z__1.i = ascale * a[i__2].i;
ctemp2.r = z__1.r, ctemp2.i = z__1.i;
/* --------------------- Begin Timing Code ----------------------- */
opst += (doublereal) ((ilast - istart) * 18 + 2);
/* ---------------------- End Timing Code ------------------------ */
zlartg_(&ctemp, &ctemp2, &c__, &s, &ctemp3);
/* Sweep */
i__2 = ilast - 1;
for (j = istart; j <= i__2; ++j) {
if (j > istart) {
i__3 = a_subscr(j, j - 1);
ctemp.r = a[i__3].r, ctemp.i = a[i__3].i;
zlartg_(&ctemp, &a_ref(j + 1, j - 1), &c__, &s, &a_ref(j, j -
1));
i__3 = a_subscr(j + 1, j - 1);
a[i__3].r = 0., a[i__3].i = 0.;
}
i__3 = ilastm;
for (jc = j; jc <= i__3; ++jc) {
i__4 = a_subscr(j, jc);
z__2.r = c__ * a[i__4].r, z__2.i = c__ * a[i__4].i;
i__5 = a_subscr(j + 1, jc);
z__3.r = s.r * a[i__5].r - s.i * a[i__5].i, z__3.i = s.r * a[
i__5].i + s.i * a[i__5].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__4 = a_subscr(j + 1, jc);
d_cnjg(&z__4, &s);
z__3.r = -z__4.r, z__3.i = -z__4.i;
i__5 = a_subscr(j, jc);
z__2.r = z__3.r * a[i__5].r - z__3.i * a[i__5].i, z__2.i =
z__3.r * a[i__5].i + z__3.i * a[i__5].r;
i__6 = a_subscr(j + 1, jc);
z__5.r = c__ * a[i__6].r, z__5.i = c__ * a[i__6].i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
a[i__4].r = z__1.r, a[i__4].i = z__1.i;
i__4 = a_subscr(j, jc);
a[i__4].r = ctemp.r, a[i__4].i = ctemp.i;
i__4 = b_subscr(j, jc);
z__2.r = c__ * b[i__4].r, z__2.i = c__ * b[i__4].i;
i__5 = b_subscr(j + 1, jc);
z__3.r = s.r * b[i__5].r - s.i * b[i__5].i, z__3.i = s.r * b[
i__5].i + s.i * b[i__5].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
ctemp2.r = z__1.r, ctemp2.i = z__1.i;
i__4 = b_subscr(j + 1, jc);
d_cnjg(&z__4, &s);
z__3.r = -z__4.r, z__3.i = -z__4.i;
i__5 = b_subscr(j, jc);
z__2.r = z__3.r * b[i__5].r - z__3.i * b[i__5].i, z__2.i =
z__3.r * b[i__5].i + z__3.i * b[i__5].r;
i__6 = b_subscr(j + 1, jc);
z__5.r = c__ * b[i__6].r, z__5.i = c__ * b[i__6].i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
b[i__4].r = z__1.r, b[i__4].i = z__1.i;
i__4 = b_subscr(j, jc);
b[i__4].r = ctemp2.r, b[i__4].i = ctemp2.i;
/* L100: */
}
if (ilq) {
i__3 = *n;
for (jr = 1; jr <= i__3; ++jr) {
i__4 = q_subscr(jr, j);
z__2.r = c__ * q[i__4].r, z__2.i = c__ * q[i__4].i;
d_cnjg(&z__4, &s);
i__5 = q_subscr(jr, j + 1);
z__3.r = z__4.r * q[i__5].r - z__4.i * q[i__5].i, z__3.i =
z__4.r * q[i__5].i + z__4.i * q[i__5].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__4 = q_subscr(jr, j + 1);
z__3.r = -s.r, z__3.i = -s.i;
i__5 = q_subscr(jr, j);
z__2.r = z__3.r * q[i__5].r - z__3.i * q[i__5].i, z__2.i =
z__3.r * q[i__5].i + z__3.i * q[i__5].r;
i__6 = q_subscr(jr, j + 1);
z__4.r = c__ * q[i__6].r, z__4.i = c__ * q[i__6].i;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
q[i__4].r = z__1.r, q[i__4].i = z__1.i;
i__4 = q_subscr(jr, j);
q[i__4].r = ctemp.r, q[i__4].i = ctemp.i;
/* L110: */
}
}
i__3 = b_subscr(j + 1, j + 1);
ctemp.r = b[i__3].r, ctemp.i = b[i__3].i;
zlartg_(&ctemp, &b_ref(j + 1, j), &c__, &s, &b_ref(j + 1, j + 1));
i__3 = b_subscr(j + 1, j);
b[i__3].r = 0., b[i__3].i = 0.;
/* Computing MIN */
i__4 = j + 2;
i__3 = min(i__4,ilast);
for (jr = ifrstm; jr <= i__3; ++jr) {
i__4 = a_subscr(jr, j + 1);
z__2.r = c__ * a[i__4].r, z__2.i = c__ * a[i__4].i;
i__5 = a_subscr(jr, j);
z__3.r = s.r * a[i__5].r - s.i * a[i__5].i, z__3.i = s.r * a[
i__5].i + s.i * a[i__5].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__4 = a_subscr(jr, j);
d_cnjg(&z__4, &s);
z__3.r = -z__4.r, z__3.i = -z__4.i;
i__5 = a_subscr(jr, j + 1);
z__2.r = z__3.r * a[i__5].r - z__3.i * a[i__5].i, z__2.i =
z__3.r * a[i__5].i + z__3.i * a[i__5].r;
i__6 = a_subscr(jr, j);
z__5.r = c__ * a[i__6].r, z__5.i = c__ * a[i__6].i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
a[i__4].r = z__1.r, a[i__4].i = z__1.i;
i__4 = a_subscr(jr, j + 1);
a[i__4].r = ctemp.r, a[i__4].i = ctemp.i;
/* L120: */
}
i__3 = j;
for (jr = ifrstm; jr <= i__3; ++jr) {
i__4 = b_subscr(jr, j + 1);
z__2.r = c__ * b[i__4].r, z__2.i = c__ * b[i__4].i;
i__5 = b_subscr(jr, j);
z__3.r = s.r * b[i__5].r - s.i * b[i__5].i, z__3.i = s.r * b[
i__5].i + s.i * b[i__5].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__4 = b_subscr(jr, j);
d_cnjg(&z__4, &s);
z__3.r = -z__4.r, z__3.i = -z__4.i;
i__5 = b_subscr(jr, j + 1);
z__2.r = z__3.r * b[i__5].r - z__3.i * b[i__5].i, z__2.i =
z__3.r * b[i__5].i + z__3.i * b[i__5].r;
i__6 = b_subscr(jr, j);
z__5.r = c__ * b[i__6].r, z__5.i = c__ * b[i__6].i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
b[i__4].r = z__1.r, b[i__4].i = z__1.i;
i__4 = b_subscr(jr, j + 1);
b[i__4].r = ctemp.r, b[i__4].i = ctemp.i;
/* L130: */
}
if (ilz) {
i__3 = *n;
for (jr = 1; jr <= i__3; ++jr) {
i__4 = z___subscr(jr, j + 1);
z__2.r = c__ * z__[i__4].r, z__2.i = c__ * z__[i__4].i;
i__5 = z___subscr(jr, j);
z__3.r = s.r * z__[i__5].r - s.i * z__[i__5].i, z__3.i =
s.r * z__[i__5].i + s.i * z__[i__5].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__4 = z___subscr(jr, j);
d_cnjg(&z__4, &s);
z__3.r = -z__4.r, z__3.i = -z__4.i;
i__5 = z___subscr(jr, j + 1);
z__2.r = z__3.r * z__[i__5].r - z__3.i * z__[i__5].i,
z__2.i = z__3.r * z__[i__5].i + z__3.i * z__[i__5]
.r;
i__6 = z___subscr(jr, j);
z__5.r = c__ * z__[i__6].r, z__5.i = c__ * z__[i__6].i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
i__4 = z___subscr(jr, j + 1);
z__[i__4].r = ctemp.r, z__[i__4].i = ctemp.i;
/* L140: */
}
}
/* L150: */
}
/* --------------------- Begin Timing Code ----------------------- */
opst += (doublereal) (ilast - istart) * (doublereal) ((ilastm -
ifrstm) * 40 + 184 + (nq + nz) * 20) - 20;
/* ---------------------- End Timing Code ------------------------ */
L160:
/* --------------------- Begin Timing Code -----------------------
End of iteration -- add in "small" contributions. */
latime_1.ops += opst;
opst = 0.;
/* ---------------------- End Timing Code ------------------------
L170: */
}
/* Drop-through = non-convergence */
L180:
*info = ilast;
/* ---------------------- Begin Timing Code ------------------------- */
latime_1.ops += opst;
opst = 0.;
/* ----------------------- End Timing Code -------------------------- */
goto L210;
/* Successful completion of all QZ steps */
L190:
/* Set Eigenvalues 1:ILO-1 */
i__1 = *ilo - 1;
for (j = 1; j <= i__1; ++j) {
absb = z_abs(&b_ref(j, j));
if (absb > safmin) {
i__2 = b_subscr(j, j);
z__2.r = b[i__2].r / absb, z__2.i = b[i__2].i / absb;
d_cnjg(&z__1, &z__2);
signbc.r = z__1.r, signbc.i = z__1.i;
i__2 = b_subscr(j, j);
b[i__2].r = absb, b[i__2].i = 0.;
if (ilschr) {
i__2 = j - 1;
zscal_(&i__2, &signbc, &b_ref(1, j), &c__1);
zscal_(&j, &signbc, &a_ref(1, j), &c__1);
/* ----------------- Begin Timing Code --------------------- */
opst += (doublereal) ((j - 1) * 12);
/* ------------------ End Timing Code ---------------------- */
} else {
i__2 = a_subscr(j, j);
i__3 = a_subscr(j, j);
z__1.r = a[i__3].r * signbc.r - a[i__3].i * signbc.i, z__1.i =
a[i__3].r * signbc.i + a[i__3].i * signbc.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
if (ilz) {
zscal_(n, &signbc, &z___ref(1, j), &c__1);
}
/* ------------------- Begin Timing Code ---------------------- */
opst += (doublereal) (nz * 6 + 13);
/* -------------------- End Timing Code ----------------------- */
} else {
i__2 = b_subscr(j, j);
b[i__2].r = 0., b[i__2].i = 0.;
}
i__2 = j;
i__3 = a_subscr(j, j);
alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i;
i__2 = j;
i__3 = b_subscr(j, j);
beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i;
/* L200: */
}
/* Normal Termination */
*info = 0;
/* Exit (other than argument error) -- return optimal workspace size */
L210:
/* ---------------------- Begin Timing Code ------------------------- */
latime_1.ops += opst;
opst = 0.;
latime_1.itcnt = (doublereal) jiter;
/* ----------------------- End Timing Code -------------------------- */
z__1.r = (doublereal) (*n), z__1.i = 0.;
work[1].r = z__1.r, work[1].i = z__1.i;
return 0;
/* End of ZHGEQZ */
} /* zhgeqz_ */
/* Subroutine */ int ztgex2_(logical *wantq, logical *wantz, integer *n,
doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
doublecomplex *q, integer *ldq, doublecomplex *z__, integer *ldz,
integer *j1, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
z_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
double sqrt(doublereal), z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static doublecomplex f, g;
static integer i__, m;
static doublecomplex s[4] /* was [2][2] */, t[4] /* was [2][2] */;
static doublereal cq, sa, sb, cz;
static doublecomplex sq;
static doublereal ss, ws;
static doublecomplex sz;
static doublereal eps, sum;
static logical weak;
static doublecomplex cdum, work[8];
extern /* Subroutine */ int zrot_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublecomplex *);
static doublereal scale;
extern doublereal dlamch_(char *, ftnlen);
static logical dtrong;
static doublereal thresh;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen),
zlartg_(doublecomplex *, doublecomplex *, doublereal *,
doublecomplex *, doublecomplex *);
static doublereal smlnum;
extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
doublereal *, doublereal *);
/* -- LAPACK auxiliary routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZTGEX2 swaps adjacent diagonal 1 by 1 blocks (A11,B11) and (A22,B22) */
/* in an upper triangular matrix pair (A, B) by an unitary equivalence */
/* transformation. */
/* (A, B) must be in generalized Schur canonical form, that is, A and */
/* B are both upper triangular. */
/* Optionally, the matrices Q and Z of generalized Schur vectors are */
/* updated. */
/* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)' */
/* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)' */
/* Arguments */
/* ========= */
/* WANTQ (input) LOGICAL */
/* .TRUE. : update the left transformation matrix Q; */
/* .FALSE.: do not update Q. */
/* WANTZ (input) LOGICAL */
/* .TRUE. : update the right transformation matrix Z; */
/* .FALSE.: do not update Z. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* A (input/output) COMPLEX*16 arrays, dimensions (LDA,N) */
/* On entry, the matrix A in the pair (A, B). */
/* On exit, the updated matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input/output) COMPLEX*16 arrays, dimensions (LDB,N) */
/* On entry, the matrix B in the pair (A, B). */
/* On exit, the updated matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* Q (input/output) COMPLEX*16 array, dimension (LDZ,N) */
/* If WANTQ = .TRUE, on entry, the unitary matrix Q. On exit, */
/* the updated matrix Q. */
/* Not referenced if WANTQ = .FALSE.. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= 1; */
/* If WANTQ = .TRUE., LDQ >= N. */
/* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) */
/* If WANTZ = .TRUE, on entry, the unitary matrix Z. On exit, */
/* the updated matrix Z. */
/* Not referenced if WANTZ = .FALSE.. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1; */
/* If WANTZ = .TRUE., LDZ >= N. */
/* J1 (input) INTEGER */
/* The index to the first block (A11, B11). */
/* INFO (output) INTEGER */
/* =0: Successful exit. */
/* =1: The transformed matrix pair (A, B) would be too far */
/* from generalized Schur form; the problem is ill- */
/* conditioned. (A, B) may have been partially reordered, */
/* and ILST points to the first row of the current */
/* position of the block being moved. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* In the current code both weak and strong stability tests are */
/* performed. The user can omit the strong stability test by changing */
/* the internal logical parameter WANDS to .FALSE.. See ref. [2] for */
/* details. */
/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
/* Estimation: Theory, Algorithms and Software, Report UMINF-94.04, */
/* Department of Computing Science, Umea University, S-901 87 Umea, */
/* Sweden, 1994. Also as LAPACK Working Note 87. To appear in */
/* Numerical Algorithms, 1996. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n <= 1) {
return 0;
}
m = 2;
weak = FALSE_;
dtrong = FALSE_;
/* Make a local copy of selected block in (A, B) */
zlacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, s, &c__2, (ftnlen)4);
zlacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, t, &c__2, (ftnlen)4);
/* Compute the threshold for testing the acceptance of swapping. */
eps = dlamch_("P", (ftnlen)1);
smlnum = dlamch_("S", (ftnlen)1) / eps;
scale = 0.;
sum = 1.;
zlacpy_("Full", &m, &m, s, &c__2, work, &m, (ftnlen)4);
zlacpy_("Full", &m, &m, t, &c__2, &work[m * m], &m, (ftnlen)4);
i__1 = (m << 1) * m;
zlassq_(&i__1, work, &c__1, &scale, &sum);
sa = scale * sqrt(sum);
/* Computing MAX */
d__1 = eps * 10. * sa;
thresh = max(d__1,smlnum);
/* Compute unitary QL and RQ that swap 1-by-1 and 1-by-1 blocks */
/* using Givens rotations and perform the swap tentatively. */
z__2.r = s[3].r * t[0].r - s[3].i * t[0].i, z__2.i = s[3].r * t[0].i + s[
3].i * t[0].r;
z__3.r = t[3].r * s[0].r - t[3].i * s[0].i, z__3.i = t[3].r * s[0].i + t[
3].i * s[0].r;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
f.r = z__1.r, f.i = z__1.i;
z__2.r = s[3].r * t[2].r - s[3].i * t[2].i, z__2.i = s[3].r * t[2].i + s[
3].i * t[2].r;
z__3.r = t[3].r * s[2].r - t[3].i * s[2].i, z__3.i = t[3].r * s[2].i + t[
3].i * s[2].r;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
g.r = z__1.r, g.i = z__1.i;
sa = z_abs(&s[3]);
sb = z_abs(&t[3]);
zlartg_(&g, &f, &cz, &sz, &cdum);
z__1.r = -sz.r, z__1.i = -sz.i;
sz.r = z__1.r, sz.i = z__1.i;
d_cnjg(&z__1, &sz);
zrot_(&c__2, s, &c__1, &s[2], &c__1, &cz, &z__1);
d_cnjg(&z__1, &sz);
zrot_(&c__2, t, &c__1, &t[2], &c__1, &cz, &z__1);
if (sa >= sb) {
zlartg_(s, &s[1], &cq, &sq, &cdum);
} else {
zlartg_(t, &t[1], &cq, &sq, &cdum);
}
zrot_(&c__2, s, &c__2, &s[1], &c__2, &cq, &sq);
zrot_(&c__2, t, &c__2, &t[1], &c__2, &cq, &sq);
/* Weak stability test: |S21| + |T21| <= O(EPS F-norm((S, T))) */
ws = z_abs(&s[1]) + z_abs(&t[1]);
weak = ws <= thresh;
if (! weak) {
goto L20;
}
if (TRUE_) {
/* Strong stability test: */
/* F-norm((A-QL'*S*QR, B-QL'*T*QR)) <= O(EPS*F-norm((A, B))) */
zlacpy_("Full", &m, &m, s, &c__2, work, &m, (ftnlen)4);
zlacpy_("Full", &m, &m, t, &c__2, &work[m * m], &m, (ftnlen)4);
d_cnjg(&z__2, &sz);
z__1.r = -z__2.r, z__1.i = -z__2.i;
zrot_(&c__2, work, &c__1, &work[2], &c__1, &cz, &z__1);
d_cnjg(&z__2, &sz);
z__1.r = -z__2.r, z__1.i = -z__2.i;
zrot_(&c__2, &work[4], &c__1, &work[6], &c__1, &cz, &z__1);
z__1.r = -sq.r, z__1.i = -sq.i;
zrot_(&c__2, work, &c__2, &work[1], &c__2, &cq, &z__1);
z__1.r = -sq.r, z__1.i = -sq.i;
zrot_(&c__2, &work[4], &c__2, &work[5], &c__2, &cq, &z__1);
for (i__ = 1; i__ <= 2; ++i__) {
i__1 = i__ - 1;
i__2 = i__ - 1;
i__3 = *j1 + i__ - 1 + *j1 * a_dim1;
z__1.r = work[i__2].r - a[i__3].r, z__1.i = work[i__2].i - a[i__3]
.i;
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
i__1 = i__ + 1;
i__2 = i__ + 1;
i__3 = *j1 + i__ - 1 + (*j1 + 1) * a_dim1;
z__1.r = work[i__2].r - a[i__3].r, z__1.i = work[i__2].i - a[i__3]
.i;
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
i__1 = i__ + 3;
i__2 = i__ + 3;
i__3 = *j1 + i__ - 1 + *j1 * b_dim1;
z__1.r = work[i__2].r - b[i__3].r, z__1.i = work[i__2].i - b[i__3]
.i;
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
i__1 = i__ + 5;
i__2 = i__ + 5;
i__3 = *j1 + i__ - 1 + (*j1 + 1) * b_dim1;
z__1.r = work[i__2].r - b[i__3].r, z__1.i = work[i__2].i - b[i__3]
.i;
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
/* L10: */
}
scale = 0.;
sum = 1.;
i__1 = (m << 1) * m;
zlassq_(&i__1, work, &c__1, &scale, &sum);
ss = scale * sqrt(sum);
dtrong = ss <= thresh;
if (! dtrong) {
goto L20;
}
}
/* If the swap is accepted ("weakly" and "strongly"), apply the */
/* equivalence transformations to the original matrix pair (A,B) */
i__1 = *j1 + 1;
d_cnjg(&z__1, &sz);
zrot_(&i__1, &a[*j1 * a_dim1 + 1], &c__1, &a[(*j1 + 1) * a_dim1 + 1], &
c__1, &cz, &z__1);
i__1 = *j1 + 1;
d_cnjg(&z__1, &sz);
zrot_(&i__1, &b[*j1 * b_dim1 + 1], &c__1, &b[(*j1 + 1) * b_dim1 + 1], &
c__1, &cz, &z__1);
i__1 = *n - *j1 + 1;
zrot_(&i__1, &a[*j1 + *j1 * a_dim1], lda, &a[*j1 + 1 + *j1 * a_dim1], lda,
&cq, &sq);
i__1 = *n - *j1 + 1;
zrot_(&i__1, &b[*j1 + *j1 * b_dim1], ldb, &b[*j1 + 1 + *j1 * b_dim1], ldb,
&cq, &sq);
/* Set N1 by N2 (2,1) blocks to 0 */
i__1 = *j1 + 1 + *j1 * a_dim1;
a[i__1].r = 0., a[i__1].i = 0.;
i__1 = *j1 + 1 + *j1 * b_dim1;
b[i__1].r = 0., b[i__1].i = 0.;
/* Accumulate transformations into Q and Z if requested. */
if (*wantz) {
d_cnjg(&z__1, &sz);
zrot_(n, &z__[*j1 * z_dim1 + 1], &c__1, &z__[(*j1 + 1) * z_dim1 + 1],
&c__1, &cz, &z__1);
}
if (*wantq) {
d_cnjg(&z__1, &sq);
zrot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[(*j1 + 1) * q_dim1 + 1], &
c__1, &cq, &z__1);
}
/* Exit with INFO = 0 if swap was successfully performed. */
return 0;
/* Exit with INFO = 1 if swap was rejected. */
L20:
*info = 1;
return 0;
/* End of ZTGEX2 */
} /* ztgex2_ */
/* 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 zunml2_(char *side, char *trans, integer *m, integer *n,
integer *k, doublecomplex *a, integer *lda, doublecomplex *tau,
doublecomplex *c__, integer *ldc, doublecomplex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, i1, i2, i3, ic, jc, mi, ni, nq;
doublecomplex aii;
logical left;
doublecomplex taui;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *), xerbla_(char *, integer *), zlacgv_(integer *, doublecomplex *, integer *);
logical notran;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZUNML2 overwrites the general complex m-by-n matrix C with */
/* Q * C if SIDE = 'L' and TRANS = 'N', or */
/* Q'* C if SIDE = 'L' and TRANS = 'C', or */
/* C * Q if SIDE = 'R' and TRANS = 'N', or */
/* C * Q' if SIDE = 'R' and TRANS = 'C', */
/* where Q is a complex unitary matrix defined as the product of k */
/* elementary reflectors */
/* Q = H(k)' . . . H(2)' H(1)' */
/* as returned by ZGELQF. Q is of order m if SIDE = 'L' and of order n */
/* if SIDE = 'R'. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'L': apply Q or Q' from the Left */
/* = 'R': apply Q or Q' from the Right */
/* TRANS (input) CHARACTER*1 */
/* = 'N': apply Q (No transpose) */
/* = 'C': apply Q' (Conjugate transpose) */
/* M (input) INTEGER */
/* The number of rows of the matrix C. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix C. N >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines */
/* the matrix Q. */
/* If SIDE = 'L', M >= K >= 0; */
/* if SIDE = 'R', N >= K >= 0. */
/* A (input) COMPLEX*16 array, dimension */
/* (LDA,M) if SIDE = 'L', */
/* (LDA,N) if SIDE = 'R' */
/* The i-th row must contain the vector which defines the */
/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
/* ZGELQF in the first k rows of its array argument A. */
/* A is modified by the routine but restored on exit. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,K). */
/* TAU (input) COMPLEX*16 array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by ZGELQF. */
/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
/* On entry, the m-by-n matrix C. */
/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M). */
/* WORK (workspace) COMPLEX*16 array, dimension */
/* (N) if SIDE = 'L', */
/* (M) if SIDE = 'R' */
/* 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 .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = lsame_(side, "L");
notran = lsame_(trans, "N");
/* NQ is the order of Q */
if (left) {
nq = *m;
} else {
nq = *n;
}
if (! left && ! lsame_(side, "R")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "C")) {
*info = -2;
} else if (*m < 0) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*k < 0 || *k > nq) {
*info = -5;
} else if (*lda < max(1,*k)) {
*info = -7;
} else if (*ldc < max(1,*m)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZUNML2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0 || *k == 0) {
return 0;
}
if (left && notran || ! left && ! notran) {
i1 = 1;
i2 = *k;
i3 = 1;
} else {
i1 = *k;
i2 = 1;
i3 = -1;
}
if (left) {
ni = *n;
jc = 1;
} else {
mi = *m;
ic = 1;
}
i__1 = i2;
i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
if (left) {
/* H(i) or H(i)' is applied to C(i:m,1:n) */
mi = *m - i__ + 1;
ic = i__;
} else {
/* H(i) or H(i)' is applied to C(1:m,i:n) */
ni = *n - i__ + 1;
jc = i__;
}
/* Apply H(i) or H(i)' */
if (notran) {
d_cnjg(&z__1, &tau[i__]);
taui.r = z__1.r, taui.i = z__1.i;
} else {
i__3 = i__;
taui.r = tau[i__3].r, taui.i = tau[i__3].i;
}
if (i__ < nq) {
i__3 = nq - i__;
zlacgv_(&i__3, &a[i__ + (i__ + 1) * a_dim1], lda);
}
i__3 = i__ + i__ * a_dim1;
aii.r = a[i__3].r, aii.i = a[i__3].i;
i__3 = i__ + i__ * a_dim1;
a[i__3].r = 1., a[i__3].i = 0.;
zlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], lda, &taui, &c__[ic +
jc * c_dim1], ldc, &work[1]);
i__3 = i__ + i__ * a_dim1;
a[i__3].r = aii.r, a[i__3].i = aii.i;
if (i__ < nq) {
i__3 = nq - i__;
zlacgv_(&i__3, &a[i__ + (i__ + 1) * a_dim1], lda);
}
/* L10: */
}
return 0;
/* End of ZUNML2 */
} /* zunml2_ */
/* Subroutine */ int zpst01_(char *uplo, integer *n, doublecomplex *a,
integer *lda, doublecomplex *afac, integer *ldafac, doublecomplex *
perm, integer *ldperm, integer *piv, doublereal *rwork, doublereal *
resid, integer *rank)
{
/* System generated locals */
integer a_dim1, a_offset, afac_dim1, afac_offset, perm_dim1, perm_offset,
i__1, i__2, i__3, i__4, i__5;
doublereal d__1;
doublecomplex z__1;
/* Local variables */
integer i__, j, k;
doublecomplex tc;
doublereal tr, eps;
doublereal anorm;
/* -- LAPACK test routine (version 3.1) -- */
/* Craig Lucas, University of Manchester / NAG Ltd. */
/* October, 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZPST01 reconstructs an Hermitian positive semidefinite matrix A */
/* from its L or U factors and the permutation matrix P and computes */
/* the residual */
/* norm( P*L*L'*P' - A ) / ( N * norm(A) * EPS ) or */
/* norm( P*U'*U*P' - A ) / ( N * norm(A) * EPS ), */
/* where EPS is the machine epsilon, L' is the conjugate transpose of L, */
/* and U' is the conjugate transpose of U. */
/* Arguments */
/* ========== */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The number of rows and columns of the matrix A. N >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The original Hermitian matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N) */
/* AFAC (input) COMPLEX*16 array, dimension (LDAFAC,N) */
/* The factor L or U from the L*L' or U'*U */
/* factorization of A. */
/* LDAFAC (input) INTEGER */
/* The leading dimension of the array AFAC. LDAFAC >= max(1,N). */
/* PERM (output) COMPLEX*16 array, dimension (LDPERM,N) */
/* Overwritten with the reconstructed matrix, and then with the */
/* difference P*L*L'*P' - A (or P*U'*U*P' - A) */
/* LDPERM (input) INTEGER */
/* The leading dimension of the array PERM. */
/* LDAPERM >= max(1,N). */
/* PIV (input) INTEGER array, dimension (N) */
/* PIV is such that the nonzero entries are */
/* P( PIV( K ), K ) = 1. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* RESID (output) DOUBLE PRECISION */
/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
afac_dim1 = *ldafac;
afac_offset = 1 + afac_dim1;
afac -= afac_offset;
perm_dim1 = *ldperm;
perm_offset = 1 + perm_dim1;
perm -= perm_offset;
--piv;
--rwork;
/* Function Body */
if (*n <= 0) {
*resid = 0.;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = dlamch_("Epsilon");
anorm = zlanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
if (anorm <= 0.) {
*resid = 1. / eps;
return 0;
}
/* Check the imaginary parts of the diagonal elements and return with */
/* an error code if any are nonzero. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (d_imag(&afac[j + j * afac_dim1]) != 0.) {
*resid = 1. / eps;
return 0;
}
/* L100: */
}
/* Compute the product U'*U, overwriting U. */
if (lsame_(uplo, "U")) {
if (*rank < *n) {
i__1 = *n;
for (j = *rank + 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = *rank + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * afac_dim1;
afac[i__3].r = 0., afac[i__3].i = 0.;
/* L110: */
}
/* L120: */
}
}
for (k = *n; k >= 1; --k) {
/* Compute the (K,K) element of the result. */
zdotc_(&z__1, &k, &afac[k * afac_dim1 + 1], &c__1, &afac[k *
afac_dim1 + 1], &c__1);
tr = z__1.r;
i__1 = k + k * afac_dim1;
afac[i__1].r = tr, afac[i__1].i = 0.;
/* Compute the rest of column K. */
i__1 = k - 1;
ztrmv_("Upper", "Conjugate", "Non-unit", &i__1, &afac[afac_offset]
, ldafac, &afac[k * afac_dim1 + 1], &c__1);
/* L130: */
}
/* Compute the product L*L', overwriting L. */
} else {
if (*rank < *n) {
i__1 = *n;
for (j = *rank + 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = i__ + j * afac_dim1;
afac[i__3].r = 0., afac[i__3].i = 0.;
/* L140: */
}
/* L150: */
}
}
for (k = *n; k >= 1; --k) {
/* Add a multiple of column K of the factor L to each of */
/* columns K+1 through N. */
if (k + 1 <= *n) {
i__1 = *n - k;
zher_("Lower", &i__1, &c_b20, &afac[k + 1 + k * afac_dim1], &
c__1, &afac[k + 1 + (k + 1) * afac_dim1], ldafac);
}
/* Scale column K by the diagonal element. */
i__1 = k + k * afac_dim1;
tc.r = afac[i__1].r, tc.i = afac[i__1].i;
i__1 = *n - k + 1;
zscal_(&i__1, &tc, &afac[k + k * afac_dim1], &c__1);
/* L160: */
}
}
/* Form P*L*L'*P' or P*U'*U*P' */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (piv[i__] <= piv[j]) {
if (i__ <= j) {
i__3 = piv[i__] + piv[j] * perm_dim1;
i__4 = i__ + j * afac_dim1;
perm[i__3].r = afac[i__4].r, perm[i__3].i = afac[i__4]
.i;
} else {
i__3 = piv[i__] + piv[j] * perm_dim1;
d_cnjg(&z__1, &afac[j + i__ * afac_dim1]);
perm[i__3].r = z__1.r, perm[i__3].i = z__1.i;
}
}
/* L170: */
}
/* L180: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (piv[i__] >= piv[j]) {
if (i__ >= j) {
i__3 = piv[i__] + piv[j] * perm_dim1;
i__4 = i__ + j * afac_dim1;
perm[i__3].r = afac[i__4].r, perm[i__3].i = afac[i__4]
.i;
} else {
i__3 = piv[i__] + piv[j] * perm_dim1;
d_cnjg(&z__1, &afac[j + i__ * afac_dim1]);
perm[i__3].r = z__1.r, perm[i__3].i = z__1.i;
}
}
/* L190: */
}
/* L200: */
}
}
/* Compute the difference P*L*L'*P' - A (or P*U'*U*P' - A). */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * perm_dim1;
i__4 = i__ + j * perm_dim1;
i__5 = i__ + j * a_dim1;
z__1.r = perm[i__4].r - a[i__5].r, z__1.i = perm[i__4].i - a[
i__5].i;
perm[i__3].r = z__1.r, perm[i__3].i = z__1.i;
/* L210: */
}
i__2 = j + j * perm_dim1;
i__3 = j + j * perm_dim1;
i__4 = j + j * a_dim1;
d__1 = a[i__4].r;
z__1.r = perm[i__3].r - d__1, z__1.i = perm[i__3].i;
perm[i__2].r = z__1.r, perm[i__2].i = z__1.i;
/* L220: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j + j * perm_dim1;
i__3 = j + j * perm_dim1;
i__4 = j + j * a_dim1;
d__1 = a[i__4].r;
z__1.r = perm[i__3].r - d__1, z__1.i = perm[i__3].i;
perm[i__2].r = z__1.r, perm[i__2].i = z__1.i;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * perm_dim1;
i__4 = i__ + j * perm_dim1;
i__5 = i__ + j * a_dim1;
z__1.r = perm[i__4].r - a[i__5].r, z__1.i = perm[i__4].i - a[
i__5].i;
perm[i__3].r = z__1.r, perm[i__3].i = z__1.i;
/* L230: */
}
/* L240: */
}
}
/* Compute norm( P*L*L'P - A ) / ( N * norm(A) * EPS ), or */
/* ( P*U'*U*P' - A )/ ( N * norm(A) * EPS ). */
*resid = zlanhe_("1", uplo, n, &perm[perm_offset], ldafac, &rwork[1]);
*resid = *resid / (doublereal) (*n) / anorm / eps;
return 0;
/* End of ZPST01 */
} /* zpst01_ */
/* Subroutine */ int zlaror_slu(char *side, char *init, integer *m, integer *n,
doublecomplex *a, integer *lda, integer *iseed, doublecomplex *x,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublecomplex z__1, z__2;
/* Builtin functions */
double z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static integer kbeg, jcol;
static doublereal xabs;
static integer irow, j;
static doublecomplex csign;
extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
static integer ixfrm;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static integer itype, nxfrm;
static doublereal xnorm;
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
extern int input_error(char *, int *);
static doublereal factor;
extern /* Subroutine */ int zlacgv_slu(integer *, doublecomplex *, integer *)
;
extern /* Double Complex */ VOID zlarnd_slu(doublecomplex *, integer *,
integer *);
extern /* Subroutine */ int zlaset_slu(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
static doublecomplex xnorms;
/* -- LAPACK auxiliary test routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZLAROR pre- or post-multiplies an M by N matrix A by a random
unitary matrix U, overwriting A. A may optionally be
initialized to the identity matrix before multiplying by U.
U is generated using the method of G.W. Stewart
( SIAM J. Numer. Anal. 17, 1980, pp. 403-409 ).
(BLAS-2 version)
Arguments
=========
SIDE - CHARACTER*1
SIDE specifies whether A is multiplied on the left or right
by U.
SIDE = 'L' Multiply A on the left (premultiply) by U
SIDE = 'R' Multiply A on the right (postmultiply) by U*
SIDE = 'C' Multiply A on the left by U and the right by U*
SIDE = 'T' Multiply A on the left by U and the right by U'
Not modified.
INIT - CHARACTER*1
INIT specifies whether or not A should be initialized to
the identity matrix.
INIT = 'I' Initialize A to (a section of) the
identity matrix before applying U.
INIT = 'N' No initialization. Apply U to the
input matrix A.
INIT = 'I' may be used to generate square (i.e., unitary)
or rectangular orthogonal matrices (orthogonality being
in the sense of ZDOTC):
For square matrices, M=N, and SIDE many be either 'L' or
'R'; the rows will be orthogonal to each other, as will the
columns.
For rectangular matrices where M < N, SIDE = 'R' will
produce a dense matrix whose rows will be orthogonal and
whose columns will not, while SIDE = 'L' will produce a
matrix whose rows will be orthogonal, and whose first M
columns will be orthogonal, the remaining columns being
zero.
For matrices where M > N, just use the previous
explaination, interchanging 'L' and 'R' and "rows" and
"columns".
Not modified.
M - INTEGER
Number of rows of A. Not modified.
N - INTEGER
Number of columns of A. Not modified.
A - COMPLEX*16 array, dimension ( LDA, N )
Input and output array. Overwritten by U A ( if SIDE = 'L' )
or by A U ( if SIDE = 'R' )
or by U A U* ( if SIDE = 'C')
or by U A U' ( if SIDE = 'T') on exit.
LDA - INTEGER
Leading dimension of A. Must be at least MAX ( 1, M ).
Not modified.
ISEED - INTEGER array, dimension ( 4 )
On entry ISEED specifies the seed of the random number
generator. The array elements should be between 0 and 4095;
if not they will be reduced mod 4096. Also, ISEED(4) must
be odd. The random number generator uses a linear
congruential sequence limited to small integers, and so
should produce machine independent random numbers. The
values of ISEED are changed on exit, and can be used in the
next call to ZLAROR to continue the same random number
sequence.
Modified.
X - COMPLEX*16 array, dimension ( 3*MAX( M, N ) )
Workspace. Of length:
2*M + N if SIDE = 'L',
2*N + M if SIDE = 'R',
3*N if SIDE = 'C' or 'T'.
Modified.
INFO - INTEGER
An error flag. It is set to:
0 if no error.
1 if ZLARND returned a bad random number (installation
problem)
-1 if SIDE is not L, R, C, or T.
-3 if M is negative.
-4 if N is negative or if SIDE is C or T and N is not equal
to M.
-6 if LDA is less than M.
=====================================================================
Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--iseed;
--x;
/* Function Body */
if (*n == 0 || *m == 0) {
return 0;
}
itype = 0;
if (strncmp(side, "L", 1)==0) {
itype = 1;
} else if (strncmp(side, "R", 1)==0) {
itype = 2;
} else if (strncmp(side, "C", 1)==0) {
itype = 3;
} else if (strncmp(side, "T", 1)==0) {
itype = 4;
}
/* Check for argument errors. */
*info = 0;
if (itype == 0) {
*info = -1;
} else if (*m < 0) {
*info = -3;
} else if (*n < 0 || itype == 3 && *n != *m) {
*info = -4;
} else if (*lda < *m) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
input_error("ZLAROR", &i__1);
return 0;
}
if (itype == 1) {
nxfrm = *m;
} else {
nxfrm = *n;
}
/* Initialize A to the identity matrix if desired */
if (strncmp(init, "I", 1)==0) {
zlaset_slu("Full", m, n, &c_b1, &c_b2, &a[a_offset], lda);
}
/* If no rotation possible, still multiply by
a random complex number from the circle |x| = 1
2) Compute Rotation by computing Householder
Transformations H(2), H(3), ..., H(n). Note that the
order in which they are computed is irrelevant. */
i__1 = nxfrm;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
x[i__2].r = 0., x[i__2].i = 0.;
/* L10: */
}
i__1 = nxfrm;
for (ixfrm = 2; ixfrm <= i__1; ++ixfrm) {
kbeg = nxfrm - ixfrm + 1;
/* Generate independent normal( 0, 1 ) random numbers */
i__2 = nxfrm;
for (j = kbeg; j <= i__2; ++j) {
i__3 = j;
zlarnd_slu(&z__1, &c__3, &iseed[1]);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
/* L20: */
}
/* Generate a Householder transformation from the random vector
X */
xnorm = dznrm2_(&ixfrm, &x[kbeg], &c__1);
xabs = z_abs(&x[kbeg]);
if (xabs != 0.) {
i__2 = kbeg;
z__1.r = x[i__2].r / xabs, z__1.i = x[i__2].i / xabs;
csign.r = z__1.r, csign.i = z__1.i;
} else {
csign.r = 1., csign.i = 0.;
}
z__1.r = xnorm * csign.r, z__1.i = xnorm * csign.i;
xnorms.r = z__1.r, xnorms.i = z__1.i;
i__2 = nxfrm + kbeg;
z__1.r = -csign.r, z__1.i = -csign.i;
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
factor = xnorm * (xnorm + xabs);
if (abs(factor) < 1e-20) {
*info = 1;
i__2 = -(*info);
input_error("ZLAROR", &i__2);
return 0;
} else {
factor = 1. / factor;
}
i__2 = kbeg;
i__3 = kbeg;
z__1.r = x[i__3].r + xnorms.r, z__1.i = x[i__3].i + xnorms.i;
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
/* Apply Householder transformation to A */
if (itype == 1 || itype == 3 || itype == 4) {
/* Apply H(k) on the left of A */
zgemv_("C", &ixfrm, n, &c_b2, &a[kbeg + a_dim1], lda, &x[kbeg], &
c__1, &c_b1, &x[(nxfrm << 1) + 1], &c__1);
z__2.r = factor, z__2.i = 0.;
z__1.r = -z__2.r, z__1.i = -z__2.i;
zgerc_(&ixfrm, n, &z__1, &x[kbeg], &c__1, &x[(nxfrm << 1) + 1], &
c__1, &a[kbeg + a_dim1], lda);
}
if (itype >= 2 && itype <= 4) {
/* Apply H(k)* (or H(k)') on the right of A */
if (itype == 4) {
zlacgv_slu(&ixfrm, &x[kbeg], &c__1);
}
zgemv_("N", m, &ixfrm, &c_b2, &a[kbeg * a_dim1 + 1], lda, &x[kbeg]
, &c__1, &c_b1, &x[(nxfrm << 1) + 1], &c__1);
z__2.r = factor, z__2.i = 0.;
z__1.r = -z__2.r, z__1.i = -z__2.i;
zgerc_(m, &ixfrm, &z__1, &x[(nxfrm << 1) + 1], &c__1, &x[kbeg], &
c__1, &a[kbeg * a_dim1 + 1], lda);
}
/* L30: */
}
zlarnd_slu(&z__1, &c__3, &iseed[1]);
x[1].r = z__1.r, x[1].i = z__1.i;
xabs = z_abs(&x[1]);
if (xabs != 0.) {
z__1.r = x[1].r / xabs, z__1.i = x[1].i / xabs;
csign.r = z__1.r, csign.i = z__1.i;
} else {
csign.r = 1., csign.i = 0.;
}
i__1 = nxfrm << 1;
x[i__1].r = csign.r, x[i__1].i = csign.i;
/* Scale the matrix A by D. */
if (itype == 1 || itype == 3 || itype == 4) {
i__1 = *m;
for (irow = 1; irow <= i__1; ++irow) {
d_cnjg(&z__1, &x[nxfrm + irow]);
zscal_(n, &z__1, &a[irow + a_dim1], lda);
/* L40: */
}
}
if (itype == 2 || itype == 3) {
i__1 = *n;
for (jcol = 1; jcol <= i__1; ++jcol) {
zscal_(m, &x[nxfrm + jcol], &a[jcol * a_dim1 + 1], &c__1);
/* L50: */
}
}
if (itype == 4) {
i__1 = *n;
for (jcol = 1; jcol <= i__1; ++jcol) {
d_cnjg(&z__1, &x[nxfrm + jcol]);
zscal_(m, &z__1, &a[jcol * a_dim1 + 1], &c__1);
/* L60: */
}
}
return 0;
/* End of ZLAROR */
} /* zlaror_slu */
/* Subroutine */ int zgerc_(integer *m, integer *n, doublecomplex *alpha,
doublecomplex *x, integer *incx, doublecomplex *y, integer *incy,
doublecomplex *a, integer *lda)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
doublecomplex z__1, z__2;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static integer i__, j, ix, jy, kx, info;
static doublecomplex temp;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
/* .. Scalar Arguments .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGERC performs the rank 1 operation */
/* A := alpha*x*conjg( y' ) + A, */
/* where alpha is a scalar, x is an m element vector, y is an n element */
/* vector and A is an m by n matrix. */
/* Parameters */
/* ========== */
/* M - INTEGER. */
/* On entry, M specifies the number of rows of the matrix A. */
/* M must be at least zero. */
/* Unchanged on exit. */
/* N - INTEGER. */
/* On entry, N specifies the number of columns of the matrix A. */
/* N must be at least zero. */
/* Unchanged on exit. */
/* ALPHA - COMPLEX*16 . */
/* On entry, ALPHA specifies the scalar alpha. */
/* Unchanged on exit. */
/* X - COMPLEX*16 array of dimension at least */
/* ( 1 + ( m - 1 )*abs( INCX ) ). */
/* Before entry, the incremented array X must contain the m */
/* element vector x. */
/* Unchanged on exit. */
/* INCX - INTEGER. */
/* On entry, INCX specifies the increment for the elements of */
/* X. INCX must not be zero. */
/* Unchanged on exit. */
/* Y - COMPLEX*16 array of dimension at least */
/* ( 1 + ( n - 1 )*abs( INCY ) ). */
/* Before entry, the incremented array Y must contain the n */
/* element vector y. */
/* Unchanged on exit. */
/* INCY - INTEGER. */
/* On entry, INCY specifies the increment for the elements of */
/* Y. INCY must not be zero. */
/* Unchanged on exit. */
/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */
/* Before entry, the leading m by n part of the array A must */
/* contain the matrix of coefficients. On exit, A is */
/* overwritten by the updated matrix. */
/* LDA - INTEGER. */
/* On entry, LDA specifies the first dimension of A as declared */
/* in the calling (sub) program. LDA must be at least */
/* max( 1, m ). */
/* Unchanged on exit. */
/* Level 2 Blas routine. */
/* -- Written on 22-October-1986. */
/* Jack Dongarra, Argonne National Lab. */
/* Jeremy Du Croz, Nag Central Office. */
/* Sven Hammarling, Nag Central Office. */
/* Richard Hanson, Sandia National Labs. */
/* .. Parameters .. */
/* .. Local Scalars .. */
/* .. External Subroutines .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--x;
--y;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
info = 0;
if (*m < 0) {
info = 1;
} else if (*n < 0) {
info = 2;
} else if (*incx == 0) {
info = 5;
} else if (*incy == 0) {
info = 7;
} else if (*lda < max(1,*m)) {
info = 9;
}
if (info != 0) {
xerbla_("ZGERC ", &info, (ftnlen)6);
return 0;
}
/* Quick return if possible. */
if (*m == 0 || *n == 0 || alpha->r == 0. && alpha->i == 0.) {
return 0;
}
/* Start the operations. In this version the elements of A are */
/* accessed sequentially with one pass through A. */
if (*incy > 0) {
jy = 1;
} else {
jy = 1 - (*n - 1) * *incy;
}
if (*incx == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = jy;
if (y[i__2].r != 0. || y[i__2].i != 0.) {
d_cnjg(&z__2, &y[jy]);
z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i =
alpha->r * z__2.i + alpha->i * z__2.r;
temp.r = z__1.r, temp.i = z__1.i;
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
i__5 = i__;
z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, z__2.i =
x[i__5].r * temp.i + x[i__5].i * temp.r;
z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + z__2.i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L10: */
}
}
jy += *incy;
/* L20: */
}
} else {
if (*incx > 0) {
kx = 1;
} else {
kx = 1 - (*m - 1) * *incx;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = jy;
if (y[i__2].r != 0. || y[i__2].i != 0.) {
d_cnjg(&z__2, &y[jy]);
z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i =
alpha->r * z__2.i + alpha->i * z__2.r;
temp.r = z__1.r, temp.i = z__1.i;
ix = kx;
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
i__5 = ix;
z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, z__2.i =
x[i__5].r * temp.i + x[i__5].i * temp.r;
z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + z__2.i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
ix += *incx;
/* L30: */
}
}
jy += *incy;
/* L40: */
}
}
return 0;
/* End of ZGERC . */
} /* zgerc_ */