/* Subroutine */ int zchkgl_(integer *nin, integer *nout)
{
/* Format strings */
static char fmt_9999[] = "(\002 .. test output of ZGGBAL .. \002)";
static char fmt_9998[] = "(\002 ratio of largest test error "
" = \002,d12.3)";
static char fmt_9997[] = "(\002 example number where info is not zero "
" = \002,i4)";
static char fmt_9996[] = "(\002 example number where ILO or IHI is wrong"
" = \002,i4)";
static char fmt_9995[] = "(\002 example number having largest error "
" = \002,i4)";
static char fmt_9994[] = "(\002 number of examples where info is not 0 "
" = \002,i4)";
static char fmt_9993[] = "(\002 total number of examples tested "
" = \002,i4)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3;
doublecomplex z__1;
/* Builtin functions */
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
double z_abs(doublecomplex *);
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
/* Local variables */
static integer info, lmax[3];
static doublereal rmax, vmax, work[120];
static doublecomplex a[400] /* was [20][20] */, b[400] /* was [20][
20] */;
static integer i__, j, n, ihiin, ninfo, iloin;
static doublereal anorm, bnorm;
extern doublereal dlamch_(char *);
static doublereal lscale[20];
extern /* Subroutine */ int zggbal_(char *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *);
static doublereal rscale[20];
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
static doublereal lsclin[20], rsclin[20];
static doublecomplex ain[400] /* was [20][20] */, bin[400] /*
was [20][20] */;
static integer ihi, ilo;
static doublereal eps;
static integer knt;
/* Fortran I/O blocks */
static cilist io___6 = { 0, 0, 0, 0, 0 };
static cilist io___9 = { 0, 0, 0, 0, 0 };
static cilist io___12 = { 0, 0, 0, 0, 0 };
static cilist io___14 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___19 = { 0, 0, 0, 0, 0 };
static cilist io___21 = { 0, 0, 0, 0, 0 };
static cilist io___23 = { 0, 0, 0, 0, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9993, 0 };
#define a_subscr(a_1,a_2) (a_2)*20 + a_1 - 21
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*20 + a_1 - 21
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define ain_subscr(a_1,a_2) (a_2)*20 + a_1 - 21
#define ain_ref(a_1,a_2) ain[ain_subscr(a_1,a_2)]
#define bin_subscr(a_1,a_2) (a_2)*20 + a_1 - 21
#define bin_ref(a_1,a_2) bin[bin_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZCHKGL tests ZGGBAL, a routine for balancing a matrix pair (A, B).
Arguments
=========
NIN (input) INTEGER
The logical unit number for input. NIN > 0.
NOUT (input) INTEGER
The logical unit number for output. NOUT > 0.
===================================================================== */
lmax[0] = 0;
lmax[1] = 0;
lmax[2] = 0;
ninfo = 0;
knt = 0;
rmax = 0.;
eps = dlamch_("Precision");
L10:
io___6.ciunit = *nin;
s_rsle(&io___6);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
goto L90;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___9.ciunit = *nin;
s_rsle(&io___9);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&a_ref(i__, j), (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___12.ciunit = *nin;
s_rsle(&io___12);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&b_ref(i__, j), (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L30: */
}
io___14.ciunit = *nin;
s_rsle(&io___14);
do_lio(&c__3, &c__1, (char *)&iloin, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ihiin, (ftnlen)sizeof(integer));
e_rsle();
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___17.ciunit = *nin;
s_rsle(&io___17);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&ain_ref(i__, j), (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L40: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___19.ciunit = *nin;
s_rsle(&io___19);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&bin_ref(i__, j), (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L50: */
}
io___21.ciunit = *nin;
s_rsle(&io___21);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__5, &c__1, (char *)&lsclin[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_rsle();
io___23.ciunit = *nin;
s_rsle(&io___23);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__5, &c__1, (char *)&rsclin[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_rsle();
anorm = zlange_("M", &n, &n, a, &c__20, work);
bnorm = zlange_("M", &n, &n, b, &c__20, work);
++knt;
zggbal_("B", &n, a, &c__20, b, &c__20, &ilo, &ihi, lscale, rscale, work, &
info);
if (info != 0) {
++ninfo;
lmax[0] = knt;
}
if (ilo != iloin || ihi != ihiin) {
++ninfo;
lmax[1] = knt;
}
vmax = 0.;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
/* Computing MAX */
i__3 = a_subscr(i__, j);
i__4 = ain_subscr(i__, j);
z__1.r = a[i__3].r - ain[i__4].r, z__1.i = a[i__3].i - ain[i__4]
.i;
d__1 = vmax, d__2 = z_abs(&z__1);
vmax = max(d__1,d__2);
/* Computing MAX */
i__3 = b_subscr(i__, j);
i__4 = bin_subscr(i__, j);
z__1.r = b[i__3].r - bin[i__4].r, z__1.i = b[i__3].i - bin[i__4]
.i;
d__1 = vmax, d__2 = z_abs(&z__1);
vmax = max(d__1,d__2);
/* L60: */
}
/* L70: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = vmax, d__3 = (d__1 = lscale[i__ - 1] - lsclin[i__ - 1], abs(
d__1));
vmax = max(d__2,d__3);
/* Computing MAX */
d__2 = vmax, d__3 = (d__1 = rscale[i__ - 1] - rsclin[i__ - 1], abs(
d__1));
vmax = max(d__2,d__3);
/* L80: */
}
vmax /= eps * max(anorm,bnorm);
if (vmax > rmax) {
lmax[2] = knt;
rmax = vmax;
}
goto L10;
L90:
io___34.ciunit = *nout;
s_wsfe(&io___34);
e_wsfe();
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
e_wsfe();
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
e_wsfe();
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
e_wsfe();
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
e_wsfe();
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
e_wsfe();
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
e_wsfe();
return 0;
/* End of ZCHKGL */
} /* zchkgl_ */
/* Subroutine */ int zgerfs_(char *trans, integer *n, integer *nrhs,
doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf,
integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x,
integer *ldx, doublereal *ferr, doublereal *berr, 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
September 30, 1994
Purpose
=======
ZGERFS improves the computed solution to a system of linear
equations and provides error bounds and backward error estimates for
the solution.
Arguments
=========
TRANS (input) CHARACTER*1
Specifies the form of the system of equations:
= 'N': A * X = B (No transpose)
= 'T': A**T * X = B (Transpose)
= 'C': A**H * X = B (Conjugate transpose)
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 B and X. NRHS >= 0.
A (input) COMPLEX*16 array, dimension (LDA,N)
The original N-by-N matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
AF (input) COMPLEX*16 array, dimension (LDAF,N)
The factors L and U from the factorization A = P*L*U
as computed by ZGETRF.
LDAF (input) INTEGER
The leading dimension of the array AF. LDAF >= max(1,N).
IPIV (input) INTEGER array, dimension (N)
The pivot indices from ZGETRF; for 1<=i<=N, row i of the
matrix was interchanged with row IPIV(i).
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 ZGETRS.
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 estimated 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). The estimate is as reliable as
the estimate for RCOND, and is almost always a slight
overestimate of the true error.
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 (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
Internal Parameters
===================
ITMAX is the maximum number of steps of iterative refinement.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b1 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
x_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer kase;
static doublereal safe1, safe2;
static integer i__, j, k;
static doublereal s;
extern logical lsame_(char *, char *);
static integer count;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *),
zcopy_(integer *, doublecomplex *, integer *, doublecomplex *,
integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *);
extern doublereal dlamch_(char *);
static doublereal xk;
static integer nz;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *), zlacon_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *);
static logical notran;
static char transn[1], transt[1];
static doublereal lstres;
extern /* Subroutine */ int zgetrs_(char *, integer *, integer *,
doublecomplex *, integer *, integer *, doublecomplex *, integer *,
integer *);
static doublereal eps;
#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 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)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1 * 1;
af -= af_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
--ferr;
--berr;
--work;
--rwork;
/* Function Body */
*info = 0;
notran = lsame_(trans, "N");
if (! notran && ! lsame_(trans, "T") && ! lsame_(
trans, "C")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldaf < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -10;
} else if (*ldx < max(1,*n)) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGERFS", &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;
}
if (notran) {
*(unsigned char *)transn = 'N';
*(unsigned char *)transt = 'C';
} else {
*(unsigned char *)transn = 'C';
*(unsigned char *)transt = 'N';
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
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 - op(A) * X,
where op(A) = A, A**T, or A**H, depending on TRANS. */
zcopy_(n, &b_ref(1, j), &c__1, &work[1], &c__1);
z__1.r = -1., z__1.i = 0.;
zgemv_(trans, n, n, &z__1, &a[a_offset], lda, &x_ref(1, j), &c__1, &
c_b1, &work[1], &c__1);
/* Compute componentwise relative backward error from formula
max(i) ( abs(R(i)) / ( abs(op(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. */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&
b_ref(i__, j)), abs(d__2));
/* L30: */
}
/* Compute abs(op(A))*abs(X) + abs(B). */
if (notran) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = x_subscr(k, j);
xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x_ref(k,
j)), abs(d__2));
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = a_subscr(i__, k);
rwork[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
d_imag(&a_ref(i__, k)), abs(d__2))) * xk;
/* L40: */
}
/* L50: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = a_subscr(i__, k);
i__5 = x_subscr(i__, j);
s += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&
a_ref(i__, k)), abs(d__2))) * ((d__3 = x[i__5].r,
abs(d__3)) + (d__4 = d_imag(&x_ref(i__, j)), abs(
d__4)));
/* L60: */
}
rwork[k] += s;
/* L70: */
}
}
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);
}
/* L80: */
}
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. */
zgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[1],
n, info);
zaxpy_(n, &c_b1, &work[1], &c__1, &x_ref(1, j), &c__1);
lstres = berr[j];
++count;
goto L20;
}
/* Bound error from formula
norm(X - XTRUE) / norm(X) .le. FERR =
norm( abs(inv(op(A)))*
( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
where
norm(Z) is the magnitude of the largest component of Z
inv(op(A)) is the inverse of op(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(op(A))*abs(X)+abs(B))
is incremented by SAFE1 if the i-th component of
abs(op(A))*abs(X) + abs(B) is less than SAFE2.
Use ZLACON to estimate the infinity-norm of the matrix
inv(op(A)) * diag(W),
where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
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;
}
/* L90: */
}
kase = 0;
L100:
zlacon_(n, &work[*n + 1], &work[1], &ferr[j], &kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)**H). */
zgetrs_(transt, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &
work[1], n, info);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L110: */
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L120: */
}
zgetrs_(transn, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &
work[1], n, info);
}
goto L100;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = x_subscr(i__, j);
d__3 = lstres, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
d_imag(&x_ref(i__, j)), abs(d__2));
lstres = max(d__3,d__4);
/* L130: */
}
if (lstres != 0.) {
ferr[j] /= lstres;
}
/* L140: */
}
return 0;
/* End of ZGERFS */
} /* zgerfs_ */
/* Subroutine */ int csprfs_(char *uplo, integer *n, integer *nrhs, complex *
ap, complex *afp, integer *ipiv, complex *b, integer *ldb, complex *x,
integer *ldx, real *ferr, real *berr, complex *work, real *rwork,
integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CSPRFS improves the computed solution to a system of linear
equations when the coefficient matrix is symmetric indefinite
and packed, and provides error bounds and backward error estimates
for the solution.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices B and X. NRHS >= 0.
AP (input) COMPLEX array, dimension (N*(N+1)/2)
The upper or lower triangle of the symmetric matrix A, packed
columnwise in a linear array. The j-th column of A is stored
in the array AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
AFP (input) COMPLEX array, dimension (N*(N+1)/2)
The factored form of the matrix A. AFP contains the block
diagonal matrix D and the multipliers used to obtain the
factor U or L from the factorization A = U*D*U**T or
A = L*D*L**T as computed by CSPTRF, 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 CSPTRF.
B (input) COMPLEX 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 array, dimension (LDX,NRHS)
On entry, the solution matrix X, as computed by CSPTRS.
On exit, the improved solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
FERR (output) REAL array, dimension (NRHS)
The estimated 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). The estimate is as reliable as
the estimate for RCOND, and is almost always a slight
overestimate of the true error.
BERR (output) REAL 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 array, dimension (2*N)
RWORK (workspace) REAL array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Internal Parameters
===================
ITMAX is the maximum number of steps of iterative refinement.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static integer kase;
static real safe1, safe2;
static integer i__, j, k;
static real s;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
static integer count;
extern /* Subroutine */ int cspmv_(char *, integer *, complex *, complex *
, complex *, integer *, complex *, complex *, integer *);
static logical upper;
static integer ik, kk;
extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real
*, integer *);
static real xk;
extern doublereal slamch_(char *);
static integer nz;
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real lstres;
extern /* Subroutine */ int csptrs_(char *, integer *, integer *, complex
*, integer *, complex *, integer *, integer *);
static real eps;
#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)]
--ap;
--afp;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
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 = -8;
} else if (*ldx < max(1,*n)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CSPRFS", &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.f;
berr[j] = 0.f;
/* L10: */
}
return 0;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
eps = slamch_("Epsilon");
safmin = slamch_("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.f;
L20:
/* Loop until stopping criterion is satisfied.
Compute residual R = B - A * X */
ccopy_(n, &b_ref(1, j), &c__1, &work[1], &c__1);
q__1.r = -1.f, q__1.i = 0.f;
cspmv_(uplo, n, &q__1, &ap[1], &x_ref(1, j), &c__1, &c_b1, &work[1], &
c__1);
/* 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. */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
b_ref(i__, j)), dabs(r__2));
/* L30: */
}
/* Compute abs(A)*abs(X) + abs(B). */
kk = 1;
if (upper) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
i__3 = x_subscr(k, j);
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x_ref(k,
j)), dabs(r__2));
ik = kk;
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ik;
rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&ap[ik]), dabs(r__2))) * xk;
i__4 = ik;
i__5 = x_subscr(i__, j);
s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
ap[ik]), dabs(r__2))) * ((r__3 = x[i__5].r, dabs(
r__3)) + (r__4 = r_imag(&x_ref(i__, j)), dabs(
r__4)));
++ik;
/* L40: */
}
i__3 = kk + k - 1;
rwork[k] = rwork[k] + ((r__1 = ap[i__3].r, dabs(r__1)) + (
r__2 = r_imag(&ap[kk + k - 1]), dabs(r__2))) * xk + s;
kk += k;
/* L50: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
i__3 = x_subscr(k, j);
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x_ref(k,
j)), dabs(r__2));
i__3 = kk;
rwork[k] += ((r__1 = ap[i__3].r, dabs(r__1)) + (r__2 = r_imag(
&ap[kk]), dabs(r__2))) * xk;
ik = kk + 1;
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
i__4 = ik;
rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&ap[ik]), dabs(r__2))) * xk;
i__4 = ik;
i__5 = x_subscr(i__, j);
s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
ap[ik]), dabs(r__2))) * ((r__3 = x[i__5].r, dabs(
r__3)) + (r__4 = r_imag(&x_ref(i__, j)), dabs(
r__4)));
++ik;
/* L60: */
}
rwork[k] += s;
kk += *n - k + 1;
/* L70: */
}
}
s = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
/* Computing MAX */
i__3 = i__;
r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2))) / rwork[i__];
s = dmax(r__3,r__4);
} else {
/* Computing MAX */
i__3 = i__;
r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__]
+ safe1);
s = dmax(r__3,r__4);
}
/* L80: */
}
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.f <= lstres && count <= 5) {
/* Update solution and try again. */
csptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info);
caxpy_(n, &c_b1, &work[1], &c__1, &x_ref(1, j), &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.
Use CLACON to estimate the infinity-norm of the matrix
inv(A) * diag(W),
where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
i__3 = i__;
rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
i__];
} else {
i__3 = i__;
rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
i__] + safe1;
}
/* L90: */
}
kase = 0;
L100:
clacon_(n, &work[*n + 1], &work[1], &ferr[j], &kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(A'). */
csptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L110: */
}
} else if (kase == 2) {
/* Multiply by inv(A)*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L120: */
}
csptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info);
}
goto L100;
}
/* Normalize error. */
lstres = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = x_subscr(i__, j);
r__3 = lstres, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x_ref(i__, j)), dabs(r__2));
lstres = dmax(r__3,r__4);
/* L130: */
}
if (lstres != 0.f) {
ferr[j] /= lstres;
}
/* L140: */
}
return 0;
/* End of CSPRFS */
} /* csprfs_ */
/* Subroutine */ int zggsvp_(char *jobu, char *jobv, char *jobq, integer *m,
integer *p, integer *n, doublecomplex *a, integer *lda, doublecomplex
*b, integer *ldb, doublereal *tola, doublereal *tolb, integer *k,
integer *l, doublecomplex *u, integer *ldu, doublecomplex *v, integer
*ldv, doublecomplex *q, integer *ldq, integer *iwork, doublereal *
rwork, 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
=======
ZGGSVP computes unitary matrices U, V and Q such that
N-K-L K L
U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0;
L ( 0 0 A23 )
M-K-L ( 0 0 0 )
N-K-L K L
= K ( 0 A12 A13 ) if M-K-L < 0;
M-K ( 0 0 A23 )
N-K-L K L
V'*B*Q = L ( 0 0 B13 )
P-L ( 0 0 0 )
where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective
numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the
conjugate transpose of Z.
This decomposition is the preprocessing step for computing the
Generalized Singular Value Decomposition (GSVD), see subroutine
ZGGSVD.
Arguments
=========
JOBU (input) CHARACTER*1
= 'U': Unitary matrix U is computed;
= 'N': U is not computed.
JOBV (input) CHARACTER*1
= 'V': Unitary matrix V is computed;
= 'N': V is not computed.
JOBQ (input) CHARACTER*1
= 'Q': Unitary matrix Q is computed;
= 'N': Q is not computed.
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
P (input) INTEGER
The number of rows of the matrix B. P >= 0.
N (input) INTEGER
The number of columns of the matrices A and B. N >= 0.
A (input/output) COMPLEX*16 array, dimension (LDA,N)
On entry, the M-by-N matrix A.
On exit, A contains the triangular (or trapezoidal) matrix
described in the Purpose section.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
B (input/output) COMPLEX*16 array, dimension (LDB,N)
On entry, the P-by-N matrix B.
On exit, B contains the triangular matrix described in
the Purpose section.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,P).
TOLA (input) DOUBLE PRECISION
TOLB (input) DOUBLE PRECISION
TOLA and TOLB are the thresholds to determine the effective
numerical rank of matrix B and a subblock of A. Generally,
they are set to
TOLA = MAX(M,N)*norm(A)*MAZHEPS,
TOLB = MAX(P,N)*norm(B)*MAZHEPS.
The size of TOLA and TOLB may affect the size of backward
errors of the decomposition.
K (output) INTEGER
L (output) INTEGER
On exit, K and L specify the dimension of the subblocks
described in Purpose section.
K + L = effective numerical rank of (A',B')'.
U (output) COMPLEX*16 array, dimension (LDU,M)
If JOBU = 'U', U contains the unitary matrix U.
If JOBU = 'N', U is not referenced.
LDU (input) INTEGER
The leading dimension of the array U. LDU >= max(1,M) if
JOBU = 'U'; LDU >= 1 otherwise.
V (output) COMPLEX*16 array, dimension (LDV,M)
If JOBV = 'V', V contains the unitary matrix V.
If JOBV = 'N', V is not referenced.
LDV (input) INTEGER
The leading dimension of the array V. LDV >= max(1,P) if
JOBV = 'V'; LDV >= 1 otherwise.
Q (output) COMPLEX*16 array, dimension (LDQ,N)
If JOBQ = 'Q', Q contains the unitary matrix Q.
If JOBQ = 'N', Q is not referenced.
LDQ (input) INTEGER
The leading dimension of the array Q. LDQ >= max(1,N) if
JOBQ = 'Q'; LDQ >= 1 otherwise.
IWORK (workspace) INTEGER array, dimension (N)
RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
TAU (workspace) COMPLEX*16 array, dimension (N)
WORK (workspace) COMPLEX*16 array, dimension (max(3*N,M,P))
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
Further Details
===============
The subroutine uses LAPACK subroutine ZGEQPF for the QR factorization
with column pivoting to detect the effective numerical rank of the
a matrix. It may be replaced by a better rank determination strategy.
=====================================================================
Test the input parameters
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b1 = {0.,0.};
static doublecomplex c_b2 = {1.,0.};
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1,
u_offset, v_dim1, v_offset, i__1, i__2, i__3;
doublereal d__1, d__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer i__, j;
extern logical lsame_(char *, char *);
static logical wantq, wantu, wantv;
extern /* Subroutine */ int zgeqr2_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *), zgerq2_(
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *), zung2r_(integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *), zunm2r_(char *, char *, integer *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *), zunmr2_(char *, char *, integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *), xerbla_(
char *, integer *), zgeqpf_(integer *, integer *,
doublecomplex *, integer *, integer *, doublecomplex *,
doublecomplex *, doublereal *, integer *), zlacpy_(char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *);
static logical forwrd;
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlapmt_(logical *, integer *, integer *, doublecomplex *,
integer *, integer *);
#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 u_subscr(a_1,a_2) (a_2)*u_dim1 + a_1
#define u_ref(a_1,a_2) u[u_subscr(a_1,a_2)]
#define v_subscr(a_1,a_2) (a_2)*v_dim1 + a_1
#define v_ref(a_1,a_2) v[v_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1 * 1;
v -= v_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
--iwork;
--rwork;
--tau;
--work;
/* Function Body */
wantu = lsame_(jobu, "U");
wantv = lsame_(jobv, "V");
wantq = lsame_(jobq, "Q");
forwrd = TRUE_;
*info = 0;
if (! (wantu || lsame_(jobu, "N"))) {
*info = -1;
} else if (! (wantv || lsame_(jobv, "N"))) {
*info = -2;
} else if (! (wantq || lsame_(jobq, "N"))) {
*info = -3;
} else if (*m < 0) {
*info = -4;
} else if (*p < 0) {
*info = -5;
} else if (*n < 0) {
*info = -6;
} else if (*lda < max(1,*m)) {
*info = -8;
} else if (*ldb < max(1,*p)) {
*info = -10;
} else if (*ldu < 1 || wantu && *ldu < *m) {
*info = -16;
} else if (*ldv < 1 || wantv && *ldv < *p) {
*info = -18;
} else if (*ldq < 1 || wantq && *ldq < *n) {
*info = -20;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGGSVP", &i__1);
return 0;
}
/* QR with column pivoting of B: B*P = V*( S11 S12 )
( 0 0 ) */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
iwork[i__] = 0;
/* L10: */
}
zgeqpf_(p, n, &b[b_offset], ldb, &iwork[1], &tau[1], &work[1], &rwork[1],
info);
/* Update A := A*P */
zlapmt_(&forwrd, m, n, &a[a_offset], lda, &iwork[1]);
/* Determine the effective rank of matrix B. */
*l = 0;
i__1 = min(*p,*n);
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = b_subscr(i__, i__);
if ((d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b_ref(i__, i__)),
abs(d__2)) > *tolb) {
++(*l);
}
/* L20: */
}
if (wantv) {
/* Copy the details of V, and form V. */
zlaset_("Full", p, p, &c_b1, &c_b1, &v[v_offset], ldv);
if (*p > 1) {
i__1 = *p - 1;
zlacpy_("Lower", &i__1, n, &b_ref(2, 1), ldb, &v_ref(2, 1), ldv);
}
i__1 = min(*p,*n);
zung2r_(p, p, &i__1, &v[v_offset], ldv, &tau[1], &work[1], info);
}
/* Clean up B */
i__1 = *l - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *l;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
b[i__3].r = 0., b[i__3].i = 0.;
/* L30: */
}
/* L40: */
}
if (*p > *l) {
i__1 = *p - *l;
zlaset_("Full", &i__1, n, &c_b1, &c_b1, &b_ref(*l + 1, 1), ldb);
}
if (wantq) {
/* Set Q = I and Update Q := Q*P */
zlaset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq);
zlapmt_(&forwrd, n, n, &q[q_offset], ldq, &iwork[1]);
}
if (*p >= *l && *n != *l) {
/* RQ factorization of ( S11 S12 ) = ( 0 S12 )*Z */
zgerq2_(l, n, &b[b_offset], ldb, &tau[1], &work[1], info);
/* Update A := A*Z' */
zunmr2_("Right", "Conjugate transpose", m, n, l, &b[b_offset], ldb, &
tau[1], &a[a_offset], lda, &work[1], info);
if (wantq) {
/* Update Q := Q*Z' */
zunmr2_("Right", "Conjugate transpose", n, n, l, &b[b_offset],
ldb, &tau[1], &q[q_offset], ldq, &work[1], info);
}
/* Clean up B */
i__1 = *n - *l;
zlaset_("Full", l, &i__1, &c_b1, &c_b1, &b[b_offset], ldb);
i__1 = *n;
for (j = *n - *l + 1; j <= i__1; ++j) {
i__2 = *l;
for (i__ = j - *n + *l + 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
b[i__3].r = 0., b[i__3].i = 0.;
/* L50: */
}
/* L60: */
}
}
/* Let N-L L
A = ( A11 A12 ) M,
then the following does the complete QR decomposition of A11:
A11 = U*( 0 T12 )*P1'
( 0 0 ) */
i__1 = *n - *l;
for (i__ = 1; i__ <= i__1; ++i__) {
iwork[i__] = 0;
/* L70: */
}
i__1 = *n - *l;
zgeqpf_(m, &i__1, &a[a_offset], lda, &iwork[1], &tau[1], &work[1], &rwork[
1], info);
/* Determine the effective rank of A11 */
*k = 0;
/* Computing MIN */
i__2 = *m, i__3 = *n - *l;
i__1 = min(i__2,i__3);
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = a_subscr(i__, i__);
if ((d__1 = a[i__2].r, abs(d__1)) + (d__2 = d_imag(&a_ref(i__, i__)),
abs(d__2)) > *tola) {
++(*k);
}
/* L80: */
}
/* Update A12 := U'*A12, where A12 = A( 1:M, N-L+1:N )
Computing MIN */
i__2 = *m, i__3 = *n - *l;
i__1 = min(i__2,i__3);
zunm2r_("Left", "Conjugate transpose", m, l, &i__1, &a[a_offset], lda, &
tau[1], &a_ref(1, *n - *l + 1), lda, &work[1], info);
if (wantu) {
/* Copy the details of U, and form U */
zlaset_("Full", m, m, &c_b1, &c_b1, &u[u_offset], ldu);
if (*m > 1) {
i__1 = *m - 1;
i__2 = *n - *l;
zlacpy_("Lower", &i__1, &i__2, &a_ref(2, 1), lda, &u_ref(2, 1),
ldu);
}
/* Computing MIN */
i__2 = *m, i__3 = *n - *l;
i__1 = min(i__2,i__3);
zung2r_(m, m, &i__1, &u[u_offset], ldu, &tau[1], &work[1], info);
}
if (wantq) {
/* Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1 */
i__1 = *n - *l;
zlapmt_(&forwrd, n, &i__1, &q[q_offset], ldq, &iwork[1]);
}
/* Clean up A: set the strictly lower triangular part of
A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0. */
i__1 = *k - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = a_subscr(i__, j);
a[i__3].r = 0., a[i__3].i = 0.;
/* L90: */
}
/* L100: */
}
if (*m > *k) {
i__1 = *m - *k;
i__2 = *n - *l;
zlaset_("Full", &i__1, &i__2, &c_b1, &c_b1, &a_ref(*k + 1, 1), lda);
}
if (*n - *l > *k) {
/* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 */
i__1 = *n - *l;
zgerq2_(k, &i__1, &a[a_offset], lda, &tau[1], &work[1], info);
if (wantq) {
/* Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1' */
i__1 = *n - *l;
zunmr2_("Right", "Conjugate transpose", n, &i__1, k, &a[a_offset],
lda, &tau[1], &q[q_offset], ldq, &work[1], info);
}
/* Clean up A */
i__1 = *n - *l - *k;
zlaset_("Full", k, &i__1, &c_b1, &c_b1, &a[a_offset], lda);
i__1 = *n - *l;
for (j = *n - *l - *k + 1; j <= i__1; ++j) {
i__2 = *k;
for (i__ = j - *n + *l + *k + 1; i__ <= i__2; ++i__) {
i__3 = a_subscr(i__, j);
a[i__3].r = 0., a[i__3].i = 0.;
/* L110: */
}
/* L120: */
}
}
if (*m > *k) {
/* QR factorization of A( K+1:M,N-L+1:N ) */
i__1 = *m - *k;
zgeqr2_(&i__1, l, &a_ref(*k + 1, *n - *l + 1), lda, &tau[1], &work[1],
info);
if (wantu) {
/* Update U(:,K+1:M) := U(:,K+1:M)*U1 */
i__1 = *m - *k;
/* Computing MIN */
i__3 = *m - *k;
i__2 = min(i__3,*l);
zunm2r_("Right", "No transpose", m, &i__1, &i__2, &a_ref(*k + 1, *
n - *l + 1), lda, &tau[1], &u_ref(1, *k + 1), ldu, &work[
1], info);
}
/* Clean up */
i__1 = *n;
for (j = *n - *l + 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = j - *n + *k + *l + 1; i__ <= i__2; ++i__) {
i__3 = a_subscr(i__, j);
a[i__3].r = 0., a[i__3].i = 0.;
/* L130: */
}
/* L140: */
}
}
return 0;
/* End of ZGGSVP */
} /* zggsvp_ */
/* Subroutine */ int cgtts2_(integer *itrans, integer *n, integer *nrhs,
complex *dl, complex *d__, complex *du, complex *du2, integer *ipiv,
complex *b, integer *ldb)
{
/* -- 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
Purpose
=======
CGTTS2 solves one of the systems of equations
A * X = B, A**T * X = B, or A**H * X = B,
with a tridiagonal matrix A using the LU factorization computed
by CGTTRF.
Arguments
=========
ITRANS (input) INTEGER
Specifies the form of the system of equations.
= 0: A * X = B (No transpose)
= 1: A**T * X = B (Transpose)
= 2: A**H * X = B (Conjugate transpose)
N (input) INTEGER
The order of the matrix A.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrix B. NRHS >= 0.
DL (input) COMPLEX array, dimension (N-1)
The (n-1) multipliers that define the matrix L from the
LU factorization of A.
D (input) COMPLEX array, dimension (N)
The n diagonal elements of the upper triangular matrix U from
the LU factorization of A.
DU (input) COMPLEX array, dimension (N-1)
The (n-1) elements of the first super-diagonal of U.
DU2 (input) COMPLEX array, dimension (N-2)
The (n-2) elements of the second super-diagonal of U.
IPIV (input) INTEGER array, dimension (N)
The pivot indices; for 1 <= i <= n, row i of the matrix was
interchanged with row IPIV(i). IPIV(i) will always be either
i or i+1; IPIV(i) = i indicates a row interchange was not
required.
B (input/output) COMPLEX array, dimension (LDB,NRHS)
On entry, the matrix of right hand side vectors B.
On exit, B is overwritten by the solution vectors X.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
=====================================================================
Quick return if possible
Parameter adjustments */
/* System generated locals */
integer b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;
complex q__1, q__2, q__3, q__4, q__5, q__6, q__7, q__8;
/* Builtin functions */
void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *);
/* Local variables */
static complex temp;
static integer i__, j;
#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)]
--dl;
--d__;
--du;
--du2;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
/* Function Body */
if (*n == 0 || *nrhs == 0) {
return 0;
}
if (*itrans == 0) {
/* Solve A*X = B using the LU factorization of A,
overwriting each right hand side vector with its solution. */
if (*nrhs <= 1) {
j = 1;
L10:
/* Solve L*x = b. */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (ipiv[i__] == i__) {
i__2 = b_subscr(i__ + 1, j);
i__3 = b_subscr(i__ + 1, j);
i__4 = i__;
i__5 = b_subscr(i__, j);
q__2.r = dl[i__4].r * b[i__5].r - dl[i__4].i * b[i__5].i,
q__2.i = dl[i__4].r * b[i__5].i + dl[i__4].i * b[
i__5].r;
q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
} else {
i__2 = b_subscr(i__, j);
temp.r = b[i__2].r, temp.i = b[i__2].i;
i__2 = b_subscr(i__, j);
i__3 = b_subscr(i__ + 1, j);
b[i__2].r = b[i__3].r, b[i__2].i = b[i__3].i;
i__2 = b_subscr(i__ + 1, j);
i__3 = i__;
i__4 = b_subscr(i__, j);
q__2.r = dl[i__3].r * b[i__4].r - dl[i__3].i * b[i__4].i,
q__2.i = dl[i__3].r * b[i__4].i + dl[i__3].i * b[
i__4].r;
q__1.r = temp.r - q__2.r, q__1.i = temp.i - q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
}
/* L20: */
}
/* Solve U*x = b. */
i__1 = b_subscr(*n, j);
c_div(&q__1, &b_ref(*n, j), &d__[*n]);
b[i__1].r = q__1.r, b[i__1].i = q__1.i;
if (*n > 1) {
i__1 = b_subscr(*n - 1, j);
i__2 = b_subscr(*n - 1, j);
i__3 = *n - 1;
i__4 = b_subscr(*n, j);
q__3.r = du[i__3].r * b[i__4].r - du[i__3].i * b[i__4].i,
q__3.i = du[i__3].r * b[i__4].i + du[i__3].i * b[i__4]
.r;
q__2.r = b[i__2].r - q__3.r, q__2.i = b[i__2].i - q__3.i;
c_div(&q__1, &q__2, &d__[*n - 1]);
b[i__1].r = q__1.r, b[i__1].i = q__1.i;
}
for (i__ = *n - 2; i__ >= 1; --i__) {
i__1 = b_subscr(i__, j);
i__2 = b_subscr(i__, j);
i__3 = i__;
i__4 = b_subscr(i__ + 1, j);
q__4.r = du[i__3].r * b[i__4].r - du[i__3].i * b[i__4].i,
q__4.i = du[i__3].r * b[i__4].i + du[i__3].i * b[i__4]
.r;
q__3.r = b[i__2].r - q__4.r, q__3.i = b[i__2].i - q__4.i;
i__5 = i__;
i__6 = b_subscr(i__ + 2, j);
q__5.r = du2[i__5].r * b[i__6].r - du2[i__5].i * b[i__6].i,
q__5.i = du2[i__5].r * b[i__6].i + du2[i__5].i * b[
i__6].r;
q__2.r = q__3.r - q__5.r, q__2.i = q__3.i - q__5.i;
c_div(&q__1, &q__2, &d__[i__]);
b[i__1].r = q__1.r, b[i__1].i = q__1.i;
/* L30: */
}
if (j < *nrhs) {
++j;
goto L10;
}
} else {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
/* Solve L*x = b. */
i__2 = *n - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
if (ipiv[i__] == i__) {
i__3 = b_subscr(i__ + 1, j);
i__4 = b_subscr(i__ + 1, j);
i__5 = i__;
i__6 = b_subscr(i__, j);
q__2.r = dl[i__5].r * b[i__6].r - dl[i__5].i * b[i__6]
.i, q__2.i = dl[i__5].r * b[i__6].i + dl[i__5]
.i * b[i__6].r;
q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i -
q__2.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
} else {
i__3 = b_subscr(i__, j);
temp.r = b[i__3].r, temp.i = b[i__3].i;
i__3 = b_subscr(i__, j);
i__4 = b_subscr(i__ + 1, j);
b[i__3].r = b[i__4].r, b[i__3].i = b[i__4].i;
i__3 = b_subscr(i__ + 1, j);
i__4 = i__;
i__5 = b_subscr(i__, j);
q__2.r = dl[i__4].r * b[i__5].r - dl[i__4].i * b[i__5]
.i, q__2.i = dl[i__4].r * b[i__5].i + dl[i__4]
.i * b[i__5].r;
q__1.r = temp.r - q__2.r, q__1.i = temp.i - q__2.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
}
/* L40: */
}
/* Solve U*x = b. */
i__2 = b_subscr(*n, j);
c_div(&q__1, &b_ref(*n, j), &d__[*n]);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
if (*n > 1) {
i__2 = b_subscr(*n - 1, j);
i__3 = b_subscr(*n - 1, j);
i__4 = *n - 1;
i__5 = b_subscr(*n, j);
q__3.r = du[i__4].r * b[i__5].r - du[i__4].i * b[i__5].i,
q__3.i = du[i__4].r * b[i__5].i + du[i__4].i * b[
i__5].r;
q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
c_div(&q__1, &q__2, &d__[*n - 1]);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
}
for (i__ = *n - 2; i__ >= 1; --i__) {
i__2 = b_subscr(i__, j);
i__3 = b_subscr(i__, j);
i__4 = i__;
i__5 = b_subscr(i__ + 1, j);
q__4.r = du[i__4].r * b[i__5].r - du[i__4].i * b[i__5].i,
q__4.i = du[i__4].r * b[i__5].i + du[i__4].i * b[
i__5].r;
q__3.r = b[i__3].r - q__4.r, q__3.i = b[i__3].i - q__4.i;
i__6 = i__;
i__7 = b_subscr(i__ + 2, j);
q__5.r = du2[i__6].r * b[i__7].r - du2[i__6].i * b[i__7]
.i, q__5.i = du2[i__6].r * b[i__7].i + du2[i__6]
.i * b[i__7].r;
q__2.r = q__3.r - q__5.r, q__2.i = q__3.i - q__5.i;
c_div(&q__1, &q__2, &d__[i__]);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L50: */
}
/* L60: */
}
}
} else if (*itrans == 1) {
/* Solve A**T * X = B. */
if (*nrhs <= 1) {
j = 1;
L70:
/* Solve U**T * x = b. */
i__1 = b_subscr(1, j);
c_div(&q__1, &b_ref(1, j), &d__[1]);
b[i__1].r = q__1.r, b[i__1].i = q__1.i;
if (*n > 1) {
i__1 = b_subscr(2, j);
i__2 = b_subscr(2, j);
i__3 = b_subscr(1, j);
q__3.r = du[1].r * b[i__3].r - du[1].i * b[i__3].i, q__3.i =
du[1].r * b[i__3].i + du[1].i * b[i__3].r;
q__2.r = b[i__2].r - q__3.r, q__2.i = b[i__2].i - q__3.i;
c_div(&q__1, &q__2, &d__[2]);
b[i__1].r = q__1.r, b[i__1].i = q__1.i;
}
i__1 = *n;
for (i__ = 3; i__ <= i__1; ++i__) {
i__2 = b_subscr(i__, j);
i__3 = b_subscr(i__, j);
i__4 = i__ - 1;
i__5 = b_subscr(i__ - 1, j);
q__4.r = du[i__4].r * b[i__5].r - du[i__4].i * b[i__5].i,
q__4.i = du[i__4].r * b[i__5].i + du[i__4].i * b[i__5]
.r;
q__3.r = b[i__3].r - q__4.r, q__3.i = b[i__3].i - q__4.i;
i__6 = i__ - 2;
i__7 = b_subscr(i__ - 2, j);
q__5.r = du2[i__6].r * b[i__7].r - du2[i__6].i * b[i__7].i,
q__5.i = du2[i__6].r * b[i__7].i + du2[i__6].i * b[
i__7].r;
q__2.r = q__3.r - q__5.r, q__2.i = q__3.i - q__5.i;
c_div(&q__1, &q__2, &d__[i__]);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L80: */
}
/* Solve L**T * x = b. */
for (i__ = *n - 1; i__ >= 1; --i__) {
if (ipiv[i__] == i__) {
i__1 = b_subscr(i__, j);
i__2 = b_subscr(i__, j);
i__3 = i__;
i__4 = b_subscr(i__ + 1, j);
q__2.r = dl[i__3].r * b[i__4].r - dl[i__3].i * b[i__4].i,
q__2.i = dl[i__3].r * b[i__4].i + dl[i__3].i * b[
i__4].r;
q__1.r = b[i__2].r - q__2.r, q__1.i = b[i__2].i - q__2.i;
b[i__1].r = q__1.r, b[i__1].i = q__1.i;
} else {
i__1 = b_subscr(i__ + 1, j);
temp.r = b[i__1].r, temp.i = b[i__1].i;
i__1 = b_subscr(i__ + 1, j);
i__2 = b_subscr(i__, j);
i__3 = i__;
q__2.r = dl[i__3].r * temp.r - dl[i__3].i * temp.i,
q__2.i = dl[i__3].r * temp.i + dl[i__3].i *
temp.r;
q__1.r = b[i__2].r - q__2.r, q__1.i = b[i__2].i - q__2.i;
b[i__1].r = q__1.r, b[i__1].i = q__1.i;
i__1 = b_subscr(i__, j);
b[i__1].r = temp.r, b[i__1].i = temp.i;
}
/* L90: */
}
if (j < *nrhs) {
++j;
goto L70;
}
} else {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
/* Solve U**T * x = b. */
i__2 = b_subscr(1, j);
c_div(&q__1, &b_ref(1, j), &d__[1]);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
if (*n > 1) {
i__2 = b_subscr(2, j);
i__3 = b_subscr(2, j);
i__4 = b_subscr(1, j);
q__3.r = du[1].r * b[i__4].r - du[1].i * b[i__4].i,
q__3.i = du[1].r * b[i__4].i + du[1].i * b[i__4]
.r;
q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
c_div(&q__1, &q__2, &d__[2]);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
}
i__2 = *n;
for (i__ = 3; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = b_subscr(i__, j);
i__5 = i__ - 1;
i__6 = b_subscr(i__ - 1, j);
q__4.r = du[i__5].r * b[i__6].r - du[i__5].i * b[i__6].i,
q__4.i = du[i__5].r * b[i__6].i + du[i__5].i * b[
i__6].r;
q__3.r = b[i__4].r - q__4.r, q__3.i = b[i__4].i - q__4.i;
i__7 = i__ - 2;
i__8 = b_subscr(i__ - 2, j);
q__5.r = du2[i__7].r * b[i__8].r - du2[i__7].i * b[i__8]
.i, q__5.i = du2[i__7].r * b[i__8].i + du2[i__7]
.i * b[i__8].r;
q__2.r = q__3.r - q__5.r, q__2.i = q__3.i - q__5.i;
c_div(&q__1, &q__2, &d__[i__]);
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L100: */
}
/* Solve L**T * x = b. */
for (i__ = *n - 1; i__ >= 1; --i__) {
if (ipiv[i__] == i__) {
i__2 = b_subscr(i__, j);
i__3 = b_subscr(i__, j);
i__4 = i__;
i__5 = b_subscr(i__ + 1, j);
q__2.r = dl[i__4].r * b[i__5].r - dl[i__4].i * b[i__5]
.i, q__2.i = dl[i__4].r * b[i__5].i + dl[i__4]
.i * b[i__5].r;
q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i -
q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
} else {
i__2 = b_subscr(i__ + 1, j);
temp.r = b[i__2].r, temp.i = b[i__2].i;
i__2 = b_subscr(i__ + 1, j);
i__3 = b_subscr(i__, j);
i__4 = i__;
q__2.r = dl[i__4].r * temp.r - dl[i__4].i * temp.i,
q__2.i = dl[i__4].r * temp.i + dl[i__4].i *
temp.r;
q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i -
q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = b_subscr(i__, j);
b[i__2].r = temp.r, b[i__2].i = temp.i;
}
/* L110: */
}
/* L120: */
}
}
} else {
/* Solve A**H * X = B. */
if (*nrhs <= 1) {
j = 1;
L130:
/* Solve U**H * x = b. */
i__1 = b_subscr(1, j);
r_cnjg(&q__2, &d__[1]);
c_div(&q__1, &b_ref(1, j), &q__2);
b[i__1].r = q__1.r, b[i__1].i = q__1.i;
if (*n > 1) {
i__1 = b_subscr(2, j);
i__2 = b_subscr(2, j);
r_cnjg(&q__4, &du[1]);
i__3 = b_subscr(1, j);
q__3.r = q__4.r * b[i__3].r - q__4.i * b[i__3].i, q__3.i =
q__4.r * b[i__3].i + q__4.i * b[i__3].r;
q__2.r = b[i__2].r - q__3.r, q__2.i = b[i__2].i - q__3.i;
r_cnjg(&q__5, &d__[2]);
c_div(&q__1, &q__2, &q__5);
b[i__1].r = q__1.r, b[i__1].i = q__1.i;
}
i__1 = *n;
for (i__ = 3; i__ <= i__1; ++i__) {
i__2 = b_subscr(i__, j);
i__3 = b_subscr(i__, j);
r_cnjg(&q__5, &du[i__ - 1]);
i__4 = b_subscr(i__ - 1, j);
q__4.r = q__5.r * b[i__4].r - q__5.i * b[i__4].i, q__4.i =
q__5.r * b[i__4].i + q__5.i * b[i__4].r;
q__3.r = b[i__3].r - q__4.r, q__3.i = b[i__3].i - q__4.i;
r_cnjg(&q__7, &du2[i__ - 2]);
i__5 = b_subscr(i__ - 2, j);
q__6.r = q__7.r * b[i__5].r - q__7.i * b[i__5].i, q__6.i =
q__7.r * b[i__5].i + q__7.i * b[i__5].r;
q__2.r = q__3.r - q__6.r, q__2.i = q__3.i - q__6.i;
r_cnjg(&q__8, &d__[i__]);
c_div(&q__1, &q__2, &q__8);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L140: */
}
/* Solve L**H * x = b. */
for (i__ = *n - 1; i__ >= 1; --i__) {
if (ipiv[i__] == i__) {
i__1 = b_subscr(i__, j);
i__2 = b_subscr(i__, j);
r_cnjg(&q__3, &dl[i__]);
i__3 = b_subscr(i__ + 1, j);
q__2.r = q__3.r * b[i__3].r - q__3.i * b[i__3].i, q__2.i =
q__3.r * b[i__3].i + q__3.i * b[i__3].r;
q__1.r = b[i__2].r - q__2.r, q__1.i = b[i__2].i - q__2.i;
b[i__1].r = q__1.r, b[i__1].i = q__1.i;
} else {
i__1 = b_subscr(i__ + 1, j);
temp.r = b[i__1].r, temp.i = b[i__1].i;
i__1 = b_subscr(i__ + 1, j);
i__2 = b_subscr(i__, j);
r_cnjg(&q__3, &dl[i__]);
q__2.r = q__3.r * temp.r - q__3.i * temp.i, q__2.i =
q__3.r * temp.i + q__3.i * temp.r;
q__1.r = b[i__2].r - q__2.r, q__1.i = b[i__2].i - q__2.i;
b[i__1].r = q__1.r, b[i__1].i = q__1.i;
i__1 = b_subscr(i__, j);
b[i__1].r = temp.r, b[i__1].i = temp.i;
}
/* L150: */
}
if (j < *nrhs) {
++j;
goto L130;
}
} else {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
/* Solve U**H * x = b. */
i__2 = b_subscr(1, j);
r_cnjg(&q__2, &d__[1]);
c_div(&q__1, &b_ref(1, j), &q__2);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
if (*n > 1) {
i__2 = b_subscr(2, j);
i__3 = b_subscr(2, j);
r_cnjg(&q__4, &du[1]);
i__4 = b_subscr(1, j);
q__3.r = q__4.r * b[i__4].r - q__4.i * b[i__4].i, q__3.i =
q__4.r * b[i__4].i + q__4.i * b[i__4].r;
q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
r_cnjg(&q__5, &d__[2]);
c_div(&q__1, &q__2, &q__5);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
}
i__2 = *n;
for (i__ = 3; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = b_subscr(i__, j);
r_cnjg(&q__5, &du[i__ - 1]);
i__5 = b_subscr(i__ - 1, j);
q__4.r = q__5.r * b[i__5].r - q__5.i * b[i__5].i, q__4.i =
q__5.r * b[i__5].i + q__5.i * b[i__5].r;
q__3.r = b[i__4].r - q__4.r, q__3.i = b[i__4].i - q__4.i;
r_cnjg(&q__7, &du2[i__ - 2]);
i__6 = b_subscr(i__ - 2, j);
q__6.r = q__7.r * b[i__6].r - q__7.i * b[i__6].i, q__6.i =
q__7.r * b[i__6].i + q__7.i * b[i__6].r;
q__2.r = q__3.r - q__6.r, q__2.i = q__3.i - q__6.i;
r_cnjg(&q__8, &d__[i__]);
c_div(&q__1, &q__2, &q__8);
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L160: */
}
/* Solve L**H * x = b. */
for (i__ = *n - 1; i__ >= 1; --i__) {
if (ipiv[i__] == i__) {
i__2 = b_subscr(i__, j);
i__3 = b_subscr(i__, j);
r_cnjg(&q__3, &dl[i__]);
i__4 = b_subscr(i__ + 1, j);
q__2.r = q__3.r * b[i__4].r - q__3.i * b[i__4].i,
q__2.i = q__3.r * b[i__4].i + q__3.i * b[i__4]
.r;
q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i -
q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
} else {
i__2 = b_subscr(i__ + 1, j);
temp.r = b[i__2].r, temp.i = b[i__2].i;
i__2 = b_subscr(i__ + 1, j);
i__3 = b_subscr(i__, j);
r_cnjg(&q__3, &dl[i__]);
q__2.r = q__3.r * temp.r - q__3.i * temp.i, q__2.i =
q__3.r * temp.i + q__3.i * temp.r;
q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i -
q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = b_subscr(i__, j);
b[i__2].r = temp.r, b[i__2].i = temp.i;
}
/* L170: */
}
/* L180: */
}
}
}
/* End of CGTTS2 */
return 0;
} /* cgtts2_ */
/* Subroutine */ int ctprfs_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, complex *ap, complex *b, integer *ldb, complex *x,
integer *ldx, real *ferr, real *berr, complex *work, real *rwork,
integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CTPRFS provides error bounds and backward error estimates for the
solution to a system of linear equations with a triangular packed
coefficient matrix.
The solution matrix X must be computed by CTPTRS or some other
means before entering this routine. CTPRFS does not do iterative
refinement because doing so cannot improve the backward error.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': A is upper triangular;
= 'L': A is lower triangular.
TRANS (input) CHARACTER*1
Specifies the form of the system of equations:
= 'N': A * X = B (No transpose)
= 'T': A**T * X = B (Transpose)
= 'C': A**H * X = B (Conjugate transpose)
DIAG (input) CHARACTER*1
= 'N': A is non-unit triangular;
= 'U': A is unit triangular.
N (input) INTEGER
The order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices B and X. NRHS >= 0.
AP (input) COMPLEX array, dimension (N*(N+1)/2)
The upper or lower triangular matrix A, packed columnwise in
a linear array. The j-th column of A is stored in the array
AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
If DIAG = 'U', the diagonal elements of A are not referenced
and are assumed to be 1.
B (input) COMPLEX array, dimension (LDB,NRHS)
The right hand side matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input) COMPLEX array, dimension (LDX,NRHS)
The solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
FERR (output) REAL array, dimension (NRHS)
The estimated 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). The estimate is as reliable as
the estimate for RCOND, and is almost always a slight
overestimate of the true error.
BERR (output) REAL 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 array, dimension (2*N)
RWORK (workspace) REAL array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static integer kase;
static real safe1, safe2;
static integer i__, j, k;
static real s;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *), ctpmv_(char *, char *, char *,
integer *, complex *, complex *, integer *);
static logical upper;
extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *,
complex *, complex *, integer *);
static integer kc;
extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real
*, integer *);
static real xk;
extern doublereal slamch_(char *);
static integer nz;
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static logical notran;
static char transn[1], transt[1];
static logical nounit;
static real lstres, eps;
#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)]
--ap;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
--ferr;
--berr;
--work;
--rwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
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 (*n < 0) {
*info = -4;
} else if (*nrhs < 0) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else if (*ldx < max(1,*n)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTPRFS", &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.f;
berr[j] = 0.f;
/* L10: */
}
return 0;
}
if (notran) {
*(unsigned char *)transn = 'N';
*(unsigned char *)transt = 'C';
} else {
*(unsigned char *)transn = 'C';
*(unsigned char *)transt = 'N';
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
eps = slamch_("Epsilon");
safmin = slamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
/* Compute residual R = B - op(A) * X,
where op(A) = A, A**T, or A**H, depending on TRANS. */
ccopy_(n, &x_ref(1, j), &c__1, &work[1], &c__1);
ctpmv_(uplo, trans, diag, n, &ap[1], &work[1], &c__1);
q__1.r = -1.f, q__1.i = 0.f;
caxpy_(n, &q__1, &b_ref(1, j), &c__1, &work[1], &c__1);
/* Compute componentwise relative backward error from formula
max(i) ( abs(R(i)) / ( abs(op(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. */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
b_ref(i__, j)), dabs(r__2));
/* L20: */
}
if (notran) {
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
kc = 1;
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = x_subscr(k, j);
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x_ref(k, j)), dabs(r__2));
i__3 = k;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = kc + i__ - 1;
rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + (
r__2 = r_imag(&ap[kc + i__ - 1]), dabs(
r__2))) * xk;
/* L30: */
}
kc += k;
/* L40: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = x_subscr(k, j);
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x_ref(k, j)), dabs(r__2));
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = kc + i__ - 1;
rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + (
r__2 = r_imag(&ap[kc + i__ - 1]), dabs(
r__2))) * xk;
/* L50: */
}
rwork[k] += xk;
kc += k;
/* L60: */
}
}
} else {
kc = 1;
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = x_subscr(k, j);
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x_ref(k, j)), dabs(r__2));
i__3 = *n;
for (i__ = k; i__ <= i__3; ++i__) {
i__4 = kc + i__ - k;
rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + (
r__2 = r_imag(&ap[kc + i__ - k]), dabs(
r__2))) * xk;
/* L70: */
}
kc = kc + *n - k + 1;
/* L80: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = x_subscr(k, j);
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x_ref(k, j)), dabs(r__2));
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
i__4 = kc + i__ - k;
rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + (
r__2 = r_imag(&ap[kc + i__ - k]), dabs(
r__2))) * xk;
/* L90: */
}
rwork[k] += xk;
kc = kc + *n - k + 1;
/* L100: */
}
}
}
} else {
/* Compute abs(A**H)*abs(X) + abs(B). */
if (upper) {
kc = 1;
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
i__3 = k;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = kc + i__ - 1;
i__5 = x_subscr(i__, j);
s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&ap[kc + i__ - 1]), dabs(r__2))) *
((r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
r_imag(&x_ref(i__, j)), dabs(r__4)));
/* L110: */
}
rwork[k] += s;
kc += k;
/* L120: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = x_subscr(k, j);
s = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x_ref(k, j)), dabs(r__2));
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = kc + i__ - 1;
i__5 = x_subscr(i__, j);
s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&ap[kc + i__ - 1]), dabs(r__2))) *
((r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
r_imag(&x_ref(i__, j)), dabs(r__4)));
/* L130: */
}
rwork[k] += s;
kc += k;
/* L140: */
}
}
} else {
kc = 1;
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
i__3 = *n;
for (i__ = k; i__ <= i__3; ++i__) {
i__4 = kc + i__ - k;
i__5 = x_subscr(i__, j);
s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&ap[kc + i__ - k]), dabs(r__2))) *
((r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
r_imag(&x_ref(i__, j)), dabs(r__4)));
/* L150: */
}
rwork[k] += s;
kc = kc + *n - k + 1;
/* L160: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = x_subscr(k, j);
s = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x_ref(k, j)), dabs(r__2));
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
i__4 = kc + i__ - k;
i__5 = x_subscr(i__, j);
s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&ap[kc + i__ - k]), dabs(r__2))) *
((r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
r_imag(&x_ref(i__, j)), dabs(r__4)));
/* L170: */
}
rwork[k] += s;
kc = kc + *n - k + 1;
/* L180: */
}
}
}
}
s = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
/* Computing MAX */
i__3 = i__;
r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2))) / rwork[i__];
s = dmax(r__3,r__4);
} else {
/* Computing MAX */
i__3 = i__;
r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__]
+ safe1);
s = dmax(r__3,r__4);
}
/* L190: */
}
berr[j] = s;
/* Bound error from formula
norm(X - XTRUE) / norm(X) .le. FERR =
norm( abs(inv(op(A)))*
( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
where
norm(Z) is the magnitude of the largest component of Z
inv(op(A)) is the inverse of op(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(op(A))*abs(X)+abs(B))
is incremented by SAFE1 if the i-th component of
abs(op(A))*abs(X) + abs(B) is less than SAFE2.
Use CLACON to estimate the infinity-norm of the matrix
inv(op(A)) * diag(W),
where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
i__3 = i__;
rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
i__];
} else {
i__3 = i__;
rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
i__] + safe1;
}
/* L200: */
}
kase = 0;
L210:
clacon_(n, &work[*n + 1], &work[1], &ferr[j], &kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)**H). */
ctpsv_(uplo, transt, diag, n, &ap[1], &work[1], &c__1);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L220: */
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L230: */
}
ctpsv_(uplo, transn, diag, n, &ap[1], &work[1], &c__1);
}
goto L210;
}
/* Normalize error. */
lstres = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = x_subscr(i__, j);
r__3 = lstres, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x_ref(i__, j)), dabs(r__2));
lstres = dmax(r__3,r__4);
/* L240: */
}
if (lstres != 0.f) {
ferr[j] /= lstres;
}
/* L250: */
}
return 0;
/* End of CTPRFS */
} /* ctprfs_ */
/* Subroutine */ int claein_(logical *rightv, logical *noinit, integer *n,
complex *h__, integer *ldh, complex *w, complex *v, complex *b,
integer *ldb, real *rwork, real *eps3, real *smlnum, integer *info)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CLAEIN uses inverse iteration to find a right or left eigenvector
corresponding to the eigenvalue W of a complex upper Hessenberg
matrix H.
Arguments
=========
RIGHTV (input) LOGICAL
= .TRUE. : compute right eigenvector;
= .FALSE.: compute left eigenvector.
NOINIT (input) LOGICAL
= .TRUE. : no initial vector supplied in V
= .FALSE.: initial vector supplied in V.
N (input) INTEGER
The order of the matrix H. N >= 0.
H (input) COMPLEX array, dimension (LDH,N)
The upper Hessenberg matrix H.
LDH (input) INTEGER
The leading dimension of the array H. LDH >= max(1,N).
W (input) COMPLEX
The eigenvalue of H whose corresponding right or left
eigenvector is to be computed.
V (input/output) COMPLEX array, dimension (N)
On entry, if NOINIT = .FALSE., V must contain a starting
vector for inverse iteration; otherwise V need not be set.
On exit, V contains the computed eigenvector, normalized so
that the component of largest magnitude has magnitude 1; here
the magnitude of a complex number (x,y) is taken to be
|x| + |y|.
B (workspace) COMPLEX array, dimension (LDB,N)
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
RWORK (workspace) REAL array, dimension (N)
EPS3 (input) REAL
A small machine-dependent value which is used to perturb
close eigenvalues, and to replace zero pivots.
SMLNUM (input) REAL
A machine-dependent value close to the underflow threshold.
INFO (output) INTEGER
= 0: successful exit
= 1: inverse iteration did not converge; V is set to the
last iterate.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1, q__2;
/* Builtin functions */
double sqrt(doublereal), r_imag(complex *);
/* Local variables */
static integer ierr;
static complex temp;
static integer i__, j;
static real scale;
static complex x;
static char trans[1];
static real rtemp, rootn, vnorm;
extern doublereal scnrm2_(integer *, complex *, integer *);
static complex ei, ej;
extern integer icamax_(integer *, complex *, integer *);
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), clatrs_(char *, char *, char *, char *, integer *, complex *,
integer *, complex *, real *, real *, integer *);
extern doublereal scasum_(integer *, complex *, integer *);
static char normin[1];
static real nrmsml, growto;
static integer its;
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define h___subscr(a_1,a_2) (a_2)*h_dim1 + a_1
#define h___ref(a_1,a_2) h__[h___subscr(a_1,a_2)]
h_dim1 = *ldh;
h_offset = 1 + h_dim1 * 1;
h__ -= h_offset;
--v;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--rwork;
/* Function Body */
*info = 0;
/* GROWTO is the threshold used in the acceptance test for an
eigenvector. */
rootn = sqrt((real) (*n));
growto = .1f / rootn;
/* Computing MAX */
r__1 = 1.f, r__2 = *eps3 * rootn;
nrmsml = dmax(r__1,r__2) * *smlnum;
/* Form B = H - W*I (except that the subdiagonal elements are not
stored). */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = h___subscr(i__, j);
b[i__3].r = h__[i__4].r, b[i__3].i = h__[i__4].i;
/* L10: */
}
i__2 = b_subscr(j, j);
i__3 = h___subscr(j, j);
q__1.r = h__[i__3].r - w->r, q__1.i = h__[i__3].i - w->i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L20: */
}
if (*noinit) {
/* Initialize V. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
v[i__2].r = *eps3, v[i__2].i = 0.f;
/* L30: */
}
} else {
/* Scale supplied initial vector. */
vnorm = scnrm2_(n, &v[1], &c__1);
r__1 = *eps3 * rootn / dmax(vnorm,nrmsml);
csscal_(n, &r__1, &v[1], &c__1);
}
if (*rightv) {
/* LU decomposition with partial pivoting of B, replacing zero
pivots by EPS3. */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = h___subscr(i__ + 1, i__);
ei.r = h__[i__2].r, ei.i = h__[i__2].i;
i__2 = b_subscr(i__, i__);
if ((r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(i__,
i__)), dabs(r__2)) < (r__3 = ei.r, dabs(r__3)) + (r__4 =
r_imag(&ei), dabs(r__4))) {
/* Interchange rows and eliminate. */
cladiv_(&q__1, &b_ref(i__, i__), &ei);
x.r = q__1.r, x.i = q__1.i;
i__2 = b_subscr(i__, i__);
b[i__2].r = ei.r, b[i__2].i = ei.i;
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = b_subscr(i__ + 1, j);
temp.r = b[i__3].r, temp.i = b[i__3].i;
i__3 = b_subscr(i__ + 1, j);
i__4 = b_subscr(i__, j);
q__2.r = x.r * temp.r - x.i * temp.i, q__2.i = x.r *
temp.i + x.i * temp.r;
q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i - q__2.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
i__3 = b_subscr(i__, j);
b[i__3].r = temp.r, b[i__3].i = temp.i;
/* L40: */
}
} else {
/* Eliminate without interchange. */
i__2 = b_subscr(i__, i__);
if (b[i__2].r == 0.f && b[i__2].i == 0.f) {
i__3 = b_subscr(i__, i__);
b[i__3].r = *eps3, b[i__3].i = 0.f;
}
cladiv_(&q__1, &ei, &b_ref(i__, i__));
x.r = q__1.r, x.i = q__1.i;
if (x.r != 0.f || x.i != 0.f) {
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = b_subscr(i__ + 1, j);
i__4 = b_subscr(i__ + 1, j);
i__5 = b_subscr(i__, j);
q__2.r = x.r * b[i__5].r - x.i * b[i__5].i, q__2.i =
x.r * b[i__5].i + x.i * b[i__5].r;
q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i -
q__2.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L50: */
}
}
}
/* L60: */
}
i__1 = b_subscr(*n, *n);
if (b[i__1].r == 0.f && b[i__1].i == 0.f) {
i__2 = b_subscr(*n, *n);
b[i__2].r = *eps3, b[i__2].i = 0.f;
}
*(unsigned char *)trans = 'N';
} else {
/* UL decomposition with partial pivoting of B, replacing zero
pivots by EPS3. */
for (j = *n; j >= 2; --j) {
i__1 = h___subscr(j, j - 1);
ej.r = h__[i__1].r, ej.i = h__[i__1].i;
i__1 = b_subscr(j, j);
if ((r__1 = b[i__1].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(j, j)),
dabs(r__2)) < (r__3 = ej.r, dabs(r__3)) + (r__4 = r_imag(
&ej), dabs(r__4))) {
/* Interchange columns and eliminate. */
cladiv_(&q__1, &b_ref(j, j), &ej);
x.r = q__1.r, x.i = q__1.i;
i__1 = b_subscr(j, j);
b[i__1].r = ej.r, b[i__1].i = ej.i;
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = b_subscr(i__, j - 1);
temp.r = b[i__2].r, temp.i = b[i__2].i;
i__2 = b_subscr(i__, j - 1);
i__3 = b_subscr(i__, j);
q__2.r = x.r * temp.r - x.i * temp.i, q__2.i = x.r *
temp.i + x.i * temp.r;
q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = b_subscr(i__, j);
b[i__2].r = temp.r, b[i__2].i = temp.i;
/* L70: */
}
} else {
/* Eliminate without interchange. */
i__1 = b_subscr(j, j);
if (b[i__1].r == 0.f && b[i__1].i == 0.f) {
i__2 = b_subscr(j, j);
b[i__2].r = *eps3, b[i__2].i = 0.f;
}
cladiv_(&q__1, &ej, &b_ref(j, j));
x.r = q__1.r, x.i = q__1.i;
if (x.r != 0.f || x.i != 0.f) {
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = b_subscr(i__, j - 1);
i__3 = b_subscr(i__, j - 1);
i__4 = b_subscr(i__, j);
q__2.r = x.r * b[i__4].r - x.i * b[i__4].i, q__2.i =
x.r * b[i__4].i + x.i * b[i__4].r;
q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i -
q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L80: */
}
}
}
/* L90: */
}
i__1 = b_subscr(1, 1);
if (b[i__1].r == 0.f && b[i__1].i == 0.f) {
i__2 = b_subscr(1, 1);
b[i__2].r = *eps3, b[i__2].i = 0.f;
}
*(unsigned char *)trans = 'C';
}
*(unsigned char *)normin = 'N';
i__1 = *n;
for (its = 1; its <= i__1; ++its) {
/* Solve U*x = scale*v for a right eigenvector
or U'*x = scale*v for a left eigenvector,
overwriting x on v. */
clatrs_("Upper", trans, "Nonunit", normin, n, &b[b_offset], ldb, &v[1]
, &scale, &rwork[1], &ierr);
*(unsigned char *)normin = 'Y';
/* Test for sufficient growth in the norm of v. */
vnorm = scasum_(n, &v[1], &c__1);
if (vnorm >= growto * scale) {
goto L120;
}
/* Choose new orthogonal starting vector and try again. */
rtemp = *eps3 / (rootn + 1.f);
v[1].r = *eps3, v[1].i = 0.f;
i__2 = *n;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = i__;
v[i__3].r = rtemp, v[i__3].i = 0.f;
/* L100: */
}
i__2 = *n - its + 1;
i__3 = *n - its + 1;
r__1 = *eps3 * rootn;
q__1.r = v[i__3].r - r__1, q__1.i = v[i__3].i;
v[i__2].r = q__1.r, v[i__2].i = q__1.i;
/* L110: */
}
/* Failure to find eigenvector in N iterations. */
*info = 1;
L120:
/* Normalize eigenvector. */
i__ = icamax_(n, &v[1], &c__1);
i__1 = i__;
r__3 = 1.f / ((r__1 = v[i__1].r, dabs(r__1)) + (r__2 = r_imag(&v[i__]),
dabs(r__2)));
csscal_(n, &r__3, &v[1], &c__1);
return 0;
/* End of CLAEIN */
} /* claein_ */
/* Subroutine */ int ctrmm_(char *side, char *uplo, char *transa, char *diag,
integer *m, integer *n, complex *alpha, complex *a, integer *lda,
complex *b, integer *ldb)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5,
i__6;
complex q__1, q__2, q__3;
/* Builtin functions */
void r_cnjg(complex *, complex *);
/* Local variables */
static integer info;
static complex temp;
static integer i__, j, k;
extern logical lsame_(char *, char *);
static logical lside;
static integer nrowa;
static logical upper;
extern /* Subroutine */ int xerbla_(char *, integer *);
static logical noconj, nounit;
#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)]
/* Purpose
=======
CTRMM performs one of the matrix-matrix operations
B := alpha*op( A )*B, or B := alpha*B*op( A )
where alpha is a scalar, B is an m by n matrix, A is a unit, or
non-unit, upper or lower triangular matrix and op( A ) is one of
op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ).
Parameters
==========
SIDE - CHARACTER*1.
On entry, SIDE specifies whether op( A ) multiplies B from
the left or right as follows:
SIDE = 'L' or 'l' B := alpha*op( A )*B.
SIDE = 'R' or 'r' B := alpha*B*op( A ).
Unchanged on exit.
UPLO - CHARACTER*1.
On entry, UPLO specifies whether the matrix A 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.
TRANSA - CHARACTER*1.
On entry, TRANSA specifies the form of op( A ) to be used in
the matrix multiplication as follows:
TRANSA = 'N' or 'n' op( A ) = A.
TRANSA = 'T' or 't' op( A ) = A'.
TRANSA = 'C' or 'c' op( A ) = conjg( A' ).
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.
M - INTEGER.
On entry, M specifies the number of rows of B. M must be at
least zero.
Unchanged on exit.
N - INTEGER.
On entry, N specifies the number of columns of B. N must be
at least zero.
Unchanged on exit.
ALPHA - COMPLEX .
On entry, ALPHA specifies the scalar alpha. When alpha is
zero then A is not referenced and B need not be set before
entry.
Unchanged on exit.
A - COMPLEX array of DIMENSION ( LDA, k ), where k is m
when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
Before entry with UPLO = 'U' or 'u', the leading k by k
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 k by k
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. When SIDE = 'L' or 'l' then
LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
then LDA must be at least max( 1, n ).
Unchanged on exit.
B - COMPLEX array of DIMENSION ( LDB, n ).
Before entry, the leading m by n part of the array B must
contain the matrix B, and on exit is overwritten by the
transformed matrix.
LDB - INTEGER.
On entry, LDB specifies the first dimension of B as declared
in the calling (sub) program. LDB must be at least
max( 1, m ).
Unchanged on exit.
Level 3 Blas routine.
-- Written on 8-February-1989.
Jack Dongarra, Argonne National Laboratory.
Iain Duff, AERE Harwell.
Jeremy Du Croz, Numerical Algorithms Group Ltd.
Sven Hammarling, Numerical Algorithms Group Ltd.
Test the input parameters.
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;
/* Function Body */
lside = lsame_(side, "L");
if (lside) {
nrowa = *m;
} else {
nrowa = *n;
}
noconj = lsame_(transa, "T");
nounit = lsame_(diag, "N");
upper = lsame_(uplo, "U");
info = 0;
if (! lside && ! lsame_(side, "R")) {
info = 1;
} else if (! upper && ! lsame_(uplo, "L")) {
info = 2;
} else if (! lsame_(transa, "N") && ! lsame_(transa,
"T") && ! lsame_(transa, "C")) {
info = 3;
} else if (! lsame_(diag, "U") && ! lsame_(diag,
"N")) {
info = 4;
} else if (*m < 0) {
info = 5;
} else if (*n < 0) {
info = 6;
} else if (*lda < max(1,nrowa)) {
info = 9;
} else if (*ldb < max(1,*m)) {
info = 11;
}
if (info != 0) {
xerbla_("CTRMM ", &info);
return 0;
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
/* And when alpha.eq.zero. */
if (alpha->r == 0.f && alpha->i == 0.f) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
b[i__3].r = 0.f, b[i__3].i = 0.f;
/* L10: */
}
/* L20: */
}
return 0;
}
/* Start the operations. */
if (lside) {
if (lsame_(transa, "N")) {
/* Form B := alpha*A*B. */
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (k = 1; k <= i__2; ++k) {
i__3 = b_subscr(k, j);
if (b[i__3].r != 0.f || b[i__3].i != 0.f) {
i__3 = b_subscr(k, j);
q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3]
.i, q__1.i = alpha->r * b[i__3].i +
alpha->i * b[i__3].r;
temp.r = q__1.r, temp.i = q__1.i;
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = b_subscr(i__, j);
i__5 = b_subscr(i__, j);
i__6 = a_subscr(i__, k);
q__2.r = temp.r * a[i__6].r - temp.i * a[i__6]
.i, q__2.i = temp.r * a[i__6].i +
temp.i * a[i__6].r;
q__1.r = b[i__5].r + q__2.r, q__1.i = b[i__5]
.i + q__2.i;
b[i__4].r = q__1.r, b[i__4].i = q__1.i;
/* L30: */
}
if (nounit) {
i__3 = a_subscr(k, k);
q__1.r = temp.r * a[i__3].r - temp.i * a[i__3]
.i, q__1.i = temp.r * a[i__3].i +
temp.i * a[i__3].r;
temp.r = q__1.r, temp.i = q__1.i;
}
i__3 = b_subscr(k, j);
b[i__3].r = temp.r, b[i__3].i = temp.i;
}
/* L40: */
}
/* L50: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
for (k = *m; k >= 1; --k) {
i__2 = b_subscr(k, j);
if (b[i__2].r != 0.f || b[i__2].i != 0.f) {
i__2 = b_subscr(k, j);
q__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2]
.i, q__1.i = alpha->r * b[i__2].i +
alpha->i * b[i__2].r;
temp.r = q__1.r, temp.i = q__1.i;
i__2 = b_subscr(k, j);
b[i__2].r = temp.r, b[i__2].i = temp.i;
if (nounit) {
i__2 = b_subscr(k, j);
i__3 = b_subscr(k, j);
i__4 = a_subscr(k, k);
q__1.r = b[i__3].r * a[i__4].r - b[i__3].i *
a[i__4].i, q__1.i = b[i__3].r * a[
i__4].i + b[i__3].i * a[i__4].r;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
}
i__2 = *m;
for (i__ = k + 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = b_subscr(i__, j);
i__5 = a_subscr(i__, k);
q__2.r = temp.r * a[i__5].r - temp.i * a[i__5]
.i, q__2.i = temp.r * a[i__5].i +
temp.i * a[i__5].r;
q__1.r = b[i__4].r + q__2.r, q__1.i = b[i__4]
.i + q__2.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L60: */
}
}
/* L70: */
}
/* L80: */
}
}
} else {
/* Form B := alpha*A'*B or B := alpha*conjg( A' )*B. */
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
for (i__ = *m; i__ >= 1; --i__) {
i__2 = b_subscr(i__, j);
temp.r = b[i__2].r, temp.i = b[i__2].i;
if (noconj) {
if (nounit) {
i__2 = a_subscr(i__, i__);
q__1.r = temp.r * a[i__2].r - temp.i * a[i__2]
.i, q__1.i = temp.r * a[i__2].i +
temp.i * a[i__2].r;
temp.r = q__1.r, temp.i = q__1.i;
}
i__2 = i__ - 1;
for (k = 1; k <= i__2; ++k) {
i__3 = a_subscr(k, i__);
i__4 = b_subscr(k, j);
q__2.r = a[i__3].r * b[i__4].r - a[i__3].i *
b[i__4].i, q__2.i = a[i__3].r * b[
i__4].i + a[i__3].i * b[i__4].r;
q__1.r = temp.r + q__2.r, q__1.i = temp.i +
q__2.i;
temp.r = q__1.r, temp.i = q__1.i;
/* L90: */
}
} else {
if (nounit) {
r_cnjg(&q__2, &a_ref(i__, i__));
q__1.r = temp.r * q__2.r - temp.i * q__2.i,
q__1.i = temp.r * q__2.i + temp.i *
q__2.r;
temp.r = q__1.r, temp.i = q__1.i;
}
i__2 = i__ - 1;
for (k = 1; k <= i__2; ++k) {
r_cnjg(&q__3, &a_ref(k, i__));
i__3 = b_subscr(k, j);
q__2.r = q__3.r * b[i__3].r - q__3.i * b[i__3]
.i, q__2.i = q__3.r * b[i__3].i +
q__3.i * b[i__3].r;
q__1.r = temp.r + q__2.r, q__1.i = temp.i +
q__2.i;
temp.r = q__1.r, temp.i = q__1.i;
/* L100: */
}
}
i__2 = b_subscr(i__, j);
q__1.r = alpha->r * temp.r - alpha->i * temp.i,
q__1.i = alpha->r * temp.i + alpha->i *
temp.r;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L110: */
}
/* L120: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
temp.r = b[i__3].r, temp.i = b[i__3].i;
if (noconj) {
if (nounit) {
i__3 = a_subscr(i__, i__);
q__1.r = temp.r * a[i__3].r - temp.i * a[i__3]
.i, q__1.i = temp.r * a[i__3].i +
temp.i * a[i__3].r;
temp.r = q__1.r, temp.i = q__1.i;
}
i__3 = *m;
for (k = i__ + 1; k <= i__3; ++k) {
i__4 = a_subscr(k, i__);
i__5 = b_subscr(k, j);
q__2.r = a[i__4].r * b[i__5].r - a[i__4].i *
b[i__5].i, q__2.i = a[i__4].r * b[
i__5].i + a[i__4].i * b[i__5].r;
q__1.r = temp.r + q__2.r, q__1.i = temp.i +
q__2.i;
temp.r = q__1.r, temp.i = q__1.i;
/* L130: */
}
} else {
if (nounit) {
r_cnjg(&q__2, &a_ref(i__, i__));
q__1.r = temp.r * q__2.r - temp.i * q__2.i,
q__1.i = temp.r * q__2.i + temp.i *
q__2.r;
temp.r = q__1.r, temp.i = q__1.i;
}
i__3 = *m;
for (k = i__ + 1; k <= i__3; ++k) {
r_cnjg(&q__3, &a_ref(k, i__));
i__4 = b_subscr(k, j);
q__2.r = q__3.r * b[i__4].r - q__3.i * b[i__4]
.i, q__2.i = q__3.r * b[i__4].i +
q__3.i * b[i__4].r;
q__1.r = temp.r + q__2.r, q__1.i = temp.i +
q__2.i;
temp.r = q__1.r, temp.i = q__1.i;
/* L140: */
}
}
i__3 = b_subscr(i__, j);
q__1.r = alpha->r * temp.r - alpha->i * temp.i,
q__1.i = alpha->r * temp.i + alpha->i *
temp.r;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L150: */
}
/* L160: */
}
}
}
} else {
if (lsame_(transa, "N")) {
/* Form B := alpha*B*A. */
if (upper) {
for (j = *n; j >= 1; --j) {
temp.r = alpha->r, temp.i = alpha->i;
if (nounit) {
i__1 = a_subscr(j, j);
q__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i,
q__1.i = temp.r * a[i__1].i + temp.i * a[i__1]
.r;
temp.r = q__1.r, temp.i = q__1.i;
}
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = b_subscr(i__, j);
i__3 = b_subscr(i__, j);
q__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i,
q__1.i = temp.r * b[i__3].i + temp.i * b[i__3]
.r;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L170: */
}
i__1 = j - 1;
for (k = 1; k <= i__1; ++k) {
i__2 = a_subscr(k, j);
if (a[i__2].r != 0.f || a[i__2].i != 0.f) {
i__2 = a_subscr(k, j);
q__1.r = alpha->r * a[i__2].r - alpha->i * a[i__2]
.i, q__1.i = alpha->r * a[i__2].i +
alpha->i * a[i__2].r;
temp.r = q__1.r, temp.i = q__1.i;
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = b_subscr(i__, j);
i__5 = b_subscr(i__, k);
q__2.r = temp.r * b[i__5].r - temp.i * b[i__5]
.i, q__2.i = temp.r * b[i__5].i +
temp.i * b[i__5].r;
q__1.r = b[i__4].r + q__2.r, q__1.i = b[i__4]
.i + q__2.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L180: */
}
}
/* L190: */
}
/* L200: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp.r = alpha->r, temp.i = alpha->i;
if (nounit) {
i__2 = a_subscr(j, j);
q__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
q__1.i = temp.r * a[i__2].i + temp.i * a[i__2]
.r;
temp.r = q__1.r, temp.i = q__1.i;
}
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = b_subscr(i__, j);
q__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i,
q__1.i = temp.r * b[i__4].i + temp.i * b[i__4]
.r;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L210: */
}
i__2 = *n;
for (k = j + 1; k <= i__2; ++k) {
i__3 = a_subscr(k, j);
if (a[i__3].r != 0.f || a[i__3].i != 0.f) {
i__3 = a_subscr(k, j);
q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3]
.i, q__1.i = alpha->r * a[i__3].i +
alpha->i * a[i__3].r;
temp.r = q__1.r, temp.i = q__1.i;
i__3 = *m;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = b_subscr(i__, j);
i__5 = b_subscr(i__, j);
i__6 = b_subscr(i__, k);
q__2.r = temp.r * b[i__6].r - temp.i * b[i__6]
.i, q__2.i = temp.r * b[i__6].i +
temp.i * b[i__6].r;
q__1.r = b[i__5].r + q__2.r, q__1.i = b[i__5]
.i + q__2.i;
b[i__4].r = q__1.r, b[i__4].i = q__1.i;
/* L220: */
}
}
/* L230: */
}
/* L240: */
}
}
} else {
/* Form B := alpha*B*A' or B := alpha*B*conjg( A' ). */
if (upper) {
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
i__2 = k - 1;
for (j = 1; j <= i__2; ++j) {
i__3 = a_subscr(j, k);
if (a[i__3].r != 0.f || a[i__3].i != 0.f) {
if (noconj) {
i__3 = a_subscr(j, k);
q__1.r = alpha->r * a[i__3].r - alpha->i * a[
i__3].i, q__1.i = alpha->r * a[i__3]
.i + alpha->i * a[i__3].r;
temp.r = q__1.r, temp.i = q__1.i;
} else {
r_cnjg(&q__2, &a_ref(j, k));
q__1.r = alpha->r * q__2.r - alpha->i *
q__2.i, q__1.i = alpha->r * q__2.i +
alpha->i * q__2.r;
temp.r = q__1.r, temp.i = q__1.i;
}
i__3 = *m;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = b_subscr(i__, j);
i__5 = b_subscr(i__, j);
i__6 = b_subscr(i__, k);
q__2.r = temp.r * b[i__6].r - temp.i * b[i__6]
.i, q__2.i = temp.r * b[i__6].i +
temp.i * b[i__6].r;
q__1.r = b[i__5].r + q__2.r, q__1.i = b[i__5]
.i + q__2.i;
b[i__4].r = q__1.r, b[i__4].i = q__1.i;
/* L250: */
}
}
/* L260: */
}
temp.r = alpha->r, temp.i = alpha->i;
if (nounit) {
if (noconj) {
i__2 = a_subscr(k, k);
q__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
q__1.i = temp.r * a[i__2].i + temp.i * a[
i__2].r;
temp.r = q__1.r, temp.i = q__1.i;
} else {
r_cnjg(&q__2, &a_ref(k, k));
q__1.r = temp.r * q__2.r - temp.i * q__2.i,
q__1.i = temp.r * q__2.i + temp.i *
q__2.r;
temp.r = q__1.r, temp.i = q__1.i;
}
}
if (temp.r != 1.f || temp.i != 0.f) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, k);
i__4 = b_subscr(i__, k);
q__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i,
q__1.i = temp.r * b[i__4].i + temp.i * b[
i__4].r;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L270: */
}
}
/* L280: */
}
} else {
for (k = *n; k >= 1; --k) {
i__1 = *n;
for (j = k + 1; j <= i__1; ++j) {
i__2 = a_subscr(j, k);
if (a[i__2].r != 0.f || a[i__2].i != 0.f) {
if (noconj) {
i__2 = a_subscr(j, k);
q__1.r = alpha->r * a[i__2].r - alpha->i * a[
i__2].i, q__1.i = alpha->r * a[i__2]
.i + alpha->i * a[i__2].r;
temp.r = q__1.r, temp.i = q__1.i;
} else {
r_cnjg(&q__2, &a_ref(j, k));
q__1.r = alpha->r * q__2.r - alpha->i *
q__2.i, q__1.i = alpha->r * q__2.i +
alpha->i * q__2.r;
temp.r = q__1.r, temp.i = q__1.i;
}
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = b_subscr(i__, j);
i__5 = b_subscr(i__, k);
q__2.r = temp.r * b[i__5].r - temp.i * b[i__5]
.i, q__2.i = temp.r * b[i__5].i +
temp.i * b[i__5].r;
q__1.r = b[i__4].r + q__2.r, q__1.i = b[i__4]
.i + q__2.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L290: */
}
}
/* L300: */
}
temp.r = alpha->r, temp.i = alpha->i;
if (nounit) {
if (noconj) {
i__1 = a_subscr(k, k);
q__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i,
q__1.i = temp.r * a[i__1].i + temp.i * a[
i__1].r;
temp.r = q__1.r, temp.i = q__1.i;
} else {
r_cnjg(&q__2, &a_ref(k, k));
q__1.r = temp.r * q__2.r - temp.i * q__2.i,
q__1.i = temp.r * q__2.i + temp.i *
q__2.r;
temp.r = q__1.r, temp.i = q__1.i;
}
}
if (temp.r != 1.f || temp.i != 0.f) {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = b_subscr(i__, k);
i__3 = b_subscr(i__, k);
q__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i,
q__1.i = temp.r * b[i__3].i + temp.i * b[
i__3].r;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L310: */
}
}
/* L320: */
}
}
}
}
return 0;
/* End of CTRMM . */
} /* ctrmm_ */
/* Subroutine */ int zerrec_(char *path, integer *nunit)
{
/* Format strings */
static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
"rror exits (\002,i3,\002 tests done)\002)";
static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
"ts of the error \002,\002exits ***\002)";
/* System generated locals */
integer i__1;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer info, ifst, ilst;
static doublecomplex work[24], a[16] /* was [4][4] */, b[16] /*
was [4][4] */, c__[16] /* was [4][4] */;
static integer i__, j, m;
static doublereal s[4], scale;
static doublecomplex x[4];
static integer nt;
static doublereal rw[24];
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), ztrexc_(char *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, integer *, integer *,
integer *), ztrsna_(char *, char *, logical *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *, integer *,
integer *, doublecomplex *, integer *, doublereal *, integer *), ztrsen_(char *, char *, logical *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *,
doublecomplex *, integer *, integer *), ztrsyl_(
char *, char *, integer *, integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, integer *);
static logical sel[4];
static doublereal sep[4];
/* Fortran I/O blocks */
static cilist io___18 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___19 = { 0, 0, 0, fmt_9998, 0 };
#define a_subscr(a_1,a_2) (a_2)*4 + a_1 - 5
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*4 + a_1 - 5
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
ZERREC tests the error exits for the routines for eigen- condition
estimation for DOUBLE PRECISION matrices:
ZTRSYL, CTREXC, CTRSNA and CTRSEN.
Arguments
=========
PATH (input) CHARACTER*3
The LAPACK path name for the routines to be tested.
NUNIT (input) INTEGER
The unit number for output.
===================================================================== */
infoc_1.nout = *nunit;
infoc_1.ok = TRUE_;
nt = 0;
/* Initialize A, B and SEL */
for (j = 1; j <= 4; ++j) {
for (i__ = 1; i__ <= 4; ++i__) {
i__1 = a_subscr(i__, j);
a[i__1].r = 0., a[i__1].i = 0.;
i__1 = b_subscr(i__, j);
b[i__1].r = 0., b[i__1].i = 0.;
/* L10: */
}
/* L20: */
}
for (i__ = 1; i__ <= 4; ++i__) {
i__1 = a_subscr(i__, i__);
a[i__1].r = 1., a[i__1].i = 0.;
sel[i__ - 1] = TRUE_;
/* L30: */
}
/* Test ZTRSYL */
s_copy(srnamc_1.srnamt, "ZTRSYL", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
ztrsyl_("X", "N", &c__1, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ztrsyl_("N", "X", &c__1, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
ztrsyl_("N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ztrsyl_("N", "N", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
ztrsyl_("N", "N", &c__1, &c__0, &c_n1, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
ztrsyl_("N", "N", &c__1, &c__2, &c__0, a, &c__1, b, &c__1, c__, &c__2, &
scale, &info);
chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
ztrsyl_("N", "N", &c__1, &c__0, &c__2, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
ztrsyl_("N", "N", &c__1, &c__2, &c__0, a, &c__2, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 8;
/* Test ZTREXC */
s_copy(srnamc_1.srnamt, "ZTREXC", (ftnlen)6, (ftnlen)6);
ifst = 1;
ilst = 1;
infoc_1.infot = 1;
ztrexc_("X", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info);
chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
ztrexc_("N", &c__0, a, &c__1, b, &c__1, &ifst, &ilst, &info);
chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ilst = 2;
ztrexc_("N", &c__2, a, &c__1, b, &c__1, &ifst, &ilst, &info);
chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
ztrexc_("V", &c__2, a, &c__2, b, &c__1, &ifst, &ilst, &info);
chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
ifst = 0;
ilst = 1;
ztrexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info);
chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
ifst = 2;
ztrexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info);
chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
ifst = 1;
ilst = 0;
ztrexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info);
chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
ilst = 2;
ztrexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info);
chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 8;
/* Test ZTRSNA */
s_copy(srnamc_1.srnamt, "ZTRSNA", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
ztrsna_("X", "A", sel, &c__0, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__1, &m, work, &c__1, rw, &info);
chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ztrsna_("B", "X", sel, &c__0, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__1, &m, work, &c__1, rw, &info);
chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ztrsna_("B", "A", sel, &c_n1, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__1, &m, work, &c__1, rw, &info);
chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
ztrsna_("V", "A", sel, &c__2, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__2, &m, work, &c__2, rw, &info);
chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
ztrsna_("B", "A", sel, &c__2, a, &c__2, b, &c__1, c__, &c__2, s, sep, &
c__2, &m, work, &c__2, rw, &info);
chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
ztrsna_("B", "A", sel, &c__2, a, &c__2, b, &c__2, c__, &c__1, s, sep, &
c__2, &m, work, &c__2, rw, &info);
chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
ztrsna_("B", "A", sel, &c__1, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__0, &m, work, &c__1, rw, &info);
chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
ztrsna_("B", "S", sel, &c__2, a, &c__2, b, &c__2, c__, &c__2, s, sep, &
c__1, &m, work, &c__1, rw, &info);
chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 16;
ztrsna_("B", "A", sel, &c__2, a, &c__2, b, &c__2, c__, &c__2, s, sep, &
c__2, &m, work, &c__1, rw, &info);
chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 9;
/* Test ZTRSEN */
sel[0] = FALSE_;
s_copy(srnamc_1.srnamt, "ZTRSEN", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
ztrsen_("X", "N", sel, &c__0, a, &c__1, b, &c__1, x, &m, s, sep, work, &
c__1, &info);
chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ztrsen_("N", "X", sel, &c__0, a, &c__1, b, &c__1, x, &m, s, sep, work, &
c__1, &info);
chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ztrsen_("N", "N", sel, &c_n1, a, &c__1, b, &c__1, x, &m, s, sep, work, &
c__1, &info);
chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
ztrsen_("N", "N", sel, &c__2, a, &c__1, b, &c__1, x, &m, s, sep, work, &
c__2, &info);
chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
ztrsen_("N", "V", sel, &c__2, a, &c__2, b, &c__1, x, &m, s, sep, work, &
c__1, &info);
chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 14;
ztrsen_("N", "V", sel, &c__2, a, &c__2, b, &c__2, x, &m, s, sep, work, &
c__0, &info);
chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 14;
ztrsen_("E", "V", sel, &c__3, a, &c__3, b, &c__3, x, &m, s, sep, work, &
c__1, &info);
chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 14;
ztrsen_("V", "V", sel, &c__3, a, &c__3, b, &c__3, x, &m, s, sep, work, &
c__3, &info);
chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 8;
/* Print a summary line. */
if (infoc_1.ok) {
io___18.ciunit = infoc_1.nout;
s_wsfe(&io___18);
do_fio(&c__1, path, (ftnlen)3);
do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___19.ciunit = infoc_1.nout;
s_wsfe(&io___19);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
return 0;
/* End of ZERREC */
} /* zerrec_ */
/* Subroutine */ int clagtm_(char *trans, integer *n, integer *nrhs, real *
alpha, complex *dl, complex *d__, complex *du, complex *x, integer *
ldx, real *beta, complex *b, integer *ldb)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
CLAGTM performs a matrix-vector product of the form
B := alpha * A * X + beta * B
where A is a tridiagonal matrix of order N, B and X are N by NRHS
matrices, and alpha and beta are real scalars, each of which may be
0., 1., or -1.
Arguments
=========
TRANS (input) CHARACTER
Specifies the operation applied to A.
= 'N': No transpose, B := alpha * A * X + beta * B
= 'T': Transpose, B := alpha * A**T * X + beta * B
= 'C': Conjugate transpose, B := alpha * A**H * X + beta * B
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) REAL
The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise,
it is assumed to be 0.
DL (input) COMPLEX array, dimension (N-1)
The (n-1) sub-diagonal elements of T.
D (input) COMPLEX array, dimension (N)
The diagonal elements of T.
DU (input) COMPLEX array, dimension (N-1)
The (n-1) super-diagonal elements of T.
X (input) COMPLEX 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) REAL
The scalar beta. BETA must be 0., 1., or -1.; otherwise,
it is assumed to be 1.
B (input/output) COMPLEX 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 */
/* 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, i__10;
complex q__1, q__2, q__3, q__4, q__5, q__6, q__7, q__8, q__9;
/* Builtin functions */
void r_cnjg(complex *, complex *);
/* 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)]
--dl;
--d__;
--du;
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;
}
/* Multiply B by BETA if BETA.NE.1. */
if (*beta == 0.f) {
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.f, b[i__3].i = 0.f;
/* L10: */
}
/* L20: */
}
} else if (*beta == -1.f) {
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);
q__1.r = -b[i__4].r, q__1.i = -b[i__4].i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L30: */
}
/* L40: */
}
}
if (*alpha == 1.f) {
if (lsame_(trans, "N")) {
/* Compute B := B + A*X */
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);
q__2.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
q__2.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
.r;
q__1.r = b[i__3].r + q__2.r, q__1.i = b[i__3].i + q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
} else {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
i__4 = x_subscr(1, j);
q__3.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
q__3.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
.r;
q__2.r = b[i__3].r + q__3.r, q__2.i = b[i__3].i + q__3.i;
i__5 = x_subscr(2, j);
q__4.r = du[1].r * x[i__5].r - du[1].i * x[i__5].i,
q__4.i = du[1].r * x[i__5].i + du[1].i * x[i__5]
.r;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
b[i__2].r = q__1.r, b[i__2].i = q__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);
q__3.r = dl[i__4].r * x[i__5].r - dl[i__4].i * x[i__5].i,
q__3.i = dl[i__4].r * x[i__5].i + dl[i__4].i * x[
i__5].r;
q__2.r = b[i__3].r + q__3.r, q__2.i = b[i__3].i + q__3.i;
i__6 = *n;
i__7 = x_subscr(*n, j);
q__4.r = d__[i__6].r * x[i__7].r - d__[i__6].i * x[i__7]
.i, q__4.i = d__[i__6].r * x[i__7].i + d__[i__6]
.i * x[i__7].r;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
b[i__2].r = q__1.r, b[i__2].i = q__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);
q__4.r = dl[i__5].r * x[i__6].r - dl[i__5].i * x[i__6]
.i, q__4.i = dl[i__5].r * x[i__6].i + dl[i__5]
.i * x[i__6].r;
q__3.r = b[i__4].r + q__4.r, q__3.i = b[i__4].i +
q__4.i;
i__7 = i__;
i__8 = x_subscr(i__, j);
q__5.r = d__[i__7].r * x[i__8].r - d__[i__7].i * x[
i__8].i, q__5.i = d__[i__7].r * x[i__8].i +
d__[i__7].i * x[i__8].r;
q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
i__9 = i__;
i__10 = x_subscr(i__ + 1, j);
q__6.r = du[i__9].r * x[i__10].r - du[i__9].i * x[
i__10].i, q__6.i = du[i__9].r * x[i__10].i +
du[i__9].i * x[i__10].r;
q__1.r = q__2.r + q__6.r, q__1.i = q__2.i + q__6.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L50: */
}
}
/* L60: */
}
} else if (lsame_(trans, "T")) {
/* Compute B := B + A**T * X */
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);
q__2.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
q__2.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
.r;
q__1.r = b[i__3].r + q__2.r, q__1.i = b[i__3].i + q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
} else {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
i__4 = x_subscr(1, j);
q__3.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
q__3.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
.r;
q__2.r = b[i__3].r + q__3.r, q__2.i = b[i__3].i + q__3.i;
i__5 = x_subscr(2, j);
q__4.r = dl[1].r * x[i__5].r - dl[1].i * x[i__5].i,
q__4.i = dl[1].r * x[i__5].i + dl[1].i * x[i__5]
.r;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
b[i__2].r = q__1.r, b[i__2].i = q__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);
q__3.r = du[i__4].r * x[i__5].r - du[i__4].i * x[i__5].i,
q__3.i = du[i__4].r * x[i__5].i + du[i__4].i * x[
i__5].r;
q__2.r = b[i__3].r + q__3.r, q__2.i = b[i__3].i + q__3.i;
i__6 = *n;
i__7 = x_subscr(*n, j);
q__4.r = d__[i__6].r * x[i__7].r - d__[i__6].i * x[i__7]
.i, q__4.i = d__[i__6].r * x[i__7].i + d__[i__6]
.i * x[i__7].r;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
b[i__2].r = q__1.r, b[i__2].i = q__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);
q__4.r = du[i__5].r * x[i__6].r - du[i__5].i * x[i__6]
.i, q__4.i = du[i__5].r * x[i__6].i + du[i__5]
.i * x[i__6].r;
q__3.r = b[i__4].r + q__4.r, q__3.i = b[i__4].i +
q__4.i;
i__7 = i__;
i__8 = x_subscr(i__, j);
q__5.r = d__[i__7].r * x[i__8].r - d__[i__7].i * x[
i__8].i, q__5.i = d__[i__7].r * x[i__8].i +
d__[i__7].i * x[i__8].r;
q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
i__9 = i__;
i__10 = x_subscr(i__ + 1, j);
q__6.r = dl[i__9].r * x[i__10].r - dl[i__9].i * x[
i__10].i, q__6.i = dl[i__9].r * x[i__10].i +
dl[i__9].i * x[i__10].r;
q__1.r = q__2.r + q__6.r, q__1.i = q__2.i + q__6.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L70: */
}
}
/* L80: */
}
} else if (lsame_(trans, "C")) {
/* Compute B := B + A**H * X */
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);
r_cnjg(&q__3, &d__[1]);
i__4 = x_subscr(1, j);
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i =
q__3.r * x[i__4].i + q__3.i * x[i__4].r;
q__1.r = b[i__3].r + q__2.r, q__1.i = b[i__3].i + q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
} else {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
r_cnjg(&q__4, &d__[1]);
i__4 = x_subscr(1, j);
q__3.r = q__4.r * x[i__4].r - q__4.i * x[i__4].i, q__3.i =
q__4.r * x[i__4].i + q__4.i * x[i__4].r;
q__2.r = b[i__3].r + q__3.r, q__2.i = b[i__3].i + q__3.i;
r_cnjg(&q__6, &dl[1]);
i__5 = x_subscr(2, j);
q__5.r = q__6.r * x[i__5].r - q__6.i * x[i__5].i, q__5.i =
q__6.r * x[i__5].i + q__6.i * x[i__5].r;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = b_subscr(*n, j);
i__3 = b_subscr(*n, j);
r_cnjg(&q__4, &du[*n - 1]);
i__4 = x_subscr(*n - 1, j);
q__3.r = q__4.r * x[i__4].r - q__4.i * x[i__4].i, q__3.i =
q__4.r * x[i__4].i + q__4.i * x[i__4].r;
q__2.r = b[i__3].r + q__3.r, q__2.i = b[i__3].i + q__3.i;
r_cnjg(&q__6, &d__[*n]);
i__5 = x_subscr(*n, j);
q__5.r = q__6.r * x[i__5].r - q__6.i * x[i__5].i, q__5.i =
q__6.r * x[i__5].i + q__6.i * x[i__5].r;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
b[i__2].r = q__1.r, b[i__2].i = q__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);
r_cnjg(&q__5, &du[i__ - 1]);
i__5 = x_subscr(i__ - 1, j);
q__4.r = q__5.r * x[i__5].r - q__5.i * x[i__5].i,
q__4.i = q__5.r * x[i__5].i + q__5.i * x[i__5]
.r;
q__3.r = b[i__4].r + q__4.r, q__3.i = b[i__4].i +
q__4.i;
r_cnjg(&q__7, &d__[i__]);
i__6 = x_subscr(i__, j);
q__6.r = q__7.r * x[i__6].r - q__7.i * x[i__6].i,
q__6.i = q__7.r * x[i__6].i + q__7.i * x[i__6]
.r;
q__2.r = q__3.r + q__6.r, q__2.i = q__3.i + q__6.i;
r_cnjg(&q__9, &dl[i__]);
i__7 = x_subscr(i__ + 1, j);
q__8.r = q__9.r * x[i__7].r - q__9.i * x[i__7].i,
q__8.i = q__9.r * x[i__7].i + q__9.i * x[i__7]
.r;
q__1.r = q__2.r + q__8.r, q__1.i = q__2.i + q__8.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L90: */
}
}
/* L100: */
}
}
} else if (*alpha == -1.f) {
if (lsame_(trans, "N")) {
/* Compute B := B - A*X */
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);
q__2.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
q__2.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
.r;
q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
} else {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
i__4 = x_subscr(1, j);
q__3.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
q__3.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
.r;
q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
i__5 = x_subscr(2, j);
q__4.r = du[1].r * x[i__5].r - du[1].i * x[i__5].i,
q__4.i = du[1].r * x[i__5].i + du[1].i * x[i__5]
.r;
q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
b[i__2].r = q__1.r, b[i__2].i = q__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);
q__3.r = dl[i__4].r * x[i__5].r - dl[i__4].i * x[i__5].i,
q__3.i = dl[i__4].r * x[i__5].i + dl[i__4].i * x[
i__5].r;
q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
i__6 = *n;
i__7 = x_subscr(*n, j);
q__4.r = d__[i__6].r * x[i__7].r - d__[i__6].i * x[i__7]
.i, q__4.i = d__[i__6].r * x[i__7].i + d__[i__6]
.i * x[i__7].r;
q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
b[i__2].r = q__1.r, b[i__2].i = q__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);
q__4.r = dl[i__5].r * x[i__6].r - dl[i__5].i * x[i__6]
.i, q__4.i = dl[i__5].r * x[i__6].i + dl[i__5]
.i * x[i__6].r;
q__3.r = b[i__4].r - q__4.r, q__3.i = b[i__4].i -
q__4.i;
i__7 = i__;
i__8 = x_subscr(i__, j);
q__5.r = d__[i__7].r * x[i__8].r - d__[i__7].i * x[
i__8].i, q__5.i = d__[i__7].r * x[i__8].i +
d__[i__7].i * x[i__8].r;
q__2.r = q__3.r - q__5.r, q__2.i = q__3.i - q__5.i;
i__9 = i__;
i__10 = x_subscr(i__ + 1, j);
q__6.r = du[i__9].r * x[i__10].r - du[i__9].i * x[
i__10].i, q__6.i = du[i__9].r * x[i__10].i +
du[i__9].i * x[i__10].r;
q__1.r = q__2.r - q__6.r, q__1.i = q__2.i - q__6.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L110: */
}
}
/* L120: */
}
} else if (lsame_(trans, "T")) {
/* Compute B := B - A'*X */
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);
q__2.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
q__2.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
.r;
q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
} else {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
i__4 = x_subscr(1, j);
q__3.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
q__3.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
.r;
q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
i__5 = x_subscr(2, j);
q__4.r = dl[1].r * x[i__5].r - dl[1].i * x[i__5].i,
q__4.i = dl[1].r * x[i__5].i + dl[1].i * x[i__5]
.r;
q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
b[i__2].r = q__1.r, b[i__2].i = q__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);
q__3.r = du[i__4].r * x[i__5].r - du[i__4].i * x[i__5].i,
q__3.i = du[i__4].r * x[i__5].i + du[i__4].i * x[
i__5].r;
q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
i__6 = *n;
i__7 = x_subscr(*n, j);
q__4.r = d__[i__6].r * x[i__7].r - d__[i__6].i * x[i__7]
.i, q__4.i = d__[i__6].r * x[i__7].i + d__[i__6]
.i * x[i__7].r;
q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
b[i__2].r = q__1.r, b[i__2].i = q__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);
q__4.r = du[i__5].r * x[i__6].r - du[i__5].i * x[i__6]
.i, q__4.i = du[i__5].r * x[i__6].i + du[i__5]
.i * x[i__6].r;
q__3.r = b[i__4].r - q__4.r, q__3.i = b[i__4].i -
q__4.i;
i__7 = i__;
i__8 = x_subscr(i__, j);
q__5.r = d__[i__7].r * x[i__8].r - d__[i__7].i * x[
i__8].i, q__5.i = d__[i__7].r * x[i__8].i +
d__[i__7].i * x[i__8].r;
q__2.r = q__3.r - q__5.r, q__2.i = q__3.i - q__5.i;
i__9 = i__;
i__10 = x_subscr(i__ + 1, j);
q__6.r = dl[i__9].r * x[i__10].r - dl[i__9].i * x[
i__10].i, q__6.i = dl[i__9].r * x[i__10].i +
dl[i__9].i * x[i__10].r;
q__1.r = q__2.r - q__6.r, q__1.i = q__2.i - q__6.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L130: */
}
}
/* L140: */
}
} else if (lsame_(trans, "C")) {
/* Compute B := B - A'*X */
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);
r_cnjg(&q__3, &d__[1]);
i__4 = x_subscr(1, j);
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i =
q__3.r * x[i__4].i + q__3.i * x[i__4].r;
q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
} else {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
r_cnjg(&q__4, &d__[1]);
i__4 = x_subscr(1, j);
q__3.r = q__4.r * x[i__4].r - q__4.i * x[i__4].i, q__3.i =
q__4.r * x[i__4].i + q__4.i * x[i__4].r;
q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
r_cnjg(&q__6, &dl[1]);
i__5 = x_subscr(2, j);
q__5.r = q__6.r * x[i__5].r - q__6.i * x[i__5].i, q__5.i =
q__6.r * x[i__5].i + q__6.i * x[i__5].r;
q__1.r = q__2.r - q__5.r, q__1.i = q__2.i - q__5.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = b_subscr(*n, j);
i__3 = b_subscr(*n, j);
r_cnjg(&q__4, &du[*n - 1]);
i__4 = x_subscr(*n - 1, j);
q__3.r = q__4.r * x[i__4].r - q__4.i * x[i__4].i, q__3.i =
q__4.r * x[i__4].i + q__4.i * x[i__4].r;
q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
r_cnjg(&q__6, &d__[*n]);
i__5 = x_subscr(*n, j);
q__5.r = q__6.r * x[i__5].r - q__6.i * x[i__5].i, q__5.i =
q__6.r * x[i__5].i + q__6.i * x[i__5].r;
q__1.r = q__2.r - q__5.r, q__1.i = q__2.i - q__5.i;
b[i__2].r = q__1.r, b[i__2].i = q__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);
r_cnjg(&q__5, &du[i__ - 1]);
i__5 = x_subscr(i__ - 1, j);
q__4.r = q__5.r * x[i__5].r - q__5.i * x[i__5].i,
q__4.i = q__5.r * x[i__5].i + q__5.i * x[i__5]
.r;
q__3.r = b[i__4].r - q__4.r, q__3.i = b[i__4].i -
q__4.i;
r_cnjg(&q__7, &d__[i__]);
i__6 = x_subscr(i__, j);
q__6.r = q__7.r * x[i__6].r - q__7.i * x[i__6].i,
q__6.i = q__7.r * x[i__6].i + q__7.i * x[i__6]
.r;
q__2.r = q__3.r - q__6.r, q__2.i = q__3.i - q__6.i;
r_cnjg(&q__9, &dl[i__]);
i__7 = x_subscr(i__ + 1, j);
q__8.r = q__9.r * x[i__7].r - q__9.i * x[i__7].i,
q__8.i = q__9.r * x[i__7].i + q__9.i * x[i__7]
.r;
q__1.r = q__2.r - q__8.r, q__1.i = q__2.i - q__8.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L150: */
}
}
/* L160: */
}
}
}
return 0;
/* End of CLAGTM */
} /* clagtm_ */
/* Subroutine */ int ctgevc_(char *side, char *howmny, logical *select,
integer *n, complex *a, integer *lda, complex *b, integer *ldb,
complex *vl, integer *ldvl, complex *vr, integer *ldvr, integer *mm,
integer *m, complex *work, real *rwork, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
CTGEVC computes some or all of the right and/or left generalized
eigenvectors of a pair of complex upper triangular matrices (A,B).
The right generalized eigenvector x and the left generalized
eigenvector y of (A,B) corresponding to a generalized eigenvalue
w are defined by:
(A - wB) * x = 0 and y**H * (A - wB) = 0
where y**H denotes the conjugate tranpose of y.
If an eigenvalue w is determined by zero diagonal elements of both A
and B, a unit vector is returned as the corresponding eigenvector.
If all eigenvectors are requested, the routine may either return
the matrices X and/or Y of right or left eigenvectors of (A,B), or
the products Z*X and/or Q*Y, where Z and Q are input unitary
matrices. If (A,B) was obtained from the generalized Schur
factorization of an original pair of matrices
(A0,B0) = (Q*A*Z**H,Q*B*Z**H),
then Z*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 matrices A and B. N >= 0.
A (input) COMPLEX array, dimension (LDA,N)
The upper triangular matrix A.
LDA (input) INTEGER
The leading dimension of array A. LDA >= max(1,N).
B (input) COMPLEX array, dimension (LDB,N)
The upper triangular matrix B. B must have real diagonal
elements.
LDB (input) INTEGER
The leading dimension of array B. LDB >= max(1,N).
VL (input/output) COMPLEX array, dimension (LDVL,MM)
On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
contain an N-by-N matrix Q (usually the unitary matrix Q
of left Schur vectors returned by CHGEQZ).
On exit, if SIDE = 'L' or 'B', VL contains:
if HOWMNY = 'A', the matrix Y of left eigenvectors of (A,B);
if HOWMNY = 'B', the matrix Q*Y;
if HOWMNY = 'S', the left eigenvectors of (A,B) 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 array VL.
LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
VR (input/output) COMPLEX array, dimension (LDVR,MM)
On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
contain an N-by-N matrix Q (usually the unitary matrix Z
of right Schur vectors returned by CHGEQZ).
On exit, if SIDE = 'R' or 'B', VR contains:
if HOWMNY = 'A', the matrix X of right eigenvectors of (A,B);
if HOWMNY = 'B', the matrix Z*X;
if HOWMNY = 'S', the right eigenvectors of (A,B) 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 array, dimension (2*N)
RWORK (workspace) REAL array, dimension (2*N)
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
=====================================================================
Decode and Test the input parameters
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {0.f,0.f};
static complex c_b2 = {1.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
vr_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4, r__5, r__6;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
static integer ibeg, ieig, iend;
static real dmin__;
static integer isrc;
static real temp;
static complex suma, sumb;
static real xmax;
static complex d__;
static integer i__, j;
static real scale;
static logical ilall;
static integer iside;
static real sbeta;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *);
static real small;
static logical compl;
static real anorm, bnorm;
static logical compr;
static complex ca, cb;
static logical ilbbad;
static real acoefa;
static integer je;
static real bcoefa, acoeff;
static complex bcoeff;
static logical ilback;
static integer im;
extern /* Subroutine */ int slabad_(real *, real *);
static real ascale, bscale;
static integer jr;
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern doublereal slamch_(char *);
static complex salpha;
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real bignum;
static logical ilcomp;
static integer ihwmny;
static real big;
static logical lsa, lsb;
static real ulp;
static complex sum;
#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 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;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_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 */
if (lsame_(howmny, "A")) {
ihwmny = 1;
ilall = TRUE_;
ilback = FALSE_;
} else if (lsame_(howmny, "S")) {
ihwmny = 2;
ilall = FALSE_;
ilback = FALSE_;
} else if (lsame_(howmny, "B") || lsame_(howmny,
"T")) {
ihwmny = 3;
ilall = TRUE_;
ilback = TRUE_;
} else {
ihwmny = -1;
}
if (lsame_(side, "R")) {
iside = 1;
compl = FALSE_;
compr = TRUE_;
} else if (lsame_(side, "L")) {
iside = 2;
compl = TRUE_;
compr = FALSE_;
} else if (lsame_(side, "B")) {
iside = 3;
compl = TRUE_;
compr = TRUE_;
} else {
iside = -1;
}
*info = 0;
if (iside < 0) {
*info = -1;
} else if (ihwmny < 0) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldb < max(1,*n)) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTGEVC", &i__1);
return 0;
}
/* Count the number of eigenvectors */
if (! ilall) {
im = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (select[j]) {
++im;
}
/* L10: */
}
} else {
im = *n;
}
/* Check diagonal of B */
ilbbad = FALSE_;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (r_imag(&b_ref(j, j)) != 0.f) {
ilbbad = TRUE_;
}
/* L20: */
}
if (ilbbad) {
*info = -7;
} else if (compl && *ldvl < *n || *ldvl < 1) {
*info = -10;
} else if (compr && *ldvr < *n || *ldvr < 1) {
*info = -12;
} else if (*mm < im) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTGEVC", &i__1);
return 0;
}
/* Quick return if possible */
*m = im;
if (*n == 0) {
return 0;
}
/* Machine Constants */
safmin = slamch_("Safe minimum");
big = 1.f / safmin;
slabad_(&safmin, &big);
ulp = slamch_("Epsilon") * slamch_("Base");
small = safmin * *n / ulp;
big = 1.f / small;
bignum = 1.f / (safmin * *n);
/* Compute the 1-norm of each column of the strictly upper triangular
part of A and B to check for possible overflow in the triangular
solver. */
i__1 = a_subscr(1, 1);
anorm = (r__1 = a[i__1].r, dabs(r__1)) + (r__2 = r_imag(&a_ref(1, 1)),
dabs(r__2));
i__1 = b_subscr(1, 1);
bnorm = (r__1 = b[i__1].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(1, 1)),
dabs(r__2));
rwork[1] = 0.f;
rwork[*n + 1] = 0.f;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
rwork[j] = 0.f;
rwork[*n + j] = 0.f;
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = a_subscr(i__, j);
rwork[j] += (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
a_ref(i__, j)), dabs(r__2));
i__3 = b_subscr(i__, j);
rwork[*n + j] += (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
b_ref(i__, j)), dabs(r__2));
/* L30: */
}
/* Computing MAX */
i__2 = a_subscr(j, j);
r__3 = anorm, r__4 = rwork[j] + ((r__1 = a[i__2].r, dabs(r__1)) + (
r__2 = r_imag(&a_ref(j, j)), dabs(r__2)));
anorm = dmax(r__3,r__4);
/* Computing MAX */
i__2 = b_subscr(j, j);
r__3 = bnorm, r__4 = rwork[*n + j] + ((r__1 = b[i__2].r, dabs(r__1))
+ (r__2 = r_imag(&b_ref(j, j)), dabs(r__2)));
bnorm = dmax(r__3,r__4);
/* L40: */
}
ascale = 1.f / dmax(anorm,safmin);
bscale = 1.f / dmax(bnorm,safmin);
/* Left eigenvectors */
if (compl) {
ieig = 0;
/* Main loop over eigenvalues */
i__1 = *n;
for (je = 1; je <= i__1; ++je) {
if (ilall) {
ilcomp = TRUE_;
} else {
ilcomp = select[je];
}
if (ilcomp) {
++ieig;
i__2 = a_subscr(je, je);
i__3 = b_subscr(je, je);
if ((r__2 = a[i__2].r, dabs(r__2)) + (r__3 = r_imag(&a_ref(je,
je)), dabs(r__3)) <= safmin && (r__1 = b[i__3].r,
dabs(r__1)) <= safmin) {
/* Singular matrix pencil -- return unit eigenvector */
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
i__3 = vl_subscr(jr, ieig);
vl[i__3].r = 0.f, vl[i__3].i = 0.f;
/* L50: */
}
i__2 = vl_subscr(ieig, ieig);
vl[i__2].r = 1.f, vl[i__2].i = 0.f;
goto L140;
}
/* Non-singular eigenvalue:
Compute coefficients a and b in
H
y ( a A - b B ) = 0
Computing MAX */
i__2 = a_subscr(je, je);
i__3 = b_subscr(je, je);
r__4 = ((r__2 = a[i__2].r, dabs(r__2)) + (r__3 = r_imag(&
a_ref(je, je)), dabs(r__3))) * ascale, r__5 = (r__1 =
b[i__3].r, dabs(r__1)) * bscale, r__4 = max(r__4,r__5)
;
temp = 1.f / dmax(r__4,safmin);
i__2 = a_subscr(je, je);
q__2.r = temp * a[i__2].r, q__2.i = temp * a[i__2].i;
q__1.r = ascale * q__2.r, q__1.i = ascale * q__2.i;
salpha.r = q__1.r, salpha.i = q__1.i;
i__2 = b_subscr(je, je);
sbeta = temp * b[i__2].r * bscale;
acoeff = sbeta * ascale;
q__1.r = bscale * salpha.r, q__1.i = bscale * salpha.i;
bcoeff.r = q__1.r, bcoeff.i = q__1.i;
/* Scale to avoid underflow */
lsa = dabs(sbeta) >= safmin && dabs(acoeff) < small;
lsb = (r__1 = salpha.r, dabs(r__1)) + (r__2 = r_imag(&salpha),
dabs(r__2)) >= safmin && (r__3 = bcoeff.r, dabs(r__3)
) + (r__4 = r_imag(&bcoeff), dabs(r__4)) < small;
scale = 1.f;
if (lsa) {
scale = small / dabs(sbeta) * dmin(anorm,big);
}
if (lsb) {
/* Computing MAX */
r__3 = scale, r__4 = small / ((r__1 = salpha.r, dabs(r__1)
) + (r__2 = r_imag(&salpha), dabs(r__2))) * dmin(
bnorm,big);
scale = dmax(r__3,r__4);
}
if (lsa || lsb) {
/* Computing MIN
Computing MAX */
r__5 = 1.f, r__6 = dabs(acoeff), r__5 = max(r__5,r__6),
r__6 = (r__1 = bcoeff.r, dabs(r__1)) + (r__2 =
r_imag(&bcoeff), dabs(r__2));
r__3 = scale, r__4 = 1.f / (safmin * dmax(r__5,r__6));
scale = dmin(r__3,r__4);
if (lsa) {
acoeff = ascale * (scale * sbeta);
} else {
acoeff = scale * acoeff;
}
if (lsb) {
q__2.r = scale * salpha.r, q__2.i = scale * salpha.i;
q__1.r = bscale * q__2.r, q__1.i = bscale * q__2.i;
bcoeff.r = q__1.r, bcoeff.i = q__1.i;
} else {
q__1.r = scale * bcoeff.r, q__1.i = scale * bcoeff.i;
bcoeff.r = q__1.r, bcoeff.i = q__1.i;
}
}
acoefa = dabs(acoeff);
bcoefa = (r__1 = bcoeff.r, dabs(r__1)) + (r__2 = r_imag(&
bcoeff), dabs(r__2));
xmax = 1.f;
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
i__3 = jr;
work[i__3].r = 0.f, work[i__3].i = 0.f;
/* L60: */
}
i__2 = je;
work[i__2].r = 1.f, work[i__2].i = 0.f;
/* Computing MAX */
r__1 = ulp * acoefa * anorm, r__2 = ulp * bcoefa * bnorm,
r__1 = max(r__1,r__2);
dmin__ = dmax(r__1,safmin);
/* H
Triangular solve of (a A - b B) y = 0
H
(rowwise in (a A - b B) , or columnwise in a A - b B) */
i__2 = *n;
for (j = je + 1; j <= i__2; ++j) {
/* Compute
j-1
SUM = sum conjg( a*A(k,j) - b*B(k,j) )*x(k)
k=je
(Scale if necessary) */
temp = 1.f / xmax;
if (acoefa * rwork[j] + bcoefa * rwork[*n + j] > bignum *
temp) {
i__3 = j - 1;
for (jr = je; jr <= i__3; ++jr) {
i__4 = jr;
i__5 = jr;
q__1.r = temp * work[i__5].r, q__1.i = temp *
work[i__5].i;
work[i__4].r = q__1.r, work[i__4].i = q__1.i;
/* L70: */
}
xmax = 1.f;
}
suma.r = 0.f, suma.i = 0.f;
sumb.r = 0.f, sumb.i = 0.f;
i__3 = j - 1;
for (jr = je; jr <= i__3; ++jr) {
r_cnjg(&q__3, &a_ref(jr, j));
i__4 = jr;
q__2.r = q__3.r * work[i__4].r - q__3.i * work[i__4]
.i, q__2.i = q__3.r * work[i__4].i + q__3.i *
work[i__4].r;
q__1.r = suma.r + q__2.r, q__1.i = suma.i + q__2.i;
suma.r = q__1.r, suma.i = q__1.i;
r_cnjg(&q__3, &b_ref(jr, j));
i__4 = jr;
q__2.r = q__3.r * work[i__4].r - q__3.i * work[i__4]
.i, q__2.i = q__3.r * work[i__4].i + q__3.i *
work[i__4].r;
q__1.r = sumb.r + q__2.r, q__1.i = sumb.i + q__2.i;
sumb.r = q__1.r, sumb.i = q__1.i;
/* L80: */
}
q__2.r = acoeff * suma.r, q__2.i = acoeff * suma.i;
r_cnjg(&q__4, &bcoeff);
q__3.r = q__4.r * sumb.r - q__4.i * sumb.i, q__3.i =
q__4.r * sumb.i + q__4.i * sumb.r;
q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
sum.r = q__1.r, sum.i = q__1.i;
/* Form x(j) = - SUM / conjg( a*A(j,j) - b*B(j,j) )
with scaling and perturbation of the denominator */
i__3 = a_subscr(j, j);
q__3.r = acoeff * a[i__3].r, q__3.i = acoeff * a[i__3].i;
i__4 = b_subscr(j, j);
q__4.r = bcoeff.r * b[i__4].r - bcoeff.i * b[i__4].i,
q__4.i = bcoeff.r * b[i__4].i + bcoeff.i * b[i__4]
.r;
q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i;
r_cnjg(&q__1, &q__2);
d__.r = q__1.r, d__.i = q__1.i;
if ((r__1 = d__.r, dabs(r__1)) + (r__2 = r_imag(&d__),
dabs(r__2)) <= dmin__) {
q__1.r = dmin__, q__1.i = 0.f;
d__.r = q__1.r, d__.i = q__1.i;
}
if ((r__1 = d__.r, dabs(r__1)) + (r__2 = r_imag(&d__),
dabs(r__2)) < 1.f) {
if ((r__1 = sum.r, dabs(r__1)) + (r__2 = r_imag(&sum),
dabs(r__2)) >= bignum * ((r__3 = d__.r, dabs(
r__3)) + (r__4 = r_imag(&d__), dabs(r__4)))) {
temp = 1.f / ((r__1 = sum.r, dabs(r__1)) + (r__2 =
r_imag(&sum), dabs(r__2)));
i__3 = j - 1;
for (jr = je; jr <= i__3; ++jr) {
i__4 = jr;
i__5 = jr;
q__1.r = temp * work[i__5].r, q__1.i = temp *
work[i__5].i;
work[i__4].r = q__1.r, work[i__4].i = q__1.i;
/* L90: */
}
xmax = temp * xmax;
q__1.r = temp * sum.r, q__1.i = temp * sum.i;
sum.r = q__1.r, sum.i = q__1.i;
}
}
i__3 = j;
q__2.r = -sum.r, q__2.i = -sum.i;
cladiv_(&q__1, &q__2, &d__);
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* Computing MAX */
i__3 = j;
r__3 = xmax, r__4 = (r__1 = work[i__3].r, dabs(r__1)) + (
r__2 = r_imag(&work[j]), dabs(r__2));
xmax = dmax(r__3,r__4);
/* L100: */
}
/* Back transform eigenvector if HOWMNY='B'. */
if (ilback) {
i__2 = *n + 1 - je;
cgemv_("N", n, &i__2, &c_b2, &vl_ref(1, je), ldvl, &work[
je], &c__1, &c_b1, &work[*n + 1], &c__1);
isrc = 2;
ibeg = 1;
} else {
isrc = 1;
ibeg = je;
}
/* Copy and scale eigenvector into column of VL */
xmax = 0.f;
i__2 = *n;
for (jr = ibeg; jr <= i__2; ++jr) {
/* Computing MAX */
i__3 = (isrc - 1) * *n + jr;
r__3 = xmax, r__4 = (r__1 = work[i__3].r, dabs(r__1)) + (
r__2 = r_imag(&work[(isrc - 1) * *n + jr]), dabs(
r__2));
xmax = dmax(r__3,r__4);
/* L110: */
}
if (xmax > safmin) {
temp = 1.f / xmax;
i__2 = *n;
for (jr = ibeg; jr <= i__2; ++jr) {
i__3 = vl_subscr(jr, ieig);
i__4 = (isrc - 1) * *n + jr;
q__1.r = temp * work[i__4].r, q__1.i = temp * work[
i__4].i;
vl[i__3].r = q__1.r, vl[i__3].i = q__1.i;
/* L120: */
}
} else {
ibeg = *n + 1;
}
i__2 = ibeg - 1;
for (jr = 1; jr <= i__2; ++jr) {
i__3 = vl_subscr(jr, ieig);
vl[i__3].r = 0.f, vl[i__3].i = 0.f;
/* L130: */
}
}
L140:
;
}
}
/* Right eigenvectors */
if (compr) {
ieig = im + 1;
/* Main loop over eigenvalues */
for (je = *n; je >= 1; --je) {
if (ilall) {
ilcomp = TRUE_;
} else {
ilcomp = select[je];
}
if (ilcomp) {
--ieig;
i__1 = a_subscr(je, je);
i__2 = b_subscr(je, je);
if ((r__2 = a[i__1].r, dabs(r__2)) + (r__3 = r_imag(&a_ref(je,
je)), dabs(r__3)) <= safmin && (r__1 = b[i__2].r,
dabs(r__1)) <= safmin) {
/* Singular matrix pencil -- return unit eigenvector */
i__1 = *n;
for (jr = 1; jr <= i__1; ++jr) {
i__2 = vr_subscr(jr, ieig);
vr[i__2].r = 0.f, vr[i__2].i = 0.f;
/* L150: */
}
i__1 = vr_subscr(ieig, ieig);
vr[i__1].r = 1.f, vr[i__1].i = 0.f;
goto L250;
}
/* Non-singular eigenvalue:
Compute coefficients a and b in
( a A - b B ) x = 0
Computing MAX */
i__1 = a_subscr(je, je);
i__2 = b_subscr(je, je);
r__4 = ((r__2 = a[i__1].r, dabs(r__2)) + (r__3 = r_imag(&
a_ref(je, je)), dabs(r__3))) * ascale, r__5 = (r__1 =
b[i__2].r, dabs(r__1)) * bscale, r__4 = max(r__4,r__5)
;
temp = 1.f / dmax(r__4,safmin);
i__1 = a_subscr(je, je);
q__2.r = temp * a[i__1].r, q__2.i = temp * a[i__1].i;
q__1.r = ascale * q__2.r, q__1.i = ascale * q__2.i;
salpha.r = q__1.r, salpha.i = q__1.i;
i__1 = b_subscr(je, je);
sbeta = temp * b[i__1].r * bscale;
acoeff = sbeta * ascale;
q__1.r = bscale * salpha.r, q__1.i = bscale * salpha.i;
bcoeff.r = q__1.r, bcoeff.i = q__1.i;
/* Scale to avoid underflow */
lsa = dabs(sbeta) >= safmin && dabs(acoeff) < small;
lsb = (r__1 = salpha.r, dabs(r__1)) + (r__2 = r_imag(&salpha),
dabs(r__2)) >= safmin && (r__3 = bcoeff.r, dabs(r__3)
) + (r__4 = r_imag(&bcoeff), dabs(r__4)) < small;
scale = 1.f;
if (lsa) {
scale = small / dabs(sbeta) * dmin(anorm,big);
}
if (lsb) {
/* Computing MAX */
r__3 = scale, r__4 = small / ((r__1 = salpha.r, dabs(r__1)
) + (r__2 = r_imag(&salpha), dabs(r__2))) * dmin(
bnorm,big);
scale = dmax(r__3,r__4);
}
if (lsa || lsb) {
/* Computing MIN
Computing MAX */
r__5 = 1.f, r__6 = dabs(acoeff), r__5 = max(r__5,r__6),
r__6 = (r__1 = bcoeff.r, dabs(r__1)) + (r__2 =
r_imag(&bcoeff), dabs(r__2));
r__3 = scale, r__4 = 1.f / (safmin * dmax(r__5,r__6));
scale = dmin(r__3,r__4);
if (lsa) {
acoeff = ascale * (scale * sbeta);
} else {
acoeff = scale * acoeff;
}
if (lsb) {
q__2.r = scale * salpha.r, q__2.i = scale * salpha.i;
q__1.r = bscale * q__2.r, q__1.i = bscale * q__2.i;
bcoeff.r = q__1.r, bcoeff.i = q__1.i;
} else {
q__1.r = scale * bcoeff.r, q__1.i = scale * bcoeff.i;
bcoeff.r = q__1.r, bcoeff.i = q__1.i;
}
}
acoefa = dabs(acoeff);
bcoefa = (r__1 = bcoeff.r, dabs(r__1)) + (r__2 = r_imag(&
bcoeff), dabs(r__2));
xmax = 1.f;
i__1 = *n;
for (jr = 1; jr <= i__1; ++jr) {
i__2 = jr;
work[i__2].r = 0.f, work[i__2].i = 0.f;
/* L160: */
}
i__1 = je;
work[i__1].r = 1.f, work[i__1].i = 0.f;
/* Computing MAX */
r__1 = ulp * acoefa * anorm, r__2 = ulp * bcoefa * bnorm,
r__1 = max(r__1,r__2);
dmin__ = dmax(r__1,safmin);
/* Triangular solve of (a A - b B) x = 0 (columnwise)
WORK(1:j-1) contains sums w,
WORK(j+1:JE) contains x */
i__1 = je - 1;
for (jr = 1; jr <= i__1; ++jr) {
i__2 = jr;
i__3 = a_subscr(jr, je);
q__2.r = acoeff * a[i__3].r, q__2.i = acoeff * a[i__3].i;
i__4 = b_subscr(jr, je);
q__3.r = bcoeff.r * b[i__4].r - bcoeff.i * b[i__4].i,
q__3.i = bcoeff.r * b[i__4].i + bcoeff.i * b[i__4]
.r;
q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L170: */
}
i__1 = je;
work[i__1].r = 1.f, work[i__1].i = 0.f;
for (j = je - 1; j >= 1; --j) {
/* Form x(j) := - w(j) / d
with scaling and perturbation of the denominator */
i__1 = a_subscr(j, j);
q__2.r = acoeff * a[i__1].r, q__2.i = acoeff * a[i__1].i;
i__2 = b_subscr(j, j);
q__3.r = bcoeff.r * b[i__2].r - bcoeff.i * b[i__2].i,
q__3.i = bcoeff.r * b[i__2].i + bcoeff.i * b[i__2]
.r;
q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
d__.r = q__1.r, d__.i = q__1.i;
if ((r__1 = d__.r, dabs(r__1)) + (r__2 = r_imag(&d__),
dabs(r__2)) <= dmin__) {
q__1.r = dmin__, q__1.i = 0.f;
d__.r = q__1.r, d__.i = q__1.i;
}
if ((r__1 = d__.r, dabs(r__1)) + (r__2 = r_imag(&d__),
dabs(r__2)) < 1.f) {
i__1 = j;
if ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 =
r_imag(&work[j]), dabs(r__2)) >= bignum * ((
r__3 = d__.r, dabs(r__3)) + (r__4 = r_imag(&
d__), dabs(r__4)))) {
i__1 = j;
temp = 1.f / ((r__1 = work[i__1].r, dabs(r__1)) +
(r__2 = r_imag(&work[j]), dabs(r__2)));
i__1 = je;
for (jr = 1; jr <= i__1; ++jr) {
i__2 = jr;
i__3 = jr;
q__1.r = temp * work[i__3].r, q__1.i = temp *
work[i__3].i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L180: */
}
}
}
i__1 = j;
i__2 = j;
q__2.r = -work[i__2].r, q__2.i = -work[i__2].i;
cladiv_(&q__1, &q__2, &d__);
work[i__1].r = q__1.r, work[i__1].i = q__1.i;
if (j > 1) {
/* w = w + x(j)*(a A(*,j) - b B(*,j) ) with scaling */
i__1 = j;
if ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 =
r_imag(&work[j]), dabs(r__2)) > 1.f) {
i__1 = j;
temp = 1.f / ((r__1 = work[i__1].r, dabs(r__1)) +
(r__2 = r_imag(&work[j]), dabs(r__2)));
if (acoefa * rwork[j] + bcoefa * rwork[*n + j] >=
bignum * temp) {
i__1 = je;
for (jr = 1; jr <= i__1; ++jr) {
i__2 = jr;
i__3 = jr;
q__1.r = temp * work[i__3].r, q__1.i =
temp * work[i__3].i;
work[i__2].r = q__1.r, work[i__2].i =
q__1.i;
/* L190: */
}
}
}
i__1 = j;
q__1.r = acoeff * work[i__1].r, q__1.i = acoeff *
work[i__1].i;
ca.r = q__1.r, ca.i = q__1.i;
i__1 = j;
q__1.r = bcoeff.r * work[i__1].r - bcoeff.i * work[
i__1].i, q__1.i = bcoeff.r * work[i__1].i +
bcoeff.i * work[i__1].r;
cb.r = q__1.r, cb.i = q__1.i;
i__1 = j - 1;
for (jr = 1; jr <= i__1; ++jr) {
i__2 = jr;
i__3 = jr;
i__4 = a_subscr(jr, j);
q__3.r = ca.r * a[i__4].r - ca.i * a[i__4].i,
q__3.i = ca.r * a[i__4].i + ca.i * a[i__4]
.r;
q__2.r = work[i__3].r + q__3.r, q__2.i = work[
i__3].i + q__3.i;
i__5 = b_subscr(jr, j);
q__4.r = cb.r * b[i__5].r - cb.i * b[i__5].i,
q__4.i = cb.r * b[i__5].i + cb.i * b[i__5]
.r;
q__1.r = q__2.r - q__4.r, q__1.i = q__2.i -
q__4.i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L200: */
}
}
/* L210: */
}
/* Back transform eigenvector if HOWMNY='B'. */
if (ilback) {
cgemv_("N", n, &je, &c_b2, &vr[vr_offset], ldvr, &work[1],
&c__1, &c_b1, &work[*n + 1], &c__1);
isrc = 2;
iend = *n;
} else {
isrc = 1;
iend = je;
}
/* Copy and scale eigenvector into column of VR */
xmax = 0.f;
i__1 = iend;
for (jr = 1; jr <= i__1; ++jr) {
/* Computing MAX */
i__2 = (isrc - 1) * *n + jr;
r__3 = xmax, r__4 = (r__1 = work[i__2].r, dabs(r__1)) + (
r__2 = r_imag(&work[(isrc - 1) * *n + jr]), dabs(
r__2));
xmax = dmax(r__3,r__4);
/* L220: */
}
if (xmax > safmin) {
temp = 1.f / xmax;
i__1 = iend;
for (jr = 1; jr <= i__1; ++jr) {
i__2 = vr_subscr(jr, ieig);
i__3 = (isrc - 1) * *n + jr;
q__1.r = temp * work[i__3].r, q__1.i = temp * work[
i__3].i;
vr[i__2].r = q__1.r, vr[i__2].i = q__1.i;
/* L230: */
}
} else {
iend = 0;
}
i__1 = *n;
for (jr = iend + 1; jr <= i__1; ++jr) {
i__2 = vr_subscr(jr, ieig);
vr[i__2].r = 0.f, vr[i__2].i = 0.f;
/* L240: */
}
}
L250:
;
}
}
return 0;
/* End of CTGEVC */
} /* ctgevc_ */
/* Subroutine */ int cgtrfs_(char *trans, integer *n, integer *nrhs, complex *
dl, complex *d__, complex *du, complex *dlf, complex *df, complex *
duf, complex *du2, integer *ipiv, complex *b, integer *ldb, complex *
x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork,
integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CGTRFS improves the computed solution to a system of linear
equations when the coefficient matrix is tridiagonal, and provides
error bounds and backward error estimates for the solution.
Arguments
=========
TRANS (input) CHARACTER*1
Specifies the form of the system of equations:
= 'N': A * X = B (No transpose)
= 'T': A**T * X = B (Transpose)
= 'C': A**H * X = B (Conjugate transpose)
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.
DL (input) COMPLEX array, dimension (N-1)
The (n-1) subdiagonal elements of A.
D (input) COMPLEX array, dimension (N)
The diagonal elements of A.
DU (input) COMPLEX array, dimension (N-1)
The (n-1) superdiagonal elements of A.
DLF (input) COMPLEX array, dimension (N-1)
The (n-1) multipliers that define the matrix L from the
LU factorization of A as computed by CGTTRF.
DF (input) COMPLEX array, dimension (N)
The n diagonal elements of the upper triangular matrix U from
the LU factorization of A.
DUF (input) COMPLEX array, dimension (N-1)
The (n-1) elements of the first superdiagonal of U.
DU2 (input) COMPLEX array, dimension (N-2)
The (n-2) elements of the second superdiagonal of U.
IPIV (input) INTEGER array, dimension (N)
The pivot indices; for 1 <= i <= n, row i of the matrix was
interchanged with row IPIV(i). IPIV(i) will always be either
i or i+1; IPIV(i) = i indicates a row interchange was not
required.
B (input) COMPLEX 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 array, dimension (LDX,NRHS)
On entry, the solution matrix X, as computed by CGTTRS.
On exit, the improved solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
FERR (output) REAL array, dimension (NRHS)
The estimated 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). The estimate is as reliable as
the estimate for RCOND, and is almost always a slight
overestimate of the true error.
BERR (output) REAL 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 array, dimension (2*N)
RWORK (workspace) REAL array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Internal Parameters
===================
ITMAX is the maximum number of steps of iterative refinement.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static real c_b18 = -1.f;
static real c_b19 = 1.f;
static complex c_b26 = {1.f,0.f};
/* 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;
real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10, r__11,
r__12, r__13, r__14;
complex q__1;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static integer kase;
static real safe1, safe2;
static integer i__, j;
static real s;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
static integer count;
extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real
*, integer *), clagtm_(char *, integer *, integer *, real *,
complex *, complex *, complex *, complex *, integer *, real *,
complex *, integer *);
static integer nz;
extern doublereal slamch_(char *);
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static logical notran;
static char transn[1];
extern /* Subroutine */ int cgttrs_(char *, integer *, integer *, complex
*, complex *, complex *, complex *, integer *, complex *, integer
*, integer *);
static char transt[1];
static real lstres, eps;
#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)]
--dl;
--d__;
--du;
--dlf;
--df;
--duf;
--du2;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
--ferr;
--berr;
--work;
--rwork;
/* Function Body */
*info = 0;
notran = lsame_(trans, "N");
if (! notran && ! lsame_(trans, "T") && ! lsame_(
trans, "C")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*ldb < max(1,*n)) {
*info = -13;
} else if (*ldx < max(1,*n)) {
*info = -15;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGTRFS", &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.f;
berr[j] = 0.f;
/* L10: */
}
return 0;
}
if (notran) {
*(unsigned char *)transn = 'N';
*(unsigned char *)transt = 'C';
} else {
*(unsigned char *)transn = 'C';
*(unsigned char *)transt = 'N';
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = 4;
eps = slamch_("Epsilon");
safmin = slamch_("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.f;
L20:
/* Loop until stopping criterion is satisfied.
Compute residual R = B - op(A) * X,
where op(A) = A, A**T, or A**H, depending on TRANS. */
ccopy_(n, &b_ref(1, j), &c__1, &work[1], &c__1);
clagtm_(trans, n, &c__1, &c_b18, &dl[1], &d__[1], &du[1], &x_ref(1, j)
, ldx, &c_b19, &work[1], n);
/* Compute abs(op(A))*abs(x) + abs(b) for use in the backward
error bound. */
if (notran) {
if (*n == 1) {
i__2 = b_subscr(1, j);
i__3 = x_subscr(1, j);
rwork[1] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
b_ref(1, j)), dabs(r__2)) + ((r__3 = d__[1].r, dabs(
r__3)) + (r__4 = r_imag(&d__[1]), dabs(r__4))) * ((
r__5 = x[i__3].r, dabs(r__5)) + (r__6 = r_imag(&x_ref(
1, j)), dabs(r__6)));
} else {
i__2 = b_subscr(1, j);
i__3 = x_subscr(1, j);
i__4 = x_subscr(2, j);
rwork[1] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
b_ref(1, j)), dabs(r__2)) + ((r__3 = d__[1].r, dabs(
r__3)) + (r__4 = r_imag(&d__[1]), dabs(r__4))) * ((
r__5 = x[i__3].r, dabs(r__5)) + (r__6 = r_imag(&x_ref(
1, j)), dabs(r__6))) + ((r__7 = du[1].r, dabs(r__7))
+ (r__8 = r_imag(&du[1]), dabs(r__8))) * ((r__9 = x[
i__4].r, dabs(r__9)) + (r__10 = r_imag(&x_ref(2, j)),
dabs(r__10)));
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = i__ - 1;
i__5 = x_subscr(i__ - 1, j);
i__6 = i__;
i__7 = x_subscr(i__, j);
i__8 = i__;
i__9 = x_subscr(i__ + 1, j);
rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&b_ref(i__, j)), dabs(r__2)) + ((r__3 = dl[
i__4].r, dabs(r__3)) + (r__4 = r_imag(&dl[i__ - 1]
), dabs(r__4))) * ((r__5 = x[i__5].r, dabs(r__5))
+ (r__6 = r_imag(&x_ref(i__ - 1, j)), dabs(r__6)))
+ ((r__7 = d__[i__6].r, dabs(r__7)) + (r__8 =
r_imag(&d__[i__]), dabs(r__8))) * ((r__9 = x[i__7]
.r, dabs(r__9)) + (r__10 = r_imag(&x_ref(i__, j)),
dabs(r__10))) + ((r__11 = du[i__8].r, dabs(r__11)
) + (r__12 = r_imag(&du[i__]), dabs(r__12))) * ((
r__13 = x[i__9].r, dabs(r__13)) + (r__14 = r_imag(
&x_ref(i__ + 1, j)), dabs(r__14)));
/* L30: */
}
i__2 = b_subscr(*n, j);
i__3 = *n - 1;
i__4 = x_subscr(*n - 1, j);
i__5 = *n;
i__6 = x_subscr(*n, j);
rwork[*n] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
b_ref(*n, j)), dabs(r__2)) + ((r__3 = dl[i__3].r,
dabs(r__3)) + (r__4 = r_imag(&dl[*n - 1]), dabs(r__4))
) * ((r__5 = x[i__4].r, dabs(r__5)) + (r__6 = r_imag(&
x_ref(*n - 1, j)), dabs(r__6))) + ((r__7 = d__[i__5]
.r, dabs(r__7)) + (r__8 = r_imag(&d__[*n]), dabs(r__8)
)) * ((r__9 = x[i__6].r, dabs(r__9)) + (r__10 =
r_imag(&x_ref(*n, j)), dabs(r__10)));
}
} else {
if (*n == 1) {
i__2 = b_subscr(1, j);
i__3 = x_subscr(1, j);
rwork[1] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
b_ref(1, j)), dabs(r__2)) + ((r__3 = d__[1].r, dabs(
r__3)) + (r__4 = r_imag(&d__[1]), dabs(r__4))) * ((
r__5 = x[i__3].r, dabs(r__5)) + (r__6 = r_imag(&x_ref(
1, j)), dabs(r__6)));
} else {
i__2 = b_subscr(1, j);
i__3 = x_subscr(1, j);
i__4 = x_subscr(2, j);
rwork[1] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
b_ref(1, j)), dabs(r__2)) + ((r__3 = d__[1].r, dabs(
r__3)) + (r__4 = r_imag(&d__[1]), dabs(r__4))) * ((
r__5 = x[i__3].r, dabs(r__5)) + (r__6 = r_imag(&x_ref(
1, j)), dabs(r__6))) + ((r__7 = dl[1].r, dabs(r__7))
+ (r__8 = r_imag(&dl[1]), dabs(r__8))) * ((r__9 = x[
i__4].r, dabs(r__9)) + (r__10 = r_imag(&x_ref(2, j)),
dabs(r__10)));
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = i__ - 1;
i__5 = x_subscr(i__ - 1, j);
i__6 = i__;
i__7 = x_subscr(i__, j);
i__8 = i__;
i__9 = x_subscr(i__ + 1, j);
rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&b_ref(i__, j)), dabs(r__2)) + ((r__3 = du[
i__4].r, dabs(r__3)) + (r__4 = r_imag(&du[i__ - 1]
), dabs(r__4))) * ((r__5 = x[i__5].r, dabs(r__5))
+ (r__6 = r_imag(&x_ref(i__ - 1, j)), dabs(r__6)))
+ ((r__7 = d__[i__6].r, dabs(r__7)) + (r__8 =
r_imag(&d__[i__]), dabs(r__8))) * ((r__9 = x[i__7]
.r, dabs(r__9)) + (r__10 = r_imag(&x_ref(i__, j)),
dabs(r__10))) + ((r__11 = dl[i__8].r, dabs(r__11)
) + (r__12 = r_imag(&dl[i__]), dabs(r__12))) * ((
r__13 = x[i__9].r, dabs(r__13)) + (r__14 = r_imag(
&x_ref(i__ + 1, j)), dabs(r__14)));
/* L40: */
}
i__2 = b_subscr(*n, j);
i__3 = *n - 1;
i__4 = x_subscr(*n - 1, j);
i__5 = *n;
i__6 = x_subscr(*n, j);
rwork[*n] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
b_ref(*n, j)), dabs(r__2)) + ((r__3 = du[i__3].r,
dabs(r__3)) + (r__4 = r_imag(&du[*n - 1]), dabs(r__4))
) * ((r__5 = x[i__4].r, dabs(r__5)) + (r__6 = r_imag(&
x_ref(*n - 1, j)), dabs(r__6))) + ((r__7 = d__[i__5]
.r, dabs(r__7)) + (r__8 = r_imag(&d__[*n]), dabs(r__8)
)) * ((r__9 = x[i__6].r, dabs(r__9)) + (r__10 =
r_imag(&x_ref(*n, j)), dabs(r__10)));
}
}
/* Compute componentwise relative backward error from formula
max(i) ( abs(R(i)) / ( abs(op(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.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
/* Computing MAX */
i__3 = i__;
r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2))) / rwork[i__];
s = dmax(r__3,r__4);
} else {
/* Computing MAX */
i__3 = i__;
r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__]
+ safe1);
s = dmax(r__3,r__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.f <= lstres && count <= 5) {
/* Update solution and try again. */
cgttrs_(trans, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[
1], &work[1], n, info);
caxpy_(n, &c_b26, &work[1], &c__1, &x_ref(1, j), &c__1);
lstres = berr[j];
++count;
goto L20;
}
/* Bound error from formula
norm(X - XTRUE) / norm(X) .le. FERR =
norm( abs(inv(op(A)))*
( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
where
norm(Z) is the magnitude of the largest component of Z
inv(op(A)) is the inverse of op(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(op(A))*abs(X)+abs(B))
is incremented by SAFE1 if the i-th component of
abs(op(A))*abs(X) + abs(B) is less than SAFE2.
Use CLACON to estimate the infinity-norm of the matrix
inv(op(A)) * diag(W),
where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
i__3 = i__;
rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
i__];
} else {
i__3 = i__;
rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
i__] + safe1;
}
/* L60: */
}
kase = 0;
L70:
clacon_(n, &work[*n + 1], &work[1], &ferr[j], &kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)**H). */
cgttrs_(transt, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &
ipiv[1], &work[1], n, info);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L80: */
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L90: */
}
cgttrs_(transn, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &
ipiv[1], &work[1], n, info);
}
goto L70;
}
/* Normalize error. */
lstres = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = x_subscr(i__, j);
r__3 = lstres, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x_ref(i__, j)), dabs(r__2));
lstres = dmax(r__3,r__4);
/* L100: */
}
if (lstres != 0.f) {
ferr[j] /= lstres;
}
/* L110: */
}
return 0;
/* End of CGTRFS */
} /* cgtrfs_ */
/* Subroutine */ int clals0_(integer *icompq, integer *nl, integer *nr,
integer *sqre, integer *nrhs, complex *b, integer *ldb, complex *bx,
integer *ldbx, integer *perm, integer *givptr, integer *givcol,
integer *ldgcol, real *givnum, integer *ldgnum, real *poles, real *
difl, real *difr, real *z__, integer *k, real *c__, real *s, real *
rwork, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
December 1, 1999
Purpose
=======
CLALS0 applies back the multiplying factors of either the left or the
right singular vector matrix of a diagonal matrix appended by a row
to the right hand side matrix B in solving the least squares problem
using the divide-and-conquer SVD approach.
For the left singular vector matrix, three types of orthogonal
matrices are involved:
(1L) Givens rotations: the number of such rotations is GIVPTR; the
pairs of columns/rows they were applied to are stored in GIVCOL;
and the C- and S-values of these rotations are stored in GIVNUM.
(2L) Permutation. The (NL+1)-st row of B is to be moved to the first
row, and for J=2:N, PERM(J)-th row of B is to be moved to the
J-th row.
(3L) The left singular vector matrix of the remaining matrix.
For the right singular vector matrix, four types of orthogonal
matrices are involved:
(1R) The right singular vector matrix of the remaining matrix.
(2R) If SQRE = 1, one extra Givens rotation to generate the right
null space.
(3R) The inverse transformation of (2L).
(4R) The inverse transformation of (1L).
Arguments
=========
ICOMPQ (input) INTEGER
Specifies whether singular vectors are to be computed in
factored form:
= 0: Left singular vector matrix.
= 1: Right singular vector matrix.
NL (input) INTEGER
The row dimension of the upper block. NL >= 1.
NR (input) INTEGER
The row dimension of the lower block. NR >= 1.
SQRE (input) INTEGER
= 0: the lower block is an NR-by-NR square matrix.
= 1: the lower block is an NR-by-(NR+1) rectangular matrix.
The bidiagonal matrix has row dimension N = NL + NR + 1,
and column dimension M = N + SQRE.
NRHS (input) INTEGER
The number of columns of B and BX. NRHS must be at least 1.
B (input/output) COMPLEX array, dimension ( LDB, NRHS )
On input, B contains the right hand sides of the least
squares problem in rows 1 through M. On output, B contains
the solution X in rows 1 through N.
LDB (input) INTEGER
The leading dimension of B. LDB must be at least
max(1,MAX( M, N ) ).
BX (workspace) COMPLEX array, dimension ( LDBX, NRHS )
LDBX (input) INTEGER
The leading dimension of BX.
PERM (input) INTEGER array, dimension ( N )
The permutations (from deflation and sorting) applied
to the two blocks.
GIVPTR (input) INTEGER
The number of Givens rotations which took place in this
subproblem.
GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )
Each pair of numbers indicates a pair of rows/columns
involved in a Givens rotation.
LDGCOL (input) INTEGER
The leading dimension of GIVCOL, must be at least N.
GIVNUM (input) REAL array, dimension ( LDGNUM, 2 )
Each number indicates the C or S value used in the
corresponding Givens rotation.
LDGNUM (input) INTEGER
The leading dimension of arrays DIFR, POLES and
GIVNUM, must be at least K.
POLES (input) REAL array, dimension ( LDGNUM, 2 )
On entry, POLES(1:K, 1) contains the new singular
values obtained from solving the secular equation, and
POLES(1:K, 2) is an array containing the poles in the secular
equation.
DIFL (input) REAL array, dimension ( K ).
On entry, DIFL(I) is the distance between I-th updated
(undeflated) singular value and the I-th (undeflated) old
singular value.
DIFR (input) REAL array, dimension ( LDGNUM, 2 ).
On entry, DIFR(I, 1) contains the distances between I-th
updated (undeflated) singular value and the I+1-th
(undeflated) old singular value. And DIFR(I, 2) is the
normalizing factor for the I-th right singular vector.
Z (input) REAL array, dimension ( K )
Contain the components of the deflation-adjusted updating row
vector.
K (input) INTEGER
Contains the dimension of the non-deflated matrix,
This is the order of the related secular equation. 1 <= K <=N.
C (input) REAL
C contains garbage if SQRE =0 and the C-value of a Givens
rotation related to the right null space if SQRE = 1.
S (input) REAL
S contains garbage if SQRE =0 and the S-value of a Givens
rotation related to the right null space if SQRE = 1.
RWORK (workspace) REAL array, dimension
( K*(1+NRHS) + 2*NRHS )
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
Further Details
===============
Based on contributions by
Ming Gu and Ren-Cang Li, Computer Science Division, University of
California at Berkeley, USA
Osni Marques, LBNL/NERSC, USA
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static real c_b5 = -1.f;
static integer c__1 = 1;
static real c_b13 = 1.f;
static real c_b15 = 0.f;
static integer c__0 = 0;
/* System generated locals */
integer givcol_dim1, givcol_offset, difr_dim1, difr_offset, givnum_dim1,
givnum_offset, poles_dim1, poles_offset, b_dim1, b_offset,
bx_dim1, bx_offset, i__1, i__2, i__3, i__4, i__5;
real r__1;
complex q__1;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static integer jcol;
static real temp;
static integer jrow;
extern doublereal snrm2_(integer *, real *, integer *);
static integer i__, j, m, n;
static real diflj, difrj, dsigj;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), sgemv_(char *, integer *, integer *, real *
, real *, integer *, real *, integer *, real *, real *, integer *), csrot_(integer *, complex *, integer *, complex *,
integer *, real *, real *);
extern doublereal slamc3_(real *, real *);
static real dj;
extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, complex *, integer *, integer *), csscal_(integer *, real *, complex *, integer *),
clacpy_(char *, integer *, integer *, complex *, integer *,
complex *, integer *), xerbla_(char *, integer *);
static real dsigjp;
static integer nlp1;
#define difr_ref(a_1,a_2) difr[(a_2)*difr_dim1 + a_1]
#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 poles_ref(a_1,a_2) poles[(a_2)*poles_dim1 + a_1]
#define bx_subscr(a_1,a_2) (a_2)*bx_dim1 + a_1
#define bx_ref(a_1,a_2) bx[bx_subscr(a_1,a_2)]
#define givcol_ref(a_1,a_2) givcol[(a_2)*givcol_dim1 + a_1]
#define givnum_ref(a_1,a_2) givnum[(a_2)*givnum_dim1 + a_1]
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
bx_dim1 = *ldbx;
bx_offset = 1 + bx_dim1 * 1;
bx -= bx_offset;
--perm;
givcol_dim1 = *ldgcol;
givcol_offset = 1 + givcol_dim1 * 1;
givcol -= givcol_offset;
difr_dim1 = *ldgnum;
difr_offset = 1 + difr_dim1 * 1;
difr -= difr_offset;
poles_dim1 = *ldgnum;
poles_offset = 1 + poles_dim1 * 1;
poles -= poles_offset;
givnum_dim1 = *ldgnum;
givnum_offset = 1 + givnum_dim1 * 1;
givnum -= givnum_offset;
--difl;
--z__;
--rwork;
/* Function Body */
*info = 0;
if (*icompq < 0 || *icompq > 1) {
*info = -1;
} else if (*nl < 1) {
*info = -2;
} else if (*nr < 1) {
*info = -3;
} else if (*sqre < 0 || *sqre > 1) {
*info = -4;
}
n = *nl + *nr + 1;
if (*nrhs < 1) {
*info = -5;
} else if (*ldb < n) {
*info = -7;
} else if (*ldbx < n) {
*info = -9;
} else if (*givptr < 0) {
*info = -11;
} else if (*ldgcol < n) {
*info = -13;
} else if (*ldgnum < n) {
*info = -15;
} else if (*k < 1) {
*info = -20;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CLALS0", &i__1);
return 0;
}
m = n + *sqre;
nlp1 = *nl + 1;
if (*icompq == 0) {
/* Apply back orthogonal transformations from the left.
Step (1L): apply back the Givens rotations performed. */
i__1 = *givptr;
for (i__ = 1; i__ <= i__1; ++i__) {
csrot_(nrhs, &b_ref(givcol_ref(i__, 2), 1), ldb, &b_ref(
givcol_ref(i__, 1), 1), ldb, &givnum_ref(i__, 2), &
givnum_ref(i__, 1));
/* L10: */
}
/* Step (2L): permute rows of B. */
ccopy_(nrhs, &b_ref(nlp1, 1), ldb, &bx_ref(1, 1), ldbx);
i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) {
ccopy_(nrhs, &b_ref(perm[i__], 1), ldb, &bx_ref(i__, 1), ldbx);
/* L20: */
}
/* Step (3L): apply the inverse of the left singular vector
matrix to BX. */
if (*k == 1) {
ccopy_(nrhs, &bx[bx_offset], ldbx, &b[b_offset], ldb);
if (z__[1] < 0.f) {
csscal_(nrhs, &c_b5, &b[b_offset], ldb);
}
} else {
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
diflj = difl[j];
dj = poles_ref(j, 1);
dsigj = -poles_ref(j, 2);
if (j < *k) {
difrj = -difr_ref(j, 1);
dsigjp = -poles_ref(j + 1, 2);
}
if (z__[j] == 0.f || poles_ref(j, 2) == 0.f) {
rwork[j] = 0.f;
} else {
rwork[j] = -poles_ref(j, 2) * z__[j] / diflj / (poles_ref(
j, 2) + dj);
}
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
if (z__[i__] == 0.f || poles_ref(i__, 2) == 0.f) {
rwork[i__] = 0.f;
} else {
rwork[i__] = poles_ref(i__, 2) * z__[i__] / (slamc3_(&
poles_ref(i__, 2), &dsigj) - diflj) / (
poles_ref(i__, 2) + dj);
}
/* L30: */
}
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
if (z__[i__] == 0.f || poles_ref(i__, 2) == 0.f) {
rwork[i__] = 0.f;
} else {
rwork[i__] = poles_ref(i__, 2) * z__[i__] / (slamc3_(&
poles_ref(i__, 2), &dsigjp) + difrj) / (
poles_ref(i__, 2) + dj);
}
/* L40: */
}
rwork[1] = -1.f;
temp = snrm2_(k, &rwork[1], &c__1);
/* Since B and BX are complex, the following call to SGEMV
is performed in two steps (real and imaginary parts).
CALL SGEMV( 'T', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO,
$ B( J, 1 ), LDB ) */
i__ = *k + (*nrhs << 1);
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = *k;
for (jrow = 1; jrow <= i__3; ++jrow) {
++i__;
i__4 = bx_subscr(jrow, jcol);
rwork[i__] = bx[i__4].r;
/* L50: */
}
/* L60: */
}
sgemv_("T", k, nrhs, &c_b13, &rwork[*k + 1 + (*nrhs << 1)], k,
&rwork[1], &c__1, &c_b15, &rwork[*k + 1], &c__1);
i__ = *k + (*nrhs << 1);
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = *k;
for (jrow = 1; jrow <= i__3; ++jrow) {
++i__;
rwork[i__] = r_imag(&bx_ref(jrow, jcol));
/* L70: */
}
/* L80: */
}
sgemv_("T", k, nrhs, &c_b13, &rwork[*k + 1 + (*nrhs << 1)], k,
&rwork[1], &c__1, &c_b15, &rwork[*k + 1 + *nrhs], &
c__1);
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = b_subscr(j, jcol);
i__4 = jcol + *k;
i__5 = jcol + *k + *nrhs;
q__1.r = rwork[i__4], q__1.i = rwork[i__5];
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L90: */
}
clascl_("G", &c__0, &c__0, &temp, &c_b13, &c__1, nrhs, &b_ref(
j, 1), ldb, info);
/* L100: */
}
}
/* Move the deflated rows of BX to B also. */
if (*k < max(m,n)) {
i__1 = n - *k;
clacpy_("A", &i__1, nrhs, &bx_ref(*k + 1, 1), ldbx, &b_ref(*k + 1,
1), ldb);
}
} else {
/* Apply back the right orthogonal transformations.
Step (1R): apply back the new right singular vector matrix
to B. */
if (*k == 1) {
ccopy_(nrhs, &b[b_offset], ldb, &bx[bx_offset], ldbx);
} else {
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
dsigj = poles_ref(j, 2);
if (z__[j] == 0.f) {
rwork[j] = 0.f;
} else {
rwork[j] = -z__[j] / difl[j] / (dsigj + poles_ref(j, 1)) /
difr_ref(j, 2);
}
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
if (z__[j] == 0.f) {
rwork[i__] = 0.f;
} else {
r__1 = -poles_ref(i__ + 1, 2);
rwork[i__] = z__[j] / (slamc3_(&dsigj, &r__1) -
difr_ref(i__, 1)) / (dsigj + poles_ref(i__, 1)
) / difr_ref(i__, 2);
}
/* L110: */
}
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
if (z__[j] == 0.f) {
rwork[i__] = 0.f;
} else {
r__1 = -poles_ref(i__, 2);
rwork[i__] = z__[j] / (slamc3_(&dsigj, &r__1) - difl[
i__]) / (dsigj + poles_ref(i__, 1)) /
difr_ref(i__, 2);
}
/* L120: */
}
/* Since B and BX are complex, the following call to SGEMV
is performed in two steps (real and imaginary parts).
CALL SGEMV( 'T', K, NRHS, ONE, B, LDB, WORK, 1, ZERO,
$ BX( J, 1 ), LDBX ) */
i__ = *k + (*nrhs << 1);
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = *k;
for (jrow = 1; jrow <= i__3; ++jrow) {
++i__;
i__4 = b_subscr(jrow, jcol);
rwork[i__] = b[i__4].r;
/* L130: */
}
/* L140: */
}
sgemv_("T", k, nrhs, &c_b13, &rwork[*k + 1 + (*nrhs << 1)], k,
&rwork[1], &c__1, &c_b15, &rwork[*k + 1], &c__1);
i__ = *k + (*nrhs << 1);
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = *k;
for (jrow = 1; jrow <= i__3; ++jrow) {
++i__;
rwork[i__] = r_imag(&b_ref(jrow, jcol));
/* L150: */
}
/* L160: */
}
sgemv_("T", k, nrhs, &c_b13, &rwork[*k + 1 + (*nrhs << 1)], k,
&rwork[1], &c__1, &c_b15, &rwork[*k + 1 + *nrhs], &
c__1);
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = bx_subscr(j, jcol);
i__4 = jcol + *k;
i__5 = jcol + *k + *nrhs;
q__1.r = rwork[i__4], q__1.i = rwork[i__5];
bx[i__3].r = q__1.r, bx[i__3].i = q__1.i;
/* L170: */
}
/* L180: */
}
}
/* Step (2R): if SQRE = 1, apply back the rotation that is
related to the right null space of the subproblem. */
if (*sqre == 1) {
ccopy_(nrhs, &b_ref(m, 1), ldb, &bx_ref(m, 1), ldbx);
csrot_(nrhs, &bx_ref(1, 1), ldbx, &bx_ref(m, 1), ldbx, c__, s);
}
if (*k < max(m,n)) {
i__1 = n - *k;
clacpy_("A", &i__1, nrhs, &b_ref(*k + 1, 1), ldb, &bx_ref(*k + 1,
1), ldbx);
}
/* Step (3R): permute rows of B. */
ccopy_(nrhs, &bx_ref(1, 1), ldbx, &b_ref(nlp1, 1), ldb);
if (*sqre == 1) {
ccopy_(nrhs, &bx_ref(m, 1), ldbx, &b_ref(m, 1), ldb);
}
i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) {
ccopy_(nrhs, &bx_ref(i__, 1), ldbx, &b_ref(perm[i__], 1), ldb);
/* L190: */
}
/* Step (4R): apply back the Givens rotations performed. */
for (i__ = *givptr; i__ >= 1; --i__) {
r__1 = -givnum_ref(i__, 1);
csrot_(nrhs, &b_ref(givcol_ref(i__, 2), 1), ldb, &b_ref(
givcol_ref(i__, 1), 1), ldb, &givnum_ref(i__, 2), &r__1);
/* L200: */
}
}
return 0;
/* End of CLALS0 */
} /* clals0_ */
/* Subroutine */ int ctrsyl_(char *trana, char *tranb, integer *isgn, integer
*m, integer *n, complex *a, integer *lda, complex *b, integer *ldb,
complex *c__, integer *ldc, real *scale, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
CTRSYL solves the complex Sylvester matrix equation:
op(A)*X + X*op(B) = scale*C or
op(A)*X - X*op(B) = scale*C,
where op(A) = A or A**H, and A and B are both upper triangular. A is
M-by-M and B is N-by-N; the right hand side C and the solution X are
M-by-N; and scale is an output scale factor, set <= 1 to avoid
overflow in X.
Arguments
=========
TRANA (input) CHARACTER*1
Specifies the option op(A):
= 'N': op(A) = A (No transpose)
= 'C': op(A) = A**H (Conjugate transpose)
TRANB (input) CHARACTER*1
Specifies the option op(B):
= 'N': op(B) = B (No transpose)
= 'C': op(B) = B**H (Conjugate transpose)
ISGN (input) INTEGER
Specifies the sign in the equation:
= +1: solve op(A)*X + X*op(B) = scale*C
= -1: solve op(A)*X - X*op(B) = scale*C
M (input) INTEGER
The order of the matrix A, and the number of rows in the
matrices X and C. M >= 0.
N (input) INTEGER
The order of the matrix B, and the number of columns in the
matrices X and C. N >= 0.
A (input) COMPLEX array, dimension (LDA,M)
The upper triangular matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
B (input) COMPLEX array, dimension (LDB,N)
The upper triangular matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
C (input/output) COMPLEX array, dimension (LDC,N)
On entry, the M-by-N right hand side matrix C.
On exit, C is overwritten by the solution matrix X.
LDC (input) INTEGER
The leading dimension of the array C. LDC >= max(1,M)
SCALE (output) REAL
The scale factor, scale, set <= 1 to avoid overflow in X.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
= 1: A and B have common or very close eigenvalues; perturbed
values were used to solve the equation (but the matrices
A and B are unchanged).
=====================================================================
Decode and Test input parameters
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
i__3, i__4;
real r__1, r__2;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
static real smin;
static complex suml, sumr;
static integer j, k, l;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
*, complex *, integer *);
static complex a11;
static real db;
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
static complex x11;
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
static real scaloc;
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), xerbla_(char *, integer *);
static real bignum;
static logical notrna, notrnb;
static real smlnum, da11;
static complex vec;
static real dum[1], eps, sgn;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1
#define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
/* Function Body */
notrna = lsame_(trana, "N");
notrnb = lsame_(tranb, "N");
*info = 0;
if (! notrna && ! lsame_(trana, "T") && ! lsame_(
trana, "C")) {
*info = -1;
} else if (! notrnb && ! lsame_(tranb, "T") && !
lsame_(tranb, "C")) {
*info = -2;
} else if (*isgn != 1 && *isgn != -1) {
*info = -3;
} else if (*m < 0) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*m)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldc < max(1,*m)) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTRSYL", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Set constants to control overflow */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = smlnum * (real) (*m * *n) / eps;
bignum = 1.f / smlnum;
/* Computing MAX */
r__1 = smlnum, r__2 = eps * clange_("M", m, m, &a[a_offset], lda, dum), r__1 = max(r__1,r__2), r__2 = eps * clange_("M", n, n,
&b[b_offset], ldb, dum);
smin = dmax(r__1,r__2);
*scale = 1.f;
sgn = (real) (*isgn);
if (notrna && notrnb) {
/* Solve A*X + ISGN*X*B = scale*C.
The (K,L)th block of X is determined starting from
bottom-left corner column by column by
A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
Where
M L-1
R(K,L) = SUM [A(K,I)*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)].
I=K+1 J=1 */
i__1 = *n;
for (l = 1; l <= i__1; ++l) {
for (k = *m; k >= 1; --k) {
/* Computing MIN */
i__2 = k + 1;
/* Computing MIN */
i__3 = k + 1;
i__4 = *m - k;
cdotu_(&q__1, &i__4, &a_ref(k, min(i__2,*m)), lda, &c___ref(
min(i__3,*m), l), &c__1);
suml.r = q__1.r, suml.i = q__1.i;
i__2 = l - 1;
cdotu_(&q__1, &i__2, &c___ref(k, 1), ldc, &b_ref(1, l), &c__1)
;
sumr.r = q__1.r, sumr.i = q__1.i;
i__2 = c___subscr(k, l);
q__3.r = sgn * sumr.r, q__3.i = sgn * sumr.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__2].r - q__2.r, q__1.i = c__[i__2].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
i__2 = a_subscr(k, k);
i__3 = b_subscr(l, l);
q__2.r = sgn * b[i__3].r, q__2.i = sgn * b[i__3].i;
q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i;
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
csscal_(m, &scaloc, &c___ref(1, j), &c__1);
/* L10: */
}
*scale *= scaloc;
}
i__2 = c___subscr(k, l);
c__[i__2].r = x11.r, c__[i__2].i = x11.i;
/* L20: */
}
/* L30: */
}
} else if (! notrna && notrnb) {
/* Solve A' *X + ISGN*X*B = scale*C.
The (K,L)th block of X is determined starting from
upper-left corner column by column by
A'(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
Where
K-1 L-1
R(K,L) = SUM [A'(I,K)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)]
I=1 J=1 */
i__1 = *n;
for (l = 1; l <= i__1; ++l) {
i__2 = *m;
for (k = 1; k <= i__2; ++k) {
i__3 = k - 1;
cdotc_(&q__1, &i__3, &a_ref(1, k), &c__1, &c___ref(1, l), &
c__1);
suml.r = q__1.r, suml.i = q__1.i;
i__3 = l - 1;
cdotu_(&q__1, &i__3, &c___ref(k, 1), ldc, &b_ref(1, l), &c__1)
;
sumr.r = q__1.r, sumr.i = q__1.i;
i__3 = c___subscr(k, l);
q__3.r = sgn * sumr.r, q__3.i = sgn * sumr.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
r_cnjg(&q__2, &a_ref(k, k));
i__3 = b_subscr(l, l);
q__3.r = sgn * b[i__3].r, q__3.i = sgn * b[i__3].i;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
csscal_(m, &scaloc, &c___ref(1, j), &c__1);
/* L40: */
}
*scale *= scaloc;
}
i__3 = c___subscr(k, l);
c__[i__3].r = x11.r, c__[i__3].i = x11.i;
/* L50: */
}
/* L60: */
}
} else if (! notrna && ! notrnb) {
/* Solve A'*X + ISGN*X*B' = C.
The (K,L)th block of X is determined starting from
upper-right corner column by column by
A'(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L)
Where
K-1
R(K,L) = SUM [A'(I,K)*X(I,L)] +
I=1
N
ISGN*SUM [X(K,J)*B'(L,J)].
J=L+1 */
for (l = *n; l >= 1; --l) {
i__1 = *m;
for (k = 1; k <= i__1; ++k) {
i__2 = k - 1;
cdotc_(&q__1, &i__2, &a_ref(1, k), &c__1, &c___ref(1, l), &
c__1);
suml.r = q__1.r, suml.i = q__1.i;
/* Computing MIN */
i__2 = l + 1;
/* Computing MIN */
i__3 = l + 1;
i__4 = *n - l;
cdotc_(&q__1, &i__4, &c___ref(k, min(i__2,*n)), ldc, &b_ref(l,
min(i__3,*n)), ldb);
sumr.r = q__1.r, sumr.i = q__1.i;
i__2 = c___subscr(k, l);
r_cnjg(&q__4, &sumr);
q__3.r = sgn * q__4.r, q__3.i = sgn * q__4.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__2].r - q__2.r, q__1.i = c__[i__2].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
i__2 = a_subscr(k, k);
i__3 = b_subscr(l, l);
q__3.r = sgn * b[i__3].r, q__3.i = sgn * b[i__3].i;
q__2.r = a[i__2].r + q__3.r, q__2.i = a[i__2].i + q__3.i;
r_cnjg(&q__1, &q__2);
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
csscal_(m, &scaloc, &c___ref(1, j), &c__1);
/* L70: */
}
*scale *= scaloc;
}
i__2 = c___subscr(k, l);
c__[i__2].r = x11.r, c__[i__2].i = x11.i;
/* L80: */
}
/* L90: */
}
} else if (notrna && ! notrnb) {
/* Solve A*X + ISGN*X*B' = C.
The (K,L)th block of X is determined starting from
bottom-left corner column by column by
A(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L)
Where
M N
R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B'(L,J)]
I=K+1 J=L+1 */
for (l = *n; l >= 1; --l) {
for (k = *m; k >= 1; --k) {
/* Computing MIN */
i__1 = k + 1;
/* Computing MIN */
i__2 = k + 1;
i__3 = *m - k;
cdotu_(&q__1, &i__3, &a_ref(k, min(i__1,*m)), lda, &c___ref(
min(i__2,*m), l), &c__1);
suml.r = q__1.r, suml.i = q__1.i;
/* Computing MIN */
i__1 = l + 1;
/* Computing MIN */
i__2 = l + 1;
i__3 = *n - l;
cdotc_(&q__1, &i__3, &c___ref(k, min(i__1,*n)), ldc, &b_ref(l,
min(i__2,*n)), ldb);
sumr.r = q__1.r, sumr.i = q__1.i;
i__1 = c___subscr(k, l);
r_cnjg(&q__4, &sumr);
q__3.r = sgn * q__4.r, q__3.i = sgn * q__4.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__1].r - q__2.r, q__1.i = c__[i__1].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
i__1 = a_subscr(k, k);
r_cnjg(&q__3, &b_ref(l, l));
q__2.r = sgn * q__3.r, q__2.i = sgn * q__3.i;
q__1.r = a[i__1].r + q__2.r, q__1.i = a[i__1].i + q__2.i;
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
csscal_(m, &scaloc, &c___ref(1, j), &c__1);
/* L100: */
}
*scale *= scaloc;
}
i__1 = c___subscr(k, l);
c__[i__1].r = x11.r, c__[i__1].i = x11.i;
/* L110: */
}
/* L120: */
}
}
return 0;
/* End of CTRSYL */
} /* ctrsyl_ */
/* Subroutine */ int zgels_(char *trans, integer *m, integer *n, integer *
nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
doublecomplex *work, integer *lwork, integer *info)
{
/* -- LAPACK driver routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
ZGELS solves overdetermined or underdetermined complex linear systems
involving an M-by-N matrix A, or its conjugate-transpose, using a QR
or LQ factorization of A. It is assumed that A has full rank.
The following options are provided:
1. If TRANS = 'N' and m >= n: find the least squares solution of
an overdetermined system, i.e., solve the least squares problem
minimize || B - A*X ||.
2. If TRANS = 'N' and m < n: find the minimum norm solution of
an underdetermined system A * X = B.
3. If TRANS = 'C' and m >= n: find the minimum norm solution of
an undetermined system A**H * X = B.
4. If TRANS = 'C' and m < n: find the least squares solution of
an overdetermined system, i.e., solve the least squares problem
minimize || B - A**H * X ||.
Several right hand side vectors b and solution vectors x can be
handled in a single call; they are stored as the columns of the
M-by-NRHS right hand side matrix B and the N-by-NRHS solution
matrix X.
Arguments
=========
TRANS (input) CHARACTER
= 'N': the linear system involves A;
= 'C': the linear system involves A**H.
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.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of
columns of the matrices B and X. NRHS >= 0.
A (input/output) COMPLEX*16 array, dimension (LDA,N)
On entry, the M-by-N matrix A.
if M >= N, A is overwritten by details of its QR
factorization as returned by ZGEQRF;
if M < N, A is overwritten by details of its LQ
factorization as returned by ZGELQF.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
On entry, the matrix B of right hand side vectors, stored
columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS
if TRANS = 'C'.
On exit, B is overwritten by the solution vectors, stored
columnwise:
if TRANS = 'N' and m >= n, rows 1 to n of B contain the least
squares solution vectors; the residual sum of squares for the
solution in each column is given by the sum of squares of
elements N+1 to M in that column;
if TRANS = 'N' and m < n, rows 1 to N of B contain the
minimum norm solution vectors;
if TRANS = 'C' and m >= n, rows 1 to M of B contain the
minimum norm solution vectors;
if TRANS = 'C' and m < n, rows 1 to M of B contain the
least squares solution vectors; the residual sum of squares
for the solution in each column is given by the sum of
squares of elements M+1 to N in that column.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= MAX(1,M,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, MN + max( MN, NRHS ) ).
For optimal performance,
LWORK >= max( 1, MN + max( MN, NRHS )*NB ).
where MN = min(M,N) and NB is the optimum block size.
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input arguments.
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b1 = {0.,0.};
static doublecomplex c_b2 = {1.,0.};
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__0 = 0;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
doublereal d__1;
/* Local variables */
static doublereal anrm, bnrm;
static integer brow;
static logical tpsd;
static integer i__, j, iascl, ibscl;
extern logical lsame_(char *, char *);
static integer wsize;
static doublereal rwork[1];
extern /* Subroutine */ int ztrsm_(char *, char *, char *, char *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *),
dlabad_(doublereal *, doublereal *);
static integer nb;
extern doublereal dlamch_(char *);
static integer mn;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static integer scllen;
static doublereal bignum;
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zgelqf_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *
), zlascl_(char *, integer *, integer *, doublereal *, doublereal
*, integer *, integer *, doublecomplex *, integer *, integer *), zgeqrf_(integer *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *, integer *), zlaset_(
char *, integer *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, integer *);
static doublereal smlnum;
static logical lquery;
extern /* Subroutine */ int zunmlq_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *), zunmqr_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *);
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--work;
/* Function Body */
*info = 0;
mn = min(*m,*n);
lquery = *lwork == -1;
if (! (lsame_(trans, "N") || lsame_(trans, "C"))) {
*info = -1;
} else if (*m < 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*lda < max(1,*m)) {
*info = -6;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = max(1,*m);
if (*ldb < max(i__1,*n)) {
*info = -8;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = mn + max(mn,*nrhs);
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -10;
}
}
}
/* Figure out optimal block size */
if (*info == 0 || *info == -10) {
tpsd = TRUE_;
if (lsame_(trans, "N")) {
tpsd = FALSE_;
}
if (*m >= *n) {
nb = ilaenv_(&c__1, "ZGEQRF", " ", m, n, &c_n1, &c_n1, (ftnlen)6,
(ftnlen)1);
if (tpsd) {
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__1, "ZUNMQR", "LN", m, nrhs, n, &
c_n1, (ftnlen)6, (ftnlen)2);
nb = max(i__1,i__2);
} else {
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__1, "ZUNMQR", "LC", m, nrhs, n, &
c_n1, (ftnlen)6, (ftnlen)2);
nb = max(i__1,i__2);
}
} else {
nb = ilaenv_(&c__1, "ZGELQF", " ", m, n, &c_n1, &c_n1, (ftnlen)6,
(ftnlen)1);
if (tpsd) {
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__1, "ZUNMLQ", "LC", n, nrhs, m, &
c_n1, (ftnlen)6, (ftnlen)2);
nb = max(i__1,i__2);
} else {
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__1, "ZUNMLQ", "LN", n, nrhs, m, &
c_n1, (ftnlen)6, (ftnlen)2);
nb = max(i__1,i__2);
}
}
/* Computing MAX */
i__1 = 1, i__2 = mn + max(mn,*nrhs) * nb;
wsize = max(i__1,i__2);
d__1 = (doublereal) wsize;
work[1].r = d__1, work[1].i = 0.;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGELS ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible
Computing MIN */
i__1 = min(*m,*n);
if (min(i__1,*nrhs) == 0) {
i__1 = max(*m,*n);
zlaset_("Full", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
return 0;
}
/* Get machine parameters */
smlnum = dlamch_("S") / dlamch_("P");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
/* Scale A, B if max element outside range [SMLNUM,BIGNUM] */
anrm = zlange_("M", m, n, &a[a_offset], lda, rwork);
iascl = 0;
if (anrm > 0. && anrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
zlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
info);
iascl = 1;
} else if (anrm > bignum) {
/* Scale matrix norm down to BIGNUM */
zlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
info);
iascl = 2;
} else if (anrm == 0.) {
/* Matrix all zero. Return zero solution. */
i__1 = max(*m,*n);
zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
goto L50;
}
brow = *m;
if (tpsd) {
brow = *n;
}
bnrm = zlange_("M", &brow, nrhs, &b[b_offset], ldb, rwork);
ibscl = 0;
if (bnrm > 0. && bnrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
zlascl_("G", &c__0, &c__0, &bnrm, &smlnum, &brow, nrhs, &b[b_offset],
ldb, info);
ibscl = 1;
} else if (bnrm > bignum) {
/* Scale matrix norm down to BIGNUM */
zlascl_("G", &c__0, &c__0, &bnrm, &bignum, &brow, nrhs, &b[b_offset],
ldb, info);
ibscl = 2;
}
if (*m >= *n) {
/* compute QR factorization of A */
i__1 = *lwork - mn;
zgeqrf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info)
;
/* workspace at least N, optimally N*NB */
if (! tpsd) {
/* Least-Squares Problem min || A * X - B ||
B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */
i__1 = *lwork - mn;
zunmqr_("Left", "Conjugate transpose", m, nrhs, n, &a[a_offset],
lda, &work[1], &b[b_offset], ldb, &work[mn + 1], &i__1,
info);
/* workspace at least NRHS, optimally NRHS*NB
B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS) */
ztrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &
c_b2, &a[a_offset], lda, &b[b_offset], ldb);
scllen = *n;
} else {
/* Overdetermined system of equations A' * X = B
B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS) */
ztrsm_("Left", "Upper", "Conjugate transpose", "Non-unit", n,
nrhs, &c_b2, &a[a_offset], lda, &b[b_offset], ldb);
/* B(N+1:M,1:NRHS) = ZERO */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = *n + 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
b[i__3].r = 0., b[i__3].i = 0.;
/* L10: */
}
/* L20: */
}
/* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS) */
i__1 = *lwork - mn;
zunmqr_("Left", "No transpose", m, nrhs, n, &a[a_offset], lda, &
work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
/* workspace at least NRHS, optimally NRHS*NB */
scllen = *m;
}
} else {
/* Compute LQ factorization of A */
i__1 = *lwork - mn;
zgelqf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info)
;
/* workspace at least M, optimally M*NB. */
if (! tpsd) {
/* underdetermined system of equations A * X = B
B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS) */
ztrsm_("Left", "Lower", "No transpose", "Non-unit", m, nrhs, &
c_b2, &a[a_offset], lda, &b[b_offset], ldb);
/* B(M+1:N,1:NRHS) = 0 */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = *m + 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
b[i__3].r = 0., b[i__3].i = 0.;
/* L30: */
}
/* L40: */
}
/* B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS) */
i__1 = *lwork - mn;
zunmlq_("Left", "Conjugate transpose", n, nrhs, m, &a[a_offset],
lda, &work[1], &b[b_offset], ldb, &work[mn + 1], &i__1,
info);
/* workspace at least NRHS, optimally NRHS*NB */
scllen = *n;
} else {
/* overdetermined system min || A' * X - B ||
B(1:N,1:NRHS) := Q * B(1:N,1:NRHS) */
i__1 = *lwork - mn;
zunmlq_("Left", "No transpose", n, nrhs, m, &a[a_offset], lda, &
work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
/* workspace at least NRHS, optimally NRHS*NB
B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS) */
ztrsm_("Left", "Lower", "Conjugate transpose", "Non-unit", m,
nrhs, &c_b2, &a[a_offset], lda, &b[b_offset], ldb);
scllen = *m;
}
}
/* Undo scaling */
if (iascl == 1) {
zlascl_("G", &c__0, &c__0, &anrm, &smlnum, &scllen, nrhs, &b[b_offset]
, ldb, info);
} else if (iascl == 2) {
zlascl_("G", &c__0, &c__0, &anrm, &bignum, &scllen, nrhs, &b[b_offset]
, ldb, info);
}
if (ibscl == 1) {
zlascl_("G", &c__0, &c__0, &smlnum, &bnrm, &scllen, nrhs, &b[b_offset]
, ldb, info);
} else if (ibscl == 2) {
zlascl_("G", &c__0, &c__0, &bignum, &bnrm, &scllen, nrhs, &b[b_offset]
, ldb, info);
}
L50:
d__1 = (doublereal) wsize;
work[1].r = d__1, work[1].i = 0.;
return 0;
/* End of ZGELS */
} /* zgels_ */
/* Subroutine */ int ztrt05_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *b,
integer *ldb, doublecomplex *x, integer *ldx, doublecomplex *xact,
integer *ldxact, doublereal *ferr, doublereal *berr, doublereal *
reslts)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
xact_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static doublereal diff, axbi;
static integer imax;
static doublereal unfl, ovfl;
static logical unit;
static integer i__, j, k;
extern logical lsame_(char *, char *);
static logical upper;
static doublereal xnorm;
extern doublereal dlamch_(char *);
static doublereal errbnd;
extern integer izamax_(integer *, doublecomplex *, integer *);
static logical notran;
static integer ifu;
static doublereal eps, tmp;
#define xact_subscr(a_1,a_2) (a_2)*xact_dim1 + a_1
#define xact_ref(a_1,a_2) xact[xact_subscr(a_1,a_2)]
#define 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 x_subscr(a_1,a_2) (a_2)*x_dim1 + a_1
#define x_ref(a_1,a_2) x[x_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
ZTRT05 tests the error bounds from iterative refinement for the
computed solution to a system of equations A*X = B, where A is a
triangular n by n matrix.
RESLTS(1) = test of the error bound
= norm(X - XACT) / ( norm(X) * FERR )
A large value is returned if this ratio is not less than one.
RESLTS(2) = residual from the iterative refinement routine
= the maximum of BERR / ( (n+1)*EPS + (*) ), where
(*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the matrix A is upper or lower triangular.
= 'U': Upper triangular
= 'L': Lower triangular
TRANS (input) CHARACTER*1
Specifies the form of the system of equations.
= 'N': A * X = B (No transpose)
= 'T': A'* X = B (Transpose)
= 'C': A'* X = B (Conjugate transpose = Transpose)
DIAG (input) CHARACTER*1
Specifies whether or not the matrix A is unit triangular.
= 'N': Non-unit triangular
= 'U': Unit triangular
N (input) INTEGER
The number of rows of the matrices X, B, and XACT, and the
order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of columns of the matrices X, B, and XACT.
NRHS >= 0.
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).
B (input) COMPLEX*16 array, dimension (LDB,NRHS)
The right hand side vectors for the system of linear
equations.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input) COMPLEX*16 array, dimension (LDX,NRHS)
The computed solution vectors. Each vector is stored as a
column of the matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
XACT (input) COMPLEX*16 array, dimension (LDX,NRHS)
The exact solution vectors. Each vector is stored as a
column of the matrix XACT.
LDXACT (input) INTEGER
The leading dimension of the array XACT. LDXACT >= max(1,N).
FERR (input) DOUBLE PRECISION array, dimension (NRHS)
The estimated forward error bounds for each solution vector
X. If XTRUE is the true solution, FERR bounds the magnitude
of the largest entry in (X - XTRUE) divided by the magnitude
of the largest entry in X.
BERR (input) DOUBLE PRECISION array, dimension (NRHS)
The componentwise relative backward error of each solution
vector (i.e., the smallest relative change in any entry of A
or B that makes X an exact solution).
RESLTS (output) DOUBLE PRECISION array, dimension (2)
The maximum over the NRHS solution vectors of the ratios:
RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
RESLTS(2) = BERR / ( (n+1)*EPS + (*) )
=====================================================================
Quick exit if N = 0 or NRHS = 0.
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
xact_dim1 = *ldxact;
xact_offset = 1 + xact_dim1 * 1;
xact -= xact_offset;
--ferr;
--berr;
--reslts;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
reslts[1] = 0.;
reslts[2] = 0.;
return 0;
}
eps = dlamch_("Epsilon");
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
unit = lsame_(diag, "U");
/* Test 1: Compute the maximum of
norm(X - XACT) / ( norm(X) * FERR )
over all the vectors X and XACT using the infinity-norm. */
errbnd = 0.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
imax = izamax_(n, &x_ref(1, j), &c__1);
/* Computing MAX */
i__2 = x_subscr(imax, j);
d__3 = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x_ref(imax, j))
, abs(d__2));
xnorm = max(d__3,unfl);
diff = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = x_subscr(i__, j);
i__4 = xact_subscr(i__, j);
z__2.r = x[i__3].r - xact[i__4].r, z__2.i = x[i__3].i - xact[i__4]
.i;
z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MAX */
d__3 = diff, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
z__1), abs(d__2));
diff = max(d__3,d__4);
/* L10: */
}
if (xnorm > 1.) {
goto L20;
} else if (diff <= ovfl * xnorm) {
goto L20;
} else {
errbnd = 1. / eps;
goto L30;
}
L20:
if (diff / xnorm <= ferr[j]) {
/* Computing MAX */
d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
errbnd = max(d__1,d__2);
} else {
errbnd = 1. / eps;
}
L30:
;
}
reslts[1] = errbnd;
/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where
(*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
ifu = 0;
if (unit) {
ifu = 1;
}
i__1 = *nrhs;
for (k = 1; k <= i__1; ++k) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, k);
tmp = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b_ref(i__,
k)), abs(d__2));
if (upper) {
if (! notran) {
i__3 = i__ - ifu;
for (j = 1; j <= i__3; ++j) {
i__4 = a_subscr(j, i__);
i__5 = x_subscr(j, k);
tmp += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
d_imag(&a_ref(j, i__)), abs(d__2))) * ((d__3 =
x[i__5].r, abs(d__3)) + (d__4 = d_imag(&
x_ref(j, k)), abs(d__4)));
/* L40: */
}
if (unit) {
i__3 = x_subscr(i__, k);
tmp += (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
&x_ref(i__, k)), abs(d__2));
}
} else {
if (unit) {
i__3 = x_subscr(i__, k);
tmp += (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
&x_ref(i__, k)), abs(d__2));
}
i__3 = *n;
for (j = i__ + ifu; j <= i__3; ++j) {
i__4 = a_subscr(i__, j);
i__5 = x_subscr(j, k);
tmp += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
d_imag(&a_ref(i__, j)), abs(d__2))) * ((d__3 =
x[i__5].r, abs(d__3)) + (d__4 = d_imag(&
x_ref(j, k)), abs(d__4)));
/* L50: */
}
}
} else {
if (notran) {
i__3 = i__ - ifu;
for (j = 1; j <= i__3; ++j) {
i__4 = a_subscr(i__, j);
i__5 = x_subscr(j, k);
tmp += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
d_imag(&a_ref(i__, j)), abs(d__2))) * ((d__3 =
x[i__5].r, abs(d__3)) + (d__4 = d_imag(&
x_ref(j, k)), abs(d__4)));
/* L60: */
}
if (unit) {
i__3 = x_subscr(i__, k);
tmp += (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
&x_ref(i__, k)), abs(d__2));
}
} else {
if (unit) {
i__3 = x_subscr(i__, k);
tmp += (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
&x_ref(i__, k)), abs(d__2));
}
i__3 = *n;
for (j = i__ + ifu; j <= i__3; ++j) {
i__4 = a_subscr(j, i__);
i__5 = x_subscr(j, k);
tmp += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
d_imag(&a_ref(j, i__)), abs(d__2))) * ((d__3 =
x[i__5].r, abs(d__3)) + (d__4 = d_imag(&
x_ref(j, k)), abs(d__4)));
/* L70: */
}
}
}
if (i__ == 1) {
axbi = tmp;
} else {
axbi = min(axbi,tmp);
}
/* L80: */
}
/* Computing MAX */
d__1 = axbi, d__2 = (*n + 1) * unfl;
tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / max(d__1,d__2));
if (k == 1) {
reslts[2] = tmp;
} else {
reslts[2] = max(reslts[2],tmp);
}
/* L90: */
}
return 0;
/* End of ZTRT05 */
} /* ztrt05_ */
/* Subroutine */ int cgtt05_(char *trans, integer *n, integer *nrhs, complex *
dl, complex *d__, complex *du, complex *b, integer *ldb, complex *x,
integer *ldx, complex *xact, integer *ldxact, real *ferr, real *berr,
real *reslts)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, xact_dim1, xact_offset, i__1,
i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9;
real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10, r__11,
r__12, r__13, r__14;
complex q__1, q__2;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static real diff, axbi;
static integer imax;
static real unfl, ovfl;
static integer i__, j, k;
extern logical lsame_(char *, char *);
static real xnorm;
extern integer icamax_(integer *, complex *, integer *);
extern doublereal slamch_(char *);
static integer nz;
static real errbnd;
static logical notran;
static real eps, tmp;
#define xact_subscr(a_1,a_2) (a_2)*xact_dim1 + a_1
#define xact_ref(a_1,a_2) xact[xact_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define x_subscr(a_1,a_2) (a_2)*x_dim1 + a_1
#define x_ref(a_1,a_2) x[x_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
CGTT05 tests the error bounds from iterative refinement for the
computed solution to a system of equations A*X = B, where A is a
general tridiagonal matrix of order n and op(A) = A or A**T,
depending on TRANS.
RESLTS(1) = test of the error bound
= norm(X - XACT) / ( norm(X) * FERR )
A large value is returned if this ratio is not less than one.
RESLTS(2) = residual from the iterative refinement routine
= the maximum of BERR / ( NZ*EPS + (*) ), where
(*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
and NZ = max. number of nonzeros in any row of A, plus 1
Arguments
=========
TRANS (input) CHARACTER*1
Specifies the form of the system of equations.
= 'N': A * X = B (No transpose)
= 'T': A**T * X = B (Transpose)
= 'C': A**H * X = B (Conjugate transpose = Transpose)
N (input) INTEGER
The number of rows of the matrices X and XACT. N >= 0.
NRHS (input) INTEGER
The number of columns of the matrices X and XACT. NRHS >= 0.
DL (input) COMPLEX array, dimension (N-1)
The (n-1) sub-diagonal elements of A.
D (input) COMPLEX array, dimension (N)
The diagonal elements of A.
DU (input) COMPLEX array, dimension (N-1)
The (n-1) super-diagonal elements of A.
B (input) COMPLEX array, dimension (LDB,NRHS)
The right hand side vectors for the system of linear
equations.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input) COMPLEX array, dimension (LDX,NRHS)
The computed solution vectors. Each vector is stored as a
column of the matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
XACT (input) COMPLEX array, dimension (LDX,NRHS)
The exact solution vectors. Each vector is stored as a
column of the matrix XACT.
LDXACT (input) INTEGER
The leading dimension of the array XACT. LDXACT >= max(1,N).
FERR (input) REAL array, dimension (NRHS)
The estimated forward error bounds for each solution vector
X. If XTRUE is the true solution, FERR bounds the magnitude
of the largest entry in (X - XTRUE) divided by the magnitude
of the largest entry in X.
BERR (input) REAL array, dimension (NRHS)
The componentwise relative backward error of each solution
vector (i.e., the smallest relative change in any entry of A
or B that makes X an exact solution).
RESLTS (output) REAL array, dimension (2)
The maximum over the NRHS solution vectors of the ratios:
RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
RESLTS(2) = BERR / ( NZ*EPS + (*) )
=====================================================================
Quick exit if N = 0 or NRHS = 0.
Parameter adjustments */
--dl;
--d__;
--du;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
xact_dim1 = *ldxact;
xact_offset = 1 + xact_dim1 * 1;
xact -= xact_offset;
--ferr;
--berr;
--reslts;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
reslts[1] = 0.f;
reslts[2] = 0.f;
return 0;
}
eps = slamch_("Epsilon");
unfl = slamch_("Safe minimum");
ovfl = 1.f / unfl;
notran = lsame_(trans, "N");
nz = 4;
/* Test 1: Compute the maximum of
norm(X - XACT) / ( norm(X) * FERR )
over all the vectors X and XACT using the infinity-norm. */
errbnd = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
imax = icamax_(n, &x_ref(1, j), &c__1);
/* Computing MAX */
i__2 = x_subscr(imax, j);
r__3 = (r__1 = x[i__2].r, dabs(r__1)) + (r__2 = r_imag(&x_ref(imax, j)
), dabs(r__2));
xnorm = dmax(r__3,unfl);
diff = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = x_subscr(i__, j);
i__4 = xact_subscr(i__, j);
q__2.r = x[i__3].r - xact[i__4].r, q__2.i = x[i__3].i - xact[i__4]
.i;
q__1.r = q__2.r, q__1.i = q__2.i;
/* Computing MAX */
r__3 = diff, r__4 = (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&
q__1), dabs(r__2));
diff = dmax(r__3,r__4);
/* L10: */
}
if (xnorm > 1.f) {
goto L20;
} else if (diff <= ovfl * xnorm) {
goto L20;
} else {
errbnd = 1.f / eps;
goto L30;
}
L20:
if (diff / xnorm <= ferr[j]) {
/* Computing MAX */
r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
errbnd = dmax(r__1,r__2);
} else {
errbnd = 1.f / eps;
}
L30:
;
}
reslts[1] = errbnd;
/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where
(*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
i__1 = *nrhs;
for (k = 1; k <= i__1; ++k) {
if (notran) {
if (*n == 1) {
i__2 = b_subscr(1, k);
i__3 = x_subscr(1, k);
axbi = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(
1, k)), dabs(r__2)) + ((r__3 = d__[1].r, dabs(r__3))
+ (r__4 = r_imag(&d__[1]), dabs(r__4))) * ((r__5 = x[
i__3].r, dabs(r__5)) + (r__6 = r_imag(&x_ref(1, k)),
dabs(r__6)));
} else {
i__2 = b_subscr(1, k);
i__3 = x_subscr(1, k);
i__4 = x_subscr(2, k);
axbi = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(
1, k)), dabs(r__2)) + ((r__3 = d__[1].r, dabs(r__3))
+ (r__4 = r_imag(&d__[1]), dabs(r__4))) * ((r__5 = x[
i__3].r, dabs(r__5)) + (r__6 = r_imag(&x_ref(1, k)),
dabs(r__6))) + ((r__7 = du[1].r, dabs(r__7)) + (r__8 =
r_imag(&du[1]), dabs(r__8))) * ((r__9 = x[i__4].r,
dabs(r__9)) + (r__10 = r_imag(&x_ref(2, k)), dabs(
r__10)));
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, k);
i__4 = i__ - 1;
i__5 = x_subscr(i__ - 1, k);
i__6 = i__;
i__7 = x_subscr(i__, k);
i__8 = i__;
i__9 = x_subscr(i__ + 1, k);
tmp = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
b_ref(i__, k)), dabs(r__2)) + ((r__3 = dl[i__4].r,
dabs(r__3)) + (r__4 = r_imag(&dl[i__ - 1]), dabs(
r__4))) * ((r__5 = x[i__5].r, dabs(r__5)) + (r__6
= r_imag(&x_ref(i__ - 1, k)), dabs(r__6))) + ((
r__7 = d__[i__6].r, dabs(r__7)) + (r__8 = r_imag(&
d__[i__]), dabs(r__8))) * ((r__9 = x[i__7].r,
dabs(r__9)) + (r__10 = r_imag(&x_ref(i__, k)),
dabs(r__10))) + ((r__11 = du[i__8].r, dabs(r__11))
+ (r__12 = r_imag(&du[i__]), dabs(r__12))) * ((
r__13 = x[i__9].r, dabs(r__13)) + (r__14 = r_imag(
&x_ref(i__ + 1, k)), dabs(r__14)));
axbi = dmin(axbi,tmp);
/* L40: */
}
i__2 = b_subscr(*n, k);
i__3 = *n - 1;
i__4 = x_subscr(*n - 1, k);
i__5 = *n;
i__6 = x_subscr(*n, k);
tmp = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(*
n, k)), dabs(r__2)) + ((r__3 = dl[i__3].r, dabs(r__3))
+ (r__4 = r_imag(&dl[*n - 1]), dabs(r__4))) * ((r__5
= x[i__4].r, dabs(r__5)) + (r__6 = r_imag(&x_ref(*n -
1, k)), dabs(r__6))) + ((r__7 = d__[i__5].r, dabs(
r__7)) + (r__8 = r_imag(&d__[*n]), dabs(r__8))) * ((
r__9 = x[i__6].r, dabs(r__9)) + (r__10 = r_imag(&
x_ref(*n, k)), dabs(r__10)));
axbi = dmin(axbi,tmp);
}
} else {
if (*n == 1) {
i__2 = b_subscr(1, k);
i__3 = x_subscr(1, k);
axbi = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(
1, k)), dabs(r__2)) + ((r__3 = d__[1].r, dabs(r__3))
+ (r__4 = r_imag(&d__[1]), dabs(r__4))) * ((r__5 = x[
i__3].r, dabs(r__5)) + (r__6 = r_imag(&x_ref(1, k)),
dabs(r__6)));
} else {
i__2 = b_subscr(1, k);
i__3 = x_subscr(1, k);
i__4 = x_subscr(2, k);
axbi = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(
1, k)), dabs(r__2)) + ((r__3 = d__[1].r, dabs(r__3))
+ (r__4 = r_imag(&d__[1]), dabs(r__4))) * ((r__5 = x[
i__3].r, dabs(r__5)) + (r__6 = r_imag(&x_ref(1, k)),
dabs(r__6))) + ((r__7 = dl[1].r, dabs(r__7)) + (r__8 =
r_imag(&dl[1]), dabs(r__8))) * ((r__9 = x[i__4].r,
dabs(r__9)) + (r__10 = r_imag(&x_ref(2, k)), dabs(
r__10)));
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, k);
i__4 = i__ - 1;
i__5 = x_subscr(i__ - 1, k);
i__6 = i__;
i__7 = x_subscr(i__, k);
i__8 = i__;
i__9 = x_subscr(i__ + 1, k);
tmp = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
b_ref(i__, k)), dabs(r__2)) + ((r__3 = du[i__4].r,
dabs(r__3)) + (r__4 = r_imag(&du[i__ - 1]), dabs(
r__4))) * ((r__5 = x[i__5].r, dabs(r__5)) + (r__6
= r_imag(&x_ref(i__ - 1, k)), dabs(r__6))) + ((
r__7 = d__[i__6].r, dabs(r__7)) + (r__8 = r_imag(&
d__[i__]), dabs(r__8))) * ((r__9 = x[i__7].r,
dabs(r__9)) + (r__10 = r_imag(&x_ref(i__, k)),
dabs(r__10))) + ((r__11 = dl[i__8].r, dabs(r__11))
+ (r__12 = r_imag(&dl[i__]), dabs(r__12))) * ((
r__13 = x[i__9].r, dabs(r__13)) + (r__14 = r_imag(
&x_ref(i__ + 1, k)), dabs(r__14)));
axbi = dmin(axbi,tmp);
/* L50: */
}
i__2 = b_subscr(*n, k);
i__3 = *n - 1;
i__4 = x_subscr(*n - 1, k);
i__5 = *n;
i__6 = x_subscr(*n, k);
tmp = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(*
n, k)), dabs(r__2)) + ((r__3 = du[i__3].r, dabs(r__3))
+ (r__4 = r_imag(&du[*n - 1]), dabs(r__4))) * ((r__5
= x[i__4].r, dabs(r__5)) + (r__6 = r_imag(&x_ref(*n -
1, k)), dabs(r__6))) + ((r__7 = d__[i__5].r, dabs(
r__7)) + (r__8 = r_imag(&d__[*n]), dabs(r__8))) * ((
r__9 = x[i__6].r, dabs(r__9)) + (r__10 = r_imag(&
x_ref(*n, k)), dabs(r__10)));
axbi = dmin(axbi,tmp);
}
}
/* Computing MAX */
r__1 = axbi, r__2 = nz * unfl;
tmp = berr[k] / (nz * eps + nz * unfl / dmax(r__1,r__2));
if (k == 1) {
reslts[2] = tmp;
} else {
reslts[2] = dmax(reslts[2],tmp);
}
/* L60: */
}
return 0;
/* End of CGTT05 */
} /* cgtt05_ */
/* Subroutine */ int cgtsv_(integer *n, integer *nrhs, complex *dl, complex *
d__, complex *du, complex *b, integer *ldb, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CGTSV solves the equation
A*X = B,
where A is an N-by-N tridiagonal matrix, by Gaussian elimination with
partial pivoting.
Note that the equation A'*X = B may be solved by interchanging the
order of the arguments DU and DL.
Arguments
=========
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.
DL (input/output) COMPLEX array, dimension (N-1)
On entry, DL must contain the (n-1) subdiagonal elements of
A.
On exit, DL is overwritten by the (n-2) elements of the
second superdiagonal of the upper triangular matrix U from
the LU factorization of A, in DL(1), ..., DL(n-2).
D (input/output) COMPLEX array, dimension (N)
On entry, D must contain the diagonal elements of A.
On exit, D is overwritten by the n diagonal elements of U.
DU (input/output) COMPLEX array, dimension (N-1)
On entry, DU must contain the (n-1) superdiagonal elements
of A.
On exit, DU is overwritten by the (n-1) elements of the first
superdiagonal of U.
B (input/output) COMPLEX array, dimension (LDB,NRHS)
On entry, the N-by-NRHS right hand side matrix B.
On exit, if INFO = 0, the N-by-NRHS 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
> 0: if INFO = i, U(i,i) is exactly zero, and the solution
has not been computed. The factorization has not been
completed unless i = N.
=====================================================================
Parameter adjustments */
/* System generated locals */
integer b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
real r__1, r__2, r__3, r__4;
complex q__1, q__2, q__3, q__4, q__5;
/* Builtin functions */
double r_imag(complex *);
void c_div(complex *, complex *, complex *);
/* Local variables */
static complex temp, mult;
static integer j, k;
extern /* Subroutine */ int xerbla_(char *, integer *);
#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)]
--dl;
--d__;
--du;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*nrhs < 0) {
*info = -2;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGTSV ", &i__1);
return 0;
}
if (*n == 0) {
return 0;
}
i__1 = *n - 1;
for (k = 1; k <= i__1; ++k) {
i__2 = k;
if (dl[i__2].r == 0.f && dl[i__2].i == 0.f) {
/* Subdiagonal is zero, no elimination is required. */
i__2 = k;
if (d__[i__2].r == 0.f && d__[i__2].i == 0.f) {
/* Diagonal is zero: set INFO = K and return; a unique
solution can not be found. */
*info = k;
return 0;
}
} else /* if(complicated condition) */ {
i__2 = k;
i__3 = k;
if ((r__1 = d__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&d__[k]),
dabs(r__2)) >= (r__3 = dl[i__3].r, dabs(r__3)) + (r__4 =
r_imag(&dl[k]), dabs(r__4))) {
/* No row interchange required */
c_div(&q__1, &dl[k], &d__[k]);
mult.r = q__1.r, mult.i = q__1.i;
i__2 = k + 1;
i__3 = k + 1;
i__4 = k;
q__2.r = mult.r * du[i__4].r - mult.i * du[i__4].i, q__2.i =
mult.r * du[i__4].i + mult.i * du[i__4].r;
q__1.r = d__[i__3].r - q__2.r, q__1.i = d__[i__3].i - q__2.i;
d__[i__2].r = q__1.r, d__[i__2].i = q__1.i;
i__2 = *nrhs;
for (j = 1; j <= i__2; ++j) {
i__3 = b_subscr(k + 1, j);
i__4 = b_subscr(k + 1, j);
i__5 = b_subscr(k, j);
q__2.r = mult.r * b[i__5].r - mult.i * b[i__5].i, q__2.i =
mult.r * b[i__5].i + mult.i * b[i__5].r;
q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i - q__2.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L10: */
}
if (k < *n - 1) {
i__2 = k;
dl[i__2].r = 0.f, dl[i__2].i = 0.f;
}
} else {
/* Interchange rows K and K+1 */
c_div(&q__1, &d__[k], &dl[k]);
mult.r = q__1.r, mult.i = q__1.i;
i__2 = k;
i__3 = k;
d__[i__2].r = dl[i__3].r, d__[i__2].i = dl[i__3].i;
i__2 = k + 1;
temp.r = d__[i__2].r, temp.i = d__[i__2].i;
i__2 = k + 1;
i__3 = k;
q__2.r = mult.r * temp.r - mult.i * temp.i, q__2.i = mult.r *
temp.i + mult.i * temp.r;
q__1.r = du[i__3].r - q__2.r, q__1.i = du[i__3].i - q__2.i;
d__[i__2].r = q__1.r, d__[i__2].i = q__1.i;
if (k < *n - 1) {
i__2 = k;
i__3 = k + 1;
dl[i__2].r = du[i__3].r, dl[i__2].i = du[i__3].i;
i__2 = k + 1;
q__2.r = -mult.r, q__2.i = -mult.i;
i__3 = k;
q__1.r = q__2.r * dl[i__3].r - q__2.i * dl[i__3].i,
q__1.i = q__2.r * dl[i__3].i + q__2.i * dl[i__3]
.r;
du[i__2].r = q__1.r, du[i__2].i = q__1.i;
}
i__2 = k;
du[i__2].r = temp.r, du[i__2].i = temp.i;
i__2 = *nrhs;
for (j = 1; j <= i__2; ++j) {
i__3 = b_subscr(k, j);
temp.r = b[i__3].r, temp.i = b[i__3].i;
i__3 = b_subscr(k, j);
i__4 = b_subscr(k + 1, j);
b[i__3].r = b[i__4].r, b[i__3].i = b[i__4].i;
i__3 = b_subscr(k + 1, j);
i__4 = b_subscr(k + 1, j);
q__2.r = mult.r * b[i__4].r - mult.i * b[i__4].i, q__2.i =
mult.r * b[i__4].i + mult.i * b[i__4].r;
q__1.r = temp.r - q__2.r, q__1.i = temp.i - q__2.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L20: */
}
}
}
/* L30: */
}
i__1 = *n;
if (d__[i__1].r == 0.f && d__[i__1].i == 0.f) {
*info = *n;
return 0;
}
/* Back solve with the matrix U from the factorization. */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = b_subscr(*n, j);
c_div(&q__1, &b_ref(*n, j), &d__[*n]);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
if (*n > 1) {
i__2 = b_subscr(*n - 1, j);
i__3 = b_subscr(*n - 1, j);
i__4 = *n - 1;
i__5 = b_subscr(*n, j);
q__3.r = du[i__4].r * b[i__5].r - du[i__4].i * b[i__5].i, q__3.i =
du[i__4].r * b[i__5].i + du[i__4].i * b[i__5].r;
q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
c_div(&q__1, &q__2, &d__[*n - 1]);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
}
for (k = *n - 2; k >= 1; --k) {
i__2 = b_subscr(k, j);
i__3 = b_subscr(k, j);
i__4 = k;
i__5 = b_subscr(k + 1, j);
q__4.r = du[i__4].r * b[i__5].r - du[i__4].i * b[i__5].i, q__4.i =
du[i__4].r * b[i__5].i + du[i__4].i * b[i__5].r;
q__3.r = b[i__3].r - q__4.r, q__3.i = b[i__3].i - q__4.i;
i__6 = k;
i__7 = b_subscr(k + 2, j);
q__5.r = dl[i__6].r * b[i__7].r - dl[i__6].i * b[i__7].i, q__5.i =
dl[i__6].r * b[i__7].i + dl[i__6].i * b[i__7].r;
q__2.r = q__3.r - q__5.r, q__2.i = q__3.i - q__5.i;
c_div(&q__1, &q__2, &d__[k]);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L40: */
}
/* L50: */
}
return 0;
/* End of CGTSV */
} /* cgtsv_ */
/* Subroutine */ int ctgsen_(integer *ijob, logical *wantq, logical *wantz,
logical *select, integer *n, complex *a, integer *lda, complex *b,
integer *ldb, complex *alpha, complex *beta, complex *q, integer *ldq,
complex *z__, integer *ldz, integer *m, real *pl, real *pr, real *
dif, complex *work, integer *lwork, integer *iwork, integer *liwork,
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
=======
CTGSEN reorders the generalized Schur decomposition of a complex
matrix pair (A, B) (in terms of an unitary equivalence trans-
formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues
appears in the leading diagonal blocks of the pair (A,B). The leading
columns of Q and Z form unitary bases of the corresponding left and
right eigenspaces (deflating subspaces). (A, B) must be in
generalized Schur canonical form, that is, A and B are both upper
triangular.
CTGSEN also computes the generalized eigenvalues
w(j)= ALPHA(j) / BETA(j)
of the reordered matrix pair (A, B).
Optionally, the routine computes estimates of reciprocal condition
numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),
(A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)
between the matrix pairs (A11, B11) and (A22,B22) that correspond to
the selected cluster and the eigenvalues outside the cluster, resp.,
and norms of "projections" onto left and right eigenspaces w.r.t.
the selected cluster in the (1,1)-block.
Arguments
=========
IJOB (input) integer
Specifies whether condition numbers are required for the
cluster of eigenvalues (PL and PR) or the deflating subspaces
(Difu and Difl):
=0: Only reorder w.r.t. SELECT. No extras.
=1: Reciprocal of norms of "projections" onto left and right
eigenspaces w.r.t. the selected cluster (PL and PR).
=2: Upper bounds on Difu and Difl. F-norm-based estimate
(DIF(1:2)).
=3: Estimate of Difu and Difl. 1-norm-based estimate
(DIF(1:2)).
About 5 times as expensive as IJOB = 2.
=4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic
version to get it all.
=5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)
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.
SELECT (input) LOGICAL array, dimension (N)
SELECT specifies the eigenvalues in the selected cluster. To
select an eigenvalue w(j), SELECT(j) must be set to
.TRUE..
N (input) INTEGER
The order of the matrices A and B. N >= 0.
A (input/output) COMPLEX array, dimension(LDA,N)
On entry, the upper triangular matrix A, in generalized
Schur canonical form.
On exit, A is overwritten by the reordered matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input/output) COMPLEX array, dimension(LDB,N)
On entry, the upper triangular matrix B, in generalized
Schur canonical form.
On exit, B is overwritten by the reordered matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
ALPHA (output) COMPLEX array, dimension (N)
BETA (output) COMPLEX array, dimension (N)
The diagonal elements of A and B, respectively,
when the pair (A,B) has been reduced to generalized Schur
form. ALPHA(i)/BETA(i) i=1,...,N are the generalized
eigenvalues.
Q (input/output) COMPLEX array, dimension (LDQ,N)
On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.
On exit, Q has been postmultiplied by the left unitary
transformation matrix which reorder (A, B); The leading M
columns of Q form orthonormal bases for the specified pair of
left eigenspaces (deflating subspaces).
If WANTQ = .FALSE., Q is not referenced.
LDQ (input) INTEGER
The leading dimension of the array Q. LDQ >= 1.
If WANTQ = .TRUE., LDQ >= N.
Z (input/output) COMPLEX array, dimension (LDZ,N)
On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.
On exit, Z has been postmultiplied by the left unitary
transformation matrix which reorder (A, B); The leading M
columns of Z form orthonormal bases for the specified pair of
left eigenspaces (deflating subspaces).
If WANTZ = .FALSE., Z is not referenced.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1.
If WANTZ = .TRUE., LDZ >= N.
M (output) INTEGER
The dimension of the specified pair of left and right
eigenspaces, (deflating subspaces) 0 <= M <= N.
PL, PR (output) REAL
If IJOB = 1, 4 or 5, PL, PR are lower bounds on the
reciprocal of the norm of "projections" onto left and right
eigenspace with respect to the selected cluster.
0 < PL, PR <= 1.
If M = 0 or M = N, PL = PR = 1.
If IJOB = 0, 2 or 3 PL, PR are not referenced.
DIF (output) REAL array, dimension (2).
If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.
If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on
Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based
estimates of Difu and Difl, computed using reversed
communication with CLACON.
If M = 0 or N, DIF(1:2) = F-norm([A, B]).
If IJOB = 0 or 1, DIF is not referenced.
WORK (workspace/output) COMPLEX array, dimension (LWORK)
IF IJOB = 0, WORK is not referenced. Otherwise,
on exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= 1
If IJOB = 1, 2 or 4, LWORK >= 2*M*(N-M)
If IJOB = 3 or 5, LWORK >= 4*M*(N-M)
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.
IWORK (workspace/output) INTEGER, dimension (LIWORK)
IF IJOB = 0, IWORK is not referenced. Otherwise,
on exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
LIWORK (input) INTEGER
The dimension of the array IWORK. LIWORK >= 1.
If IJOB = 1, 2 or 4, LIWORK >= N+2;
If IJOB = 3 or 5, LIWORK >= MAX(N+2, 2*M*(N-M));
If LIWORK = -1, then a workspace query is assumed; the
routine only calculates the optimal size of the IWORK array,
returns this value as the first entry of the IWORK array, and
no error message related to LIWORK is issued by XERBLA.
INFO (output) INTEGER
=0: Successful exit.
<0: If INFO = -i, the i-th argument had an illegal value.
=1: Reordering of (A, B) failed because the transformed
matrix pair (A, B) would be too far from generalized
Schur form; the problem is very ill-conditioned.
(A, B) may have been partially reordered.
If requested, 0 is returned in DIF(*), PL and PR.
Further Details
===============
CTGSEN first collects the selected eigenvalues by computing unitary
U and W that move them to the top left corner of (A, B). In other
words, the selected eigenvalues are the eigenvalues of (A11, B11) in
U'*(A, B)*W = (A11 A12) (B11 B12) n1
( 0 A22),( 0 B22) n2
n1 n2 n1 n2
where N = n1+n2 and U' means the conjugate transpose of U. The first
n1 columns of U and W span the specified pair of left and right
eigenspaces (deflating subspaces) of (A, B).
If (A, B) has been obtained from the generalized real Schur
decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the
reordered generalized Schur form of (C, D) is given by
(C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',
and the first n1 columns of Q*U and Z*W span the corresponding
deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).
Note that if the selected eigenvalue is sufficiently ill-conditioned,
then its value may differ significantly from its value before
reordering.
The reciprocal condition numbers of the left and right eigenspaces
spanned by the first n1 columns of U and W (or Q*U and Z*W) may
be returned in DIF(1:2), corresponding to Difu and Difl, resp.
The Difu and Difl are defined as:
Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )
and
Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],
where sigma-min(Zu) is the smallest singular value of the
(2*n1*n2)-by-(2*n1*n2) matrix
Zu = [ kron(In2, A11) -kron(A22', In1) ]
[ kron(In2, B11) -kron(B22', In1) ].
Here, Inx is the identity matrix of size nx and A22' is the
transpose of A22. kron(X, Y) is the Kronecker product between
the matrices X and Y.
When DIF(2) is small, small changes in (A, B) can cause large changes
in the deflating subspace. An approximate (asymptotic) bound on the
maximum angular error in the computed deflating subspaces is
EPS * norm((A, B)) / DIF(2),
where EPS is the machine precision.
The reciprocal norm of the projectors on the left and right
eigenspaces associated with (A11, B11) may be returned in PL and PR.
They are computed as follows. First we compute L and R so that
P*(A, B)*Q is block diagonal, where
P = ( I -L ) n1 Q = ( I R ) n1
( 0 I ) n2 and ( 0 I ) n2
n1 n2 n1 n2
and (L, R) is the solution to the generalized Sylvester equation
A11*R - L*A22 = -A12
B11*R - L*B22 = -B12
Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).
An approximate (asymptotic) bound on the average absolute error of
the selected eigenvalues is
EPS * norm((A, B)) / PL.
There are also global error bounds which valid for perturbations up
to a certain restriction: A lower bound (x) on the smallest
F-norm(E,F) for which an eigenvalue of (A11, B11) may move and
coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),
(i.e. (A + E, B + F), is
x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).
An approximate bound on x can be computed from DIF(1:2), PL and PR.
If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed
(L', R') and unperturbed (L, R) left and right deflating subspaces
associated with the selected cluster in the (1,1)-blocks can be
bounded as
max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))
max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))
See LAPACK User's Guide section 4.11 or the following references
for more information.
Note that if the default method for computing the Frobenius-norm-
based estimate DIF is not wanted (see CLATDF), then the parameter
IDIFJB (see below) should be changed from 3 to 4 (routine CLATDF
(IJOB = 2 will be used)). See CTGSYL for more details.
Based on contributions by
Bo Kagstrom and Peter Poromaa, Department of Computing Science,
Umea University, S-901 87 Umea, Sweden.
References
==========
[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.
[3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
for Solving the Generalized Sylvester Equation and Estimating the
Separation between Regular Matrix Pairs, Report UMINF - 93.23,
Department of Computing Science, Umea University, S-901 87 Umea,
Sweden, December 1993, Revised April 1994, Also as LAPACK working
Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,
1996.
=====================================================================
Decode and test the input parameters
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
z_offset, i__1, i__2, i__3;
complex q__1, q__2;
/* Builtin functions */
double sqrt(doublereal), c_abs(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
static integer kase, ierr;
static real dsum;
static logical swap;
static integer i__, k;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
static logical wantd;
static integer lwmin;
static logical wantp;
static integer n1, n2;
static logical wantd1, wantd2;
static real dscale;
static integer ks;
extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real
*, integer *);
extern doublereal slamch_(char *);
static real rdscal;
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *);
static real safmin;
extern /* Subroutine */ int ctgexc_(logical *, logical *, integer *,
complex *, integer *, complex *, integer *, complex *, integer *,
complex *, integer *, integer *, integer *, integer *), xerbla_(
char *, integer *), classq_(integer *, complex *, integer
*, real *, real *);
static integer liwmin;
extern /* Subroutine */ int ctgsyl_(char *, integer *, integer *, integer
*, complex *, integer *, complex *, integer *, complex *, integer
*, complex *, integer *, complex *, integer *, complex *, integer
*, real *, real *, complex *, integer *, integer *, integer *);
static integer mn2;
static logical lquery;
static integer ijb;
#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)]
--select;
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;
--dif;
--work;
--iwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1 || *liwork == -1;
if (*ijob < 0 || *ijob > 5) {
*info = -1;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldq < 1 || *wantq && *ldq < *n) {
*info = -13;
} else if (*ldz < 1 || *wantz && *ldz < *n) {
*info = -15;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTGSEN", &i__1);
return 0;
}
ierr = 0;
wantp = *ijob == 1 || *ijob >= 4;
wantd1 = *ijob == 2 || *ijob == 4;
wantd2 = *ijob == 3 || *ijob == 5;
wantd = wantd1 || wantd2;
/* Set M to the dimension of the specified pair of deflating
subspaces. */
*m = 0;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
i__2 = k;
i__3 = a_subscr(k, k);
alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i;
i__2 = k;
i__3 = b_subscr(k, k);
beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i;
if (k < *n) {
if (select[k]) {
++(*m);
}
} else {
if (select[*n]) {
++(*m);
}
}
/* L10: */
}
if (*ijob == 1 || *ijob == 2 || *ijob == 4) {
/* Computing MAX */
i__1 = 1, i__2 = (*m << 1) * (*n - *m);
lwmin = max(i__1,i__2);
/* Computing MAX */
i__1 = 1, i__2 = *n + 2;
liwmin = max(i__1,i__2);
} else if (*ijob == 3 || *ijob == 5) {
/* Computing MAX */
i__1 = 1, i__2 = (*m << 2) * (*n - *m);
lwmin = max(i__1,i__2);
/* Computing MAX */
i__1 = 1, i__2 = (*m << 1) * (*n - *m), i__1 = max(i__1,i__2), i__2 =
*n + 2;
liwmin = max(i__1,i__2);
} else {
lwmin = 1;
liwmin = 1;
}
work[1].r = (real) lwmin, work[1].i = 0.f;
iwork[1] = liwmin;
if (*lwork < lwmin && ! lquery) {
*info = -21;
} else if (*liwork < liwmin && ! lquery) {
*info = -23;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTGSEN", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible. */
if (*m == *n || *m == 0) {
if (wantp) {
*pl = 1.f;
*pr = 1.f;
}
if (wantd) {
dscale = 0.f;
dsum = 1.f;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
classq_(n, &a_ref(1, i__), &c__1, &dscale, &dsum);
classq_(n, &b_ref(1, i__), &c__1, &dscale, &dsum);
/* L20: */
}
dif[1] = dscale * sqrt(dsum);
dif[2] = dif[1];
}
goto L70;
}
/* Get machine constant */
safmin = slamch_("S");
/* Collect the selected blocks at the top-left corner of (A, B). */
ks = 0;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
swap = select[k];
if (swap) {
++ks;
/* Swap the K-th block to position KS. Compute unitary Q
and Z that will swap adjacent diagonal blocks in (A, B). */
if (k != ks) {
ctgexc_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb,
&q[q_offset], ldq, &z__[z_offset], ldz, &k, &ks, &
ierr);
}
if (ierr > 0) {
/* Swap is rejected: exit. */
*info = 1;
if (wantp) {
*pl = 0.f;
*pr = 0.f;
}
if (wantd) {
dif[1] = 0.f;
dif[2] = 0.f;
}
goto L70;
}
}
/* L30: */
}
if (wantp) {
/* Solve generalized Sylvester equation for R and L:
A11 * R - L * A22 = A12
B11 * R - L * B22 = B12 */
n1 = *m;
n2 = *n - *m;
i__ = n1 + 1;
clacpy_("Full", &n1, &n2, &a_ref(1, i__), lda, &work[1], &n1);
clacpy_("Full", &n1, &n2, &b_ref(1, i__), ldb, &work[n1 * n2 + 1], &
n1);
ijb = 0;
i__1 = *lwork - (n1 << 1) * n2;
ctgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a_ref(i__, i__), lda,
&work[1], &n1, &b[b_offset], ldb, &b_ref(i__, i__), ldb, &
work[n1 * n2 + 1], &n1, &dscale, &dif[1], &work[(n1 * n2 << 1)
+ 1], &i__1, &iwork[1], &ierr);
/* Estimate the reciprocal of norms of "projections" onto
left and right eigenspaces */
rdscal = 0.f;
dsum = 1.f;
i__1 = n1 * n2;
classq_(&i__1, &work[1], &c__1, &rdscal, &dsum);
*pl = rdscal * sqrt(dsum);
if (*pl == 0.f) {
*pl = 1.f;
} else {
*pl = dscale / (sqrt(dscale * dscale / *pl + *pl) * sqrt(*pl));
}
rdscal = 0.f;
dsum = 1.f;
i__1 = n1 * n2;
classq_(&i__1, &work[n1 * n2 + 1], &c__1, &rdscal, &dsum);
*pr = rdscal * sqrt(dsum);
if (*pr == 0.f) {
*pr = 1.f;
} else {
*pr = dscale / (sqrt(dscale * dscale / *pr + *pr) * sqrt(*pr));
}
}
if (wantd) {
/* Compute estimates Difu and Difl. */
if (wantd1) {
n1 = *m;
n2 = *n - *m;
i__ = n1 + 1;
ijb = 3;
/* Frobenius norm-based Difu estimate. */
i__1 = *lwork - (n1 << 1) * n2;
ctgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a_ref(i__, i__),
lda, &work[1], &n1, &b[b_offset], ldb, &b_ref(i__, i__),
ldb, &work[n1 * n2 + 1], &n1, &dscale, &dif[1], &work[(n1
* n2 << 1) + 1], &i__1, &iwork[1], &ierr);
/* Frobenius norm-based Difl estimate. */
i__1 = *lwork - (n1 << 1) * n2;
ctgsyl_("N", &ijb, &n2, &n1, &a_ref(i__, i__), lda, &a[a_offset],
lda, &work[1], &n2, &b_ref(i__, i__), ldb, &b[b_offset],
ldb, &work[n1 * n2 + 1], &n2, &dscale, &dif[2], &work[(n1
* n2 << 1) + 1], &i__1, &iwork[1], &ierr);
} else {
/* Compute 1-norm-based estimates of Difu and Difl using
reversed communication with CLACON. In each step a
generalized Sylvester equation or a transposed variant
is solved. */
kase = 0;
n1 = *m;
n2 = *n - *m;
i__ = n1 + 1;
ijb = 0;
mn2 = (n1 << 1) * n2;
/* 1-norm-based estimate of Difu. */
L40:
clacon_(&mn2, &work[mn2 + 1], &work[1], &dif[1], &kase);
if (kase != 0) {
if (kase == 1) {
/* Solve generalized Sylvester equation */
i__1 = *lwork - (n1 << 1) * n2;
ctgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a_ref(
i__, i__), lda, &work[1], &n1, &b[b_offset], ldb,
&b_ref(i__, i__), ldb, &work[n1 * n2 + 1], &n1, &
dscale, &dif[1], &work[(n1 * n2 << 1) + 1], &i__1,
&iwork[1], &ierr);
} else {
/* Solve the transposed variant. */
i__1 = *lwork - (n1 << 1) * n2;
ctgsyl_("C", &ijb, &n1, &n2, &a[a_offset], lda, &a_ref(
i__, i__), lda, &work[1], &n1, &b[b_offset], ldb,
&b_ref(i__, i__), ldb, &work[n1 * n2 + 1], &n1, &
dscale, &dif[1], &work[(n1 * n2 << 1) + 1], &i__1,
&iwork[1], &ierr);
}
goto L40;
}
dif[1] = dscale / dif[1];
/* 1-norm-based estimate of Difl. */
L50:
clacon_(&mn2, &work[mn2 + 1], &work[1], &dif[2], &kase);
if (kase != 0) {
if (kase == 1) {
/* Solve generalized Sylvester equation */
i__1 = *lwork - (n1 << 1) * n2;
ctgsyl_("N", &ijb, &n2, &n1, &a_ref(i__, i__), lda, &a[
a_offset], lda, &work[1], &n2, &b_ref(i__, i__),
ldb, &b[b_offset], ldb, &work[n1 * n2 + 1], &n2, &
dscale, &dif[2], &work[(n1 * n2 << 1) + 1], &i__1,
&iwork[1], &ierr);
} else {
/* Solve the transposed variant. */
i__1 = *lwork - (n1 << 1) * n2;
ctgsyl_("C", &ijb, &n2, &n1, &a_ref(i__, i__), lda, &a[
a_offset], lda, &work[1], &n2, &b[b_offset], ldb,
&b_ref(i__, i__), ldb, &work[n1 * n2 + 1], &n2, &
dscale, &dif[2], &work[(n1 * n2 << 1) + 1], &i__1,
&iwork[1], &ierr);
}
goto L50;
}
dif[2] = dscale / dif[2];
}
}
/* If B(K,K) is complex, make it real and positive (normalization
of the generalized Schur form) and Store the generalized
eigenvalues of reordered pair (A, B) */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
dscale = c_abs(&b_ref(k, k));
if (dscale > safmin) {
i__2 = b_subscr(k, k);
q__2.r = b[i__2].r / dscale, q__2.i = b[i__2].i / dscale;
r_cnjg(&q__1, &q__2);
work[1].r = q__1.r, work[1].i = q__1.i;
i__2 = b_subscr(k, k);
q__1.r = b[i__2].r / dscale, q__1.i = b[i__2].i / dscale;
work[2].r = q__1.r, work[2].i = q__1.i;
i__2 = b_subscr(k, k);
b[i__2].r = dscale, b[i__2].i = 0.f;
i__2 = *n - k;
cscal_(&i__2, &work[1], &b_ref(k, k + 1), ldb);
i__2 = *n - k + 1;
cscal_(&i__2, &work[1], &a_ref(k, k), lda);
if (*wantq) {
cscal_(n, &work[2], &q_ref(1, k), &c__1);
}
} else {
i__2 = b_subscr(k, k);
b[i__2].r = 0.f, b[i__2].i = 0.f;
}
i__2 = k;
i__3 = a_subscr(k, k);
alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i;
i__2 = k;
i__3 = b_subscr(k, k);
beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i;
/* L60: */
}
L70:
work[1].r = (real) lwmin, work[1].i = 0.f;
iwork[1] = liwmin;
return 0;
/* End of CTGSEN */
} /* ctgsen_ */
/* Subroutine */ int zsymm_(char *side, char *uplo, integer *m, integer *n,
doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex *
b, integer *ldb, doublecomplex *beta, doublecomplex *c__, integer *
ldc)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
i__3, i__4, i__5, i__6;
doublecomplex z__1, z__2, z__3, z__4, z__5;
/* Local variables */
static integer info;
static doublecomplex temp1, temp2;
static integer i__, j, k;
extern logical lsame_(char *, char *);
static integer nrowa;
static logical upper;
extern /* Subroutine */ int xerbla_(char *, integer *);
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1
#define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)]
/* Purpose
=======
ZSYMM performs one of the matrix-matrix operations
C := alpha*A*B + beta*C,
or
C := alpha*B*A + beta*C,
where alpha and beta are scalars, A is a symmetric matrix and B and
C are m by n matrices.
Parameters
==========
SIDE - CHARACTER*1.
On entry, SIDE specifies whether the symmetric matrix A
appears on the left or right in the operation as follows:
SIDE = 'L' or 'l' C := alpha*A*B + beta*C,
SIDE = 'R' or 'r' C := alpha*B*A + beta*C,
Unchanged on exit.
UPLO - CHARACTER*1.
On entry, UPLO specifies whether the upper or lower
triangular part of the symmetric matrix A is to be
referenced as follows:
UPLO = 'U' or 'u' Only the upper triangular part of the
symmetric matrix is to be referenced.
UPLO = 'L' or 'l' Only the lower triangular part of the
symmetric matrix is to be referenced.
Unchanged on exit.
M - INTEGER.
On entry, M specifies the number of rows of the matrix C.
M must be at least zero.
Unchanged on exit.
N - INTEGER.
On entry, N specifies the number of columns of the matrix C.
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, ka ), where ka is
m when SIDE = 'L' or 'l' and is n otherwise.
Before entry with SIDE = 'L' or 'l', the m by m part of
the array A must contain the symmetric matrix, such that
when UPLO = 'U' or 'u', the leading m by m upper triangular
part of the array A must contain the upper triangular part
of the symmetric matrix and the strictly lower triangular
part of A is not referenced, and when UPLO = 'L' or 'l',
the leading m by m lower triangular part of the array A
must contain the lower triangular part of the symmetric
matrix and the strictly upper triangular part of A is not
referenced.
Before entry with SIDE = 'R' or 'r', the n by n part of
the array A must contain the symmetric matrix, such that
when UPLO = 'U' or 'u', the leading n by n upper triangular
part of the array A must contain the upper triangular part
of the symmetric matrix and the strictly lower triangular
part of A is not referenced, and when UPLO = 'L' or 'l',
the leading n by n lower triangular part of the array A
must contain the lower triangular part of the symmetric
matrix and the strictly upper triangular part of A is not
referenced.
Unchanged on exit.
LDA - INTEGER.
On entry, LDA specifies the first dimension of A as declared
in the calling (sub) program. When SIDE = 'L' or 'l' then
LDA must be at least max( 1, m ), otherwise LDA must be at
least max( 1, n ).
Unchanged on exit.
B - COMPLEX*16 array of DIMENSION ( LDB, n ).
Before entry, the leading m by n part of the array B must
contain the matrix B.
Unchanged on exit.
LDB - INTEGER.
On entry, LDB specifies the first dimension of B as declared
in the calling (sub) program. LDB must be at least
max( 1, m ).
Unchanged on exit.
BETA - COMPLEX*16 .
On entry, BETA specifies the scalar beta. When BETA is
supplied as zero then C need not be set on input.
Unchanged on exit.
C - COMPLEX*16 array of DIMENSION ( LDC, n ).
Before entry, the leading m by n part of the array C must
contain the matrix C, except when beta is zero, in which
case C need not be set on entry.
On exit, the array C is overwritten by the m by n updated
matrix.
LDC - INTEGER.
On entry, LDC specifies the first dimension of C as declared
in the calling (sub) program. LDC must be at least
max( 1, m ).
Unchanged on exit.
Level 3 Blas routine.
-- Written on 8-February-1989.
Jack Dongarra, Argonne National Laboratory.
Iain Duff, AERE Harwell.
Jeremy Du Croz, Numerical Algorithms Group Ltd.
Sven Hammarling, Numerical Algorithms Group Ltd.
Set NROWA as the number of rows of A.
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;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
/* Function Body */
if (lsame_(side, "L")) {
nrowa = *m;
} else {
nrowa = *n;
}
upper = lsame_(uplo, "U");
/* Test the input parameters. */
info = 0;
if (! lsame_(side, "L") && ! lsame_(side, "R")) {
info = 1;
} else if (! upper && ! lsame_(uplo, "L")) {
info = 2;
} else if (*m < 0) {
info = 3;
} else if (*n < 0) {
info = 4;
} else if (*lda < max(1,nrowa)) {
info = 7;
} else if (*ldb < max(1,*m)) {
info = 9;
} else if (*ldc < max(1,*m)) {
info = 12;
}
if (info != 0) {
xerbla_("ZSYMM ", &info);
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;
}
/* And when alpha.eq.zero. */
if (alpha->r == 0. && alpha->i == 0.) {
if (beta->r == 0. && beta->i == 0.) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, j);
c__[i__3].r = 0., c__[i__3].i = 0.;
/* L10: */
}
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, j);
i__4 = c___subscr(i__, j);
z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i,
z__1.i = beta->r * c__[i__4].i + beta->i * c__[
i__4].r;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L30: */
}
/* L40: */
}
}
return 0;
}
/* Start the operations. */
if (lsame_(side, "L")) {
/* Form C := alpha*A*B + beta*C. */
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
z__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3]
.r;
temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.;
i__3 = i__ - 1;
for (k = 1; k <= i__3; ++k) {
i__4 = c___subscr(k, j);
i__5 = c___subscr(k, j);
i__6 = a_subscr(k, i__);
z__2.r = temp1.r * a[i__6].r - temp1.i * a[i__6].i,
z__2.i = temp1.r * a[i__6].i + temp1.i * a[
i__6].r;
z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i +
z__2.i;
c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
i__4 = b_subscr(k, j);
i__5 = a_subscr(k, i__);
z__2.r = b[i__4].r * a[i__5].r - b[i__4].i * a[i__5]
.i, z__2.i = b[i__4].r * a[i__5].i + b[i__4]
.i * a[i__5].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;
/* L50: */
}
if (beta->r == 0. && beta->i == 0.) {
i__3 = c___subscr(i__, j);
i__4 = a_subscr(i__, i__);
z__2.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i,
z__2.i = temp1.r * a[i__4].i + temp1.i * a[
i__4].r;
z__3.r = alpha->r * temp2.r - alpha->i * temp2.i,
z__3.i = alpha->r * temp2.i + alpha->i *
temp2.r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
} else {
i__3 = c___subscr(i__, j);
i__4 = c___subscr(i__, j);
z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
.i, z__3.i = beta->r * c__[i__4].i + beta->i *
c__[i__4].r;
i__5 = a_subscr(i__, i__);
z__4.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
z__4.i = temp1.r * a[i__5].i + temp1.i * a[
i__5].r;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = alpha->r * temp2.r - alpha->i * temp2.i,
z__5.i = alpha->r * temp2.i + alpha->i *
temp2.r;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
}
/* L60: */
}
/* L70: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
for (i__ = *m; i__ >= 1; --i__) {
i__2 = b_subscr(i__, j);
z__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2].i,
z__1.i = alpha->r * b[i__2].i + alpha->i * b[i__2]
.r;
temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.;
i__2 = *m;
for (k = i__ + 1; k <= i__2; ++k) {
i__3 = c___subscr(k, j);
i__4 = c___subscr(k, j);
i__5 = a_subscr(k, i__);
z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
z__2.i = temp1.r * a[i__5].i + temp1.i * a[
i__5].r;
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;
i__3 = b_subscr(k, j);
i__4 = a_subscr(k, i__);
z__2.r = b[i__3].r * a[i__4].r - b[i__3].i * a[i__4]
.i, z__2.i = b[i__3].r * a[i__4].i + b[i__3]
.i * a[i__4].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;
/* L80: */
}
if (beta->r == 0. && beta->i == 0.) {
i__2 = c___subscr(i__, j);
i__3 = a_subscr(i__, i__);
z__2.r = temp1.r * a[i__3].r - temp1.i * a[i__3].i,
z__2.i = temp1.r * a[i__3].i + temp1.i * a[
i__3].r;
z__3.r = alpha->r * temp2.r - alpha->i * temp2.i,
z__3.i = alpha->r * temp2.i + alpha->i *
temp2.r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
} else {
i__2 = c___subscr(i__, j);
i__3 = c___subscr(i__, j);
z__3.r = beta->r * c__[i__3].r - beta->i * c__[i__3]
.i, z__3.i = beta->r * c__[i__3].i + beta->i *
c__[i__3].r;
i__4 = a_subscr(i__, i__);
z__4.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i,
z__4.i = temp1.r * a[i__4].i + temp1.i * a[
i__4].r;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = alpha->r * temp2.r - alpha->i * temp2.i,
z__5.i = alpha->r * temp2.i + alpha->i *
temp2.r;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
}
/* L90: */
}
/* L100: */
}
}
} else {
/* Form C := alpha*B*A + beta*C. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = a_subscr(j, j);
z__1.r = alpha->r * a[i__2].r - alpha->i * a[i__2].i, z__1.i =
alpha->r * a[i__2].i + alpha->i * a[i__2].r;
temp1.r = z__1.r, temp1.i = z__1.i;
if (beta->r == 0. && beta->i == 0.) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, j);
i__4 = b_subscr(i__, j);
z__1.r = temp1.r * b[i__4].r - temp1.i * b[i__4].i,
z__1.i = temp1.r * b[i__4].i + temp1.i * b[i__4]
.r;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L110: */
}
} else {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, j);
i__4 = c___subscr(i__, j);
z__2.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i,
z__2.i = beta->r * c__[i__4].i + beta->i * c__[
i__4].r;
i__5 = b_subscr(i__, j);
z__3.r = temp1.r * b[i__5].r - temp1.i * b[i__5].i,
z__3.i = temp1.r * b[i__5].i + temp1.i * b[i__5]
.r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L120: */
}
}
i__2 = j - 1;
for (k = 1; k <= i__2; ++k) {
if (upper) {
i__3 = a_subscr(k, j);
z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
z__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3]
.r;
temp1.r = z__1.r, temp1.i = z__1.i;
} else {
i__3 = a_subscr(j, k);
z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
z__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3]
.r;
temp1.r = z__1.r, temp1.i = z__1.i;
}
i__3 = *m;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = c___subscr(i__, j);
i__5 = c___subscr(i__, j);
i__6 = b_subscr(i__, k);
z__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i,
z__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6]
.r;
z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i +
z__2.i;
c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
/* L130: */
}
/* L140: */
}
i__2 = *n;
for (k = j + 1; k <= i__2; ++k) {
if (upper) {
i__3 = a_subscr(j, k);
z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
z__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3]
.r;
temp1.r = z__1.r, temp1.i = z__1.i;
} else {
i__3 = a_subscr(k, j);
z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
z__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3]
.r;
temp1.r = z__1.r, temp1.i = z__1.i;
}
i__3 = *m;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = c___subscr(i__, j);
i__5 = c___subscr(i__, j);
i__6 = b_subscr(i__, k);
z__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i,
z__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6]
.r;
z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i +
z__2.i;
c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
/* L150: */
}
/* L160: */
}
/* L170: */
}
}
return 0;
/* End of ZSYMM . */
} /* zsymm_ */
/* Subroutine */ int zlacpy_(char *uplo, integer *m, integer *n,
doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb)
{
/* -- 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
=======
ZLACPY copies all or part of a two-dimensional matrix A to another
matrix B.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies the part of the matrix A to be copied to B.
= 'U': Upper triangular part
= 'L': Lower triangular part
Otherwise: All of the matrix A
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) COMPLEX*16 array, dimension (LDA,N)
The m by n matrix A. If UPLO = 'U', only the upper trapezium
is accessed; if UPLO = 'L', only the lower trapezium is
accessed.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
B (output) COMPLEX*16 array, dimension (LDB,N)
On exit, B = A in the locations specified by UPLO.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,M).
=====================================================================
Parameter adjustments */
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
/* Local variables */
static integer i__, j;
extern logical lsame_(char *, char *);
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
/* Function Body */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = min(j,*m);
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = a_subscr(i__, j);
b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i;
/* L10: */
}
/* L20: */
}
} else if (lsame_(uplo, "L")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = a_subscr(i__, j);
b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i;
/* L30: */
}
/* L40: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = a_subscr(i__, j);
b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i;
/* L50: */
}
/* L60: */
}
}
return 0;
/* End of ZLACPY */
} /* zlacpy_ */
/* Subroutine */ int zptt05_(integer *n, integer *nrhs, doublereal *d__,
doublecomplex *e, doublecomplex *b, integer *ldb, doublecomplex *x,
integer *ldx, doublecomplex *xact, integer *ldxact, doublereal *ferr,
doublereal *berr, doublereal *reslts)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, xact_dim1, xact_offset, i__1,
i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10,
d__11, d__12;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static doublereal diff, axbi;
static integer imax;
static doublereal unfl, ovfl;
static integer i__, j, k;
static doublereal xnorm;
extern doublereal dlamch_(char *);
static integer nz;
static doublereal errbnd;
extern integer izamax_(integer *, doublecomplex *, integer *);
static doublereal eps, tmp;
#define xact_subscr(a_1,a_2) (a_2)*xact_dim1 + a_1
#define xact_ref(a_1,a_2) xact[xact_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define x_subscr(a_1,a_2) (a_2)*x_dim1 + a_1
#define x_ref(a_1,a_2) x[x_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
ZPTT05 tests the error bounds from iterative refinement for the
computed solution to a system of equations A*X = B, where A is a
Hermitian tridiagonal matrix of order n.
RESLTS(1) = test of the error bound
= norm(X - XACT) / ( norm(X) * FERR )
A large value is returned if this ratio is not less than one.
RESLTS(2) = residual from the iterative refinement routine
= the maximum of BERR / ( NZ*EPS + (*) ), where
(*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
and NZ = max. number of nonzeros in any row of A, plus 1
Arguments
=========
N (input) INTEGER
The number of rows of the matrices X, B, and XACT, and the
order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of columns of the matrices X, B, and XACT.
NRHS >= 0.
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 elements of the tridiagonal matrix A.
B (input) COMPLEX*16 array, dimension (LDB,NRHS)
The right hand side vectors for the system of linear
equations.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input) COMPLEX*16 array, dimension (LDX,NRHS)
The computed solution vectors. Each vector is stored as a
column of the matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
XACT (input) COMPLEX*16 array, dimension (LDX,NRHS)
The exact solution vectors. Each vector is stored as a
column of the matrix XACT.
LDXACT (input) INTEGER
The leading dimension of the array XACT. LDXACT >= max(1,N).
FERR (input) DOUBLE PRECISION array, dimension (NRHS)
The estimated forward error bounds for each solution vector
X. If XTRUE is the true solution, FERR bounds the magnitude
of the largest entry in (X - XTRUE) divided by the magnitude
of the largest entry in X.
BERR (input) DOUBLE PRECISION array, dimension (NRHS)
The componentwise relative backward error of each solution
vector (i.e., the smallest relative change in any entry of A
or B that makes X an exact solution).
RESLTS (output) DOUBLE PRECISION array, dimension (2)
The maximum over the NRHS solution vectors of the ratios:
RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
RESLTS(2) = BERR / ( NZ*EPS + (*) )
=====================================================================
Quick exit if N = 0 or NRHS = 0.
Parameter adjustments */
--d__;
--e;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
xact_dim1 = *ldxact;
xact_offset = 1 + xact_dim1 * 1;
xact -= xact_offset;
--ferr;
--berr;
--reslts;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
reslts[1] = 0.;
reslts[2] = 0.;
return 0;
}
eps = dlamch_("Epsilon");
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
nz = 4;
/* Test 1: Compute the maximum of
norm(X - XACT) / ( norm(X) * FERR )
over all the vectors X and XACT using the infinity-norm. */
errbnd = 0.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
imax = izamax_(n, &x_ref(1, j), &c__1);
/* Computing MAX */
i__2 = x_subscr(imax, j);
d__3 = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x_ref(imax, j))
, abs(d__2));
xnorm = max(d__3,unfl);
diff = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = x_subscr(i__, j);
i__4 = xact_subscr(i__, j);
z__2.r = x[i__3].r - xact[i__4].r, z__2.i = x[i__3].i - xact[i__4]
.i;
z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MAX */
d__3 = diff, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
z__1), abs(d__2));
diff = max(d__3,d__4);
/* L10: */
}
if (xnorm > 1.) {
goto L20;
} else if (diff <= ovfl * xnorm) {
goto L20;
} else {
errbnd = 1. / eps;
goto L30;
}
L20:
if (diff / xnorm <= ferr[j]) {
/* Computing MAX */
d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
errbnd = max(d__1,d__2);
} else {
errbnd = 1. / eps;
}
L30:
;
}
reslts[1] = errbnd;
/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where
(*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
i__1 = *nrhs;
for (k = 1; k <= i__1; ++k) {
if (*n == 1) {
i__2 = x_subscr(1, k);
z__2.r = d__[1] * x[i__2].r, z__2.i = d__[1] * x[i__2].i;
z__1.r = z__2.r, z__1.i = z__2.i;
i__3 = b_subscr(1, k);
axbi = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b_ref(1, k)
), abs(d__2)) + ((d__3 = z__1.r, abs(d__3)) + (d__4 =
d_imag(&z__1), abs(d__4)));
} else {
i__2 = x_subscr(1, k);
z__2.r = d__[1] * x[i__2].r, z__2.i = d__[1] * x[i__2].i;
z__1.r = z__2.r, z__1.i = z__2.i;
i__3 = b_subscr(1, k);
i__4 = x_subscr(2, k);
axbi = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b_ref(1, k)
), abs(d__2)) + ((d__3 = z__1.r, abs(d__3)) + (d__4 =
d_imag(&z__1), abs(d__4))) + ((d__5 = e[1].r, abs(d__5))
+ (d__6 = d_imag(&e[1]), abs(d__6))) * ((d__7 = x[i__4].r,
abs(d__7)) + (d__8 = d_imag(&x_ref(2, k)), abs(d__8)));
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = x_subscr(i__, k);
z__2.r = d__[i__3] * x[i__4].r, z__2.i = d__[i__3] * x[i__4]
.i;
z__1.r = z__2.r, z__1.i = z__2.i;
i__5 = b_subscr(i__, k);
i__6 = i__ - 1;
i__7 = x_subscr(i__ - 1, k);
i__8 = i__;
i__9 = x_subscr(i__ + 1, k);
tmp = (d__1 = b[i__5].r, abs(d__1)) + (d__2 = d_imag(&b_ref(
i__, k)), abs(d__2)) + ((d__3 = e[i__6].r, abs(d__3))
+ (d__4 = d_imag(&e[i__ - 1]), abs(d__4))) * ((d__5 =
x[i__7].r, abs(d__5)) + (d__6 = d_imag(&x_ref(i__ - 1,
k)), abs(d__6))) + ((d__7 = z__1.r, abs(d__7)) + (
d__8 = d_imag(&z__1), abs(d__8))) + ((d__9 = e[i__8]
.r, abs(d__9)) + (d__10 = d_imag(&e[i__]), abs(d__10))
) * ((d__11 = x[i__9].r, abs(d__11)) + (d__12 =
d_imag(&x_ref(i__ + 1, k)), abs(d__12)));
axbi = min(axbi,tmp);
/* L40: */
}
i__2 = *n;
i__3 = x_subscr(*n, k);
z__2.r = d__[i__2] * x[i__3].r, z__2.i = d__[i__2] * x[i__3].i;
z__1.r = z__2.r, z__1.i = z__2.i;
i__4 = b_subscr(*n, k);
i__5 = *n - 1;
i__6 = x_subscr(*n - 1, k);
tmp = (d__1 = b[i__4].r, abs(d__1)) + (d__2 = d_imag(&b_ref(*n, k)
), abs(d__2)) + ((d__3 = e[i__5].r, abs(d__3)) + (d__4 =
d_imag(&e[*n - 1]), abs(d__4))) * ((d__5 = x[i__6].r, abs(
d__5)) + (d__6 = d_imag(&x_ref(*n - 1, k)), abs(d__6))) +
((d__7 = z__1.r, abs(d__7)) + (d__8 = d_imag(&z__1), abs(
d__8)));
axbi = min(axbi,tmp);
}
/* Computing MAX */
d__1 = axbi, d__2 = nz * unfl;
tmp = berr[k] / (nz * eps + nz * unfl / max(d__1,d__2));
if (k == 1) {
reslts[2] = tmp;
} else {
reslts[2] = max(reslts[2],tmp);
}
/* L50: */
}
return 0;
/* End of ZPTT05 */
} /* zptt05_ */
/* Subroutine */ int clatm5_(integer *prtype, integer *m, integer *n, complex
*a, integer *lda, complex *b, integer *ldb, complex *c__, integer *
ldc, complex *d__, integer *ldd, complex *e, integer *lde, complex *f,
integer *ldf, complex *r__, integer *ldr, complex *l, integer *ldl,
real *alpha, integer *qblcka, integer *qblckb)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1,
d_offset, e_dim1, e_offset, f_dim1, f_offset, l_dim1, l_offset,
r_dim1, r_offset, i__1, i__2, i__3, i__4;
doublereal d__1;
complex q__1, q__2, q__3, q__4, q__5;
/* Builtin functions */
void c_sin(complex *, complex *), c_div(complex *, complex *, complex *);
/* Local variables */
static integer i__, j, k;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *);
static complex imeps, reeps;
#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 d___subscr(a_1,a_2) (a_2)*d_dim1 + a_1
#define d___ref(a_1,a_2) d__[d___subscr(a_1,a_2)]
#define e_subscr(a_1,a_2) (a_2)*e_dim1 + a_1
#define e_ref(a_1,a_2) e[e_subscr(a_1,a_2)]
#define l_subscr(a_1,a_2) (a_2)*l_dim1 + a_1
#define l_ref(a_1,a_2) l[l_subscr(a_1,a_2)]
#define r___subscr(a_1,a_2) (a_2)*r_dim1 + a_1
#define r___ref(a_1,a_2) r__[r___subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
CLATM5 generates matrices involved in the Generalized Sylvester
equation:
A * R - L * B = C
D * R - L * E = F
They also satisfy (the diagonalization condition)
[ I -L ] ( [ A -C ], [ D -F ] ) [ I R ] = ( [ A ], [ D ] )
[ I ] ( [ B ] [ E ] ) [ I ] ( [ B ] [ E ] )
Arguments
=========
PRTYPE (input) INTEGER
"Points" to a certian type of the matrices to generate
(see futher details).
M (input) INTEGER
Specifies the order of A and D and the number of rows in
C, F, R and L.
N (input) INTEGER
Specifies the order of B and E and the number of columns in
C, F, R and L.
A (output) COMPLEX array, dimension (LDA, M).
On exit A M-by-M is initialized according to PRTYPE.
LDA (input) INTEGER
The leading dimension of A.
B (output) COMPLEX array, dimension (LDB, N).
On exit B N-by-N is initialized according to PRTYPE.
LDB (input) INTEGER
The leading dimension of B.
C (output) COMPLEX array, dimension (LDC, N).
On exit C M-by-N is initialized according to PRTYPE.
LDC (input) INTEGER
The leading dimension of C.
D (output) COMPLEX array, dimension (LDD, M).
On exit D M-by-M is initialized according to PRTYPE.
LDD (input) INTEGER
The leading dimension of D.
E (output) COMPLEX array, dimension (LDE, N).
On exit E N-by-N is initialized according to PRTYPE.
LDE (input) INTEGER
The leading dimension of E.
F (output) COMPLEX array, dimension (LDF, N).
On exit F M-by-N is initialized according to PRTYPE.
LDF (input) INTEGER
The leading dimension of F.
R (output) COMPLEX array, dimension (LDR, N).
On exit R M-by-N is initialized according to PRTYPE.
LDR (input) INTEGER
The leading dimension of R.
L (output) COMPLEX array, dimension (LDL, N).
On exit L M-by-N is initialized according to PRTYPE.
LDL (input) INTEGER
The leading dimension of L.
ALPHA (input) REAL
Parameter used in generating PRTYPE = 1 and 5 matrices.
QBLCKA (input) INTEGER
When PRTYPE = 3, specifies the distance between 2-by-2
blocks on the diagonal in A. Otherwise, QBLCKA is not
referenced. QBLCKA > 1.
QBLCKB (input) INTEGER
When PRTYPE = 3, specifies the distance between 2-by-2
blocks on the diagonal in B. Otherwise, QBLCKB is not
referenced. QBLCKB > 1.
Further Details
===============
PRTYPE = 1: A and B are Jordan blocks, D and E are identity matrices
A : if (i == j) then A(i, j) = 1.0
if (j == i + 1) then A(i, j) = -1.0
else A(i, j) = 0.0, i, j = 1...M
B : if (i == j) then B(i, j) = 1.0 - ALPHA
if (j == i + 1) then B(i, j) = 1.0
else B(i, j) = 0.0, i, j = 1...N
D : if (i == j) then D(i, j) = 1.0
else D(i, j) = 0.0, i, j = 1...M
E : if (i == j) then E(i, j) = 1.0
else E(i, j) = 0.0, i, j = 1...N
L = R are chosen from [-10...10],
which specifies the right hand sides (C, F).
PRTYPE = 2 or 3: Triangular and/or quasi- triangular.
A : if (i <= j) then A(i, j) = [-1...1]
else A(i, j) = 0.0, i, j = 1...M
if (PRTYPE = 3) then
A(k + 1, k + 1) = A(k, k)
A(k + 1, k) = [-1...1]
sign(A(k, k + 1) = -(sin(A(k + 1, k))
k = 1, M - 1, QBLCKA
B : if (i <= j) then B(i, j) = [-1...1]
else B(i, j) = 0.0, i, j = 1...N
if (PRTYPE = 3) then
B(k + 1, k + 1) = B(k, k)
B(k + 1, k) = [-1...1]
sign(B(k, k + 1) = -(sign(B(k + 1, k))
k = 1, N - 1, QBLCKB
D : if (i <= j) then D(i, j) = [-1...1].
else D(i, j) = 0.0, i, j = 1...M
E : if (i <= j) then D(i, j) = [-1...1]
else E(i, j) = 0.0, i, j = 1...N
L, R are chosen from [-10...10],
which specifies the right hand sides (C, F).
PRTYPE = 4 Full
A(i, j) = [-10...10]
D(i, j) = [-1...1] i,j = 1...M
B(i, j) = [-10...10]
E(i, j) = [-1...1] i,j = 1...N
R(i, j) = [-10...10]
L(i, j) = [-1...1] i = 1..M ,j = 1...N
L, R specifies the right hand sides (C, F).
PRTYPE = 5 special case common and/or close eigs.
=====================================================================
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;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
d_dim1 = *ldd;
d_offset = 1 + d_dim1 * 1;
d__ -= d_offset;
e_dim1 = *lde;
e_offset = 1 + e_dim1 * 1;
e -= e_offset;
f_dim1 = *ldf;
f_offset = 1 + f_dim1 * 1;
f -= f_offset;
r_dim1 = *ldr;
r_offset = 1 + r_dim1 * 1;
r__ -= r_offset;
l_dim1 = *ldl;
l_offset = 1 + l_dim1 * 1;
l -= l_offset;
/* Function Body */
if (*prtype == 1) {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *m;
for (j = 1; j <= i__2; ++j) {
if (i__ == j) {
i__3 = a_subscr(i__, j);
a[i__3].r = 1.f, a[i__3].i = 0.f;
i__3 = d___subscr(i__, j);
d__[i__3].r = 1.f, d__[i__3].i = 0.f;
} else if (i__ == j - 1) {
i__3 = a_subscr(i__, j);
q__1.r = -1.f, q__1.i = 0.f;
a[i__3].r = q__1.r, a[i__3].i = q__1.i;
i__3 = d___subscr(i__, j);
d__[i__3].r = 0.f, d__[i__3].i = 0.f;
} else {
i__3 = a_subscr(i__, j);
a[i__3].r = 0.f, a[i__3].i = 0.f;
i__3 = d___subscr(i__, j);
d__[i__3].r = 0.f, d__[i__3].i = 0.f;
}
/* L10: */
}
/* L20: */
}
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 = b_subscr(i__, j);
q__1.r = 1.f - *alpha, q__1.i = 0.f;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
i__3 = e_subscr(i__, j);
e[i__3].r = 1.f, e[i__3].i = 0.f;
} else if (i__ == j - 1) {
i__3 = b_subscr(i__, j);
b[i__3].r = 1.f, b[i__3].i = 0.f;
i__3 = e_subscr(i__, j);
e[i__3].r = 0.f, e[i__3].i = 0.f;
} else {
i__3 = b_subscr(i__, j);
b[i__3].r = 0.f, b[i__3].i = 0.f;
i__3 = e_subscr(i__, j);
e[i__3].r = 0.f, e[i__3].i = 0.f;
}
/* L30: */
}
/* L40: */
}
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
i__3 = r___subscr(i__, j);
i__4 = i__ / j;
q__4.r = (real) i__4, q__4.i = 0.f;
c_sin(&q__3, &q__4);
q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i;
q__1.r = q__2.r * 20.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f
+ q__2.i * 20.f;
r__[i__3].r = q__1.r, r__[i__3].i = q__1.i;
i__3 = l_subscr(i__, j);
i__4 = r___subscr(i__, j);
l[i__3].r = r__[i__4].r, l[i__3].i = r__[i__4].i;
/* L50: */
}
/* L60: */
}
} else if (*prtype == 2 || *prtype == 3) {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *m;
for (j = 1; j <= i__2; ++j) {
if (i__ <= j) {
i__3 = a_subscr(i__, j);
q__4.r = (real) i__, q__4.i = 0.f;
c_sin(&q__3, &q__4);
q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i;
q__1.r = q__2.r * 2.f - q__2.i * 0.f, q__1.i = q__2.r *
0.f + q__2.i * 2.f;
a[i__3].r = q__1.r, a[i__3].i = q__1.i;
i__3 = d___subscr(i__, j);
i__4 = i__ * j;
q__4.r = (real) i__4, q__4.i = 0.f;
c_sin(&q__3, &q__4);
q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i;
q__1.r = q__2.r * 2.f - q__2.i * 0.f, q__1.i = q__2.r *
0.f + q__2.i * 2.f;
d__[i__3].r = q__1.r, d__[i__3].i = q__1.i;
} else {
i__3 = a_subscr(i__, j);
a[i__3].r = 0.f, a[i__3].i = 0.f;
i__3 = d___subscr(i__, j);
d__[i__3].r = 0.f, d__[i__3].i = 0.f;
}
/* L70: */
}
/* L80: */
}
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 = b_subscr(i__, j);
i__4 = i__ + j;
q__4.r = (real) i__4, q__4.i = 0.f;
c_sin(&q__3, &q__4);
q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i;
q__1.r = q__2.r * 2.f - q__2.i * 0.f, q__1.i = q__2.r *
0.f + q__2.i * 2.f;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
i__3 = e_subscr(i__, j);
q__4.r = (real) j, q__4.i = 0.f;
c_sin(&q__3, &q__4);
q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i;
q__1.r = q__2.r * 2.f - q__2.i * 0.f, q__1.i = q__2.r *
0.f + q__2.i * 2.f;
e[i__3].r = q__1.r, e[i__3].i = q__1.i;
} else {
i__3 = b_subscr(i__, j);
b[i__3].r = 0.f, b[i__3].i = 0.f;
i__3 = e_subscr(i__, j);
e[i__3].r = 0.f, e[i__3].i = 0.f;
}
/* L90: */
}
/* L100: */
}
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
i__3 = r___subscr(i__, j);
i__4 = i__ * j;
q__4.r = (real) i__4, q__4.i = 0.f;
c_sin(&q__3, &q__4);
q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i;
q__1.r = q__2.r * 20.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f
+ q__2.i * 20.f;
r__[i__3].r = q__1.r, r__[i__3].i = q__1.i;
i__3 = l_subscr(i__, j);
i__4 = i__ + j;
q__4.r = (real) i__4, q__4.i = 0.f;
c_sin(&q__3, &q__4);
q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i;
q__1.r = q__2.r * 20.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f
+ q__2.i * 20.f;
l[i__3].r = q__1.r, l[i__3].i = q__1.i;
/* L110: */
}
/* L120: */
}
if (*prtype == 3) {
if (*qblcka <= 1) {
*qblcka = 2;
}
i__1 = *m - 1;
i__2 = *qblcka;
for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
i__3 = a_subscr(k + 1, k + 1);
i__4 = a_subscr(k, k);
a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i;
i__3 = a_subscr(k + 1, k);
c_sin(&q__2, &a_ref(k, k + 1));
q__1.r = -q__2.r, q__1.i = -q__2.i;
a[i__3].r = q__1.r, a[i__3].i = q__1.i;
/* L130: */
}
if (*qblckb <= 1) {
*qblckb = 2;
}
i__2 = *n - 1;
i__1 = *qblckb;
for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
i__3 = b_subscr(k + 1, k + 1);
i__4 = b_subscr(k, k);
b[i__3].r = b[i__4].r, b[i__3].i = b[i__4].i;
i__3 = b_subscr(k + 1, k);
c_sin(&q__2, &b_ref(k, k + 1));
q__1.r = -q__2.r, q__1.i = -q__2.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L140: */
}
}
} else if (*prtype == 4) {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *m;
for (j = 1; j <= i__2; ++j) {
i__3 = a_subscr(i__, j);
i__4 = i__ * j;
q__4.r = (real) i__4, q__4.i = 0.f;
c_sin(&q__3, &q__4);
q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i;
q__1.r = q__2.r * 20.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f
+ q__2.i * 20.f;
a[i__3].r = q__1.r, a[i__3].i = q__1.i;
i__3 = d___subscr(i__, j);
i__4 = i__ + j;
q__4.r = (real) i__4, q__4.i = 0.f;
c_sin(&q__3, &q__4);
q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i;
q__1.r = q__2.r * 2.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f +
q__2.i * 2.f;
d__[i__3].r = q__1.r, d__[i__3].i = q__1.i;
/* L150: */
}
/* L160: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
i__3 = b_subscr(i__, j);
i__4 = i__ + j;
q__4.r = (real) i__4, q__4.i = 0.f;
c_sin(&q__3, &q__4);
q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i;
q__1.r = q__2.r * 20.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f
+ q__2.i * 20.f;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
i__3 = e_subscr(i__, j);
i__4 = i__ * j;
q__4.r = (real) i__4, q__4.i = 0.f;
c_sin(&q__3, &q__4);
q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i;
q__1.r = q__2.r * 2.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f +
q__2.i * 2.f;
e[i__3].r = q__1.r, e[i__3].i = q__1.i;
/* L170: */
}
/* L180: */
}
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
i__3 = r___subscr(i__, j);
i__4 = j / i__;
q__4.r = (real) i__4, q__4.i = 0.f;
c_sin(&q__3, &q__4);
q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i;
q__1.r = q__2.r * 20.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f
+ q__2.i * 20.f;
r__[i__3].r = q__1.r, r__[i__3].i = q__1.i;
i__3 = l_subscr(i__, j);
i__4 = i__ * j;
q__4.r = (real) i__4, q__4.i = 0.f;
c_sin(&q__3, &q__4);
q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i;
q__1.r = q__2.r * 2.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f +
q__2.i * 2.f;
l[i__3].r = q__1.r, l[i__3].i = q__1.i;
/* L190: */
}
/* L200: */
}
} else if (*prtype >= 5) {
q__3.r = 1.f, q__3.i = 0.f;
q__2.r = q__3.r * 20.f - q__3.i * 0.f, q__2.i = q__3.r * 0.f + q__3.i
* 20.f;
q__1.r = q__2.r / *alpha, q__1.i = q__2.i / *alpha;
reeps.r = q__1.r, reeps.i = q__1.i;
q__2.r = -1.5f, q__2.i = 0.f;
q__1.r = q__2.r / *alpha, q__1.i = q__2.i / *alpha;
imeps.r = q__1.r, imeps.i = q__1.i;
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
i__3 = r___subscr(i__, j);
i__4 = i__ * j;
q__5.r = (real) i__4, q__5.i = 0.f;
c_sin(&q__4, &q__5);
q__3.r = .5f - q__4.r, q__3.i = 0.f - q__4.i;
q__2.r = *alpha * q__3.r, q__2.i = *alpha * q__3.i;
c_div(&q__1, &q__2, &c_b5);
r__[i__3].r = q__1.r, r__[i__3].i = q__1.i;
i__3 = l_subscr(i__, j);
i__4 = i__ + j;
q__5.r = (real) i__4, q__5.i = 0.f;
c_sin(&q__4, &q__5);
q__3.r = .5f - q__4.r, q__3.i = 0.f - q__4.i;
q__2.r = *alpha * q__3.r, q__2.i = *alpha * q__3.i;
c_div(&q__1, &q__2, &c_b5);
l[i__3].r = q__1.r, l[i__3].i = q__1.i;
/* L210: */
}
/* L220: */
}
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = d___subscr(i__, i__);
d__[i__2].r = 1.f, d__[i__2].i = 0.f;
/* L230: */
}
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ <= 4) {
i__2 = a_subscr(i__, i__);
a[i__2].r = 1.f, a[i__2].i = 0.f;
if (i__ > 2) {
i__2 = a_subscr(i__, i__);
q__1.r = reeps.r + 1.f, q__1.i = reeps.i + 0.f;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
}
if (i__ % 2 != 0 && i__ < *m) {
i__2 = a_subscr(i__, i__ + 1);
a[i__2].r = imeps.r, a[i__2].i = imeps.i;
} else if (i__ > 1) {
i__2 = a_subscr(i__, i__ - 1);
q__1.r = -imeps.r, q__1.i = -imeps.i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
}
} else if (i__ <= 8) {
if (i__ <= 6) {
i__2 = a_subscr(i__, i__);
a[i__2].r = reeps.r, a[i__2].i = reeps.i;
} else {
i__2 = a_subscr(i__, i__);
q__1.r = -reeps.r, q__1.i = -reeps.i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
}
if (i__ % 2 != 0 && i__ < *m) {
i__2 = a_subscr(i__, i__ + 1);
a[i__2].r = 1.f, a[i__2].i = 0.f;
} else if (i__ > 1) {
i__2 = a_subscr(i__, i__ - 1);
q__1.r = -1.f, q__1.i = 0.f;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
}
} else {
i__2 = a_subscr(i__, i__);
a[i__2].r = 1.f, a[i__2].i = 0.f;
if (i__ % 2 != 0 && i__ < *m) {
i__2 = a_subscr(i__, i__ + 1);
d__1 = 2.;
q__1.r = d__1 * imeps.r, q__1.i = d__1 * imeps.i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
} else if (i__ > 1) {
i__2 = a_subscr(i__, i__ - 1);
q__2.r = -imeps.r, q__2.i = -imeps.i;
d__1 = 2.;
q__1.r = d__1 * q__2.r, q__1.i = d__1 * q__2.i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
}
}
/* L240: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = e_subscr(i__, i__);
e[i__2].r = 1.f, e[i__2].i = 0.f;
if (i__ <= 4) {
i__2 = b_subscr(i__, i__);
q__1.r = -1.f, q__1.i = 0.f;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
if (i__ > 2) {
i__2 = b_subscr(i__, i__);
q__1.r = 1.f - reeps.r, q__1.i = 0.f - reeps.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
}
if (i__ % 2 != 0 && i__ < *n) {
i__2 = b_subscr(i__, i__ + 1);
b[i__2].r = imeps.r, b[i__2].i = imeps.i;
} else if (i__ > 1) {
i__2 = b_subscr(i__, i__ - 1);
q__1.r = -imeps.r, q__1.i = -imeps.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
}
} else if (i__ <= 8) {
if (i__ <= 6) {
i__2 = b_subscr(i__, i__);
b[i__2].r = reeps.r, b[i__2].i = reeps.i;
} else {
i__2 = b_subscr(i__, i__);
q__1.r = -reeps.r, q__1.i = -reeps.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
}
if (i__ % 2 != 0 && i__ < *n) {
i__2 = b_subscr(i__, i__ + 1);
q__1.r = imeps.r + 1.f, q__1.i = imeps.i + 0.f;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
} else if (i__ > 1) {
i__2 = b_subscr(i__, i__ - 1);
q__2.r = -1.f, q__2.i = 0.f;
q__1.r = q__2.r - imeps.r, q__1.i = q__2.i - imeps.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
}
} else {
i__2 = b_subscr(i__, i__);
q__1.r = 1.f - reeps.r, q__1.i = 0.f - reeps.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
if (i__ % 2 != 0 && i__ < *n) {
i__2 = b_subscr(i__, i__ + 1);
d__1 = 2.;
q__1.r = d__1 * imeps.r, q__1.i = d__1 * imeps.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
} else if (i__ > 1) {
i__2 = b_subscr(i__, i__ - 1);
q__2.r = -imeps.r, q__2.i = -imeps.i;
d__1 = 2.;
q__1.r = d__1 * q__2.r, q__1.i = d__1 * q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
}
}
/* L250: */
}
}
/* Compute rhs (C, F) */
cgemm_("N", "N", m, n, m, &c_b1, &a[a_offset], lda, &r__[r_offset], ldr, &
c_b3, &c__[c_offset], ldc);
q__1.r = -1.f, q__1.i = 0.f;
cgemm_("N", "N", m, n, n, &q__1, &l[l_offset], ldl, &b[b_offset], ldb, &
c_b1, &c__[c_offset], ldc);
cgemm_("N", "N", m, n, m, &c_b1, &d__[d_offset], ldd, &r__[r_offset], ldr,
&c_b3, &f[f_offset], ldf);
q__1.r = -1.f, q__1.i = 0.f;
cgemm_("N", "N", m, n, n, &q__1, &l[l_offset], ldl, &e[e_offset], lde, &
c_b1, &f[f_offset], ldf);
/* End of CLATM5 */
return 0;
} /* clatm5_ */
/* Subroutine */ int zdrgev_(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 *qe, integer *ldqe, doublecomplex *alpha, doublecomplex
*beta, doublecomplex *alpha1, doublecomplex *beta1, doublecomplex *
work, integer *lwork, doublereal *rwork, doublereal *result, 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 ZDRGEV: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/3x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 ZDRGEV: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,3x,\002N=\002,i4,\002, JTYPE=\002,"
"i3,\002, ISEED=(\002,3(i4,\002,\002),i5,\002)\002)";
static char fmt_9997[] = "(/1x,a3,\002 -- Complex Generalized eigenvalue"
" problem \002,\002driver\002)";
static char fmt_9996[] = "(\002 Matrix types (see ZDRGEV 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: \002,/\002 1 = max "
"| ( b A - a B )'*l | / const.,\002,/\002 2 = | |VR(i)| - 1 | / u"
"lp,\002,/\002 3 = max | ( b A - a B )*r | / const.\002,/\002 4 ="
" | |VL(i)| - 1 | / ulp,\002,/\002 5 = 0 if W same no matter if r"
" or l computed,\002,/\002 6 = 0 if l same no matter if l compute"
"d,\002,/\002 7 = 0 if r same no matter if r computed,\002,/1x)";
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, qe_dim1,
qe_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;
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
double d_sign(doublereal *, doublereal *), z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer iadd, ierr, nmax, i__, j, n;
static logical badnn;
static doublereal rmagn[4];
static doublecomplex ctemp;
extern /* Subroutine */ int zget52_(logical *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *
, doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
doublereal *);
static integer nmats, jsize;
extern /* Subroutine */ int zggev_(char *, char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, integer *);
static integer nerrs, jtype, n1;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), zlatm4_(
integer *, integer *, integer *, integer *, logical *, doublereal
*, doublereal *, doublereal *, integer *, integer *,
doublecomplex *, integer *);
static integer jc, nb, in;
extern doublereal dlamch_(char *);
static integer jr;
extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal safmin, safmax;
static integer ioldsd[4];
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
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 *);
static integer minwrk, maxwrk;
static doublereal ulpinv;
static integer mtypes, ntestt;
static doublereal ulp;
/* Fortran I/O blocks */
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9991, 0 };
#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)]
#define qe_subscr(a_1,a_2) (a_2)*qe_dim1 + a_1
#define qe_ref(a_1,a_2) qe[qe_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
ZDRGEV checks the nonsymmetric generalized eigenvalue problem driver
routine ZGGEV.
ZGGEV computes for a pair of n-by-n nonsymmetric matrices (A,B) the
generalized eigenvalues and, optionally, the left and right
eigenvectors.
A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
or a ratio alpha/beta = w, such that A - w*B is singular. It is
usually represented as the pair (alpha,beta), as there is reasonalbe
interpretation for beta=0, and even for both being zero.
A right generalized eigenvector corresponding to a generalized
eigenvalue w for a pair of matrices (A,B) is a vector r such that
(A - wB) * r = 0. A left generalized eigenvector is a vector l such
that l**H * (A - wB) = 0, where l**H is the conjugate-transpose of l.
When ZDRGEV 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 tests
will be performed and compared with the threshhold THRESH.
Results from ZGGEV:
(1) max over all left eigenvalue/-vector pairs (alpha/beta,l) of
| VL**H * (beta A - alpha B) |/( ulp max(|beta A|, |alpha B|) )
where VL**H is the conjugate-transpose of VL.
(2) | |VL(i)| - 1 | / ulp and whether largest component real
VL(i) denotes the i-th column of VL.
(3) max over all left eigenvalue/-vector pairs (alpha/beta,r) of
| (beta A - alpha B) * VR | / ( ulp max(|beta A|, |alpha B|) )
(4) | |VR(i)| - 1 | / ulp and whether largest component real
VR(i) denotes the i-th column of VR.
(5) W(full) = W(partial)
W(full) denotes the eigenvalues computed when both l and r
are also computed, and W(partial) denotes the eigenvalues
computed when only W, only W and r, or only W and l are
computed.
(6) VL(full) = VL(partial)
VL(full) denotes the left eigenvectors computed when both l
and r are computed, and VL(partial) denotes the result
when only l is computed.
(7) VR(full) = VR(partial)
VR(full) denotes the right eigenvectors computed when both l
and r are also computed, and VR(partial) denotes the result
when only l is computed.
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,
ZDRGES 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, ZDRGEV
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. 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 ZDRGES 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. It must be at least zero.
NOUNIT (input) INTEGER
The FORTRAN unit number for printing out error messages
(e.g., if a routine returns IERR 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 ZGGEV. 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 ZGGEV.
Q (workspace) COMPLEX*16 array, dimension (LDQ, max(NN))
The (left) eigenvectors matrix computed by ZGGEV.
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 ZGGEV.
QE (workspace) COMPLEX*16 array, dimension( LDQ, max(NN) )
QE holds the computed right or left eigenvectors.
LDQE (input) INTEGER
The leading dimension of QE. LDQE >= max(1,max(NN)).
ALPHA (workspace) COMPLEX*16 array, dimension (max(NN))
BETA (workspace) COMPLEX*16 array, dimension (max(NN))
The generalized eigenvalues of (A,B) computed by ZGGEV.
( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th
generalized eigenvalue of A and B.
ALPHA1 (workspace) COMPLEX*16 array, dimension (max(NN))
BETA1 (workspace) COMPLEX*16 array, dimension (max(NN))
Like ALPHAR, ALPHAI, BETA, these arrays contain the
eigenvalues of A and B, but those computed when ZGGEV only
computes a partial eigendecomposition, i.e. not the
eigenvalues and left and right eigenvectors.
WORK (workspace) COMPLEX*16 array, dimension (LWORK)
LWORK (input) INTEGER
The number of entries in WORK. LWORK >= N*(N+1)
RWORK (workspace) DOUBLE PRECISION array, dimension (8*N)
Real workspace.
RESULT (output) DOUBLE PRECISION array, dimension (2)
The values computed by the tests described above.
The values are currently limited to 1/ulp, to avoid overflow.
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.
=====================================================================
Parameter adjustments */
--nn;
--dotype;
--iseed;
t_dim1 = *lda;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
s_dim1 = *lda;
s_offset = 1 + s_dim1 * 1;
s -= s_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
z_dim1 = *ldq;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
qe_dim1 = *ldqe;
qe_offset = 1 + qe_dim1 * 1;
qe -= qe_offset;
--alpha;
--beta;
--alpha1;
--beta1;
--work;
--rwork;
--result;
/* Function Body
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;
} else if (*ldqe <= 1 || *ldqe < nmax) {
*info = -17;
}
/* 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 * (nmax + 1);
/* Computing MAX */
i__1 = 1, i__2 = ilaenv_(&c__1, "ZGEQRF", " ", &nmax, &nmax, &c_n1, &
c_n1, (ftnlen)6, (ftnlen)1), i__1 = max(i__1,i__2), i__2 =
ilaenv_(&c__1, "ZUNMQR", "LC", &nmax, &nmax, &nmax, &c_n1, (
ftnlen)6, (ftnlen)2), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
c__1, "ZUNGQR", " ", &nmax, &nmax, &nmax, &c_n1, (ftnlen)6, (
ftnlen)1);
nb = max(i__1,i__2);
/* Computing MAX */
i__1 = nmax << 1, i__2 = nmax * (nb + 1), i__1 = max(i__1,i__2), i__2
= nmax * (nmax + 1);
maxwrk = max(i__1,i__2);
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
}
if (*lwork < minwrk) {
*info = -23;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZDRGEV", &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 sizes, types */
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 * n1;
if (*nsizes != 1) {
mtypes = min(26,*ntypes);
} else {
mtypes = min(27,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L210;
}
++nmats;
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* 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 L100;
}
ierr = 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 = a_subscr(iadd, iadd);
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_b28, &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 = b_subscr(iadd, iadd);
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 = q_subscr(jr, jc);
zlarnd_(&z__1, &c__3, &iseed[1]);
q[i__5].r = z__1.r, q[i__5].i = z__1.i;
i__5 = z___subscr(jr, jc);
zlarnd_(&z__1, &c__3, &iseed[1]);
z__[i__5].r = z__1.r, z__[i__5].i = z__1.i;
/* L30: */
}
i__4 = n + 1 - jc;
zlarfg_(&i__4, &q_ref(jc, jc), &q_ref(jc + 1, jc), &
c__1, &work[jc]);
i__4 = (n << 1) + jc;
i__5 = q_subscr(jc, jc);
d__2 = q[i__5].r;
d__1 = d_sign(&c_b28, &d__2);
work[i__4].r = d__1, work[i__4].i = 0.;
i__4 = q_subscr(jc, jc);
q[i__4].r = 1., q[i__4].i = 0.;
i__4 = n + 1 - jc;
zlarfg_(&i__4, &z___ref(jc, jc), &z___ref(jc + 1, jc),
&c__1, &work[n + jc]);
i__4 = n * 3 + jc;
i__5 = z___subscr(jc, jc);
d__2 = z__[i__5].r;
d__1 = d_sign(&c_b28, &d__2);
work[i__4].r = d__1, work[i__4].i = 0.;
i__4 = z___subscr(jc, jc);
z__[i__4].r = 1., z__[i__4].i = 0.;
/* L40: */
}
zlarnd_(&z__1, &c__3, &iseed[1]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__3 = q_subscr(n, n);
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 = z___subscr(n, n);
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 = a_subscr(jr, jc);
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 = a_subscr(jr, jc);
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 = b_subscr(jr, jc);
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 = b_subscr(jr, jc);
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;
/* L50: */
}
/* L60: */
}
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], &ierr);
if (ierr != 0) {
goto L90;
}
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], &ierr);
if (ierr != 0) {
goto L90;
}
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], &ierr);
if (ierr != 0) {
goto L90;
}
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], &ierr);
if (ierr != 0) {
goto L90;
}
}
} 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 = a_subscr(jr, jc);
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 = b_subscr(jr, jc);
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;
/* L70: */
}
/* L80: */
}
}
L90:
if (ierr != 0) {
io___40.ciunit = *nounit;
s_wsfe(&io___40);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&ierr, (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(ierr);
return 0;
}
L100:
for (i__ = 1; i__ <= 7; ++i__) {
result[i__] = -1.;
/* L110: */
}
/* Call ZGGEV to compute eigenvalues and eigenvectors. */
zlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
zlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
zggev_("V", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &alpha[
1], &beta[1], &q[q_offset], ldq, &z__[z_offset], ldq, &
work[1], lwork, &rwork[1], &ierr);
if (ierr != 0 && ierr != n + 1) {
result[1] = ulpinv;
io___42.ciunit = *nounit;
s_wsfe(&io___42);
do_fio(&c__1, "ZGGEV1", (ftnlen)6);
do_fio(&c__1, (char *)&ierr, (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(ierr);
goto L190;
}
/* Do the tests (1) and (2) */
zget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &q[
q_offset], ldq, &alpha[1], &beta[1], &work[1], &rwork[1],
&result[1]);
if (result[2] > *thresh) {
io___43.ciunit = *nounit;
s_wsfe(&io___43);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "ZGGEV1", (ftnlen)6);
do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(doublereal));
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();
}
/* Do the tests (3) and (4) */
zget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &z__[
z_offset], ldq, &alpha[1], &beta[1], &work[1], &rwork[1],
&result[3]);
if (result[4] > *thresh) {
io___44.ciunit = *nounit;
s_wsfe(&io___44);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "ZGGEV1", (ftnlen)6);
do_fio(&c__1, (char *)&result[4], (ftnlen)sizeof(doublereal));
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();
}
/* Do test (5) */
zlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
zlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
zggev_("N", "N", &n, &s[s_offset], lda, &t[t_offset], lda, &
alpha1[1], &beta1[1], &q[q_offset], ldq, &z__[z_offset],
ldq, &work[1], lwork, &rwork[1], &ierr);
if (ierr != 0 && ierr != n + 1) {
result[1] = ulpinv;
io___45.ciunit = *nounit;
s_wsfe(&io___45);
do_fio(&c__1, "ZGGEV2", (ftnlen)6);
do_fio(&c__1, (char *)&ierr, (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(ierr);
goto L190;
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = j;
i__6 = j;
i__7 = j;
if (alpha[i__4].r != alpha1[i__5].r || alpha[i__4].i !=
alpha1[i__5].i || (beta[i__6].r != beta1[i__7].r ||
beta[i__6].i != beta1[i__7].i)) {
result[5] = ulpinv;
}
/* L120: */
}
/* Do test (6): Compute eigenvalues and left eigenvectors,
and test them */
zlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
zlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
zggev_("V", "N", &n, &s[s_offset], lda, &t[t_offset], lda, &
alpha1[1], &beta1[1], &qe[qe_offset], ldqe, &z__[z_offset]
, ldq, &work[1], lwork, &rwork[1], &ierr);
if (ierr != 0 && ierr != n + 1) {
result[1] = ulpinv;
io___46.ciunit = *nounit;
s_wsfe(&io___46);
do_fio(&c__1, "ZGGEV3", (ftnlen)6);
do_fio(&c__1, (char *)&ierr, (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(ierr);
goto L190;
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = j;
i__6 = j;
i__7 = j;
if (alpha[i__4].r != alpha1[i__5].r || alpha[i__4].i !=
alpha1[i__5].i || (beta[i__6].r != beta1[i__7].r ||
beta[i__6].i != beta1[i__7].i)) {
result[6] = ulpinv;
}
/* L130: */
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = n;
for (jc = 1; jc <= i__4; ++jc) {
i__5 = q_subscr(j, jc);
i__6 = qe_subscr(j, jc);
if (q[i__5].r != qe[i__6].r || q[i__5].i != qe[i__6].i) {
result[6] = ulpinv;
}
/* L140: */
}
/* L150: */
}
/* Do test (7): Compute eigenvalues and right eigenvectors,
and test them */
zlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
zlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
zggev_("N", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &
alpha1[1], &beta1[1], &q[q_offset], ldq, &qe[qe_offset],
ldqe, &work[1], lwork, &rwork[1], &ierr);
if (ierr != 0 && ierr != n + 1) {
result[1] = ulpinv;
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, "ZGGEV4", (ftnlen)6);
do_fio(&c__1, (char *)&ierr, (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(ierr);
goto L190;
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = j;
i__6 = j;
i__7 = j;
if (alpha[i__4].r != alpha1[i__5].r || alpha[i__4].i !=
alpha1[i__5].i || (beta[i__6].r != beta1[i__7].r ||
beta[i__6].i != beta1[i__7].i)) {
result[7] = ulpinv;
}
/* L160: */
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = n;
for (jc = 1; jc <= i__4; ++jc) {
i__5 = z___subscr(j, jc);
i__6 = qe_subscr(j, jc);
if (z__[i__5].r != qe[i__6].r || z__[i__5].i != qe[i__6]
.i) {
result[7] = ulpinv;
}
/* L170: */
}
/* L180: */
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L190:
ntestt += 7;
/* Print out tests which fail. */
for (jr = 1; jr <= 9; ++jr) {
if (result[jr] >= *thresh) {
/* If this is the first test to fail,
print a header to the data file. */
if (nerrs == 0) {
io___48.ciunit = *nounit;
s_wsfe(&io___48);
do_fio(&c__1, "ZGV", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___49.ciunit = *nounit;
s_wsfe(&io___49);
e_wsfe();
io___50.ciunit = *nounit;
s_wsfe(&io___50);
e_wsfe();
io___51.ciunit = *nounit;
s_wsfe(&io___51);
do_fio(&c__1, "Orthogonal", (ftnlen)10);
e_wsfe();
/* Tests performed */
io___52.ciunit = *nounit;
s_wsfe(&io___52);
e_wsfe();
}
++nerrs;
if (result[jr] < 1e4) {
io___53.ciunit = *nounit;
s_wsfe(&io___53);
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___54.ciunit = *nounit;
s_wsfe(&io___54);
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();
}
}
/* L200: */
}
L210:
;
}
/* L220: */
}
/* Summary */
alasvm_("ZGV", nounit, &nerrs, &ntestt, &c__0);
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
return 0;
/* End of ZDRGEV */
} /* zdrgev_ */
/* Subroutine */ int csytrs_(char *uplo, integer *n, integer *nrhs, complex *
a, integer *lda, integer *ipiv, complex *b, integer *ldb, integer *
info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CSYTRS solves a system of linear equations A*X = B with a complex
symmetric matrix A using the factorization A = U*D*U**T or
A = L*D*L**T computed by CSYTRF.
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**T;
= 'L': Lower triangular, form is A = L*D*L**T.
N (input) INTEGER
The order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrix B. NRHS >= 0.
A (input) COMPLEX array, dimension (LDA,N)
The block diagonal matrix D and the multipliers used to
obtain the factor U or L as computed by CSYTRF.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
IPIV (input) INTEGER array, dimension (N)
Details of the interchanges and the block structure of D
as determined by CSYTRF.
B (input/output) COMPLEX array, dimension (LDB,NRHS)
On entry, the right hand side matrix B.
On exit, the solution matrix X.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
complex q__1, q__2, q__3;
/* Builtin functions */
void c_div(complex *, complex *, complex *);
/* Local variables */
static complex akm1k;
static integer j, k;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
extern logical lsame_(char *, char *);
static complex denom;
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *), cgeru_(integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *),
cswap_(integer *, complex *, integer *, complex *, integer *);
static logical upper;
static complex ak, bk;
static integer kp;
extern /* Subroutine */ int xerbla_(char *, integer *);
static complex akm1, bkm1;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CSYTRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
return 0;
}
if (upper) {
/* Solve A*X = B, where A = U*D*U'.
First solve U*D*X = B, overwriting B with X.
K is the main loop index, decreasing from N to 1 in steps of
1 or 2, depending on the size of the diagonal blocks. */
k = *n;
L10:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L30;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block
Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
cswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb);
}
/* Multiply by inv(U(K)), where U(K) is the transformation
stored in column K of A. */
i__1 = k - 1;
q__1.r = -1.f, q__1.i = 0.f;
cgeru_(&i__1, nrhs, &q__1, &a_ref(1, k), &c__1, &b_ref(k, 1), ldb,
&b_ref(1, 1), ldb);
/* Multiply by the inverse of the diagonal block. */
c_div(&q__1, &c_b1, &a_ref(k, k));
cscal_(nrhs, &q__1, &b_ref(k, 1), ldb);
--k;
} else {
/* 2 x 2 diagonal block
Interchange rows K-1 and -IPIV(K). */
kp = -ipiv[k];
if (kp != k - 1) {
cswap_(nrhs, &b_ref(k - 1, 1), ldb, &b_ref(kp, 1), ldb);
}
/* Multiply by inv(U(K)), where U(K) is the transformation
stored in columns K-1 and K of A. */
i__1 = k - 2;
q__1.r = -1.f, q__1.i = 0.f;
cgeru_(&i__1, nrhs, &q__1, &a_ref(1, k), &c__1, &b_ref(k, 1), ldb,
&b_ref(1, 1), ldb);
i__1 = k - 2;
q__1.r = -1.f, q__1.i = 0.f;
cgeru_(&i__1, nrhs, &q__1, &a_ref(1, k - 1), &c__1, &b_ref(k - 1,
1), ldb, &b_ref(1, 1), ldb);
/* Multiply by the inverse of the diagonal block. */
i__1 = a_subscr(k - 1, k);
akm1k.r = a[i__1].r, akm1k.i = a[i__1].i;
c_div(&q__1, &a_ref(k - 1, k - 1), &akm1k);
akm1.r = q__1.r, akm1.i = q__1.i;
c_div(&q__1, &a_ref(k, k), &akm1k);
ak.r = q__1.r, ak.i = q__1.i;
q__2.r = akm1.r * ak.r - akm1.i * ak.i, q__2.i = akm1.r * ak.i +
akm1.i * ak.r;
q__1.r = q__2.r - 1.f, q__1.i = q__2.i + 0.f;
denom.r = q__1.r, denom.i = q__1.i;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
c_div(&q__1, &b_ref(k - 1, j), &akm1k);
bkm1.r = q__1.r, bkm1.i = q__1.i;
c_div(&q__1, &b_ref(k, j), &akm1k);
bk.r = q__1.r, bk.i = q__1.i;
i__2 = b_subscr(k - 1, j);
q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r *
bkm1.i + ak.i * bkm1.r;
q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i;
c_div(&q__1, &q__2, &denom);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = b_subscr(k, j);
q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r *
bk.i + akm1.i * bk.r;
q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i;
c_div(&q__1, &q__2, &denom);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L20: */
}
k += -2;
}
goto L10;
L30:
/* Next solve U'*X = B, overwriting B with X.
K is the main loop index, increasing from 1 to N in steps of
1 or 2, depending on the size of the diagonal blocks. */
k = 1;
L40:
/* If K > N, exit from loop. */
if (k > *n) {
goto L50;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block
Multiply by inv(U'(K)), where U(K) is the transformation
stored in column K of A. */
i__1 = k - 1;
q__1.r = -1.f, q__1.i = 0.f;
cgemv_("Transpose", &i__1, nrhs, &q__1, &b[b_offset], ldb, &a_ref(
1, k), &c__1, &c_b1, &b_ref(k, 1), ldb);
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
cswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb);
}
++k;
} else {
/* 2 x 2 diagonal block
Multiply by inv(U'(K+1)), where U(K+1) is the transformation
stored in columns K and K+1 of A. */
i__1 = k - 1;
q__1.r = -1.f, q__1.i = 0.f;
cgemv_("Transpose", &i__1, nrhs, &q__1, &b[b_offset], ldb, &a_ref(
1, k), &c__1, &c_b1, &b_ref(k, 1), ldb);
i__1 = k - 1;
q__1.r = -1.f, q__1.i = 0.f;
cgemv_("Transpose", &i__1, nrhs, &q__1, &b[b_offset], ldb, &a_ref(
1, k + 1), &c__1, &c_b1, &b_ref(k + 1, 1), ldb)
;
/* Interchange rows K and -IPIV(K). */
kp = -ipiv[k];
if (kp != k) {
cswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb);
}
k += 2;
}
goto L40;
L50:
;
} else {
/* Solve A*X = B, where A = L*D*L'.
First solve L*D*X = B, overwriting B with X.
K is the main loop index, increasing from 1 to N in steps of
1 or 2, depending on the size of the diagonal blocks. */
k = 1;
L60:
/* If K > N, exit from loop. */
if (k > *n) {
goto L80;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block
Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
cswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb);
}
/* Multiply by inv(L(K)), where L(K) is the transformation
stored in column K of A. */
if (k < *n) {
i__1 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
cgeru_(&i__1, nrhs, &q__1, &a_ref(k + 1, k), &c__1, &b_ref(k,
1), ldb, &b_ref(k + 1, 1), ldb);
}
/* Multiply by the inverse of the diagonal block. */
c_div(&q__1, &c_b1, &a_ref(k, k));
cscal_(nrhs, &q__1, &b_ref(k, 1), ldb);
++k;
} else {
/* 2 x 2 diagonal block
Interchange rows K+1 and -IPIV(K). */
kp = -ipiv[k];
if (kp != k + 1) {
cswap_(nrhs, &b_ref(k + 1, 1), ldb, &b_ref(kp, 1), ldb);
}
/* Multiply by inv(L(K)), where L(K) is the transformation
stored in columns K and K+1 of A. */
if (k < *n - 1) {
i__1 = *n - k - 1;
q__1.r = -1.f, q__1.i = 0.f;
cgeru_(&i__1, nrhs, &q__1, &a_ref(k + 2, k), &c__1, &b_ref(k,
1), ldb, &b_ref(k + 2, 1), ldb);
i__1 = *n - k - 1;
q__1.r = -1.f, q__1.i = 0.f;
cgeru_(&i__1, nrhs, &q__1, &a_ref(k + 2, k + 1), &c__1, &
b_ref(k + 1, 1), ldb, &b_ref(k + 2, 1), ldb);
}
/* Multiply by the inverse of the diagonal block. */
i__1 = a_subscr(k + 1, k);
akm1k.r = a[i__1].r, akm1k.i = a[i__1].i;
c_div(&q__1, &a_ref(k, k), &akm1k);
akm1.r = q__1.r, akm1.i = q__1.i;
c_div(&q__1, &a_ref(k + 1, k + 1), &akm1k);
ak.r = q__1.r, ak.i = q__1.i;
q__2.r = akm1.r * ak.r - akm1.i * ak.i, q__2.i = akm1.r * ak.i +
akm1.i * ak.r;
q__1.r = q__2.r - 1.f, q__1.i = q__2.i + 0.f;
denom.r = q__1.r, denom.i = q__1.i;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
c_div(&q__1, &b_ref(k, j), &akm1k);
bkm1.r = q__1.r, bkm1.i = q__1.i;
c_div(&q__1, &b_ref(k + 1, j), &akm1k);
bk.r = q__1.r, bk.i = q__1.i;
i__2 = b_subscr(k, j);
q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r *
bkm1.i + ak.i * bkm1.r;
q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i;
c_div(&q__1, &q__2, &denom);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = b_subscr(k + 1, j);
q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r *
bk.i + akm1.i * bk.r;
q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i;
c_div(&q__1, &q__2, &denom);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L70: */
}
k += 2;
}
goto L60;
L80:
/* Next solve L'*X = B, overwriting B with X.
K is the main loop index, decreasing from N to 1 in steps of
1 or 2, depending on the size of the diagonal blocks. */
k = *n;
L90:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L100;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block
Multiply by inv(L'(K)), where L(K) is the transformation
stored in column K of A. */
if (k < *n) {
i__1 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
cgemv_("Transpose", &i__1, nrhs, &q__1, &b_ref(k + 1, 1), ldb,
&a_ref(k + 1, k), &c__1, &c_b1, &b_ref(k, 1), ldb);
}
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
cswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb);
}
--k;
} else {
/* 2 x 2 diagonal block
Multiply by inv(L'(K-1)), where L(K-1) is the transformation
stored in columns K-1 and K of A. */
if (k < *n) {
i__1 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
cgemv_("Transpose", &i__1, nrhs, &q__1, &b_ref(k + 1, 1), ldb,
&a_ref(k + 1, k), &c__1, &c_b1, &b_ref(k, 1), ldb);
i__1 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
cgemv_("Transpose", &i__1, nrhs, &q__1, &b_ref(k + 1, 1), ldb,
&a_ref(k + 1, k - 1), &c__1, &c_b1, &b_ref(k - 1, 1),
ldb);
}
/* Interchange rows K and -IPIV(K). */
kp = -ipiv[k];
if (kp != k) {
cswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb);
}
k += -2;
}
goto L90;
L100:
;
}
return 0;
/* End of CSYTRS */
} /* csytrs_ */
/* Subroutine */ int cdrvgg_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, real *thresh, real *thrshn, integer *
nounit, complex *a, integer *lda, complex *b, complex *s, complex *t,
complex *s2, complex *t2, complex *q, integer *ldq, complex *z__,
complex *alpha1, complex *beta1, complex *alpha2, complex *beta2,
complex *vl, complex *vr, complex *work, integer *lwork, real *rwork,
real *result, 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 CDRVGG: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 CDRVGG: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\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 eigenvalue"
" problem driver\002)";
static char fmt_9996[] = "(\002 Matrix types (see CDRVGG 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,/20x,\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 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 = difference between (alpha,beta"
") and diagonals of\002,\002 (S,T)\002,/\002 6 = max | ( b A - a "
"B )\002,a,\002 l | / const. 7 = max | ( b A - a B ) r | / cons"
"t.\002,/1x)";
static char fmt_9992[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\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,i3,\002 is\002"
",1p,e10.3)";
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, s_dim1,
s_offset, s2_dim1, s2_offset, t_dim1, t_offset, t2_dim1,
t2_offset, vl_dim1, vl_offset, vr_dim1, vr_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;
real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10, r__11,
r__12, r__13, r__14, r__15, r__16;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double r_sign(real *, real *), c_abs(complex *);
void r_cnjg(complex *, complex *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
double r_imag(complex *);
/* Local variables */
static integer iadd, nmax;
static real temp1, temp2;
static integer j, n;
static logical badnn;
extern /* Subroutine */ int cgegs_(char *, char *, integer *, complex *,
integer *, complex *, integer *, complex *, complex *, complex *,
integer *, complex *, integer *, complex *, integer *, real *,
integer *), cgegv_(char *, char *, integer *,
complex *, integer *, complex *, integer *, complex *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *,
real *, integer *), cget51_(integer *, integer *,
complex *, integer *, complex *, integer *, complex *, integer *,
complex *, integer *, complex *, real *, real *), cget52_(logical
*, integer *, complex *, integer *, complex *, integer *, complex
*, integer *, complex *, complex *, complex *, real *, real *);
static real dumma[4];
static integer iinfo;
static real rmagn[4];
static complex ctemp;
static integer nmats, jsize, nerrs, i1, jtype, ntest, n1;
extern /* Subroutine */ int clatm4_(integer *, integer *, integer *,
integer *, logical *, real *, real *, real *, integer *, integer *
, complex *, integer *), cunm2r_(char *, char *, integer *,
integer *, integer *, complex *, integer *, complex *, complex *,
integer *, complex *, integer *);
static integer jc, nb;
extern /* Subroutine */ int slabad_(real *, real *);
static integer in, jr;
extern /* Subroutine */ int clarfg_(integer *, complex *, complex *,
integer *, complex *);
static integer ns;
extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *);
static real safmin, safmax;
static integer ioldsd[4];
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *), claset_(char *, integer *, integer *,
complex *, complex *, complex *, integer *), xerbla_(char
*, integer *);
static real ulpinv;
static integer lwkopt, mtypes, ntestt, nbz;
static real ulp;
/* Fortran I/O blocks */
static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9991, 0 };
#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 s_subscr(a_1,a_2) (a_2)*s_dim1 + a_1
#define s_ref(a_1,a_2) s[s_subscr(a_1,a_2)]
#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 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 test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CDRVGG checks the nonsymmetric generalized eigenvalue driver
routines.
T T T
CGEGS factors A and B as Q S Z and Q T Z , where means
transpose, T is upper triangular, S is in generalized Schur form
(upper triangular), and Q and Z are unitary. It also
computes the generalized eigenvalues (alpha(1),beta(1)), ...,
(alpha(n),beta(n)), where alpha(j)=S(j,j) and beta(j)=T(j,j) --
thus, w(j) = alpha(j)/beta(j) is a root of the generalized
eigenvalue problem
det( A - w(j) B ) = 0
and m(j) = beta(j)/alpha(j) is a root of the essentially equivalent
problem
det( m(j) A - B ) = 0
CGEGV computes the generalized eigenvalues (alpha(1),beta(1)), ...,
(alpha(n),beta(n)), the matrix L whose columns contain the
generalized left eigenvectors l, and the matrix R whose columns
contain the generalized right eigenvectors r for the pair (A,B).
When CDRVGG 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, one matrix will be generated and used
to test the nonsymmetric eigenroutines. For each matrix, 7
tests will be performed and compared with the threshhold THRESH:
Results from CGEGS:
H
(1) | A - Q S Z | / ( |A| n ulp )
H
(2) | B - Q T Z | / ( |B| n ulp )
H
(3) | I - QQ | / ( n ulp )
H
(4) | I - ZZ | / ( n ulp )
(5) 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)|)
Results from CGEGV:
(6) max over all left eigenvalue/-vector pairs (beta/alpha,l) of
| l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) )
where l**H is the conjugate tranpose of l.
(7) max over all right eigenvalue/-vector pairs (beta/alpha,r) of
| (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) )
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 unitary 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,
CDRVGG does nothing. It must be at least zero.
NN (input) INTEGER array, dimension (NSIZES)
An array containing the sizes to be used for the matrices.
Zero values will be skipped. The values must be at least
zero.
NTYPES (input) INTEGER
The number of elements in DOTYPE. If it is zero, CDRVGG
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. 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 CDRVGG to continue the same random number
sequence.
THRESH (input) REAL
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. It must be at least zero.
THRSHN (input) REAL
Threshhold for reporting eigenvector normalization error.
If the normalization of any eigenvector differs from 1 by
more than THRSHN*ulp, then a special error message will be
printed. (This is handled separately from the other tests,
since only a compiler or programming error should cause an
error message, at least if THRSHN is at least 5--10.)
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 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, T, S2, and T2.
It must be at least 1 and at least max( NN ).
B (input/workspace) COMPLEX 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 array, dimension (LDA, max(NN))
The upper triangular matrix computed from A by CGEGS.
T (workspace) COMPLEX array, dimension (LDA, max(NN))
The upper triangular matrix computed from B by CGEGS.
S2 (workspace) COMPLEX array, dimension (LDA, max(NN))
The matrix computed from A by CGEGV. This will be the
Schur (upper triangular) form of some matrix related to A,
but will not, in general, be the same as S.
T2 (workspace) COMPLEX array, dimension (LDA, max(NN))
The matrix computed from B by CGEGV. This will be the
Schur form of some matrix related to B, but will not, in
general, be the same as T.
Q (workspace) COMPLEX array, dimension (LDQ, max(NN))
The (left) unitary matrix computed by CGEGS.
LDQ (input) INTEGER
The leading dimension of Q, Z, VL, and VR. It must
be at least 1 and at least max( NN ).
Z (workspace) COMPLEX array, dimension (LDQ, max(NN))
The (right) unitary matrix computed by CGEGS.
ALPHA1 (workspace) COMPLEX array, dimension (max(NN))
BETA1 (workspace) COMPLEX array, dimension (max(NN))
The generalized eigenvalues of (A,B) computed by CGEGS.
ALPHA1(k) / BETA1(k) is the k-th generalized eigenvalue of
the matrices in A and B.
ALPHA2 (workspace) COMPLEX array, dimension (max(NN))
BETA2 (workspace) COMPLEX array, dimension (max(NN))
The generalized eigenvalues of (A,B) computed by CGEGV.
ALPHA2(k) / BETA2(k) is the k-th generalized eigenvalue of
the matrices in A and B.
VL (workspace) COMPLEX array, dimension (LDQ, max(NN))
The (lower triangular) left eigenvector matrix for the
matrices in A and B.
VR (workspace) COMPLEX array, dimension (LDQ, max(NN))
The (upper triangular) right eigenvector matrix for the
matrices in A and B.
WORK (workspace) COMPLEX array, dimension (LWORK)
LWORK (input) INTEGER
The number of entries in WORK. This must be at least
MAX( 2*N, N*(NB+1), (k+1)*(2*k+N+1) ), where "k" is the
sum of the blocksize and number-of-shifts for CHGEQZ, and
NB is the greatest of the blocksizes for CGEQRF, CUNMQR,
and CUNGQR. (The blocksizes and the number-of-shifts are
retrieved through calls to ILAENV.)
RWORK (workspace) REAL array, dimension (8*N)
RESULT (output) REAL array, dimension (7)
The values computed by the tests described above.
The values are currently limited to 1/ulp, to avoid
overflow.
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.
=====================================================================
Parameter adjustments */
--nn;
--dotype;
--iseed;
t2_dim1 = *lda;
t2_offset = 1 + t2_dim1 * 1;
t2 -= t2_offset;
s2_dim1 = *lda;
s2_offset = 1 + s2_dim1 * 1;
s2 -= s2_offset;
t_dim1 = *lda;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
s_dim1 = *lda;
s_offset = 1 + s_dim1 * 1;
s -= s_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
vr_dim1 = *ldq;
vr_offset = 1 + vr_dim1 * 1;
vr -= vr_offset;
vl_dim1 = *ldq;
vl_offset = 1 + vl_dim1 * 1;
vl -= vl_offset;
z_dim1 = *ldq;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
--alpha1;
--beta1;
--alpha2;
--beta2;
--work;
--rwork;
--result;
/* Function Body
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: */
}
/* Maximum blocksize and shift -- we assume that blocksize and number
of shifts are monotone increasing functions of N.
Computing MAX */
i__1 = 1, i__2 = ilaenv_(&c__1, "CGEQRF", " ", &nmax, &nmax, &c_n1, &c_n1,
(ftnlen)6, (ftnlen)1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
c__1, "CUNMQR", "LC", &nmax, &nmax, &nmax, &c_n1, (ftnlen)6, (
ftnlen)2), i__1 = max(i__1,i__2), i__2 = ilaenv_(&c__1, "CUNGQR",
" ", &nmax, &nmax, &nmax, &c_n1, (ftnlen)6, (ftnlen)1);
nb = max(i__1,i__2);
nbz = ilaenv_(&c__1, "CHGEQZ", "SII", &nmax, &c__1, &nmax, &c__0, (ftnlen)
6, (ftnlen)3);
ns = ilaenv_(&c__4, "CHGEQZ", "SII", &nmax, &c__1, &nmax, &c__0, (ftnlen)
6, (ftnlen)3);
i1 = nbz + ns;
/* Computing MAX */
i__1 = nmax << 1, i__2 = nmax * (nb + 1), i__1 = max(i__1,i__2), i__2 = ((
i1 << 1) + nmax + 1) * (i1 + 1);
lwkopt = max(i__1,i__2);
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.f) {
*info = -6;
} else if (*lda <= 1 || *lda < nmax) {
*info = -10;
} else if (*ldq <= 1 || *ldq < nmax) {
*info = -19;
} else if (lwkopt > *lwork) {
*info = -30;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CDRVGG", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
ulp = slamch_("Precision");
safmin = slamch_("Safe minimum");
safmin /= ulp;
safmax = 1.f / safmin;
slabad_(&safmin, &safmax);
ulpinv = 1.f / ulp;
/* The values RMAGN(2:3) depend on N, see below. */
rmagn[0] = 0.f;
rmagn[1] = 1.f;
/* Loop over sizes, types */
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 / (real) n1;
rmagn[3] = safmin * ulpinv * n1;
if (*nsizes != 1) {
mtypes = min(26,*ntypes);
} else {
mtypes = min(27,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L150;
}
++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 <= 7; ++j) {
result[j] = 0.f;
/* L30: */
}
/* Compute A and B
Description of control parameters:
KCLASS: =1 means w/o rotation, =2 means w/ rotation,
=3 means random.
KATYPE: the "type" to be passed to CLATM4 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, IBSIGN: 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) {
claset_("Full", &n, &n, &c_b1, &c_b1, &a[a_offset],
lda);
}
} else {
in = n;
}
clatm4_(&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 = a_subscr(iadd, iadd);
i__4 = kamagn[jtype - 1];
a[i__3].r = rmagn[i__4], a[i__3].i = 0.f;
}
/* Generate B (w/o rotation) */
if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
claset_("Full", &n, &n, &c_b1, &c_b1, &b[b_offset],
lda);
}
} else {
in = n;
}
clatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
&kz2[kbzero[jtype - 1] - 1], &lbsign[jtype - 1], &
rmagn[kbmagn[jtype - 1]], &c_b39, &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 = b_subscr(iadd, iadd);
i__4 = kbmagn[jtype - 1];
b[i__3].r = rmagn[i__4], b[i__3].i = 0.f;
}
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 = q_subscr(jr, jc);
clarnd_(&q__1, &c__3, &iseed[1]);
q[i__5].r = q__1.r, q[i__5].i = q__1.i;
i__5 = z___subscr(jr, jc);
clarnd_(&q__1, &c__3, &iseed[1]);
z__[i__5].r = q__1.r, z__[i__5].i = q__1.i;
/* L40: */
}
i__4 = n + 1 - jc;
clarfg_(&i__4, &q_ref(jc, jc), &q_ref(jc + 1, jc), &
c__1, &work[jc]);
i__4 = (n << 1) + jc;
i__5 = q_subscr(jc, jc);
r__2 = q[i__5].r;
r__1 = r_sign(&c_b39, &r__2);
work[i__4].r = r__1, work[i__4].i = 0.f;
i__4 = q_subscr(jc, jc);
q[i__4].r = 1.f, q[i__4].i = 0.f;
i__4 = n + 1 - jc;
clarfg_(&i__4, &z___ref(jc, jc), &z___ref(jc + 1, jc),
&c__1, &work[n + jc]);
i__4 = n * 3 + jc;
i__5 = z___subscr(jc, jc);
r__2 = z__[i__5].r;
r__1 = r_sign(&c_b39, &r__2);
work[i__4].r = r__1, work[i__4].i = 0.f;
i__4 = z___subscr(jc, jc);
z__[i__4].r = 1.f, z__[i__4].i = 0.f;
/* L50: */
}
clarnd_(&q__1, &c__3, &iseed[1]);
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__3 = q_subscr(n, n);
q[i__3].r = 1.f, q[i__3].i = 0.f;
i__3 = n;
work[i__3].r = 0.f, work[i__3].i = 0.f;
i__3 = n * 3;
r__1 = c_abs(&ctemp);
q__1.r = ctemp.r / r__1, q__1.i = ctemp.i / r__1;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
clarnd_(&q__1, &c__3, &iseed[1]);
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__3 = z___subscr(n, n);
z__[i__3].r = 1.f, z__[i__3].i = 0.f;
i__3 = n << 1;
work[i__3].r = 0.f, work[i__3].i = 0.f;
i__3 = n << 2;
r__1 = c_abs(&ctemp);
q__1.r = ctemp.r / r__1, q__1.i = ctemp.i / r__1;
work[i__3].r = q__1.r, work[i__3].i = q__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 = a_subscr(jr, jc);
i__6 = (n << 1) + jr;
r_cnjg(&q__3, &work[n * 3 + jc]);
q__2.r = work[i__6].r * q__3.r - work[i__6].i *
q__3.i, q__2.i = work[i__6].r * q__3.i +
work[i__6].i * q__3.r;
i__7 = a_subscr(jr, jc);
q__1.r = q__2.r * a[i__7].r - q__2.i * a[i__7].i,
q__1.i = q__2.r * a[i__7].i + q__2.i * a[
i__7].r;
a[i__5].r = q__1.r, a[i__5].i = q__1.i;
i__5 = b_subscr(jr, jc);
i__6 = (n << 1) + jr;
r_cnjg(&q__3, &work[n * 3 + jc]);
q__2.r = work[i__6].r * q__3.r - work[i__6].i *
q__3.i, q__2.i = work[i__6].r * q__3.i +
work[i__6].i * q__3.r;
i__7 = b_subscr(jr, jc);
q__1.r = q__2.r * b[i__7].r - q__2.i * b[i__7].i,
q__1.i = q__2.r * b[i__7].i + q__2.i * b[
i__7].r;
b[i__5].r = q__1.r, b[i__5].i = q__1.i;
/* L60: */
}
/* L70: */
}
i__3 = n - 1;
cunm2r_("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;
cunm2r_("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;
cunm2r_("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;
cunm2r_("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 = a_subscr(jr, jc);
i__6 = kamagn[jtype - 1];
clarnd_(&q__2, &c__4, &iseed[1]);
q__1.r = rmagn[i__6] * q__2.r, q__1.i = rmagn[i__6] *
q__2.i;
a[i__5].r = q__1.r, a[i__5].i = q__1.i;
i__5 = b_subscr(jr, jc);
i__6 = kbmagn[jtype - 1];
clarnd_(&q__2, &c__4, &iseed[1]);
q__1.r = rmagn[i__6] * q__2.r, q__1.i = rmagn[i__6] *
q__2.i;
b[i__5].r = q__1.r, b[i__5].i = q__1.i;
/* L80: */
}
/* L90: */
}
}
L100:
if (iinfo != 0) {
io___43.ciunit = *nounit;
s_wsfe(&io___43);
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:
/* Call CGEGS to compute H, T, Q, Z, alpha, and beta. */
clacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
clacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
ntest = 1;
result[1] = ulpinv;
cgegs_("V", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &
alpha1[1], &beta1[1], &q[q_offset], ldq, &z__[z_offset],
ldq, &work[1], lwork, &rwork[1], &iinfo);
if (iinfo != 0) {
io___44.ciunit = *nounit;
s_wsfe(&io___44);
do_fio(&c__1, "CGEGS", (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 L130;
}
ntest = 4;
/* Do tests 1--4 */
cget51_(&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]);
cget51_(&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]);
cget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &q[
q_offset], ldq, &q[q_offset], ldq, &work[1], &rwork[1], &
result[3]);
cget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &z__[
z_offset], ldq, &z__[z_offset], ldq, &work[1], &rwork[1],
&result[4]);
/* Do test 5: compare eigenvalues with diagonals. */
temp1 = 0.f;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = s_subscr(j, j);
q__2.r = alpha1[i__4].r - s[i__5].r, q__2.i = alpha1[i__4].i
- s[i__5].i;
q__1.r = q__2.r, q__1.i = q__2.i;
i__6 = j;
i__7 = t_subscr(j, j);
q__4.r = beta1[i__6].r - t[i__7].r, q__4.i = beta1[i__6].i -
t[i__7].i;
q__3.r = q__4.r, q__3.i = q__4.i;
/* Computing MAX */
i__8 = j;
i__9 = s_subscr(j, j);
r__13 = safmin, r__14 = (r__1 = alpha1[i__8].r, dabs(r__1)) +
(r__2 = r_imag(&alpha1[j]), dabs(r__2)), r__13 = max(
r__13,r__14), r__14 = (r__3 = s[i__9].r, dabs(r__3))
+ (r__4 = r_imag(&s_ref(j, j)), dabs(r__4));
/* Computing MAX */
i__10 = j;
i__11 = t_subscr(j, j);
r__15 = safmin, r__16 = (r__5 = beta1[i__10].r, dabs(r__5)) +
(r__6 = r_imag(&beta1[j]), dabs(r__6)), r__15 = max(
r__15,r__16), r__16 = (r__7 = t[i__11].r, dabs(r__7))
+ (r__8 = r_imag(&t_ref(j, j)), dabs(r__8));
temp2 = (((r__9 = q__1.r, dabs(r__9)) + (r__10 = r_imag(&q__1)
, dabs(r__10))) / dmax(r__13,r__14) + ((r__11 =
q__3.r, dabs(r__11)) + (r__12 = r_imag(&q__3), dabs(
r__12))) / dmax(r__15,r__16)) / ulp;
temp1 = dmax(temp1,temp2);
/* L120: */
}
result[5] = temp1;
/* Call CGEGV to compute S2, T2, VL, and VR, do tests.
Eigenvalues and Eigenvectors */
clacpy_(" ", &n, &n, &a[a_offset], lda, &s2[s2_offset], lda);
clacpy_(" ", &n, &n, &b[b_offset], lda, &t2[t2_offset], lda);
ntest = 6;
result[6] = ulpinv;
cgegv_("V", "V", &n, &s2[s2_offset], lda, &t2[t2_offset], lda, &
alpha2[1], &beta2[1], &vl[vl_offset], ldq, &vr[vr_offset],
ldq, &work[1], lwork, &rwork[1], &iinfo);
if (iinfo != 0) {
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, "CGEGV", (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 L130;
}
ntest = 7;
/* Do Tests 6 and 7 */
cget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &vl[
vl_offset], ldq, &alpha2[1], &beta2[1], &work[1], &rwork[
1], dumma);
result[6] = dumma[0];
if (dumma[1] > *thrshn) {
io___49.ciunit = *nounit;
s_wsfe(&io___49);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "CGEGV", (ftnlen)5);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
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();
}
cget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &vr[
vr_offset], ldq, &alpha2[1], &beta2[1], &work[1], &rwork[
1], dumma);
result[7] = dumma[0];
if (dumma[1] > *thresh) {
io___50.ciunit = *nounit;
s_wsfe(&io___50);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "CGEGV", (ftnlen)5);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
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();
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L130:
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___51.ciunit = *nounit;
s_wsfe(&io___51);
do_fio(&c__1, "CGG", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___52.ciunit = *nounit;
s_wsfe(&io___52);
e_wsfe();
io___53.ciunit = *nounit;
s_wsfe(&io___53);
e_wsfe();
io___54.ciunit = *nounit;
s_wsfe(&io___54);
do_fio(&c__1, "Unitary", (ftnlen)7);
e_wsfe();
/* Tests performed */
io___55.ciunit = *nounit;
s_wsfe(&io___55);
do_fio(&c__1, "unitary", (ftnlen)7);
do_fio(&c__1, "*", (ftnlen)1);
do_fio(&c__1, "conjugate transpose", (ftnlen)19);
for (j = 1; j <= 5; ++j) {
do_fio(&c__1, "*", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
if (result[jr] < 1e4f) {
io___56.ciunit = *nounit;
s_wsfe(&io___56);
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(
real));
e_wsfe();
} else {
io___57.ciunit = *nounit;
s_wsfe(&io___57);
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(
real));
e_wsfe();
}
}
/* L140: */
}
L150:
;
}
/* L160: */
}
/* Summary */
alasvm_("CGG", nounit, &nerrs, &ntestt, &c__0);
return 0;
/* End of CDRVGG */
} /* cdrvgg_ */
/* Subroutine */ int chegs2_(integer *itype, char *uplo, integer *n, complex *
a, integer *lda, complex *b, integer *ldb, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CHEGS2 reduces a complex Hermitian-definite generalized
eigenproblem to standard form.
If ITYPE = 1, the problem is A*x = lambda*B*x,
and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')
If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.
B must have been previously factorized as U'*U or L*L' by CPOTRF.
Arguments
=========
ITYPE (input) INTEGER
= 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');
= 2 or 3: compute U*A*U' or L'*A*L.
UPLO (input) CHARACTER
Specifies whether the upper or lower triangular part of the
Hermitian matrix A is stored, and how B has been factorized.
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrices A and B. N >= 0.
A (input/output) COMPLEX array, dimension (LDA,N)
On entry, the Hermitian matrix A. If UPLO = 'U', the leading
n by n upper triangular part of A contains the upper
triangular part of the matrix A, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading n by n lower triangular part of A contains the lower
triangular part of the matrix A, and the strictly upper
triangular part of A is not referenced.
On exit, if INFO = 0, the transformed matrix, stored in the
same format as A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input) COMPLEX array, dimension (LDB,N)
The triangular factor from the Cholesky factorization of B,
as returned by CPOTRF.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
real r__1, r__2;
complex q__1;
/* Local variables */
extern /* Subroutine */ int cher2_(char *, integer *, complex *, complex *
, integer *, complex *, integer *, complex *, integer *);
static integer k;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
static logical upper;
extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *,
complex *, integer *, complex *, integer *), ctrsv_(char *, char *, char *, integer *, complex *,
integer *, complex *, integer *);
static complex ct;
extern /* Subroutine */ int clacgv_(integer *, complex *, integer *),
csscal_(integer *, real *, complex *, integer *), xerbla_(char *,
integer *);
static real akk, bkk;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHEGS2", &i__1);
return 0;
}
if (*itype == 1) {
if (upper) {
/* Compute inv(U')*A*inv(U) */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the upper triangle of A(k:n,k:n) */
i__2 = a_subscr(k, k);
akk = a[i__2].r;
i__2 = b_subscr(k, k);
bkk = b[i__2].r;
/* Computing 2nd power */
r__1 = bkk;
akk /= r__1 * r__1;
i__2 = a_subscr(k, k);
a[i__2].r = akk, a[i__2].i = 0.f;
if (k < *n) {
i__2 = *n - k;
r__1 = 1.f / bkk;
csscal_(&i__2, &r__1, &a_ref(k, k + 1), lda);
r__1 = akk * -.5f;
ct.r = r__1, ct.i = 0.f;
i__2 = *n - k;
clacgv_(&i__2, &a_ref(k, k + 1), lda);
i__2 = *n - k;
clacgv_(&i__2, &b_ref(k, k + 1), ldb);
i__2 = *n - k;
caxpy_(&i__2, &ct, &b_ref(k, k + 1), ldb, &a_ref(k, k + 1)
, lda);
i__2 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
cher2_(uplo, &i__2, &q__1, &a_ref(k, k + 1), lda, &b_ref(
k, k + 1), ldb, &a_ref(k + 1, k + 1), lda);
i__2 = *n - k;
caxpy_(&i__2, &ct, &b_ref(k, k + 1), ldb, &a_ref(k, k + 1)
, lda);
i__2 = *n - k;
clacgv_(&i__2, &b_ref(k, k + 1), ldb);
i__2 = *n - k;
ctrsv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &
b_ref(k + 1, k + 1), ldb, &a_ref(k, k + 1), lda);
i__2 = *n - k;
clacgv_(&i__2, &a_ref(k, k + 1), lda);
}
/* L10: */
}
} else {
/* Compute inv(L)*A*inv(L') */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the lower triangle of A(k:n,k:n) */
i__2 = a_subscr(k, k);
akk = a[i__2].r;
i__2 = b_subscr(k, k);
bkk = b[i__2].r;
/* Computing 2nd power */
r__1 = bkk;
akk /= r__1 * r__1;
i__2 = a_subscr(k, k);
a[i__2].r = akk, a[i__2].i = 0.f;
if (k < *n) {
i__2 = *n - k;
r__1 = 1.f / bkk;
csscal_(&i__2, &r__1, &a_ref(k + 1, k), &c__1);
r__1 = akk * -.5f;
ct.r = r__1, ct.i = 0.f;
i__2 = *n - k;
caxpy_(&i__2, &ct, &b_ref(k + 1, k), &c__1, &a_ref(k + 1,
k), &c__1);
i__2 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
cher2_(uplo, &i__2, &q__1, &a_ref(k + 1, k), &c__1, &
b_ref(k + 1, k), &c__1, &a_ref(k + 1, k + 1), lda);
i__2 = *n - k;
caxpy_(&i__2, &ct, &b_ref(k + 1, k), &c__1, &a_ref(k + 1,
k), &c__1);
i__2 = *n - k;
ctrsv_(uplo, "No transpose", "Non-unit", &i__2, &b_ref(k
+ 1, k + 1), ldb, &a_ref(k + 1, k), &c__1);
}
/* L20: */
}
}
} else {
if (upper) {
/* Compute U*A*U' */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the upper triangle of A(1:k,1:k) */
i__2 = a_subscr(k, k);
akk = a[i__2].r;
i__2 = b_subscr(k, k);
bkk = b[i__2].r;
i__2 = k - 1;
ctrmv_(uplo, "No transpose", "Non-unit", &i__2, &b[b_offset],
ldb, &a_ref(1, k), &c__1);
r__1 = akk * .5f;
ct.r = r__1, ct.i = 0.f;
i__2 = k - 1;
caxpy_(&i__2, &ct, &b_ref(1, k), &c__1, &a_ref(1, k), &c__1);
i__2 = k - 1;
cher2_(uplo, &i__2, &c_b1, &a_ref(1, k), &c__1, &b_ref(1, k),
&c__1, &a[a_offset], lda);
i__2 = k - 1;
caxpy_(&i__2, &ct, &b_ref(1, k), &c__1, &a_ref(1, k), &c__1);
i__2 = k - 1;
csscal_(&i__2, &bkk, &a_ref(1, k), &c__1);
i__2 = a_subscr(k, k);
/* Computing 2nd power */
r__2 = bkk;
r__1 = akk * (r__2 * r__2);
a[i__2].r = r__1, a[i__2].i = 0.f;
/* L30: */
}
} else {
/* Compute L'*A*L */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the lower triangle of A(1:k,1:k) */
i__2 = a_subscr(k, k);
akk = a[i__2].r;
i__2 = b_subscr(k, k);
bkk = b[i__2].r;
i__2 = k - 1;
clacgv_(&i__2, &a_ref(k, 1), lda);
i__2 = k - 1;
ctrmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &b[
b_offset], ldb, &a_ref(k, 1), lda);
r__1 = akk * .5f;
ct.r = r__1, ct.i = 0.f;
i__2 = k - 1;
clacgv_(&i__2, &b_ref(k, 1), ldb);
i__2 = k - 1;
caxpy_(&i__2, &ct, &b_ref(k, 1), ldb, &a_ref(k, 1), lda);
i__2 = k - 1;
cher2_(uplo, &i__2, &c_b1, &a_ref(k, 1), lda, &b_ref(k, 1),
ldb, &a[a_offset], lda);
i__2 = k - 1;
caxpy_(&i__2, &ct, &b_ref(k, 1), ldb, &a_ref(k, 1), lda);
i__2 = k - 1;
clacgv_(&i__2, &b_ref(k, 1), ldb);
i__2 = k - 1;
csscal_(&i__2, &bkk, &a_ref(k, 1), lda);
i__2 = k - 1;
clacgv_(&i__2, &a_ref(k, 1), lda);
i__2 = a_subscr(k, k);
/* Computing 2nd power */
r__2 = bkk;
r__1 = akk * (r__2 * r__2);
a[i__2].r = r__1, a[i__2].i = 0.f;
/* L40: */
}
}
}
return 0;
/* End of CHEGS2 */
} /* chegs2_ */
/* Subroutine */ int cgghrd_(char *compq, char *compz, integer *n, integer *
ilo, integer *ihi, complex *a, integer *lda, complex *b, integer *ldb,
complex *q, integer *ldq, complex *z__, integer *ldz, 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
=======
CGGHRD reduces a pair of complex matrices (A,B) to generalized upper
Hessenberg form using unitary transformations, where A is a
general matrix and B is upper triangular: Q' * A * Z = H and
Q' * B * Z = T, where H is upper Hessenberg, T is upper triangular,
and Q and Z are unitary, and ' means conjugate transpose.
The unitary matrices Q and Z are determined as products of Givens
rotations. They may either be formed explicitly, or they may be
postmultiplied into input matrices Q1 and Z1, so that
Q1 * A * Z1' = (Q1*Q) * H * (Z1*Z)'
Q1 * B * Z1' = (Q1*Q) * T * (Z1*Z)'
Arguments
=========
COMPQ (input) CHARACTER*1
= 'N': do not compute Q;
= 'I': Q is initialized to the unit matrix, and the
unitary matrix Q is returned;
= 'V': Q must contain a unitary matrix Q1 on entry,
and the product Q1*Q is returned.
COMPZ (input) CHARACTER*1
= 'N': do not compute Q;
= 'I': Q is initialized to the unit matrix, and the
unitary matrix Q is returned;
= 'V': Q must contain a unitary matrix Q1 on entry,
and the product Q1*Q is returned.
N (input) INTEGER
The order of the matrices A and B. 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 CGGBAL; otherwise they should be set
to 1 and N respectively.
1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
A (input/output) COMPLEX 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
rest is set to zero.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input/output) COMPLEX array, dimension (LDB, N)
On entry, the N-by-N upper triangular matrix B.
On exit, the upper triangular matrix T = Q' B Z. The
elements below the diagonal are set to zero.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
Q (input/output) COMPLEX array, dimension (LDQ, N)
If COMPQ='N': Q is not referenced.
If COMPQ='I': on entry, Q need not be set, and on exit it
contains the unitary matrix Q, where Q'
is the product of the Givens transformations
which are applied to A and B on the left.
If COMPQ='V': on entry, Q must contain a unitary matrix
Q1, and on exit this is overwritten by Q1*Q.
LDQ (input) INTEGER
The leading dimension of the array Q.
LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.
Z (input/output) COMPLEX array, dimension (LDZ, N)
If COMPZ='N': Z is not referenced.
If COMPZ='I': on entry, Z need not be set, and on exit it
contains the unitary matrix Z, which is
the product of the Givens transformations
which are applied to A and B on the right.
If COMPZ='V': on entry, Z must contain a unitary matrix
Z1, and on exit this is overwritten by Z1*Z.
LDZ (input) INTEGER
The leading dimension of the array Z.
LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
Further Details
===============
This routine reduces A to Hessenberg and B to triangular form by
an unblocked reduction, as described in _Matrix_Computations_,
by Golub and van Loan (Johns Hopkins Press).
=====================================================================
Decode COMPQ
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
static complex c_b2 = {0.f,0.f};
static integer c__1 = 1;
/* 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;
complex q__1;
/* Builtin functions */
void r_cnjg(complex *, complex *);
/* Local variables */
static integer jcol;
extern /* Subroutine */ int crot_(integer *, complex *, integer *,
complex *, integer *, real *, complex *);
static integer jrow;
static real c__;
static complex s;
extern logical lsame_(char *, char *);
static complex ctemp;
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *), clartg_(complex *,
complex *, real *, complex *, complex *), xerbla_(char *, integer
*);
static integer icompq, icompz;
static logical ilq, ilz;
#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)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
/* Function Body */
if (lsame_(compq, "N")) {
ilq = FALSE_;
icompq = 1;
} else if (lsame_(compq, "V")) {
ilq = TRUE_;
icompq = 2;
} else if (lsame_(compq, "I")) {
ilq = TRUE_;
icompq = 3;
} else {
icompq = 0;
}
/* Decode COMPZ */
if (lsame_(compz, "N")) {
ilz = FALSE_;
icompz = 1;
} else if (lsame_(compz, "V")) {
ilz = TRUE_;
icompz = 2;
} else if (lsame_(compz, "I")) {
ilz = TRUE_;
icompz = 3;
} else {
icompz = 0;
}
/* Test the input parameters. */
*info = 0;
if (icompq <= 0) {
*info = -1;
} else if (icompz <= 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ilo < 1) {
*info = -4;
} else if (*ihi > *n || *ihi < *ilo - 1) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (ilq && *ldq < *n || *ldq < 1) {
*info = -11;
} else if (ilz && *ldz < *n || *ldz < 1) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGGHRD", &i__1);
return 0;
}
/* Initialize Q and Z if desired. */
if (icompq == 3) {
claset_("Full", n, n, &c_b2, &c_b1, &q[q_offset], ldq);
}
if (icompz == 3) {
claset_("Full", n, n, &c_b2, &c_b1, &z__[z_offset], ldz);
}
/* Quick return if possible */
if (*n <= 1) {
return 0;
}
/* Zero out lower triangle of B */
i__1 = *n - 1;
for (jcol = 1; jcol <= i__1; ++jcol) {
i__2 = *n;
for (jrow = jcol + 1; jrow <= i__2; ++jrow) {
i__3 = b_subscr(jrow, jcol);
b[i__3].r = 0.f, b[i__3].i = 0.f;
/* L10: */
}
/* L20: */
}
/* Reduce A and B */
i__1 = *ihi - 2;
for (jcol = *ilo; jcol <= i__1; ++jcol) {
i__2 = jcol + 2;
for (jrow = *ihi; jrow >= i__2; --jrow) {
/* Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL) */
i__3 = a_subscr(jrow - 1, jcol);
ctemp.r = a[i__3].r, ctemp.i = a[i__3].i;
clartg_(&ctemp, &a_ref(jrow, jcol), &c__, &s, &a_ref(jrow - 1,
jcol));
i__3 = a_subscr(jrow, jcol);
a[i__3].r = 0.f, a[i__3].i = 0.f;
i__3 = *n - jcol;
crot_(&i__3, &a_ref(jrow - 1, jcol + 1), lda, &a_ref(jrow, jcol +
1), lda, &c__, &s);
i__3 = *n + 2 - jrow;
crot_(&i__3, &b_ref(jrow - 1, jrow - 1), ldb, &b_ref(jrow, jrow -
1), ldb, &c__, &s);
if (ilq) {
r_cnjg(&q__1, &s);
crot_(n, &q_ref(1, jrow - 1), &c__1, &q_ref(1, jrow), &c__1, &
c__, &q__1);
}
/* Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1) */
i__3 = b_subscr(jrow, jrow);
ctemp.r = b[i__3].r, ctemp.i = b[i__3].i;
clartg_(&ctemp, &b_ref(jrow, jrow - 1), &c__, &s, &b_ref(jrow,
jrow));
i__3 = b_subscr(jrow, jrow - 1);
b[i__3].r = 0.f, b[i__3].i = 0.f;
crot_(ihi, &a_ref(1, jrow), &c__1, &a_ref(1, jrow - 1), &c__1, &
c__, &s);
i__3 = jrow - 1;
crot_(&i__3, &b_ref(1, jrow), &c__1, &b_ref(1, jrow - 1), &c__1, &
c__, &s);
if (ilz) {
crot_(n, &z___ref(1, jrow), &c__1, &z___ref(1, jrow - 1), &
c__1, &c__, &s);
}
/* L30: */
}
/* L40: */
}
return 0;
/* End of CGGHRD */
} /* cgghrd_ */
/* Subroutine */ int cgsvts_(integer *m, integer *p, integer *n, complex *a,
complex *af, integer *lda, complex *b, complex *bf, integer *ldb,
complex *u, integer *ldu, complex *v, integer *ldv, complex *q,
integer *ldq, real *alpha, real *beta, complex *r__, integer *ldr,
integer *iwork, complex *work, integer *lwork, real *rwork, real *
result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, bf_dim1,
bf_offset, q_dim1, q_offset, r_dim1, r_offset, u_dim1, u_offset,
v_dim1, v_offset, i__1, i__2, i__3, i__4, i__5, i__6;
real r__1;
complex q__1, q__2;
/* Local variables */
static integer info;
static real unfl, temp;
static integer i__, j, k, l;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *), cherk_(char *,
char *, integer *, integer *, real *, complex *, integer *, real *
, complex *, integer *);
static real resid, anorm, bnorm;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *), clanhe_(char *, char *, integer *,
complex *, integer *, real *), slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), claset_(char *,
integer *, integer *, complex *, complex *, complex *, integer *), cggsvd_(char *, char *, char *, integer *, integer *,
integer *, integer *, integer *, complex *, integer *, complex *,
integer *, real *, real *, complex *, integer *, complex *,
integer *, complex *, integer *, complex *, real *, integer *,
integer *);
static real ulpinv, ulp;
#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 r___subscr(a_1,a_2) (a_2)*r_dim1 + a_1
#define r___ref(a_1,a_2) r__[r___subscr(a_1,a_2)]
#define af_subscr(a_1,a_2) (a_2)*af_dim1 + a_1
#define af_ref(a_1,a_2) af[af_subscr(a_1,a_2)]
#define bf_subscr(a_1,a_2) (a_2)*bf_dim1 + a_1
#define bf_ref(a_1,a_2) bf[bf_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
CGSVTS tests CGGSVD, which computes the GSVD of an M-by-N matrix A
and a P-by-N matrix B:
U'*A*Q = D1*R and V'*B*Q = D2*R.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
P (input) INTEGER
The number of rows of the matrix B. P >= 0.
N (input) INTEGER
The number of columns of the matrices A and B. N >= 0.
A (input) COMPLEX array, dimension (LDA,M)
The M-by-N matrix A.
AF (output) COMPLEX array, dimension (LDA,N)
Details of the GSVD of A and B, as returned by CGGSVD,
see CGGSVD for further details.
LDA (input) INTEGER
The leading dimension of the arrays A and AF.
LDA >= max( 1,M ).
B (input) COMPLEX array, dimension (LDB,P)
On entry, the P-by-N matrix B.
BF (output) COMPLEX array, dimension (LDB,N)
Details of the GSVD of A and B, as returned by CGGSVD,
see CGGSVD for further details.
LDB (input) INTEGER
The leading dimension of the arrays B and BF.
LDB >= max(1,P).
U (output) COMPLEX array, dimension(LDU,M)
The M by M unitary matrix U.
LDU (input) INTEGER
The leading dimension of the array U. LDU >= max(1,M).
V (output) COMPLEX array, dimension(LDV,M)
The P by P unitary matrix V.
LDV (input) INTEGER
The leading dimension of the array V. LDV >= max(1,P).
Q (output) COMPLEX array, dimension(LDQ,N)
The N by N unitary matrix Q.
LDQ (input) INTEGER
The leading dimension of the array Q. LDQ >= max(1,N).
ALPHA (output) REAL array, dimension (N)
BETA (output) REAL array, dimension (N)
The generalized singular value pairs of A and B, the
``diagonal'' matrices D1 and D2 are constructed from
ALPHA and BETA, see subroutine CGGSVD for details.
R (output) COMPLEX array, dimension(LDQ,N)
The upper triangular matrix R.
LDR (input) INTEGER
The leading dimension of the array R. LDR >= max(1,N).
IWORK (workspace) INTEGER array, dimension (N)
WORK (workspace) COMPLEX array, dimension (LWORK)
LWORK (input) INTEGER
The dimension of the array WORK,
LWORK >= max(M,P,N)*max(M,P,N).
RWORK (workspace) REAL array, dimension (max(M,P,N))
RESULT (output) REAL array, dimension (5)
The test ratios:
RESULT(1) = norm( U'*A*Q - D1*R ) / ( MAX(M,N)*norm(A)*ULP)
RESULT(2) = norm( V'*B*Q - D2*R ) / ( MAX(P,N)*norm(B)*ULP)
RESULT(3) = norm( I - U'*U ) / ( M*ULP )
RESULT(4) = norm( I - V'*V ) / ( P*ULP )
RESULT(5) = norm( I - Q'*Q ) / ( N*ULP )
RESULT(6) = 0 if ALPHA is in decreasing order;
= ULPINV otherwise.
=====================================================================
Parameter adjustments */
af_dim1 = *lda;
af_offset = 1 + af_dim1 * 1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
bf_dim1 = *ldb;
bf_offset = 1 + bf_dim1 * 1;
bf -= bf_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1 * 1;
v -= v_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
--alpha;
--beta;
r_dim1 = *ldr;
r_offset = 1 + r_dim1 * 1;
r__ -= r_offset;
--iwork;
--work;
--rwork;
--result;
/* Function Body */
ulp = slamch_("Precision");
ulpinv = 1.f / ulp;
unfl = slamch_("Safe minimum");
/* Copy the matrix A to the array AF. */
clacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
clacpy_("Full", p, n, &b[b_offset], ldb, &bf[bf_offset], ldb);
/* Computing MAX */
r__1 = clange_("1", m, n, &a[a_offset], lda, &rwork[1]);
anorm = dmax(r__1,unfl);
/* Computing MAX */
r__1 = clange_("1", p, n, &b[b_offset], ldb, &rwork[1]);
bnorm = dmax(r__1,unfl);
/* Factorize the matrices A and B in the arrays AF and BF. */
cggsvd_("U", "V", "Q", m, n, p, &k, &l, &af[af_offset], lda, &bf[
bf_offset], ldb, &alpha[1], &beta[1], &u[u_offset], ldu, &v[
v_offset], ldv, &q[q_offset], ldq, &work[1], &rwork[1], &iwork[1],
&info);
/* Copy R
Computing MIN */
i__2 = k + l;
i__1 = min(i__2,*m);
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = k + l;
for (j = i__; j <= i__2; ++j) {
i__3 = r___subscr(i__, j);
i__4 = af_subscr(i__, *n - k - l + j);
r__[i__3].r = af[i__4].r, r__[i__3].i = af[i__4].i;
/* L10: */
}
/* L20: */
}
if (*m - k - l < 0) {
i__1 = k + l;
for (i__ = *m + 1; i__ <= i__1; ++i__) {
i__2 = k + l;
for (j = i__; j <= i__2; ++j) {
i__3 = r___subscr(i__, j);
i__4 = bf_subscr(i__ - k, *n - k - l + j);
r__[i__3].r = bf[i__4].r, r__[i__3].i = bf[i__4].i;
/* L30: */
}
/* L40: */
}
}
/* Compute A:= U'*A*Q - D1*R */
cgemm_("No transpose", "No transpose", m, n, n, &c_b2, &a[a_offset], lda,
&q[q_offset], ldq, &c_b1, &work[1], lda);
cgemm_("Conjugate transpose", "No transpose", m, n, m, &c_b2, &u[u_offset]
, ldu, &work[1], lda, &c_b1, &a[a_offset], lda);
i__1 = k;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = k + l;
for (j = i__; j <= i__2; ++j) {
i__3 = a_subscr(i__, *n - k - l + j);
i__4 = a_subscr(i__, *n - k - l + j);
i__5 = r___subscr(i__, j);
q__1.r = a[i__4].r - r__[i__5].r, q__1.i = a[i__4].i - r__[i__5]
.i;
a[i__3].r = q__1.r, a[i__3].i = q__1.i;
/* L50: */
}
/* L60: */
}
/* Computing MIN */
i__2 = k + l;
i__1 = min(i__2,*m);
for (i__ = k + 1; i__ <= i__1; ++i__) {
i__2 = k + l;
for (j = i__; j <= i__2; ++j) {
i__3 = a_subscr(i__, *n - k - l + j);
i__4 = a_subscr(i__, *n - k - l + j);
i__5 = i__;
i__6 = r___subscr(i__, j);
q__2.r = alpha[i__5] * r__[i__6].r, q__2.i = alpha[i__5] * r__[
i__6].i;
q__1.r = a[i__4].r - q__2.r, q__1.i = a[i__4].i - q__2.i;
a[i__3].r = q__1.r, a[i__3].i = q__1.i;
/* L70: */
}
/* L80: */
}
/* Compute norm( U'*A*Q - D1*R ) / ( MAX(1,M,N)*norm(A)*ULP ) . */
resid = clange_("1", m, n, &a[a_offset], lda, &rwork[1]);
if (anorm > 0.f) {
/* Computing MAX */
i__1 = max(1,*m);
result[1] = resid / (real) max(i__1,*n) / anorm / ulp;
} else {
result[1] = 0.f;
}
/* Compute B := V'*B*Q - D2*R */
cgemm_("No transpose", "No transpose", p, n, n, &c_b2, &b[b_offset], ldb,
&q[q_offset], ldq, &c_b1, &work[1], ldb);
cgemm_("Conjugate transpose", "No transpose", p, n, p, &c_b2, &v[v_offset]
, ldv, &work[1], ldb, &c_b1, &b[b_offset], ldb);
i__1 = l;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = l;
for (j = i__; j <= i__2; ++j) {
i__3 = b_subscr(i__, *n - l + j);
i__4 = b_subscr(i__, *n - l + j);
i__5 = k + i__;
i__6 = r___subscr(k + i__, k + j);
q__2.r = beta[i__5] * r__[i__6].r, q__2.i = beta[i__5] * r__[i__6]
.i;
q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i - q__2.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L90: */
}
/* L100: */
}
/* Compute norm( V'*B*Q - D2*R ) / ( MAX(P,N)*norm(B)*ULP ) . */
resid = clange_("1", p, n, &b[b_offset], ldb, &rwork[1]);
if (bnorm > 0.f) {
/* Computing MAX */
i__1 = max(1,*p);
result[2] = resid / (real) max(i__1,*n) / bnorm / ulp;
} else {
result[2] = 0.f;
}
/* Compute I - U'*U */
claset_("Full", m, m, &c_b1, &c_b2, &work[1], ldq);
cherk_("Upper", "Conjugate transpose", m, m, &c_b36, &u[u_offset], ldu, &
c_b37, &work[1], ldu);
/* Compute norm( I - U'*U ) / ( M * ULP ) . */
resid = clanhe_("1", "Upper", m, &work[1], ldu, &rwork[1]);
result[3] = resid / (real) max(1,*m) / ulp;
/* Compute I - V'*V */
claset_("Full", p, p, &c_b1, &c_b2, &work[1], ldv);
cherk_("Upper", "Conjugate transpose", p, p, &c_b36, &v[v_offset], ldv, &
c_b37, &work[1], ldv);
/* Compute norm( I - V'*V ) / ( P * ULP ) . */
resid = clanhe_("1", "Upper", p, &work[1], ldv, &rwork[1]);
result[4] = resid / (real) max(1,*p) / ulp;
/* Compute I - Q'*Q */
claset_("Full", n, n, &c_b1, &c_b2, &work[1], ldq);
cherk_("Upper", "Conjugate transpose", n, n, &c_b36, &q[q_offset], ldq, &
c_b37, &work[1], ldq);
/* Compute norm( I - Q'*Q ) / ( N * ULP ) . */
resid = clanhe_("1", "Upper", n, &work[1], ldq, &rwork[1]);
result[5] = resid / (real) max(1,*n) / ulp;
/* Check sorting */
scopy_(n, &alpha[1], &c__1, &rwork[1], &c__1);
/* Computing MIN */
i__2 = k + l;
i__1 = min(i__2,*m);
for (i__ = k + 1; i__ <= i__1; ++i__) {
j = iwork[i__];
if (i__ != j) {
temp = rwork[i__];
rwork[i__] = rwork[j];
rwork[j] = temp;
}
/* L110: */
}
result[6] = 0.f;
/* Computing MIN */
i__2 = k + l;
i__1 = min(i__2,*m) - 1;
for (i__ = k + 1; i__ <= i__1; ++i__) {
if (rwork[i__] < rwork[i__ + 1]) {
result[6] = ulpinv;
}
/* L120: */
}
return 0;
/* End of CGSVTS */
} /* cgsvts_ */
/* Subroutine */ int zptts2_(integer *iuplo, integer *n, integer *nrhs,
doublereal *d__, doublecomplex *e, doublecomplex *b, integer *ldb)
{
/* -- 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
=======
ZPTTS2 solves a tridiagonal system of the form
A * X = B
using the factorization A = U'*D*U or A = L*D*L' computed by ZPTTRF.
D is a diagonal matrix specified in the vector D, U (or L) is a unit
bidiagonal matrix whose superdiagonal (subdiagonal) is specified in
the vector E, and X and B are N by NRHS matrices.
Arguments
=========
IUPLO (input) INTEGER
Specifies the form of the factorization and whether the
vector E is the superdiagonal of the upper bidiagonal factor
U or the subdiagonal of the lower bidiagonal factor L.
= 1: A = U'*D*U, E is the superdiagonal of U
= 0: A = L*D*L', E is the subdiagonal of L
N (input) INTEGER
The order of the tridiagonal 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 diagonal elements of the diagonal matrix D from the
factorization A = U'*D*U or A = L*D*L'.
E (input) COMPLEX*16 array, dimension (N-1)
If IUPLO = 1, the (n-1) superdiagonal elements of the unit
bidiagonal factor U from the factorization A = U'*D*U.
If IUPLO = 0, the (n-1) subdiagonal elements of the unit
bidiagonal factor L from the factorization A = L*D*L'.
B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
On entry, the right hand side vectors B for the system of
linear equations.
On exit, the solution vectors, X.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
=====================================================================
Quick return if possible
Parameter adjustments */
/* System generated locals */
integer b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static integer i__, j;
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *);
#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)]
--d__;
--e;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
/* Function Body */
if (*n <= 1) {
if (*n == 1) {
d__1 = 1. / d__[1];
zdscal_(nrhs, &d__1, &b[b_offset], ldb);
}
return 0;
}
if (*iuplo == 1) {
/* Solve A * X = B using the factorization A = U'*D*U,
overwriting each right hand side vector with its solution. */
if (*nrhs <= 2) {
j = 1;
L10:
/* Solve U' * x = b. */
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = b_subscr(i__, j);
i__3 = b_subscr(i__, j);
i__4 = b_subscr(i__ - 1, j);
d_cnjg(&z__3, &e[i__ - 1]);
z__2.r = b[i__4].r * z__3.r - b[i__4].i * z__3.i, z__2.i = b[
i__4].r * z__3.i + b[i__4].i * z__3.r;
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;
/* L20: */
}
/* Solve D * U * x = b. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = b_subscr(i__, j);
i__3 = b_subscr(i__, j);
i__4 = i__;
z__1.r = b[i__3].r / d__[i__4], z__1.i = b[i__3].i / d__[i__4]
;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
/* L30: */
}
for (i__ = *n - 1; i__ >= 1; --i__) {
i__1 = b_subscr(i__, j);
i__2 = b_subscr(i__, j);
i__3 = b_subscr(i__ + 1, j);
i__4 = i__;
z__2.r = b[i__3].r * e[i__4].r - b[i__3].i * e[i__4].i,
z__2.i = b[i__3].r * e[i__4].i + b[i__3].i * e[i__4]
.r;
z__1.r = b[i__2].r - z__2.r, z__1.i = b[i__2].i - z__2.i;
b[i__1].r = z__1.r, b[i__1].i = z__1.i;
/* L40: */
}
if (j < *nrhs) {
++j;
goto L10;
}
} else {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
/* Solve U' * x = b. */
i__2 = *n;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = b_subscr(i__, j);
i__5 = b_subscr(i__ - 1, j);
d_cnjg(&z__3, &e[i__ - 1]);
z__2.r = b[i__5].r * z__3.r - b[i__5].i * z__3.i, z__2.i =
b[i__5].r * z__3.i + b[i__5].i * z__3.r;
z__1.r = b[i__4].r - z__2.r, z__1.i = b[i__4].i - z__2.i;
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
/* L50: */
}
/* Solve D * U * x = b. */
i__2 = b_subscr(*n, j);
i__3 = b_subscr(*n, j);
i__4 = *n;
z__1.r = b[i__3].r / d__[i__4], z__1.i = b[i__3].i / d__[i__4]
;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
for (i__ = *n - 1; i__ >= 1; --i__) {
i__2 = b_subscr(i__, j);
i__3 = b_subscr(i__, j);
i__4 = i__;
z__2.r = b[i__3].r / d__[i__4], z__2.i = b[i__3].i / d__[
i__4];
i__5 = b_subscr(i__ + 1, j);
i__6 = i__;
z__3.r = b[i__5].r * e[i__6].r - b[i__5].i * e[i__6].i,
z__3.i = b[i__5].r * e[i__6].i + b[i__5].i * e[
i__6].r;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
/* L60: */
}
/* L70: */
}
}
} else {
/* Solve A * X = B using the factorization A = L*D*L',
overwriting each right hand side vector with its solution. */
if (*nrhs <= 2) {
j = 1;
L80:
/* Solve L * x = b. */
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = b_subscr(i__, j);
i__3 = b_subscr(i__, j);
i__4 = b_subscr(i__ - 1, j);
i__5 = i__ - 1;
z__2.r = b[i__4].r * e[i__5].r - b[i__4].i * e[i__5].i,
z__2.i = b[i__4].r * e[i__5].i + b[i__4].i * e[i__5]
.r;
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;
/* L90: */
}
/* Solve D * L' * x = b. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = b_subscr(i__, j);
i__3 = b_subscr(i__, j);
i__4 = i__;
z__1.r = b[i__3].r / d__[i__4], z__1.i = b[i__3].i / d__[i__4]
;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
/* L100: */
}
for (i__ = *n - 1; i__ >= 1; --i__) {
i__1 = b_subscr(i__, j);
i__2 = b_subscr(i__, j);
i__3 = b_subscr(i__ + 1, j);
d_cnjg(&z__3, &e[i__]);
z__2.r = b[i__3].r * z__3.r - b[i__3].i * z__3.i, z__2.i = b[
i__3].r * z__3.i + b[i__3].i * z__3.r;
z__1.r = b[i__2].r - z__2.r, z__1.i = b[i__2].i - z__2.i;
b[i__1].r = z__1.r, b[i__1].i = z__1.i;
/* L110: */
}
if (j < *nrhs) {
++j;
goto L80;
}
} else {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
/* Solve L * x = b. */
i__2 = *n;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = b_subscr(i__, j);
i__5 = b_subscr(i__ - 1, j);
i__6 = i__ - 1;
z__2.r = b[i__5].r * e[i__6].r - b[i__5].i * e[i__6].i,
z__2.i = b[i__5].r * e[i__6].i + b[i__5].i * e[
i__6].r;
z__1.r = b[i__4].r - z__2.r, z__1.i = b[i__4].i - z__2.i;
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
/* L120: */
}
/* Solve D * L' * x = b. */
i__2 = b_subscr(*n, j);
i__3 = b_subscr(*n, j);
i__4 = *n;
z__1.r = b[i__3].r / d__[i__4], z__1.i = b[i__3].i / d__[i__4]
;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
for (i__ = *n - 1; i__ >= 1; --i__) {
i__2 = b_subscr(i__, j);
i__3 = b_subscr(i__, j);
i__4 = i__;
z__2.r = b[i__3].r / d__[i__4], z__2.i = b[i__3].i / d__[
i__4];
i__5 = b_subscr(i__ + 1, j);
d_cnjg(&z__4, &e[i__]);
z__3.r = b[i__5].r * z__4.r - b[i__5].i * z__4.i, z__3.i =
b[i__5].r * z__4.i + b[i__5].i * z__4.r;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
/* L130: */
}
/* L140: */
}
}
}
return 0;
/* End of ZPTTS2 */
} /* zptts2_ */
