/* Subroutine */ int spotf2_(char *uplo, integer *n, real *a, integer *lda,
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
=======
SPOTF2 computes the Cholesky factorization of a real symmetric
positive definite 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 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
symmetric matrix A is stored.
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) REAL array, dimension (LDA,N)
On entry, the symmetric 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 factor U or L from the Cholesky
factorization A = U'*U or A = L*L'.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -k, the k-th argument had an illegal value
> 0: if INFO = k, the leading minor of order k is not
positive definite, and the factorization could not be
completed.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static real c_b10 = -1.f;
static real c_b12 = 1.f;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
static integer j;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
sgemv_(char *, integer *, integer *, real *, real *, integer *,
real *, integer *, real *, real *, integer *);
static logical upper;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real ajj;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPOTF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
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 = j - 1;
ajj = a_ref(j, j) - sdot_(&i__2, &a_ref(1, j), &c__1, &a_ref(1, j)
, &c__1);
if (ajj <= 0.f) {
a_ref(j, j) = ajj;
goto L30;
}
ajj = sqrt(ajj);
a_ref(j, j) = ajj;
/* Compute elements J+1:N of row J. */
if (j < *n) {
i__2 = j - 1;
i__3 = *n - j;
sgemv_("Transpose", &i__2, &i__3, &c_b10, &a_ref(1, j + 1),
lda, &a_ref(1, j), &c__1, &c_b12, &a_ref(j, j + 1),
lda);
i__2 = *n - j;
r__1 = 1.f / ajj;
sscal_(&i__2, &r__1, &a_ref(j, j + 1), lda);
}
/* L10: */
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute L(J,J) and test for non-positive-definiteness. */
i__2 = j - 1;
ajj = a_ref(j, j) - sdot_(&i__2, &a_ref(j, 1), lda, &a_ref(j, 1),
lda);
if (ajj <= 0.f) {
a_ref(j, j) = ajj;
goto L30;
}
ajj = sqrt(ajj);
a_ref(j, j) = ajj;
/* Compute elements J+1:N of column J. */
if (j < *n) {
i__2 = *n - j;
i__3 = j - 1;
sgemv_("No transpose", &i__2, &i__3, &c_b10, &a_ref(j + 1, 1),
lda, &a_ref(j, 1), lda, &c_b12, &a_ref(j + 1, j), &
c__1);
i__2 = *n - j;
r__1 = 1.f / ajj;
sscal_(&i__2, &r__1, &a_ref(j + 1, j), &c__1);
}
/* L20: */
}
}
goto L40;
L30:
*info = j;
L40:
return 0;
/* End of SPOTF2 */
} /* spotf2_ */
/* Subroutine */ int sstemr_(char *jobz, char *range, integer *n, real *d__,
real *e, real *vl, real *vu, integer *il, integer *iu, integer *m,
real *w, real *z__, integer *ldz, integer *nzc, integer *isuppz,
logical *tryrac, real *work, integer *lwork, integer *iwork, integer *
liwork, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j;
real r1, r2;
integer jj;
real cs;
integer in;
real sn, wl, wu;
integer iil, iiu;
real eps, tmp;
integer indd, iend, jblk, wend;
real rmin, rmax;
integer itmp;
real tnrm;
integer inde2;
extern /* Subroutine */ int slae2_(real *, real *, real *, real *, real *)
;
integer itmp2;
real rtol1, rtol2, scale;
integer indgp;
extern logical lsame_(char *, char *);
integer iinfo;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
integer iindw, ilast, lwmin;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), sswap_(integer *, real *, integer *, real *, integer *
);
logical wantz;
extern /* Subroutine */ int slaev2_(real *, real *, real *, real *, real *
, real *, real *);
logical alleig;
integer ibegin;
logical indeig;
integer iindbl;
logical valeig;
extern doublereal slamch_(char *);
integer wbegin;
real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
real bignum;
integer inderr, iindwk, indgrs, offset;
extern /* Subroutine */ int slarrc_(char *, integer *, real *, real *,
real *, real *, real *, integer *, integer *, integer *, integer *
), slarre_(char *, integer *, real *, real *, integer *,
integer *, real *, real *, real *, real *, real *, real *,
integer *, integer *, integer *, real *, real *, real *, integer *
, integer *, real *, real *, real *, integer *, integer *)
;
real thresh;
integer iinspl, indwrk, ifirst, liwmin, nzcmin;
real pivmin;
extern doublereal slanst_(char *, integer *, real *, real *);
extern /* Subroutine */ int slarrj_(integer *, real *, real *, integer *,
integer *, real *, integer *, real *, real *, real *, integer *,
real *, real *, integer *), slarrr_(integer *, real *, real *,
integer *);
integer nsplit;
extern /* Subroutine */ int slarrv_(integer *, real *, real *, real *,
real *, real *, integer *, integer *, integer *, integer *, real *
, real *, real *, real *, real *, real *, integer *, integer *,
real *, real *, integer *, integer *, real *, integer *, integer *
);
real smlnum;
extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *);
logical lquery, zquery;
/* -- LAPACK computational routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SSTEMR computes selected eigenvalues and, optionally, eigenvectors */
/* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has */
/* a well defined set of pairwise different real eigenvalues, the corresponding */
/* real eigenvectors are pairwise orthogonal. */
/* The spectrum may be computed either completely or partially by specifying */
/* either an interval (VL,VU] or a range of indices IL:IU for the desired */
/* eigenvalues. */
/* Depending on the number of desired eigenvalues, these are computed either */
/* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are */
/* computed by the use of various suitable L D L^T factorizations near clusters */
/* of close eigenvalues (referred to as RRRs, Relatively Robust */
/* Representations). An informal sketch of the algorithm follows. */
/* For each unreduced block (submatrix) of T, */
/* (a) Compute T - sigma I = L D L^T, so that L and D */
/* define all the wanted eigenvalues to high relative accuracy. */
/* This means that small relative changes in the entries of D and L */
/* cause only small relative changes in the eigenvalues and */
/* eigenvectors. The standard (unfactored) representation of the */
/* tridiagonal matrix T does not have this property in general. */
/* (b) Compute the eigenvalues to suitable accuracy. */
/* If the eigenvectors are desired, the algorithm attains full */
/* accuracy of the computed eigenvalues only right before */
/* the corresponding vectors have to be computed, see steps c) and d). */
/* (c) For each cluster of close eigenvalues, select a new */
/* shift close to the cluster, find a new factorization, and refine */
/* the shifted eigenvalues to suitable accuracy. */
/* (d) For each eigenvalue with a large enough relative separation compute */
/* the corresponding eigenvector by forming a rank revealing twisted */
/* factorization. Go back to (c) for any clusters that remain. */
/* For more details, see: */
/* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */
/* to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */
/* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */
/* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */
/* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */
/* 2004. Also LAPACK Working Note 154. */
/* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */
/* tridiagonal eigenvalue/eigenvector problem", */
/* Computer Science Division Technical Report No. UCB/CSD-97-971, */
/* UC Berkeley, May 1997. */
/* Notes: */
/* 1.SSTEMR works only on machines which follow IEEE-754 */
/* floating-point standard in their handling of infinities and NaNs. */
/* This permits the use of efficient inner loops avoiding a check for */
/* zero divisors. */
/* Arguments */
/* ========= */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* RANGE (input) CHARACTER*1 */
/* = 'A': all eigenvalues will be found. */
/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
/* will be found. */
/* = 'I': the IL-th through IU-th eigenvalues will be found. */
/* N (input) INTEGER */
/* The order of the matrix. N >= 0. */
/* D (input/output) REAL array, dimension (N) */
/* On entry, the N diagonal elements of the tridiagonal matrix */
/* T. On exit, D is overwritten. */
/* E (input/output) REAL array, dimension (N) */
/* On entry, the (N-1) subdiagonal elements of the tridiagonal */
/* matrix T in elements 1 to N-1 of E. E(N) need not be set on */
/* input, but is used internally as workspace. */
/* On exit, E is overwritten. */
/* VL (input) REAL */
/* VU (input) REAL */
/* If RANGE='V', the lower and upper bounds of the interval to */
/* be searched for eigenvalues. VL < VU. */
/* Not referenced if RANGE = 'A' or 'I'. */
/* IL (input) INTEGER */
/* IU (input) INTEGER */
/* If RANGE='I', the indices (in ascending order) of the */
/* smallest and largest eigenvalues to be returned. */
/* 1 <= IL <= IU <= N, if N > 0. */
/* Not referenced if RANGE = 'A' or 'V'. */
/* M (output) INTEGER */
/* The total number of eigenvalues found. 0 <= M <= N. */
/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
/* W (output) REAL array, dimension (N) */
/* The first M elements contain the selected eigenvalues in */
/* ascending order. */
/* Z (output) REAL array, dimension (LDZ, max(1,M) ) */
/* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z */
/* contain the orthonormal eigenvectors of the matrix T */
/* corresponding to the selected eigenvalues, with the i-th */
/* column of Z holding the eigenvector associated with W(i). */
/* If JOBZ = 'N', then Z is not referenced. */
/* Note: the user must ensure that at least max(1,M) columns are */
/* supplied in the array Z; if RANGE = 'V', the exact value of M */
/* is not known in advance and can be computed with a workspace */
/* query by setting NZC = -1, see below. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', then LDZ >= max(1,N). */
/* NZC (input) INTEGER */
/* The number of eigenvectors to be held in the array Z. */
/* If RANGE = 'A', then NZC >= max(1,N). */
/* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU]. */
/* If RANGE = 'I', then NZC >= IU-IL+1. */
/* If NZC = -1, then a workspace query is assumed; the */
/* routine calculates the number of columns of the array Z that */
/* are needed to hold the eigenvectors. */
/* This value is returned as the first entry of the Z array, and */
/* no error message related to NZC is issued by XERBLA. */
/* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) ) */
/* The support of the eigenvectors in Z, i.e., the indices */
/* indicating the nonzero elements in Z. The i-th computed eigenvector */
/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */
/* ISUPPZ( 2*i ). This is relevant in the case when the matrix */
/* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0. */
/* TRYRAC (input/output) LOGICAL */
/* If TRYRAC.EQ..TRUE., indicates that the code should check whether */
/* the tridiagonal matrix defines its eigenvalues to high relative */
/* accuracy. If so, the code uses relative-accuracy preserving */
/* algorithms that might be (a bit) slower depending on the matrix. */
/* If the matrix does not define its eigenvalues to high relative */
/* accuracy, the code can uses possibly faster algorithms. */
/* If TRYRAC.EQ..FALSE., the code is not required to guarantee */
/* relatively accurate eigenvalues and can use the fastest possible */
/* techniques. */
/* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix */
/* does not define its eigenvalues to high relative accuracy. */
/* WORK (workspace/output) REAL array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal */
/* (and minimal) LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,18*N) */
/* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* IWORK (workspace/output) INTEGER array, dimension (LIWORK) */
/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. LIWORK >= max(1,10*N) */
/* if the eigenvectors are desired, and LIWORK >= max(1,8*N) */
/* if only the eigenvalues are to be computed. */
/* 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 */
/* On exit, INFO */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = 1X, internal error in SLARRE, */
/* if INFO = 2X, internal error in SLARRV. */
/* Here, the digit X = ABS( IINFO ) < 10, where IINFO is */
/* the nonzero error code returned by SLARRE or */
/* SLARRV, respectively. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Beresford Parlett, University of California, Berkeley, USA */
/* Jim Demmel, University of California, Berkeley, USA */
/* Inderjit Dhillon, University of Texas, Austin, USA */
/* Osni Marques, LBNL/NERSC, USA */
/* Christof Voemel, University of California, Berkeley, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--isuppz;
--work;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
lquery = *lwork == -1 || *liwork == -1;
zquery = *nzc == -1;
*tryrac = *info != 0;
/* SSTEMR needs WORK of size 6*N, IWORK of size 3*N. */
/* In addition, SLARRE needs WORK of size 6*N, IWORK of size 5*N. */
/* Furthermore, SLARRV needs WORK of size 12*N, IWORK of size 7*N. */
if (wantz) {
lwmin = *n * 18;
liwmin = *n * 10;
} else {
/* need less workspace if only the eigenvalues are wanted */
lwmin = *n * 12;
liwmin = *n << 3;
}
wl = 0.f;
wu = 0.f;
iil = 0;
iiu = 0;
if (valeig) {
/* We do not reference VL, VU in the cases RANGE = 'I','A' */
/* The interval (WL, WU] contains all the wanted eigenvalues. */
/* It is either given by the user or computed in SLARRE. */
wl = *vl;
wu = *vu;
} else if (indeig) {
/* We do not reference IL, IU in the cases RANGE = 'V','A' */
iil = *il;
iiu = *iu;
}
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (valeig && *n > 0 && wu <= wl) {
*info = -7;
} else if (indeig && (iil < 1 || iil > *n)) {
*info = -8;
} else if (indeig && (iiu < iil || iiu > *n)) {
*info = -9;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -13;
} else if (*lwork < lwmin && ! lquery) {
*info = -17;
} else if (*liwork < liwmin && ! lquery) {
*info = -19;
}
/* Get machine constants. */
safmin = slamch_("Safe minimum");
eps = slamch_("Precision");
smlnum = safmin / eps;
bignum = 1.f / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin));
rmax = dmin(r__1,r__2);
if (*info == 0) {
work[1] = (real) lwmin;
iwork[1] = liwmin;
if (wantz && alleig) {
nzcmin = *n;
} else if (wantz && valeig) {
slarrc_("T", n, vl, vu, &d__[1], &e[1], &safmin, &nzcmin, &itmp, &
itmp2, info);
} else if (wantz && indeig) {
nzcmin = iiu - iil + 1;
} else {
/* WANTZ .EQ. FALSE. */
nzcmin = 0;
}
if (zquery && *info == 0) {
z__[z_dim1 + 1] = (real) nzcmin;
} else if (*nzc < nzcmin && ! zquery) {
*info = -14;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSTEMR", &i__1);
return 0;
} else if (lquery || zquery) {
return 0;
}
/* Handle N = 0, 1, and 2 cases immediately */
*m = 0;
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (alleig || indeig) {
*m = 1;
w[1] = d__[1];
} else {
if (wl < d__[1] && wu >= d__[1]) {
*m = 1;
w[1] = d__[1];
}
}
if (wantz && ! zquery) {
z__[z_dim1 + 1] = 1.f;
isuppz[1] = 1;
isuppz[2] = 1;
}
return 0;
}
if (*n == 2) {
if (! wantz) {
slae2_(&d__[1], &e[1], &d__[2], &r1, &r2);
} else if (wantz && ! zquery) {
slaev2_(&d__[1], &e[1], &d__[2], &r1, &r2, &cs, &sn);
}
if (alleig || valeig && r2 > wl && r2 <= wu || indeig && iil == 1) {
++(*m);
w[*m] = r2;
if (wantz && ! zquery) {
z__[*m * z_dim1 + 1] = -sn;
z__[*m * z_dim1 + 2] = cs;
/* Note: At most one of SN and CS can be zero. */
if (sn != 0.f) {
if (cs != 0.f) {
isuppz[(*m << 1) - 1] = 1;
isuppz[(*m << 1) - 1] = 2;
} else {
isuppz[(*m << 1) - 1] = 1;
isuppz[(*m << 1) - 1] = 1;
}
} else {
isuppz[(*m << 1) - 1] = 2;
isuppz[*m * 2] = 2;
}
}
}
if (alleig || valeig && r1 > wl && r1 <= wu || indeig && iiu == 2) {
++(*m);
w[*m] = r1;
if (wantz && ! zquery) {
z__[*m * z_dim1 + 1] = cs;
z__[*m * z_dim1 + 2] = sn;
/* Note: At most one of SN and CS can be zero. */
if (sn != 0.f) {
if (cs != 0.f) {
isuppz[(*m << 1) - 1] = 1;
isuppz[(*m << 1) - 1] = 2;
} else {
isuppz[(*m << 1) - 1] = 1;
isuppz[(*m << 1) - 1] = 1;
}
} else {
isuppz[(*m << 1) - 1] = 2;
isuppz[*m * 2] = 2;
}
}
}
return 0;
}
/* Continue with general N */
indgrs = 1;
inderr = (*n << 1) + 1;
indgp = *n * 3 + 1;
indd = (*n << 2) + 1;
inde2 = *n * 5 + 1;
indwrk = *n * 6 + 1;
iinspl = 1;
iindbl = *n + 1;
iindw = (*n << 1) + 1;
iindwk = *n * 3 + 1;
/* Scale matrix to allowable range, if necessary. */
/* The allowable range is related to the PIVMIN parameter; see the */
/* comments in SLARRD. The preference for scaling small values */
/* up is heuristic; we expect users' matrices not to be close to the */
/* RMAX threshold. */
scale = 1.f;
tnrm = slanst_("M", n, &d__[1], &e[1]);
if (tnrm > 0.f && tnrm < rmin) {
scale = rmin / tnrm;
} else if (tnrm > rmax) {
scale = rmax / tnrm;
}
if (scale != 1.f) {
sscal_(n, &scale, &d__[1], &c__1);
i__1 = *n - 1;
sscal_(&i__1, &scale, &e[1], &c__1);
tnrm *= scale;
if (valeig) {
/* If eigenvalues in interval have to be found, */
/* scale (WL, WU] accordingly */
wl *= scale;
wu *= scale;
}
}
/* Compute the desired eigenvalues of the tridiagonal after splitting */
/* into smaller subblocks if the corresponding off-diagonal elements */
/* are small */
/* THRESH is the splitting parameter for SLARRE */
/* A negative THRESH forces the old splitting criterion based on the */
/* size of the off-diagonal. A positive THRESH switches to splitting */
/* which preserves relative accuracy. */
if (*tryrac) {
/* Test whether the matrix warrants the more expensive relative approach. */
slarrr_(n, &d__[1], &e[1], &iinfo);
} else {
/* The user does not care about relative accurately eigenvalues */
iinfo = -1;
}
/* Set the splitting criterion */
if (iinfo == 0) {
thresh = eps;
} else {
thresh = -eps;
/* relative accuracy is desired but T does not guarantee it */
*tryrac = FALSE_;
}
if (*tryrac) {
/* Copy original diagonal, needed to guarantee relative accuracy */
scopy_(n, &d__[1], &c__1, &work[indd], &c__1);
}
/* Store the squares of the offdiagonal values of T */
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
/* Computing 2nd power */
r__1 = e[j];
work[inde2 + j - 1] = r__1 * r__1;
/* L5: */
}
/* Set the tolerance parameters for bisection */
if (! wantz) {
/* SLARRE computes the eigenvalues to full precision. */
rtol1 = eps * 4.f;
rtol2 = eps * 4.f;
} else {
/* SLARRE computes the eigenvalues to less than full precision. */
/* SLARRV will refine the eigenvalue approximations, and we can */
/* need less accurate initial bisection in SLARRE. */
/* Note: these settings do only affect the subset case and SLARRE */
/* Computing MAX */
r__1 = sqrt(eps) * .05f, r__2 = eps * 4.f;
rtol1 = dmax(r__1,r__2);
/* Computing MAX */
r__1 = sqrt(eps) * .005f, r__2 = eps * 4.f;
rtol2 = dmax(r__1,r__2);
}
slarre_(range, n, &wl, &wu, &iil, &iiu, &d__[1], &e[1], &work[inde2], &
rtol1, &rtol2, &thresh, &nsplit, &iwork[iinspl], m, &w[1], &work[
inderr], &work[indgp], &iwork[iindbl], &iwork[iindw], &work[
indgrs], &pivmin, &work[indwrk], &iwork[iindwk], &iinfo);
if (iinfo != 0) {
*info = abs(iinfo) + 10;
return 0;
}
/* Note that if RANGE .NE. 'V', SLARRE computes bounds on the desired */
/* part of the spectrum. All desired eigenvalues are contained in */
/* (WL,WU] */
if (wantz) {
/* Compute the desired eigenvectors corresponding to the computed */
/* eigenvalues */
slarrv_(n, &wl, &wu, &d__[1], &e[1], &pivmin, &iwork[iinspl], m, &
c__1, m, &c_b18, &rtol1, &rtol2, &w[1], &work[inderr], &work[
indgp], &iwork[iindbl], &iwork[iindw], &work[indgrs], &z__[
z_offset], ldz, &isuppz[1], &work[indwrk], &iwork[iindwk], &
iinfo);
if (iinfo != 0) {
*info = abs(iinfo) + 20;
return 0;
}
} else {
/* SLARRE computes eigenvalues of the (shifted) root representation */
/* SLARRV returns the eigenvalues of the unshifted matrix. */
/* However, if the eigenvectors are not desired by the user, we need */
/* to apply the corresponding shifts from SLARRE to obtain the */
/* eigenvalues of the original matrix. */
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
itmp = iwork[iindbl + j - 1];
w[j] += e[iwork[iinspl + itmp - 1]];
/* L20: */
}
}
if (*tryrac) {
/* Refine computed eigenvalues so that they are relatively accurate */
/* with respect to the original matrix T. */
ibegin = 1;
wbegin = 1;
i__1 = iwork[iindbl + *m - 1];
for (jblk = 1; jblk <= i__1; ++jblk) {
iend = iwork[iinspl + jblk - 1];
in = iend - ibegin + 1;
wend = wbegin - 1;
/* check if any eigenvalues have to be refined in this block */
L36:
if (wend < *m) {
if (iwork[iindbl + wend] == jblk) {
++wend;
goto L36;
}
}
if (wend < wbegin) {
ibegin = iend + 1;
goto L39;
}
offset = iwork[iindw + wbegin - 1] - 1;
ifirst = iwork[iindw + wbegin - 1];
ilast = iwork[iindw + wend - 1];
rtol2 = eps * 4.f;
slarrj_(&in, &work[indd + ibegin - 1], &work[inde2 + ibegin - 1],
&ifirst, &ilast, &rtol2, &offset, &w[wbegin], &work[
inderr + wbegin - 1], &work[indwrk], &iwork[iindwk], &
pivmin, &tnrm, &iinfo);
ibegin = iend + 1;
wbegin = wend + 1;
L39:
;
}
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (scale != 1.f) {
r__1 = 1.f / scale;
sscal_(m, &r__1, &w[1], &c__1);
}
/* If eigenvalues are not in increasing order, then sort them, */
/* possibly along with eigenvectors. */
if (nsplit > 1) {
if (! wantz) {
slasrt_("I", m, &w[1], &iinfo);
if (iinfo != 0) {
*info = 3;
return 0;
}
} else {
i__1 = *m - 1;
for (j = 1; j <= i__1; ++j) {
i__ = 0;
tmp = w[j];
i__2 = *m;
for (jj = j + 1; jj <= i__2; ++jj) {
if (w[jj] < tmp) {
i__ = jj;
tmp = w[jj];
}
/* L50: */
}
if (i__ != 0) {
w[i__] = w[j];
w[j] = tmp;
if (wantz) {
sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j *
z_dim1 + 1], &c__1);
itmp = isuppz[(i__ << 1) - 1];
isuppz[(i__ << 1) - 1] = isuppz[(j << 1) - 1];
isuppz[(j << 1) - 1] = itmp;
itmp = isuppz[i__ * 2];
isuppz[i__ * 2] = isuppz[j * 2];
isuppz[j * 2] = itmp;
}
}
/* L60: */
}
}
}
work[1] = (real) lwmin;
iwork[1] = liwmin;
return 0;
/* End of SSTEMR */
} /* sstemr_ */
/* Subroutine */ int slaror_(char *side, char *init, integer *m, integer *n,
real *a, integer *lda, integer *iseed, real *x, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
real r__1;
/* Builtin functions */
double r_sign(real *, real *);
/* Local variables */
static integer kbeg, jcol;
extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
integer *, real *, integer *, real *, integer *);
static integer irow;
extern real snrm2_(integer *, real *, integer *);
static integer j;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
sgemv_(char *, integer *, integer *, real *, real *, integer *,
real *, integer *, real *, real *, integer *);
static integer ixfrm, itype, nxfrm;
static real xnorm;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real factor;
extern doublereal slarnd_(integer *, integer *);
extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
real *, real *, integer *);
static real xnorms;
/* -- LAPACK auxiliary test routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SLAROR pre- or post-multiplies an M by N matrix A by a random
orthogonal matrix U, overwriting A. A may optionally be initialized
to the identity matrix before multiplying by U. U is generated using
the method of G.W. Stewart (SIAM J. Numer. Anal. 17, 1980, 403-409).
Arguments
=========
SIDE (input) CHARACTER*1
Specifies whether A is multiplied on the left or right by U.
= 'L': Multiply A on the left (premultiply) by U
= 'R': Multiply A on the right (postmultiply) by U'
= 'C' or 'T': Multiply A on the left by U and the right
by U' (Here, U' means U-transpose.)
INIT (input) CHARACTER*1
Specifies whether or not A should be initialized to the
identity matrix.
= 'I': Initialize A to (a section of) the identity matrix
before applying U.
= 'N': No initialization. Apply U to the input matrix A.
INIT = 'I' may be used to generate square or rectangular
orthogonal matrices:
For M = N and SIDE = 'L' or 'R', the rows will be orthogonal
to each other, as will the columns.
If M < N, SIDE = 'R' produces a dense matrix whose rows are
orthogonal and whose columns are not, while SIDE = 'L'
produces a matrix whose rows are orthogonal, and whose first
M columns are orthogonal, and whose remaining columns are
zero.
If M > N, SIDE = 'L' produces a dense matrix whose columns
are orthogonal and whose rows are not, while SIDE = 'R'
produces a matrix whose columns are orthogonal, and whose
first M rows are orthogonal, and whose remaining rows are
zero.
M (input) INTEGER
The number of rows of A.
N (input) INTEGER
The number of columns of A.
A (input/output) REAL array, dimension (LDA, N)
On entry, the array A.
On exit, overwritten by U A ( if SIDE = 'L' ),
or by A U ( if SIDE = 'R' ),
or by U A U' ( if SIDE = 'C' or 'T').
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
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 SLAROR to continue the same random number
sequence.
X (workspace) REAL array, dimension (3*MAX( M, N ))
Workspace of length
2*M + N if SIDE = 'L',
2*N + M if SIDE = 'R',
3*N if SIDE = 'C' or 'T'.
INFO (output) INTEGER
An error flag. It is set to:
= 0: normal return
< 0: if INFO = -k, the k-th argument had an illegal value
= 1: if the random numbers generated by SLARND are bad.
=====================================================================
Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--iseed;
--x;
/* Function Body */
if (*n == 0 || *m == 0) {
return 0;
}
itype = 0;
if (lsame_(side, "L")) {
itype = 1;
} else if (lsame_(side, "R")) {
itype = 2;
} else if (lsame_(side, "C") || lsame_(side, "T")) {
itype = 3;
}
/* Check for argument errors. */
*info = 0;
if (itype == 0) {
*info = -1;
} else if (*m < 0) {
*info = -3;
} else if (*n < 0 || itype == 3 && *n != *m) {
*info = -4;
} else if (*lda < *m) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SLAROR", &i__1);
return 0;
}
if (itype == 1) {
nxfrm = *m;
} else {
nxfrm = *n;
}
/* Initialize A to the identity matrix if desired */
if (lsame_(init, "I")) {
slaset_("Full", m, n, &c_b9, &c_b10, &a[a_offset], lda);
}
/* If no rotation possible, multiply by random +/-1
Compute rotation by computing Householder transformations
H(2), H(3), ..., H(nhouse) */
i__1 = nxfrm;
for (j = 1; j <= i__1; ++j) {
x[j] = 0.f;
/* L10: */
}
i__1 = nxfrm;
for (ixfrm = 2; ixfrm <= i__1; ++ixfrm) {
kbeg = nxfrm - ixfrm + 1;
/* Generate independent normal( 0, 1 ) random numbers */
i__2 = nxfrm;
for (j = kbeg; j <= i__2; ++j) {
x[j] = slarnd_(&c__3, &iseed[1]);
/* L20: */
}
/* Generate a Householder transformation from the random vector
X */
xnorm = snrm2_(&ixfrm, &x[kbeg], &c__1);
xnorms = r_sign(&xnorm, &x[kbeg]);
r__1 = -(doublereal)x[kbeg];
x[kbeg + nxfrm] = r_sign(&c_b10, &r__1);
factor = xnorms * (xnorms + x[kbeg]);
if (dabs(factor) < 1e-20f) {
*info = 1;
xerbla_("SLAROR", info);
return 0;
} else {
factor = 1.f / factor;
}
x[kbeg] += xnorms;
/* Apply Householder transformation to A */
if (itype == 1 || itype == 3) {
/* Apply H(k) from the left. */
sgemv_("T", &ixfrm, n, &c_b10, &a[kbeg + a_dim1], lda, &x[kbeg], &
c__1, &c_b9, &x[(nxfrm << 1) + 1], &c__1);
r__1 = -(doublereal)factor;
sger_(&ixfrm, n, &r__1, &x[kbeg], &c__1, &x[(nxfrm << 1) + 1], &
c__1, &a[kbeg + a_dim1], lda);
}
if (itype == 2 || itype == 3) {
/* Apply H(k) from the right. */
sgemv_("N", m, &ixfrm, &c_b10, &a[kbeg * a_dim1 + 1], lda, &x[
kbeg], &c__1, &c_b9, &x[(nxfrm << 1) + 1], &c__1);
r__1 = -(doublereal)factor;
sger_(m, &ixfrm, &r__1, &x[(nxfrm << 1) + 1], &c__1, &x[kbeg], &
c__1, &a[kbeg * a_dim1 + 1], lda);
}
/* L30: */
}
r__1 = slarnd_(&c__3, &iseed[1]);
x[nxfrm * 2] = r_sign(&c_b10, &r__1);
/* Scale the matrix A by D. */
if (itype == 1 || itype == 3) {
i__1 = *m;
for (irow = 1; irow <= i__1; ++irow) {
sscal_(n, &x[nxfrm + irow], &a[irow + a_dim1], lda);
/* L40: */
}
}
if (itype == 2 || itype == 3) {
i__1 = *n;
for (jcol = 1; jcol <= i__1; ++jcol) {
sscal_(m, &x[nxfrm + jcol], &a[jcol * a_dim1 + 1], &c__1);
/* L50: */
}
}
return 0;
/* End of SLAROR */
} /* slaror_ */
/* Subroutine */ int slatrd_(char *uplo, integer *n, integer *nb, real *a,
integer *lda, real *e, real *tau, real *w, integer *ldw)
{
/* System generated locals */
integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3;
/* Local variables */
integer i__, iw;
real alpha;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* SLATRD reduces NB rows and columns of a real symmetric matrix A to */
/* symmetric tridiagonal form by an orthogonal similarity */
/* transformation Q' * A * Q, and returns the matrices V and W which are */
/* needed to apply the transformation to the unreduced part of A. */
/* If UPLO = 'U', SLATRD reduces the last NB rows and columns of a */
/* matrix, of which the upper triangle is supplied; */
/* if UPLO = 'L', SLATRD reduces the first NB rows and columns of a */
/* matrix, of which the lower triangle is supplied. */
/* This is an auxiliary routine called by SSYTRD. */
/* 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. */
/* NB (input) INTEGER */
/* The number of rows and columns to be reduced. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the symmetric 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 UPLO = 'U', the last NB columns have been reduced to */
/* tridiagonal form, with the diagonal elements overwriting */
/* the diagonal elements of A; the elements above the diagonal */
/* with the array TAU, represent the orthogonal matrix Q as a */
/* product of elementary reflectors; */
/* if UPLO = 'L', the first NB columns have been reduced to */
/* tridiagonal form, with the diagonal elements overwriting */
/* the diagonal elements of A; the elements below the diagonal */
/* with the array TAU, represent the orthogonal matrix Q as a */
/* product of elementary reflectors. */
/* See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= (1,N). */
/* E (output) REAL array, dimension (N-1) */
/* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal */
/* elements of the last NB columns of the reduced matrix; */
/* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of */
/* the first NB columns of the reduced matrix. */
/* TAU (output) REAL array, dimension (N-1) */
/* The scalar factors of the elementary reflectors, stored in */
/* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. */
/* See Further Details. */
/* W (output) REAL array, dimension (LDW,NB) */
/* The n-by-nb matrix W required to update the unreduced part */
/* of A. */
/* LDW (input) INTEGER */
/* The leading dimension of the array W. LDW >= max(1,N). */
/* Further Details */
/* =============== */
/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
/* reflectors */
/* Q = H(n) H(n-1) . . . H(n-nb+1). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a real scalar, and v is a real vector with */
/* v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), */
/* and tau in TAU(i-1). */
/* If UPLO = 'L', the matrix Q is represented as a product of elementary */
/* reflectors */
/* Q = H(1) H(2) . . . H(nb). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a real scalar, and v is a real vector with */
/* v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), */
/* and tau in TAU(i). */
/* The elements of the vectors v together form the n-by-nb matrix V */
/* which is needed, with W, to apply the transformation to the unreduced */
/* part of the matrix, using a symmetric rank-2k update of the form: */
/* A := A - V*W' - W*V'. */
/* The contents of A on exit are illustrated by the following examples */
/* with n = 5 and nb = 2: */
/* if UPLO = 'U': if UPLO = 'L': */
/* ( a a a v4 v5 ) ( d ) */
/* ( a a v4 v5 ) ( 1 d ) */
/* ( a 1 v5 ) ( v1 1 a ) */
/* ( d 1 ) ( v1 v2 a a ) */
/* ( d ) ( v1 v2 a a a ) */
/* where d denotes a diagonal element of the reduced matrix, a denotes */
/* an element of the original matrix that is unchanged, and vi denotes */
/* an element of the vector defining H(i). */
/* ===================================================================== */
/* Quick return if possible */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--e;
--tau;
w_dim1 = *ldw;
w_offset = 1 + w_dim1;
w -= w_offset;
/* Function Body */
if (*n <= 0) {
return 0;
}
if (lsame_(uplo, "U")) {
/* Reduce last NB columns of upper triangle */
i__1 = *n - *nb + 1;
for (i__ = *n; i__ >= i__1; --i__) {
iw = i__ - *n + *nb;
if (i__ < *n) {
/* Update A(1:i,i) */
i__2 = *n - i__;
sgemv_("No transpose", &i__, &i__2, &c_b5, &a[(i__ + 1) *
a_dim1 + 1], lda, &w[i__ + (iw + 1) * w_dim1], ldw, &
c_b6, &a[i__ * a_dim1 + 1], &c__1);
i__2 = *n - i__;
sgemv_("No transpose", &i__, &i__2, &c_b5, &w[(iw + 1) *
w_dim1 + 1], ldw, &a[i__ + (i__ + 1) * a_dim1], lda, &
c_b6, &a[i__ * a_dim1 + 1], &c__1);
}
if (i__ > 1) {
/* Generate elementary reflector H(i) to annihilate */
/* A(1:i-2,i) */
i__2 = i__ - 1;
slarfg_(&i__2, &a[i__ - 1 + i__ * a_dim1], &a[i__ * a_dim1 +
1], &c__1, &tau[i__ - 1]);
e[i__ - 1] = a[i__ - 1 + i__ * a_dim1];
a[i__ - 1 + i__ * a_dim1] = 1.f;
/* Compute W(1:i-1,i) */
i__2 = i__ - 1;
ssymv_("Upper", &i__2, &c_b6, &a[a_offset], lda, &a[i__ *
a_dim1 + 1], &c__1, &c_b16, &w[iw * w_dim1 + 1], &
c__1);
if (i__ < *n) {
i__2 = i__ - 1;
i__3 = *n - i__;
sgemv_("Transpose", &i__2, &i__3, &c_b6, &w[(iw + 1) *
w_dim1 + 1], ldw, &a[i__ * a_dim1 + 1], &c__1, &
c_b16, &w[i__ + 1 + iw * w_dim1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
sgemv_("No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) *
a_dim1 + 1], lda, &w[i__ + 1 + iw * w_dim1], &
c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
sgemv_("Transpose", &i__2, &i__3, &c_b6, &a[(i__ + 1) *
a_dim1 + 1], lda, &a[i__ * a_dim1 + 1], &c__1, &
c_b16, &w[i__ + 1 + iw * w_dim1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
sgemv_("No transpose", &i__2, &i__3, &c_b5, &w[(iw + 1) *
w_dim1 + 1], ldw, &w[i__ + 1 + iw * w_dim1], &
c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1);
}
i__2 = i__ - 1;
sscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1);
i__2 = i__ - 1;
alpha = tau[i__ - 1] * -.5f * sdot_(&i__2, &w[iw * w_dim1 + 1]
, &c__1, &a[i__ * a_dim1 + 1], &c__1);
i__2 = i__ - 1;
saxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw *
w_dim1 + 1], &c__1);
}
}
} else {
/* Reduce first NB columns of lower triangle */
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i:n,i) */
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
sgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + a_dim1], lda,
&w[i__ + w_dim1], ldw, &c_b6, &a[i__ + i__ * a_dim1], &
c__1);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
sgemv_("No transpose", &i__2, &i__3, &c_b5, &w[i__ + w_dim1], ldw,
&a[i__ + a_dim1], lda, &c_b6, &a[i__ + i__ * a_dim1], &
c__1);
if (i__ < *n) {
/* Generate elementary reflector H(i) to annihilate */
/* A(i+2:n,i) */
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
slarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *n)+
i__ * a_dim1], &c__1, &tau[i__]);
e[i__] = a[i__ + 1 + i__ * a_dim1];
a[i__ + 1 + i__ * a_dim1] = 1.f;
/* Compute W(i+1:n,i) */
i__2 = *n - i__;
ssymv_("Lower", &i__2, &c_b6, &a[i__ + 1 + (i__ + 1) * a_dim1]
, lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[
i__ + 1 + i__ * w_dim1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
sgemv_("Transpose", &i__2, &i__3, &c_b6, &w[i__ + 1 + w_dim1],
ldw, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[
i__ * w_dim1 + 1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
sgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 +
a_dim1], lda, &w[i__ * w_dim1 + 1], &c__1, &c_b6, &w[
i__ + 1 + i__ * w_dim1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
sgemv_("Transpose", &i__2, &i__3, &c_b6, &a[i__ + 1 + a_dim1],
lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[
i__ * w_dim1 + 1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
sgemv_("No transpose", &i__2, &i__3, &c_b5, &w[i__ + 1 +
w_dim1], ldw, &w[i__ * w_dim1 + 1], &c__1, &c_b6, &w[
i__ + 1 + i__ * w_dim1], &c__1);
i__2 = *n - i__;
sscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1);
i__2 = *n - i__;
alpha = tau[i__] * -.5f * sdot_(&i__2, &w[i__ + 1 + i__ *
w_dim1], &c__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
i__2 = *n - i__;
saxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[
i__ + 1 + i__ * w_dim1], &c__1);
}
}
}
return 0;
/* End of SLATRD */
} /* slatrd_ */
int sgebal_(char *job, int *n, float *a, int *lda,
int *ilo, int *ihi, float *scale, int *info)
{
/* System generated locals */
int a_dim1, a_offset, i__1, i__2;
float r__1, r__2;
/* Local variables */
float c__, f, g;
int i__, j, k, l, m;
float r__, s, ca, ra;
int ica, ira, iexc;
extern int lsame_(char *, char *);
extern int sscal_(int *, float *, float *, int *),
sswap_(int *, float *, int *, float *, int *);
float sfmin1, sfmin2, sfmax1, sfmax2;
extern double slamch_(char *);
extern int xerbla_(char *, int *);
extern int isamax_(int *, float *, int *);
int noconv;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGEBAL balances a general float matrix A. This involves, first, */
/* permuting A by a similarity transformation to isolate eigenvalues */
/* in the first 1 to ILO-1 and last IHI+1 to N elements on the */
/* diagonal; and second, applying a diagonal similarity transformation */
/* to rows and columns ILO to IHI to make the rows and columns as */
/* close in norm as possible. Both steps are optional. */
/* Balancing may reduce the 1-norm of the matrix, and improve the */
/* accuracy of the computed eigenvalues and/or eigenvectors. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* Specifies the operations to be performed on A: */
/* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0 */
/* for i = 1,...,N; */
/* = 'P': permute only; */
/* = 'S': scale only; */
/* = 'B': both permute and scale. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the input matrix A. */
/* On exit, A is overwritten by the balanced matrix. */
/* If JOB = 'N', A is not referenced. */
/* See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* ILO (output) INTEGER */
/* IHI (output) INTEGER */
/* ILO and IHI are set to ints such that on exit */
/* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. */
/* If JOB = 'N' or 'S', ILO = 1 and IHI = N. */
/* SCALE (output) REAL array, dimension (N) */
/* Details of the permutations and scaling factors applied to */
/* A. If P(j) is the index of the row and column interchanged */
/* with row and column j and D(j) is the scaling factor */
/* applied to row and column j, then */
/* SCALE(j) = P(j) for j = 1,...,ILO-1 */
/* = D(j) for j = ILO,...,IHI */
/* = P(j) for j = IHI+1,...,N. */
/* The order in which the interchanges are made is N to IHI+1, */
/* then 1 to ILO-1. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* The permutations consist of row and column interchanges which put */
/* the matrix in the form */
/* ( T1 X Y ) */
/* P A P = ( 0 B Z ) */
/* ( 0 0 T2 ) */
/* where T1 and T2 are upper triangular matrices whose eigenvalues lie */
/* along the diagonal. The column indices ILO and IHI mark the starting */
/* and ending columns of the submatrix B. Balancing consists of applying */
/* a diagonal similarity transformation inv(D) * B * D to make the */
/* 1-norms of each row of B and its corresponding column nearly equal. */
/* The output matrix is */
/* ( T1 X*D Y ) */
/* ( 0 inv(D)*B*D inv(D)*Z ). */
/* ( 0 0 T2 ) */
/* Information about the permutations P and the diagonal matrix D is */
/* returned in the vector SCALE. */
/* This subroutine is based on the EISPACK routine BALANC. */
/* Modified by Tzu-Yi Chen, Computer Science Division, University of */
/* California at Berkeley, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--scale;
/* Function Body */
*info = 0;
if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S")
&& ! lsame_(job, "B")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < MAX(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGEBAL", &i__1);
return 0;
}
k = 1;
l = *n;
if (*n == 0) {
goto L210;
}
if (lsame_(job, "N")) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
scale[i__] = 1.f;
/* L10: */
}
goto L210;
}
if (lsame_(job, "S")) {
goto L120;
}
/* Permutation to isolate eigenvalues if possible */
goto L50;
/* Row and column exchange. */
L20:
scale[m] = (float) j;
if (j == m) {
goto L30;
}
sswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
i__1 = *n - k + 1;
sswap_(&i__1, &a[j + k * a_dim1], lda, &a[m + k * a_dim1], lda);
L30:
switch (iexc) {
case 1: goto L40;
case 2: goto L80;
}
/* Search for rows isolating an eigenvalue and push them down. */
L40:
if (l == 1) {
goto L210;
}
--l;
L50:
for (j = l; j >= 1; --j) {
i__1 = l;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ == j) {
goto L60;
}
if (a[j + i__ * a_dim1] != 0.f) {
goto L70;
}
L60:
;
}
m = l;
iexc = 1;
goto L20;
L70:
;
}
goto L90;
/* Search for columns isolating an eigenvalue and push them left. */
L80:
++k;
L90:
i__1 = l;
for (j = k; j <= i__1; ++j) {
i__2 = l;
for (i__ = k; i__ <= i__2; ++i__) {
if (i__ == j) {
goto L100;
}
if (a[i__ + j * a_dim1] != 0.f) {
goto L110;
}
L100:
;
}
m = k;
iexc = 2;
goto L20;
L110:
;
}
L120:
i__1 = l;
for (i__ = k; i__ <= i__1; ++i__) {
scale[i__] = 1.f;
/* L130: */
}
if (lsame_(job, "P")) {
goto L210;
}
/* Balance the submatrix in rows K to L. */
/* Iterative loop for norm reduction */
sfmin1 = slamch_("S") / slamch_("P");
sfmax1 = 1.f / sfmin1;
sfmin2 = sfmin1 * 2.f;
sfmax2 = 1.f / sfmin2;
L140:
noconv = FALSE;
i__1 = l;
for (i__ = k; i__ <= i__1; ++i__) {
c__ = 0.f;
r__ = 0.f;
i__2 = l;
for (j = k; j <= i__2; ++j) {
if (j == i__) {
goto L150;
}
c__ += (r__1 = a[j + i__ * a_dim1], ABS(r__1));
r__ += (r__1 = a[i__ + j * a_dim1], ABS(r__1));
L150:
;
}
ica = isamax_(&l, &a[i__ * a_dim1 + 1], &c__1);
ca = (r__1 = a[ica + i__ * a_dim1], ABS(r__1));
i__2 = *n - k + 1;
ira = isamax_(&i__2, &a[i__ + k * a_dim1], lda);
ra = (r__1 = a[i__ + (ira + k - 1) * a_dim1], ABS(r__1));
/* Guard against zero C or R due to underflow. */
if (c__ == 0.f || r__ == 0.f) {
goto L200;
}
g = r__ / 2.f;
f = 1.f;
s = c__ + r__;
L160:
/* Computing MAX */
r__1 = MAX(f,c__);
/* Computing MIN */
r__2 = MIN(r__,g);
if (c__ >= g || MAX(r__1,ca) >= sfmax2 || MIN(r__2,ra) <= sfmin2) {
goto L170;
}
f *= 2.f;
c__ *= 2.f;
ca *= 2.f;
r__ /= 2.f;
g /= 2.f;
ra /= 2.f;
goto L160;
L170:
g = c__ / 2.f;
L180:
/* Computing MIN */
r__1 = MIN(f,c__), r__1 = MIN(r__1,g);
if (g < r__ || MAX(r__,ra) >= sfmax2 || MIN(r__1,ca) <= sfmin2) {
goto L190;
}
f /= 2.f;
c__ /= 2.f;
g /= 2.f;
ca /= 2.f;
r__ *= 2.f;
ra *= 2.f;
goto L180;
/* Now balance. */
L190:
if (c__ + r__ >= s * .95f) {
goto L200;
}
if (f < 1.f && scale[i__] < 1.f) {
if (f * scale[i__] <= sfmin1) {
goto L200;
}
}
if (f > 1.f && scale[i__] > 1.f) {
if (scale[i__] >= sfmax1 / f) {
goto L200;
}
}
g = 1.f / f;
scale[i__] *= f;
noconv = TRUE;
i__2 = *n - k + 1;
sscal_(&i__2, &g, &a[i__ + k * a_dim1], lda);
sscal_(&l, &f, &a[i__ * a_dim1 + 1], &c__1);
L200:
;
}
if (noconv) {
goto L140;
}
L210:
*ilo = k;
*ihi = l;
return 0;
/* End of SGEBAL */
} /* sgebal_ */
/* Subroutine */ int sgbtrf_(integer *m, integer *n, integer *kl, integer *ku,
real *ab, integer *ldab, integer *ipiv, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
real r__1;
/* Local variables */
integer i__, j, i2, i3, j2, j3, k2, jb, nb, ii, jj, jm, ip, jp, km, ju,
kv, nw;
extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
integer *, real *, integer *, real *, integer *);
real temp;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
sgemm_(char *, char *, integer *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *);
real work13[4160] /* was [65][64] */, work31[4160] /* was [65][
64] */;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), sswap_(integer *, real *, integer *, real *, integer *
), strsm_(char *, char *, char *, char *, integer *, integer *,
real *, real *, integer *, real *, integer *), sgbtf2_(integer *, integer *, integer *, integer
*, real *, integer *, integer *, integer *), xerbla_(char *,
integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *), isamax_(integer *, real *,
integer *);
extern /* Subroutine */ int slaswp_(integer *, real *, integer *, integer
*, integer *, integer *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGBTRF computes an LU factorization of a real m-by-n band matrix A */
/* using partial pivoting with row interchanges. */
/* This is the blocked version of the algorithm, calling Level 3 BLAS. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* KL (input) INTEGER */
/* The number of subdiagonals within the band of A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of superdiagonals within the band of A. KU >= 0. */
/* AB (input/output) REAL array, dimension (LDAB,N) */
/* On entry, the matrix A in band storage, in rows KL+1 to */
/* 2*KL+KU+1; rows 1 to KL of the array need not be set. */
/* The j-th column of A is stored in the j-th column of the */
/* array AB as follows: */
/* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) */
/* On exit, details of the factorization: U is stored as an */
/* upper triangular band matrix with KL+KU superdiagonals in */
/* rows 1 to KL+KU+1, and the multipliers used during the */
/* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */
/* See below for further details. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
/* IPIV (output) INTEGER array, dimension (min(M,N)) */
/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
/* matrix was interchanged with row IPIV(i). */
/* 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. The factorization */
/* has been completed, but the factor U is exactly */
/* singular, and division by zero will occur if it is used */
/* to solve a system of equations. */
/* Further Details */
/* =============== */
/* The band storage scheme is illustrated by the following example, when */
/* M = N = 6, KL = 2, KU = 1: */
/* On entry: On exit: */
/* * * * + + + * * * u14 u25 u36 */
/* * * + + + + * * 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 */
/* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */
/* a31 a42 a53 a64 * * m31 m42 m53 m64 * * */
/* Array elements marked * are not used by the routine; elements marked */
/* + need not be set on entry, but are required by the routine to store */
/* elements of U because of fill-in resulting from the row interchanges. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* KV is the number of superdiagonals in the factor U, allowing for */
/* fill-in */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--ipiv;
/* Function Body */
kv = *ku + *kl;
/* Test the input parameters. */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kl < 0) {
*info = -3;
} else if (*ku < 0) {
*info = -4;
} else if (*ldab < *kl + kv + 1) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGBTRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Determine the block size for this environment */
nb = ilaenv_(&c__1, "SGBTRF", " ", m, n, kl, ku);
/* The block size must not exceed the limit set by the size of the */
/* local arrays WORK13 and WORK31. */
nb = min(nb,64);
if (nb <= 1 || nb > *kl) {
/* Use unblocked code */
sgbtf2_(m, n, kl, ku, &ab[ab_offset], ldab, &ipiv[1], info);
} else {
/* Use blocked code */
/* Zero the superdiagonal elements of the work array WORK13 */
i__1 = nb;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work13[i__ + j * 65 - 66] = 0.f;
/* L10: */
}
/* L20: */
}
/* Zero the subdiagonal elements of the work array WORK31 */
i__1 = nb;
for (j = 1; j <= i__1; ++j) {
i__2 = nb;
for (i__ = j + 1; i__ <= i__2; ++i__) {
work31[i__ + j * 65 - 66] = 0.f;
/* L30: */
}
/* L40: */
}
/* Gaussian elimination with partial pivoting */
/* Set fill-in elements in columns KU+2 to KV to zero */
i__1 = min(kv,*n);
for (j = *ku + 2; j <= i__1; ++j) {
i__2 = *kl;
for (i__ = kv - j + 2; i__ <= i__2; ++i__) {
ab[i__ + j * ab_dim1] = 0.f;
/* L50: */
}
/* L60: */
}
/* JU is the index of the last column affected by the current */
/* stage of the factorization */
ju = 1;
i__1 = min(*m,*n);
i__2 = nb;
for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Computing MIN */
i__3 = nb, i__4 = min(*m,*n) - j + 1;
jb = min(i__3,i__4);
/* The active part of the matrix is partitioned */
/* A11 A12 A13 */
/* A21 A22 A23 */
/* A31 A32 A33 */
/* Here A11, A21 and A31 denote the current block of JB columns */
/* which is about to be factorized. The number of rows in the */
/* partitioning are JB, I2, I3 respectively, and the numbers */
/* of columns are JB, J2, J3. The superdiagonal elements of A13 */
/* and the subdiagonal elements of A31 lie outside the band. */
/* Computing MIN */
i__3 = *kl - jb, i__4 = *m - j - jb + 1;
i2 = min(i__3,i__4);
/* Computing MIN */
i__3 = jb, i__4 = *m - j - *kl + 1;
i3 = min(i__3,i__4);
/* J2 and J3 are computed after JU has been updated. */
/* Factorize the current block of JB columns */
i__3 = j + jb - 1;
for (jj = j; jj <= i__3; ++jj) {
/* Set fill-in elements in column JJ+KV to zero */
if (jj + kv <= *n) {
i__4 = *kl;
for (i__ = 1; i__ <= i__4; ++i__) {
ab[i__ + (jj + kv) * ab_dim1] = 0.f;
/* L70: */
}
}
/* Find pivot and test for singularity. KM is the number of */
/* subdiagonal elements in the current column. */
/* Computing MIN */
i__4 = *kl, i__5 = *m - jj;
km = min(i__4,i__5);
i__4 = km + 1;
jp = isamax_(&i__4, &ab[kv + 1 + jj * ab_dim1], &c__1);
ipiv[jj] = jp + jj - j;
if (ab[kv + jp + jj * ab_dim1] != 0.f) {
/* Computing MAX */
/* Computing MIN */
i__6 = jj + *ku + jp - 1;
i__4 = ju, i__5 = min(i__6,*n);
ju = max(i__4,i__5);
if (jp != 1) {
/* Apply interchange to columns J to J+JB-1 */
if (jp + jj - 1 < j + *kl) {
i__4 = *ldab - 1;
i__5 = *ldab - 1;
sswap_(&jb, &ab[kv + 1 + jj - j + j * ab_dim1], &
i__4, &ab[kv + jp + jj - j + j * ab_dim1],
&i__5);
} else {
/* The interchange affects columns J to JJ-1 of A31 */
/* which are stored in the work array WORK31 */
i__4 = jj - j;
i__5 = *ldab - 1;
sswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1],
&i__5, &work31[jp + jj - j - *kl - 1], &
c__65);
i__4 = j + jb - jj;
i__5 = *ldab - 1;
i__6 = *ldab - 1;
sswap_(&i__4, &ab[kv + 1 + jj * ab_dim1], &i__5, &
ab[kv + jp + jj * ab_dim1], &i__6);
}
}
/* Compute multipliers */
r__1 = 1.f / ab[kv + 1 + jj * ab_dim1];
sscal_(&km, &r__1, &ab[kv + 2 + jj * ab_dim1], &c__1);
/* Update trailing submatrix within the band and within */
/* the current block. JM is the index of the last column */
/* which needs to be updated. */
/* Computing MIN */
i__4 = ju, i__5 = j + jb - 1;
jm = min(i__4,i__5);
if (jm > jj) {
i__4 = jm - jj;
i__5 = *ldab - 1;
i__6 = *ldab - 1;
sger_(&km, &i__4, &c_b18, &ab[kv + 2 + jj * ab_dim1],
&c__1, &ab[kv + (jj + 1) * ab_dim1], &i__5, &
ab[kv + 1 + (jj + 1) * ab_dim1], &i__6);
}
} else {
/* If pivot is zero, set INFO to the index of the pivot */
/* unless a zero pivot has already been found. */
if (*info == 0) {
*info = jj;
}
}
/* Copy current column of A31 into the work array WORK31 */
/* Computing MIN */
i__4 = jj - j + 1;
nw = min(i__4,i3);
if (nw > 0) {
scopy_(&nw, &ab[kv + *kl + 1 - jj + j + jj * ab_dim1], &
c__1, &work31[(jj - j + 1) * 65 - 65], &c__1);
}
/* L80: */
}
if (j + jb <= *n) {
/* Apply the row interchanges to the other blocks. */
/* Computing MIN */
i__3 = ju - j + 1;
j2 = min(i__3,kv) - jb;
/* Computing MAX */
i__3 = 0, i__4 = ju - j - kv + 1;
j3 = max(i__3,i__4);
/* Use SLASWP to apply the row interchanges to A12, A22, and */
/* A32. */
i__3 = *ldab - 1;
slaswp_(&j2, &ab[kv + 1 - jb + (j + jb) * ab_dim1], &i__3, &
c__1, &jb, &ipiv[j], &c__1);
/* Adjust the pivot indices. */
i__3 = j + jb - 1;
for (i__ = j; i__ <= i__3; ++i__) {
ipiv[i__] = ipiv[i__] + j - 1;
/* L90: */
}
/* Apply the row interchanges to A13, A23, and A33 */
/* columnwise. */
k2 = j - 1 + jb + j2;
i__3 = j3;
for (i__ = 1; i__ <= i__3; ++i__) {
jj = k2 + i__;
i__4 = j + jb - 1;
for (ii = j + i__ - 1; ii <= i__4; ++ii) {
ip = ipiv[ii];
if (ip != ii) {
temp = ab[kv + 1 + ii - jj + jj * ab_dim1];
ab[kv + 1 + ii - jj + jj * ab_dim1] = ab[kv + 1 +
ip - jj + jj * ab_dim1];
ab[kv + 1 + ip - jj + jj * ab_dim1] = temp;
}
/* L100: */
}
/* L110: */
}
/* Update the relevant part of the trailing submatrix */
if (j2 > 0) {
/* Update A12 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
strsm_("Left", "Lower", "No transpose", "Unit", &jb, &j2,
&c_b31, &ab[kv + 1 + j * ab_dim1], &i__3, &ab[kv
+ 1 - jb + (j + jb) * ab_dim1], &i__4);
if (i2 > 0) {
/* Update A22 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
i__5 = *ldab - 1;
sgemm_("No transpose", "No transpose", &i2, &j2, &jb,
&c_b18, &ab[kv + 1 + jb + j * ab_dim1], &i__3,
&ab[kv + 1 - jb + (j + jb) * ab_dim1], &i__4,
&c_b31, &ab[kv + 1 + (j + jb) * ab_dim1], &
i__5);
}
if (i3 > 0) {
/* Update A32 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
sgemm_("No transpose", "No transpose", &i3, &j2, &jb,
&c_b18, work31, &c__65, &ab[kv + 1 - jb + (j
+ jb) * ab_dim1], &i__3, &c_b31, &ab[kv + *kl
+ 1 - jb + (j + jb) * ab_dim1], &i__4);
}
}
if (j3 > 0) {
/* Copy the lower triangle of A13 into the work array */
/* WORK13 */
i__3 = j3;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = jb;
for (ii = jj; ii <= i__4; ++ii) {
work13[ii + jj * 65 - 66] = ab[ii - jj + 1 + (jj
+ j + kv - 1) * ab_dim1];
/* L120: */
}
/* L130: */
}
/* Update A13 in the work array */
i__3 = *ldab - 1;
strsm_("Left", "Lower", "No transpose", "Unit", &jb, &j3,
&c_b31, &ab[kv + 1 + j * ab_dim1], &i__3, work13,
&c__65);
if (i2 > 0) {
/* Update A23 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
sgemm_("No transpose", "No transpose", &i2, &j3, &jb,
&c_b18, &ab[kv + 1 + jb + j * ab_dim1], &i__3,
work13, &c__65, &c_b31, &ab[jb + 1 + (j + kv)
* ab_dim1], &i__4);
}
if (i3 > 0) {
/* Update A33 */
i__3 = *ldab - 1;
sgemm_("No transpose", "No transpose", &i3, &j3, &jb,
&c_b18, work31, &c__65, work13, &c__65, &
c_b31, &ab[*kl + 1 + (j + kv) * ab_dim1], &
i__3);
}
/* Copy the lower triangle of A13 back into place */
i__3 = j3;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = jb;
for (ii = jj; ii <= i__4; ++ii) {
ab[ii - jj + 1 + (jj + j + kv - 1) * ab_dim1] =
work13[ii + jj * 65 - 66];
/* L140: */
}
/* L150: */
}
}
} else {
/* Adjust the pivot indices. */
i__3 = j + jb - 1;
for (i__ = j; i__ <= i__3; ++i__) {
ipiv[i__] = ipiv[i__] + j - 1;
/* L160: */
}
}
/* Partially undo the interchanges in the current block to */
/* restore the upper triangular form of A31 and copy the upper */
/* triangle of A31 back into place */
i__3 = j;
for (jj = j + jb - 1; jj >= i__3; --jj) {
jp = ipiv[jj] - jj + 1;
if (jp != 1) {
/* Apply interchange to columns J to JJ-1 */
if (jp + jj - 1 < j + *kl) {
/* The interchange does not affect A31 */
i__4 = jj - j;
i__5 = *ldab - 1;
i__6 = *ldab - 1;
sswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], &
i__5, &ab[kv + jp + jj - j + j * ab_dim1], &
i__6);
} else {
/* The interchange does affect A31 */
i__4 = jj - j;
i__5 = *ldab - 1;
sswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], &
i__5, &work31[jp + jj - j - *kl - 1], &c__65);
}
}
/* Copy the current column of A31 back into place */
/* Computing MIN */
i__4 = i3, i__5 = jj - j + 1;
nw = min(i__4,i__5);
if (nw > 0) {
scopy_(&nw, &work31[(jj - j + 1) * 65 - 65], &c__1, &ab[
kv + *kl + 1 - jj + j + jj * ab_dim1], &c__1);
}
/* L170: */
}
/* L180: */
}
}
return 0;
/* End of SGBTRF */
} /* sgbtrf_ */
/* Subroutine */ int sgetf2_(integer *m, integer *n, real *a, integer *lda,
integer *ipiv, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
real r__1;
/* Local variables */
integer i__, j, jp;
extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
integer *, real *, integer *, real *, integer *), sscal_(integer *
, real *, real *, integer *);
real sfmin;
extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer isamax_(integer *, real *, integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGETF2 computes an LU factorization of a general m-by-n matrix A */
/* using partial pivoting with row interchanges. */
/* The factorization has the form */
/* A = P * L * U */
/* where P is a permutation matrix, L is lower triangular with unit */
/* diagonal elements (lower trapezoidal if m > n), and U is upper */
/* triangular (upper trapezoidal if m < n). */
/* This is the right-looking Level 2 BLAS version of the algorithm. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the m by n matrix to be factored. */
/* On exit, the factors L and U from the factorization */
/* A = P*L*U; the unit diagonal elements of L are not stored. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* IPIV (output) INTEGER array, dimension (min(M,N)) */
/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
/* matrix was interchanged with row IPIV(i). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* > 0: if INFO = k, U(k,k) is exactly zero. The factorization */
/* has been completed, but the factor U is exactly */
/* singular, and division by zero will occur if it is used */
/* to solve a system of equations. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGETF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Compute machine safe minimum */
sfmin = slamch_("S");
i__1 = min(*m,*n);
for (j = 1; j <= i__1; ++j) {
/* Find pivot and test for singularity. */
i__2 = *m - j + 1;
jp = j - 1 + isamax_(&i__2, &a[j + j * a_dim1], &c__1);
ipiv[j] = jp;
if (a[jp + j * a_dim1] != 0.f) {
/* Apply the interchange to columns 1:N. */
if (jp != j) {
sswap_(n, &a[j + a_dim1], lda, &a[jp + a_dim1], lda);
}
/* Compute elements J+1:M of J-th column. */
if (j < *m) {
if ((r__1 = a[j + j * a_dim1], dabs(r__1)) >= sfmin) {
i__2 = *m - j;
r__1 = 1.f / a[j + j * a_dim1];
sscal_(&i__2, &r__1, &a[j + 1 + j * a_dim1], &c__1);
} else {
i__2 = *m - j;
for (i__ = 1; i__ <= i__2; ++i__) {
a[j + i__ + j * a_dim1] /= a[j + j * a_dim1];
/* L20: */
}
}
}
} else if (*info == 0) {
*info = j;
}
if (j < min(*m,*n)) {
/* Update trailing submatrix. */
i__2 = *m - j;
i__3 = *n - j;
sger_(&i__2, &i__3, &c_b8, &a[j + 1 + j * a_dim1], &c__1, &a[j + (
j + 1) * a_dim1], lda, &a[j + 1 + (j + 1) * a_dim1], lda);
}
/* L10: */
}
return 0;
/* End of SGETF2 */
} /* sgetf2_ */
/* Subroutine */ int sgeevx_(char *balanc, char *jobvl, char *jobvr, char *
sense, integer *n, real *a, integer *lda, real *wr, real *wi, real *
vl, integer *ldvl, real *vr, integer *ldvr, integer *ilo, integer *
ihi, real *scale, real *abnrm, real *rconde, real *rcondv, real *work,
integer *lwork, integer *iwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, k;
real r__, cs, sn;
char job[1];
real scl, dum[1], eps;
char side[1];
real anrm;
integer ierr, itau, iwrk, nout;
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *);
extern doublereal snrm2_(integer *, real *, integer *);
integer icond;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
extern doublereal slapy2_(real *, real *);
extern /* Subroutine */ int slabad_(real *, real *);
logical scalea;
real cscale;
extern /* Subroutine */ int sgebak_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, integer *, integer *), sgebal_(char *, integer *, real *, integer *,
integer *, integer *, real *, integer *);
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real
*, integer *, real *, real *, integer *, integer *), xerbla_(char
*, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
logical select[1];
real bignum;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *);
extern integer isamax_(integer *, real *, integer *);
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slartg_(real *, real *,
real *, real *, real *), sorghr_(integer *, integer *, integer *,
real *, integer *, real *, real *, integer *, integer *), shseqr_(
char *, char *, integer *, integer *, integer *, real *, integer *
, real *, real *, real *, integer *, real *, integer *, integer *), strevc_(char *, char *, logical *, integer *,
real *, integer *, real *, integer *, real *, integer *, integer *
, integer *, real *, integer *);
integer minwrk, maxwrk;
extern /* Subroutine */ int strsna_(char *, char *, logical *, integer *,
real *, integer *, real *, integer *, real *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *,
integer *);
logical wantvl, wntsnb;
integer hswork;
logical wntsne;
real smlnum;
logical lquery, wantvr, wntsnn, wntsnv;
/* -- LAPACK driver routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGEEVX computes for an N-by-N real nonsymmetric matrix A, the */
/* eigenvalues and, optionally, the left and/or right eigenvectors. */
/* Optionally also, it computes a balancing transformation to improve */
/* the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */
/* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues */
/* (RCONDE), and reciprocal condition numbers for the right */
/* eigenvectors (RCONDV). */
/* The right eigenvector v(j) of A satisfies */
/* A * v(j) = lambda(j) * v(j) */
/* where lambda(j) is its eigenvalue. */
/* The left eigenvector u(j) of A satisfies */
/* u(j)**H * A = lambda(j) * u(j)**H */
/* where u(j)**H denotes the conjugate transpose of u(j). */
/* The computed eigenvectors are normalized to have Euclidean norm */
/* equal to 1 and largest component real. */
/* Balancing a matrix means permuting the rows and columns to make it */
/* more nearly upper triangular, and applying a diagonal similarity */
/* transformation D * A * D**(-1), where D is a diagonal matrix, to */
/* make its rows and columns closer in norm and the condition numbers */
/* of its eigenvalues and eigenvectors smaller. The computed */
/* reciprocal condition numbers correspond to the balanced matrix. */
/* Permuting rows and columns will not change the condition numbers */
/* (in exact arithmetic) but diagonal scaling will. For further */
/* explanation of balancing, see section 4.10.2 of the LAPACK */
/* Users' Guide. */
/* Arguments */
/* ========= */
/* BALANC (input) CHARACTER*1 */
/* Indicates how the input matrix should be diagonally scaled */
/* and/or permuted to improve the conditioning of its */
/* eigenvalues. */
/* = 'N': Do not diagonally scale or permute; */
/* = 'P': Perform permutations to make the matrix more nearly */
/* upper triangular. Do not diagonally scale; */
/* = 'S': Diagonally scale the matrix, i.e. replace A by */
/* D*A*D**(-1), where D is a diagonal matrix chosen */
/* to make the rows and columns of A more equal in */
/* norm. Do not permute; */
/* = 'B': Both diagonally scale and permute A. */
/* Computed reciprocal condition numbers will be for the matrix */
/* after balancing and/or permuting. Permuting does not change */
/* condition numbers (in exact arithmetic), but balancing does. */
/* JOBVL (input) CHARACTER*1 */
/* = 'N': left eigenvectors of A are not computed; */
/* = 'V': left eigenvectors of A are computed. */
/* If SENSE = 'E' or 'B', JOBVL must = 'V'. */
/* JOBVR (input) CHARACTER*1 */
/* = 'N': right eigenvectors of A are not computed; */
/* = 'V': right eigenvectors of A are computed. */
/* If SENSE = 'E' or 'B', JOBVR must = 'V'. */
/* SENSE (input) CHARACTER*1 */
/* Determines which reciprocal condition numbers are computed. */
/* = 'N': None are computed; */
/* = 'E': Computed for eigenvalues only; */
/* = 'V': Computed for right eigenvectors only; */
/* = 'B': Computed for eigenvalues and right eigenvectors. */
/* If SENSE = 'E' or 'B', both left and right eigenvectors */
/* must also be computed (JOBVL = 'V' and JOBVR = 'V'). */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the N-by-N matrix A. */
/* On exit, A has been overwritten. If JOBVL = 'V' or */
/* JOBVR = 'V', A contains the real Schur form of the balanced */
/* version of the input matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* WR (output) REAL array, dimension (N) */
/* WI (output) REAL array, dimension (N) */
/* WR and WI contain the real and imaginary parts, */
/* respectively, of the computed eigenvalues. Complex */
/* conjugate pairs of eigenvalues will appear consecutively */
/* with the eigenvalue having the positive imaginary part */
/* first. */
/* VL (output) REAL array, dimension (LDVL,N) */
/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
/* after another in the columns of VL, in the same order */
/* as their eigenvalues. */
/* If JOBVL = 'N', VL is not referenced. */
/* If the j-th eigenvalue is real, then u(j) = VL(:,j), */
/* the j-th column of VL. */
/* If the j-th and (j+1)-st eigenvalues form a complex */
/* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and */
/* u(j+1) = VL(:,j) - i*VL(:,j+1). */
/* LDVL (input) INTEGER */
/* The leading dimension of the array VL. LDVL >= 1; if */
/* JOBVL = 'V', LDVL >= N. */
/* VR (output) REAL array, dimension (LDVR,N) */
/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
/* after another in the columns of VR, in the same order */
/* as their eigenvalues. */
/* If JOBVR = 'N', VR is not referenced. */
/* If the j-th eigenvalue is real, then v(j) = VR(:,j), */
/* the j-th column of VR. */
/* If the j-th and (j+1)-st eigenvalues form a complex */
/* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and */
/* v(j+1) = VR(:,j) - i*VR(:,j+1). */
/* LDVR (input) INTEGER */
/* The leading dimension of the array VR. LDVR >= 1, and if */
/* JOBVR = 'V', LDVR >= N. */
/* ILO (output) INTEGER */
/* IHI (output) INTEGER */
/* ILO and IHI are integer values determined when A was */
/* balanced. The balanced A(i,j) = 0 if I > J and */
/* J = 1,...,ILO-1 or I = IHI+1,...,N. */
/* SCALE (output) REAL array, dimension (N) */
/* Details of the permutations and scaling factors applied */
/* when balancing A. If P(j) is the index of the row and column */
/* interchanged with row and column j, and D(j) is the scaling */
/* factor applied to row and column j, then */
/* SCALE(J) = P(J), for J = 1,...,ILO-1 */
/* = D(J), for J = ILO,...,IHI */
/* = P(J) for J = IHI+1,...,N. */
/* The order in which the interchanges are made is N to IHI+1, */
/* then 1 to ILO-1. */
/* ABNRM (output) REAL */
/* The one-norm of the balanced matrix (the maximum */
/* of the sum of absolute values of elements of any column). */
/* RCONDE (output) REAL array, dimension (N) */
/* RCONDE(j) is the reciprocal condition number of the j-th */
/* eigenvalue. */
/* RCONDV (output) REAL array, dimension (N) */
/* RCONDV(j) is the reciprocal condition number of the j-th */
/* right eigenvector. */
/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. If SENSE = 'N' or 'E', */
/* LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V', */
/* LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6). */
/* For good performance, LWORK must generally be larger. */
/* 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) INTEGER array, dimension (2*N-2) */
/* If SENSE = 'N' or 'E', not referenced. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = i, the QR algorithm failed to compute all the */
/* eigenvalues, and no eigenvectors or condition numbers */
/* have been computed; elements 1:ILO-1 and i+1:N of WR */
/* and WI contain eigenvalues which have converged. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--wr;
--wi;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--scale;
--rconde;
--rcondv;
--work;
--iwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1;
wantvl = lsame_(jobvl, "V");
wantvr = lsame_(jobvr, "V");
wntsnn = lsame_(sense, "N");
wntsne = lsame_(sense, "E");
wntsnv = lsame_(sense, "V");
wntsnb = lsame_(sense, "B");
if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P")
|| lsame_(balanc, "B"))) {
*info = -1;
} else if (! wantvl && ! lsame_(jobvl, "N")) {
*info = -2;
} else if (! wantvr && ! lsame_(jobvr, "N")) {
*info = -3;
} else if (! (wntsnn || wntsne || wntsnb || wntsnv) || (wntsne || wntsnb)
&& ! (wantvl && wantvr)) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldvl < 1 || wantvl && *ldvl < *n) {
*info = -11;
} else if (*ldvr < 1 || wantvr && *ldvr < *n) {
*info = -13;
}
/* 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. */
/* HSWORK refers to the workspace preferred by SHSEQR, as */
/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
/* the worst case.) */
if (*info == 0) {
if (*n == 0) {
minwrk = 1;
maxwrk = 1;
} else {
maxwrk = *n + *n * ilaenv_(&c__1, "SGEHRD", " ", n, &c__1, n, &
c__0);
if (wantvl) {
shseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
1], &vl[vl_offset], ldvl, &work[1], &c_n1, info);
} else if (wantvr) {
shseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
1], &vr[vr_offset], ldvr, &work[1], &c_n1, info);
} else {
if (wntsnn) {
shseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &wr[1],
&wi[1], &vr[vr_offset], ldvr, &work[1], &c_n1,
info);
} else {
shseqr_("S", "N", n, &c__1, n, &a[a_offset], lda, &wr[1],
&wi[1], &vr[vr_offset], ldvr, &work[1], &c_n1,
info);
}
}
hswork = work[1];
if (! wantvl && ! wantvr) {
minwrk = *n << 1;
if (! wntsnn) {
/* Computing MAX */
i__1 = minwrk, i__2 = *n * *n + *n * 6;
minwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,hswork);
if (! wntsnn) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *n + *n * 6;
maxwrk = max(i__1,i__2);
}
} else {
minwrk = *n * 3;
if (! wntsnn && ! wntsne) {
/* Computing MAX */
i__1 = minwrk, i__2 = *n * *n + *n * 6;
minwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,hswork);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "SORGHR",
" ", n, &c__1, n, &c_n1);
maxwrk = max(i__1,i__2);
if (! wntsnn && ! wntsne) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *n + *n * 6;
maxwrk = max(i__1,i__2);
}
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3;
maxwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,minwrk);
}
work[1] = (real) maxwrk;
if (*lwork < minwrk && ! lquery) {
*info = -21;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGEEVX", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
icond = 0;
anrm = slange_("M", n, n, &a[a_offset], lda, dum);
scalea = FALSE_;
if (anrm > 0.f && anrm < smlnum) {
scalea = TRUE_;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE_;
cscale = bignum;
}
if (scalea) {
slascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
ierr);
}
/* Balance the matrix and compute ABNRM */
sgebal_(balanc, n, &a[a_offset], lda, ilo, ihi, &scale[1], &ierr);
*abnrm = slange_("1", n, n, &a[a_offset], lda, dum);
if (scalea) {
dum[0] = *abnrm;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &c__1, &
ierr);
*abnrm = dum[0];
}
/* Reduce to upper Hessenberg form */
/* (Workspace: need 2*N, prefer N+N*NB) */
itau = 1;
iwrk = itau + *n;
i__1 = *lwork - iwrk + 1;
sgehrd_(n, ilo, ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, &
ierr);
if (wantvl) {
/* Want left eigenvectors */
/* Copy Householder vectors to VL */
*(unsigned char *)side = 'L';
slacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl)
;
/* Generate orthogonal matrix in VL */
/* (Workspace: need 2*N-1, prefer N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
sorghr_(n, ilo, ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], &
i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VL */
/* (Workspace: need 1, prefer HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
shseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vl[
vl_offset], ldvl, &work[iwrk], &i__1, info);
if (wantvr) {
/* Want left and right eigenvectors */
/* Copy Schur vectors to VR */
*(unsigned char *)side = 'B';
slacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
}
} else if (wantvr) {
/* Want right eigenvectors */
/* Copy Householder vectors to VR */
*(unsigned char *)side = 'R';
slacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr)
;
/* Generate orthogonal matrix in VR */
/* (Workspace: need 2*N-1, prefer N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
sorghr_(n, ilo, ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], &
i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VR */
/* (Workspace: need 1, prefer HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
shseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
} else {
/* Compute eigenvalues only */
/* If condition numbers desired, compute Schur form */
if (wntsnn) {
*(unsigned char *)job = 'E';
} else {
*(unsigned char *)job = 'S';
}
/* (Workspace: need 1, prefer HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
shseqr_(job, "N", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
}
/* If INFO > 0 from SHSEQR, then quit */
if (*info > 0) {
goto L50;
}
if (wantvl || wantvr) {
/* Compute left and/or right eigenvectors */
/* (Workspace: need 3*N) */
strevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
&vr[vr_offset], ldvr, n, &nout, &work[iwrk], &ierr);
}
/* Compute condition numbers if desired */
/* (Workspace: need N*N+6*N unless SENSE = 'E') */
if (! wntsnn) {
strsna_(sense, "A", select, n, &a[a_offset], lda, &vl[vl_offset],
ldvl, &vr[vr_offset], ldvr, &rconde[1], &rcondv[1], n, &nout,
&work[iwrk], n, &iwork[1], &icond);
}
if (wantvl) {
/* Undo balancing of left eigenvectors */
sgebak_(balanc, "L", n, ilo, ihi, &scale[1], n, &vl[vl_offset], ldvl,
&ierr);
/* Normalize left eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wi[i__] == 0.f) {
scl = 1.f / snrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
sscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
} else if (wi[i__] > 0.f) {
r__1 = snrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
r__2 = snrm2_(n, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
scl = 1.f / slapy2_(&r__1, &r__2);
sscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
sscal_(n, &scl, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* Computing 2nd power */
r__1 = vl[k + i__ * vl_dim1];
/* Computing 2nd power */
r__2 = vl[k + (i__ + 1) * vl_dim1];
work[k] = r__1 * r__1 + r__2 * r__2;
/* L10: */
}
k = isamax_(n, &work[1], &c__1);
slartg_(&vl[k + i__ * vl_dim1], &vl[k + (i__ + 1) * vl_dim1],
&cs, &sn, &r__);
srot_(n, &vl[i__ * vl_dim1 + 1], &c__1, &vl[(i__ + 1) *
vl_dim1 + 1], &c__1, &cs, &sn);
vl[k + (i__ + 1) * vl_dim1] = 0.f;
}
/* L20: */
}
}
if (wantvr) {
/* Undo balancing of right eigenvectors */
sgebak_(balanc, "R", n, ilo, ihi, &scale[1], n, &vr[vr_offset], ldvr,
&ierr);
/* Normalize right eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wi[i__] == 0.f) {
scl = 1.f / snrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
sscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
} else if (wi[i__] > 0.f) {
r__1 = snrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
r__2 = snrm2_(n, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
scl = 1.f / slapy2_(&r__1, &r__2);
sscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
sscal_(n, &scl, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* Computing 2nd power */
r__1 = vr[k + i__ * vr_dim1];
/* Computing 2nd power */
r__2 = vr[k + (i__ + 1) * vr_dim1];
work[k] = r__1 * r__1 + r__2 * r__2;
/* L30: */
}
k = isamax_(n, &work[1], &c__1);
slartg_(&vr[k + i__ * vr_dim1], &vr[k + (i__ + 1) * vr_dim1],
&cs, &sn, &r__);
srot_(n, &vr[i__ * vr_dim1 + 1], &c__1, &vr[(i__ + 1) *
vr_dim1 + 1], &c__1, &cs, &sn);
vr[k + (i__ + 1) * vr_dim1] = 0.f;
}
/* L40: */
}
}
/* Undo scaling if necessary */
L50:
if (scalea) {
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[*info +
1], &i__2, &ierr);
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[*info +
1], &i__2, &ierr);
if (*info == 0) {
if ((wntsnv || wntsnb) && icond == 0) {
slascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &rcondv[
1], n, &ierr);
}
} else {
i__1 = *ilo - 1;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[1],
n, &ierr);
i__1 = *ilo - 1;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[1],
n, &ierr);
}
}
work[1] = (real) maxwrk;
return 0;
/* End of SGEEVX */
} /* sgeevx_ */
/* Subroutine */
int clatps_(char *uplo, char *trans, char *diag, char * normin, integer *n, complex *ap, complex *x, real *scale, real *cnorm, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
integer i__, j, ip;
real xj, rec, tjj;
integer jinc, jlen;
real xbnd;
integer imax;
real tmax;
complex tjjs;
real xmax, grow;
extern /* Complex */
VOID cdotc_f2c_(complex *, integer *, complex *, integer *, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */
int sscal_(integer *, real *, real *, integer *);
real tscal;
complex uscal;
integer jlast;
extern /* Complex */
VOID cdotu_f2c_(complex *, integer *, complex *, integer *, complex *, integer *);
complex csumj;
extern /* Subroutine */
int caxpy_(integer *, complex *, complex *, integer *, complex *, integer *);
logical upper;
extern /* Subroutine */
int ctpsv_(char *, char *, char *, integer *, complex *, complex *, integer *), slabad_( real *, real *);
extern integer icamax_(integer *, complex *, integer *);
extern /* Complex */
VOID cladiv_(complex *, complex *, complex *);
extern real slamch_(char *);
extern /* Subroutine */
int csscal_(integer *, real *, complex *, integer *), xerbla_(char *, integer *);
real bignum;
extern integer isamax_(integer *, real *, integer *);
extern real scasum_(integer *, complex *, integer *);
logical notran;
integer jfirst;
real smlnum;
logical nounit;
/* -- LAPACK auxiliary routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--cnorm;
--x;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
/* Test the input parameters. */
if (! upper && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (! notran && ! lsame_(trans, "T") && ! lsame_(trans, "C"))
{
*info = -2;
}
else if (! nounit && ! lsame_(diag, "U"))
{
*info = -3;
}
else if (! lsame_(normin, "Y") && ! lsame_(normin, "N"))
{
*info = -4;
}
else if (*n < 0)
{
*info = -5;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CLATPS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
/* Determine machine dependent parameters to control overflow. */
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum /= slamch_("Precision");
bignum = 1.f / smlnum;
*scale = 1.f;
if (lsame_(normin, "N"))
{
/* Compute the 1-norm of each column, not including the diagonal. */
if (upper)
{
/* A is upper triangular. */
ip = 1;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = j - 1;
cnorm[j] = scasum_(&i__2, &ap[ip], &c__1);
ip += j;
/* L10: */
}
}
else
{
/* A is lower triangular. */
ip = 1;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n - j;
cnorm[j] = scasum_(&i__2, &ap[ip + 1], &c__1);
ip = ip + *n - j + 1;
/* L20: */
}
cnorm[*n] = 0.f;
}
}
/* Scale the column norms by TSCAL if the maximum element in CNORM is */
/* greater than BIGNUM/2. */
imax = isamax_(n, &cnorm[1], &c__1);
tmax = cnorm[imax];
if (tmax <= bignum * .5f)
{
tscal = 1.f;
}
else
{
tscal = .5f / (smlnum * tmax);
sscal_(n, &tscal, &cnorm[1], &c__1);
}
/* Compute a bound on the computed solution vector to see if the */
/* Level 2 BLAS routine CTPSV can be used. */
xmax = 0.f;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MAX */
i__2 = j;
r__3 = xmax;
r__4 = (r__1 = x[i__2].r / 2.f, abs(r__1)) + (r__2 = r_imag(&x[j]) / 2.f, abs(r__2)); // , expr subst
xmax = max(r__3,r__4);
/* L30: */
}
xbnd = xmax;
if (notran)
{
/* Compute the growth in A * x = b. */
if (upper)
{
jfirst = *n;
jlast = 1;
jinc = -1;
}
else
{
jfirst = 1;
jlast = *n;
jinc = 1;
}
if (tscal != 1.f)
{
grow = 0.f;
goto L60;
}
if (nounit)
{
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
/* Initially, G(0) = max{
x(i), i=1,...,n}
. */
grow = .5f / max(xbnd,smlnum);
xbnd = grow;
ip = jfirst * (jfirst + 1) / 2;
jlen = *n;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst;
i__2 < 0 ? j >= i__1 : j <= i__1;
j += i__2)
{
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum)
{
goto L60;
}
i__3 = ip;
tjjs.r = ap[i__3].r;
tjjs.i = ap[i__3].i; // , expr subst
tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs( r__2));
if (tjj >= smlnum)
{
/* M(j) = G(j-1) / abs(A(j,j)) */
/* Computing MIN */
r__1 = xbnd;
r__2 = min(1.f,tjj) * grow; // , expr subst
xbnd = min(r__1,r__2);
}
else
{
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.f;
}
if (tjj + cnorm[j] >= smlnum)
{
/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */
grow *= tjj / (tjj + cnorm[j]);
}
else
{
/* G(j) could overflow, set GROW to 0. */
grow = 0.f;
}
ip += jinc * jlen;
--jlen;
/* L40: */
}
grow = xbnd;
}
else
{
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{
x(i), i=1,...,n}
. */
/* Computing MIN */
r__1 = 1.f;
r__2 = .5f / max(xbnd,smlnum); // , expr subst
grow = min(r__1,r__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst;
i__1 < 0 ? j >= i__2 : j <= i__2;
j += i__1)
{
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum)
{
goto L60;
}
/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
grow *= 1.f / (cnorm[j] + 1.f);
/* L50: */
}
}
L60:
;
}
else
{
/* Compute the growth in A**T * x = b or A**H * x = b. */
if (upper)
{
jfirst = 1;
jlast = *n;
jinc = 1;
}
else
{
jfirst = *n;
jlast = 1;
jinc = -1;
}
if (tscal != 1.f)
{
grow = 0.f;
goto L90;
}
if (nounit)
{
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
/* Initially, M(0) = max{
x(i), i=1,...,n}
. */
grow = .5f / max(xbnd,smlnum);
xbnd = grow;
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst;
i__2 < 0 ? j >= i__1 : j <= i__1;
j += i__2)
{
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum)
{
goto L90;
}
/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
xj = cnorm[j] + 1.f;
/* Computing MIN */
r__1 = grow;
r__2 = xbnd / xj; // , expr subst
grow = min(r__1,r__2);
i__3 = ip;
tjjs.r = ap[i__3].r;
tjjs.i = ap[i__3].i; // , expr subst
tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs( r__2));
if (tjj >= smlnum)
{
/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
if (xj > tjj)
{
xbnd *= tjj / xj;
}
}
else
{
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.f;
}
++jlen;
ip += jinc * jlen;
/* L70: */
}
grow = min(grow,xbnd);
}
else
{
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{
x(i), i=1,...,n}
. */
/* Computing MIN */
r__1 = 1.f;
r__2 = .5f / max(xbnd,smlnum); // , expr subst
grow = min(r__1,r__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst;
i__1 < 0 ? j >= i__2 : j <= i__2;
j += i__1)
{
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum)
{
goto L90;
}
/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
xj = cnorm[j] + 1.f;
grow /= xj;
/* L80: */
}
}
L90:
;
}
if (grow * tscal > smlnum)
{
/* Use the Level 2 BLAS solve if the reciprocal of the bound on */
/* elements of X is not too small. */
ctpsv_(uplo, trans, diag, n, &ap[1], &x[1], &c__1);
}
else
{
/* Use a Level 1 BLAS solve, scaling intermediate results. */
if (xmax > bignum * .5f)
{
/* Scale X so that its components are less than or equal to */
/* BIGNUM in absolute value. */
*scale = bignum * .5f / xmax;
csscal_(n, scale, &x[1], &c__1);
xmax = bignum;
}
else
{
xmax *= 2.f;
}
if (notran)
{
/* Solve A * x = b */
ip = jfirst * (jfirst + 1) / 2;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst;
i__2 < 0 ? j >= i__1 : j <= i__1;
j += i__2)
{
/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
i__3 = j;
xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]), abs(r__2));
if (nounit)
{
i__3 = ip;
q__1.r = tscal * ap[i__3].r;
q__1.i = tscal * ap[i__3].i; // , expr subst
tjjs.r = q__1.r;
tjjs.i = q__1.i; // , expr subst
}
else
{
tjjs.r = tscal;
tjjs.i = 0.f; // , expr subst
if (tscal == 1.f)
{
goto L105;
}
}
tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs( r__2));
if (tjj > smlnum)
{
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f)
{
if (xj > tjj * bignum)
{
/* Scale x by 1/b(j). */
rec = 1.f / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r;
x[i__3].i = q__1.i; // , expr subst
i__3 = j;
xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]) , abs(r__2));
}
else if (tjj > 0.f)
{
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum)
{
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */
/* to avoid overflow when dividing by A(j,j). */
rec = tjj * bignum / xj;
if (cnorm[j] > 1.f)
{
/* Scale by 1/CNORM(j) to avoid overflow when */
/* multiplying x(j) times column j. */
rec /= cnorm[j];
}
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r;
x[i__3].i = q__1.i; // , expr subst
i__3 = j;
xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]) , abs(r__2));
}
else
{
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0, and compute a solution to A*x = 0. */
i__3 = *n;
for (i__ = 1;
i__ <= i__3;
++i__)
{
i__4 = i__;
x[i__4].r = 0.f;
x[i__4].i = 0.f; // , expr subst
/* L100: */
}
i__3 = j;
x[i__3].r = 1.f;
x[i__3].i = 0.f; // , expr subst
xj = 1.f;
*scale = 0.f;
xmax = 0.f;
}
L105: /* Scale x if necessary to avoid overflow when adding a */
/* multiple of column j of A. */
if (xj > 1.f)
{
rec = 1.f / xj;
if (cnorm[j] > (bignum - xmax) * rec)
{
/* Scale x by 1/(2*abs(x(j))). */
rec *= .5f;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
}
else if (xj * cnorm[j] > bignum - xmax)
{
/* Scale x by 1/2. */
csscal_(n, &c_b36, &x[1], &c__1);
*scale *= .5f;
}
if (upper)
{
if (j > 1)
{
/* Compute the update */
/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */
i__3 = j - 1;
i__4 = j;
q__2.r = -x[i__4].r;
q__2.i = -x[i__4].i; // , expr subst
q__1.r = tscal * q__2.r;
q__1.i = tscal * q__2.i; // , expr subst
caxpy_(&i__3, &q__1, &ap[ip - j + 1], &c__1, &x[1], & c__1);
i__3 = j - 1;
i__ = icamax_(&i__3, &x[1], &c__1);
i__3 = i__;
xmax = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag( &x[i__]), abs(r__2));
}
ip -= j;
}
else
{
if (j < *n)
{
/* Compute the update */
/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */
i__3 = *n - j;
i__4 = j;
q__2.r = -x[i__4].r;
q__2.i = -x[i__4].i; // , expr subst
q__1.r = tscal * q__2.r;
q__1.i = tscal * q__2.i; // , expr subst
caxpy_(&i__3, &q__1, &ap[ip + 1], &c__1, &x[j + 1], & c__1);
i__3 = *n - j;
i__ = j + icamax_(&i__3, &x[j + 1], &c__1);
i__3 = i__;
xmax = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag( &x[i__]), abs(r__2));
}
ip = ip + *n - j + 1;
}
/* L110: */
}
}
else if (lsame_(trans, "T"))
{
/* Solve A**T * x = b */
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
i__2 = jlast;
i__1 = jinc;
for (j = jfirst;
i__1 < 0 ? j >= i__2 : j <= i__2;
j += i__1)
{
/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
/* k<>j */
i__3 = j;
xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]), abs(r__2));
uscal.r = tscal;
uscal.i = 0.f; // , expr subst
rec = 1.f / max(xmax,1.f);
if (cnorm[j] > (bignum - xj) * rec)
{
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5f;
if (nounit)
{
i__3 = ip;
q__1.r = tscal * ap[i__3].r;
q__1.i = tscal * ap[i__3] .i; // , expr subst
tjjs.r = q__1.r;
tjjs.i = q__1.i; // , expr subst
}
else
{
tjjs.r = tscal;
tjjs.i = 0.f; // , expr subst
}
tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs(r__2));
if (tjj > 1.f)
{
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
r__1 = 1.f;
r__2 = rec * tjj; // , expr subst
rec = min(r__1,r__2);
cladiv_(&q__1, &uscal, &tjjs);
uscal.r = q__1.r;
uscal.i = q__1.i; // , expr subst
}
if (rec < 1.f)
{
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0.f;
csumj.i = 0.f; // , expr subst
if (uscal.r == 1.f && uscal.i == 0.f)
{
/* If the scaling needed for A in the dot product is 1, */
/* call CDOTU to perform the dot product. */
if (upper)
{
i__3 = j - 1;
cdotu_f2c_(&q__1, &i__3, &ap[ip - j + 1], &c__1, &x[1], & c__1);
csumj.r = q__1.r;
csumj.i = q__1.i; // , expr subst
}
else if (j < *n)
{
i__3 = *n - j;
cdotu_f2c_(&q__1, &i__3, &ap[ip + 1], &c__1, &x[j + 1], & c__1);
csumj.r = q__1.r;
csumj.i = q__1.i; // , expr subst
}
}
else
{
/* Otherwise, use in-line code for the dot product. */
if (upper)
{
i__3 = j - 1;
for (i__ = 1;
i__ <= i__3;
++i__)
{
i__4 = ip - j + i__;
q__3.r = ap[i__4].r * uscal.r - ap[i__4].i * uscal.i;
q__3.i = ap[i__4].r * uscal.i + ap[i__4].i * uscal.r; // , expr subst
i__5 = i__;
q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i;
q__2.i = q__3.r * x[i__5].i + q__3.i * x[ i__5].r; // , expr subst
q__1.r = csumj.r + q__2.r;
q__1.i = csumj.i + q__2.i; // , expr subst
csumj.r = q__1.r;
csumj.i = q__1.i; // , expr subst
/* L120: */
}
}
else if (j < *n)
{
i__3 = *n - j;
for (i__ = 1;
i__ <= i__3;
++i__)
{
i__4 = ip + i__;
q__3.r = ap[i__4].r * uscal.r - ap[i__4].i * uscal.i;
q__3.i = ap[i__4].r * uscal.i + ap[i__4].i * uscal.r; // , expr subst
i__5 = j + i__;
q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i;
q__2.i = q__3.r * x[i__5].i + q__3.i * x[ i__5].r; // , expr subst
q__1.r = csumj.r + q__2.r;
q__1.i = csumj.i + q__2.i; // , expr subst
csumj.r = q__1.r;
csumj.i = q__1.i; // , expr subst
/* L130: */
}
}
}
q__1.r = tscal;
q__1.i = 0.f; // , expr subst
if (uscal.r == q__1.r && uscal.i == q__1.i)
{
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
/* was not used to scale the dotproduct. */
i__3 = j;
i__4 = j;
q__1.r = x[i__4].r - csumj.r;
q__1.i = x[i__4].i - csumj.i; // , expr subst
x[i__3].r = q__1.r;
x[i__3].i = q__1.i; // , expr subst
i__3 = j;
xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]) , abs(r__2));
if (nounit)
{
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
i__3 = ip;
q__1.r = tscal * ap[i__3].r;
q__1.i = tscal * ap[i__3] .i; // , expr subst
tjjs.r = q__1.r;
tjjs.i = q__1.i; // , expr subst
}
else
{
tjjs.r = tscal;
tjjs.i = 0.f; // , expr subst
if (tscal == 1.f)
{
goto L145;
}
}
tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs(r__2));
if (tjj > smlnum)
{
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f)
{
if (xj > tjj * bignum)
{
/* Scale X by 1/abs(x(j)). */
rec = 1.f / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r;
x[i__3].i = q__1.i; // , expr subst
}
else if (tjj > 0.f)
{
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum)
{
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r;
x[i__3].i = q__1.i; // , expr subst
}
else
{
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0 and compute a solution to A**T *x = 0. */
i__3 = *n;
for (i__ = 1;
i__ <= i__3;
++i__)
{
i__4 = i__;
x[i__4].r = 0.f;
x[i__4].i = 0.f; // , expr subst
/* L140: */
}
i__3 = j;
x[i__3].r = 1.f;
x[i__3].i = 0.f; // , expr subst
*scale = 0.f;
xmax = 0.f;
}
L145:
;
}
else
{
/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
/* product has already been divided by 1/A(j,j). */
i__3 = j;
cladiv_(&q__2, &x[j], &tjjs);
q__1.r = q__2.r - csumj.r;
q__1.i = q__2.i - csumj.i; // , expr subst
x[i__3].r = q__1.r;
x[i__3].i = q__1.i; // , expr subst
}
/* Computing MAX */
i__3 = j;
r__3 = xmax;
r__4 = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]), abs(r__2)); // , expr subst
xmax = max(r__3,r__4);
++jlen;
ip += jinc * jlen;
/* L150: */
}
}
else
{
/* Solve A**H * x = b */
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst;
i__2 < 0 ? j >= i__1 : j <= i__1;
j += i__2)
{
/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
/* k<>j */
i__3 = j;
xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]), abs(r__2));
uscal.r = tscal;
uscal.i = 0.f; // , expr subst
rec = 1.f / max(xmax,1.f);
if (cnorm[j] > (bignum - xj) * rec)
{
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5f;
if (nounit)
{
r_cnjg(&q__2, &ap[ip]);
q__1.r = tscal * q__2.r;
q__1.i = tscal * q__2.i; // , expr subst
tjjs.r = q__1.r;
tjjs.i = q__1.i; // , expr subst
}
else
{
tjjs.r = tscal;
tjjs.i = 0.f; // , expr subst
}
tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs(r__2));
if (tjj > 1.f)
{
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
r__1 = 1.f;
r__2 = rec * tjj; // , expr subst
rec = min(r__1,r__2);
cladiv_(&q__1, &uscal, &tjjs);
uscal.r = q__1.r;
uscal.i = q__1.i; // , expr subst
}
if (rec < 1.f)
{
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0.f;
csumj.i = 0.f; // , expr subst
if (uscal.r == 1.f && uscal.i == 0.f)
{
/* If the scaling needed for A in the dot product is 1, */
/* call CDOTC to perform the dot product. */
if (upper)
{
i__3 = j - 1;
cdotc_f2c_(&q__1, &i__3, &ap[ip - j + 1], &c__1, &x[1], & c__1);
csumj.r = q__1.r;
csumj.i = q__1.i; // , expr subst
}
else if (j < *n)
{
i__3 = *n - j;
cdotc_f2c_(&q__1, &i__3, &ap[ip + 1], &c__1, &x[j + 1], & c__1);
csumj.r = q__1.r;
csumj.i = q__1.i; // , expr subst
}
}
else
{
/* Otherwise, use in-line code for the dot product. */
if (upper)
{
i__3 = j - 1;
for (i__ = 1;
i__ <= i__3;
++i__)
{
r_cnjg(&q__4, &ap[ip - j + i__]);
q__3.r = q__4.r * uscal.r - q__4.i * uscal.i;
q__3.i = q__4.r * uscal.i + q__4.i * uscal.r; // , expr subst
i__4 = i__;
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; // , expr subst
q__1.r = csumj.r + q__2.r;
q__1.i = csumj.i + q__2.i; // , expr subst
csumj.r = q__1.r;
csumj.i = q__1.i; // , expr subst
/* L160: */
}
}
else if (j < *n)
{
i__3 = *n - j;
for (i__ = 1;
i__ <= i__3;
++i__)
{
r_cnjg(&q__4, &ap[ip + i__]);
q__3.r = q__4.r * uscal.r - q__4.i * uscal.i;
q__3.i = q__4.r * uscal.i + q__4.i * uscal.r; // , expr subst
i__4 = j + i__;
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; // , expr subst
q__1.r = csumj.r + q__2.r;
q__1.i = csumj.i + q__2.i; // , expr subst
csumj.r = q__1.r;
csumj.i = q__1.i; // , expr subst
/* L170: */
}
}
}
q__1.r = tscal;
q__1.i = 0.f; // , expr subst
if (uscal.r == q__1.r && uscal.i == q__1.i)
{
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
/* was not used to scale the dotproduct. */
i__3 = j;
i__4 = j;
q__1.r = x[i__4].r - csumj.r;
q__1.i = x[i__4].i - csumj.i; // , expr subst
x[i__3].r = q__1.r;
x[i__3].i = q__1.i; // , expr subst
i__3 = j;
xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]) , abs(r__2));
if (nounit)
{
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
r_cnjg(&q__2, &ap[ip]);
q__1.r = tscal * q__2.r;
q__1.i = tscal * q__2.i; // , expr subst
tjjs.r = q__1.r;
tjjs.i = q__1.i; // , expr subst
}
else
{
tjjs.r = tscal;
tjjs.i = 0.f; // , expr subst
if (tscal == 1.f)
{
goto L185;
}
}
tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs(r__2));
if (tjj > smlnum)
{
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f)
{
if (xj > tjj * bignum)
{
/* Scale X by 1/abs(x(j)). */
rec = 1.f / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r;
x[i__3].i = q__1.i; // , expr subst
}
else if (tjj > 0.f)
{
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum)
{
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r;
x[i__3].i = q__1.i; // , expr subst
}
else
{
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0 and compute a solution to A**H *x = 0. */
i__3 = *n;
for (i__ = 1;
i__ <= i__3;
++i__)
{
i__4 = i__;
x[i__4].r = 0.f;
x[i__4].i = 0.f; // , expr subst
/* L180: */
}
i__3 = j;
x[i__3].r = 1.f;
x[i__3].i = 0.f; // , expr subst
*scale = 0.f;
xmax = 0.f;
}
L185:
;
}
else
{
/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
/* product has already been divided by 1/A(j,j). */
i__3 = j;
cladiv_(&q__2, &x[j], &tjjs);
q__1.r = q__2.r - csumj.r;
q__1.i = q__2.i - csumj.i; // , expr subst
x[i__3].r = q__1.r;
x[i__3].i = q__1.i; // , expr subst
}
/* Computing MAX */
i__3 = j;
r__3 = xmax;
r__4 = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]), abs(r__2)); // , expr subst
xmax = max(r__3,r__4);
++jlen;
ip += jinc * jlen;
/* L190: */
}
}
*scale /= tscal;
}
/* Scale the column norms by 1/TSCAL for return. */
if (tscal != 1.f)
{
r__1 = 1.f / tscal;
sscal_(n, &r__1, &cnorm[1], &c__1);
}
return 0;
/* End of CLATPS */
}
int sspevx_(char *jobz, char *range, char *uplo, int *n,
float *ap, float *vl, float *vu, int *il, int *iu, float *abstol,
int *m, float *w, float *z__, int *ldz, float *work, int *
iwork, int *ifail, int *info)
{
/* System generated locals */
int z_dim1, z_offset, i__1, i__2;
float r__1, r__2;
/* Builtin functions */
double sqrt(double);
/* Local variables */
int i__, j, jj;
float eps, vll, vuu, tmp1;
int indd, inde;
float anrm;
int imax;
float rmin, rmax;
int test;
int itmp1, indee;
float sigma;
extern int lsame_(char *, char *);
int iinfo;
extern int sscal_(int *, float *, float *, int *);
char order[1];
extern int scopy_(int *, float *, int *, float *,
int *), sswap_(int *, float *, int *, float *, int *
);
int wantz, alleig, indeig;
int iscale, indibl;
int valeig;
extern double slamch_(char *);
float safmin;
extern int xerbla_(char *, int *);
float abstll, bignum;
int indtau, indisp, indiwo, indwrk;
extern double slansp_(char *, char *, int *, float *, float *);
extern int sstein_(int *, float *, float *, int *,
float *, int *, int *, float *, int *, float *, int *
, int *, int *), ssterf_(int *, float *, float *,
int *);
int nsplit;
extern int sstebz_(char *, char *, int *, float *,
float *, int *, int *, float *, float *, float *, int *,
int *, float *, int *, int *, float *, int *,
int *);
float smlnum;
extern int sopgtr_(char *, int *, float *, float *,
float *, int *, float *, int *), ssptrd_(char *,
int *, float *, float *, float *, float *, int *),
ssteqr_(char *, int *, float *, float *, float *, int *,
float *, int *), sopmtr_(char *, char *, char *,
int *, int *, float *, float *, float *, int *, float *,
int *);
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SSPEVX computes selected eigenvalues and, optionally, eigenvectors */
/* of a float symmetric matrix A in packed storage. Eigenvalues/vectors */
/* can be selected by specifying either a range of values or a range of */
/* indices for the desired eigenvalues. */
/* Arguments */
/* ========= */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* RANGE (input) CHARACTER*1 */
/* = 'A': all eigenvalues will be found; */
/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
/* will be found; */
/* = 'I': the IL-th through IU-th eigenvalues will be found. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input/output) REAL array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the symmetric matrix */
/* A, packed columnwise in a linear array. The j-th column of A */
/* is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
/* On exit, AP is overwritten by values generated during the */
/* reduction to tridiagonal form. If UPLO = 'U', the diagonal */
/* and first superdiagonal of the tridiagonal matrix T overwrite */
/* the corresponding elements of A, and if UPLO = 'L', the */
/* diagonal and first subdiagonal of T overwrite the */
/* corresponding elements of A. */
/* VL (input) REAL */
/* VU (input) REAL */
/* If RANGE='V', the lower and upper bounds of the interval to */
/* be searched for eigenvalues. VL < VU. */
/* Not referenced if RANGE = 'A' or 'I'. */
/* IL (input) INTEGER */
/* IU (input) INTEGER */
/* If RANGE='I', the indices (in ascending order) of the */
/* smallest and largest eigenvalues to be returned. */
/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
/* Not referenced if RANGE = 'A' or 'V'. */
/* ABSTOL (input) REAL */
/* The absolute error tolerance for the eigenvalues. */
/* An approximate eigenvalue is accepted as converged */
/* when it is determined to lie in an interval [a,b] */
/* of width less than or equal to */
/* ABSTOL + EPS * MAX( |a|,|b| ) , */
/* where EPS is the machine precision. If ABSTOL is less than */
/* or equal to zero, then EPS*|T| will be used in its place, */
/* where |T| is the 1-norm of the tridiagonal matrix obtained */
/* by reducing AP to tridiagonal form. */
/* Eigenvalues will be computed most accurately when ABSTOL is */
/* set to twice the underflow threshold 2*SLAMCH('S'), not zero. */
/* If this routine returns with INFO>0, indicating that some */
/* eigenvectors did not converge, try setting ABSTOL to */
/* 2*SLAMCH('S'). */
/* See "Computing Small Singular Values of Bidiagonal Matrices */
/* with Guaranteed High Relative Accuracy," by Demmel and */
/* Kahan, LAPACK Working Note #3. */
/* M (output) INTEGER */
/* The total number of eigenvalues found. 0 <= M <= N. */
/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
/* W (output) REAL array, dimension (N) */
/* If INFO = 0, the selected eigenvalues in ascending order. */
/* Z (output) REAL array, dimension (LDZ, MAX(1,M)) */
/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
/* contain the orthonormal eigenvectors of the matrix A */
/* corresponding to the selected eigenvalues, with the i-th */
/* column of Z holding the eigenvector associated with W(i). */
/* If an eigenvector fails to converge, then that column of Z */
/* contains the latest approximation to the eigenvector, and the */
/* index of the eigenvector is returned in IFAIL. */
/* If JOBZ = 'N', then Z is not referenced. */
/* Note: the user must ensure that at least MAX(1,M) columns are */
/* supplied in the array Z; if RANGE = 'V', the exact value of M */
/* is not known in advance and an upper bound must be used. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= MAX(1,N). */
/* WORK (workspace) REAL array, dimension (8*N) */
/* IWORK (workspace) INTEGER array, dimension (5*N) */
/* IFAIL (output) INTEGER array, dimension (N) */
/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
/* indices of the eigenvectors that failed to converge. */
/* If JOBZ = 'N', then IFAIL is not referenced. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, then i eigenvectors failed to converge. */
/* Their indices are stored in array IFAIL. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--iwork;
--ifail;
/* Function Body */
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (! (lsame_(uplo, "L") || lsame_(uplo,
"U"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else {
if (valeig) {
if (*n > 0 && *vu <= *vl) {
*info = -7;
}
} else if (indeig) {
if (*il < 1 || *il > MAX(1,*n)) {
*info = -8;
} else if (*iu < MIN(*n,*il) || *iu > *n) {
*info = -9;
}
}
}
if (*info == 0) {
if (*ldz < 1 || wantz && *ldz < *n) {
*info = -14;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSPEVX", &i__1);
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (alleig || indeig) {
*m = 1;
w[1] = ap[1];
} else {
if (*vl < ap[1] && *vu >= ap[1]) {
*m = 1;
w[1] = ap[1];
}
}
if (wantz) {
z__[z_dim1 + 1] = 1.f;
}
return 0;
}
/* Get machine constants. */
safmin = slamch_("Safe minimum");
eps = slamch_("Precision");
smlnum = safmin / eps;
bignum = 1.f / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin));
rmax = MIN(r__1,r__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
abstll = *abstol;
if (valeig) {
vll = *vl;
vuu = *vu;
} else {
vll = 0.f;
vuu = 0.f;
}
anrm = slansp_("M", uplo, n, &ap[1], &work[1]);
if (anrm > 0.f && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
i__1 = *n * (*n + 1) / 2;
sscal_(&i__1, &sigma, &ap[1], &c__1);
if (*abstol > 0.f) {
abstll = *abstol * sigma;
}
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Call SSPTRD to reduce symmetric packed matrix to tridiagonal form. */
indtau = 1;
inde = indtau + *n;
indd = inde + *n;
indwrk = indd + *n;
ssptrd_(uplo, n, &ap[1], &work[indd], &work[inde], &work[indtau], &iinfo);
/* If all eigenvalues are desired and ABSTOL is less than or equal */
/* to zero, then call SSTERF or SOPGTR and SSTEQR. If this fails */
/* for some eigenvalue, then try SSTEBZ. */
test = FALSE;
if (indeig) {
if (*il == 1 && *iu == *n) {
test = TRUE;
}
}
if ((alleig || test) && *abstol <= 0.f) {
scopy_(n, &work[indd], &c__1, &w[1], &c__1);
indee = indwrk + (*n << 1);
if (! wantz) {
i__1 = *n - 1;
scopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
ssterf_(n, &w[1], &work[indee], info);
} else {
sopgtr_(uplo, n, &ap[1], &work[indtau], &z__[z_offset], ldz, &
work[indwrk], &iinfo);
i__1 = *n - 1;
scopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
ssteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[
indwrk], info);
if (*info == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
ifail[i__] = 0;
/* L10: */
}
}
}
if (*info == 0) {
*m = *n;
goto L20;
}
*info = 0;
}
/* Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
indibl = 1;
indisp = indibl + *n;
indiwo = indisp + *n;
sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[
inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[
indwrk], &iwork[indiwo], info);
if (wantz) {
sstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[
indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &
ifail[1], info);
/* Apply orthogonal matrix used in reduction to tridiagonal */
/* form to eigenvectors returned by SSTEIN. */
sopmtr_("L", uplo, "N", n, m, &ap[1], &work[indtau], &z__[z_offset],
ldz, &work[indwrk], &iinfo);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
L20:
if (iscale == 1) {
if (*info == 0) {
imax = *m;
} else {
imax = *info - 1;
}
r__1 = 1.f / sigma;
sscal_(&imax, &r__1, &w[1], &c__1);
}
/* If eigenvalues are not in order, then sort them, along with */
/* eigenvectors. */
if (wantz) {
i__1 = *m - 1;
for (j = 1; j <= i__1; ++j) {
i__ = 0;
tmp1 = w[j];
i__2 = *m;
for (jj = j + 1; jj <= i__2; ++jj) {
if (w[jj] < tmp1) {
i__ = jj;
tmp1 = w[jj];
}
/* L30: */
}
if (i__ != 0) {
itmp1 = iwork[indibl + i__ - 1];
w[i__] = w[j];
iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
w[j] = tmp1;
iwork[indibl + j - 1] = itmp1;
sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
&c__1);
if (*info != 0) {
itmp1 = ifail[i__];
ifail[i__] = ifail[j];
ifail[j] = itmp1;
}
}
/* L40: */
}
}
return 0;
/* End of SSPEVX */
} /* sspevx_ */
/* Subroutine */ int sspgst_(integer *itype, char *uplo, integer *n, real *ap,
real *bp, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
SSPGST reduces a real symmetric-definite generalized eigenproblem
to standard form, using packed storage.
If ITYPE = 1, the problem is A*x = lambda*B*x,
and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)
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**T or L**T*A*L.
B must have been previously factorized as U**T*U or L*L**T by SPPTRF.
Arguments
=========
ITYPE (input) INTEGER
= 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);
= 2 or 3: compute U*A*U**T or L**T*A*L.
UPLO (input) CHARACTER
= 'U': Upper triangle of A is stored and B is factored as
U**T*U;
= 'L': Lower triangle of A is stored and B is factored as
L*L**T.
N (input) INTEGER
The order of the matrices A and B. N >= 0.
AP (input/output) REAL array, dimension (N*(N+1)/2)
On entry, the upper or lower triangle of the symmetric matrix
A, packed columnwise in a linear array. The j-th column of A
is stored in the array AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
On exit, if INFO = 0, the transformed matrix, stored in the
same format as A.
BP (input) REAL array, dimension (N*(N+1)/2)
The triangular factor from the Cholesky factorization of B,
stored in the same format as A, as returned by SPPTRF.
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;
static real c_b9 = -1.f;
static real c_b11 = 1.f;
/* System generated locals */
integer i__1, i__2;
real r__1;
/* Local variables */
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
extern /* Subroutine */ int sspr2_(char *, integer *, real *, real *,
integer *, real *, integer *, real *);
static integer j, k;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static logical upper;
static integer j1, k1;
extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
real *, integer *), sspmv_(char *, integer *, real *, real *,
real *, integer *, real *, real *, integer *), stpmv_(
char *, char *, char *, integer *, real *, real *, integer *), stpsv_(char *, char *, char *, integer *,
real *, real *, integer *);
static integer jj, kk;
static real ct;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real ajj;
static integer j1j1;
static real akk;
static integer k1k1;
static real bjj, bkk;
--bp;
--ap;
/* 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;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSPGST", &i__1);
return 0;
}
if (*itype == 1) {
if (upper) {
/* Compute inv(U')*A*inv(U)
J1 and JJ are the indices of A(1,j) and A(j,j) */
jj = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
j1 = jj + 1;
jj += j;
/* Compute the j-th column of the upper triangle of A */
bjj = bp[jj];
stpsv_(uplo, "Transpose", "Nonunit", &j, &bp[1], &ap[j1], &
c__1);
i__2 = j - 1;
sspmv_(uplo, &i__2, &c_b9, &ap[1], &bp[j1], &c__1, &c_b11, &
ap[j1], &c__1);
i__2 = j - 1;
r__1 = 1.f / bjj;
sscal_(&i__2, &r__1, &ap[j1], &c__1);
i__2 = j - 1;
ap[jj] = (ap[jj] - sdot_(&i__2, &ap[j1], &c__1, &bp[j1], &
c__1)) / bjj;
/* L10: */
}
} else {
/* Compute inv(L)*A*inv(L')
KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) */
kk = 1;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
k1k1 = kk + *n - k + 1;
/* Update the lower triangle of A(k:n,k:n) */
akk = ap[kk];
bkk = bp[kk];
/* Computing 2nd power */
r__1 = bkk;
akk /= r__1 * r__1;
ap[kk] = akk;
if (k < *n) {
i__2 = *n - k;
r__1 = 1.f / bkk;
sscal_(&i__2, &r__1, &ap[kk + 1], &c__1);
ct = akk * -.5f;
i__2 = *n - k;
saxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
;
i__2 = *n - k;
sspr2_(uplo, &i__2, &c_b9, &ap[kk + 1], &c__1, &bp[kk + 1]
, &c__1, &ap[k1k1]);
i__2 = *n - k;
saxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
;
i__2 = *n - k;
stpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1],
&ap[kk + 1], &c__1);
}
kk = k1k1;
/* L20: */
}
}
} else {
if (upper) {
/* Compute U*A*U'
K1 and KK are the indices of A(1,k) and A(k,k) */
kk = 0;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
k1 = kk + 1;
kk += k;
/* Update the upper triangle of A(1:k,1:k) */
akk = ap[kk];
bkk = bp[kk];
i__2 = k - 1;
stpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[
k1], &c__1);
ct = akk * .5f;
i__2 = k - 1;
saxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
sspr2_(uplo, &i__2, &c_b11, &ap[k1], &c__1, &bp[k1], &c__1, &
ap[1]);
i__2 = k - 1;
saxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
sscal_(&i__2, &bkk, &ap[k1], &c__1);
/* Computing 2nd power */
r__1 = bkk;
ap[kk] = akk * (r__1 * r__1);
/* L30: */
}
} else {
/* Compute L'*A*L
JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) */
jj = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
j1j1 = jj + *n - j + 1;
/* Compute the j-th column of the lower triangle of A */
ajj = ap[jj];
bjj = bp[jj];
i__2 = *n - j;
ap[jj] = ajj * bjj + sdot_(&i__2, &ap[jj + 1], &c__1, &bp[jj
+ 1], &c__1);
i__2 = *n - j;
sscal_(&i__2, &bjj, &ap[jj + 1], &c__1);
i__2 = *n - j;
sspmv_(uplo, &i__2, &c_b11, &ap[j1j1], &bp[jj + 1], &c__1, &
c_b11, &ap[jj + 1], &c__1);
i__2 = *n - j + 1;
stpmv_(uplo, "Transpose", "Non-unit", &i__2, &bp[jj], &ap[jj],
&c__1);
jj = j1j1;
/* L40: */
}
}
}
return 0;
/* End of SSPGST */
} /* sspgst_ */
/* Subroutine */ int sorgr2_(integer *m, integer *n, integer *k, real *a,
integer *lda, real *tau, real *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
real r__1;
/* Local variables */
integer i__, j, l, ii;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
slarf_(char *, integer *, integer *, real *, integer *, real *,
real *, integer *, real *), xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SORGR2 generates an m by n real matrix Q with orthonormal rows, */
/* which is defined as the last m rows of a product of k elementary */
/* reflectors of order n */
/* Q = H(1) H(2) . . . H(k) */
/* as returned by SGERQF. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix Q. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix Q. N >= M. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines the */
/* matrix Q. M >= K >= 0. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the (m-k+i)-th row must contain the vector which */
/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
/* returned by SGERQF in the last k rows of its array argument */
/* A. */
/* On exit, the m by n matrix Q. */
/* LDA (input) INTEGER */
/* The first dimension of the array A. LDA >= max(1,M). */
/* TAU (input) REAL array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by SGERQF. */
/* WORK (workspace) REAL array, dimension (M) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument has an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < *m) {
*info = -2;
} else if (*k < 0 || *k > *m) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SORGR2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m <= 0) {
return 0;
}
if (*k < *m) {
/* Initialise rows 1:m-k to rows of the unit matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m - *k;
for (l = 1; l <= i__2; ++l) {
a[l + j * a_dim1] = 0.f;
/* L10: */
}
if (j > *n - *m && j <= *n - *k) {
a[*m - *n + j + j * a_dim1] = 1.f;
}
/* L20: */
}
}
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
ii = *m - *k + i__;
/* Apply H(i) to A(1:m-k+i,1:n-k+i) from the right */
a[ii + (*n - *m + ii) * a_dim1] = 1.f;
i__2 = ii - 1;
i__3 = *n - *m + ii;
slarf_("Right", &i__2, &i__3, &a[ii + a_dim1], lda, &tau[i__], &a[
a_offset], lda, &work[1]);
i__2 = *n - *m + ii - 1;
r__1 = -tau[i__];
sscal_(&i__2, &r__1, &a[ii + a_dim1], lda);
a[ii + (*n - *m + ii) * a_dim1] = 1.f - tau[i__];
/* Set A(m-k+i,n-k+i+1:n) to zero */
i__2 = *n;
for (l = *n - *m + ii + 1; l <= i__2; ++l) {
a[ii + l * a_dim1] = 0.f;
/* L30: */
}
/* L40: */
}
return 0;
/* End of SORGR2 */
} /* sorgr2_ */
/* Subroutine */ int slabrd_(integer *m, integer *n, integer *nb, real *a,
integer *lda, real *d__, real *e, real *tauq, real *taup, real *x,
integer *ldx, real *y, integer *ldy)
{
/* -- 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
=======
SLABRD reduces the first NB rows and columns of a real general
m by n matrix A to upper or lower bidiagonal form by an orthogonal
transformation Q' * A * P, and returns the matrices X and Y which
are needed to apply the transformation to the unreduced part of A.
If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower
bidiagonal form.
This is an auxiliary routine called by SGEBRD
Arguments
=========
M (input) INTEGER
The number of rows in the matrix A.
N (input) INTEGER
The number of columns in the matrix A.
NB (input) INTEGER
The number of leading rows and columns of A to be reduced.
A (input/output) REAL array, dimension (LDA,N)
On entry, the m by n general matrix to be reduced.
On exit, the first NB rows and columns of the matrix are
overwritten; the rest of the array is unchanged.
If m >= n, elements on and below the diagonal in the first NB
columns, with the array TAUQ, represent the orthogonal
matrix Q as a product of elementary reflectors; and
elements above the diagonal in the first NB rows, with the
array TAUP, represent the orthogonal matrix P as a product
of elementary reflectors.
If m < n, elements below the diagonal in the first NB
columns, with the array TAUQ, represent the orthogonal
matrix Q as a product of elementary reflectors, and
elements on and above the diagonal in the first NB rows,
with the array TAUP, represent the orthogonal matrix P as
a product of elementary reflectors.
See Further Details.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
D (output) REAL array, dimension (NB)
The diagonal elements of the first NB rows and columns of
the reduced matrix. D(i) = A(i,i).
E (output) REAL array, dimension (NB)
The off-diagonal elements of the first NB rows and columns of
the reduced matrix.
TAUQ (output) REAL array dimension (NB)
The scalar factors of the elementary reflectors which
represent the orthogonal matrix Q. See Further Details.
TAUP (output) REAL array, dimension (NB)
The scalar factors of the elementary reflectors which
represent the orthogonal matrix P. See Further Details.
X (output) REAL array, dimension (LDX,NB)
The m-by-nb matrix X required to update the unreduced part
of A.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= M.
Y (output) REAL array, dimension (LDY,NB)
The n-by-nb matrix Y required to update the unreduced part
of A.
LDY (output) INTEGER
The leading dimension of the array Y. LDY >= N.
Further Details
===============
The matrices Q and P are represented as products of elementary
reflectors:
Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb)
Each H(i) and G(i) has the form:
H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
where tauq and taup are real scalars, and v and u are real vectors.
If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in
A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in
A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in
A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in
A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
The elements of the vectors v and u together form the m-by-nb matrix
V and the nb-by-n matrix U' which are needed, with X and Y, to apply
the transformation to the unreduced part of the matrix, using a block
update of the form: A := A - V*Y' - X*U'.
The contents of A on exit are illustrated by the following examples
with nb = 2:
m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 )
( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 )
( v1 v2 a a a ) ( v1 1 a a a a )
( v1 v2 a a a ) ( v1 v2 a a a a )
( v1 v2 a a a ) ( v1 v2 a a a a )
( v1 v2 a a a )
where a denotes an element of the original matrix which is unchanged,
vi denotes an element of the vector defining H(i), and ui an element
of the vector defining G(i).
=====================================================================
Quick return if possible
Parameter adjustments */
/* Table of constant values */
static real c_b4 = -1.f;
static real c_b5 = 1.f;
static integer c__1 = 1;
static real c_b16 = 0.f;
/* System generated locals */
integer a_dim1, a_offset, x_dim1, x_offset, y_dim1, y_offset, i__1, i__2,
i__3;
/* Local variables */
static integer i__;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
sgemv_(char *, integer *, integer *, real *, real *, integer *,
real *, integer *, real *, real *, integer *), slarfg_(
integer *, real *, real *, integer *, real *);
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define x_ref(a_1,a_2) x[(a_2)*x_dim1 + a_1]
#define y_ref(a_1,a_2) y[(a_2)*y_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--d__;
--e;
--tauq;
--taup;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1 * 1;
y -= y_offset;
/* Function Body */
if (*m <= 0 || *n <= 0) {
return 0;
}
if (*m >= *n) {
/* Reduce to upper bidiagonal form */
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i:m,i) */
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
sgemv_("No transpose", &i__2, &i__3, &c_b4, &a_ref(i__, 1), lda, &
y_ref(i__, 1), ldy, &c_b5, &a_ref(i__, i__), &c__1);
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
sgemv_("No transpose", &i__2, &i__3, &c_b4, &x_ref(i__, 1), ldx, &
a_ref(1, i__), &c__1, &c_b5, &a_ref(i__, i__), &c__1);
/* Generate reflection Q(i) to annihilate A(i+1:m,i)
Computing MIN */
i__2 = i__ + 1;
i__3 = *m - i__ + 1;
slarfg_(&i__3, &a_ref(i__, i__), &a_ref(min(i__2,*m), i__), &c__1,
&tauq[i__]);
d__[i__] = a_ref(i__, i__);
if (i__ < *n) {
a_ref(i__, i__) = 1.f;
/* Compute Y(i+1:n,i) */
i__2 = *m - i__ + 1;
i__3 = *n - i__;
sgemv_("Transpose", &i__2, &i__3, &c_b5, &a_ref(i__, i__ + 1),
lda, &a_ref(i__, i__), &c__1, &c_b16, &y_ref(i__ + 1,
i__), &c__1);
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
sgemv_("Transpose", &i__2, &i__3, &c_b5, &a_ref(i__, 1), lda,
&a_ref(i__, i__), &c__1, &c_b16, &y_ref(1, i__), &
c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
sgemv_("No transpose", &i__2, &i__3, &c_b4, &y_ref(i__ + 1, 1)
, ldy, &y_ref(1, i__), &c__1, &c_b5, &y_ref(i__ + 1,
i__), &c__1);
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
sgemv_("Transpose", &i__2, &i__3, &c_b5, &x_ref(i__, 1), ldx,
&a_ref(i__, i__), &c__1, &c_b16, &y_ref(1, i__), &
c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
sgemv_("Transpose", &i__2, &i__3, &c_b4, &a_ref(1, i__ + 1),
lda, &y_ref(1, i__), &c__1, &c_b5, &y_ref(i__ + 1,
i__), &c__1);
i__2 = *n - i__;
sscal_(&i__2, &tauq[i__], &y_ref(i__ + 1, i__), &c__1);
/* Update A(i,i+1:n) */
i__2 = *n - i__;
sgemv_("No transpose", &i__2, &i__, &c_b4, &y_ref(i__ + 1, 1),
ldy, &a_ref(i__, 1), lda, &c_b5, &a_ref(i__, i__ + 1)
, lda);
i__2 = i__ - 1;
i__3 = *n - i__;
sgemv_("Transpose", &i__2, &i__3, &c_b4, &a_ref(1, i__ + 1),
lda, &x_ref(i__, 1), ldx, &c_b5, &a_ref(i__, i__ + 1),
lda);
/* Generate reflection P(i) to annihilate A(i,i+2:n)
Computing MIN */
i__2 = i__ + 2;
i__3 = *n - i__;
slarfg_(&i__3, &a_ref(i__, i__ + 1), &a_ref(i__, min(i__2,*n))
, lda, &taup[i__]);
e[i__] = a_ref(i__, i__ + 1);
a_ref(i__, i__ + 1) = 1.f;
/* Compute X(i+1:m,i) */
i__2 = *m - i__;
i__3 = *n - i__;
sgemv_("No transpose", &i__2, &i__3, &c_b5, &a_ref(i__ + 1,
i__ + 1), lda, &a_ref(i__, i__ + 1), lda, &c_b16, &
x_ref(i__ + 1, i__), &c__1);
i__2 = *n - i__;
sgemv_("Transpose", &i__2, &i__, &c_b5, &y_ref(i__ + 1, 1),
ldy, &a_ref(i__, i__ + 1), lda, &c_b16, &x_ref(1, i__)
, &c__1);
i__2 = *m - i__;
sgemv_("No transpose", &i__2, &i__, &c_b4, &a_ref(i__ + 1, 1),
lda, &x_ref(1, i__), &c__1, &c_b5, &x_ref(i__ + 1,
i__), &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
sgemv_("No transpose", &i__2, &i__3, &c_b5, &a_ref(1, i__ + 1)
, lda, &a_ref(i__, i__ + 1), lda, &c_b16, &x_ref(1,
i__), &c__1);
i__2 = *m - i__;
i__3 = i__ - 1;
sgemv_("No transpose", &i__2, &i__3, &c_b4, &x_ref(i__ + 1, 1)
, ldx, &x_ref(1, i__), &c__1, &c_b5, &x_ref(i__ + 1,
i__), &c__1);
i__2 = *m - i__;
sscal_(&i__2, &taup[i__], &x_ref(i__ + 1, i__), &c__1);
}
/* L10: */
}
} else {
/* Reduce to lower bidiagonal form */
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i,i:n) */
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
sgemv_("No transpose", &i__2, &i__3, &c_b4, &y_ref(i__, 1), ldy, &
a_ref(i__, 1), lda, &c_b5, &a_ref(i__, i__), lda);
i__2 = i__ - 1;
i__3 = *n - i__ + 1;
sgemv_("Transpose", &i__2, &i__3, &c_b4, &a_ref(1, i__), lda, &
x_ref(i__, 1), ldx, &c_b5, &a_ref(i__, i__), lda);
/* Generate reflection P(i) to annihilate A(i,i+1:n)
Computing MIN */
i__2 = i__ + 1;
i__3 = *n - i__ + 1;
slarfg_(&i__3, &a_ref(i__, i__), &a_ref(i__, min(i__2,*n)), lda, &
taup[i__]);
d__[i__] = a_ref(i__, i__);
if (i__ < *m) {
a_ref(i__, i__) = 1.f;
/* Compute X(i+1:m,i) */
i__2 = *m - i__;
i__3 = *n - i__ + 1;
sgemv_("No transpose", &i__2, &i__3, &c_b5, &a_ref(i__ + 1,
i__), lda, &a_ref(i__, i__), lda, &c_b16, &x_ref(i__
+ 1, i__), &c__1);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
sgemv_("Transpose", &i__2, &i__3, &c_b5, &y_ref(i__, 1), ldy,
&a_ref(i__, i__), lda, &c_b16, &x_ref(1, i__), &c__1);
i__2 = *m - i__;
i__3 = i__ - 1;
sgemv_("No transpose", &i__2, &i__3, &c_b4, &a_ref(i__ + 1, 1)
, lda, &x_ref(1, i__), &c__1, &c_b5, &x_ref(i__ + 1,
i__), &c__1);
i__2 = i__ - 1;
i__3 = *n - i__ + 1;
sgemv_("No transpose", &i__2, &i__3, &c_b5, &a_ref(1, i__),
lda, &a_ref(i__, i__), lda, &c_b16, &x_ref(1, i__), &
c__1);
i__2 = *m - i__;
i__3 = i__ - 1;
sgemv_("No transpose", &i__2, &i__3, &c_b4, &x_ref(i__ + 1, 1)
, ldx, &x_ref(1, i__), &c__1, &c_b5, &x_ref(i__ + 1,
i__), &c__1);
i__2 = *m - i__;
sscal_(&i__2, &taup[i__], &x_ref(i__ + 1, i__), &c__1);
/* Update A(i+1:m,i) */
i__2 = *m - i__;
i__3 = i__ - 1;
sgemv_("No transpose", &i__2, &i__3, &c_b4, &a_ref(i__ + 1, 1)
, lda, &y_ref(i__, 1), ldy, &c_b5, &a_ref(i__ + 1,
i__), &c__1);
i__2 = *m - i__;
sgemv_("No transpose", &i__2, &i__, &c_b4, &x_ref(i__ + 1, 1),
ldx, &a_ref(1, i__), &c__1, &c_b5, &a_ref(i__ + 1,
i__), &c__1);
/* Generate reflection Q(i) to annihilate A(i+2:m,i)
Computing MIN */
i__2 = i__ + 2;
i__3 = *m - i__;
slarfg_(&i__3, &a_ref(i__ + 1, i__), &a_ref(min(i__2,*m), i__)
, &c__1, &tauq[i__]);
e[i__] = a_ref(i__ + 1, i__);
a_ref(i__ + 1, i__) = 1.f;
/* Compute Y(i+1:n,i) */
i__2 = *m - i__;
i__3 = *n - i__;
sgemv_("Transpose", &i__2, &i__3, &c_b5, &a_ref(i__ + 1, i__
+ 1), lda, &a_ref(i__ + 1, i__), &c__1, &c_b16, &
y_ref(i__ + 1, i__), &c__1);
i__2 = *m - i__;
i__3 = i__ - 1;
sgemv_("Transpose", &i__2, &i__3, &c_b5, &a_ref(i__ + 1, 1),
lda, &a_ref(i__ + 1, i__), &c__1, &c_b16, &y_ref(1,
i__), &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
sgemv_("No transpose", &i__2, &i__3, &c_b4, &y_ref(i__ + 1, 1)
, ldy, &y_ref(1, i__), &c__1, &c_b5, &y_ref(i__ + 1,
i__), &c__1);
i__2 = *m - i__;
sgemv_("Transpose", &i__2, &i__, &c_b5, &x_ref(i__ + 1, 1),
ldx, &a_ref(i__ + 1, i__), &c__1, &c_b16, &y_ref(1,
i__), &c__1);
i__2 = *n - i__;
sgemv_("Transpose", &i__, &i__2, &c_b4, &a_ref(1, i__ + 1),
lda, &y_ref(1, i__), &c__1, &c_b5, &y_ref(i__ + 1,
i__), &c__1);
i__2 = *n - i__;
sscal_(&i__2, &tauq[i__], &y_ref(i__ + 1, i__), &c__1);
}
/* L20: */
}
}
return 0;
/* End of SLABRD */
} /* slabrd_ */
/* Subroutine */ int ssyevr_(char *jobz, char *range, char *uplo, integer *n,
real *a, integer *lda, real *vl, real *vu, integer *il, integer *iu,
real *abstol, integer *m, real *w, real *z__, integer *ldz, integer *
isuppz, real *work, integer *lwork, integer *iwork, integer *liwork,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, nb, jj;
real eps, vll, vuu, tmp1;
integer indd, inde;
real anrm;
integer imax;
real rmin, rmax;
logical test;
integer inddd, indee;
real sigma;
extern logical lsame_(char *, char *);
integer iinfo;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
char order[1];
integer indwk, lwmin;
logical lower;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), sswap_(integer *, real *, integer *, real *, integer *
);
logical wantz, alleig, indeig;
integer iscale, ieeeok, indibl, indifl;
logical valeig;
extern doublereal slamch_(char *);
real safmin;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *);
real abstll, bignum;
integer indtau, indisp, indiwo, indwkn, liwmin;
logical tryrac;
extern /* Subroutine */ int sstein_(integer *, real *, real *, integer *,
real *, integer *, integer *, real *, integer *, real *, integer *
, integer *, integer *), ssterf_(integer *, real *, real *,
integer *);
integer llwrkn, llwork, nsplit;
real smlnum;
extern doublereal slansy_(char *, char *, integer *, real *, integer *,
real *);
extern /* Subroutine */ int sstebz_(char *, char *, integer *, real *,
real *, integer *, integer *, real *, real *, real *, integer *,
integer *, real *, integer *, integer *, real *, integer *,
integer *), sstemr_(char *, char *, integer *,
real *, real *, real *, real *, integer *, integer *, integer *,
real *, real *, integer *, integer *, integer *, logical *, real *
, integer *, integer *, integer *, integer *);
integer lwkopt;
logical lquery;
extern /* Subroutine */ int sormtr_(char *, char *, char *, integer *,
integer *, real *, integer *, real *, real *, integer *, real *,
integer *, integer *), ssytrd_(char *,
integer *, real *, integer *, real *, real *, real *, real *,
integer *, integer *);
/* -- LAPACK driver routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SSYEVR computes selected eigenvalues and, optionally, eigenvectors */
/* of a real symmetric matrix A. Eigenvalues and eigenvectors can be */
/* selected by specifying either a range of values or a range of */
/* indices for the desired eigenvalues. */
/* SSYEVR first reduces the matrix A to tridiagonal form T with a call */
/* to SSYTRD. Then, whenever possible, SSYEVR calls SSTEMR to compute */
/* the eigenspectrum using Relatively Robust Representations. SSTEMR */
/* computes eigenvalues by the dqds algorithm, while orthogonal */
/* eigenvectors are computed from various "good" L D L^T representations */
/* (also known as Relatively Robust Representations). Gram-Schmidt */
/* orthogonalization is avoided as far as possible. More specifically, */
/* the various steps of the algorithm are as follows. */
/* For each unreduced block (submatrix) of T, */
/* (a) Compute T - sigma I = L D L^T, so that L and D */
/* define all the wanted eigenvalues to high relative accuracy. */
/* This means that small relative changes in the entries of D and L */
/* cause only small relative changes in the eigenvalues and */
/* eigenvectors. The standard (unfactored) representation of the */
/* tridiagonal matrix T does not have this property in general. */
/* (b) Compute the eigenvalues to suitable accuracy. */
/* If the eigenvectors are desired, the algorithm attains full */
/* accuracy of the computed eigenvalues only right before */
/* the corresponding vectors have to be computed, see steps c) and d). */
/* (c) For each cluster of close eigenvalues, select a new */
/* shift close to the cluster, find a new factorization, and refine */
/* the shifted eigenvalues to suitable accuracy. */
/* (d) For each eigenvalue with a large enough relative separation compute */
/* the corresponding eigenvector by forming a rank revealing twisted */
/* factorization. Go back to (c) for any clusters that remain. */
/* The desired accuracy of the output can be specified by the input */
/* parameter ABSTOL. */
/* For more details, see SSTEMR's documentation and: */
/* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */
/* to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */
/* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */
/* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */
/* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */
/* 2004. Also LAPACK Working Note 154. */
/* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */
/* tridiagonal eigenvalue/eigenvector problem", */
/* Computer Science Division Technical Report No. UCB/CSD-97-971, */
/* UC Berkeley, May 1997. */
/* Note 1 : SSYEVR calls SSTEMR when the full spectrum is requested */
/* on machines which conform to the ieee-754 floating point standard. */
/* SSYEVR calls SSTEBZ and SSTEIN on non-ieee machines and */
/* when partial spectrum requests are made. */
/* Normal execution of SSTEMR may create NaNs and infinities and */
/* hence may abort due to a floating point exception in environments */
/* which do not handle NaNs and infinities in the ieee standard default */
/* manner. */
/* Arguments */
/* ========= */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* RANGE (input) CHARACTER*1 */
/* = 'A': all eigenvalues will be found. */
/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
/* will be found. */
/* = 'I': the IL-th through IU-th eigenvalues will be found. */
/* ********* For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and */
/* ********* SSTEIN are called */
/* 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. */
/* A (input/output) REAL array, dimension (LDA, N) */
/* On entry, the symmetric matrix A. If UPLO = 'U', the */
/* leading N-by-N upper triangular part of A contains the */
/* upper triangular part of the matrix A. If UPLO = 'L', */
/* the leading N-by-N lower triangular part of A contains */
/* the lower triangular part of the matrix A. */
/* On exit, the lower triangle (if UPLO='L') or the upper */
/* triangle (if UPLO='U') of A, including the diagonal, is */
/* destroyed. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* VL (input) REAL */
/* VU (input) REAL */
/* If RANGE='V', the lower and upper bounds of the interval to */
/* be searched for eigenvalues. VL < VU. */
/* Not referenced if RANGE = 'A' or 'I'. */
/* IL (input) INTEGER */
/* IU (input) INTEGER */
/* If RANGE='I', the indices (in ascending order) of the */
/* smallest and largest eigenvalues to be returned. */
/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
/* Not referenced if RANGE = 'A' or 'V'. */
/* ABSTOL (input) REAL */
/* The absolute error tolerance for the eigenvalues. */
/* An approximate eigenvalue is accepted as converged */
/* when it is determined to lie in an interval [a,b] */
/* of width less than or equal to */
/* ABSTOL + EPS * max( |a|,|b| ) , */
/* where EPS is the machine precision. If ABSTOL is less than */
/* or equal to zero, then EPS*|T| will be used in its place, */
/* where |T| is the 1-norm of the tridiagonal matrix obtained */
/* by reducing A to tridiagonal form. */
/* See "Computing Small Singular Values of Bidiagonal Matrices */
/* with Guaranteed High Relative Accuracy," by Demmel and */
/* Kahan, LAPACK Working Note #3. */
/* If high relative accuracy is important, set ABSTOL to */
/* SLAMCH( 'Safe minimum' ). Doing so will guarantee that */
/* eigenvalues are computed to high relative accuracy when */
/* possible in future releases. The current code does not */
/* make any guarantees about high relative accuracy, but */
/* future releases will. See J. Barlow and J. Demmel, */
/* "Computing Accurate Eigensystems of Scaled Diagonally */
/* Dominant Matrices", LAPACK Working Note #7, for a discussion */
/* of which matrices define their eigenvalues to high relative */
/* accuracy. */
/* M (output) INTEGER */
/* The total number of eigenvalues found. 0 <= M <= N. */
/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
/* W (output) REAL array, dimension (N) */
/* The first M elements contain the selected eigenvalues in */
/* ascending order. */
/* Z (output) REAL array, dimension (LDZ, max(1,M)) */
/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
/* contain the orthonormal eigenvectors of the matrix A */
/* corresponding to the selected eigenvalues, with the i-th */
/* column of Z holding the eigenvector associated with W(i). */
/* If JOBZ = 'N', then Z is not referenced. */
/* Note: the user must ensure that at least max(1,M) columns are */
/* supplied in the array Z; if RANGE = 'V', the exact value of M */
/* is not known in advance and an upper bound must be used. */
/* Supplying N columns is always safe. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= max(1,N). */
/* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) ) */
/* The support of the eigenvectors in Z, i.e., the indices */
/* indicating the nonzero elements in Z. The i-th eigenvector */
/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */
/* ISUPPZ( 2*i ). */
/* ********* Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 */
/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,26*N). */
/* For optimal efficiency, LWORK >= (NB+6)*N, */
/* where NB is the max of the blocksize for SSYTRD and SORMTR */
/* returned by ILAENV. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal sizes of the WORK and IWORK */
/* arrays, returns these values as the first entries of the WORK */
/* and IWORK arrays, and no error message related to LWORK or */
/* LIWORK is issued by XERBLA. */
/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
/* On exit, if INFO = 0, IWORK(1) returns the optimal LWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. LIWORK >= max(1,10*N). */
/* If LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal sizes of the WORK and */
/* IWORK arrays, returns these values as the first entries of */
/* the WORK and IWORK arrays, and no error message related to */
/* LWORK or LIWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: Internal error */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Inderjit Dhillon, IBM Almaden, USA */
/* Osni Marques, LBNL/NERSC, USA */
/* Ken Stanley, Computer Science Division, University of */
/* California at Berkeley, USA */
/* Jason Riedy, Computer Science Division, University of */
/* California at Berkeley, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--isuppz;
--work;
--iwork;
/* Function Body */
ieeeok = ilaenv_(&c__10, "SSYEVR", "N", &c__1, &c__2, &c__3, &c__4);
lower = lsame_(uplo, "L");
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
lquery = *lwork == -1 || *liwork == -1;
/* Computing MAX */
i__1 = 1, i__2 = *n * 26;
lwmin = max(i__1,i__2);
/* Computing MAX */
i__1 = 1, i__2 = *n * 10;
liwmin = max(i__1,i__2);
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (! (lower || lsame_(uplo, "U"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else {
if (valeig) {
if (*n > 0 && *vu <= *vl) {
*info = -8;
}
} else if (indeig) {
if (*il < 1 || *il > max(1,*n)) {
*info = -9;
} else if (*iu < min(*n,*il) || *iu > *n) {
*info = -10;
}
}
}
if (*info == 0) {
if (*ldz < 1 || wantz && *ldz < *n) {
*info = -15;
}
}
if (*info == 0) {
nb = ilaenv_(&c__1, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1);
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__1, "SORMTR", uplo, n, &c_n1, &c_n1, &
c_n1);
nb = max(i__1,i__2);
/* Computing MAX */
i__1 = (nb + 1) * *n;
lwkopt = max(i__1,lwmin);
work[1] = (real) lwkopt;
iwork[1] = liwmin;
if (*lwork < lwmin && ! lquery) {
*info = -18;
} else if (*liwork < liwmin && ! lquery) {
*info = -20;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSYEVR", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
work[1] = 1.f;
return 0;
}
if (*n == 1) {
work[1] = 26.f;
if (alleig || indeig) {
*m = 1;
w[1] = a[a_dim1 + 1];
} else {
if (*vl < a[a_dim1 + 1] && *vu >= a[a_dim1 + 1]) {
*m = 1;
w[1] = a[a_dim1 + 1];
}
}
if (wantz) {
z__[z_dim1 + 1] = 1.f;
}
return 0;
}
/* Get machine constants. */
safmin = slamch_("Safe minimum");
eps = slamch_("Precision");
smlnum = safmin / eps;
bignum = 1.f / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin));
rmax = dmin(r__1,r__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
abstll = *abstol;
if (valeig) {
vll = *vl;
vuu = *vu;
}
anrm = slansy_("M", uplo, n, &a[a_offset], lda, &work[1]);
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) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j + 1;
sscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1);
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1);
/* L20: */
}
}
if (*abstol > 0.f) {
abstll = *abstol * sigma;
}
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Initialize indices into workspaces. Note: The IWORK indices are */
/* used only if SSTERF or SSTEMR fail. */
/* WORK(INDTAU:INDTAU+N-1) stores the scalar factors of the */
/* elementary reflectors used in SSYTRD. */
indtau = 1;
/* WORK(INDD:INDD+N-1) stores the tridiagonal's diagonal entries. */
indd = indtau + *n;
/* WORK(INDE:INDE+N-1) stores the off-diagonal entries of the */
/* tridiagonal matrix from SSYTRD. */
inde = indd + *n;
/* WORK(INDDD:INDDD+N-1) is a copy of the diagonal entries over */
/* -written by SSTEMR (the SSTERF path copies the diagonal to W). */
inddd = inde + *n;
/* WORK(INDEE:INDEE+N-1) is a copy of the off-diagonal entries over */
/* -written while computing the eigenvalues in SSTERF and SSTEMR. */
indee = inddd + *n;
/* INDWK is the starting offset of the left-over workspace, and */
/* LLWORK is the remaining workspace size. */
indwk = indee + *n;
llwork = *lwork - indwk + 1;
/* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in SSTEBZ and */
/* stores the block indices of each of the M<=N eigenvalues. */
indibl = 1;
/* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in SSTEBZ and */
/* stores the starting and finishing indices of each block. */
indisp = indibl + *n;
/* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors */
/* that corresponding to eigenvectors that fail to converge in */
/* SSTEIN. This information is discarded; if any fail, the driver */
/* returns INFO > 0. */
indifl = indisp + *n;
/* INDIWO is the offset of the remaining integer workspace. */
indiwo = indisp + *n;
/* Call SSYTRD to reduce symmetric matrix to tridiagonal form. */
ssytrd_(uplo, n, &a[a_offset], lda, &work[indd], &work[inde], &work[
indtau], &work[indwk], &llwork, &iinfo);
/* If all eigenvalues are desired */
/* then call SSTERF or SSTEMR and SORMTR. */
test = FALSE_;
if (indeig) {
if (*il == 1 && *iu == *n) {
test = TRUE_;
}
}
if ((alleig || test) && ieeeok == 1) {
if (! wantz) {
scopy_(n, &work[indd], &c__1, &w[1], &c__1);
i__1 = *n - 1;
scopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
ssterf_(n, &w[1], &work[indee], info);
} else {
i__1 = *n - 1;
scopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
scopy_(n, &work[indd], &c__1, &work[inddd], &c__1);
if (*abstol <= *n * 2.f * eps) {
tryrac = TRUE_;
} else {
tryrac = FALSE_;
}
sstemr_(jobz, "A", n, &work[inddd], &work[indee], vl, vu, il, iu,
m, &w[1], &z__[z_offset], ldz, n, &isuppz[1], &tryrac, &
work[indwk], lwork, &iwork[1], liwork, info);
/* Apply orthogonal matrix used in reduction to tridiagonal */
/* form to eigenvectors returned by SSTEIN. */
if (wantz && *info == 0) {
indwkn = inde;
llwrkn = *lwork - indwkn + 1;
sormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau]
, &z__[z_offset], ldz, &work[indwkn], &llwrkn, &iinfo);
}
}
if (*info == 0) {
/* Everything worked. Skip SSTEBZ/SSTEIN. IWORK(:) are */
/* undefined. */
*m = *n;
goto L30;
}
*info = 0;
}
/* Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN. */
/* Also call SSTEBZ and SSTEIN if SSTEMR fails. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[
inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[
indwk], &iwork[indiwo], info);
if (wantz) {
sstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[
indisp], &z__[z_offset], ldz, &work[indwk], &iwork[indiwo], &
iwork[indifl], info);
/* Apply orthogonal matrix used in reduction to tridiagonal */
/* form to eigenvectors returned by SSTEIN. */
indwkn = inde;
llwrkn = *lwork - indwkn + 1;
sormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[
z_offset], ldz, &work[indwkn], &llwrkn, &iinfo);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
/* Jump here if SSTEMR/SSTEIN succeeded. */
L30:
if (iscale == 1) {
if (*info == 0) {
imax = *m;
} else {
imax = *info - 1;
}
r__1 = 1.f / sigma;
sscal_(&imax, &r__1, &w[1], &c__1);
}
/* If eigenvalues are not in order, then sort them, along with */
/* eigenvectors. Note: We do not sort the IFAIL portion of IWORK. */
/* It may not be initialized (if SSTEMR/SSTEIN succeeded), and we do */
/* not return this detailed information to the user. */
if (wantz) {
i__1 = *m - 1;
for (j = 1; j <= i__1; ++j) {
i__ = 0;
tmp1 = w[j];
i__2 = *m;
for (jj = j + 1; jj <= i__2; ++jj) {
if (w[jj] < tmp1) {
i__ = jj;
tmp1 = w[jj];
}
/* L40: */
}
if (i__ != 0) {
w[i__] = w[j];
w[j] = tmp1;
sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
&c__1);
}
/* L50: */
}
}
/* Set WORK(1) to optimal workspace size. */
work[1] = (real) lwkopt;
iwork[1] = liwmin;
return 0;
/* End of SSYEVR */
} /* ssyevr_ */
/* Subroutine */
int chpevd_(char *jobz, char *uplo, integer *n, complex *ap, real *w, complex *z__, integer *ldz, complex *work, integer *lwork, real *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
real eps;
integer inde;
real anrm;
integer imax;
real rmin, rmax, sigma;
extern logical lsame_(char *, char *);
integer iinfo;
extern /* Subroutine */
int sscal_(integer *, real *, real *, integer *);
integer lwmin, llrwk, llwrk;
logical wantz;
integer iscale;
extern real clanhp_(char *, char *, integer *, complex *, real *);
extern /* Subroutine */
int cstedc_(char *, integer *, real *, real *, complex *, integer *, complex *, integer *, real *, integer *, integer *, integer *, integer *);
extern real slamch_(char *);
extern /* Subroutine */
int csscal_(integer *, real *, complex *, integer *);
real safmin;
extern /* Subroutine */
int xerbla_(char *, integer *);
real bignum;
integer indtau;
extern /* Subroutine */
int chptrd_(char *, integer *, complex *, real *, real *, complex *, integer *);
integer indrwk, indwrk, liwmin;
extern /* Subroutine */
int ssterf_(integer *, real *, real *, integer *);
integer lrwmin;
extern /* Subroutine */
int cupmtr_(char *, char *, char *, integer *, integer *, complex *, complex *, complex *, integer *, complex *, integer *);
real smlnum;
logical lquery;
/* -- LAPACK driver routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--rwork;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V");
lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1;
*info = 0;
if (! (wantz || lsame_(jobz, "N")))
{
*info = -1;
}
else if (! (lsame_(uplo, "L") || lsame_(uplo, "U")))
{
*info = -2;
}
else if (*n < 0)
{
*info = -3;
}
else if (*ldz < 1 || wantz && *ldz < *n)
{
*info = -7;
}
if (*info == 0)
{
if (*n <= 1)
{
lwmin = 1;
liwmin = 1;
lrwmin = 1;
}
else
{
if (wantz)
{
lwmin = *n << 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;
}
}
work[1].r = (real) lwmin;
work[1].i = 0.f; // , expr subst
rwork[1] = (real) lrwmin;
iwork[1] = liwmin;
if (*lwork < lwmin && ! lquery)
{
*info = -9;
}
else if (*lrwork < lrwmin && ! lquery)
{
*info = -11;
}
else if (*liwork < liwmin && ! lquery)
{
*info = -13;
}
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CHPEVD", &i__1);
return 0;
}
else if (lquery)
{
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
if (*n == 1)
{
w[1] = ap[1].r;
if (wantz)
{
i__1 = z_dim1 + 1;
z__[i__1].r = 1.f;
z__[i__1].i = 0.f; // , expr subst
}
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 = clanhp_("M", uplo, n, &ap[1], &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)
{
i__1 = *n * (*n + 1) / 2;
csscal_(&i__1, &sigma, &ap[1], &c__1);
}
/* Call CHPTRD to reduce Hermitian packed matrix to tridiagonal form. */
inde = 1;
indtau = 1;
indrwk = inde + *n;
indwrk = indtau + *n;
llwrk = *lwork - indwrk + 1;
llrwk = *lrwork - indrwk + 1;
chptrd_(uplo, n, &ap[1], &w[1], &rwork[inde], &work[indtau], &iinfo);
/* For eigenvalues only, call SSTERF. For eigenvectors, first call */
/* CUPGTR to generate the orthogonal matrix, then call CSTEDC. */
if (! wantz)
{
ssterf_(n, &w[1], &rwork[inde], info);
}
else
{
cstedc_("I", n, &w[1], &rwork[inde], &z__[z_offset], ldz, &work[ indwrk], &llwrk, &rwork[indrwk], &llrwk, &iwork[1], liwork, info);
cupmtr_("L", uplo, "N", n, n, &ap[1], &work[indtau], &z__[z_offset], ldz, &work[indwrk], &iinfo);
}
/* 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);
}
work[1].r = (real) lwmin;
work[1].i = 0.f; // , expr subst
rwork[1] = (real) lrwmin;
iwork[1] = liwmin;
return 0;
/* End of CHPEVD */
}
/* Subroutine */ int chpevx_(char *jobz, char *range, char *uplo, integer *n,
complex *ap, real *vl, real *vu, integer *il, integer *iu, real *
abstol, integer *m, real *w, complex *z__, integer *ldz, complex *
work, real *rwork, integer *iwork, integer *ifail, 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
=======
CHPEVX computes selected eigenvalues and, optionally, eigenvectors
of a complex Hermitian matrix A in packed storage.
Eigenvalues/vectors can be selected by specifying either a range of
values or a range of indices for the desired eigenvalues.
Arguments
=========
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
RANGE (input) CHARACTER*1
= 'A': all eigenvalues will be found;
= 'V': all eigenvalues in the half-open interval (VL,VU]
will be found;
= 'I': the IL-th through IU-th eigenvalues will be found.
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
AP (input/output) COMPLEX array, dimension (N*(N+1)/2)
On entry, the upper or lower triangle of the Hermitian matrix
A, packed columnwise in a linear array. The j-th column of A
is stored in the array AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
On exit, AP is overwritten by values generated during the
reduction to tridiagonal form. If UPLO = 'U', the diagonal
and first superdiagonal of the tridiagonal matrix T overwrite
the corresponding elements of A, and if UPLO = 'L', the
diagonal and first subdiagonal of T overwrite the
corresponding elements of A.
VL (input) REAL
VU (input) REAL
If RANGE='V', the lower and upper bounds of the interval to
be searched for eigenvalues. VL < VU.
Not referenced if RANGE = 'A' or 'I'.
IL (input) INTEGER
IU (input) INTEGER
If RANGE='I', the indices (in ascending order) of the
smallest and largest eigenvalues to be returned.
1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
Not referenced if RANGE = 'A' or 'V'.
ABSTOL (input) REAL
The absolute error tolerance for the eigenvalues.
An approximate eigenvalue is accepted as converged
when it is determined to lie in an interval [a,b]
of width less than or equal to
ABSTOL + EPS * max( |a|,|b| ) ,
where EPS is the machine precision. If ABSTOL is less than
or equal to zero, then EPS*|T| will be used in its place,
where |T| is the 1-norm of the tridiagonal matrix obtained
by reducing AP to tridiagonal form.
Eigenvalues will be computed most accurately when ABSTOL is
set to twice the underflow threshold 2*SLAMCH('S'), not zero.
If this routine returns with INFO>0, indicating that some
eigenvectors did not converge, try setting ABSTOL to
2*SLAMCH('S').
See "Computing Small Singular Values of Bidiagonal Matrices
with Guaranteed High Relative Accuracy," by Demmel and
Kahan, LAPACK Working Note #3.
M (output) INTEGER
The total number of eigenvalues found. 0 <= M <= N.
If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
W (output) REAL array, dimension (N)
If INFO = 0, the selected eigenvalues in ascending order.
Z (output) COMPLEX array, dimension (LDZ, max(1,M))
If JOBZ = 'V', then if INFO = 0, the first M columns of Z
contain the orthonormal eigenvectors of the matrix A
corresponding to the selected eigenvalues, with the i-th
column of Z holding the eigenvector associated with W(i).
If an eigenvector fails to converge, then that column of Z
contains the latest approximation to the eigenvector, and
the index of the eigenvector is returned in IFAIL.
If JOBZ = 'N', then Z is not referenced.
Note: the user must ensure that at least max(1,M) columns are
supplied in the array Z; if RANGE = 'V', the exact value of M
is not known in advance and an upper bound must be used.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1, and if
JOBZ = 'V', LDZ >= max(1,N).
WORK (workspace) COMPLEX array, dimension (2*N)
RWORK (workspace) REAL array, dimension (7*N)
IWORK (workspace) INTEGER array, dimension (5*N)
IFAIL (output) INTEGER array, dimension (N)
If JOBZ = 'V', then if INFO = 0, the first M elements of
IFAIL are zero. If INFO > 0, then IFAIL contains the
indices of the eigenvectors that failed to converge.
If JOBZ = 'N', then IFAIL is not referenced.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, then i eigenvectors failed to converge.
Their indices are stored in array IFAIL.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer indd, inde;
static real anrm;
static integer imax;
static real rmin, rmax;
static integer itmp1, i__, j, indee;
static real sigma;
extern logical lsame_(char *, char *);
static integer iinfo;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static char order[1];
extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
complex *, integer *), scopy_(integer *, real *, integer *, real *
, integer *);
static logical wantz;
static integer jj;
static logical alleig, indeig;
static integer iscale, indibl;
extern doublereal clanhp_(char *, char *, integer *, complex *, real *);
static logical valeig;
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*);
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real abstll, bignum;
static integer indiwk, indisp, indtau;
extern /* Subroutine */ int chptrd_(char *, integer *, complex *, real *,
real *, complex *, integer *), cstein_(integer *, real *,
real *, integer *, real *, integer *, integer *, complex *,
integer *, real *, integer *, integer *, integer *);
static integer indrwk, indwrk;
extern /* Subroutine */ int csteqr_(char *, integer *, real *, real *,
complex *, integer *, real *, integer *), cupgtr_(char *,
integer *, complex *, complex *, complex *, integer *, complex *,
integer *), ssterf_(integer *, real *, real *, integer *);
static integer nsplit;
extern /* Subroutine */ int cupmtr_(char *, char *, char *, integer *,
integer *, complex *, complex *, complex *, integer *, complex *,
integer *);
static real smlnum;
extern /* Subroutine */ int sstebz_(char *, char *, integer *, real *,
real *, integer *, integer *, real *, real *, real *, integer *,
integer *, real *, integer *, integer *, real *, integer *,
integer *);
static real eps, vll, vuu, tmp1;
#define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1
#define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)]
--ap;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
--rwork;
--iwork;
--ifail;
/* Function Body */
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (! (lsame_(uplo, "L") || lsame_(uplo,
"U"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else {
if (valeig) {
if (*n > 0 && *vu <= *vl) {
*info = -7;
}
} else if (indeig) {
if (*il < 1 || *il > max(1,*n)) {
*info = -8;
} else if (*iu < min(*n,*il) || *iu > *n) {
*info = -9;
}
}
}
if (*info == 0) {
if (*ldz < 1 || wantz && *ldz < *n) {
*info = -14;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHPEVX", &i__1);
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (alleig || indeig) {
*m = 1;
w[1] = ap[1].r;
} else {
if (*vl < ap[1].r && *vu >= ap[1].r) {
*m = 1;
w[1] = ap[1].r;
}
}
if (wantz) {
i__1 = z___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);
/* Computing MIN */
r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin));
rmax = dmin(r__1,r__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
abstll = *abstol;
if (valeig) {
vll = *vl;
vuu = *vu;
} else {
vll = 0.f;
vuu = 0.f;
}
anrm = clanhp_("M", uplo, n, &ap[1], &rwork[1]);
if (anrm > 0.f && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
i__1 = *n * (*n + 1) / 2;
csscal_(&i__1, &sigma, &ap[1], &c__1);
if (*abstol > 0.f) {
abstll = *abstol * sigma;
}
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Call CHPTRD to reduce Hermitian packed matrix to tridiagonal form. */
indd = 1;
inde = indd + *n;
indrwk = inde + *n;
indtau = 1;
indwrk = indtau + *n;
chptrd_(uplo, n, &ap[1], &rwork[indd], &rwork[inde], &work[indtau], &
iinfo);
/* If all eigenvalues are desired and ABSTOL is less than or equal
to zero, then call SSTERF or CUPGTR and CSTEQR. If this fails
for some eigenvalue, then try SSTEBZ. */
if ((alleig || indeig && *il == 1 && *iu == *n) && *abstol <= 0.f) {
scopy_(n, &rwork[indd], &c__1, &w[1], &c__1);
indee = indrwk + (*n << 1);
if (! wantz) {
i__1 = *n - 1;
scopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
ssterf_(n, &w[1], &rwork[indee], info);
} else {
cupgtr_(uplo, n, &ap[1], &work[indtau], &z__[z_offset], ldz, &
work[indwrk], &iinfo);
i__1 = *n - 1;
scopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
csteqr_(jobz, n, &w[1], &rwork[indee], &z__[z_offset], ldz, &
rwork[indrwk], info);
if (*info == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
ifail[i__] = 0;
/* L10: */
}
}
}
if (*info == 0) {
*m = *n;
goto L20;
}
*info = 0;
}
/* Otherwise, call SSTEBZ and, if eigenvectors are desired, CSTEIN. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
indibl = 1;
indisp = indibl + *n;
indiwk = indisp + *n;
sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indd], &
rwork[inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &
rwork[indrwk], &iwork[indiwk], info);
if (wantz) {
cstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[indibl], &
iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[
indiwk], &ifail[1], info);
/* Apply unitary matrix used in reduction to tridiagonal
form to eigenvectors returned by CSTEIN. */
indwrk = indtau + *n;
cupmtr_("L", uplo, "N", n, m, &ap[1], &work[indtau], &z__[z_offset],
ldz, &work[indwrk], info);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
L20:
if (iscale == 1) {
if (*info == 0) {
imax = *m;
} else {
imax = *info - 1;
}
r__1 = 1.f / sigma;
sscal_(&imax, &r__1, &w[1], &c__1);
}
/* If eigenvalues are not in order, then sort them, along with
eigenvectors. */
if (wantz) {
i__1 = *m - 1;
for (j = 1; j <= i__1; ++j) {
i__ = 0;
tmp1 = w[j];
i__2 = *m;
for (jj = j + 1; jj <= i__2; ++jj) {
if (w[jj] < tmp1) {
i__ = jj;
tmp1 = w[jj];
}
/* L30: */
}
if (i__ != 0) {
itmp1 = iwork[indibl + i__ - 1];
w[i__] = w[j];
iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
w[j] = tmp1;
iwork[indibl + j - 1] = itmp1;
cswap_(n, &z___ref(1, i__), &c__1, &z___ref(1, j), &c__1);
if (*info != 0) {
itmp1 = ifail[i__];
ifail[i__] = ifail[j];
ifail[j] = itmp1;
}
}
/* L40: */
}
}
return 0;
/* End of CHPEVX */
} /* chpevx_ */
/* Subroutine */ int sorg2r_(integer *m, integer *n, integer *k, real *a,
integer *lda, real *tau, real *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
real r__1;
/* Local variables */
integer i__, j, l;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
slarf_(char *, integer *, integer *, real *, integer *, real *,
real *, integer *, real *), xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SORG2R generates an m by n real matrix Q with orthonormal columns, */
/* which is defined as the first n columns of a product of k elementary */
/* reflectors of order m */
/* Q = H(1) H(2) . . . H(k) */
/* as returned by SGEQRF. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix Q. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix Q. M >= N >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines the */
/* matrix Q. N >= K >= 0. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the i-th column must contain the vector which */
/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
/* returned by SGEQRF in the first k columns of its array */
/* argument A. */
/* On exit, the m-by-n matrix Q. */
/* LDA (input) INTEGER */
/* The first dimension of the array A. LDA >= max(1,M). */
/* TAU (input) REAL array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by SGEQRF. */
/* WORK (workspace) REAL array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument has an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0 || *n > *m) {
*info = -2;
} else if (*k < 0 || *k > *n) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SORG2R", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
return 0;
}
/* Initialise columns k+1:n to columns of the unit matrix */
i__1 = *n;
for (j = *k + 1; j <= i__1; ++j) {
i__2 = *m;
for (l = 1; l <= i__2; ++l) {
a[l + j * a_dim1] = 0.f;
/* L10: */
}
a[j + j * a_dim1] = 1.f;
/* L20: */
}
for (i__ = *k; i__ >= 1; --i__) {
/* Apply H(i) to A(i:m,i:n) from the left */
if (i__ < *n) {
a[i__ + i__ * a_dim1] = 1.f;
i__1 = *m - i__ + 1;
i__2 = *n - i__;
slarf_("Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[
i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
}
if (i__ < *m) {
i__1 = *m - i__;
r__1 = -tau[i__];
sscal_(&i__1, &r__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
}
a[i__ + i__ * a_dim1] = 1.f - tau[i__];
/* Set A(1:i-1,i) to zero */
i__1 = i__ - 1;
for (l = 1; l <= i__1; ++l) {
a[l + i__ * a_dim1] = 0.f;
/* L30: */
}
/* L40: */
}
return 0;
/* End of SORG2R */
} /* sorg2r_ */
/* Subroutine */ int sggbak_(char *job, char *side, integer *n, integer *ilo,
integer *ihi, real *lscale, real *rscale, integer *m, real *v,
integer *ldv, 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
=======
SGGBAK forms the right or left eigenvectors of a real generalized
eigenvalue problem A*x = lambda*B*x, by backward transformation on
the computed eigenvectors of the balanced pair of matrices output by
SGGBAL.
Arguments
=========
JOB (input) CHARACTER*1
Specifies the type of backward transformation required:
= 'N': do nothing, return immediately;
= 'P': do backward transformation for permutation only;
= 'S': do backward transformation for scaling only;
= 'B': do backward transformations for both permutation and
scaling.
JOB must be the same as the argument JOB supplied to SGGBAL.
SIDE (input) CHARACTER*1
= 'R': V contains right eigenvectors;
= 'L': V contains left eigenvectors.
N (input) INTEGER
The number of rows of the matrix V. N >= 0.
ILO (input) INTEGER
IHI (input) INTEGER
The integers ILO and IHI determined by SGGBAL.
1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
LSCALE (input) REAL array, dimension (N)
Details of the permutations and/or scaling factors applied
to the left side of A and B, as returned by SGGBAL.
RSCALE (input) REAL array, dimension (N)
Details of the permutations and/or scaling factors applied
to the right side of A and B, as returned by SGGBAL.
M (input) INTEGER
The number of columns of the matrix V. M >= 0.
V (input/output) REAL array, dimension (LDV,M)
On entry, the matrix of right or left eigenvectors to be
transformed, as returned by STGEVC.
On exit, V is overwritten by the transformed eigenvectors.
LDV (input) INTEGER
The leading dimension of the matrix V. LDV >= max(1,N).
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
Further Details
===============
See R.C. Ward, Balancing the generalized eigenvalue problem,
SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
=====================================================================
Test the input parameters
Parameter adjustments */
/* System generated locals */
integer v_dim1, v_offset, i__1;
/* Local variables */
static integer i__, k;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static logical leftv;
extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
integer *), xerbla_(char *, integer *);
static logical rightv;
#define v_ref(a_1,a_2) v[(a_2)*v_dim1 + a_1]
--lscale;
--rscale;
v_dim1 = *ldv;
v_offset = 1 + v_dim1 * 1;
v -= v_offset;
/* Function Body */
rightv = lsame_(side, "R");
leftv = lsame_(side, "L");
*info = 0;
if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S")
&& ! lsame_(job, "B")) {
*info = -1;
} else if (! rightv && ! leftv) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ilo < 1) {
*info = -4;
} else if (*ihi < *ilo || *ihi > max(1,*n)) {
*info = -5;
} else if (*m < 0) {
*info = -6;
} else if (*ldv < max(1,*n)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGGBAK", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*m == 0) {
return 0;
}
if (lsame_(job, "N")) {
return 0;
}
if (*ilo == *ihi) {
goto L30;
}
/* Backward balance */
if (lsame_(job, "S") || lsame_(job, "B")) {
/* Backward transformation on right eigenvectors */
if (rightv) {
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
sscal_(m, &rscale[i__], &v_ref(i__, 1), ldv);
/* L10: */
}
}
/* Backward transformation on left eigenvectors */
if (leftv) {
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
sscal_(m, &lscale[i__], &v_ref(i__, 1), ldv);
/* L20: */
}
}
}
/* Backward permutation */
L30:
if (lsame_(job, "P") || lsame_(job, "B")) {
/* Backward permutation on right eigenvectors */
if (rightv) {
if (*ilo == 1) {
goto L50;
}
for (i__ = *ilo - 1; i__ >= 1; --i__) {
k = rscale[i__];
if (k == i__) {
goto L40;
}
sswap_(m, &v_ref(i__, 1), ldv, &v_ref(k, 1), ldv);
L40:
;
}
L50:
if (*ihi == *n) {
goto L70;
}
i__1 = *n;
for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
k = rscale[i__];
if (k == i__) {
goto L60;
}
sswap_(m, &v_ref(i__, 1), ldv, &v_ref(k, 1), ldv);
L60:
;
}
}
/* Backward permutation on left eigenvectors */
L70:
if (leftv) {
if (*ilo == 1) {
goto L90;
}
for (i__ = *ilo - 1; i__ >= 1; --i__) {
k = lscale[i__];
if (k == i__) {
goto L80;
}
sswap_(m, &v_ref(i__, 1), ldv, &v_ref(k, 1), ldv);
L80:
;
}
L90:
if (*ihi == *n) {
goto L110;
}
i__1 = *n;
for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
k = lscale[i__];
if (k == i__) {
goto L100;
}
sswap_(m, &v_ref(i__, 1), ldv, &v_ref(k, 1), ldv);
L100:
;
}
}
}
L110:
return 0;
/* End of SGGBAK */
} /* sggbak_ */
/* Subroutine */ int sstevd_(char *jobz, integer *n, real *d, real *e, real *
z, integer *ldz, real *work, integer *lwork, integer *iwork, integer *
liwork, integer *info)
{
/* -- LAPACK driver routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SSTEVD computes all eigenvalues and, optionally, eigenvectors of a
real symmetric tridiagonal matrix. 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.
N (input) INTEGER
The order of the matrix. N >= 0.
D (input/output) REAL array, dimension (N)
On entry, the n diagonal elements of the tridiagonal matrix
A.
On exit, if INFO = 0, the eigenvalues in ascending order.
E (input/output) REAL array, dimension (N)
On entry, the (n-1) subdiagonal elements of the tridiagonal
matrix A, stored in elements 1 to N-1 of E; E(N) need not
be set, but is used by the routine.
On exit, the contents of E are destroyed.
Z (output) REAL 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 D(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) REAL array,
dimension (LWORK)
On exit, if LWORK > 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK.
If JOBZ = 'N' or N <= 1 then LWORK must be at least 1.
If JOBZ = 'V' and N > 1 then LWORK must be at least
( 1 + 3*N + 2*N*lg N + 2*N**2 ),
where lg( N ) = smallest integer k such
that 2**k >= N.
IWORK (workspace/output) INTEGER array, dimension (LIWORK)
On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK.
LIWORK (input) INTEGER
The dimension of the array IWORK.
If JOBZ = 'N' or N <= 1 then LIWORK must be at least 1.
If JOBZ = 'V' and N > 1 then LIWORK must be at least 2+5*N.
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 E did not converge to zero.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__2 = 2;
static integer c__1 = 1;
/* System generated locals */
integer z_dim1, z_offset, i__1;
real r__1;
/* Builtin functions */
double log(doublereal);
integer pow_ii(integer *, integer *);
double sqrt(doublereal);
/* Local variables */
static real rmin, rmax, tnrm, sigma;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static integer lwmin;
static logical wantz;
static integer iscale;
extern doublereal slamch_(char *);
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real bignum;
extern /* Subroutine */ int sstedc_(char *, integer *, real *, real *,
real *, integer *, real *, integer *, integer *, integer *,
integer *);
static integer liwmin;
extern doublereal slanst_(char *, integer *, real *, real *);
extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *);
static real smlnum;
static integer lgn;
static real eps;
#define D(I) d[(I)-1]
#define E(I) e[(I)-1]
#define WORK(I) work[(I)-1]
#define IWORK(I) iwork[(I)-1]
#define Z(I,J) z[(I)-1 + ((J)-1)* ( *ldz)]
wantz = lsame_(jobz, "V");
*info = 0;
liwmin = 1;
lwmin = 1;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -6;
} else if (*n > 1 && wantz) {
lgn = (integer) (log((real) (*n)) / log(2.f));
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
/* Computing 2nd power */
i__1 = *n;
lwmin = *n * 3 + 1 + (*n << 1) * lgn + (i__1 * i__1 << 1);
liwmin = *n * 5 + 2;
if (*lwork < lwmin) {
*info = -8;
} else if (*liwork < liwmin) {
*info = -10;
}
} else if (*lwork < 1) {
*info = -8;
} else if (*liwork < 1) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSTEVD", &i__1);
goto L10;
}
/* Quick return if possible */
if (*n == 0) {
goto L10;
}
if (*n == 1) {
if (wantz) {
Z(1,1) = 1.f;
}
goto L10;
}
/* 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. */
iscale = 0;
tnrm = slanst_("M", n, &D(1), &E(1));
if (tnrm > 0.f && tnrm < rmin) {
iscale = 1;
sigma = rmin / tnrm;
} else if (tnrm > rmax) {
iscale = 1;
sigma = rmax / tnrm;
}
if (iscale == 1) {
sscal_(n, &sigma, &D(1), &c__1);
i__1 = *n - 1;
sscal_(&i__1, &sigma, &E(1), &c__1);
}
/* For eigenvalues only, call SSTERF. For eigenvalues and
eigenvectors, call SSTEDC. */
if (! wantz) {
ssterf_(n, &D(1), &E(1), info);
} else {
sstedc_("I", n, &D(1), &E(1), &Z(1,1), ldz, &WORK(1), lwork, &
IWORK(1), liwork, info);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (iscale == 1) {
r__1 = 1.f / sigma;
sscal_(n, &r__1, &D(1), &c__1);
}
L10:
if (*lwork > 0) {
WORK(1) = (real) lwmin;
}
if (*liwork > 0) {
IWORK(1) = liwmin;
}
return 0;
/* End of SSTEVD */
} /* sstevd_ */
/* Subroutine */ int chpev_(char *jobz, char *uplo, integer *n, complex *ap,
real *w, complex *z, integer *ldz, complex *work, real *rwork,
integer *info)
{
/* -- LAPACK driver routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
CHPEV computes all the eigenvalues and, optionally, eigenvectors of a
complex Hermitian matrix in packed storage.
Arguments
=========
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
AP (input/output) COMPLEX array, dimension (N*(N+1)/2)
On entry, the upper or lower triangle of the Hermitian matrix
A, packed columnwise in a linear array. The j-th column of A
is stored in the array AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
On exit, AP is overwritten by values generated during the
reduction to tridiagonal form. If UPLO = 'U', the diagonal
and first superdiagonal of the tridiagonal matrix T overwrite
the corresponding elements of A, and if UPLO = 'L', the
diagonal and first subdiagonal of T overwrite the
corresponding elements of A.
W (output) 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 (max(1, 2*N-1))
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
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer 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 wantz;
static integer iscale;
extern doublereal clanhp_(char *, char *, integer *, complex *, real *), slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*);
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real bignum;
static integer indtau;
extern /* Subroutine */ int chptrd_(char *, integer *, complex *, real *,
real *, complex *, integer *);
static integer indrwk, indwrk;
extern /* Subroutine */ int csteqr_(char *, integer *, real *, real *,
complex *, integer *, real *, integer *), cupgtr_(char *,
integer *, complex *, complex *, complex *, integer *, complex *,
integer *), ssterf_(integer *, real *, real *, integer *);
static real smlnum, eps;
#define AP(I) ap[(I)-1]
#define W(I) w[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define Z(I,J) z[(I)-1 + ((J)-1)* ( *ldz)]
wantz = lsame_(jobz, "V");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (lsame_(uplo, "L") || lsame_(uplo, "U"))) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHPEV ", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
W(1) = AP(1).r;
RWORK(1) = 1.f;
if (wantz) {
i__1 = z_dim1 + 1;
Z(1,1).r = 1.f, Z(1,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 = clanhp_("M", uplo, n, &AP(1), &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) {
i__1 = *n * (*n + 1) / 2;
csscal_(&i__1, &sigma, &AP(1), &c__1);
}
/* Call CHPTRD to reduce Hermitian packed matrix to tridiagonal form.
*/
inde = 1;
indtau = 1;
chptrd_(uplo, n, &AP(1), &W(1), &RWORK(inde), &WORK(indtau), &iinfo);
/* For eigenvalues only, call SSTERF. For eigenvectors, first call
CUPGTR to generate the orthogonal matrix, then call CSTEQR. */
if (! wantz) {
ssterf_(n, &W(1), &RWORK(inde), info);
} else {
indwrk = indtau + *n;
cupgtr_(uplo, n, &AP(1), &WORK(indtau), &Z(1,1), ldz, &WORK(
indwrk), &iinfo);
indrwk = inde + *n;
csteqr_(jobz, n, &W(1), &RWORK(inde), &Z(1,1), 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 CHPEV */
} /* chpev_ */
/* Subroutine */
int cheev_(char *jobz, char *uplo, integer *n, complex *a, integer *lda, real *w, complex *work, integer *lwork, real *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer nb;
real eps;
integer inde;
real anrm;
integer imax;
real rmin, rmax, sigma;
extern logical lsame_(char *, char *);
integer iinfo;
extern /* Subroutine */
int sscal_(integer *, real *, real *, integer *);
logical lower, wantz;
extern real clanhe_(char *, char *, integer *, complex *, integer *, real *);
integer iscale;
extern /* Subroutine */
int clascl_(char *, integer *, integer *, real *, real *, integer *, integer *, complex *, integer *, integer *);
extern real slamch_(char *);
extern /* Subroutine */
int chetrd_(char *, integer *, complex *, integer *, real *, real *, complex *, complex *, integer *, integer *);
real safmin;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
extern /* Subroutine */
int xerbla_(char *, integer *);
real bignum;
integer indtau, indwrk;
extern /* Subroutine */
int csteqr_(char *, integer *, real *, real *, complex *, integer *, real *, integer *), cungtr_(char *, integer *, complex *, integer *, complex *, complex *, integer *, integer *), ssterf_(integer *, real *, real *, integer *);
integer llwork;
real smlnum;
integer lwkopt;
logical lquery;
/* -- LAPACK driver routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
--work;
--rwork;
/* Function Body */
wantz = lsame_(jobz, "V");
lower = lsame_(uplo, "L");
lquery = *lwork == -1;
*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 (*lda < max(1,*n))
{
*info = -5;
}
if (*info == 0)
{
nb = ilaenv_(&c__1, "CHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
/* Computing MAX */
i__1 = 1;
i__2 = (nb + 1) * *n; // , expr subst
lwkopt = max(i__1,i__2);
work[1].r = (real) lwkopt;
work[1].i = 0.f; // , expr subst
/* Computing MAX */
i__1 = 1;
i__2 = (*n << 1) - 1; // , expr subst
if (*lwork < max(i__1,i__2) && ! lquery)
{
*info = -8;
}
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CHEEV ", &i__1);
return 0;
}
else if (lquery)
{
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
if (*n == 1)
{
i__1 = a_dim1 + 1;
w[1] = a[i__1].r;
work[1].r = 1.f;
work[1].i = 0.f; // , expr subst
if (wantz)
{
i__1 = a_dim1 + 1;
a[i__1].r = 1.f;
a[i__1].i = 0.f; // , expr subst
}
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 = clanhe_("M", uplo, n, &a[a_offset], lda, &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)
{
clascl_(uplo, &c__0, &c__0, &c_b18, &sigma, n, n, &a[a_offset], lda, info);
}
/* Call CHETRD to reduce Hermitian matrix to tridiagonal form. */
inde = 1;
indtau = 1;
indwrk = indtau + *n;
llwork = *lwork - indwrk + 1;
chetrd_(uplo, n, &a[a_offset], lda, &w[1], &rwork[inde], &work[indtau], & work[indwrk], &llwork, &iinfo);
/* For eigenvalues only, call SSTERF. For eigenvectors, first call */
/* CUNGTR to generate the unitary matrix, then call CSTEQR. */
if (! wantz)
{
ssterf_(n, &w[1], &rwork[inde], info);
}
else
{
cungtr_(uplo, n, &a[a_offset], lda, &work[indtau], &work[indwrk], & llwork, &iinfo);
indwrk = inde + *n;
csteqr_(jobz, n, &w[1], &rwork[inde], &a[a_offset], lda, &rwork[ indwrk], 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);
}
/* Set WORK(1) to optimal complex workspace size. */
work[1].r = (real) lwkopt;
work[1].i = 0.f; // , expr subst
return 0;
/* End of CHEEV */
}
/* Subroutine */ int spotf2_(char *uplo, integer *n, real *a, integer *lda,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
real r__1;
/* Local variables */
integer j;
real ajj;
logical upper;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* SPOTF2 computes the Cholesky factorization of a real symmetric */
/* positive definite 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 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 */
/* symmetric matrix A is stored. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the symmetric 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 factor U or L from the Cholesky */
/* factorization A = U'*U or A = L*L'. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* > 0: if INFO = k, the leading minor of order k is not */
/* positive definite, and the factorization could not be */
/* completed. */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPOTF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
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 = j - 1;
ajj = a[j + j * a_dim1] - sdot_(&i__2, &a[j * a_dim1 + 1], &c__1,
&a[j * a_dim1 + 1], &c__1);
if (ajj <= 0.f || sisnan_(&ajj)) {
a[j + j * a_dim1] = ajj;
goto L30;
}
ajj = sqrt(ajj);
a[j + j * a_dim1] = ajj;
/* Compute elements J+1:N of row J. */
if (j < *n) {
i__2 = j - 1;
i__3 = *n - j;
sgemv_("Transpose", &i__2, &i__3, &c_b10, &a[(j + 1) * a_dim1
+ 1], lda, &a[j * a_dim1 + 1], &c__1, &c_b12, &a[j + (
j + 1) * a_dim1], lda);
i__2 = *n - j;
r__1 = 1.f / ajj;
sscal_(&i__2, &r__1, &a[j + (j + 1) * a_dim1], lda);
}
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute L(J,J) and test for non-positive-definiteness. */
i__2 = j - 1;
ajj = a[j + j * a_dim1] - sdot_(&i__2, &a[j + a_dim1], lda, &a[j
+ a_dim1], lda);
if (ajj <= 0.f || sisnan_(&ajj)) {
a[j + j * a_dim1] = ajj;
goto L30;
}
ajj = sqrt(ajj);
a[j + j * a_dim1] = ajj;
/* Compute elements J+1:N of column J. */
if (j < *n) {
i__2 = *n - j;
i__3 = j - 1;
sgemv_("No transpose", &i__2, &i__3, &c_b10, &a[j + 1 +
a_dim1], lda, &a[j + a_dim1], lda, &c_b12, &a[j + 1 +
j * a_dim1], &c__1);
i__2 = *n - j;
r__1 = 1.f / ajj;
sscal_(&i__2, &r__1, &a[j + 1 + j * a_dim1], &c__1);
}
}
}
goto L40;
L30:
*info = j;
L40:
return 0;
/* End of SPOTF2 */
} /* spotf2_ */
int slaein_(int *rightv, int *noinit, int *n,
float *h__, int *ldh, float *wr, float *wi, float *vr, float *vi, float
*b, int *ldb, float *work, float *eps3, float *smlnum, float *bignum,
int *info)
{
/* System generated locals */
int b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4;
float r__1, r__2, r__3, r__4;
/* Builtin functions */
double sqrt(double);
/* Local variables */
int i__, j;
float w, x, y;
int i1, i2, i3;
float w1, ei, ej, xi, xr, rec;
int its, ierr;
float temp, norm, vmax;
extern double snrm2_(int *, float *, int *);
float scale;
extern int sscal_(int *, float *, float *, int *);
char trans[1];
float vcrit;
extern double sasum_(int *, float *, int *);
float rootn, vnorm;
extern double slapy2_(float *, float *);
float absbii, absbjj;
extern int isamax_(int *, float *, int *);
extern int sladiv_(float *, float *, float *, float *, float *
, float *);
char normin[1];
float nrmsml;
extern int slatrs_(char *, char *, char *, char *,
int *, float *, int *, float *, float *, float *, int *);
float growto;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLAEIN uses inverse iteration to find a right or left eigenvector */
/* corresponding to the eigenvalue (WR,WI) of a float 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 (VR,VI). */
/* = .FALSE.: initial vector supplied in (VR,VI). */
/* N (input) INTEGER */
/* The order of the matrix H. N >= 0. */
/* H (input) REAL array, dimension (LDH,N) */
/* The upper Hessenberg matrix H. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= MAX(1,N). */
/* WR (input) REAL */
/* WI (input) REAL */
/* The float and imaginary parts of the eigenvalue of H whose */
/* corresponding right or left eigenvector is to be computed. */
/* VR (input/output) REAL array, dimension (N) */
/* VI (input/output) REAL array, dimension (N) */
/* On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain */
/* a float starting vector for inverse iteration using the float */
/* eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI */
/* must contain the float and imaginary parts of a complex */
/* starting vector for inverse iteration using the complex */
/* eigenvalue (WR,WI); otherwise VR and VI need not be set. */
/* On exit, if WI = 0.0 (float eigenvalue), VR contains the */
/* computed float eigenvector; if WI.ne.0.0 (complex eigenvalue), */
/* VR and VI contain the float and imaginary parts of the */
/* computed complex eigenvector. The eigenvector is 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|. */
/* VI is not referenced if WI = 0.0. */
/* B (workspace) REAL array, dimension (LDB,N) */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= N+1. */
/* WORK (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. */
/* BIGNUM (input) REAL */
/* A machine-dependent value close to the overflow threshold. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* = 1: inverse iteration did not converge; VR is set to the */
/* last iterate, and so is VI if WI.ne.0.0. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--vr;
--vi;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--work;
/* Function Body */
*info = 0;
/* GROWTO is the threshold used in the acceptance test for an */
/* eigenvector. */
rootn = sqrt((float) (*n));
growto = .1f / rootn;
/* Computing MAX */
r__1 = 1.f, r__2 = *eps3 * rootn;
nrmsml = MAX(r__1,r__2) * *smlnum;
/* Form B = H - (WR,WI)*I (except that the subdiagonal elements and */
/* the imaginary parts of the diagonal 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__) {
b[i__ + j * b_dim1] = h__[i__ + j * h_dim1];
/* L10: */
}
b[j + j * b_dim1] = h__[j + j * h_dim1] - *wr;
/* L20: */
}
if (*wi == 0.f) {
/* Real eigenvalue. */
if (*noinit) {
/* Set initial vector. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
vr[i__] = *eps3;
/* L30: */
}
} else {
/* Scale supplied initial vector. */
vnorm = snrm2_(n, &vr[1], &c__1);
r__1 = *eps3 * rootn / MAX(vnorm,nrmsml);
sscal_(n, &r__1, &vr[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__) {
ei = h__[i__ + 1 + i__ * h_dim1];
if ((r__1 = b[i__ + i__ * b_dim1], ABS(r__1)) < ABS(ei)) {
/* Interchange rows and eliminate. */
x = b[i__ + i__ * b_dim1] / ei;
b[i__ + i__ * b_dim1] = ei;
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
temp = b[i__ + 1 + j * b_dim1];
b[i__ + 1 + j * b_dim1] = b[i__ + j * b_dim1] - x *
temp;
b[i__ + j * b_dim1] = temp;
/* L40: */
}
} else {
/* Eliminate without interchange. */
if (b[i__ + i__ * b_dim1] == 0.f) {
b[i__ + i__ * b_dim1] = *eps3;
}
x = ei / b[i__ + i__ * b_dim1];
if (x != 0.f) {
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
b[i__ + 1 + j * b_dim1] -= x * b[i__ + j * b_dim1]
;
/* L50: */
}
}
}
/* L60: */
}
if (b[*n + *n * b_dim1] == 0.f) {
b[*n + *n * b_dim1] = *eps3;
}
*(unsigned char *)trans = 'N';
} else {
/* UL decomposition with partial pivoting of B, replacing zero */
/* pivots by EPS3. */
for (j = *n; j >= 2; --j) {
ej = h__[j + (j - 1) * h_dim1];
if ((r__1 = b[j + j * b_dim1], ABS(r__1)) < ABS(ej)) {
/* Interchange columns and eliminate. */
x = b[j + j * b_dim1] / ej;
b[j + j * b_dim1] = ej;
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = b[i__ + (j - 1) * b_dim1];
b[i__ + (j - 1) * b_dim1] = b[i__ + j * b_dim1] - x *
temp;
b[i__ + j * b_dim1] = temp;
/* L70: */
}
} else {
/* Eliminate without interchange. */
if (b[j + j * b_dim1] == 0.f) {
b[j + j * b_dim1] = *eps3;
}
x = ej / b[j + j * b_dim1];
if (x != 0.f) {
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
b[i__ + (j - 1) * b_dim1] -= x * b[i__ + j *
b_dim1];
/* L80: */
}
}
}
/* L90: */
}
if (b[b_dim1 + 1] == 0.f) {
b[b_dim1 + 1] = *eps3;
}
*(unsigned char *)trans = 'T';
}
*(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. */
slatrs_("Upper", trans, "Nonunit", normin, n, &b[b_offset], ldb, &
vr[1], &scale, &work[1], &ierr);
*(unsigned char *)normin = 'Y';
/* Test for sufficient growth in the norm of v. */
vnorm = sasum_(n, &vr[1], &c__1);
if (vnorm >= growto * scale) {
goto L120;
}
/* Choose new orthogonal starting vector and try again. */
temp = *eps3 / (rootn + 1.f);
vr[1] = *eps3;
i__2 = *n;
for (i__ = 2; i__ <= i__2; ++i__) {
vr[i__] = temp;
/* L100: */
}
vr[*n - its + 1] -= *eps3 * rootn;
/* L110: */
}
/* Failure to find eigenvector in N iterations. */
*info = 1;
L120:
/* Normalize eigenvector. */
i__ = isamax_(n, &vr[1], &c__1);
r__2 = 1.f / (r__1 = vr[i__], ABS(r__1));
sscal_(n, &r__2, &vr[1], &c__1);
} else {
/* Complex eigenvalue. */
if (*noinit) {
/* Set initial vector. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
vr[i__] = *eps3;
vi[i__] = 0.f;
/* L130: */
}
} else {
/* Scale supplied initial vector. */
r__1 = snrm2_(n, &vr[1], &c__1);
r__2 = snrm2_(n, &vi[1], &c__1);
norm = slapy2_(&r__1, &r__2);
rec = *eps3 * rootn / MAX(norm,nrmsml);
sscal_(n, &rec, &vr[1], &c__1);
sscal_(n, &rec, &vi[1], &c__1);
}
if (*rightv) {
/* LU decomposition with partial pivoting of B, replacing zero */
/* pivots by EPS3. */
/* The imaginary part of the (i,j)-th element of U is stored in */
/* B(j+1,i). */
b[b_dim1 + 2] = -(*wi);
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
b[i__ + 1 + b_dim1] = 0.f;
/* L140: */
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
absbii = slapy2_(&b[i__ + i__ * b_dim1], &b[i__ + 1 + i__ *
b_dim1]);
ei = h__[i__ + 1 + i__ * h_dim1];
if (absbii < ABS(ei)) {
/* Interchange rows and eliminate. */
xr = b[i__ + i__ * b_dim1] / ei;
xi = b[i__ + 1 + i__ * b_dim1] / ei;
b[i__ + i__ * b_dim1] = ei;
b[i__ + 1 + i__ * b_dim1] = 0.f;
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
temp = b[i__ + 1 + j * b_dim1];
b[i__ + 1 + j * b_dim1] = b[i__ + j * b_dim1] - xr *
temp;
b[j + 1 + (i__ + 1) * b_dim1] = b[j + 1 + i__ *
b_dim1] - xi * temp;
b[i__ + j * b_dim1] = temp;
b[j + 1 + i__ * b_dim1] = 0.f;
/* L150: */
}
b[i__ + 2 + i__ * b_dim1] = -(*wi);
b[i__ + 1 + (i__ + 1) * b_dim1] -= xi * *wi;
b[i__ + 2 + (i__ + 1) * b_dim1] += xr * *wi;
} else {
/* Eliminate without interchanging rows. */
if (absbii == 0.f) {
b[i__ + i__ * b_dim1] = *eps3;
b[i__ + 1 + i__ * b_dim1] = 0.f;
absbii = *eps3;
}
ei = ei / absbii / absbii;
xr = b[i__ + i__ * b_dim1] * ei;
xi = -b[i__ + 1 + i__ * b_dim1] * ei;
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
b[i__ + 1 + j * b_dim1] = b[i__ + 1 + j * b_dim1] -
xr * b[i__ + j * b_dim1] + xi * b[j + 1 + i__
* b_dim1];
b[j + 1 + (i__ + 1) * b_dim1] = -xr * b[j + 1 + i__ *
b_dim1] - xi * b[i__ + j * b_dim1];
/* L160: */
}
b[i__ + 2 + (i__ + 1) * b_dim1] -= *wi;
}
/* Compute 1-norm of offdiagonal elements of i-th row. */
i__2 = *n - i__;
i__3 = *n - i__;
work[i__] = sasum_(&i__2, &b[i__ + (i__ + 1) * b_dim1], ldb)
+ sasum_(&i__3, &b[i__ + 2 + i__ * b_dim1], &c__1);
/* L170: */
}
if (b[*n + *n * b_dim1] == 0.f && b[*n + 1 + *n * b_dim1] == 0.f)
{
b[*n + *n * b_dim1] = *eps3;
}
work[*n] = 0.f;
i1 = *n;
i2 = 1;
i3 = -1;
} else {
/* UL decomposition with partial pivoting of conjg(B), */
/* replacing zero pivots by EPS3. */
/* The imaginary part of the (i,j)-th element of U is stored in */
/* B(j+1,i). */
b[*n + 1 + *n * b_dim1] = *wi;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
b[*n + 1 + j * b_dim1] = 0.f;
/* L180: */
}
for (j = *n; j >= 2; --j) {
ej = h__[j + (j - 1) * h_dim1];
absbjj = slapy2_(&b[j + j * b_dim1], &b[j + 1 + j * b_dim1]);
if (absbjj < ABS(ej)) {
/* Interchange columns and eliminate */
xr = b[j + j * b_dim1] / ej;
xi = b[j + 1 + j * b_dim1] / ej;
b[j + j * b_dim1] = ej;
b[j + 1 + j * b_dim1] = 0.f;
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = b[i__ + (j - 1) * b_dim1];
b[i__ + (j - 1) * b_dim1] = b[i__ + j * b_dim1] - xr *
temp;
b[j + i__ * b_dim1] = b[j + 1 + i__ * b_dim1] - xi *
temp;
b[i__ + j * b_dim1] = temp;
b[j + 1 + i__ * b_dim1] = 0.f;
/* L190: */
}
b[j + 1 + (j - 1) * b_dim1] = *wi;
b[j - 1 + (j - 1) * b_dim1] += xi * *wi;
b[j + (j - 1) * b_dim1] -= xr * *wi;
} else {
/* Eliminate without interchange. */
if (absbjj == 0.f) {
b[j + j * b_dim1] = *eps3;
b[j + 1 + j * b_dim1] = 0.f;
absbjj = *eps3;
}
ej = ej / absbjj / absbjj;
xr = b[j + j * b_dim1] * ej;
xi = -b[j + 1 + j * b_dim1] * ej;
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
b[i__ + (j - 1) * b_dim1] = b[i__ + (j - 1) * b_dim1]
- xr * b[i__ + j * b_dim1] + xi * b[j + 1 +
i__ * b_dim1];
b[j + i__ * b_dim1] = -xr * b[j + 1 + i__ * b_dim1] -
xi * b[i__ + j * b_dim1];
/* L200: */
}
b[j + (j - 1) * b_dim1] += *wi;
}
/* Compute 1-norm of offdiagonal elements of j-th column. */
i__1 = j - 1;
i__2 = j - 1;
work[j] = sasum_(&i__1, &b[j * b_dim1 + 1], &c__1) + sasum_(&
i__2, &b[j + 1 + b_dim1], ldb);
/* L210: */
}
if (b[b_dim1 + 1] == 0.f && b[b_dim1 + 2] == 0.f) {
b[b_dim1 + 1] = *eps3;
}
work[1] = 0.f;
i1 = 1;
i2 = *n;
i3 = 1;
}
i__1 = *n;
for (its = 1; its <= i__1; ++its) {
scale = 1.f;
vmax = 1.f;
vcrit = *bignum;
/* Solve U*(xr,xi) = scale*(vr,vi) for a right eigenvector, */
/* or U'*(xr,xi) = scale*(vr,vi) for a left eigenvector, */
/* overwriting (xr,xi) on (vr,vi). */
i__2 = i2;
i__3 = i3;
for (i__ = i1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3)
{
if (work[i__] > vcrit) {
rec = 1.f / vmax;
sscal_(n, &rec, &vr[1], &c__1);
sscal_(n, &rec, &vi[1], &c__1);
scale *= rec;
vmax = 1.f;
vcrit = *bignum;
}
xr = vr[i__];
xi = vi[i__];
if (*rightv) {
i__4 = *n;
for (j = i__ + 1; j <= i__4; ++j) {
xr = xr - b[i__ + j * b_dim1] * vr[j] + b[j + 1 + i__
* b_dim1] * vi[j];
xi = xi - b[i__ + j * b_dim1] * vi[j] - b[j + 1 + i__
* b_dim1] * vr[j];
/* L220: */
}
} else {
i__4 = i__ - 1;
for (j = 1; j <= i__4; ++j) {
xr = xr - b[j + i__ * b_dim1] * vr[j] + b[i__ + 1 + j
* b_dim1] * vi[j];
xi = xi - b[j + i__ * b_dim1] * vi[j] - b[i__ + 1 + j
* b_dim1] * vr[j];
/* L230: */
}
}
w = (r__1 = b[i__ + i__ * b_dim1], ABS(r__1)) + (r__2 = b[
i__ + 1 + i__ * b_dim1], ABS(r__2));
if (w > *smlnum) {
if (w < 1.f) {
w1 = ABS(xr) + ABS(xi);
if (w1 > w * *bignum) {
rec = 1.f / w1;
sscal_(n, &rec, &vr[1], &c__1);
sscal_(n, &rec, &vi[1], &c__1);
xr = vr[i__];
xi = vi[i__];
scale *= rec;
vmax *= rec;
}
}
/* Divide by diagonal element of B. */
sladiv_(&xr, &xi, &b[i__ + i__ * b_dim1], &b[i__ + 1 +
i__ * b_dim1], &vr[i__], &vi[i__]);
/* Computing MAX */
r__3 = (r__1 = vr[i__], ABS(r__1)) + (r__2 = vi[i__],
ABS(r__2));
vmax = MAX(r__3,vmax);
vcrit = *bignum / vmax;
} else {
i__4 = *n;
for (j = 1; j <= i__4; ++j) {
vr[j] = 0.f;
vi[j] = 0.f;
/* L240: */
}
vr[i__] = 1.f;
vi[i__] = 1.f;
scale = 0.f;
vmax = 1.f;
vcrit = *bignum;
}
/* L250: */
}
/* Test for sufficient growth in the norm of (VR,VI). */
vnorm = sasum_(n, &vr[1], &c__1) + sasum_(n, &vi[1], &c__1);
if (vnorm >= growto * scale) {
goto L280;
}
/* Choose a new orthogonal starting vector and try again. */
y = *eps3 / (rootn + 1.f);
vr[1] = *eps3;
vi[1] = 0.f;
i__3 = *n;
for (i__ = 2; i__ <= i__3; ++i__) {
vr[i__] = y;
vi[i__] = 0.f;
/* L260: */
}
vr[*n - its + 1] -= *eps3 * rootn;
/* L270: */
}
/* Failure to find eigenvector in N iterations */
*info = 1;
L280:
/* Normalize eigenvector. */
vnorm = 0.f;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__3 = vnorm, r__4 = (r__1 = vr[i__], ABS(r__1)) + (r__2 = vi[
i__], ABS(r__2));
vnorm = MAX(r__3,r__4);
/* L290: */
}
r__1 = 1.f / vnorm;
sscal_(n, &r__1, &vr[1], &c__1);
r__1 = 1.f / vnorm;
sscal_(n, &r__1, &vi[1], &c__1);
}
return 0;
/* End of SLAEIN */
} /* slaein_ */
/* Subroutine */ int shseqr_(char *job, char *compz, integer *n, integer *ilo,
integer *ihi, real *h__, integer *ldh, real *wr, real *wi, real *z__,
integer *ldz, real *work, integer *lwork, integer *info, ftnlen
job_len, ftnlen compz_len)
{
/* System generated locals */
address a__1[2];
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3[2], i__4,
i__5;
real r__1, r__2;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static integer i__, j, k, l;
static real s[225] /* was [15][15] */, v[16];
static integer i1, i2, ii, nh, nr, ns, nv;
static real vv[16];
static integer itn;
static real tau;
static integer its;
static real ulp, tst1;
static integer maxb;
static real absw;
static integer ierr;
static real unfl, temp, ovfl;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static integer itemp;
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *,
ftnlen);
static logical initz, wantt;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
static logical wantz;
extern doublereal slapy2_(real *, real *);
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal slamch_(char *, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *,
real *);
extern integer isamax_(integer *, real *, integer *);
extern doublereal slanhs_(char *, integer *, real *, integer *, real *,
ftnlen);
extern /* Subroutine */ int slahqr_(logical *, logical *, integer *,
integer *, integer *, real *, integer *, real *, real *, integer *
, integer *, real *, integer *, integer *), slacpy_(char *,
integer *, integer *, real *, integer *, real *, integer *,
ftnlen), slaset_(char *, integer *, integer *, real *, real *,
real *, integer *, ftnlen), slarfx_(char *, integer *, integer *,
real *, real *, real *, integer *, real *, ftnlen);
static real smlnum;
static logical lquery;
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SHSEQR computes the eigenvalues of a real upper Hessenberg matrix H */
/* and, optionally, the matrices T and Z from the Schur decomposition */
/* H = Z T Z**T, where T is an upper quasi-triangular matrix (the Schur */
/* form), and Z is the orthogonal matrix of Schur vectors. */
/* Optionally Z may be postmultiplied into an input orthogonal matrix Q, */
/* so that this routine can give the Schur factorization of a matrix A */
/* which has been reduced to the Hessenberg form H by the orthogonal */
/* matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* = 'E': compute eigenvalues only; */
/* = 'S': compute eigenvalues and the Schur form T. */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': no Schur vectors are computed; */
/* = 'I': Z is initialized to the unit matrix and the matrix Z */
/* of Schur vectors of H is returned; */
/* = 'V': Z must contain an orthogonal matrix Q on entry, and */
/* the product Q*Z is returned. */
/* N (input) INTEGER */
/* The order of the matrix H. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that H is already upper triangular in rows */
/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
/* set by a previous call to SGEBAL, and then passed to SGEHRD */
/* when the matrix output by SGEBAL is reduced to Hessenberg */
/* form. Otherwise ILO and IHI should be set to 1 and N */
/* respectively. */
/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
/* H (input/output) REAL array, dimension (LDH,N) */
/* On entry, the upper Hessenberg matrix H. */
/* On exit, if JOB = 'S', H contains the upper quasi-triangular */
/* matrix T from the Schur decomposition (the Schur form); */
/* 2-by-2 diagonal blocks (corresponding to complex conjugate */
/* pairs of eigenvalues) are returned in standard form, with */
/* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. If JOB = 'E', */
/* the contents of H are unspecified on exit. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= max(1,N). */
/* WR (output) REAL array, dimension (N) */
/* WI (output) REAL array, dimension (N) */
/* The real and imaginary parts, respectively, of the computed */
/* eigenvalues. If two eigenvalues are computed as a complex */
/* conjugate pair, they are stored in consecutive elements of */
/* WR and WI, say the i-th and (i+1)th, with WI(i) > 0 and */
/* WI(i+1) < 0. If JOB = 'S', the eigenvalues are stored in the */
/* same order as on the diagonal of the Schur form returned in */
/* H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 */
/* diagonal block, WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and */
/* WI(i+1) = -WI(i). */
/* Z (input/output) REAL array, dimension (LDZ,N) */
/* If COMPZ = 'N': Z is not referenced. */
/* If COMPZ = 'I': on entry, Z need not be set, and on exit, Z */
/* contains the orthogonal matrix Z of the Schur vectors of H. */
/* If COMPZ = 'V': on entry Z must contain an N-by-N matrix Q, */
/* which is assumed to be equal to the unit matrix except for */
/* the submatrix Z(ILO:IHI,ILO:IHI); on exit Z contains Q*Z. */
/* Normally Q is the orthogonal matrix generated by SORGHR after */
/* the call to SGEHRD which formed the Hessenberg matrix H. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. */
/* LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise. */
/* WORK (workspace/output) REAL array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,N). */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, SHSEQR failed to compute all of the */
/* eigenvalues in a total of 30*(IHI-ILO+1) iterations; */
/* elements 1:ilo-1 and i+1:n of WR and WI contain those */
/* eigenvalues which have been successfully computed. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--wr;
--wi;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
/* Function Body */
wantt = lsame_(job, "S", (ftnlen)1, (ftnlen)1);
initz = lsame_(compz, "I", (ftnlen)1, (ftnlen)1);
wantz = initz || lsame_(compz, "V", (ftnlen)1, (ftnlen)1);
*info = 0;
work[1] = (real) max(1,*n);
lquery = *lwork == -1;
if (! lsame_(job, "E", (ftnlen)1, (ftnlen)1) && ! wantt) {
*info = -1;
} else if (! lsame_(compz, "N", (ftnlen)1, (ftnlen)1) && ! wantz) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ilo < 1 || *ilo > max(1,*n)) {
*info = -4;
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
*info = -5;
} else if (*ldh < max(1,*n)) {
*info = -7;
} else if (*ldz < 1 || wantz && *ldz < max(1,*n)) {
*info = -11;
} else if (*lwork < max(1,*n) && ! lquery) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SHSEQR", &i__1, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
/* Initialize Z, if necessary */
if (initz) {
slaset_("Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz, (ftnlen)4);
}
/* Store the eigenvalues isolated by SGEBAL. */
i__1 = *ilo - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
wr[i__] = h__[i__ + i__ * h_dim1];
wi[i__] = 0.f;
/* L10: */
}
i__1 = *n;
for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
wr[i__] = h__[i__ + i__ * h_dim1];
wi[i__] = 0.f;
/* L20: */
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
wr[*ilo] = h__[*ilo + *ilo * h_dim1];
wi[*ilo] = 0.f;
return 0;
}
/* Set rows and columns ILO to IHI to zero below the first */
/* subdiagonal. */
i__1 = *ihi - 2;
for (j = *ilo; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 2; i__ <= i__2; ++i__) {
h__[i__ + j * h_dim1] = 0.f;
/* L30: */
}
/* L40: */
}
nh = *ihi - *ilo + 1;
/* Determine the order of the multi-shift QR algorithm to be used. */
/* Writing concatenation */
i__3[0] = 1, a__1[0] = job;
i__3[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
ns = ilaenv_(&c__4, "SHSEQR", ch__1, n, ilo, ihi, &c_n1, (ftnlen)6, (
ftnlen)2);
/* Writing concatenation */
i__3[0] = 1, a__1[0] = job;
i__3[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
maxb = ilaenv_(&c__8, "SHSEQR", ch__1, n, ilo, ihi, &c_n1, (ftnlen)6, (
ftnlen)2);
if (ns <= 2 || ns > nh || maxb >= nh) {
/* Use the standard double-shift algorithm */
slahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[
1], ilo, ihi, &z__[z_offset], ldz, info);
return 0;
}
maxb = max(3,maxb);
/* Computing MIN */
i__1 = min(ns,maxb);
ns = min(i__1,15);
/* Now 2 < NS <= MAXB < NH. */
/* Set machine-dependent constants for the stopping criterion. */
/* If norm(H) <= sqrt(OVFL), overflow should not occur. */
unfl = slamch_("Safe minimum", (ftnlen)12);
ovfl = 1.f / unfl;
slabad_(&unfl, &ovfl);
ulp = slamch_("Precision", (ftnlen)9);
smlnum = unfl * (nh / ulp);
/* I1 and I2 are the indices of the first row and last column of H */
/* to which transformations must be applied. If eigenvalues only are */
/* being computed, I1 and I2 are set inside the main loop. */
if (wantt) {
i1 = 1;
i2 = *n;
}
/* ITN is the total number of multiple-shift QR iterations allowed. */
itn = nh * 30;
/* The main loop begins here. I is the loop index and decreases from */
/* IHI to ILO in steps of at most MAXB. Each iteration of the loop */
/* works with the active submatrix in rows and columns L to I. */
/* Eigenvalues I+1 to IHI have already converged. Either L = ILO or */
/* H(L,L-1) is negligible so that the matrix splits. */
i__ = *ihi;
L50:
l = *ilo;
if (i__ < *ilo) {
goto L170;
}
/* Perform multiple-shift QR iterations on rows and columns ILO to I */
/* until a submatrix of order at most MAXB splits off at the bottom */
/* because a subdiagonal element has become negligible. */
i__1 = itn;
for (its = 0; its <= i__1; ++its) {
/* Look for a single small subdiagonal element. */
i__2 = l + 1;
for (k = i__; k >= i__2; --k) {
tst1 = (r__1 = h__[k - 1 + (k - 1) * h_dim1], dabs(r__1)) + (r__2
= h__[k + k * h_dim1], dabs(r__2));
if (tst1 == 0.f) {
i__4 = i__ - l + 1;
tst1 = slanhs_("1", &i__4, &h__[l + l * h_dim1], ldh, &work[1]
, (ftnlen)1);
}
/* Computing MAX */
r__2 = ulp * tst1;
if ((r__1 = h__[k + (k - 1) * h_dim1], dabs(r__1)) <= dmax(r__2,
smlnum)) {
goto L70;
}
/* L60: */
}
L70:
l = k;
if (l > *ilo) {
/* H(L,L-1) is negligible. */
h__[l + (l - 1) * h_dim1] = 0.f;
}
/* Exit from loop if a submatrix of order <= MAXB has split off. */
if (l >= i__ - maxb + 1) {
goto L160;
}
/* Now the active submatrix is in rows and columns L to I. If */
/* eigenvalues only are being computed, only the active submatrix */
/* need be transformed. */
if (! wantt) {
i1 = l;
i2 = i__;
}
if (its == 20 || its == 30) {
/* Exceptional shifts. */
i__2 = i__;
for (ii = i__ - ns + 1; ii <= i__2; ++ii) {
wr[ii] = ((r__1 = h__[ii + (ii - 1) * h_dim1], dabs(r__1)) + (
r__2 = h__[ii + ii * h_dim1], dabs(r__2))) * 1.5f;
wi[ii] = 0.f;
/* L80: */
}
} else {
/* Use eigenvalues of trailing submatrix of order NS as shifts. */
slacpy_("Full", &ns, &ns, &h__[i__ - ns + 1 + (i__ - ns + 1) *
h_dim1], ldh, s, &c__15, (ftnlen)4);
slahqr_(&c_false, &c_false, &ns, &c__1, &ns, s, &c__15, &wr[i__ -
ns + 1], &wi[i__ - ns + 1], &c__1, &ns, &z__[z_offset],
ldz, &ierr);
if (ierr > 0) {
/* If SLAHQR failed to compute all NS eigenvalues, use the */
/* unconverged diagonal elements as the remaining shifts. */
i__2 = ierr;
for (ii = 1; ii <= i__2; ++ii) {
wr[i__ - ns + ii] = s[ii + ii * 15 - 16];
wi[i__ - ns + ii] = 0.f;
/* L90: */
}
}
}
/* Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns)) */
/* where G is the Hessenberg submatrix H(L:I,L:I) and w is */
/* the vector of shifts (stored in WR and WI). The result is */
/* stored in the local array V. */
v[0] = 1.f;
i__2 = ns + 1;
for (ii = 2; ii <= i__2; ++ii) {
v[ii - 1] = 0.f;
/* L100: */
}
nv = 1;
i__2 = i__;
for (j = i__ - ns + 1; j <= i__2; ++j) {
if (wi[j] >= 0.f) {
if (wi[j] == 0.f) {
/* real shift */
i__4 = nv + 1;
scopy_(&i__4, v, &c__1, vv, &c__1);
i__4 = nv + 1;
r__1 = -wr[j];
sgemv_("No transpose", &i__4, &nv, &c_b10, &h__[l + l *
h_dim1], ldh, vv, &c__1, &r__1, v, &c__1, (ftnlen)
12);
++nv;
} else if (wi[j] > 0.f) {
/* complex conjugate pair of shifts */
i__4 = nv + 1;
scopy_(&i__4, v, &c__1, vv, &c__1);
i__4 = nv + 1;
r__1 = wr[j] * -2.f;
sgemv_("No transpose", &i__4, &nv, &c_b10, &h__[l + l *
h_dim1], ldh, v, &c__1, &r__1, vv, &c__1, (ftnlen)
12);
i__4 = nv + 1;
itemp = isamax_(&i__4, vv, &c__1);
/* Computing MAX */
r__2 = (r__1 = vv[itemp - 1], dabs(r__1));
temp = 1.f / dmax(r__2,smlnum);
i__4 = nv + 1;
sscal_(&i__4, &temp, vv, &c__1);
absw = slapy2_(&wr[j], &wi[j]);
temp = temp * absw * absw;
i__4 = nv + 2;
i__5 = nv + 1;
sgemv_("No transpose", &i__4, &i__5, &c_b10, &h__[l + l *
h_dim1], ldh, vv, &c__1, &temp, v, &c__1, (ftnlen)
12);
nv += 2;
}
/* Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero, */
/* reset it to the unit vector. */
itemp = isamax_(&nv, v, &c__1);
temp = (r__1 = v[itemp - 1], dabs(r__1));
if (temp == 0.f) {
v[0] = 1.f;
i__4 = nv;
for (ii = 2; ii <= i__4; ++ii) {
v[ii - 1] = 0.f;
/* L110: */
}
} else {
temp = dmax(temp,smlnum);
r__1 = 1.f / temp;
sscal_(&nv, &r__1, v, &c__1);
}
}
/* L120: */
}
/* Multiple-shift QR step */
i__2 = i__ - 1;
for (k = l; k <= i__2; ++k) {
/* The first iteration of this loop determines a reflection G */
/* from the vector V and applies it from left and right to H, */
/* thus creating a nonzero bulge below the subdiagonal. */
/* Each subsequent iteration determines a reflection G to */
/* restore the Hessenberg form in the (K-1)th column, and thus */
/* chases the bulge one step toward the bottom of the active */
/* submatrix. NR is the order of G. */
/* Computing MIN */
i__4 = ns + 1, i__5 = i__ - k + 1;
nr = min(i__4,i__5);
if (k > l) {
scopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
}
slarfg_(&nr, v, &v[1], &c__1, &tau);
if (k > l) {
h__[k + (k - 1) * h_dim1] = v[0];
i__4 = i__;
for (ii = k + 1; ii <= i__4; ++ii) {
h__[ii + (k - 1) * h_dim1] = 0.f;
/* L130: */
}
}
v[0] = 1.f;
/* Apply G from the left to transform the rows of the matrix in */
/* columns K to I2. */
i__4 = i2 - k + 1;
slarfx_("Left", &nr, &i__4, v, &tau, &h__[k + k * h_dim1], ldh, &
work[1], (ftnlen)4);
/* Apply G from the right to transform the columns of the */
/* matrix in rows I1 to min(K+NR,I). */
/* Computing MIN */
i__5 = k + nr;
i__4 = min(i__5,i__) - i1 + 1;
slarfx_("Right", &i__4, &nr, v, &tau, &h__[i1 + k * h_dim1], ldh,
&work[1], (ftnlen)5);
if (wantz) {
/* Accumulate transformations in the matrix Z */
slarfx_("Right", &nh, &nr, v, &tau, &z__[*ilo + k * z_dim1],
ldz, &work[1], (ftnlen)5);
}
/* L140: */
}
/* L150: */
}
/* Failure to converge in remaining number of iterations */
*info = i__;
return 0;
L160:
/* A submatrix of order <= MAXB in rows and columns L to I has split */
/* off. Use the double-shift QR algorithm to handle it. */
slahqr_(&wantt, &wantz, n, &l, &i__, &h__[h_offset], ldh, &wr[1], &wi[1],
ilo, ihi, &z__[z_offset], ldz, info);
if (*info > 0) {
return 0;
}
/* Decrement number of remaining iterations, and return to start of */
/* the main loop with a new value of I. */
itn -= its;
i__ = l - 1;
goto L50;
L170:
work[1] = (real) max(1,*n);
return 0;
/* End of SHSEQR */
} /* shseqr_ */
/* Subroutine */ int slals0_(integer *icompq, integer *nl, integer *nr,
integer *sqre, integer *nrhs, real *b, integer *ldb, real *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 *
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
December 1, 1999
Purpose
=======
SLALS0 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) REAL 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) REAL 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.
WORK (workspace) REAL array, dimension ( K )
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_b11 = 1.f;
static real c_b13 = 0.f;
static integer c__0 = 0;
/* System generated locals */
integer givcol_dim1, givcol_offset, b_dim1, b_offset, bx_dim1, bx_offset,
difr_dim1, difr_offset, givnum_dim1, givnum_offset, poles_dim1,
poles_offset, i__1, i__2;
real r__1;
/* Local variables */
static real temp;
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *);
extern doublereal snrm2_(integer *, real *, integer *);
static integer i__, j, m, n;
static real diflj, difrj, dsigj;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
sgemv_(char *, integer *, integer *, real *, real *, integer *,
real *, integer *, real *, real *, integer *), scopy_(
integer *, real *, integer *, real *, integer *);
extern doublereal slamc3_(real *, real *);
static real dj;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real dsigjp;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *), slacpy_(char *, integer *, integer *, real *, integer *,
real *, integer *);
static integer nlp1;
#define difr_ref(a_1,a_2) difr[(a_2)*difr_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define poles_ref(a_1,a_2) poles[(a_2)*poles_dim1 + a_1]
#define bx_ref(a_1,a_2) bx[(a_2)*bx_dim1 + a_1]
#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__;
--work;
/* 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_("SLALS0", &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__) {
srot_(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. */
scopy_(nrhs, &b_ref(nlp1, 1), ldb, &bx_ref(1, 1), ldbx);
i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) {
scopy_(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) {
scopy_(nrhs, &bx[bx_offset], ldbx, &b[b_offset], ldb);
if (z__[1] < 0.f) {
sscal_(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) {
work[j] = 0.f;
} else {
work[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) {
work[i__] = 0.f;
} else {
work[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) {
work[i__] = 0.f;
} else {
work[i__] = poles_ref(i__, 2) * z__[i__] / (slamc3_(&
poles_ref(i__, 2), &dsigjp) + difrj) / (
poles_ref(i__, 2) + dj);
}
/* L40: */
}
work[1] = -1.f;
temp = snrm2_(k, &work[1], &c__1);
sgemv_("T", k, nrhs, &c_b11, &bx[bx_offset], ldbx, &work[1], &
c__1, &c_b13, &b_ref(j, 1), ldb);
slascl_("G", &c__0, &c__0, &temp, &c_b11, &c__1, nrhs, &b_ref(
j, 1), ldb, info);
/* L50: */
}
}
/* Move the deflated rows of BX to B also. */
if (*k < max(m,n)) {
i__1 = n - *k;
slacpy_("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) {
scopy_(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) {
work[j] = 0.f;
} else {
work[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) {
work[i__] = 0.f;
} else {
r__1 = -poles_ref(i__ + 1, 2);
work[i__] = z__[j] / (slamc3_(&dsigj, &r__1) -
difr_ref(i__, 1)) / (dsigj + poles_ref(i__, 1)
) / difr_ref(i__, 2);
}
/* L60: */
}
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
if (z__[j] == 0.f) {
work[i__] = 0.f;
} else {
r__1 = -poles_ref(i__, 2);
work[i__] = z__[j] / (slamc3_(&dsigj, &r__1) - difl[
i__]) / (dsigj + poles_ref(i__, 1)) /
difr_ref(i__, 2);
}
/* L70: */
}
sgemv_("T", k, nrhs, &c_b11, &b[b_offset], ldb, &work[1], &
c__1, &c_b13, &bx_ref(j, 1), ldbx);
/* L80: */
}
}
/* Step (2R): if SQRE = 1, apply back the rotation that is
related to the right null space of the subproblem. */
if (*sqre == 1) {
scopy_(nrhs, &b_ref(m, 1), ldb, &bx_ref(m, 1), ldbx);
srot_(nrhs, &bx_ref(1, 1), ldbx, &bx_ref(m, 1), ldbx, c__, s);
}
if (*k < max(m,n)) {
i__1 = n - *k;
slacpy_("A", &i__1, nrhs, &b_ref(*k + 1, 1), ldb, &bx_ref(*k + 1,
1), ldbx);
}
/* Step (3R): permute rows of B. */
scopy_(nrhs, &bx_ref(1, 1), ldbx, &b_ref(nlp1, 1), ldb);
if (*sqre == 1) {
scopy_(nrhs, &bx_ref(m, 1), ldbx, &b_ref(m, 1), ldb);
}
i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) {
scopy_(nrhs, &bx_ref(i__, 1), ldbx, &b_ref(perm[i__], 1), ldb);
/* L90: */
}
/* Step (4R): apply back the Givens rotations performed. */
for (i__ = *givptr; i__ >= 1; --i__) {
r__1 = -givnum_ref(i__, 1);
srot_(nrhs, &b_ref(givcol_ref(i__, 2), 1), ldb, &b_ref(givcol_ref(
i__, 1), 1), ldb, &givnum_ref(i__, 2), &r__1);
/* L100: */
}
}
return 0;
/* End of SLALS0 */
} /* slals0_ */
/* Subroutine */ int sget01_(integer *m, integer *n, real *a, integer *lda,
real *afac, integer *ldafac, integer *ipiv, real *rwork, real *resid)
{
/* System generated locals */
integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2;
/* Local variables */
integer i__, j, k;
real t, eps;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
real anorm;
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *), strmv_(char *, char *, char *, integer *, real *,
integer *, real *, integer *);
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int slaswp_(integer *, real *, integer *, integer
*, integer *, integer *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGET01 reconstructs a matrix A from its L*U factorization and */
/* computes the residual */
/* norm(L*U - A) / ( N * norm(A) * EPS ), */
/* where EPS is the machine epsilon. */
/* Arguments */
/* ========== */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input) REAL array, dimension (LDA,N) */
/* The original M x N matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* AFAC (input/output) REAL array, dimension (LDAFAC,N) */
/* The factored form of the matrix A. AFAC contains the factors */
/* L and U from the L*U factorization as computed by SGETRF. */
/* Overwritten with the reconstructed matrix, and then with the */
/* difference L*U - A. */
/* LDAFAC (input) INTEGER */
/* The leading dimension of the array AFAC. LDAFAC >= max(1,M). */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices from SGETRF. */
/* RWORK (workspace) REAL array, dimension (M) */
/* RESID (output) REAL */
/* norm(L*U - A) / ( N * norm(A) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if M = 0 or N = 0. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
afac_dim1 = *ldafac;
afac_offset = 1 + afac_dim1;
afac -= afac_offset;
--ipiv;
--rwork;
/* Function Body */
if (*m <= 0 || *n <= 0) {
*resid = 0.f;
return 0;
}
/* Determine EPS and the norm of A. */
eps = slamch_("Epsilon");
anorm = slange_("1", m, n, &a[a_offset], lda, &rwork[1]);
/* Compute the product L*U and overwrite AFAC with the result. */
/* A column at a time of the product is obtained, starting with */
/* column N. */
for (k = *n; k >= 1; --k) {
if (k > *m) {
strmv_("Lower", "No transpose", "Unit", m, &afac[afac_offset],
ldafac, &afac[k * afac_dim1 + 1], &c__1);
} else {
/* Compute elements (K+1:M,K) */
t = afac[k + k * afac_dim1];
if (k + 1 <= *m) {
i__1 = *m - k;
sscal_(&i__1, &t, &afac[k + 1 + k * afac_dim1], &c__1);
i__1 = *m - k;
i__2 = k - 1;
sgemv_("No transpose", &i__1, &i__2, &c_b11, &afac[k + 1 +
afac_dim1], ldafac, &afac[k * afac_dim1 + 1], &c__1, &
c_b11, &afac[k + 1 + k * afac_dim1], &c__1);
}
/* Compute the (K,K) element */
i__1 = k - 1;
afac[k + k * afac_dim1] = t + sdot_(&i__1, &afac[k + afac_dim1],
ldafac, &afac[k * afac_dim1 + 1], &c__1);
/* Compute elements (1:K-1,K) */
i__1 = k - 1;
strmv_("Lower", "No transpose", "Unit", &i__1, &afac[afac_offset],
ldafac, &afac[k * afac_dim1 + 1], &c__1);
}
/* L10: */
}
i__1 = min(*m,*n);
slaswp_(n, &afac[afac_offset], ldafac, &c__1, &i__1, &ipiv[1], &c_n1);
/* Compute the difference L*U - A and store in AFAC. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
afac[i__ + j * afac_dim1] -= a[i__ + j * a_dim1];
/* L20: */
}
/* L30: */
}
/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
*resid = slange_("1", m, n, &afac[afac_offset], ldafac, &rwork[1]);
if (anorm <= 0.f) {
if (*resid != 0.f) {
*resid = 1.f / eps;
}
} else {
*resid = *resid / (real) (*n) / anorm / eps;
}
return 0;
/* End of SGET01 */
} /* sget01_ */
/* Subroutine */ int sorgl2_(integer *m, integer *n, integer *k, real *a,
integer *lda, real *tau, real *work, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
SORGL2 generates an m by n real matrix Q with orthonormal rows,
which is defined as the first m rows of a product of k elementary
reflectors of order n
Q = H(k) . . . H(2) H(1)
as returned by SGELQF.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix Q. M >= 0.
N (input) INTEGER
The number of columns of the matrix Q. N >= M.
K (input) INTEGER
The number of elementary reflectors whose product defines the
matrix Q. M >= K >= 0.
A (input/output) REAL array, dimension (LDA,N)
On entry, the i-th row must contain the vector which defines
the elementary reflector H(i), for i = 1,2,...,k, as returned
by SGELQF in the first k rows of its array argument A.
On exit, the m-by-n matrix Q.
LDA (input) INTEGER
The first dimension of the array A. LDA >= max(1,M).
TAU (input) REAL array, dimension (K)
TAU(i) must contain the scalar factor of the elementary
reflector H(i), as returned by SGELQF.
WORK (workspace) REAL array, dimension (M)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument has an illegal value
=====================================================================
Test the input arguments
Parameter adjustments
Function Body */
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
real r__1;
/* Local variables */
static integer i, j, l;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
slarf_(char *, integer *, integer *, real *, integer *, real *,
real *, integer *, real *), xerbla_(char *, integer *);
#define TAU(I) tau[(I)-1]
#define WORK(I) work[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < *m) {
*info = -2;
} else if (*k < 0 || *k > *m) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SORGL2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m <= 0) {
return 0;
}
if (*k < *m) {
/* Initialise rows k+1:m to rows of the unit matrix */
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = *m;
for (l = *k + 1; l <= *m; ++l) {
A(l,j) = 0.f;
/* L10: */
}
if (j > *k && j <= *m) {
A(j,j) = 1.f;
}
/* L20: */
}
}
for (i = *k; i >= 1; --i) {
/* Apply H(i) to A(i:m,i:n) from the right */
if (i < *n) {
if (i < *m) {
A(i,i) = 1.f;
i__1 = *m - i;
i__2 = *n - i + 1;
slarf_("Right", &i__1, &i__2, &A(i,i), lda, &TAU(i)
, &A(i+1,i), lda, &WORK(1));
}
i__1 = *n - i;
r__1 = -(doublereal)TAU(i);
sscal_(&i__1, &r__1, &A(i,i+1), lda);
}
A(i,i) = 1.f - TAU(i);
/* Set A(1:i-1,i) to zero */
i__1 = i - 1;
for (l = 1; l <= i-1; ++l) {
A(i,l) = 0.f;
/* L30: */
}
/* L40: */
}
return 0;
/* End of SORGL2 */
} /* sorgl2_ */
/* Subroutine */ int stgsja_(char *jobu, char *jobv, char *jobq, integer *m,
integer *p, integer *n, integer *k, integer *l, real *a, integer *lda,
real *b, integer *ldb, real *tola, real *tolb, real *alpha, real *
beta, real *u, integer *ldu, real *v, integer *ldv, real *q, integer *
ldq, real *work, integer *ncycle, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1,
u_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4;
real r__1;
/* Local variables */
integer i__, j;
real a1, a2, a3, b1, b2, b3, csq, csu, csv, snq, rwk, snu, snv;
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *);
real gamma;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
logical initq, initu, initv, wantq, upper;
real error, ssmin;
logical wantu, wantv;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), slags2_(logical *, real *, real *, real *, real *,
real *, real *, real *, real *, real *, real *, real *, real *);
integer kcycle;
extern /* Subroutine */ int xerbla_(char *, integer *), slapll_(
integer *, real *, integer *, real *, integer *, real *), slartg_(
real *, real *, real *, real *, real *), slaset_(char *, integer *
, integer *, real *, real *, real *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* STGSJA computes the generalized singular value decomposition (GSVD) */
/* of two real upper triangular (or trapezoidal) matrices A and B. */
/* On entry, it is assumed that matrices A and B have the following */
/* forms, which may be obtained by the preprocessing subroutine SGGSVP */
/* from a general M-by-N matrix A and P-by-N matrix B: */
/* N-K-L K L */
/* A = K ( 0 A12 A13 ) if M-K-L >= 0; */
/* L ( 0 0 A23 ) */
/* M-K-L ( 0 0 0 ) */
/* N-K-L K L */
/* A = K ( 0 A12 A13 ) if M-K-L < 0; */
/* M-K ( 0 0 A23 ) */
/* N-K-L K L */
/* B = L ( 0 0 B13 ) */
/* P-L ( 0 0 0 ) */
/* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */
/* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */
/* otherwise A23 is (M-K)-by-L upper trapezoidal. */
/* On exit, */
/* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ), */
/* where U, V and Q are orthogonal matrices, Z' denotes the transpose */
/* of Z, R is a nonsingular upper triangular matrix, and D1 and D2 are */
/* ``diagonal'' matrices, which are of the following structures: */
/* If M-K-L >= 0, */
/* K L */
/* D1 = K ( I 0 ) */
/* L ( 0 C ) */
/* M-K-L ( 0 0 ) */
/* K L */
/* D2 = L ( 0 S ) */
/* P-L ( 0 0 ) */
/* N-K-L K L */
/* ( 0 R ) = K ( 0 R11 R12 ) K */
/* L ( 0 0 R22 ) L */
/* where */
/* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */
/* S = diag( BETA(K+1), ... , BETA(K+L) ), */
/* C**2 + S**2 = I. */
/* R is stored in A(1:K+L,N-K-L+1:N) on exit. */
/* If M-K-L < 0, */
/* K M-K K+L-M */
/* D1 = K ( I 0 0 ) */
/* M-K ( 0 C 0 ) */
/* K M-K K+L-M */
/* D2 = M-K ( 0 S 0 ) */
/* K+L-M ( 0 0 I ) */
/* P-L ( 0 0 0 ) */
/* N-K-L K M-K K+L-M */
/* ( 0 R ) = K ( 0 R11 R12 R13 ) */
/* M-K ( 0 0 R22 R23 ) */
/* K+L-M ( 0 0 0 R33 ) */
/* where */
/* C = diag( ALPHA(K+1), ... , ALPHA(M) ), */
/* S = diag( BETA(K+1), ... , BETA(M) ), */
/* C**2 + S**2 = I. */
/* R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored */
/* ( 0 R22 R23 ) */
/* in B(M-K+1:L,N+M-K-L+1:N) on exit. */
/* The computation of the orthogonal transformation matrices U, V or Q */
/* is optional. These matrices may either be formed explicitly, or they */
/* may be postmultiplied into input matrices U1, V1, or Q1. */
/* Arguments */
/* ========= */
/* JOBU (input) CHARACTER*1 */
/* = 'U': U must contain an orthogonal matrix U1 on entry, and */
/* the product U1*U is returned; */
/* = 'I': U is initialized to the unit matrix, and the */
/* orthogonal matrix U is returned; */
/* = 'N': U is not computed. */
/* JOBV (input) CHARACTER*1 */
/* = 'V': V must contain an orthogonal matrix V1 on entry, and */
/* the product V1*V is returned; */
/* = 'I': V is initialized to the unit matrix, and the */
/* orthogonal matrix V is returned; */
/* = 'N': V is not computed. */
/* JOBQ (input) CHARACTER*1 */
/* = 'Q': Q must contain an orthogonal matrix Q1 on entry, and */
/* the product Q1*Q is returned; */
/* = 'I': Q is initialized to the unit matrix, and the */
/* orthogonal matrix Q is returned; */
/* = 'N': Q is not computed. */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* P (input) INTEGER */
/* The number of rows of the matrix B. P >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrices A and B. N >= 0. */
/* K (input) INTEGER */
/* L (input) INTEGER */
/* K and L specify the subblocks in the input matrices A and B: */
/* A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N) */
/* of A and B, whose GSVD is going to be computed by STGSJA. */
/* See Further details. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular */
/* matrix R or part of R. See Purpose for details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* B (input/output) REAL array, dimension (LDB,N) */
/* On entry, the P-by-N matrix B. */
/* On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains */
/* a part of R. See Purpose for details. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,P). */
/* TOLA (input) REAL */
/* TOLB (input) REAL */
/* TOLA and TOLB are the convergence criteria for the Jacobi- */
/* Kogbetliantz iteration procedure. Generally, they are the */
/* same as used in the preprocessing step, say */
/* TOLA = max(M,N)*norm(A)*MACHEPS, */
/* TOLB = max(P,N)*norm(B)*MACHEPS. */
/* ALPHA (output) REAL array, dimension (N) */
/* BETA (output) REAL array, dimension (N) */
/* On exit, ALPHA and BETA contain the generalized singular */
/* value pairs of A and B; */
/* ALPHA(1:K) = 1, */
/* BETA(1:K) = 0, */
/* and if M-K-L >= 0, */
/* ALPHA(K+1:K+L) = diag(C), */
/* BETA(K+1:K+L) = diag(S), */
/* or if M-K-L < 0, */
/* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0 */
/* BETA(K+1:M) = S, BETA(M+1:K+L) = 1. */
/* Furthermore, if K+L < N, */
/* ALPHA(K+L+1:N) = 0 and */
/* BETA(K+L+1:N) = 0. */
/* U (input/output) REAL array, dimension (LDU,M) */
/* On entry, if JOBU = 'U', U must contain a matrix U1 (usually */
/* the orthogonal matrix returned by SGGSVP). */
/* On exit, */
/* if JOBU = 'I', U contains the orthogonal matrix U; */
/* if JOBU = 'U', U contains the product U1*U. */
/* If JOBU = 'N', U is not referenced. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= max(1,M) if */
/* JOBU = 'U'; LDU >= 1 otherwise. */
/* V (input/output) REAL array, dimension (LDV,P) */
/* On entry, if JOBV = 'V', V must contain a matrix V1 (usually */
/* the orthogonal matrix returned by SGGSVP). */
/* On exit, */
/* if JOBV = 'I', V contains the orthogonal matrix V; */
/* if JOBV = 'V', V contains the product V1*V. */
/* If JOBV = 'N', V is not referenced. */
/* LDV (input) INTEGER */
/* The leading dimension of the array V. LDV >= max(1,P) if */
/* JOBV = 'V'; LDV >= 1 otherwise. */
/* Q (input/output) REAL array, dimension (LDQ,N) */
/* On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually */
/* the orthogonal matrix returned by SGGSVP). */
/* On exit, */
/* if JOBQ = 'I', Q contains the orthogonal matrix Q; */
/* if JOBQ = 'Q', Q contains the product Q1*Q. */
/* If JOBQ = 'N', Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= max(1,N) if */
/* JOBQ = 'Q'; LDQ >= 1 otherwise. */
/* WORK (workspace) REAL array, dimension (2*N) */
/* NCYCLE (output) INTEGER */
/* The number of cycles required for convergence. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* = 1: the procedure does not converge after MAXIT cycles. */
/* Internal Parameters */
/* =================== */
/* MAXIT INTEGER */
/* MAXIT specifies the total loops that the iterative procedure */
/* may take. If after MAXIT cycles, the routine fails to */
/* converge, we return INFO = 1. */
/* Further Details */
/* =============== */
/* STGSJA essentially uses a variant of Kogbetliantz algorithm to reduce */
/* min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L */
/* matrix B13 to the form: */
/* U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1, */
/* where U1, V1 and Q1 are orthogonal matrix, and Z' is the transpose */
/* of Z. C1 and S1 are diagonal matrices satisfying */
/* C1**2 + S1**2 = I, */
/* and R1 is an L-by-L nonsingular upper triangular matrix. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--alpha;
--beta;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--work;
/* Function Body */
initu = lsame_(jobu, "I");
wantu = initu || lsame_(jobu, "U");
initv = lsame_(jobv, "I");
wantv = initv || lsame_(jobv, "V");
initq = lsame_(jobq, "I");
wantq = initq || lsame_(jobq, "Q");
*info = 0;
if (! (initu || wantu || lsame_(jobu, "N"))) {
*info = -1;
} else if (! (initv || wantv || lsame_(jobv, "N")))
{
*info = -2;
} else if (! (initq || wantq || lsame_(jobq, "N")))
{
*info = -3;
} else if (*m < 0) {
*info = -4;
} else if (*p < 0) {
*info = -5;
} else if (*n < 0) {
*info = -6;
} else if (*lda < max(1,*m)) {
*info = -10;
} else if (*ldb < max(1,*p)) {
*info = -12;
} else if (*ldu < 1 || wantu && *ldu < *m) {
*info = -18;
} else if (*ldv < 1 || wantv && *ldv < *p) {
*info = -20;
} else if (*ldq < 1 || wantq && *ldq < *n) {
*info = -22;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("STGSJA", &i__1);
return 0;
}
/* Initialize U, V and Q, if necessary */
if (initu) {
slaset_("Full", m, m, &c_b13, &c_b14, &u[u_offset], ldu);
}
if (initv) {
slaset_("Full", p, p, &c_b13, &c_b14, &v[v_offset], ldv);
}
if (initq) {
slaset_("Full", n, n, &c_b13, &c_b14, &q[q_offset], ldq);
}
/* Loop until convergence */
upper = FALSE_;
for (kcycle = 1; kcycle <= 40; ++kcycle) {
upper = ! upper;
i__1 = *l - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *l;
for (j = i__ + 1; j <= i__2; ++j) {
a1 = 0.f;
a2 = 0.f;
a3 = 0.f;
if (*k + i__ <= *m) {
a1 = a[*k + i__ + (*n - *l + i__) * a_dim1];
}
if (*k + j <= *m) {
a3 = a[*k + j + (*n - *l + j) * a_dim1];
}
b1 = b[i__ + (*n - *l + i__) * b_dim1];
b3 = b[j + (*n - *l + j) * b_dim1];
if (upper) {
if (*k + i__ <= *m) {
a2 = a[*k + i__ + (*n - *l + j) * a_dim1];
}
b2 = b[i__ + (*n - *l + j) * b_dim1];
} else {
if (*k + j <= *m) {
a2 = a[*k + j + (*n - *l + i__) * a_dim1];
}
b2 = b[j + (*n - *l + i__) * b_dim1];
}
slags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, &
csv, &snv, &csq, &snq);
/* Update (K+I)-th and (K+J)-th rows of matrix A: U'*A */
if (*k + j <= *m) {
srot_(l, &a[*k + j + (*n - *l + 1) * a_dim1], lda, &a[*k
+ i__ + (*n - *l + 1) * a_dim1], lda, &csu, &snu);
}
/* Update I-th and J-th rows of matrix B: V'*B */
srot_(l, &b[j + (*n - *l + 1) * b_dim1], ldb, &b[i__ + (*n - *
l + 1) * b_dim1], ldb, &csv, &snv);
/* Update (N-L+I)-th and (N-L+J)-th columns of matrices */
/* A and B: A*Q and B*Q */
/* Computing MIN */
i__4 = *k + *l;
i__3 = min(i__4,*m);
srot_(&i__3, &a[(*n - *l + j) * a_dim1 + 1], &c__1, &a[(*n - *
l + i__) * a_dim1 + 1], &c__1, &csq, &snq);
srot_(l, &b[(*n - *l + j) * b_dim1 + 1], &c__1, &b[(*n - *l +
i__) * b_dim1 + 1], &c__1, &csq, &snq);
if (upper) {
if (*k + i__ <= *m) {
a[*k + i__ + (*n - *l + j) * a_dim1] = 0.f;
}
b[i__ + (*n - *l + j) * b_dim1] = 0.f;
} else {
if (*k + j <= *m) {
a[*k + j + (*n - *l + i__) * a_dim1] = 0.f;
}
b[j + (*n - *l + i__) * b_dim1] = 0.f;
}
/* Update orthogonal matrices U, V, Q, if desired. */
if (wantu && *k + j <= *m) {
srot_(m, &u[(*k + j) * u_dim1 + 1], &c__1, &u[(*k + i__) *
u_dim1 + 1], &c__1, &csu, &snu);
}
if (wantv) {
srot_(p, &v[j * v_dim1 + 1], &c__1, &v[i__ * v_dim1 + 1],
&c__1, &csv, &snv);
}
if (wantq) {
srot_(n, &q[(*n - *l + j) * q_dim1 + 1], &c__1, &q[(*n - *
l + i__) * q_dim1 + 1], &c__1, &csq, &snq);
}
/* L10: */
}
/* L20: */
}
if (! upper) {
/* The matrices A13 and B13 were lower triangular at the start */
/* of the cycle, and are now upper triangular. */
/* Convergence test: test the parallelism of the corresponding */
/* rows of A and B. */
error = 0.f;
/* Computing MIN */
i__2 = *l, i__3 = *m - *k;
i__1 = min(i__2,i__3);
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *l - i__ + 1;
scopy_(&i__2, &a[*k + i__ + (*n - *l + i__) * a_dim1], lda, &
work[1], &c__1);
i__2 = *l - i__ + 1;
scopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &work[*
l + 1], &c__1);
i__2 = *l - i__ + 1;
slapll_(&i__2, &work[1], &c__1, &work[*l + 1], &c__1, &ssmin);
error = dmax(error,ssmin);
/* L30: */
}
if (dabs(error) <= dmin(*tola,*tolb)) {
goto L50;
}
}
/* End of cycle loop */
/* L40: */
}
/* The algorithm has not converged after MAXIT cycles. */
*info = 1;
goto L100;
L50:
/* If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged. */
/* Compute the generalized singular value pairs (ALPHA, BETA), and */
/* set the triangular matrix R to array A. */
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
alpha[i__] = 1.f;
beta[i__] = 0.f;
/* L60: */
}
/* Computing MIN */
i__2 = *l, i__3 = *m - *k;
i__1 = min(i__2,i__3);
for (i__ = 1; i__ <= i__1; ++i__) {
a1 = a[*k + i__ + (*n - *l + i__) * a_dim1];
b1 = b[i__ + (*n - *l + i__) * b_dim1];
if (a1 != 0.f) {
gamma = b1 / a1;
/* change sign if necessary */
if (gamma < 0.f) {
i__2 = *l - i__ + 1;
sscal_(&i__2, &c_b43, &b[i__ + (*n - *l + i__) * b_dim1], ldb)
;
if (wantv) {
sscal_(p, &c_b43, &v[i__ * v_dim1 + 1], &c__1);
}
}
r__1 = dabs(gamma);
slartg_(&r__1, &c_b14, &beta[*k + i__], &alpha[*k + i__], &rwk);
if (alpha[*k + i__] >= beta[*k + i__]) {
i__2 = *l - i__ + 1;
r__1 = 1.f / alpha[*k + i__];
sscal_(&i__2, &r__1, &a[*k + i__ + (*n - *l + i__) * a_dim1],
lda);
} else {
i__2 = *l - i__ + 1;
r__1 = 1.f / beta[*k + i__];
sscal_(&i__2, &r__1, &b[i__ + (*n - *l + i__) * b_dim1], ldb);
i__2 = *l - i__ + 1;
scopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k
+ i__ + (*n - *l + i__) * a_dim1], lda);
}
} else {
alpha[*k + i__] = 0.f;
beta[*k + i__] = 1.f;
i__2 = *l - i__ + 1;
scopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k +
i__ + (*n - *l + i__) * a_dim1], lda);
}
/* L70: */
}
/* Post-assignment */
i__1 = *k + *l;
for (i__ = *m + 1; i__ <= i__1; ++i__) {
alpha[i__] = 0.f;
beta[i__] = 1.f;
/* L80: */
}
if (*k + *l < *n) {
i__1 = *n;
for (i__ = *k + *l + 1; i__ <= i__1; ++i__) {
alpha[i__] = 0.f;
beta[i__] = 0.f;
/* L90: */
}
}
L100:
*ncycle = kcycle;
return 0;
/* End of STGSJA */
} /* stgsja_ */
/* Subroutine */ int clatbs_(char *uplo, char *trans, char *diag, char *
normin, integer *n, integer *kd, complex *ab, integer *ldab, complex *
x, real *scale, real *cnorm, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_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, q__3, q__4;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
integer i__, j;
real xj, rec, tjj;
integer jinc, jlen;
real xbnd;
integer imax;
real tmax;
complex tjjs;
real xmax, grow;
integer maind;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
real tscal;
complex uscal;
integer jlast;
extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
*, complex *, integer *);
complex csumj;
extern /* Subroutine */ int ctbsv_(char *, char *, char *, integer *,
integer *, complex *, integer *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer *
, complex *, integer *);
logical upper;
extern /* Subroutine */ int slabad_(real *, real *);
extern integer icamax_(integer *, complex *, integer *);
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), xerbla_(char *, integer *);
real bignum;
extern integer isamax_(integer *, real *, integer *);
extern doublereal scasum_(integer *, complex *, integer *);
logical notran;
integer jfirst;
real smlnum;
logical nounit;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLATBS solves one of the triangular systems */
/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b, */
/* with scaling to prevent overflow, where A is an upper or lower */
/* triangular band matrix. Here A' denotes the transpose of A, x and b */
/* are n-element vectors, and s is a scaling factor, usually less than */
/* or equal to 1, chosen so that the components of x will be less than */
/* the overflow threshold. If the unscaled problem will not cause */
/* overflow, the Level 2 BLAS routine CTBSV is called. If the matrix A */
/* is singular (A(j,j) = 0 for some j), then s is set to 0 and a */
/* non-trivial solution to A*x = 0 is returned. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Specifies the operation applied to A. */
/* = 'N': Solve A * x = s*b (No transpose) */
/* = 'T': Solve A**T * x = s*b (Transpose) */
/* = 'C': Solve A**H * x = s*b (Conjugate transpose) */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* NORMIN (input) CHARACTER*1 */
/* Specifies whether CNORM has been set or not. */
/* = 'Y': CNORM contains the column norms on entry */
/* = 'N': CNORM is not set on entry. On exit, the norms will */
/* be computed and stored in CNORM. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* KD (input) INTEGER */
/* The number of subdiagonals or superdiagonals in the */
/* triangular matrix A. KD >= 0. */
/* AB (input) COMPLEX array, dimension (LDAB,N) */
/* The upper or lower triangular band matrix A, stored in the */
/* first KD+1 rows of the array. The j-th column of A is stored */
/* in the j-th column of the array AB as follows: */
/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KD+1. */
/* X (input/output) COMPLEX array, dimension (N) */
/* On entry, the right hand side b of the triangular system. */
/* On exit, X is overwritten by the solution vector x. */
/* SCALE (output) REAL */
/* The scaling factor s for the triangular system */
/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b. */
/* If SCALE = 0, the matrix A is singular or badly scaled, and */
/* the vector x is an exact or approximate solution to A*x = 0. */
/* CNORM (input or output) REAL array, dimension (N) */
/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */
/* contains the norm of the off-diagonal part of the j-th column */
/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */
/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */
/* must be greater than or equal to the 1-norm. */
/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */
/* returns the 1-norm of the offdiagonal part of the j-th column */
/* of A. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* Further Details */
/* ======= ======= */
/* A rough bound on x is computed; if that is less than overflow, CTBSV */
/* is called, otherwise, specific code is used which checks for possible */
/* overflow or divide-by-zero at every operation. */
/* A columnwise scheme is used for solving A*x = b. The basic algorithm */
/* if A is lower triangular is */
/* x[1:n] := b[1:n] */
/* for j = 1, ..., n */
/* x(j) := x(j) / A(j,j) */
/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */
/* end */
/* Define bounds on the components of x after j iterations of the loop: */
/* M(j) = bound on x[1:j] */
/* G(j) = bound on x[j+1:n] */
/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */
/* Then for iteration j+1 we have */
/* M(j+1) <= G(j) / | A(j+1,j+1) | */
/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */
/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */
/* where CNORM(j+1) is greater than or equal to the infinity-norm of */
/* column j+1 of A, not counting the diagonal. Hence */
/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */
/* 1<=i<=j */
/* and */
/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */
/* 1<=i< j */
/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine CTBSV if the */
/* reciprocal of the largest M(j), j=1,..,n, is larger than */
/* max(underflow, 1/overflow). */
/* The bound on x(j) is also used to determine when a step in the */
/* columnwise method can be performed without fear of overflow. If */
/* the computed bound is greater than a large constant, x is scaled to */
/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */
/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */
/* Similarly, a row-wise scheme is used to solve A**T *x = b or */
/* A**H *x = b. The basic algorithm for A upper triangular is */
/* for j = 1, ..., n */
/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */
/* end */
/* We simultaneously compute two bounds */
/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */
/* M(j) = bound on x(i), 1<=i<=j */
/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */
/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */
/* Then the bound on x(j) is */
/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */
/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */
/* 1<=i<=j */
/* and we can safely call CTBSV if 1/M(n) and 1/G(n) are both greater */
/* than max(underflow, 1/overflow). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--x;
--cnorm;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
/* Test the input parameters. */
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && !
lsame_(trans, "C")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (! lsame_(normin, "Y") && ! lsame_(normin,
"N")) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*kd < 0) {
*info = -6;
} else if (*ldab < *kd + 1) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CLATBS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine machine dependent parameters to control overflow. */
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum /= slamch_("Precision");
bignum = 1.f / smlnum;
*scale = 1.f;
if (lsame_(normin, "N")) {
/* Compute the 1-norm of each column, not including the diagonal. */
if (upper) {
/* A is upper triangular. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__2 = *kd, i__3 = j - 1;
jlen = min(i__2,i__3);
cnorm[j] = scasum_(&jlen, &ab[*kd + 1 - jlen + j * ab_dim1], &
c__1);
/* L10: */
}
} else {
/* A is lower triangular. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__2 = *kd, i__3 = *n - j;
jlen = min(i__2,i__3);
if (jlen > 0) {
cnorm[j] = scasum_(&jlen, &ab[j * ab_dim1 + 2], &c__1);
} else {
cnorm[j] = 0.f;
}
/* L20: */
}
}
}
/* Scale the column norms by TSCAL if the maximum element in CNORM is */
/* greater than BIGNUM/2. */
imax = isamax_(n, &cnorm[1], &c__1);
tmax = cnorm[imax];
if (tmax <= bignum * .5f) {
tscal = 1.f;
} else {
tscal = .5f / (smlnum * tmax);
sscal_(n, &tscal, &cnorm[1], &c__1);
}
/* Compute a bound on the computed solution vector to see if the */
/* Level 2 BLAS routine CTBSV can be used. */
xmax = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = j;
r__3 = xmax, r__4 = (r__1 = x[i__2].r / 2.f, dabs(r__1)) + (r__2 =
r_imag(&x[j]) / 2.f, dabs(r__2));
xmax = dmax(r__3,r__4);
/* L30: */
}
xbnd = xmax;
if (notran) {
/* Compute the growth in A * x = b. */
if (upper) {
jfirst = *n;
jlast = 1;
jinc = -1;
maind = *kd + 1;
} else {
jfirst = 1;
jlast = *n;
jinc = 1;
maind = 1;
}
if (tscal != 1.f) {
grow = 0.f;
goto L60;
}
if (nounit) {
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
/* Initially, G(0) = max{x(i), i=1,...,n}. */
grow = .5f / dmax(xbnd,smlnum);
xbnd = grow;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L60;
}
i__3 = maind + j * ab_dim1;
tjjs.r = ab[i__3].r, tjjs.i = ab[i__3].i;
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj >= smlnum) {
/* M(j) = G(j-1) / abs(A(j,j)) */
/* Computing MIN */
r__1 = xbnd, r__2 = dmin(1.f,tjj) * grow;
xbnd = dmin(r__1,r__2);
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.f;
}
if (tjj + cnorm[j] >= smlnum) {
/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */
grow *= tjj / (tjj + cnorm[j]);
} else {
/* G(j) could overflow, set GROW to 0. */
grow = 0.f;
}
/* L40: */
}
grow = xbnd;
} else {
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
/* Computing MIN */
r__1 = 1.f, r__2 = .5f / dmax(xbnd,smlnum);
grow = dmin(r__1,r__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L60;
}
/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
grow *= 1.f / (cnorm[j] + 1.f);
/* L50: */
}
}
L60:
;
} else {
/* Compute the growth in A**T * x = b or A**H * x = b. */
if (upper) {
jfirst = 1;
jlast = *n;
jinc = 1;
maind = *kd + 1;
} else {
jfirst = *n;
jlast = 1;
jinc = -1;
maind = 1;
}
if (tscal != 1.f) {
grow = 0.f;
goto L90;
}
if (nounit) {
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
/* Initially, M(0) = max{x(i), i=1,...,n}. */
grow = .5f / dmax(xbnd,smlnum);
xbnd = grow;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L90;
}
/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
xj = cnorm[j] + 1.f;
/* Computing MIN */
r__1 = grow, r__2 = xbnd / xj;
grow = dmin(r__1,r__2);
i__3 = maind + j * ab_dim1;
tjjs.r = ab[i__3].r, tjjs.i = ab[i__3].i;
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj >= smlnum) {
/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
if (xj > tjj) {
xbnd *= tjj / xj;
}
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.f;
}
/* L70: */
}
grow = dmin(grow,xbnd);
} else {
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
/* Computing MIN */
r__1 = 1.f, r__2 = .5f / dmax(xbnd,smlnum);
grow = dmin(r__1,r__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L90;
}
/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
xj = cnorm[j] + 1.f;
grow /= xj;
/* L80: */
}
}
L90:
;
}
if (grow * tscal > smlnum) {
/* Use the Level 2 BLAS solve if the reciprocal of the bound on */
/* elements of X is not too small. */
ctbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &x[1], &c__1);
} else {
/* Use a Level 1 BLAS solve, scaling intermediate results. */
if (xmax > bignum * .5f) {
/* Scale X so that its components are less than or equal to */
/* BIGNUM in absolute value. */
*scale = bignum * .5f / xmax;
csscal_(n, scale, &x[1], &c__1);
xmax = bignum;
} else {
xmax *= 2.f;
}
if (notran) {
/* Solve A * x = b */
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
dabs(r__2));
if (nounit) {
i__3 = maind + j * ab_dim1;
q__1.r = tscal * ab[i__3].r, q__1.i = tscal * ab[i__3].i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
if (tscal == 1.f) {
goto L105;
}
}
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f) {
if (xj > tjj * bignum) {
/* Scale x by 1/b(j). */
rec = 1.f / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
} else if (tjj > 0.f) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */
/* to avoid overflow when dividing by A(j,j). */
rec = tjj * bignum / xj;
if (cnorm[j] > 1.f) {
/* Scale by 1/CNORM(j) to avoid overflow when */
/* multiplying x(j) times column j. */
rec /= cnorm[j];
}
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0, and compute a solution to A*x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0.f, x[i__4].i = 0.f;
/* L100: */
}
i__3 = j;
x[i__3].r = 1.f, x[i__3].i = 0.f;
xj = 1.f;
*scale = 0.f;
xmax = 0.f;
}
L105:
/* Scale x if necessary to avoid overflow when adding a */
/* multiple of column j of A. */
if (xj > 1.f) {
rec = 1.f / xj;
if (cnorm[j] > (bignum - xmax) * rec) {
/* Scale x by 1/(2*abs(x(j))). */
rec *= .5f;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
} else if (xj * cnorm[j] > bignum - xmax) {
/* Scale x by 1/2. */
csscal_(n, &c_b36, &x[1], &c__1);
*scale *= .5f;
}
if (upper) {
if (j > 1) {
/* Compute the update */
/* x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) - */
/* x(j)* A(max(1,j-kd):j-1,j) */
/* Computing MIN */
i__3 = *kd, i__4 = j - 1;
jlen = min(i__3,i__4);
i__3 = j;
q__2.r = -x[i__3].r, q__2.i = -x[i__3].i;
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
caxpy_(&jlen, &q__1, &ab[*kd + 1 - jlen + j * ab_dim1]
, &c__1, &x[j - jlen], &c__1);
i__3 = j - 1;
i__ = icamax_(&i__3, &x[1], &c__1);
i__3 = i__;
xmax = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[i__]), dabs(r__2));
}
} else if (j < *n) {
/* Compute the update */
/* x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) - */
/* x(j) * A(j+1:min(j+kd,n),j) */
/* Computing MIN */
i__3 = *kd, i__4 = *n - j;
jlen = min(i__3,i__4);
if (jlen > 0) {
i__3 = j;
q__2.r = -x[i__3].r, q__2.i = -x[i__3].i;
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
caxpy_(&jlen, &q__1, &ab[j * ab_dim1 + 2], &c__1, &x[
j + 1], &c__1);
}
i__3 = *n - j;
i__ = j + icamax_(&i__3, &x[j + 1], &c__1);
i__3 = i__;
xmax = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[
i__]), dabs(r__2));
}
/* L110: */
}
} else if (lsame_(trans, "T")) {
/* Solve A**T * x = b */
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
/* k<>j */
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
dabs(r__2));
uscal.r = tscal, uscal.i = 0.f;
rec = 1.f / dmax(xmax,1.f);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5f;
if (nounit) {
i__3 = maind + j * ab_dim1;
q__1.r = tscal * ab[i__3].r, q__1.i = tscal * ab[i__3]
.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
}
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > 1.f) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
r__1 = 1.f, r__2 = rec * tjj;
rec = dmin(r__1,r__2);
cladiv_(&q__1, &uscal, &tjjs);
uscal.r = q__1.r, uscal.i = q__1.i;
}
if (rec < 1.f) {
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0.f, csumj.i = 0.f;
if (uscal.r == 1.f && uscal.i == 0.f) {
/* If the scaling needed for A in the dot product is 1, */
/* call CDOTU to perform the dot product. */
if (upper) {
/* Computing MIN */
i__3 = *kd, i__4 = j - 1;
jlen = min(i__3,i__4);
cdotu_(&q__1, &jlen, &ab[*kd + 1 - jlen + j * ab_dim1]
, &c__1, &x[j - jlen], &c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
} else {
/* Computing MIN */
i__3 = *kd, i__4 = *n - j;
jlen = min(i__3,i__4);
if (jlen > 1) {
cdotu_(&q__1, &jlen, &ab[j * ab_dim1 + 2], &c__1,
&x[j + 1], &c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
}
}
} else {
/* Otherwise, use in-line code for the dot product. */
if (upper) {
/* Computing MIN */
i__3 = *kd, i__4 = j - 1;
jlen = min(i__3,i__4);
i__3 = jlen;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = *kd + i__ - jlen + j * ab_dim1;
q__3.r = ab[i__4].r * uscal.r - ab[i__4].i *
uscal.i, q__3.i = ab[i__4].r * uscal.i +
ab[i__4].i * uscal.r;
i__5 = j - jlen - 1 + i__;
q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i,
q__2.i = q__3.r * x[i__5].i + q__3.i * x[
i__5].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L120: */
}
} else {
/* Computing MIN */
i__3 = *kd, i__4 = *n - j;
jlen = min(i__3,i__4);
i__3 = jlen;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + 1 + j * ab_dim1;
q__3.r = ab[i__4].r * uscal.r - ab[i__4].i *
uscal.i, q__3.i = ab[i__4].r * uscal.i +
ab[i__4].i * uscal.r;
i__5 = j + i__;
q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i,
q__2.i = q__3.r * x[i__5].i + q__3.i * x[
i__5].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L130: */
}
}
}
q__1.r = tscal, q__1.i = 0.f;
if (uscal.r == q__1.r && uscal.i == q__1.i) {
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
/* was not used to scale the dotproduct. */
i__3 = j;
i__4 = j;
q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i -
csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
if (nounit) {
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
i__3 = maind + j * ab_dim1;
q__1.r = tscal * ab[i__3].r, q__1.i = tscal * ab[i__3]
.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
if (tscal == 1.f) {
goto L145;
}
}
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f) {
if (xj > tjj * bignum) {
/* Scale X by 1/abs(x(j)). */
rec = 1.f / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} else if (tjj > 0.f) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0 and compute a solution to A**T *x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0.f, x[i__4].i = 0.f;
/* L140: */
}
i__3 = j;
x[i__3].r = 1.f, x[i__3].i = 0.f;
*scale = 0.f;
xmax = 0.f;
}
L145:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
/* product has already been divided by 1/A(j,j). */
i__3 = j;
cladiv_(&q__2, &x[j], &tjjs);
q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
}
/* Computing MAX */
i__3 = j;
r__3 = xmax, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[j]), dabs(r__2));
xmax = dmax(r__3,r__4);
/* L150: */
}
} else {
/* Solve A**H * x = b */
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
/* k<>j */
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
dabs(r__2));
uscal.r = tscal, uscal.i = 0.f;
rec = 1.f / dmax(xmax,1.f);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5f;
if (nounit) {
r_cnjg(&q__2, &ab[maind + j * ab_dim1]);
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
}
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > 1.f) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
r__1 = 1.f, r__2 = rec * tjj;
rec = dmin(r__1,r__2);
cladiv_(&q__1, &uscal, &tjjs);
uscal.r = q__1.r, uscal.i = q__1.i;
}
if (rec < 1.f) {
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0.f, csumj.i = 0.f;
if (uscal.r == 1.f && uscal.i == 0.f) {
/* If the scaling needed for A in the dot product is 1, */
/* call CDOTC to perform the dot product. */
if (upper) {
/* Computing MIN */
i__3 = *kd, i__4 = j - 1;
jlen = min(i__3,i__4);
cdotc_(&q__1, &jlen, &ab[*kd + 1 - jlen + j * ab_dim1]
, &c__1, &x[j - jlen], &c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
} else {
/* Computing MIN */
i__3 = *kd, i__4 = *n - j;
jlen = min(i__3,i__4);
if (jlen > 1) {
cdotc_(&q__1, &jlen, &ab[j * ab_dim1 + 2], &c__1,
&x[j + 1], &c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
}
}
} else {
/* Otherwise, use in-line code for the dot product. */
if (upper) {
/* Computing MIN */
i__3 = *kd, i__4 = j - 1;
jlen = min(i__3,i__4);
i__3 = jlen;
for (i__ = 1; i__ <= i__3; ++i__) {
r_cnjg(&q__4, &ab[*kd + i__ - jlen + j * ab_dim1])
;
q__3.r = q__4.r * uscal.r - q__4.i * uscal.i,
q__3.i = q__4.r * uscal.i + q__4.i *
uscal.r;
i__4 = j - jlen - 1 + i__;
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 = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L160: */
}
} else {
/* Computing MIN */
i__3 = *kd, i__4 = *n - j;
jlen = min(i__3,i__4);
i__3 = jlen;
for (i__ = 1; i__ <= i__3; ++i__) {
r_cnjg(&q__4, &ab[i__ + 1 + j * ab_dim1]);
q__3.r = q__4.r * uscal.r - q__4.i * uscal.i,
q__3.i = q__4.r * uscal.i + q__4.i *
uscal.r;
i__4 = j + i__;
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 = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L170: */
}
}
}
q__1.r = tscal, q__1.i = 0.f;
if (uscal.r == q__1.r && uscal.i == q__1.i) {
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
/* was not used to scale the dotproduct. */
i__3 = j;
i__4 = j;
q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i -
csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
if (nounit) {
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
r_cnjg(&q__2, &ab[maind + j * ab_dim1]);
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
if (tscal == 1.f) {
goto L185;
}
}
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f) {
if (xj > tjj * bignum) {
/* Scale X by 1/abs(x(j)). */
rec = 1.f / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} else if (tjj > 0.f) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0 and compute a solution to A**H *x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0.f, x[i__4].i = 0.f;
/* L180: */
}
i__3 = j;
x[i__3].r = 1.f, x[i__3].i = 0.f;
*scale = 0.f;
xmax = 0.f;
}
L185:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
/* product has already been divided by 1/A(j,j). */
i__3 = j;
cladiv_(&q__2, &x[j], &tjjs);
q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
}
/* Computing MAX */
i__3 = j;
r__3 = xmax, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[j]), dabs(r__2));
xmax = dmax(r__3,r__4);
/* L190: */
}
}
*scale /= tscal;
}
/* Scale the column norms by 1/TSCAL for return. */
if (tscal != 1.f) {
r__1 = 1.f / tscal;
sscal_(n, &r__1, &cnorm[1], &c__1);
}
return 0;
/* End of CLATBS */
} /* clatbs_ */
/* Subroutine */ int sgebak_(char *job, char *side, integer *n, integer *ilo,
integer *ihi, real *scale, integer *m, real *v, integer *ldv, integer
*info)
{
/* System generated locals */
integer v_dim1, v_offset, i__1;
/* Local variables */
integer i__, k;
real s;
integer ii;
logical leftv;
logical rightv;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* SGEBAK forms the right or left eigenvectors of a real general matrix */
/* by backward transformation on the computed eigenvectors of the */
/* balanced matrix output by SGEBAL. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* Specifies the type of backward transformation required: */
/* = 'N', do nothing, return immediately; */
/* = 'P', do backward transformation for permutation only; */
/* = 'S', do backward transformation for scaling only; */
/* = 'B', do backward transformations for both permutation and */
/* scaling. */
/* JOB must be the same as the argument JOB supplied to SGEBAL. */
/* SIDE (input) CHARACTER*1 */
/* = 'R': V contains right eigenvectors; */
/* = 'L': V contains left eigenvectors. */
/* N (input) INTEGER */
/* The number of rows of the matrix V. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* The integers ILO and IHI determined by SGEBAL. */
/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
/* SCALE (input) REAL array, dimension (N) */
/* Details of the permutation and scaling factors, as returned */
/* by SGEBAL. */
/* M (input) INTEGER */
/* The number of columns of the matrix V. M >= 0. */
/* V (input/output) REAL array, dimension (LDV,M) */
/* On entry, the matrix of right or left eigenvectors to be */
/* transformed, as returned by SHSEIN or STREVC. */
/* On exit, V is overwritten by the transformed eigenvectors. */
/* LDV (input) INTEGER */
/* The leading dimension of the array V. LDV >= max(1,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 */
--scale;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
/* Function Body */
rightv = lsame_(side, "R");
leftv = lsame_(side, "L");
*info = 0;
if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S")
&& ! lsame_(job, "B")) {
*info = -1;
} else if (! rightv && ! leftv) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ilo < 1 || *ilo > max(1,*n)) {
*info = -4;
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
*info = -5;
} else if (*m < 0) {
*info = -7;
} else if (*ldv < max(1,*n)) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGEBAK", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*m == 0) {
return 0;
}
if (lsame_(job, "N")) {
return 0;
}
if (*ilo == *ihi) {
goto L30;
}
/* Backward balance */
if (lsame_(job, "S") || lsame_(job, "B")) {
if (rightv) {
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
s = scale[i__];
sscal_(m, &s, &v[i__ + v_dim1], ldv);
}
}
if (leftv) {
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
s = 1.f / scale[i__];
sscal_(m, &s, &v[i__ + v_dim1], ldv);
}
}
}
/* Backward permutation */
/* For I = ILO-1 step -1 until 1, */
/* IHI+1 step 1 until N do -- */
L30:
if (lsame_(job, "P") || lsame_(job, "B")) {
if (rightv) {
i__1 = *n;
for (ii = 1; ii <= i__1; ++ii) {
i__ = ii;
if (i__ >= *ilo && i__ <= *ihi) {
goto L40;
}
if (i__ < *ilo) {
i__ = *ilo - ii;
}
k = scale[i__];
if (k == i__) {
goto L40;
}
sswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
L40:
;
}
}
if (leftv) {
i__1 = *n;
for (ii = 1; ii <= i__1; ++ii) {
i__ = ii;
if (i__ >= *ilo && i__ <= *ihi) {
goto L50;
}
if (i__ < *ilo) {
i__ = *ilo - ii;
}
k = scale[i__];
if (k == i__) {
goto L50;
}
sswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
L50:
;
}
}
}
return 0;
/* End of SGEBAK */
} /* sgebak_ */
