/* Subroutine */ int chbev_(char *jobz, char *uplo, integer *n, integer *kd,
complex *ab, integer *ldab, real *w, complex *z__, integer *ldz,
complex *work, real *rwork, integer *info)
{
/* -- LAPACK driver routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
CHBEV computes all the eigenvalues and, optionally, eigenvectors of
a complex Hermitian band matrix A.
Arguments
=========
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
KD (input) INTEGER
The number of superdiagonals of the matrix A if UPLO = 'U',
or the number of subdiagonals if UPLO = 'L'. KD >= 0.
AB (input/output) COMPLEX array, dimension (LDAB, N)
On entry, the upper or lower triangle of the Hermitian band
matrix A, stored in the first KD+1 rows of the array. The
j-th column of A is stored in the j-th column of the array AB
as follows:
if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
On exit, AB is overwritten by values generated during the
reduction to tridiagonal form. If UPLO = 'U', the first
superdiagonal and the diagonal of the tridiagonal matrix T
are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
the diagonal and first subdiagonal of T are returned in the
first two rows of AB.
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD + 1.
W (output) REAL array, dimension (N)
If INFO = 0, the eigenvalues in ascending order.
Z (output) COMPLEX array, dimension (LDZ, N)
If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
eigenvectors of the matrix A, with the i-th column of Z
holding the eigenvector associated with W(i).
If JOBZ = 'N', then Z is not referenced.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1, and if
JOBZ = 'V', LDZ >= max(1,N).
WORK (workspace) COMPLEX array, dimension (N)
RWORK (workspace) REAL array, dimension (max(1,3*N-2))
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: if INFO = i, the algorithm failed to converge; i
off-diagonal elements of an intermediate tridiagonal
form did not converge to zero.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static real c_b11 = 1.f;
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, z_dim1, z_offset, i__1;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer inde;
static real anrm;
static integer imax;
static real rmin, rmax, sigma;
extern logical lsame_(char *, char *);
static integer iinfo;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static logical lower, wantz;
extern doublereal clanhb_(char *, char *, integer *, integer *, complex *,
integer *, real *);
static integer iscale;
extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, complex *, integer *, integer *), chbtrd_(char *, char *, integer *, integer *, complex *,
integer *, real *, real *, complex *, integer *, complex *,
integer *);
extern doublereal slamch_(char *);
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real bignum;
static integer indrwk;
extern /* Subroutine */ int csteqr_(char *, integer *, real *, real *,
complex *, integer *, real *, integer *), ssterf_(integer
*, real *, real *, integer *);
static real smlnum, eps;
#define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1
#define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)]
#define ab_subscr(a_1,a_2) (a_2)*ab_dim1 + a_1
#define ab_ref(a_1,a_2) ab[ab_subscr(a_1,a_2)]
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
--rwork;
/* Function Body */
wantz = lsame_(jobz, "V");
lower = lsame_(uplo, "L");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (lower || lsame_(uplo, "U"))) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*kd < 0) {
*info = -4;
} else if (*ldab < *kd + 1) {
*info = -6;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHBEV ", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (lower) {
i__1 = ab_subscr(1, 1);
w[1] = ab[i__1].r;
} else {
i__1 = ab_subscr(*kd + 1, 1);
w[1] = ab[i__1].r;
}
if (wantz) {
i__1 = z___subscr(1, 1);
z__[i__1].r = 1.f, z__[i__1].i = 0.f;
}
return 0;
}
/* Get machine constants. */
safmin = slamch_("Safe minimum");
eps = slamch_("Precision");
smlnum = safmin / eps;
bignum = 1.f / smlnum;
rmin = sqrt(smlnum);
rmax = sqrt(bignum);
/* Scale matrix to allowable range, if necessary. */
anrm = clanhb_("M", uplo, n, kd, &ab[ab_offset], ldab, &rwork[1]);
iscale = 0;
if (anrm > 0.f && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
if (lower) {
clascl_("B", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab,
info);
} else {
clascl_("Q", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab,
info);
}
}
/* Call CHBTRD to reduce Hermitian band matrix to tridiagonal form. */
inde = 1;
chbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &w[1], &rwork[inde], &
z__[z_offset], ldz, &work[1], &iinfo);
/* For eigenvalues only, call SSTERF. For eigenvectors, call CSTEQR. */
if (! wantz) {
ssterf_(n, &w[1], &rwork[inde], info);
} else {
indrwk = inde + *n;
csteqr_(jobz, n, &w[1], &rwork[inde], &z__[z_offset], ldz, &rwork[
indrwk], info);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (iscale == 1) {
if (*info == 0) {
imax = *n;
} else {
imax = *info - 1;
}
r__1 = 1.f / sigma;
sscal_(&imax, &r__1, &w[1], &c__1);
}
return 0;
/* End of CHBEV */
} /* chbev_ */
/* Subroutine */ int zpbtrf_(char *uplo, integer *n, integer *kd,
doublecomplex *ab, integer *ldab, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZPBTRF computes the Cholesky factorization of a complex Hermitian
positive definite band matrix A.
The factorization has the form
A = U**H * U, if UPLO = 'U', or
A = L * L**H, if UPLO = 'L',
where U is an upper triangular matrix and L is lower triangular.
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.
KD (input) INTEGER
The number of superdiagonals of the matrix A if UPLO = 'U',
or the number of subdiagonals if UPLO = 'L'. KD >= 0.
AB (input/output) COMPLEX*16 array, dimension (LDAB,N)
On entry, the upper or lower triangle of the Hermitian band
matrix A, stored in the first KD+1 rows of the array. The
j-th column of A is stored in the j-th column of the array AB
as follows:
if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
On exit, if INFO = 0, the triangular factor U or L from the
Cholesky factorization A = U**H*U or A = L*L**H of the band
matrix A, in the same storage format as A.
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, the leading minor of order i is not
positive definite, and the factorization could not be
completed.
Further Details
===============
The band storage scheme is illustrated by the following example, when
N = 6, KD = 2, and UPLO = 'U':
On entry: On exit:
* * a13 a24 a35 a46 * * u13 u24 u35 u46
* a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
Similarly, if UPLO = 'L' the format of A is as follows:
On entry: On exit:
a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
a31 a42 a53 a64 * * l31 l42 l53 l64 * *
Array elements marked * are not used by the routine.
Contributed by
Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b1 = {1.,0.};
static integer c__1 = 1;
static integer c_n1 = -1;
static doublereal c_b21 = -1.;
static doublereal c_b22 = 1.;
static integer c__33 = 33;
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublecomplex z__1;
/* Local variables */
static doublecomplex work[1056] /* was [33][32] */;
static integer i__, j;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zherk_(char *, char *, integer *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *);
static integer i2, i3;
extern /* Subroutine */ int ztrsm_(char *, char *, char *, char *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *),
zpbtf2_(char *, integer *, integer *, doublecomplex *, integer *,
integer *);
static integer ib, nb, ii, jj;
extern /* Subroutine */ int zpotf2_(char *, integer *, doublecomplex *,
integer *, integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
#define work_subscr(a_1,a_2) (a_2)*33 + a_1 - 34
#define work_ref(a_1,a_2) work[work_subscr(a_1,a_2)]
#define ab_subscr(a_1,a_2) (a_2)*ab_dim1 + a_1
#define ab_ref(a_1,a_2) ab[ab_subscr(a_1,a_2)]
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
/* Function Body */
*info = 0;
if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kd < 0) {
*info = -3;
} else if (*ldab < *kd + 1) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPBTRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine the block size for this environment */
nb = ilaenv_(&c__1, "ZPBTRF", uplo, n, kd, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
/* The block size must not exceed the semi-bandwidth KD, and must not
exceed the limit set by the size of the local array WORK. */
nb = min(nb,32);
if (nb <= 1 || nb > *kd) {
/* Use unblocked code */
zpbtf2_(uplo, n, kd, &ab[ab_offset], ldab, info);
} else {
/* Use blocked code */
if (lsame_(uplo, "U")) {
/* Compute the Cholesky factorization of a Hermitian band
matrix, given the upper triangle of the matrix in band
storage.
Zero the upper triangle of the work array. */
i__1 = nb;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = work_subscr(i__, j);
work[i__3].r = 0., work[i__3].i = 0.;
/* L10: */
}
/* L20: */
}
/* Process the band matrix one diagonal block at a time. */
i__1 = *n;
i__2 = nb;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__3 = nb, i__4 = *n - i__ + 1;
ib = min(i__3,i__4);
/* Factorize the diagonal block */
i__3 = *ldab - 1;
zpotf2_(uplo, &ib, &ab_ref(*kd + 1, i__), &i__3, &ii);
if (ii != 0) {
*info = i__ + ii - 1;
goto L150;
}
if (i__ + ib <= *n) {
/* Update the relevant part of the trailing submatrix.
If A11 denotes the diagonal block which has just been
factorized, then we need to update the remaining
blocks in the diagram:
A11 A12 A13
A22 A23
A33
The numbers of rows and columns in the partitioning
are IB, I2, I3 respectively. The blocks A12, A22 and
A23 are empty if IB = KD. The upper triangle of A13
lies outside the band.
Computing MIN */
i__3 = *kd - ib, i__4 = *n - i__ - ib + 1;
i2 = min(i__3,i__4);
/* Computing MIN */
i__3 = ib, i__4 = *n - i__ - *kd + 1;
i3 = min(i__3,i__4);
if (i2 > 0) {
/* Update A12 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
ztrsm_("Left", "Upper", "Conjugate transpose", "Non-"
"unit", &ib, &i2, &c_b1, &ab_ref(*kd + 1, i__),
&i__3, &ab_ref(*kd + 1 - ib, i__ + ib), &
i__4);
/* Update A22 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
zherk_("Upper", "Conjugate transpose", &i2, &ib, &
c_b21, &ab_ref(*kd + 1 - ib, i__ + ib), &i__3,
&c_b22, &ab_ref(*kd + 1, i__ + ib), &i__4);
}
if (i3 > 0) {
/* Copy the lower triangle of A13 into the work array. */
i__3 = i3;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = ib;
for (ii = jj; ii <= i__4; ++ii) {
i__5 = work_subscr(ii, jj);
i__6 = ab_subscr(ii - jj + 1, jj + i__ + *kd
- 1);
work[i__5].r = ab[i__6].r, work[i__5].i = ab[
i__6].i;
/* L30: */
}
/* L40: */
}
/* Update A13 (in the work array). */
i__3 = *ldab - 1;
ztrsm_("Left", "Upper", "Conjugate transpose", "Non-"
"unit", &ib, &i3, &c_b1, &ab_ref(*kd + 1, i__),
&i__3, work, &c__33);
/* Update A23 */
if (i2 > 0) {
z__1.r = -1., z__1.i = 0.;
i__3 = *ldab - 1;
i__4 = *ldab - 1;
zgemm_("Conjugate transpose", "No transpose", &i2,
&i3, &ib, &z__1, &ab_ref(*kd + 1 - ib,
i__ + ib), &i__3, work, &c__33, &c_b1, &
ab_ref(ib + 1, i__ + *kd), &i__4);
}
/* Update A33 */
i__3 = *ldab - 1;
zherk_("Upper", "Conjugate transpose", &i3, &ib, &
c_b21, work, &c__33, &c_b22, &ab_ref(*kd + 1,
i__ + *kd), &i__3);
/* Copy the lower triangle of A13 back into place. */
i__3 = i3;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = ib;
for (ii = jj; ii <= i__4; ++ii) {
i__5 = ab_subscr(ii - jj + 1, jj + i__ + *kd
- 1);
i__6 = work_subscr(ii, jj);
ab[i__5].r = work[i__6].r, ab[i__5].i = work[
i__6].i;
/* L50: */
}
/* L60: */
}
}
}
/* L70: */
}
} else {
/* Compute the Cholesky factorization of a Hermitian band
matrix, given the lower triangle of the matrix in band
storage.
Zero the lower triangle of the work array. */
i__2 = nb;
for (j = 1; j <= i__2; ++j) {
i__1 = nb;
for (i__ = j + 1; i__ <= i__1; ++i__) {
i__3 = work_subscr(i__, j);
work[i__3].r = 0., work[i__3].i = 0.;
/* L80: */
}
/* L90: */
}
/* Process the band matrix one diagonal block at a time. */
i__2 = *n;
i__1 = nb;
for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
/* Computing MIN */
i__3 = nb, i__4 = *n - i__ + 1;
ib = min(i__3,i__4);
/* Factorize the diagonal block */
i__3 = *ldab - 1;
zpotf2_(uplo, &ib, &ab_ref(1, i__), &i__3, &ii);
if (ii != 0) {
*info = i__ + ii - 1;
goto L150;
}
if (i__ + ib <= *n) {
/* Update the relevant part of the trailing submatrix.
If A11 denotes the diagonal block which has just been
factorized, then we need to update the remaining
blocks in the diagram:
A11
A21 A22
A31 A32 A33
The numbers of rows and columns in the partitioning
are IB, I2, I3 respectively. The blocks A21, A22 and
A32 are empty if IB = KD. The lower triangle of A31
lies outside the band.
Computing MIN */
i__3 = *kd - ib, i__4 = *n - i__ - ib + 1;
i2 = min(i__3,i__4);
/* Computing MIN */
i__3 = ib, i__4 = *n - i__ - *kd + 1;
i3 = min(i__3,i__4);
if (i2 > 0) {
/* Update A21 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
ztrsm_("Right", "Lower", "Conjugate transpose", "Non"
"-unit", &i2, &ib, &c_b1, &ab_ref(1, i__), &
i__3, &ab_ref(ib + 1, i__), &i__4);
/* Update A22 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
zherk_("Lower", "No transpose", &i2, &ib, &c_b21, &
ab_ref(ib + 1, i__), &i__3, &c_b22, &ab_ref(1,
i__ + ib), &i__4);
}
if (i3 > 0) {
/* Copy the upper triangle of A31 into the work array. */
i__3 = ib;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = min(jj,i3);
for (ii = 1; ii <= i__4; ++ii) {
i__5 = work_subscr(ii, jj);
i__6 = ab_subscr(*kd + 1 - jj + ii, jj + i__
- 1);
work[i__5].r = ab[i__6].r, work[i__5].i = ab[
i__6].i;
/* L100: */
}
/* L110: */
}
/* Update A31 (in the work array). */
i__3 = *ldab - 1;
ztrsm_("Right", "Lower", "Conjugate transpose", "Non"
"-unit", &i3, &ib, &c_b1, &ab_ref(1, i__), &
i__3, work, &c__33);
/* Update A32 */
if (i2 > 0) {
z__1.r = -1., z__1.i = 0.;
i__3 = *ldab - 1;
i__4 = *ldab - 1;
zgemm_("No transpose", "Conjugate transpose", &i3,
&i2, &ib, &z__1, work, &c__33, &ab_ref(
ib + 1, i__), &i__3, &c_b1, &ab_ref(*kd +
1 - ib, i__ + ib), &i__4);
}
/* Update A33 */
i__3 = *ldab - 1;
zherk_("Lower", "No transpose", &i3, &ib, &c_b21,
work, &c__33, &c_b22, &ab_ref(1, i__ + *kd), &
i__3);
/* Copy the upper triangle of A31 back into place. */
i__3 = ib;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = min(jj,i3);
for (ii = 1; ii <= i__4; ++ii) {
i__5 = ab_subscr(*kd + 1 - jj + ii, jj + i__
- 1);
i__6 = work_subscr(ii, jj);
ab[i__5].r = work[i__6].r, ab[i__5].i = work[
i__6].i;
/* L120: */
}
/* L130: */
}
}
}
/* L140: */
}
}
}
return 0;
L150:
return 0;
/* End of ZPBTRF */
} /* zpbtrf_ */
/* Subroutine */ int cgbt05_(char *trans, integer *n, integer *kl, integer *
ku, integer *nrhs, complex *ab, integer *ldab, complex *b, integer *
ldb, complex *x, integer *ldx, complex *xact, integer *ldxact, real *
ferr, real *berr, real *reslts)
{
/* System generated locals */
integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
xact_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1, q__2;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static real diff, axbi;
static integer imax;
static real unfl, ovfl;
static integer i__, j, k;
extern logical lsame_(char *, char *);
static real xnorm;
extern integer icamax_(integer *, complex *, integer *);
extern doublereal slamch_(char *);
static integer nz;
static real errbnd;
static logical notran;
static real eps, tmp;
#define xact_subscr(a_1,a_2) (a_2)*xact_dim1 + a_1
#define xact_ref(a_1,a_2) xact[xact_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define x_subscr(a_1,a_2) (a_2)*x_dim1 + a_1
#define x_ref(a_1,a_2) x[x_subscr(a_1,a_2)]
#define ab_subscr(a_1,a_2) (a_2)*ab_dim1 + a_1
#define ab_ref(a_1,a_2) ab[ab_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
CGBT05 tests the error bounds from iterative refinement for the
computed solution to a system of equations op(A)*X = B, where A is a
general band matrix of order n with kl subdiagonals and ku
superdiagonals and op(A) = A or A**T, depending on TRANS.
RESLTS(1) = test of the error bound
= norm(X - XACT) / ( norm(X) * FERR )
A large value is returned if this ratio is not less than one.
RESLTS(2) = residual from the iterative refinement routine
= the maximum of BERR / ( NZ*EPS + (*) ), where
(*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
and NZ = max. number of nonzeros in any row of A, plus 1
Arguments
=========
TRANS (input) CHARACTER*1
Specifies the form of the system of equations.
= 'N': A * X = B (No transpose)
= 'T': A**T * X = B (Transpose)
= 'C': A**H * X = B (Conjugate transpose = Transpose)
N (input) INTEGER
The number of rows of the matrices X, B, and XACT, and the
order of the matrix A. N >= 0.
KL (input) INTEGER
The number of subdiagonals within the band of A. KL >= 0.
KU (input) INTEGER
The number of superdiagonals within the band of A. KU >= 0.
NRHS (input) INTEGER
The number of columns of the matrices X, B, and XACT.
NRHS >= 0.
AB (input) COMPLEX array, dimension (LDAB,N)
The original band matrix A, stored in rows 1 to KL+KU+1.
The j-th column of A is stored in the j-th column of the
array AB as follows:
AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KL+KU+1.
B (input) COMPLEX array, dimension (LDB,NRHS)
The right hand side vectors for the system of linear
equations.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input) COMPLEX array, dimension (LDX,NRHS)
The computed solution vectors. Each vector is stored as a
column of the matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
XACT (input) COMPLEX array, dimension (LDX,NRHS)
The exact solution vectors. Each vector is stored as a
column of the matrix XACT.
LDXACT (input) INTEGER
The leading dimension of the array XACT. LDXACT >= max(1,N).
FERR (input) REAL array, dimension (NRHS)
The estimated forward error bounds for each solution vector
X. If XTRUE is the true solution, FERR bounds the magnitude
of the largest entry in (X - XTRUE) divided by the magnitude
of the largest entry in X.
BERR (input) REAL array, dimension (NRHS)
The componentwise relative backward error of each solution
vector (i.e., the smallest relative change in any entry of A
or B that makes X an exact solution).
RESLTS (output) REAL array, dimension (2)
The maximum over the NRHS solution vectors of the ratios:
RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
RESLTS(2) = BERR / ( NZ*EPS + (*) )
=====================================================================
Quick exit if N = 0 or NRHS = 0.
Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
xact_dim1 = *ldxact;
xact_offset = 1 + xact_dim1 * 1;
xact -= xact_offset;
--ferr;
--berr;
--reslts;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
reslts[1] = 0.f;
reslts[2] = 0.f;
return 0;
}
eps = slamch_("Epsilon");
unfl = slamch_("Safe minimum");
ovfl = 1.f / unfl;
notran = lsame_(trans, "N");
/* Computing MIN */
i__1 = *kl + *ku + 2, i__2 = *n + 1;
nz = min(i__1,i__2);
/* Test 1: Compute the maximum of
norm(X - XACT) / ( norm(X) * FERR )
over all the vectors X and XACT using the infinity-norm. */
errbnd = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
imax = icamax_(n, &x_ref(1, j), &c__1);
/* Computing MAX */
i__2 = x_subscr(imax, j);
r__3 = (r__1 = x[i__2].r, dabs(r__1)) + (r__2 = r_imag(&x_ref(imax, j)
), dabs(r__2));
xnorm = dmax(r__3,unfl);
diff = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = x_subscr(i__, j);
i__4 = xact_subscr(i__, j);
q__2.r = x[i__3].r - xact[i__4].r, q__2.i = x[i__3].i - xact[i__4]
.i;
q__1.r = q__2.r, q__1.i = q__2.i;
/* Computing MAX */
r__3 = diff, r__4 = (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&
q__1), dabs(r__2));
diff = dmax(r__3,r__4);
/* L10: */
}
if (xnorm > 1.f) {
goto L20;
} else if (diff <= ovfl * xnorm) {
goto L20;
} else {
errbnd = 1.f / eps;
goto L30;
}
L20:
if (diff / xnorm <= ferr[j]) {
/* Computing MAX */
r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
errbnd = dmax(r__1,r__2);
} else {
errbnd = 1.f / eps;
}
L30:
;
}
reslts[1] = errbnd;
/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where
(*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
i__1 = *nrhs;
for (k = 1; k <= i__1; ++k) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, k);
tmp = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(i__,
k)), dabs(r__2));
if (notran) {
/* Computing MAX */
i__3 = i__ - *kl;
/* Computing MIN */
i__5 = i__ + *ku;
i__4 = min(i__5,*n);
for (j = max(i__3,1); j <= i__4; ++j) {
i__3 = ab_subscr(*ku + 1 + i__ - j, j);
i__5 = x_subscr(j, k);
tmp += ((r__1 = ab[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
ab_ref(*ku + 1 + i__ - j, j)), dabs(r__2))) * ((
r__3 = x[i__5].r, dabs(r__3)) + (r__4 = r_imag(&
x_ref(j, k)), dabs(r__4)));
/* L40: */
}
} else {
/* Computing MAX */
i__4 = i__ - *ku;
/* Computing MIN */
i__5 = i__ + *kl;
i__3 = min(i__5,*n);
for (j = max(i__4,1); j <= i__3; ++j) {
i__4 = ab_subscr(*ku + 1 + j - i__, i__);
i__5 = x_subscr(j, k);
tmp += ((r__1 = ab[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
ab_ref(*ku + 1 + j - i__, i__)), dabs(r__2))) * ((
r__3 = x[i__5].r, dabs(r__3)) + (r__4 = r_imag(&
x_ref(j, k)), dabs(r__4)));
/* L50: */
}
}
if (i__ == 1) {
axbi = tmp;
} else {
axbi = dmin(axbi,tmp);
}
/* L60: */
}
/* Computing MAX */
r__1 = axbi, r__2 = nz * unfl;
tmp = berr[k] / (nz * eps + nz * unfl / dmax(r__1,r__2));
if (k == 1) {
reslts[2] = tmp;
} else {
reslts[2] = dmax(reslts[2],tmp);
}
/* L70: */
}
return 0;
/* End of CGBT05 */
} /* cgbt05_ */
/* Subroutine */ int zpbtf2_(char *uplo, integer *n, integer *kd,
doublecomplex *ab, integer *ldab, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
ZPBTF2 computes the Cholesky factorization of a complex Hermitian
positive definite band matrix A.
The factorization has the form
A = U' * U , if UPLO = 'U', or
A = L * L', if UPLO = 'L',
where U is an upper triangular matrix, U' is the conjugate transpose
of U, and L is lower triangular.
This is the unblocked version of the algorithm, calling Level 2 BLAS.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the upper or lower triangular part of the
Hermitian matrix A is stored:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrix A. N >= 0.
KD (input) INTEGER
The number of super-diagonals of the matrix A if UPLO = 'U',
or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
AB (input/output) COMPLEX*16 array, dimension (LDAB,N)
On entry, the upper or lower triangle of the Hermitian band
matrix A, stored in the first KD+1 rows of the array. The
j-th column of A is stored in the j-th column of the array AB
as follows:
if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
On exit, if INFO = 0, the triangular factor U or L from the
Cholesky factorization A = U'*U or A = L*L' of the band
matrix A, in the same storage format as A.
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -k, the k-th argument had an illegal value
> 0: if INFO = k, the leading minor of order k is not
positive definite, and the factorization could not be
completed.
Further Details
===============
The band storage scheme is illustrated by the following example, when
N = 6, KD = 2, and UPLO = 'U':
On entry: On exit:
* * a13 a24 a35 a46 * * u13 u24 u35 u46
* a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
Similarly, if UPLO = 'L' the format of A is as follows:
On entry: On exit:
a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
a31 a42 a53 a64 * * l31 l42 l53 l64 * *
Array elements marked * are not used by the routine.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static doublereal c_b8 = -1.;
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
extern /* Subroutine */ int zher_(char *, integer *, doublereal *,
doublecomplex *, integer *, doublecomplex *, integer *);
static integer j;
extern logical lsame_(char *, char *);
static logical upper;
static integer kn;
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *), zlacgv_(
integer *, doublecomplex *, integer *);
static doublereal ajj;
static integer kld;
#define ab_subscr(a_1,a_2) (a_2)*ab_dim1 + a_1
#define ab_ref(a_1,a_2) ab[ab_subscr(a_1,a_2)]
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kd < 0) {
*info = -3;
} else if (*ldab < *kd + 1) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPBTF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Computing MAX */
i__1 = 1, i__2 = *ldab - 1;
kld = max(i__1,i__2);
if (upper) {
/* Compute the Cholesky factorization A = U'*U. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute U(J,J) and test for non-positive-definiteness. */
i__2 = ab_subscr(*kd + 1, j);
ajj = ab[i__2].r;
if (ajj <= 0.) {
i__2 = ab_subscr(*kd + 1, j);
ab[i__2].r = ajj, ab[i__2].i = 0.;
goto L30;
}
ajj = sqrt(ajj);
i__2 = ab_subscr(*kd + 1, j);
ab[i__2].r = ajj, ab[i__2].i = 0.;
/* Compute elements J+1:J+KN of row J and update the
trailing submatrix within the band.
Computing MIN */
i__2 = *kd, i__3 = *n - j;
kn = min(i__2,i__3);
if (kn > 0) {
d__1 = 1. / ajj;
zdscal_(&kn, &d__1, &ab_ref(*kd, j + 1), &kld);
zlacgv_(&kn, &ab_ref(*kd, j + 1), &kld);
zher_("Upper", &kn, &c_b8, &ab_ref(*kd, j + 1), &kld, &ab_ref(
*kd + 1, j + 1), &kld);
zlacgv_(&kn, &ab_ref(*kd, j + 1), &kld);
}
/* L10: */
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute L(J,J) and test for non-positive-definiteness. */
i__2 = ab_subscr(1, j);
ajj = ab[i__2].r;
if (ajj <= 0.) {
i__2 = ab_subscr(1, j);
ab[i__2].r = ajj, ab[i__2].i = 0.;
goto L30;
}
ajj = sqrt(ajj);
i__2 = ab_subscr(1, j);
ab[i__2].r = ajj, ab[i__2].i = 0.;
/* Compute elements J+1:J+KN of column J and update the
trailing submatrix within the band.
Computing MIN */
i__2 = *kd, i__3 = *n - j;
kn = min(i__2,i__3);
if (kn > 0) {
d__1 = 1. / ajj;
zdscal_(&kn, &d__1, &ab_ref(2, j), &c__1);
zher_("Lower", &kn, &c_b8, &ab_ref(2, j), &c__1, &ab_ref(1, j
+ 1), &kld);
}
/* L20: */
}
}
return 0;
L30:
*info = j;
return 0;
/* End of ZPBTF2 */
} /* zpbtf2_ */
/* Subroutine */ int cgbbrd_(char *vect, integer *m, integer *n, integer *ncc,
integer *kl, integer *ku, complex *ab, integer *ldab, real *d__,
real *e, complex *q, integer *ldq, complex *pt, integer *ldpt,
complex *c__, integer *ldc, 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
=======
CGBBRD reduces a complex general m-by-n band matrix A to real upper
bidiagonal form B by a unitary transformation: Q' * A * P = B.
The routine computes B, and optionally forms Q or P', or computes
Q'*C for a given matrix C.
Arguments
=========
VECT (input) CHARACTER*1
Specifies whether or not the matrices Q and P' are to be
formed.
= 'N': do not form Q or P';
= 'Q': form Q only;
= 'P': form P' only;
= 'B': form both.
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0.
NCC (input) INTEGER
The number of columns of the matrix C. NCC >= 0.
KL (input) INTEGER
The number of subdiagonals of the matrix A. KL >= 0.
KU (input) INTEGER
The number of superdiagonals of the matrix A. KU >= 0.
AB (input/output) COMPLEX array, dimension (LDAB,N)
On entry, the m-by-n band matrix A, stored in rows 1 to
KL+KU+1. The j-th column of A is stored in the j-th column of
the array AB as follows:
AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
On exit, A is overwritten by values generated during the
reduction.
LDAB (input) INTEGER
The leading dimension of the array A. LDAB >= KL+KU+1.
D (output) REAL array, dimension (min(M,N))
The diagonal elements of the bidiagonal matrix B.
E (output) REAL array, dimension (min(M,N)-1)
The superdiagonal elements of the bidiagonal matrix B.
Q (output) COMPLEX array, dimension (LDQ,M)
If VECT = 'Q' or 'B', the m-by-m unitary matrix Q.
If VECT = 'N' or 'P', the array Q is not referenced.
LDQ (input) INTEGER
The leading dimension of the array Q.
LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.
PT (output) COMPLEX array, dimension (LDPT,N)
If VECT = 'P' or 'B', the n-by-n unitary matrix P'.
If VECT = 'N' or 'Q', the array PT is not referenced.
LDPT (input) INTEGER
The leading dimension of the array PT.
LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.
C (input/output) COMPLEX array, dimension (LDC,NCC)
On entry, an m-by-ncc matrix C.
On exit, C is overwritten by Q'*C.
C is not referenced if NCC = 0.
LDC (input) INTEGER
The leading dimension of the array C.
LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.
WORK (workspace) COMPLEX array, dimension (max(M,N))
RWORK (workspace) REAL array, dimension (max(M,N))
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
=====================================================================
Test the input parameters
Parameter adjustments */
/* 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 ab_dim1, ab_offset, c_dim1, c_offset, pt_dim1, pt_offset, q_dim1,
q_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
complex q__1, q__2, q__3;
/* Builtin functions */
void r_cnjg(complex *, complex *);
double c_abs(complex *);
/* Local variables */
static integer inca;
static real abst;
extern /* Subroutine */ int crot_(integer *, complex *, integer *,
complex *, integer *, real *, complex *);
static integer i__, j, l;
static complex t;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
extern logical lsame_(char *, char *);
static logical wantb, wantc;
static integer minmn;
static logical wantq;
static integer j1, j2, kb;
static complex ra;
static real rc;
static integer kk;
static complex rb;
static integer ml, nr, mu;
static complex rs;
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *), clartg_(complex *,
complex *, real *, complex *, complex *), xerbla_(char *, integer
*), clargv_(integer *, complex *, integer *, complex *,
integer *, real *, integer *), clartv_(integer *, complex *,
integer *, complex *, integer *, real *, complex *, integer *);
static integer kb1, ml0;
static logical wantpt;
static integer mu0, klm, kun, nrt, klu1;
#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)]
#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 ab_subscr(a_1,a_2) (a_2)*ab_dim1 + a_1
#define ab_ref(a_1,a_2) ab[ab_subscr(a_1,a_2)]
#define pt_subscr(a_1,a_2) (a_2)*pt_dim1 + a_1
#define pt_ref(a_1,a_2) pt[pt_subscr(a_1,a_2)]
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
--d__;
--e;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
pt_dim1 = *ldpt;
pt_offset = 1 + pt_dim1 * 1;
pt -= pt_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
--work;
--rwork;
/* Function Body */
wantb = lsame_(vect, "B");
wantq = lsame_(vect, "Q") || wantb;
wantpt = lsame_(vect, "P") || wantb;
wantc = *ncc > 0;
klu1 = *kl + *ku + 1;
*info = 0;
if (! wantq && ! wantpt && ! lsame_(vect, "N")) {
*info = -1;
} else if (*m < 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ncc < 0) {
*info = -4;
} else if (*kl < 0) {
*info = -5;
} else if (*ku < 0) {
*info = -6;
} else if (*ldab < klu1) {
*info = -8;
} else if (*ldq < 1 || wantq && *ldq < max(1,*m)) {
*info = -12;
} else if (*ldpt < 1 || wantpt && *ldpt < max(1,*n)) {
*info = -14;
} else if (*ldc < 1 || wantc && *ldc < max(1,*m)) {
*info = -16;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGBBRD", &i__1);
return 0;
}
/* Initialize Q and P' to the unit matrix, if needed */
if (wantq) {
claset_("Full", m, m, &c_b1, &c_b2, &q[q_offset], ldq);
}
if (wantpt) {
claset_("Full", n, n, &c_b1, &c_b2, &pt[pt_offset], ldpt);
}
/* Quick return if possible. */
if (*m == 0 || *n == 0) {
return 0;
}
minmn = min(*m,*n);
if (*kl + *ku > 1) {
/* Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce
first to lower bidiagonal form and then transform to upper
bidiagonal */
if (*ku > 0) {
ml0 = 1;
mu0 = 2;
} else {
ml0 = 2;
mu0 = 1;
}
/* Wherever possible, plane rotations are generated and applied in
vector operations of length NR over the index set J1:J2:KLU1.
The complex sines of the plane rotations are stored in WORK,
and the real cosines in RWORK.
Computing MIN */
i__1 = *m - 1;
klm = min(i__1,*kl);
/* Computing MIN */
i__1 = *n - 1;
kun = min(i__1,*ku);
kb = klm + kun;
kb1 = kb + 1;
inca = kb1 * *ldab;
nr = 0;
j1 = klm + 2;
j2 = 1 - kun;
i__1 = minmn;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Reduce i-th column and i-th row of matrix to bidiagonal form */
ml = klm + 1;
mu = kun + 1;
i__2 = kb;
for (kk = 1; kk <= i__2; ++kk) {
j1 += kb;
j2 += kb;
/* generate plane rotations to annihilate nonzero elements
which have been created below the band */
if (nr > 0) {
clargv_(&nr, &ab_ref(klu1, j1 - klm - 1), &inca, &work[j1]
, &kb1, &rwork[j1], &kb1);
}
/* apply plane rotations from the left */
i__3 = kb;
for (l = 1; l <= i__3; ++l) {
if (j2 - klm + l - 1 > *n) {
nrt = nr - 1;
} else {
nrt = nr;
}
if (nrt > 0) {
clartv_(&nrt, &ab_ref(klu1 - l, j1 - klm + l - 1), &
inca, &ab_ref(klu1 - l + 1, j1 - klm + l - 1),
&inca, &rwork[j1], &work[j1], &kb1);
}
/* L10: */
}
if (ml > ml0) {
if (ml <= *m - i__ + 1) {
/* generate plane rotation to annihilate a(i+ml-1,i)
within the band, and apply rotation from the left */
clartg_(&ab_ref(*ku + ml - 1, i__), &ab_ref(*ku + ml,
i__), &rwork[i__ + ml - 1], &work[i__ + ml -
1], &ra);
i__3 = ab_subscr(*ku + ml - 1, i__);
ab[i__3].r = ra.r, ab[i__3].i = ra.i;
if (i__ < *n) {
/* Computing MIN */
i__4 = *ku + ml - 2, i__5 = *n - i__;
i__3 = min(i__4,i__5);
i__6 = *ldab - 1;
i__7 = *ldab - 1;
crot_(&i__3, &ab_ref(*ku + ml - 2, i__ + 1), &
i__6, &ab_ref(*ku + ml - 1, i__ + 1), &
i__7, &rwork[i__ + ml - 1], &work[i__ +
ml - 1]);
}
}
++nr;
j1 -= kb1;
}
if (wantq) {
/* accumulate product of plane rotations in Q */
i__3 = j2;
i__4 = kb1;
for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4)
{
r_cnjg(&q__1, &work[j]);
crot_(m, &q_ref(1, j - 1), &c__1, &q_ref(1, j), &c__1,
&rwork[j], &q__1);
/* L20: */
}
}
if (wantc) {
/* apply plane rotations to C */
i__4 = j2;
i__3 = kb1;
for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3)
{
crot_(ncc, &c___ref(j - 1, 1), ldc, &c___ref(j, 1),
ldc, &rwork[j], &work[j]);
/* L30: */
}
}
if (j2 + kun > *n) {
/* adjust J2 to keep within the bounds of the matrix */
--nr;
j2 -= kb1;
}
i__3 = j2;
i__4 = kb1;
for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
/* create nonzero element a(j-1,j+ku) above the band
and store it in WORK(n+1:2*n) */
i__5 = j + kun;
i__6 = j;
i__7 = ab_subscr(1, j + kun);
q__1.r = work[i__6].r * ab[i__7].r - work[i__6].i * ab[
i__7].i, q__1.i = work[i__6].r * ab[i__7].i +
work[i__6].i * ab[i__7].r;
work[i__5].r = q__1.r, work[i__5].i = q__1.i;
i__5 = ab_subscr(1, j + kun);
i__6 = j;
i__7 = ab_subscr(1, j + kun);
q__1.r = rwork[i__6] * ab[i__7].r, q__1.i = rwork[i__6] *
ab[i__7].i;
ab[i__5].r = q__1.r, ab[i__5].i = q__1.i;
/* L40: */
}
/* generate plane rotations to annihilate nonzero elements
which have been generated above the band */
if (nr > 0) {
clargv_(&nr, &ab_ref(1, j1 + kun - 1), &inca, &work[j1 +
kun], &kb1, &rwork[j1 + kun], &kb1);
}
/* apply plane rotations from the right */
i__4 = kb;
for (l = 1; l <= i__4; ++l) {
if (j2 + l - 1 > *m) {
nrt = nr - 1;
} else {
nrt = nr;
}
if (nrt > 0) {
clartv_(&nrt, &ab_ref(l + 1, j1 + kun - 1), &inca, &
ab_ref(l, j1 + kun), &inca, &rwork[j1 + kun],
&work[j1 + kun], &kb1);
}
/* L50: */
}
if (ml == ml0 && mu > mu0) {
if (mu <= *n - i__ + 1) {
/* generate plane rotation to annihilate a(i,i+mu-1)
within the band, and apply rotation from the right */
clartg_(&ab_ref(*ku - mu + 3, i__ + mu - 2), &ab_ref(*
ku - mu + 2, i__ + mu - 1), &rwork[i__ + mu -
1], &work[i__ + mu - 1], &ra);
i__4 = ab_subscr(*ku - mu + 3, i__ + mu - 2);
ab[i__4].r = ra.r, ab[i__4].i = ra.i;
/* Computing MIN */
i__3 = *kl + mu - 2, i__5 = *m - i__;
i__4 = min(i__3,i__5);
crot_(&i__4, &ab_ref(*ku - mu + 4, i__ + mu - 2), &
c__1, &ab_ref(*ku - mu + 3, i__ + mu - 1), &
c__1, &rwork[i__ + mu - 1], &work[i__ + mu -
1]);
}
++nr;
j1 -= kb1;
}
if (wantpt) {
/* accumulate product of plane rotations in P' */
i__4 = j2;
i__3 = kb1;
for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3)
{
r_cnjg(&q__1, &work[j + kun]);
crot_(n, &pt_ref(j + kun - 1, 1), ldpt, &pt_ref(j +
kun, 1), ldpt, &rwork[j + kun], &q__1);
/* L60: */
}
}
if (j2 + kb > *m) {
/* adjust J2 to keep within the bounds of the matrix */
--nr;
j2 -= kb1;
}
i__3 = j2;
i__4 = kb1;
for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
/* create nonzero element a(j+kl+ku,j+ku-1) below the
band and store it in WORK(1:n) */
i__5 = j + kb;
i__6 = j + kun;
i__7 = ab_subscr(klu1, j + kun);
q__1.r = work[i__6].r * ab[i__7].r - work[i__6].i * ab[
i__7].i, q__1.i = work[i__6].r * ab[i__7].i +
work[i__6].i * ab[i__7].r;
work[i__5].r = q__1.r, work[i__5].i = q__1.i;
i__5 = ab_subscr(klu1, j + kun);
i__6 = j + kun;
i__7 = ab_subscr(klu1, j + kun);
q__1.r = rwork[i__6] * ab[i__7].r, q__1.i = rwork[i__6] *
ab[i__7].i;
ab[i__5].r = q__1.r, ab[i__5].i = q__1.i;
/* L70: */
}
if (ml > ml0) {
--ml;
} else {
--mu;
}
/* L80: */
}
/* L90: */
}
}
if (*ku == 0 && *kl > 0) {
/* A has been reduced to complex lower bidiagonal form
Transform lower bidiagonal form to upper bidiagonal by applying
plane rotations from the left, overwriting superdiagonal
elements on subdiagonal elements
Computing MIN */
i__2 = *m - 1;
i__1 = min(i__2,*n);
for (i__ = 1; i__ <= i__1; ++i__) {
clartg_(&ab_ref(1, i__), &ab_ref(2, i__), &rc, &rs, &ra);
i__2 = ab_subscr(1, i__);
ab[i__2].r = ra.r, ab[i__2].i = ra.i;
if (i__ < *n) {
i__2 = ab_subscr(2, i__);
i__4 = ab_subscr(1, i__ + 1);
q__1.r = rs.r * ab[i__4].r - rs.i * ab[i__4].i, q__1.i = rs.r
* ab[i__4].i + rs.i * ab[i__4].r;
ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
i__2 = ab_subscr(1, i__ + 1);
i__4 = ab_subscr(1, i__ + 1);
q__1.r = rc * ab[i__4].r, q__1.i = rc * ab[i__4].i;
ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
}
if (wantq) {
r_cnjg(&q__1, &rs);
crot_(m, &q_ref(1, i__), &c__1, &q_ref(1, i__ + 1), &c__1, &
rc, &q__1);
}
if (wantc) {
crot_(ncc, &c___ref(i__, 1), ldc, &c___ref(i__ + 1, 1), ldc, &
rc, &rs);
}
/* L100: */
}
} else {
/* A has been reduced to complex upper bidiagonal form or is
diagonal */
if (*ku > 0 && *m < *n) {
/* Annihilate a(m,m+1) by applying plane rotations from the
right */
i__1 = ab_subscr(*ku, *m + 1);
rb.r = ab[i__1].r, rb.i = ab[i__1].i;
for (i__ = *m; i__ >= 1; --i__) {
clartg_(&ab_ref(*ku + 1, i__), &rb, &rc, &rs, &ra);
i__1 = ab_subscr(*ku + 1, i__);
ab[i__1].r = ra.r, ab[i__1].i = ra.i;
if (i__ > 1) {
r_cnjg(&q__3, &rs);
q__2.r = -q__3.r, q__2.i = -q__3.i;
i__1 = ab_subscr(*ku, i__);
q__1.r = q__2.r * ab[i__1].r - q__2.i * ab[i__1].i,
q__1.i = q__2.r * ab[i__1].i + q__2.i * ab[i__1]
.r;
rb.r = q__1.r, rb.i = q__1.i;
i__1 = ab_subscr(*ku, i__);
i__2 = ab_subscr(*ku, i__);
q__1.r = rc * ab[i__2].r, q__1.i = rc * ab[i__2].i;
ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
}
if (wantpt) {
r_cnjg(&q__1, &rs);
crot_(n, &pt_ref(i__, 1), ldpt, &pt_ref(*m + 1, 1), ldpt,
&rc, &q__1);
}
/* L110: */
}
}
}
/* Make diagonal and superdiagonal elements real, storing them in D
and E */
i__1 = ab_subscr(*ku + 1, 1);
t.r = ab[i__1].r, t.i = ab[i__1].i;
i__1 = minmn;
for (i__ = 1; i__ <= i__1; ++i__) {
abst = c_abs(&t);
d__[i__] = abst;
if (abst != 0.f) {
q__1.r = t.r / abst, q__1.i = t.i / abst;
t.r = q__1.r, t.i = q__1.i;
} else {
t.r = 1.f, t.i = 0.f;
}
if (wantq) {
cscal_(m, &t, &q_ref(1, i__), &c__1);
}
if (wantc) {
r_cnjg(&q__1, &t);
cscal_(ncc, &q__1, &c___ref(i__, 1), ldc);
}
if (i__ < minmn) {
if (*ku == 0 && *kl == 0) {
e[i__] = 0.f;
i__2 = ab_subscr(1, i__ + 1);
t.r = ab[i__2].r, t.i = ab[i__2].i;
} else {
if (*ku == 0) {
i__2 = ab_subscr(2, i__);
r_cnjg(&q__2, &t);
q__1.r = ab[i__2].r * q__2.r - ab[i__2].i * q__2.i,
q__1.i = ab[i__2].r * q__2.i + ab[i__2].i *
q__2.r;
t.r = q__1.r, t.i = q__1.i;
} else {
i__2 = ab_subscr(*ku, i__ + 1);
r_cnjg(&q__2, &t);
q__1.r = ab[i__2].r * q__2.r - ab[i__2].i * q__2.i,
q__1.i = ab[i__2].r * q__2.i + ab[i__2].i *
q__2.r;
t.r = q__1.r, t.i = q__1.i;
}
abst = c_abs(&t);
e[i__] = abst;
if (abst != 0.f) {
q__1.r = t.r / abst, q__1.i = t.i / abst;
t.r = q__1.r, t.i = q__1.i;
} else {
t.r = 1.f, t.i = 0.f;
}
if (wantpt) {
cscal_(n, &t, &pt_ref(i__ + 1, 1), ldpt);
}
i__2 = ab_subscr(*ku + 1, i__ + 1);
r_cnjg(&q__2, &t);
q__1.r = ab[i__2].r * q__2.r - ab[i__2].i * q__2.i, q__1.i =
ab[i__2].r * q__2.i + ab[i__2].i * q__2.r;
t.r = q__1.r, t.i = q__1.i;
}
}
/* L120: */
}
return 0;
/* End of CGBBRD */
} /* cgbbrd_ */
/* Subroutine */ int claqsb_(char *uplo, integer *n, integer *kd, complex *ab,
integer *ldab, real *s, real *scond, real *amax, char *equed)
{
/* -- 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
=======
CLAQSB equilibrates a symmetric band matrix A using the scaling
factors in the vector S.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the upper or lower triangular part of the
symmetric matrix A is stored.
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrix A. N >= 0.
KD (input) INTEGER
The number of super-diagonals of the matrix A if UPLO = 'U',
or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
AB (input/output) COMPLEX array, dimension (LDAB,N)
On entry, the upper or lower triangle of the symmetric band
matrix A, stored in the first KD+1 rows of the array. The
j-th column of A is stored in the j-th column of the array AB
as follows:
if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
On exit, if INFO = 0, the triangular factor U or L from the
Cholesky factorization A = U'*U or A = L*L' of the band
matrix A, in the same storage format as A.
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
S (output) REAL array, dimension (N)
The scale factors for A.
SCOND (input) REAL
Ratio of the smallest S(i) to the largest S(i).
AMAX (input) REAL
Absolute value of largest matrix entry.
EQUED (output) CHARACTER*1
Specifies whether or not equilibration was done.
= 'N': No equilibration.
= 'Y': Equilibration was done, i.e., A has been replaced by
diag(S) * A * diag(S).
Internal Parameters
===================
THRESH is a threshold value used to decide if scaling should be done
based on the ratio of the scaling factors. If SCOND < THRESH,
scaling is done.
LARGE and SMALL are threshold values used to decide if scaling should
be done based on the absolute size of the largest matrix element.
If AMAX > LARGE or AMAX < SMALL, scaling is done.
=====================================================================
Quick return if possible
Parameter adjustments */
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
real r__1;
complex q__1;
/* Local variables */
static integer i__, j;
static real large;
extern logical lsame_(char *, char *);
static real small, cj;
extern doublereal slamch_(char *);
#define ab_subscr(a_1,a_2) (a_2)*ab_dim1 + a_1
#define ab_ref(a_1,a_2) ab[ab_subscr(a_1,a_2)]
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
--s;
/* Function Body */
if (*n <= 0) {
*(unsigned char *)equed = 'N';
return 0;
}
/* Initialize LARGE and SMALL. */
small = slamch_("Safe minimum") / slamch_("Precision");
large = 1.f / small;
if (*scond >= .1f && *amax >= small && *amax <= large) {
/* No equilibration */
*(unsigned char *)equed = 'N';
} else {
/* Replace A by diag(S) * A * diag(S). */
if (lsame_(uplo, "U")) {
/* Upper triangle of A is stored in band format. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
cj = s[j];
/* Computing MAX */
i__2 = 1, i__3 = j - *kd;
i__4 = j;
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
i__2 = ab_subscr(*kd + 1 + i__ - j, j);
r__1 = cj * s[i__];
i__3 = ab_subscr(*kd + 1 + i__ - j, j);
q__1.r = r__1 * ab[i__3].r, q__1.i = r__1 * ab[i__3].i;
ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
/* L10: */
}
/* L20: */
}
} else {
/* Lower triangle of A is stored. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
cj = s[j];
/* Computing MIN */
i__2 = *n, i__3 = j + *kd;
i__4 = min(i__2,i__3);
for (i__ = j; i__ <= i__4; ++i__) {
i__2 = ab_subscr(i__ + 1 - j, j);
r__1 = cj * s[i__];
i__3 = ab_subscr(i__ + 1 - j, j);
q__1.r = r__1 * ab[i__3].r, q__1.i = r__1 * ab[i__3].i;
ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
/* L30: */
}
/* L40: */
}
}
*(unsigned char *)equed = 'Y';
}
return 0;
/* End of CLAQSB */
} /* claqsb_ */
/* Subroutine */ int zlattb_(integer *imat, char *uplo, char *trans, char *
diag, integer *iseed, integer *n, integer *kd, doublecomplex *ab,
integer *ldab, doublecomplex *b, doublecomplex *work, doublereal *
rwork, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double sqrt(doublereal);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
double pow_dd(doublereal *, doublereal *), z_abs(doublecomplex *);
/* Local variables */
static doublereal sfac;
static integer ioff, mode, lenj;
static char path[3], dist[1];
static doublereal unfl, rexp;
static char type__[1];
static doublereal texp;
static doublecomplex star1, plus1, plus2;
static integer i__, j;
static doublereal bscal;
extern logical lsame_(char *, char *);
static doublereal tscal, anorm, bnorm, tleft;
static logical upper;
static doublereal tnorm;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *), zlatb4_(char *, integer *,
integer *, integer *, char *, integer *, integer *, doublereal *,
integer *, doublereal *, char *),
dlabad_(doublereal *, doublereal *);
static integer kl;
extern doublereal dlamch_(char *);
static integer ku, iy;
extern doublereal dlarnd_(integer *, integer *);
static char packit[1];
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *);
static doublereal bignum, cndnum;
extern /* Subroutine */ int dlarnv_(integer *, integer *, integer *,
doublereal *);
extern integer izamax_(integer *, doublecomplex *, integer *);
extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
integer *);
static integer jcount;
extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublecomplex *, integer *,
doublecomplex *, integer *);
static doublereal smlnum;
extern /* Subroutine */ int zlarnv_(integer *, integer *, integer *,
doublecomplex *);
static doublereal ulp;
#define ab_subscr(a_1,a_2) (a_2)*ab_dim1 + a_1
#define ab_ref(a_1,a_2) ab[ab_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZLATTB generates a triangular test matrix in 2-dimensional storage.
IMAT and UPLO uniquely specify the properties of the test matrix,
which is returned in the array A.
Arguments
=========
IMAT (input) INTEGER
An integer key describing which matrix to generate for this
path.
UPLO (input) CHARACTER*1
Specifies whether the matrix A will be upper or lower
triangular.
= 'U': Upper triangular
= 'L': Lower triangular
TRANS (input) CHARACTER*1
Specifies whether the matrix or its transpose will be used.
= 'N': No transpose
= 'T': Transpose
= 'C': Conjugate transpose (= transpose)
DIAG (output) CHARACTER*1
Specifies whether or not the matrix A is unit triangular.
= 'N': Non-unit triangular
= 'U': Unit triangular
ISEED (input/output) INTEGER array, dimension (4)
The seed vector for the random number generator (used in
ZLATMS). Modified on exit.
N (input) INTEGER
The order of the matrix to be generated.
KD (input) INTEGER
The number of superdiagonals or subdiagonals of the banded
triangular matrix A. KD >= 0.
AB (output) COMPLEX*16 array, dimension (LDAB,N)
The upper or lower triangular banded matrix A, stored in the
first KD+1 rows of AB. Let j be a column of A, 1<=j<=n.
If UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j.
If UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
B (workspace) COMPLEX*16 array, dimension (N)
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
=====================================================================
Parameter adjustments */
--iseed;
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
--b;
--work;
--rwork;
/* Function Body */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "TB", (ftnlen)2, (ftnlen)2);
unfl = dlamch_("Safe minimum");
ulp = dlamch_("Epsilon") * dlamch_("Base");
smlnum = unfl;
bignum = (1. - ulp) / smlnum;
dlabad_(&smlnum, &bignum);
if (*imat >= 6 && *imat <= 9 || *imat == 17) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
*info = 0;
/* Quick return if N.LE.0. */
if (*n <= 0) {
return 0;
}
/* Call ZLATB4 to set parameters for CLATMS. */
upper = lsame_(uplo, "U");
if (upper) {
zlatb4_(path, imat, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
dist);
ku = *kd;
/* Computing MAX */
i__1 = 0, i__2 = *kd - *n + 1;
ioff = max(i__1,i__2) + 1;
kl = 0;
*(unsigned char *)packit = 'Q';
} else {
i__1 = -(*imat);
zlatb4_(path, &i__1, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
dist);
kl = *kd;
ioff = 1;
ku = 0;
*(unsigned char *)packit = 'B';
}
/* IMAT <= 5: Non-unit triangular matrix */
if (*imat <= 5) {
zlatms_(n, n, dist, &iseed[1], type__, &rwork[1], &mode, &cndnum, &
anorm, &kl, &ku, packit, &ab_ref(ioff, 1), ldab, &work[1],
info);
/* IMAT > 5: Unit triangular matrix
The diagonal is deliberately set to something other than 1.
IMAT = 6: Matrix is the identity */
} else if (*imat == 6) {
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = 1, i__3 = *kd + 2 - j;
i__4 = *kd;
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
i__2 = ab_subscr(i__, j);
ab[i__2].r = 0., ab[i__2].i = 0.;
/* L10: */
}
i__4 = ab_subscr(*kd + 1, j);
ab[i__4].r = (doublereal) j, ab[i__4].i = 0.;
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__4 = ab_subscr(1, j);
ab[i__4].r = (doublereal) j, ab[i__4].i = 0.;
/* Computing MIN */
i__2 = *kd + 1, i__3 = *n - j + 1;
i__4 = min(i__2,i__3);
for (i__ = 2; i__ <= i__4; ++i__) {
i__2 = ab_subscr(i__, j);
ab[i__2].r = 0., ab[i__2].i = 0.;
/* L30: */
}
/* L40: */
}
}
/* IMAT > 6: Non-trivial unit triangular matrix
A unit triangular matrix T with condition CNDNUM is formed.
In this version, T only has bandwidth 2, the rest of it is zero. */
} else if (*imat <= 9) {
tnorm = sqrt(cndnum);
/* Initialize AB to zero. */
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__4 = 1, i__2 = *kd + 2 - j;
i__3 = *kd;
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
i__4 = ab_subscr(i__, j);
ab[i__4].r = 0., ab[i__4].i = 0.;
/* L50: */
}
i__3 = ab_subscr(*kd + 1, j);
d__1 = (doublereal) j;
ab[i__3].r = d__1, ab[i__3].i = 0.;
/* L60: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__4 = *kd + 1, i__2 = *n - j + 1;
i__3 = min(i__4,i__2);
for (i__ = 2; i__ <= i__3; ++i__) {
i__4 = ab_subscr(i__, j);
ab[i__4].r = 0., ab[i__4].i = 0.;
/* L70: */
}
i__3 = ab_subscr(1, j);
d__1 = (doublereal) j;
ab[i__3].r = d__1, ab[i__3].i = 0.;
/* L80: */
}
}
/* Special case: T is tridiagonal. Set every other offdiagonal
so that the matrix has norm TNORM+1. */
if (*kd == 1) {
if (upper) {
i__1 = ab_subscr(1, 2);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = tnorm * z__2.r, z__1.i = tnorm * z__2.i;
ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
lenj = (*n - 3) / 2;
zlarnv_(&c__2, &iseed[1], &lenj, &work[1]);
i__1 = lenj;
for (j = 1; j <= i__1; ++j) {
i__3 = ab_subscr(1, j + 1 << 1);
i__4 = j;
z__1.r = tnorm * work[i__4].r, z__1.i = tnorm * work[i__4]
.i;
ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
/* L90: */
}
} else {
i__1 = ab_subscr(2, 1);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = tnorm * z__2.r, z__1.i = tnorm * z__2.i;
ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
lenj = (*n - 3) / 2;
zlarnv_(&c__2, &iseed[1], &lenj, &work[1]);
i__1 = lenj;
for (j = 1; j <= i__1; ++j) {
i__3 = ab_subscr(2, (j << 1) + 1);
i__4 = j;
z__1.r = tnorm * work[i__4].r, z__1.i = tnorm * work[i__4]
.i;
ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
/* L100: */
}
}
} else if (*kd > 1) {
/* Form a unit triangular matrix T with condition CNDNUM. T is
given by
| 1 + * |
| 1 + |
T = | 1 + * |
| 1 + |
| 1 + * |
| 1 + |
| . . . |
Each element marked with a '*' is formed by taking the product
of the adjacent elements marked with '+'. The '*'s can be
chosen freely, and the '+'s are chosen so that the inverse of
T will have elements of the same magnitude as T.
The two offdiagonals of T are stored in WORK. */
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = tnorm * z__2.r, z__1.i = tnorm * z__2.i;
star1.r = z__1.r, star1.i = z__1.i;
sfac = sqrt(tnorm);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = sfac * z__2.r, z__1.i = sfac * z__2.i;
plus1.r = z__1.r, plus1.i = z__1.i;
i__1 = *n;
for (j = 1; j <= i__1; j += 2) {
z_div(&z__1, &star1, &plus1);
plus2.r = z__1.r, plus2.i = z__1.i;
i__3 = j;
work[i__3].r = plus1.r, work[i__3].i = plus1.i;
i__3 = *n + j;
work[i__3].r = star1.r, work[i__3].i = star1.i;
if (j + 1 <= *n) {
i__3 = j + 1;
work[i__3].r = plus2.r, work[i__3].i = plus2.i;
i__3 = *n + j + 1;
work[i__3].r = 0., work[i__3].i = 0.;
z_div(&z__1, &star1, &plus2);
plus1.r = z__1.r, plus1.i = z__1.i;
/* Generate a new *-value with norm between sqrt(TNORM)
and TNORM. */
rexp = dlarnd_(&c__2, &iseed[1]);
if (rexp < 0.) {
d__2 = 1. - rexp;
d__1 = -pow_dd(&sfac, &d__2);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
star1.r = z__1.r, star1.i = z__1.i;
} else {
d__2 = rexp + 1.;
d__1 = pow_dd(&sfac, &d__2);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
star1.r = z__1.r, star1.i = z__1.i;
}
}
/* L110: */
}
/* Copy the tridiagonal T to AB. */
if (upper) {
i__1 = *n - 1;
zcopy_(&i__1, &work[1], &c__1, &ab_ref(*kd, 2), ldab);
i__1 = *n - 2;
zcopy_(&i__1, &work[*n + 1], &c__1, &ab_ref(*kd - 1, 3), ldab)
;
} else {
i__1 = *n - 1;
zcopy_(&i__1, &work[1], &c__1, &ab_ref(2, 1), ldab);
i__1 = *n - 2;
zcopy_(&i__1, &work[*n + 1], &c__1, &ab_ref(3, 1), ldab);
}
}
/* IMAT > 9: Pathological test cases. These triangular matrices
are badly scaled or badly conditioned, so when used in solving a
triangular system they may cause overflow in the solution vector. */
} else if (*imat == 10) {
/* Type 10: Generate a triangular matrix with elements between
-1 and 1. Give the diagonal norm 2 to make it well-conditioned.
Make the right hand side large so that it requires scaling. */
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = j - 1;
lenj = min(i__3,*kd);
zlarnv_(&c__4, &iseed[1], &lenj, &ab_ref(*kd + 1 - lenj, j));
i__3 = ab_subscr(*kd + 1, j);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
/* L120: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *n - j;
lenj = min(i__3,*kd);
if (lenj > 0) {
zlarnv_(&c__4, &iseed[1], &lenj, &ab_ref(2, j));
}
i__3 = ab_subscr(1, j);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
/* L130: */
}
}
/* Set the right hand side so that the largest value is BIGNUM. */
zlarnv_(&c__2, &iseed[1], n, &b[1]);
iy = izamax_(n, &b[1], &c__1);
bnorm = z_abs(&b[iy]);
bscal = bignum / max(1.,bnorm);
zdscal_(n, &bscal, &b[1], &c__1);
} else if (*imat == 11) {
/* Type 11: Make the first diagonal element in the solve small to
cause immediate overflow when dividing by T(j,j).
In type 11, the offdiagonal elements are small (CNORM(j) < 1). */
zlarnv_(&c__2, &iseed[1], n, &b[1]);
tscal = 1. / (doublereal) (*kd + 1);
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = j - 1;
lenj = min(i__3,*kd);
if (lenj > 0) {
zlarnv_(&c__4, &iseed[1], &lenj, &ab_ref(*kd + 2 - lenj,
j));
zdscal_(&lenj, &tscal, &ab_ref(*kd + 2 - lenj, j), &c__1);
}
i__3 = ab_subscr(*kd + 1, j);
zlarnd_(&z__1, &c__5, &iseed[1]);
ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
/* L140: */
}
i__1 = ab_subscr(*kd + 1, *n);
i__3 = ab_subscr(*kd + 1, *n);
z__1.r = smlnum * ab[i__3].r, z__1.i = smlnum * ab[i__3].i;
ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *n - j;
lenj = min(i__3,*kd);
if (lenj > 0) {
zlarnv_(&c__4, &iseed[1], &lenj, &ab_ref(2, j));
zdscal_(&lenj, &tscal, &ab_ref(2, j), &c__1);
}
i__3 = ab_subscr(1, j);
zlarnd_(&z__1, &c__5, &iseed[1]);
ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
/* L150: */
}
i__1 = ab_subscr(1, 1);
i__3 = ab_subscr(1, 1);
z__1.r = smlnum * ab[i__3].r, z__1.i = smlnum * ab[i__3].i;
ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
}
} else if (*imat == 12) {
/* Type 12: Make the first diagonal element in the solve small to
cause immediate overflow when dividing by T(j,j).
In type 12, the offdiagonal elements are O(1) (CNORM(j) > 1). */
zlarnv_(&c__2, &iseed[1], n, &b[1]);
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = j - 1;
lenj = min(i__3,*kd);
if (lenj > 0) {
zlarnv_(&c__4, &iseed[1], &lenj, &ab_ref(*kd + 2 - lenj,
j));
}
i__3 = ab_subscr(*kd + 1, j);
zlarnd_(&z__1, &c__5, &iseed[1]);
ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
/* L160: */
}
i__1 = ab_subscr(*kd + 1, *n);
i__3 = ab_subscr(*kd + 1, *n);
z__1.r = smlnum * ab[i__3].r, z__1.i = smlnum * ab[i__3].i;
ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *n - j;
lenj = min(i__3,*kd);
if (lenj > 0) {
zlarnv_(&c__4, &iseed[1], &lenj, &ab_ref(2, j));
}
i__3 = ab_subscr(1, j);
zlarnd_(&z__1, &c__5, &iseed[1]);
ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
/* L170: */
}
i__1 = ab_subscr(1, 1);
i__3 = ab_subscr(1, 1);
z__1.r = smlnum * ab[i__3].r, z__1.i = smlnum * ab[i__3].i;
ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
}
} else if (*imat == 13) {
/* Type 13: T is diagonal with small numbers on the diagonal to
make the growth factor underflow, but a small right hand side
chosen so that the solution does not overflow. */
if (upper) {
jcount = 1;
for (j = *n; j >= 1; --j) {
/* Computing MAX */
i__1 = 1, i__3 = *kd + 1 - (j - 1);
i__4 = *kd;
for (i__ = max(i__1,i__3); i__ <= i__4; ++i__) {
i__1 = ab_subscr(i__, j);
ab[i__1].r = 0., ab[i__1].i = 0.;
/* L180: */
}
if (jcount <= 2) {
i__4 = ab_subscr(*kd + 1, j);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
ab[i__4].r = z__1.r, ab[i__4].i = z__1.i;
} else {
i__4 = ab_subscr(*kd + 1, j);
zlarnd_(&z__1, &c__5, &iseed[1]);
ab[i__4].r = z__1.r, ab[i__4].i = z__1.i;
}
++jcount;
if (jcount > 4) {
jcount = 1;
}
/* L190: */
}
} else {
jcount = 1;
i__4 = *n;
for (j = 1; j <= i__4; ++j) {
/* Computing MIN */
i__3 = *n - j + 1, i__2 = *kd + 1;
i__1 = min(i__3,i__2);
for (i__ = 2; i__ <= i__1; ++i__) {
i__3 = ab_subscr(i__, j);
ab[i__3].r = 0., ab[i__3].i = 0.;
/* L200: */
}
if (jcount <= 2) {
i__1 = ab_subscr(1, j);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
} else {
i__1 = ab_subscr(1, j);
zlarnd_(&z__1, &c__5, &iseed[1]);
ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
}
++jcount;
if (jcount > 4) {
jcount = 1;
}
/* L210: */
}
}
/* Set the right hand side alternately zero and small. */
if (upper) {
b[1].r = 0., b[1].i = 0.;
for (i__ = *n; i__ >= 2; i__ += -2) {
i__4 = i__;
b[i__4].r = 0., b[i__4].i = 0.;
i__4 = i__ - 1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
b[i__4].r = z__1.r, b[i__4].i = z__1.i;
/* L220: */
}
} else {
i__4 = *n;
b[i__4].r = 0., b[i__4].i = 0.;
i__4 = *n - 1;
for (i__ = 1; i__ <= i__4; i__ += 2) {
i__1 = i__;
b[i__1].r = 0., b[i__1].i = 0.;
i__1 = i__ + 1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
b[i__1].r = z__1.r, b[i__1].i = z__1.i;
/* L230: */
}
}
} else if (*imat == 14) {
/* Type 14: Make the diagonal elements small to cause gradual
overflow when dividing by T(j,j). To control the amount of
scaling needed, the matrix is bidiagonal. */
texp = 1. / (doublereal) (*kd + 1);
tscal = pow_dd(&smlnum, &texp);
zlarnv_(&c__4, &iseed[1], n, &b[1]);
if (upper) {
i__4 = *n;
for (j = 1; j <= i__4; ++j) {
/* Computing MAX */
i__1 = 1, i__3 = *kd + 2 - j;
i__2 = *kd;
for (i__ = max(i__1,i__3); i__ <= i__2; ++i__) {
i__1 = ab_subscr(i__, j);
ab[i__1].r = 0., ab[i__1].i = 0.;
/* L240: */
}
if (j > 1 && *kd > 0) {
i__2 = ab_subscr(*kd, j);
ab[i__2].r = -1., ab[i__2].i = -1.;
}
i__2 = ab_subscr(*kd + 1, j);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
/* L250: */
}
i__4 = *n;
b[i__4].r = 1., b[i__4].i = 1.;
} else {
i__4 = *n;
for (j = 1; j <= i__4; ++j) {
/* Computing MIN */
i__1 = *n - j + 1, i__3 = *kd + 1;
i__2 = min(i__1,i__3);
for (i__ = 3; i__ <= i__2; ++i__) {
i__1 = ab_subscr(i__, j);
ab[i__1].r = 0., ab[i__1].i = 0.;
/* L260: */
}
if (j < *n && *kd > 0) {
i__2 = ab_subscr(2, j);
ab[i__2].r = -1., ab[i__2].i = -1.;
}
i__2 = ab_subscr(1, j);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
/* L270: */
}
b[1].r = 1., b[1].i = 1.;
}
} else if (*imat == 15) {
/* Type 15: One zero diagonal element. */
iy = *n / 2 + 1;
if (upper) {
i__4 = *n;
for (j = 1; j <= i__4; ++j) {
/* Computing MIN */
i__2 = j, i__1 = *kd + 1;
lenj = min(i__2,i__1);
zlarnv_(&c__4, &iseed[1], &lenj, &ab_ref(*kd + 2 - lenj, j));
if (j != iy) {
i__2 = ab_subscr(*kd + 1, j);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
} else {
i__2 = ab_subscr(*kd + 1, j);
ab[i__2].r = 0., ab[i__2].i = 0.;
}
/* L280: */
}
} else {
i__4 = *n;
for (j = 1; j <= i__4; ++j) {
/* Computing MIN */
i__2 = *n - j + 1, i__1 = *kd + 1;
lenj = min(i__2,i__1);
zlarnv_(&c__4, &iseed[1], &lenj, &ab_ref(1, j));
if (j != iy) {
i__2 = ab_subscr(1, j);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
} else {
i__2 = ab_subscr(1, j);
ab[i__2].r = 0., ab[i__2].i = 0.;
}
/* L290: */
}
}
zlarnv_(&c__2, &iseed[1], n, &b[1]);
zdscal_(n, &c_b91, &b[1], &c__1);
} else if (*imat == 16) {
/* Type 16: Make the offdiagonal elements large to cause overflow
when adding a column of T. In the non-transposed case, the
matrix is constructed to cause overflow when adding a column in
every other step. */
tscal = unfl / ulp;
tscal = (1. - ulp) / tscal;
i__4 = *n;
for (j = 1; j <= i__4; ++j) {
i__2 = *kd + 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__1 = ab_subscr(i__, j);
ab[i__1].r = 0., ab[i__1].i = 0.;
/* L300: */
}
/* L310: */
}
texp = 1.;
if (*kd > 0) {
if (upper) {
i__4 = -(*kd);
for (j = *n; i__4 < 0 ? j >= 1 : j <= 1; j += i__4) {
/* Computing MAX */
i__1 = 1, i__3 = j - *kd + 1;
i__2 = max(i__1,i__3);
for (i__ = j; i__ >= i__2; i__ += -2) {
i__1 = ab_subscr(j - i__ + 1, i__);
d__1 = -tscal / (doublereal) (*kd + 2);
ab[i__1].r = d__1, ab[i__1].i = 0.;
i__1 = ab_subscr(*kd + 1, i__);
ab[i__1].r = 1., ab[i__1].i = 0.;
i__1 = i__;
d__1 = texp * (1. - ulp);
b[i__1].r = d__1, b[i__1].i = 0.;
/* Computing MAX */
i__1 = 1, i__3 = j - *kd + 1;
if (i__ > max(i__1,i__3)) {
i__1 = ab_subscr(j - i__ + 2, i__ - 1);
d__1 = -(tscal / (doublereal) (*kd + 2)) / (
doublereal) (*kd + 3);
ab[i__1].r = d__1, ab[i__1].i = 0.;
i__1 = ab_subscr(*kd + 1, i__ - 1);
ab[i__1].r = 1., ab[i__1].i = 0.;
i__1 = i__ - 1;
d__1 = texp * (doublereal) ((*kd + 1) * (*kd + 1)
+ *kd);
b[i__1].r = d__1, b[i__1].i = 0.;
}
texp *= 2.;
/* L320: */
}
/* Computing MAX */
i__1 = 1, i__3 = j - *kd + 1;
i__2 = max(i__1,i__3);
d__1 = (doublereal) (*kd + 2) / (doublereal) (*kd + 3) *
tscal;
b[i__2].r = d__1, b[i__2].i = 0.;
/* L330: */
}
} else {
i__4 = *n;
i__2 = *kd;
for (j = 1; i__2 < 0 ? j >= i__4 : j <= i__4; j += i__2) {
texp = 1.;
/* Computing MIN */
i__1 = *kd + 1, i__3 = *n - j + 1;
lenj = min(i__1,i__3);
/* Computing MIN */
i__3 = *n, i__5 = j + *kd - 1;
i__1 = min(i__3,i__5);
for (i__ = j; i__ <= i__1; i__ += 2) {
i__3 = ab_subscr(lenj - (i__ - j), j);
d__1 = -tscal / (doublereal) (*kd + 2);
ab[i__3].r = d__1, ab[i__3].i = 0.;
i__3 = ab_subscr(1, j);
ab[i__3].r = 1., ab[i__3].i = 0.;
i__3 = j;
d__1 = texp * (1. - ulp);
b[i__3].r = d__1, b[i__3].i = 0.;
/* Computing MIN */
i__3 = *n, i__5 = j + *kd - 1;
if (i__ < min(i__3,i__5)) {
i__3 = ab_subscr(lenj - (i__ - j + 1), i__ + 1);
d__1 = -(tscal / (doublereal) (*kd + 2)) / (
doublereal) (*kd + 3);
ab[i__3].r = d__1, ab[i__3].i = 0.;
i__3 = ab_subscr(1, i__ + 1);
ab[i__3].r = 1., ab[i__3].i = 0.;
i__3 = i__ + 1;
d__1 = texp * (doublereal) ((*kd + 1) * (*kd + 1)
+ *kd);
b[i__3].r = d__1, b[i__3].i = 0.;
}
texp *= 2.;
/* L340: */
}
/* Computing MIN */
i__3 = *n, i__5 = j + *kd - 1;
i__1 = min(i__3,i__5);
d__1 = (doublereal) (*kd + 2) / (doublereal) (*kd + 3) *
tscal;
b[i__1].r = d__1, b[i__1].i = 0.;
/* L350: */
}
}
}
} else if (*imat == 17) {
/* Type 17: Generate a unit triangular matrix with elements
between -1 and 1, and make the right hand side large so that it
requires scaling. */
if (upper) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
/* Computing MIN */
i__4 = j - 1;
lenj = min(i__4,*kd);
zlarnv_(&c__4, &iseed[1], &lenj, &ab_ref(*kd + 1 - lenj, j));
i__4 = ab_subscr(*kd + 1, j);
d__1 = (doublereal) j;
ab[i__4].r = d__1, ab[i__4].i = 0.;
/* L360: */
}
} else {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
/* Computing MIN */
i__4 = *n - j;
lenj = min(i__4,*kd);
if (lenj > 0) {
zlarnv_(&c__4, &iseed[1], &lenj, &ab_ref(2, j));
}
i__4 = ab_subscr(1, j);
d__1 = (doublereal) j;
ab[i__4].r = d__1, ab[i__4].i = 0.;
/* L370: */
}
}
/* Set the right hand side so that the largest value is BIGNUM. */
zlarnv_(&c__2, &iseed[1], n, &b[1]);
iy = izamax_(n, &b[1], &c__1);
bnorm = z_abs(&b[iy]);
bscal = bignum / max(1.,bnorm);
zdscal_(n, &bscal, &b[1], &c__1);
} else if (*imat == 18) {
/* Type 18: Generate a triangular matrix with elements between
BIGNUM/(KD+1) and BIGNUM so that at least one of the column
norms will exceed BIGNUM.
1/3/91: ZLATBS no longer can handle this case */
tleft = bignum / (doublereal) (*kd + 1);
tscal = bignum * ((doublereal) (*kd + 1) / (doublereal) (*kd + 2));
if (upper) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
/* Computing MIN */
i__4 = j, i__1 = *kd + 1;
lenj = min(i__4,i__1);
zlarnv_(&c__5, &iseed[1], &lenj, &ab_ref(*kd + 2 - lenj, j));
dlarnv_(&c__1, &iseed[1], &lenj, &rwork[*kd + 2 - lenj]);
i__4 = *kd + 1;
for (i__ = *kd + 2 - lenj; i__ <= i__4; ++i__) {
i__1 = ab_subscr(i__, j);
i__3 = ab_subscr(i__, j);
d__1 = tleft + rwork[i__] * tscal;
z__1.r = d__1 * ab[i__3].r, z__1.i = d__1 * ab[i__3].i;
ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
/* L380: */
}
/* L390: */
}
} else {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
/* Computing MIN */
i__4 = *n - j + 1, i__1 = *kd + 1;
lenj = min(i__4,i__1);
zlarnv_(&c__5, &iseed[1], &lenj, &ab_ref(1, j));
dlarnv_(&c__1, &iseed[1], &lenj, &rwork[1]);
i__4 = lenj;
for (i__ = 1; i__ <= i__4; ++i__) {
i__1 = ab_subscr(i__, j);
i__3 = ab_subscr(i__, j);
d__1 = tleft + rwork[i__] * tscal;
z__1.r = d__1 * ab[i__3].r, z__1.i = d__1 * ab[i__3].i;
ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
/* L400: */
}
/* L410: */
}
}
zlarnv_(&c__2, &iseed[1], n, &b[1]);
zdscal_(n, &c_b91, &b[1], &c__1);
}
/* Flip the matrix if the transpose will be used. */
if (! lsame_(trans, "N")) {
if (upper) {
i__2 = *n / 2;
for (j = 1; j <= i__2; ++j) {
/* Computing MIN */
i__4 = *n - (j << 1) + 1, i__1 = *kd + 1;
lenj = min(i__4,i__1);
i__4 = *ldab - 1;
zswap_(&lenj, &ab_ref(*kd + 1, j), &i__4, &ab_ref(*kd + 2 -
lenj, *n - j + 1), &c_n1);
/* L420: */
}
} else {
i__2 = *n / 2;
for (j = 1; j <= i__2; ++j) {
/* Computing MIN */
i__4 = *n - (j << 1) + 1, i__1 = *kd + 1;
lenj = min(i__4,i__1);
i__4 = -(*ldab) + 1;
zswap_(&lenj, &ab_ref(1, j), &c__1, &ab_ref(lenj, *n - j + 2
- lenj), &i__4);
/* L430: */
}
}
}
return 0;
/* End of ZLATTB */
} /* zlattb_ */
/* Subroutine */ int zhbevd_(char *jobz, char *uplo, integer *n, integer *kd,
doublecomplex *ab, integer *ldab, doublereal *w, doublecomplex *z__,
integer *ldz, doublecomplex *work, integer *lwork, doublereal *rwork,
integer *lrwork, integer *iwork, integer *liwork, 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
=======
ZHBEVD computes all the eigenvalues and, optionally, eigenvectors of
a complex Hermitian band matrix A. If eigenvectors are desired, it
uses a divide and conquer algorithm.
The divide and conquer algorithm makes very mild assumptions about
floating point arithmetic. It will work on machines with a guard
digit in add/subtract, or on those binary machines without guard
digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
Cray-2. It could conceivably fail on hexadecimal or decimal machines
without guard digits, but we know of none.
Arguments
=========
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
KD (input) INTEGER
The number of superdiagonals of the matrix A if UPLO = 'U',
or the number of subdiagonals if UPLO = 'L'. KD >= 0.
AB (input/output) COMPLEX*16 array, dimension (LDAB, N)
On entry, the upper or lower triangle of the Hermitian band
matrix A, stored in the first KD+1 rows of the array. The
j-th column of A is stored in the j-th column of the array AB
as follows:
if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
On exit, AB is overwritten by values generated during the
reduction to tridiagonal form. If UPLO = 'U', the first
superdiagonal and the diagonal of the tridiagonal matrix T
are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
the diagonal and first subdiagonal of T are returned in the
first two rows of AB.
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD + 1.
W (output) DOUBLE PRECISION array, dimension (N)
If INFO = 0, the eigenvalues in ascending order.
Z (output) COMPLEX*16 array, dimension (LDZ, N)
If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
eigenvectors of the matrix A, with the i-th column of Z
holding the eigenvector associated with W(i).
If JOBZ = 'N', then Z is not referenced.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1, and if
JOBZ = 'V', LDZ >= max(1,N).
WORK (workspace/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.
If N <= 1, LWORK must be at least 1.
If JOBZ = 'N' and N > 1, LWORK must be at least N.
If JOBZ = 'V' and N > 1, LWORK must be at least 2*N**2.
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
RWORK (workspace/output) DOUBLE PRECISION array,
dimension (LRWORK)
On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
LRWORK (input) INTEGER
The dimension of array RWORK.
If N <= 1, LRWORK must be at least 1.
If JOBZ = 'N' and N > 1, LRWORK must be at least N.
If JOBZ = 'V' and N > 1, LRWORK must be at least
1 + 5*N + 2*N**2.
If LRWORK = -1, then a workspace query is assumed; the
routine only calculates the optimal size of the RWORK array,
returns this value as the first entry of the RWORK array, and
no error message related to LRWORK is issued by XERBLA.
IWORK (workspace/output) INTEGER array, dimension (LIWORK)
On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
LIWORK (input) INTEGER
The dimension of array IWORK.
If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.
If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N .
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.
> 0: if INFO = i, the algorithm failed to converge; i
off-diagonal elements of an intermediate tridiagonal
form did not converge to zero.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b1 = {0.,0.};
static doublecomplex c_b2 = {1.,0.};
static doublereal c_b13 = 1.;
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, z_dim1, z_offset, i__1;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer inde;
static doublereal anrm;
static integer imax;
static doublereal rmin, rmax;
static integer llwk2;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static doublereal sigma;
extern logical lsame_(char *, char *);
static integer iinfo;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
static integer lwmin;
static logical lower;
static integer llrwk;
static logical wantz;
static integer indwk2;
extern doublereal dlamch_(char *);
static integer iscale;
static doublereal safmin;
extern doublereal zlanhb_(char *, char *, integer *, integer *,
doublecomplex *, integer *, doublereal *);
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal bignum;
extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
integer *), zlascl_(char *, integer *, integer *, doublereal *,
doublereal *, integer *, integer *, doublecomplex *, integer *,
integer *), zstedc_(char *, integer *, doublereal *,
doublereal *, doublecomplex *, integer *, doublecomplex *,
integer *, doublereal *, integer *, integer *, integer *, integer
*), zhbtrd_(char *, char *, integer *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *,
doublecomplex *, integer *, doublecomplex *, integer *);
static integer indwrk, liwmin;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static integer lrwmin;
static doublereal smlnum;
static logical lquery;
static doublereal eps;
#define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1
#define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)]
#define ab_subscr(a_1,a_2) (a_2)*ab_dim1 + a_1
#define ab_ref(a_1,a_2) ab[ab_subscr(a_1,a_2)]
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
--rwork;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V");
lower = lsame_(uplo, "L");
lquery = *lwork == -1 || *liwork == -1 || *lrwork == -1;
*info = 0;
if (*n <= 1) {
lwmin = 1;
lrwmin = 1;
liwmin = 1;
} else {
if (wantz) {
/* Computing 2nd power */
i__1 = *n;
lwmin = i__1 * i__1 << 1;
/* Computing 2nd power */
i__1 = *n;
lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1);
liwmin = *n * 5 + 3;
} else {
lwmin = *n;
lrwmin = *n;
liwmin = 1;
}
}
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (lower || lsame_(uplo, "U"))) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*kd < 0) {
*info = -4;
} else if (*ldab < *kd + 1) {
*info = -6;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -9;
} else if (*lwork < lwmin && ! lquery) {
*info = -11;
} else if (*lrwork < lrwmin && ! lquery) {
*info = -13;
} else if (*liwork < liwmin && ! lquery) {
*info = -15;
}
if (*info == 0) {
work[1].r = (doublereal) lwmin, work[1].i = 0.;
rwork[1] = (doublereal) lrwmin;
iwork[1] = liwmin;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHBEVD", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
i__1 = ab_subscr(1, 1);
w[1] = ab[i__1].r;
if (wantz) {
i__1 = z___subscr(1, 1);
z__[i__1].r = 1., z__[i__1].i = 0.;
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
rmax = sqrt(bignum);
/* Scale matrix to allowable range, if necessary. */
anrm = zlanhb_("M", uplo, n, kd, &ab[ab_offset], ldab, &rwork[1]);
iscale = 0;
if (anrm > 0. && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
if (lower) {
zlascl_("B", kd, kd, &c_b13, &sigma, n, n, &ab[ab_offset], ldab,
info);
} else {
zlascl_("Q", kd, kd, &c_b13, &sigma, n, n, &ab[ab_offset], ldab,
info);
}
}
/* Call ZHBTRD to reduce Hermitian band matrix to tridiagonal form. */
inde = 1;
indwrk = inde + *n;
indwk2 = *n * *n + 1;
llwk2 = *lwork - indwk2 + 1;
llrwk = *lrwork - indwrk + 1;
zhbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &w[1], &rwork[inde], &
z__[z_offset], ldz, &work[1], &iinfo);
/* For eigenvalues only, call DSTERF. For eigenvectors, call ZSTEDC. */
if (! wantz) {
dsterf_(n, &w[1], &rwork[inde], info);
} else {
zstedc_("I", n, &w[1], &rwork[inde], &work[1], n, &work[indwk2], &
llwk2, &rwork[indwrk], &llrwk, &iwork[1], liwork, info);
zgemm_("N", "N", n, n, n, &c_b2, &z__[z_offset], ldz, &work[1], n, &
c_b1, &work[indwk2], n);
zlacpy_("A", n, n, &work[indwk2], n, &z__[z_offset], ldz);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (iscale == 1) {
if (*info == 0) {
imax = *n;
} else {
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__1, &w[1], &c__1);
}
work[1].r = (doublereal) lwmin, work[1].i = 0.;
rwork[1] = (doublereal) lrwmin;
iwork[1] = liwmin;
return 0;
/* End of ZHBEVD */
} /* zhbevd_ */