/* Subroutine */ int sbdsdc_(char *uplo, char *compq, integer *n, real *d__,
real *e, real *u, integer *ldu, real *vt, integer *ldvt, real *q,
integer *iq, real *work, integer *iwork, integer *info)
{
/* System generated locals */
integer u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2;
real r__1;
/* Builtin functions */
double r_sign(real *, real *), log(doublereal);
/* Local variables */
static integer difl, difr, ierr, perm, mlvl, sqre, i__, j, k;
static real p, r__;
static integer z__;
extern logical lsame_(char *, char *);
static integer poles;
extern /* Subroutine */ int slasr_(char *, char *, char *, integer *,
integer *, real *, real *, real *, integer *);
static integer iuplo, nsize, start;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), sswap_(integer *, real *, integer *, real *, integer *
), slasd0_(integer *, integer *, real *, real *, real *, integer *
, real *, integer *, integer *, integer *, real *, integer *);
static integer ic, ii, kk;
static real cs;
static integer is, iu;
static real sn;
extern doublereal slamch_(char *);
extern /* Subroutine */ int slasda_(integer *, integer *, integer *,
integer *, real *, real *, real *, integer *, real *, integer *,
real *, real *, real *, real *, integer *, integer *, integer *,
integer *, real *, real *, real *, real *, integer *, integer *),
xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *);
static integer givcol;
extern /* Subroutine */ int slasdq_(char *, integer *, integer *, integer
*, integer *, integer *, real *, real *, real *, integer *, real *
, integer *, real *, integer *, real *, integer *);
static integer icompq;
extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
real *, real *, integer *), slartg_(real *, real *, real *
, real *, real *);
static real orgnrm;
static integer givnum;
extern doublereal slanst_(char *, integer *, real *, real *);
static integer givptr, nm1, qstart, smlsiz, wstart, smlszp;
static real eps;
static integer ivt;
#define u_ref(a_1,a_2) u[(a_2)*u_dim1 + a_1]
#define vt_ref(a_1,a_2) vt[(a_2)*vt_dim1 + a_1]
/* -- LAPACK routine (instrumented to count ops, version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1999
Purpose
=======
SBDSDC computes the singular value decomposition (SVD) of a real
N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT,
using a divide and conquer method, where S is a diagonal matrix
with non-negative diagonal elements (the singular values of B), and
U and VT are orthogonal matrices of left and right singular vectors,
respectively. SBDSDC can be used to compute all singular values,
and optionally, singular vectors or singular vectors in compact form.
This code 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. See SLASD3 for details.
The code currently call SLASDQ if singular values only are desired.
However, it can be slightly modified to compute singular values
using the divide and conquer method.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': B is upper bidiagonal.
= 'L': B is lower bidiagonal.
COMPQ (input) CHARACTER*1
Specifies whether singular vectors are to be computed
as follows:
= 'N': Compute singular values only;
= 'P': Compute singular values and compute singular
vectors in compact form;
= 'I': Compute singular values and singular vectors.
N (input) INTEGER
The order of the matrix B. N >= 0.
D (input/output) REAL array, dimension (N)
On entry, the n diagonal elements of the bidiagonal matrix B.
On exit, if INFO=0, the singular values of B.
E (input/output) REAL array, dimension (N)
On entry, the elements of E contain the offdiagonal
elements of the bidiagonal matrix whose SVD is desired.
On exit, E has been destroyed.
U (output) REAL array, dimension (LDU,N)
If COMPQ = 'I', then:
On exit, if INFO = 0, U contains the left singular vectors
of the bidiagonal matrix.
For other values of COMPQ, U is not referenced.
LDU (input) INTEGER
The leading dimension of the array U. LDU >= 1.
If singular vectors are desired, then LDU >= max( 1, N ).
VT (output) REAL array, dimension (LDVT,N)
If COMPQ = 'I', then:
On exit, if INFO = 0, VT' contains the right singular
vectors of the bidiagonal matrix.
For other values of COMPQ, VT is not referenced.
LDVT (input) INTEGER
The leading dimension of the array VT. LDVT >= 1.
If singular vectors are desired, then LDVT >= max( 1, N ).
Q (output) REAL array, dimension (LDQ)
If COMPQ = 'P', then:
On exit, if INFO = 0, Q and IQ contain the left
and right singular vectors in a compact form,
requiring O(N log N) space instead of 2*N**2.
In particular, Q contains all the REAL data in
LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))
words of memory, where SMLSIZ is returned by ILAENV and
is equal to the maximum size of the subproblems at the
bottom of the computation tree (usually about 25).
For other values of COMPQ, Q is not referenced.
IQ (output) INTEGER array, dimension (LDIQ)
If COMPQ = 'P', then:
On exit, if INFO = 0, Q and IQ contain the left
and right singular vectors in a compact form,
requiring O(N log N) space instead of 2*N**2.
In particular, IQ contains all INTEGER data in
LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))
words of memory, where SMLSIZ is returned by ILAENV and
is equal to the maximum size of the subproblems at the
bottom of the computation tree (usually about 25).
For other values of COMPQ, IQ is not referenced.
WORK (workspace) REAL array, dimension (LWORK)
If COMPQ = 'N' then LWORK >= (4 * N).
If COMPQ = 'P' then LWORK >= (6 * N).
If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).
IWORK (workspace) INTEGER array, dimension (7*N)
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: The algorithm failed to compute an singular value.
The update process of divide and conquer failed.
Further Details
===============
Based on contributions by
Ming Gu and Huan Ren, Computer Science Division, University of
California at Berkeley, USA
=====================================================================
Test the input parameters.
Parameter adjustments */
--d__;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1 * 1;
vt -= vt_offset;
--q;
--iq;
--work;
--iwork;
/* Function Body */
*info = 0;
iuplo = 0;
if (lsame_(uplo, "U")) {
iuplo = 1;
}
if (lsame_(uplo, "L")) {
iuplo = 2;
}
if (lsame_(compq, "N")) {
icompq = 0;
} else if (lsame_(compq, "P")) {
icompq = 1;
} else if (lsame_(compq, "I")) {
icompq = 2;
} else {
icompq = -1;
}
if (iuplo == 0) {
*info = -1;
} else if (icompq < 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ldu < 1 || icompq == 2 && *ldu < *n) {
*info = -7;
} else if (*ldvt < 1 || icompq == 2 && *ldvt < *n) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SBDSDC", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
smlsiz = ilaenv_(&c__9, "SBDSDC", " ", &c__0, &c__0, &c__0, &c__0, (
ftnlen)6, (ftnlen)1);
if (*n == 1) {
if (icompq == 1) {
q[1] = r_sign(&c_b15, &d__[1]);
q[smlsiz * *n + 1] = 1.f;
} else if (icompq == 2) {
u_ref(1, 1) = r_sign(&c_b15, &d__[1]);
vt_ref(1, 1) = 1.f;
}
d__[1] = dabs(d__[1]);
return 0;
}
nm1 = *n - 1;
/* If matrix lower bidiagonal, rotate to be upper bidiagonal
by applying Givens rotations on the left */
wstart = 1;
qstart = 3;
if (icompq == 1) {
scopy_(n, &d__[1], &c__1, &q[1], &c__1);
i__1 = *n - 1;
scopy_(&i__1, &e[1], &c__1, &q[*n + 1], &c__1);
}
if (iuplo == 2) {
qstart = 5;
wstart = (*n << 1) - 1;
latime_1.ops += (real) (*n - 1 << 3);
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
slartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__;
e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1];
if (icompq == 1) {
q[i__ + (*n << 1)] = cs;
q[i__ + *n * 3] = sn;
} else if (icompq == 2) {
work[i__] = cs;
work[nm1 + i__] = -sn;
}
/* L10: */
}
}
/* If ICOMPQ = 0, use SLASDQ to compute the singular values. */
if (icompq == 0) {
slasdq_("U", &c__0, n, &c__0, &c__0, &c__0, &d__[1], &e[1], &vt[
vt_offset], ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[
wstart], info);
goto L40;
}
/* If N is smaller than the minimum divide size SMLSIZ, then solve
the problem with another solver. */
if (*n <= smlsiz) {
if (icompq == 2) {
slaset_("A", n, n, &c_b29, &c_b15, &u[u_offset], ldu);
slaset_("A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt);
slasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &vt[vt_offset]
, ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[
wstart], info);
} else if (icompq == 1) {
iu = 1;
ivt = iu + *n;
slaset_("A", n, n, &c_b29, &c_b15, &q[iu + (qstart - 1) * *n], n);
slaset_("A", n, n, &c_b29, &c_b15, &q[ivt + (qstart - 1) * *n], n);
slasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &q[ivt + (
qstart - 1) * *n], n, &q[iu + (qstart - 1) * *n], n, &q[
iu + (qstart - 1) * *n], n, &work[wstart], info);
}
goto L40;
}
if (icompq == 2) {
slaset_("A", n, n, &c_b29, &c_b15, &u[u_offset], ldu);
slaset_("A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt);
}
/* Scale. */
orgnrm = slanst_("M", n, &d__[1], &e[1]);
if (orgnrm == 0.f) {
return 0;
}
latime_1.ops += (real) (*n + nm1);
slascl_("G", &c__0, &c__0, &orgnrm, &c_b15, n, &c__1, &d__[1], n, &ierr);
slascl_("G", &c__0, &c__0, &orgnrm, &c_b15, &nm1, &c__1, &e[1], &nm1, &
ierr);
eps = slamch_("Epsilon");
mlvl = (integer) (log((real) (*n) / (real) (smlsiz + 1)) / log(2.f)) + 1;
smlszp = smlsiz + 1;
if (icompq == 1) {
iu = 1;
ivt = smlsiz + 1;
difl = ivt + smlszp;
difr = difl + mlvl;
z__ = difr + (mlvl << 1);
ic = z__ + mlvl;
is = ic + 1;
poles = is + 1;
givnum = poles + (mlvl << 1);
k = 1;
givptr = 2;
perm = 3;
givcol = perm + mlvl;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((r__1 = d__[i__], dabs(r__1)) < eps) {
d__[i__] = r_sign(&eps, &d__[i__]);
}
/* L20: */
}
start = 1;
sqre = 0;
i__1 = nm1;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((r__1 = e[i__], dabs(r__1)) < eps || i__ == nm1) {
/* Subproblem found. First determine its size and then
apply divide and conquer on it. */
if (i__ < nm1) {
/* A subproblem with E(I) small for I < NM1. */
nsize = i__ - start + 1;
} else if ((r__1 = e[i__], dabs(r__1)) >= eps) {
/* A subproblem with E(NM1) not too small but I = NM1. */
nsize = *n - start + 1;
} else {
/* A subproblem with E(NM1) small. This implies an
1-by-1 subproblem at D(N). Solve this 1-by-1 problem
first. */
nsize = i__ - start + 1;
if (icompq == 2) {
u_ref(*n, *n) = r_sign(&c_b15, &d__[*n]);
vt_ref(*n, *n) = 1.f;
} else if (icompq == 1) {
q[*n + (qstart - 1) * *n] = r_sign(&c_b15, &d__[*n]);
q[*n + (smlsiz + qstart - 1) * *n] = 1.f;
}
d__[*n] = (r__1 = d__[*n], dabs(r__1));
}
if (icompq == 2) {
slasd0_(&nsize, &sqre, &d__[start], &e[start], &u_ref(start,
start), ldu, &vt_ref(start, start), ldvt, &smlsiz, &
iwork[1], &work[wstart], info);
} else {
slasda_(&icompq, &smlsiz, &nsize, &sqre, &d__[start], &e[
start], &q[start + (iu + qstart - 2) * *n], n, &q[
start + (ivt + qstart - 2) * *n], &iq[start + k * *n],
&q[start + (difl + qstart - 2) * *n], &q[start + (
difr + qstart - 2) * *n], &q[start + (z__ + qstart -
2) * *n], &q[start + (poles + qstart - 2) * *n], &iq[
start + givptr * *n], &iq[start + givcol * *n], n, &
iq[start + perm * *n], &q[start + (givnum + qstart -
2) * *n], &q[start + (ic + qstart - 2) * *n], &q[
start + (is + qstart - 2) * *n], &work[wstart], &
iwork[1], info);
if (*info != 0) {
return 0;
}
}
start = i__ + 1;
}
/* L30: */
}
/* Unscale */
latime_1.ops += (real) (*n);
slascl_("G", &c__0, &c__0, &c_b15, &orgnrm, n, &c__1, &d__[1], n, &ierr);
L40:
/* Use Selection Sort to minimize swaps of singular vectors */
i__1 = *n;
for (ii = 2; ii <= i__1; ++ii) {
i__ = ii - 1;
kk = i__;
p = d__[i__];
i__2 = *n;
for (j = ii; j <= i__2; ++j) {
if (d__[j] > p) {
kk = j;
p = d__[j];
}
/* L50: */
}
if (kk != i__) {
d__[kk] = d__[i__];
d__[i__] = p;
if (icompq == 1) {
iq[i__] = kk;
} else if (icompq == 2) {
sswap_(n, &u_ref(1, i__), &c__1, &u_ref(1, kk), &c__1);
sswap_(n, &vt_ref(i__, 1), ldvt, &vt_ref(kk, 1), ldvt);
}
} else if (icompq == 1) {
iq[i__] = i__;
}
/* L60: */
}
/* If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO */
if (icompq == 1) {
if (iuplo == 1) {
iq[*n] = 1;
} else {
iq[*n] = 0;
}
}
/* If B is lower bidiagonal, update U by those Givens rotations
which rotated B to be upper bidiagonal */
if (iuplo == 2 && icompq == 2) {
latime_1.ops += (real) ((*n - 1) * 6 * *n);
slasr_("L", "V", "B", n, n, &work[1], &work[*n], &u[u_offset], ldu);
}
return 0;
/* End of SBDSDC */
} /* sbdsdc_ */
/* Subroutine */ int dlasd0_(integer *n, integer *sqre, doublereal *d__,
doublereal *e, doublereal *u, integer *ldu, doublereal *vt, integer *
ldvt, integer *smlsiz, integer *iwork, doublereal *work, integer *
info)
{
/* System generated locals */
integer u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2;
/* Builtin functions */
integer pow_ii(integer *, integer *);
/* Local variables */
integer i__, j, m, i1, ic, lf, nd, ll, nl, nr, im1, ncc, nlf, nrf, iwk,
lvl, ndb1, nlp1, nrp1;
doublereal beta;
integer idxq, nlvl;
doublereal alpha;
integer inode, ndiml, idxqc, ndimr, itemp, sqrei;
extern /* Subroutine */ int dlasd1_(integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *, integer *, doublereal *,
integer *), dlasdq_(char *, integer *, integer *, integer *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *), dlasdt_(integer *, integer *,
integer *, integer *, integer *, integer *, integer *), xerbla_(
char *, integer *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* Using a divide and conquer approach, DLASD0 computes the singular */
/* value decomposition (SVD) of a real upper bidiagonal N-by-M */
/* matrix B with diagonal D and offdiagonal E, where M = N + SQRE. */
/* The algorithm computes orthogonal matrices U and VT such that */
/* B = U * S * VT. The singular values S are overwritten on D. */
/* A related subroutine, DLASDA, computes only the singular values, */
/* and optionally, the singular vectors in compact form. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* On entry, the row dimension of the upper bidiagonal matrix. */
/* This is also the dimension of the main diagonal array D. */
/* SQRE (input) INTEGER */
/* Specifies the column dimension of the bidiagonal matrix. */
/* = 0: The bidiagonal matrix has column dimension M = N; */
/* = 1: The bidiagonal matrix has column dimension M = N+1; */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry D contains the main diagonal of the bidiagonal */
/* matrix. */
/* On exit D, if INFO = 0, contains its singular values. */
/* E (input) DOUBLE PRECISION array, dimension (M-1) */
/* Contains the subdiagonal entries of the bidiagonal matrix. */
/* On exit, E has been destroyed. */
/* U (output) DOUBLE PRECISION array, dimension at least (LDQ, N) */
/* On exit, U contains the left singular vectors. */
/* LDU (input) INTEGER */
/* On entry, leading dimension of U. */
/* VT (output) DOUBLE PRECISION array, dimension at least (LDVT, M) */
/* On exit, VT' contains the right singular vectors. */
/* LDVT (input) INTEGER */
/* On entry, leading dimension of VT. */
/* SMLSIZ (input) INTEGER */
/* On entry, maximum size of the subproblems at the */
/* bottom of the computation tree. */
/* IWORK (workspace) INTEGER work array. */
/* Dimension must be at least (8 * N) */
/* WORK (workspace) DOUBLE PRECISION work array. */
/* Dimension must be at least (3 * M**2 + 2 * M) */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = 1, an singular value did not converge */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Ming Gu and Huan Ren, Computer Science Division, University of */
/* California at Berkeley, USA */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
--iwork;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*sqre < 0 || *sqre > 1) {
*info = -2;
}
m = *n + *sqre;
if (*ldu < *n) {
*info = -6;
} else if (*ldvt < m) {
*info = -8;
} else if (*smlsiz < 3) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLASD0", &i__1);
return 0;
}
/* If the input matrix is too small, call DLASDQ to find the SVD. */
if (*n <= *smlsiz) {
dlasdq_("U", sqre, n, &m, n, &c__0, &d__[1], &e[1], &vt[vt_offset],
ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[1], info);
return 0;
}
/* Set up the computation tree. */
inode = 1;
ndiml = inode + *n;
ndimr = ndiml + *n;
idxq = ndimr + *n;
iwk = idxq + *n;
dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr],
smlsiz);
/* For the nodes on bottom level of the tree, solve */
/* their subproblems by DLASDQ. */
ndb1 = (nd + 1) / 2;
ncc = 0;
i__1 = nd;
for (i__ = ndb1; i__ <= i__1; ++i__) {
/* IC : center row of each node */
/* NL : number of rows of left subproblem */
/* NR : number of rows of right subproblem */
/* NLF: starting row of the left subproblem */
/* NRF: starting row of the right subproblem */
i1 = i__ - 1;
ic = iwork[inode + i1];
nl = iwork[ndiml + i1];
nlp1 = nl + 1;
nr = iwork[ndimr + i1];
nrp1 = nr + 1;
nlf = ic - nl;
nrf = ic + 1;
sqrei = 1;
dlasdq_("U", &sqrei, &nl, &nlp1, &nl, &ncc, &d__[nlf], &e[nlf], &vt[
nlf + nlf * vt_dim1], ldvt, &u[nlf + nlf * u_dim1], ldu, &u[
nlf + nlf * u_dim1], ldu, &work[1], info);
if (*info != 0) {
return 0;
}
itemp = idxq + nlf - 2;
i__2 = nl;
for (j = 1; j <= i__2; ++j) {
iwork[itemp + j] = j;
/* L10: */
}
if (i__ == nd) {
sqrei = *sqre;
} else {
sqrei = 1;
}
nrp1 = nr + sqrei;
dlasdq_("U", &sqrei, &nr, &nrp1, &nr, &ncc, &d__[nrf], &e[nrf], &vt[
nrf + nrf * vt_dim1], ldvt, &u[nrf + nrf * u_dim1], ldu, &u[
nrf + nrf * u_dim1], ldu, &work[1], info);
if (*info != 0) {
return 0;
}
itemp = idxq + ic;
i__2 = nr;
for (j = 1; j <= i__2; ++j) {
iwork[itemp + j - 1] = j;
/* L20: */
}
/* L30: */
}
/* Now conquer each subproblem bottom-up. */
for (lvl = nlvl; lvl >= 1; --lvl) {
/* Find the first node LF and last node LL on the */
/* current level LVL. */
if (lvl == 1) {
lf = 1;
ll = 1;
} else {
i__1 = lvl - 1;
lf = pow_ii(&c__2, &i__1);
ll = (lf << 1) - 1;
}
i__1 = ll;
for (i__ = lf; i__ <= i__1; ++i__) {
im1 = i__ - 1;
ic = iwork[inode + im1];
nl = iwork[ndiml + im1];
nr = iwork[ndimr + im1];
nlf = ic - nl;
if (*sqre == 0 && i__ == ll) {
sqrei = *sqre;
} else {
sqrei = 1;
}
idxqc = idxq + nlf - 1;
alpha = d__[ic];
beta = e[ic];
dlasd1_(&nl, &nr, &sqrei, &d__[nlf], &alpha, &beta, &u[nlf + nlf *
u_dim1], ldu, &vt[nlf + nlf * vt_dim1], ldvt, &iwork[
idxqc], &iwork[iwk], &work[1], info);
if (*info != 0) {
return 0;
}
/* L40: */
}
/* L50: */
}
return 0;
/* End of DLASD0 */
} /* dlasd0_ */
/* Subroutine */ int zpttrs_(char *uplo, integer *n, integer *nrhs,
doublereal *d__, doublecomplex *e, doublecomplex *b, integer *ldb,
integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, i__1, i__2, i__3;
/* Local variables */
integer j, jb, nb, iuplo;
logical upper;
extern /* Subroutine */ int zptts2_(integer *, integer *, integer *,
doublereal *, doublecomplex *, doublecomplex *, integer *),
xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, 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 */
/* ======= */
/* ZPTTRS solves a tridiagonal system of the form */
/* A * X = B */
/* using the factorization A = U'*D*U or A = L*D*L' computed by ZPTTRF. */
/* D is a diagonal matrix specified in the vector D, U (or L) is a unit */
/* bidiagonal matrix whose superdiagonal (subdiagonal) is specified in */
/* the vector E, and X and B are N by NRHS matrices. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies the form of the factorization and whether the */
/* vector E is the superdiagonal of the upper bidiagonal factor */
/* U or the subdiagonal of the lower bidiagonal factor L. */
/* = 'U': A = U'*D*U, E is the superdiagonal of U */
/* = 'L': A = L*D*L', E is the subdiagonal of L */
/* N (input) INTEGER */
/* The order of the tridiagonal matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrix B. NRHS >= 0. */
/* D (input) DOUBLE PRECISION array, dimension (N) */
/* The n diagonal elements of the diagonal matrix D from the */
/* factorization A = U'*D*U or A = L*D*L'. */
/* E (input) COMPLEX*16 array, dimension (N-1) */
/* If UPLO = 'U', the (n-1) superdiagonal elements of the unit */
/* bidiagonal factor U from the factorization A = U'*D*U. */
/* If UPLO = 'L', the (n-1) subdiagonal elements of the unit */
/* bidiagonal factor L from the factorization A = L*D*L'. */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* On entry, the right hand side vectors B for the system of */
/* linear equations. */
/* On exit, the solution vectors, X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments. */
/* Parameter adjustments */
--d__;
--e;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
upper = *(unsigned char *)uplo == 'U' || *(unsigned char *)uplo == 'u';
if (! upper && ! (*(unsigned char *)uplo == 'L' || *(unsigned char *)uplo
== 'l')) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPTTRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
return 0;
}
/* Determine the number of right-hand sides to solve at a time. */
if (*nrhs == 1) {
nb = 1;
} else {
/* Computing MAX */
i__1 = 1, i__2 = ilaenv_(&c__1, "ZPTTRS", uplo, n, nrhs, &c_n1, &c_n1);
nb = max(i__1,i__2);
}
/* Decode UPLO */
if (upper) {
iuplo = 1;
} else {
iuplo = 0;
}
if (nb >= *nrhs) {
zptts2_(&iuplo, n, nrhs, &d__[1], &e[1], &b[b_offset], ldb);
} else {
i__1 = *nrhs;
i__2 = nb;
for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Computing MIN */
i__3 = *nrhs - j + 1;
jb = min(i__3,nb);
zptts2_(&iuplo, n, &jb, &d__[1], &e[1], &b[j * b_dim1 + 1], ldb);
/* L10: */
}
}
return 0;
/* End of ZPTTRS */
} /* zpttrs_ */
/* Subroutine */ int dorg2l_(integer *m, integer *n, integer *k, doublereal *
a, integer *lda, doublereal *tau, doublereal *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
/* Local variables */
integer i__, j, l, ii;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DORG2L generates an m by n real matrix Q with orthonormal columns, */
/* which is defined as the last n columns of a product of k elementary */
/* reflectors of order m */
/* Q = H(k) . . . H(2) H(1) */
/* as returned by DGEQLF. */
/* 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) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the (n-k+i)-th column must contain the vector which */
/* returned by DGEQLF in the last 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) DOUBLE PRECISION array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by DGEQLF. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument has an illegal value */
/* ===================================================================== */
/* 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_("DORG2L", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
return 0;
}
/* Initialise columns 1:n-k to columns of the unit matrix */
i__1 = *n - *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (l = 1; l <= i__2; ++l) {
a[l + j * a_dim1] = 0.;
}
a[*m - *n + j + j * a_dim1] = 1.;
}
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
ii = *n - *k + i__;
/* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left */
a[*m - *n + ii + ii * a_dim1] = 1.;
i__2 = *m - *n + ii;
i__3 = ii - 1;
dlarf_("Left", &i__2, &i__3, &a[ii * a_dim1 + 1], &c__1, &tau[i__], &
a[a_offset], lda, &work[1]);
i__2 = *m - *n + ii - 1;
d__1 = -tau[i__];
dscal_(&i__2, &d__1, &a[ii * a_dim1 + 1], &c__1);
a[*m - *n + ii + ii * a_dim1] = 1. - tau[i__];
/* Set A(m-k+i+1:m,n-k+i) to zero */
i__2 = *m;
for (l = *m - *n + ii + 1; l <= i__2; ++l) {
a[l + ii * a_dim1] = 0.;
}
}
return 0;
/* End of DORG2L */
} /* dorg2l_ */
/* Subroutine */ int dpbequ_(char *uplo, integer *n, integer *kd, doublereal *
ab, integer *ldab, doublereal *s, doublereal *scond, doublereal *amax,
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
=======
DPBEQU computes row and column scalings intended to equilibrate a
symmetric positive definite band matrix A and reduce its condition
number (with respect to the two-norm). S contains the scale factors,
S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
choice of S puts the condition number of B within a factor N of the
smallest possible condition number over all possible diagonal
scalings.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangular of A is stored;
= 'L': Lower triangular of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
KD (input) INTEGER
The number of superdiagonals of the matrix A if UPLO = 'U',
or the number of subdiagonals if UPLO = 'L'. KD >= 0.
AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
The upper or lower triangle of the symmetric band matrix A,
stored in the first KD+1 rows of the array. The j-th column
of A is stored in the j-th column of the array AB as follows:
if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
LDAB (input) INTEGER
The leading dimension of the array A. LDAB >= KD+1.
S (output) DOUBLE PRECISION array, dimension (N)
If INFO = 0, S contains the scale factors for A.
SCOND (output) DOUBLE PRECISION
If INFO = 0, S contains the ratio of the smallest S(i) to
the largest S(i). If SCOND >= 0.1 and AMAX is neither too
large nor too small, it is not worth scaling by S.
AMAX (output) DOUBLE PRECISION
Absolute value of largest matrix element. If AMAX is very
close to overflow or very close to underflow, the matrix
should be scaled.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: if INFO = i, the i-th diagonal element is nonpositive.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* System generated locals */
integer ab_dim1, ab_offset, i__1;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static doublereal smin;
static integer i__, j;
extern logical lsame_(char *, char *);
static logical upper;
extern /* Subroutine */ int xerbla_(char *, integer *);
#define ab_ref(a_1,a_2) ab[(a_2)*ab_dim1 + a_1]
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
--s;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kd < 0) {
*info = -3;
} else if (*ldab < *kd + 1) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DPBEQU", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*scond = 1.;
*amax = 0.;
return 0;
}
if (upper) {
j = *kd + 1;
} else {
j = 1;
}
/* Initialize SMIN and AMAX. */
s[1] = ab_ref(j, 1);
smin = s[1];
*amax = s[1];
/* Find the minimum and maximum diagonal elements. */
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
s[i__] = ab_ref(j, i__);
/* Computing MIN */
d__1 = smin, d__2 = s[i__];
smin = min(d__1,d__2);
/* Computing MAX */
d__1 = *amax, d__2 = s[i__];
*amax = max(d__1,d__2);
/* L10: */
}
if (smin <= 0.) {
/* Find the first non-positive diagonal element and return. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (s[i__] <= 0.) {
*info = i__;
return 0;
}
/* L20: */
}
} else {
/* Set the scale factors to the reciprocals
of the diagonal elements. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
s[i__] = 1. / sqrt(s[i__]);
/* L30: */
}
/* Compute SCOND = min(S(I)) / max(S(I)) */
*scond = sqrt(smin) / sqrt(*amax);
}
return 0;
/* End of DPBEQU */
} /* dpbequ_ */
/* Subroutine */ int cggrqf_(integer *m, integer *p, integer *n, complex *a,
integer *lda, complex *taua, complex *b, integer *ldb, complex *taub,
complex *work, integer *lwork, integer *info)
{
/* -- LAPACK 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
=======
CGGRQF computes a generalized RQ factorization of an M-by-N matrix A
and a P-by-N matrix B:
A = R*Q, B = Z*T*Q,
where Q is an N-by-N unitary matrix, Z is a P-by-P unitary
matrix, and R and T assume one of the forms:
if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N,
N-M M ( R21 ) N
N
where R12 or R21 is upper triangular, and
if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P,
( 0 ) P-N P N-P
N
where T11 is upper triangular.
In particular, if B is square and nonsingular, the GRQ factorization
of A and B implicitly gives the RQ factorization of A*inv(B):
A*inv(B) = (R*inv(T))*Z'
where inv(B) denotes the inverse of the matrix B, and Z' denotes the
conjugate transpose of the matrix Z.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
P (input) INTEGER
The number of rows of the matrix B. P >= 0.
N (input) INTEGER
The number of columns of the matrices A and B. N >= 0.
A (input/output) COMPLEX array, dimension (LDA,N)
On entry, the M-by-N matrix A.
On exit, if M <= N, the upper triangle of the subarray
A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;
if M > N, the elements on and above the (M-N)-th subdiagonal
contain the M-by-N upper trapezoidal matrix R; the remaining
elements, with the array TAUA, represent the unitary
matrix Q as a product of elementary reflectors (see Further
Details).
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
TAUA (output) COMPLEX array, dimension (min(M,N))
The scalar factors of the elementary reflectors which
represent the unitary matrix Q (see Further Details).
B (input/output) COMPLEX array, dimension (LDB,N)
On entry, the P-by-N matrix B.
On exit, the elements on and above the diagonal of the array
contain the min(P,N)-by-N upper trapezoidal matrix T (T is
upper triangular if P >= N); the elements below the diagonal,
with the array TAUB, represent the unitary matrix Z as a
product of elementary reflectors (see Further Details).
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,P).
TAUB (output) COMPLEX array, dimension (min(P,N))
The scalar factors of the elementary reflectors which
represent the unitary matrix Z (see Further Details).
WORK (workspace/output) COMPLEX 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,M,P).
For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
where NB1 is the optimal blocksize for the RQ factorization
of an M-by-N matrix, NB2 is the optimal blocksize for the
QR factorization of a P-by-N matrix, and NB3 is the optimal
blocksize for a call of CUNMRQ.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO=-i, the i-th argument had an illegal value.
Further Details
===============
The matrix Q is represented as a product of elementary reflectors
Q = H(1) H(2) . . . H(k), where k = min(m,n).
Each H(i) has the form
H(i) = I - taua * v * v'
where taua is a complex scalar, and v is a complex vector with
v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
A(m-k+i,1:n-k+i-1), and taua in TAUA(i).
To form Q explicitly, use LAPACK subroutine CUNGRQ.
To use Q to update another matrix, use LAPACK subroutine CUNMRQ.
The matrix Z is represented as a product of elementary reflectors
Z = H(1) H(2) . . . H(k), where k = min(p,n).
Each H(i) has the form
H(i) = I - taub * v * v'
where taub is a complex scalar, and v is a complex vector with
v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),
and taub in TAUB(i).
To form Z explicitly, use LAPACK subroutine CUNGQR.
To use Z to update another matrix, use LAPACK subroutine CUNMQR.
=====================================================================
Test the input parameters
Parameter adjustments
Function Body */
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
doublereal d__1;
/* Local variables */
static integer lopt;
extern /* Subroutine */ int cgeqrf_(integer *, integer *, complex *,
integer *, complex *, complex *, integer *, integer *), cgerqf_(
integer *, integer *, complex *, integer *, complex *, complex *,
integer *, integer *), xerbla_(char *, integer *),
cunmrq_(char *, char *, integer *, integer *, integer *, complex *
, integer *, complex *, complex *, integer *, complex *, integer *
, integer *);
#define TAUA(I) taua[(I)-1]
#define TAUB(I) taub[(I)-1]
#define WORK(I) work[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*p < 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
} else if (*ldb < max(1,*p)) {
*info = -8;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = max(1,*m), i__1 = max(i__1,*p);
if (*lwork < max(i__1,*n)) {
*info = -11;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGGRQF", &i__1);
return 0;
}
/* RQ factorization of M-by-N matrix A: A = R*Q */
cgerqf_(m, n, &A(1,1), lda, &TAUA(1), &WORK(1), lwork, info);
lopt = WORK(1).r;
/* Update B := B*Q' */
i__1 = min(*m,*n);
/* Computing MAX */
i__2 = 1, i__3 = *m - *n + 1;
cunmrq_("Right", "Conjugate Transpose", p, n, &i__1, &A(max(1,*m-*n+1),1), lda, &TAUA(1), &B(1,1), ldb, &WORK(1), lwork, info);
/* Computing MAX */
i__1 = lopt, i__2 = (integer) WORK(1).r;
lopt = max(i__1,i__2);
/* QR factorization of P-by-N matrix B: B = Z*T */
cgeqrf_(p, n, &B(1,1), ldb, &TAUB(1), &WORK(1), lwork, info);
/* Computing MAX */
i__1 = lopt, i__2 = (integer) WORK(1).r;
d__1 = (doublereal) max(i__1,i__2);
WORK(1).r = d__1, WORK(1).i = 0.f;
return 0;
/* End of CGGRQF */
} /* cggrqf_ */
/* Subroutine */ int sgelsd_(integer *m, integer *n, integer *nrhs, real *a,
integer *lda, real *b, integer *ldb, real *s, real *rcond, integer *
rank, real *work, integer *lwork, integer *iwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
/* Builtin functions */
double log(doublereal);
/* Local variables */
integer ie, il, mm;
real eps, anrm, bnrm;
integer itau, nlvl, iascl, ibscl;
real sfmin;
integer minmn, maxmn, itaup, itauq, mnthr, nwork;
extern /* Subroutine */ int slabad_(real *, real *), sgebrd_(integer *,
integer *, real *, integer *, real *, real *, real *, real *,
real *, integer *, integer *);
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
real bignum;
extern /* Subroutine */ int sgelqf_(integer *, integer *, real *, integer
*, real *, real *, integer *, integer *), slalsd_(char *, integer
*, integer *, integer *, real *, real *, real *, integer *, real *
, integer *, real *, integer *, integer *), slascl_(char *
, integer *, integer *, real *, real *, integer *, integer *,
real *, integer *, integer *);
integer wlalsd;
extern /* Subroutine */ int sgeqrf_(integer *, integer *, real *, integer
*, real *, real *, integer *, integer *), slacpy_(char *, integer
*, integer *, real *, integer *, real *, integer *),
slaset_(char *, integer *, integer *, real *, real *, real *,
integer *);
integer ldwork;
extern /* Subroutine */ int sormbr_(char *, char *, char *, integer *,
integer *, integer *, real *, integer *, real *, real *, integer *
, real *, integer *, integer *);
integer liwork, minwrk, maxwrk;
real smlnum;
extern /* Subroutine */ int sormlq_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *, real *,
integer *, integer *);
logical lquery;
integer smlsiz;
extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *, 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 */
/* ======= */
/* SGELSD computes the minimum-norm solution to a real linear least */
/* squares problem: */
/* minimize 2-norm(| b - A*x |) */
/* using the singular value decomposition (SVD) of A. A is an M-by-N */
/* matrix which may be rank-deficient. */
/* Several right hand side vectors b and solution vectors x can be */
/* handled in a single call; they are stored as the columns of the */
/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
/* matrix X. */
/* The problem is solved in three steps: */
/* (1) Reduce the coefficient matrix A to bidiagonal form with */
/* Householder transformations, reducing the original problem */
/* into a "bidiagonal least squares problem" (BLS) */
/* (2) Solve the BLS using a divide and conquer approach. */
/* (3) Apply back all the Householder tranformations to solve */
/* the original least squares problem. */
/* The effective rank of A is determined by treating as zero those */
/* singular values which are less than RCOND times the largest singular */
/* value. */
/* 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 */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* A (input) REAL array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, A has been destroyed. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* B (input/output) REAL array, dimension (LDB,NRHS) */
/* On entry, the M-by-NRHS right hand side matrix B. */
/* On exit, B is overwritten by the N-by-NRHS solution */
/* matrix X. If m >= n and RANK = n, the residual */
/* sum-of-squares for the solution in the i-th column is given */
/* by the sum of squares of elements n+1:m in that column. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,max(M,N)). */
/* S (output) REAL array, dimension (min(M,N)) */
/* The singular values of A in decreasing order. */
/* The condition number of A in the 2-norm = S(1)/S(min(m,n)). */
/* RCOND (input) REAL */
/* RCOND is used to determine the effective rank of A. */
/* Singular values S(i) <= RCOND*S(1) are treated as zero. */
/* If RCOND < 0, machine precision is used instead. */
/* RANK (output) INTEGER */
/* The effective rank of A, i.e., the number of singular values */
/* which are greater than RCOND*S(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 must be at least 1. */
/* The exact minimum amount of workspace needed depends on M, */
/* N and NRHS. As long as LWORK is at least */
/* 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2, */
/* if M is greater than or equal to N or */
/* 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2, */
/* if M is less than N, the code will execute correctly. */
/* SMLSIZ is returned by ILAENV and is equal to the maximum */
/* size of the subproblems at the bottom of the computation */
/* tree (usually about 25), and */
/* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ) */
/* For good performance, LWORK should generally be larger. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the array WORK and the */
/* minimum size of the array IWORK, and returns these values as */
/* the first entries of the WORK and IWORK arrays, and no error */
/* message related to LWORK is issued by XERBLA. */
/* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK)) */
/* LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN), */
/* where MINMN = MIN( M,N ). */
/* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: the algorithm for computing the SVD failed to converge; */
/* if INFO = i, i off-diagonal elements of an intermediate */
/* bidiagonal form did not converge to zero. */
/* 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 */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. 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;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--s;
--work;
--iwork;
/* Function Body */
*info = 0;
minmn = min(*m,*n);
maxmn = max(*m,*n);
lquery = *lwork == -1;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
} else if (*ldb < max(1,maxmn)) {
*info = -7;
}
/* 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.) */
if (*info == 0) {
minwrk = 1;
maxwrk = 1;
liwork = 1;
if (minmn > 0) {
smlsiz = ilaenv_(&c__9, "SGELSD", " ", &c__0, &c__0, &c__0, &c__0);
mnthr = ilaenv_(&c__6, "SGELSD", " ", m, n, nrhs, &c_n1);
/* Computing MAX */
i__1 = (integer) (log((real) minmn / (real) (smlsiz + 1)) / log(
2.f)) + 1;
nlvl = max(i__1,0);
liwork = minmn * 3 * nlvl + minmn * 11;
mm = *m;
if (*m >= *n && *m >= mnthr) {
/* Path 1a - overdetermined, with many more rows than */
/* columns. */
mm = *n;
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "SGEQRF",
" ", m, n, &c_n1, &c_n1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, "SORMQR",
"LT", m, nrhs, n, &c_n1);
maxwrk = max(i__1,i__2);
}
if (*m >= *n) {
/* Path 1 - overdetermined or exactly determined. */
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3 + (mm + *n) * ilaenv_(&c__1,
"SGEBRD", " ", &mm, n, &c_n1, &c_n1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3 + *nrhs * ilaenv_(&c__1, "SORMBR"
, "QLT", &mm, nrhs, n, &c_n1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
"SORMBR", "PLN", n, nrhs, n, &c_n1);
maxwrk = max(i__1,i__2);
/* Computing 2nd power */
i__1 = smlsiz + 1;
wlalsd = *n * 9 + (*n << 1) * smlsiz + (*n << 3) * nlvl + *n *
*nrhs + i__1 * i__1;
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3 + wlalsd;
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = *n * 3 + mm, i__2 = *n * 3 + *nrhs, i__1 = max(i__1,
i__2), i__2 = *n * 3 + wlalsd;
minwrk = max(i__1,i__2);
}
if (*n > *m) {
/* Computing 2nd power */
i__1 = smlsiz + 1;
wlalsd = *m * 9 + (*m << 1) * smlsiz + (*m << 3) * nlvl + *m *
*nrhs + i__1 * i__1;
if (*n >= mnthr) {
/* Path 2a - underdetermined, with many more columns */
/* than rows. */
maxwrk = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, &
c_n1, &c_n1);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m << 1) *
ilaenv_(&c__1, "SGEBRD", " ", m, m, &c_n1, &c_n1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + *nrhs *
ilaenv_(&c__1, "SORMBR", "QLT", m, nrhs, m, &c_n1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m - 1) *
ilaenv_(&c__1, "SORMBR", "PLN", m, nrhs, m, &c_n1);
maxwrk = max(i__1,i__2);
if (*nrhs > 1) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs;
maxwrk = max(i__1,i__2);
} else {
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 1);
maxwrk = max(i__1,i__2);
}
/* Computing MAX */
i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, "SORMLQ"
, "LT", n, nrhs, m, &c_n1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + wlalsd;
maxwrk = max(i__1,i__2);
} else {
/* Path 2 - remaining underdetermined cases. */
maxwrk = *m * 3 + (*n + *m) * ilaenv_(&c__1, "SGEBRD",
" ", m, n, &c_n1, &c_n1);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + *nrhs * ilaenv_(&c__1,
"SORMBR", "QLT", m, nrhs, n, &c_n1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORM"
"BR", "PLN", n, nrhs, m, &c_n1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + wlalsd;
maxwrk = max(i__1,i__2);
}
/* Computing MAX */
i__1 = *m * 3 + *nrhs, i__2 = *m * 3 + *m, i__1 = max(i__1,
i__2), i__2 = *m * 3 + wlalsd;
minwrk = max(i__1,i__2);
}
}
minwrk = min(minwrk,maxwrk);
work[1] = (real) maxwrk;
iwork[1] = liwork;
if (*lwork < minwrk && ! lquery) {
*info = -12;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGELSD", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible. */
if (*m == 0 || *n == 0) {
*rank = 0;
return 0;
}
/* Get machine parameters. */
eps = slamch_("P");
sfmin = slamch_("S");
smlnum = sfmin / eps;
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
/* Scale A if max entry outside range [SMLNUM,BIGNUM]. */
anrm = slange_("M", m, n, &a[a_offset], lda, &work[1]);
iascl = 0;
if (anrm > 0.f && anrm < smlnum) {
/* Scale matrix norm up to SMLNUM. */
slascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
info);
iascl = 1;
} else if (anrm > bignum) {
/* Scale matrix norm down to BIGNUM. */
slascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
info);
iascl = 2;
} else if (anrm == 0.f) {
/* Matrix all zero. Return zero solution. */
i__1 = max(*m,*n);
slaset_("F", &i__1, nrhs, &c_b81, &c_b81, &b[b_offset], ldb);
slaset_("F", &minmn, &c__1, &c_b81, &c_b81, &s[1], &c__1);
*rank = 0;
goto L10;
}
/* Scale B if max entry outside range [SMLNUM,BIGNUM]. */
bnrm = slange_("M", m, nrhs, &b[b_offset], ldb, &work[1]);
ibscl = 0;
if (bnrm > 0.f && bnrm < smlnum) {
/* Scale matrix norm up to SMLNUM. */
slascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
info);
ibscl = 1;
} else if (bnrm > bignum) {
/* Scale matrix norm down to BIGNUM. */
slascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
info);
ibscl = 2;
}
/* If M < N make sure certain entries of B are zero. */
if (*m < *n) {
i__1 = *n - *m;
slaset_("F", &i__1, nrhs, &c_b81, &c_b81, &b[*m + 1 + b_dim1], ldb);
}
/* Overdetermined case. */
if (*m >= *n) {
/* Path 1 - overdetermined or exactly determined. */
mm = *m;
if (*m >= mnthr) {
/* Path 1a - overdetermined, with many more rows than columns. */
mm = *n;
itau = 1;
nwork = itau + *n;
/* Compute A=Q*R. */
/* (Workspace: need 2*N, prefer N+N*NB) */
i__1 = *lwork - nwork + 1;
sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1,
info);
/* Multiply B by transpose(Q). */
/* (Workspace: need N+NRHS, prefer N+NRHS*NB) */
i__1 = *lwork - nwork + 1;
sormqr_("L", "T", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[
b_offset], ldb, &work[nwork], &i__1, info);
/* Zero out below R. */
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
slaset_("L", &i__1, &i__2, &c_b81, &c_b81, &a[a_dim1 + 2],
lda);
}
}
ie = 1;
itauq = ie + *n;
itaup = itauq + *n;
nwork = itaup + *n;
/* Bidiagonalize R in A. */
/* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) */
i__1 = *lwork - nwork + 1;
sgebrd_(&mm, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
work[itaup], &work[nwork], &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors of R. */
/* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) */
i__1 = *lwork - nwork + 1;
sormbr_("Q", "L", "T", &mm, nrhs, n, &a[a_offset], lda, &work[itauq],
&b[b_offset], ldb, &work[nwork], &i__1, info);
/* Solve the bidiagonal least squares problem. */
slalsd_("U", &smlsiz, n, nrhs, &s[1], &work[ie], &b[b_offset], ldb,
rcond, rank, &work[nwork], &iwork[1], info);
if (*info != 0) {
goto L10;
}
/* Multiply B by right bidiagonalizing vectors of R. */
i__1 = *lwork - nwork + 1;
sormbr_("P", "L", "N", n, nrhs, n, &a[a_offset], lda, &work[itaup], &
b[b_offset], ldb, &work[nwork], &i__1, info);
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = *m, i__2 = (*m << 1) - 4, i__1 = max(i__1,i__2), i__1 = max(
i__1,*nrhs), i__2 = *n - *m * 3, i__1 = max(i__1,i__2);
if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + max(i__1,wlalsd)) {
/* Path 2a - underdetermined, with many more columns than rows */
/* and sufficient workspace for an efficient algorithm. */
ldwork = *m;
/* Computing MAX */
/* Computing MAX */
i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4), i__3 =
max(i__3,*nrhs), i__4 = *n - *m * 3;
i__1 = (*m << 2) + *m * *lda + max(i__3,i__4), i__2 = *m * *lda +
*m + *m * *nrhs, i__1 = max(i__1,i__2), i__2 = (*m << 2)
+ *m * *lda + wlalsd;
if (*lwork >= max(i__1,i__2)) {
ldwork = *lda;
}
itau = 1;
nwork = *m + 1;
/* Compute A=L*Q. */
/* (Workspace: need 2*M, prefer M+M*NB) */
i__1 = *lwork - nwork + 1;
sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1,
info);
il = nwork;
/* Copy L to WORK(IL), zeroing out above its diagonal. */
slacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwork);
i__1 = *m - 1;
i__2 = *m - 1;
slaset_("U", &i__1, &i__2, &c_b81, &c_b81, &work[il + ldwork], &
ldwork);
ie = il + ldwork * *m;
itauq = ie + *m;
itaup = itauq + *m;
nwork = itaup + *m;
/* Bidiagonalize L in WORK(IL). */
/* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) */
i__1 = *lwork - nwork + 1;
sgebrd_(m, m, &work[il], &ldwork, &s[1], &work[ie], &work[itauq],
&work[itaup], &work[nwork], &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors of L. */
/* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) */
i__1 = *lwork - nwork + 1;
sormbr_("Q", "L", "T", m, nrhs, m, &work[il], &ldwork, &work[
itauq], &b[b_offset], ldb, &work[nwork], &i__1, info);
/* Solve the bidiagonal least squares problem. */
slalsd_("U", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset],
ldb, rcond, rank, &work[nwork], &iwork[1], info);
if (*info != 0) {
goto L10;
}
/* Multiply B by right bidiagonalizing vectors of L. */
i__1 = *lwork - nwork + 1;
sormbr_("P", "L", "N", m, nrhs, m, &work[il], &ldwork, &work[
itaup], &b[b_offset], ldb, &work[nwork], &i__1, info);
/* Zero out below first M rows of B. */
i__1 = *n - *m;
slaset_("F", &i__1, nrhs, &c_b81, &c_b81, &b[*m + 1 + b_dim1],
ldb);
nwork = itau + *m;
/* Multiply transpose(Q) by B. */
/* (Workspace: need M+NRHS, prefer M+NRHS*NB) */
i__1 = *lwork - nwork + 1;
sormlq_("L", "T", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[
b_offset], ldb, &work[nwork], &i__1, info);
} else {
/* Path 2 - remaining underdetermined cases. */
ie = 1;
itauq = ie + *m;
itaup = itauq + *m;
nwork = itaup + *m;
/* Bidiagonalize A. */
/* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */
i__1 = *lwork - nwork + 1;
sgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
work[itaup], &work[nwork], &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors. */
/* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) */
i__1 = *lwork - nwork + 1;
sormbr_("Q", "L", "T", m, nrhs, n, &a[a_offset], lda, &work[itauq]
, &b[b_offset], ldb, &work[nwork], &i__1, info);
/* Solve the bidiagonal least squares problem. */
slalsd_("L", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset],
ldb, rcond, rank, &work[nwork], &iwork[1], info);
if (*info != 0) {
goto L10;
}
/* Multiply B by right bidiagonalizing vectors of A. */
i__1 = *lwork - nwork + 1;
sormbr_("P", "L", "N", n, nrhs, m, &a[a_offset], lda, &work[itaup]
, &b[b_offset], ldb, &work[nwork], &i__1, info);
}
}
/* Undo scaling. */
if (iascl == 1) {
slascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
info);
slascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
minmn, info);
} else if (iascl == 2) {
slascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
info);
slascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
minmn, info);
}
if (ibscl == 1) {
slascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
info);
} else if (ibscl == 2) {
slascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
info);
}
L10:
work[1] = (real) maxwrk;
iwork[1] = liwork;
return 0;
/* End of SGELSD */
} /* sgelsd_ */
/* 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;
/* Local variables */
integer j, kbeg, jcol;
integer irow;
integer ixfrm, itype, nxfrm;
real xnorm;
real factor;
extern doublereal slarnd_(integer *, integer *);
real xnorms;
/* -- LAPACK auxiliary test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* 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. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
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 = -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 = -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 = -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 dpoequb_(integer *n, doublereal *a, integer *lda,
doublereal *s, doublereal *scond, doublereal *amax, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double log(doublereal), pow_di(doublereal *, integer *), sqrt(doublereal);
/* Local variables */
integer i__;
doublereal tmp, base, smin;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/* -- Jason Riedy of Univ. of California Berkeley. -- */
/* -- November 2008 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley and NAG Ltd. -- */
/* .. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DPOEQU computes row and column scalings intended to equilibrate a */
/* symmetric positive definite matrix A and reduce its condition number */
/* (with respect to the two-norm). S contains the scale factors, */
/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */
/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */
/* choice of S puts the condition number of B within a factor N of the */
/* smallest possible condition number over all possible diagonal */
/* scalings. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The N-by-N symmetric positive definite matrix whose scaling */
/* factors are to be computed. Only the diagonal elements of A */
/* are referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* S (output) DOUBLE PRECISION array, dimension (N) */
/* If INFO = 0, S contains the scale factors for A. */
/* SCOND (output) DOUBLE PRECISION */
/* If INFO = 0, S contains the ratio of the smallest S(i) to */
/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
/* large nor too small, it is not worth scaling by S. */
/* AMAX (output) DOUBLE PRECISION */
/* Absolute value of largest matrix element. If AMAX is very */
/* close to overflow or very close to underflow, the matrix */
/* should be scaled. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Positive definite only performs 1 pass of equilibration. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--s;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*lda < max(1,*n)) {
*info = -3;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DPOEQUB", &i__1);
return 0;
}
/* Quick return if possible. */
if (*n == 0) {
*scond = 1.;
*amax = 0.;
return 0;
}
base = dlamch_("B");
tmp = -.5 / log(base);
/* Find the minimum and maximum diagonal elements. */
s[1] = a[a_dim1 + 1];
smin = s[1];
*amax = s[1];
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
s[i__] = a[i__ + i__ * a_dim1];
/* Computing MIN */
d__1 = smin, d__2 = s[i__];
smin = min(d__1,d__2);
/* Computing MAX */
d__1 = *amax, d__2 = s[i__];
*amax = max(d__1,d__2);
/* L10: */
}
if (smin <= 0.) {
/* Find the first non-positive diagonal element and return. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (s[i__] <= 0.) {
*info = i__;
return 0;
}
/* L20: */
}
} else {
/* Set the scale factors to the reciprocals */
/* of the diagonal elements. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = (integer) (tmp * log(s[i__]));
s[i__] = pow_di(&base, &i__2);
/* L30: */
}
/* Compute SCOND = min(S(I)) / max(S(I)). */
*scond = sqrt(smin) / sqrt(*amax);
}
return 0;
/* End of DPOEQUB */
} /* dpoequb_ */
/*! \brief
*
* <pre>
* Purpose
* =======
*
* SGSEQU computes row and column scalings intended to equilibrate an
* M-by-N sparse matrix A and reduce its condition number. R returns the row
* scale factors and C the column scale factors, chosen to try to make
* the largest element in each row and column of the matrix B with
* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
*
* R(i) and C(j) are restricted to be between SMLNUM = smallest safe
* number and BIGNUM = largest safe number. Use of these scaling
* factors is not guaranteed to reduce the condition number of A but
* works well in practice.
*
* See supermatrix.h for the definition of 'SuperMatrix' structure.
*
* Arguments
* =========
*
* A (input) SuperMatrix*
* The matrix of dimension (A->nrow, A->ncol) whose equilibration
* factors are to be computed. The type of A can be:
* Stype = SLU_NC; Dtype = SLU_S; Mtype = SLU_GE.
*
* R (output) float*, size A->nrow
* If INFO = 0 or INFO > M, R contains the row scale factors
* for A.
*
* C (output) float*, size A->ncol
* If INFO = 0, C contains the column scale factors for A.
*
* ROWCND (output) float*
* If INFO = 0 or INFO > M, ROWCND contains the ratio of the
* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
* AMAX is neither too large nor too small, it is not worth
* scaling by R.
*
* COLCND (output) float*
* If INFO = 0, COLCND contains the ratio of the smallest
* C(i) to the largest C(i). If COLCND >= 0.1, it is not
* worth scaling by C.
*
* AMAX (output) float*
* Absolute value of largest matrix element. If AMAX is very
* close to overflow or very close to underflow, the matrix
* should be scaled.
*
* INFO (output) int*
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, and i is
* <= A->nrow: the i-th row of A is exactly zero
* > A->ncol: the (i-M)-th column of A is exactly zero
*
* =====================================================================
* </pre>
*/
void
sgsequ(SuperMatrix *A, float *r, float *c, float *rowcnd,
float *colcnd, float *amax, int *info)
{
/* Local variables */
NCformat *Astore;
float *Aval;
int i, j, irow;
float rcmin, rcmax;
float bignum, smlnum;
extern float slamch_(char *);
/* Test the input parameters. */
*info = 0;
if ( A->nrow < 0 || A->ncol < 0 ||
A->Stype != SLU_NC || A->Dtype != SLU_S || A->Mtype != SLU_GE )
*info = -1;
if (*info != 0) {
i = -(*info);
xerbla_("sgsequ", &i);
return;
}
/* Quick return if possible */
if ( A->nrow == 0 || A->ncol == 0 ) {
*rowcnd = 1.;
*colcnd = 1.;
*amax = 0.;
return;
}
Astore = A->Store;
Aval = Astore->nzval;
/* Get machine constants. */
smlnum = slamch_("S");
bignum = 1. / smlnum;
/* Compute row scale factors. */
for (i = 0; i < A->nrow; ++i) r[i] = 0.;
/* Find the maximum element in each row. */
for (j = 0; j < A->ncol; ++j)
for (i = Astore->colptr[j]; i < Astore->colptr[j+1]; ++i) {
irow = Astore->rowind[i];
r[irow] = SUPERLU_MAX( r[irow], fabs(Aval[i]) );
}
/* Find the maximum and minimum scale factors. */
rcmin = bignum;
rcmax = 0.;
for (i = 0; i < A->nrow; ++i) {
rcmax = SUPERLU_MAX(rcmax, r[i]);
rcmin = SUPERLU_MIN(rcmin, r[i]);
}
*amax = rcmax;
if (rcmin == 0.) {
/* Find the first zero scale factor and return an error code. */
for (i = 0; i < A->nrow; ++i)
if (r[i] == 0.) {
*info = i + 1;
return;
}
} else {
/* Invert the scale factors. */
for (i = 0; i < A->nrow; ++i)
r[i] = 1. / SUPERLU_MIN( SUPERLU_MAX( r[i], smlnum ), bignum );
/* Compute ROWCND = min(R(I)) / max(R(I)) */
*rowcnd = SUPERLU_MAX( rcmin, smlnum ) / SUPERLU_MIN( rcmax, bignum );
}
/* Compute column scale factors */
for (j = 0; j < A->ncol; ++j) c[j] = 0.;
/* Find the maximum element in each column, assuming the row
scalings computed above. */
for (j = 0; j < A->ncol; ++j)
for (i = Astore->colptr[j]; i < Astore->colptr[j+1]; ++i) {
irow = Astore->rowind[i];
c[j] = SUPERLU_MAX( c[j], fabs(Aval[i]) * r[irow] );
}
/* Find the maximum and minimum scale factors. */
rcmin = bignum;
rcmax = 0.;
for (j = 0; j < A->ncol; ++j) {
rcmax = SUPERLU_MAX(rcmax, c[j]);
rcmin = SUPERLU_MIN(rcmin, c[j]);
}
if (rcmin == 0.) {
/* Find the first zero scale factor and return an error code. */
for (j = 0; j < A->ncol; ++j)
if ( c[j] == 0. ) {
*info = A->nrow + j + 1;
return;
}
} else {
/* Invert the scale factors. */
for (j = 0; j < A->ncol; ++j)
c[j] = 1. / SUPERLU_MIN( SUPERLU_MAX( c[j], smlnum ), bignum);
/* Compute COLCND = min(C(J)) / max(C(J)) */
*colcnd = SUPERLU_MAX( rcmin, smlnum ) / SUPERLU_MIN( rcmax, bignum );
}
return;
} /* sgsequ */
/* Subroutine */ int dlauum_(char *uplo, integer *n, doublereal *a, integer *
lda, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */
integer i__, ib, nb;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *);
logical upper;
extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *), dlauu2_(char *, integer *,
doublereal *, integer *, integer *), xerbla_(char *,
integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAUUM computes the product U * U' or L' * L, where the triangular */
/* factor U or L is stored in the upper or lower triangular part of */
/* the array A. */
/* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */
/* overwriting the factor U in A. */
/* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */
/* overwriting the factor L in A. */
/* This is the blocked form of the algorithm, calling Level 3 BLAS. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the triangular factor stored in the array A */
/* is upper or lower triangular: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the triangular factor U or L. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the triangular factor U or L. */
/* On exit, if UPLO = 'U', the upper triangle of A is */
/* overwritten with the upper triangle of the product U * U'; */
/* if UPLO = 'L', the lower triangle of A is overwritten with */
/* the lower triangle of the product L' * L. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* ===================================================================== */
/* .. 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;
/* 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_("DLAUUM", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine the block size for this environment. */
nb = ilaenv_(&c__1, "DLAUUM", uplo, n, &c_n1, &c_n1, &c_n1);
if (nb <= 1 || nb >= *n) {
/* Use unblocked code */
dlauu2_(uplo, n, &a[a_offset], lda, info);
} else {
/* Use blocked code */
if (upper) {
/* Compute the product U * U'. */
i__1 = *n;
i__2 = nb;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__3 = nb, i__4 = *n - i__ + 1;
ib = min(i__3,i__4);
i__3 = i__ - 1;
dtrmm_("Right", "Upper", "Transpose", "Non-unit", &i__3, &ib,
&c_b15, &a[i__ + i__ * a_dim1], lda, &a[i__ * a_dim1
+ 1], lda)
;
dlauu2_("Upper", &ib, &a[i__ + i__ * a_dim1], lda, info);
if (i__ + ib <= *n) {
i__3 = i__ - 1;
i__4 = *n - i__ - ib + 1;
dgemm_("No transpose", "Transpose", &i__3, &ib, &i__4, &
c_b15, &a[(i__ + ib) * a_dim1 + 1], lda, &a[i__ +
(i__ + ib) * a_dim1], lda, &c_b15, &a[i__ *
a_dim1 + 1], lda);
i__3 = *n - i__ - ib + 1;
dsyrk_("Upper", "No transpose", &ib, &i__3, &c_b15, &a[
i__ + (i__ + ib) * a_dim1], lda, &c_b15, &a[i__ +
i__ * a_dim1], lda);
}
/* L10: */
}
} else {
/* Compute the product L' * L. */
i__2 = *n;
i__1 = nb;
for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
/* Computing MIN */
i__3 = nb, i__4 = *n - i__ + 1;
ib = min(i__3,i__4);
i__3 = i__ - 1;
dtrmm_("Left", "Lower", "Transpose", "Non-unit", &ib, &i__3, &
c_b15, &a[i__ + i__ * a_dim1], lda, &a[i__ + a_dim1],
lda);
dlauu2_("Lower", &ib, &a[i__ + i__ * a_dim1], lda, info);
if (i__ + ib <= *n) {
i__3 = i__ - 1;
i__4 = *n - i__ - ib + 1;
dgemm_("Transpose", "No transpose", &ib, &i__3, &i__4, &
c_b15, &a[i__ + ib + i__ * a_dim1], lda, &a[i__ +
ib + a_dim1], lda, &c_b15, &a[i__ + a_dim1], lda);
i__3 = *n - i__ - ib + 1;
dsyrk_("Lower", "Transpose", &ib, &i__3, &c_b15, &a[i__ +
ib + i__ * a_dim1], lda, &c_b15, &a[i__ + i__ *
a_dim1], lda);
}
/* L20: */
}
}
}
return 0;
/* End of DLAUUM */
} /* dlauum_ */
/* Subroutine */ int ssyev_(char *jobz, char *uplo, integer *n, real *a,
integer *lda, real *w, real *work, integer *lwork, 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;
integer iscale;
extern doublereal slamch_(char *);
real safmin;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *);
real bignum;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *);
integer indtau, indwrk;
extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *);
extern doublereal slansy_(char *, char *, integer *, real *, integer *,
real *);
integer llwork;
real smlnum;
integer lwkopt;
logical lquery;
extern /* Subroutine */ int sorgtr_(char *, integer *, real *, integer *,
real *, real *, integer *, integer *), ssteqr_(char *,
integer *, real *, real *, real *, integer *, real *, integer *), ssytrd_(char *, integer *, real *, integer *, real *,
real *, real *, real *, integer *, integer *);
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SSYEV computes all eigenvalues and, optionally, eigenvectors of a */
/* real symmetric matrix A. */
/* Arguments */
/* ========= */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* 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, if JOBZ = 'V', then if INFO = 0, A contains the */
/* orthonormal eigenvectors of the matrix A. */
/* If JOBZ = 'N', then 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). */
/* W (output) REAL array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The length of the array WORK. LWORK >= max(1,3*N-1). */
/* For optimal efficiency, LWORK >= (NB+2)*N, */
/* where NB is the blocksize for SSYTRD returned by ILAENV. */
/* 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, the algorithm failed to converge; i */
/* off-diagonal elements of an intermediate tridiagonal */
/* form did not converge to zero. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
--work;
/* 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, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1);
/* Computing MAX */
i__1 = 1, i__2 = (nb + 2) * *n;
lwkopt = max(i__1,i__2);
work[1] = (real) lwkopt;
/* Computing MAX */
i__1 = 1, i__2 = *n * 3 - 1;
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -8;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSYEV ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
w[1] = a[a_dim1 + 1];
work[1] = 2.f;
if (wantz) {
a[a_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);
rmax = sqrt(bignum);
/* Scale matrix to allowable range, if necessary. */
anrm = slansy_("M", uplo, n, &a[a_offset], lda, &work[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) {
slascl_(uplo, &c__0, &c__0, &c_b17, &sigma, n, n, &a[a_offset], lda,
info);
}
/* Call SSYTRD to reduce symmetric matrix to tridiagonal form. */
inde = 1;
indtau = inde + *n;
indwrk = indtau + *n;
llwork = *lwork - indwrk + 1;
ssytrd_(uplo, n, &a[a_offset], lda, &w[1], &work[inde], &work[indtau], &
work[indwrk], &llwork, &iinfo);
/* For eigenvalues only, call SSTERF. For eigenvectors, first call */
/* SORGTR to generate the orthogonal matrix, then call SSTEQR. */
if (! wantz) {
ssterf_(n, &w[1], &work[inde], info);
} else {
sorgtr_(uplo, n, &a[a_offset], lda, &work[indtau], &work[indwrk], &
llwork, &iinfo);
ssteqr_(jobz, n, &w[1], &work[inde], &a[a_offset], lda, &work[indtau],
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 workspace size. */
work[1] = (real) lwkopt;
return 0;
/* End of SSYEV */
} /* ssyev_ */
int ctbrfs_(char *uplo, char *trans, char *diag, int *n,
int *kd, int *nrhs, complex *ab, int *ldab, complex *b,
int *ldb, complex *x, int *ldx, float *ferr, float *berr,
complex *work, float *rwork, int *info)
{
/* System generated locals */
int ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1,
i__2, i__3, i__4, i__5;
float r__1, r__2, r__3, r__4;
complex q__1;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
int i__, j, k;
float s, xk;
int nz;
float eps;
int kase;
float safe1, safe2;
extern int lsame_(char *, char *);
int isave[3];
extern int ctbmv_(char *, char *, char *, int *,
int *, complex *, int *, complex *, int *), ccopy_(int *, complex *, int *, complex *
, int *), ctbsv_(char *, char *, char *, int *, int *,
complex *, int *, complex *, int *), caxpy_(int *, complex *, complex *, int *,
complex *, int *);
int upper;
extern int clacn2_(int *, complex *, complex *, float
*, int *, int *);
extern double slamch_(char *);
float safmin;
extern int xerbla_(char *, int *);
int notran;
char transn[1], transt[1];
int nounit;
float lstres;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CTBRFS provides error bounds and backward error estimates for the */
/* solution to a system of linear equations with a triangular band */
/* coefficient matrix. */
/* The solution matrix X must be computed by CTBTRS or some other */
/* means before entering this routine. CTBRFS does not do iterative */
/* refinement because doing so cannot improve the backward error. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': A is upper triangular; */
/* = 'L': A is lower triangular. */
/* TRANS (input) CHARACTER*1 */
/* Specifies the form of the system of equations: */
/* = 'N': A * X = B (No transpose) */
/* = 'T': A**T * X = B (Transpose) */
/* = 'C': A**H * X = B (Conjugate transpose) */
/* DIAG (input) CHARACTER*1 */
/* = 'N': A is non-unit triangular; */
/* = 'U': A is unit triangular. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* KD (input) INTEGER */
/* The number of superdiagonals or subdiagonals of the */
/* triangular band matrix A. KD >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 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). */
/* If DIAG = 'U', the diagonal elements of A are not referenced */
/* and are assumed to be 1. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KD+1. */
/* B (input) COMPLEX array, dimension (LDB,NRHS) */
/* The right hand side matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= MAX(1,N). */
/* X (input) COMPLEX array, dimension (LDX,NRHS) */
/* The solution matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= MAX(1,N). */
/* FERR (output) REAL array, dimension (NRHS) */
/* The estimated forward error bound for each solution vector */
/* X(j) (the j-th column of the solution matrix X). */
/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
/* is an estimated upper bound for the magnitude of the largest */
/* element in (X(j) - XTRUE) divided by the magnitude of the */
/* largest element in X(j). The estimate is as reliable as */
/* the estimate for RCOND, and is almost always a slight */
/* overestimate of the true error. */
/* BERR (output) REAL array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector X(j) (i.e., the smallest relative change in */
/* any element of A or B that makes X(j) an exact solution). */
/* WORK (workspace) COMPLEX array, dimension (2*N) */
/* RWORK (workspace) REAL array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--rwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && !
lsame_(trans, "C")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*kd < 0) {
*info = -5;
} else if (*nrhs < 0) {
*info = -6;
} else if (*ldab < *kd + 1) {
*info = -8;
} else if (*ldb < MAX(1,*n)) {
*info = -10;
} else if (*ldx < MAX(1,*n)) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTBRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] = 0.f;
berr[j] = 0.f;
/* L10: */
}
return 0;
}
if (notran) {
*(unsigned char *)transn = 'N';
*(unsigned char *)transt = 'C';
} else {
*(unsigned char *)transn = 'C';
*(unsigned char *)transt = 'N';
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *kd + 2;
eps = slamch_("Epsilon");
safmin = slamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
/* Compute residual R = B - op(A) * X, */
/* where op(A) = A, A**T, or A**H, depending on TRANS. */
ccopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
ctbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[1], &
c__1);
q__1.r = -1.f, q__1.i = -0.f;
caxpy_(n, &q__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
/* Compute componentwise relative backward error from formula */
/* MAX(i) ( ABS(R(i)) / ( ABS(op(A))*ABS(X) + ABS(B) )(i) ) */
/* where ABS(Z) is the componentwise absolute value of the matrix */
/* or vector Z. If the i-th component of the denominator is less */
/* than SAFE2, then SAFE1 is added to the i-th components of the */
/* numerator and denominator before dividing. */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
rwork[i__] = (r__1 = b[i__3].r, ABS(r__1)) + (r__2 = r_imag(&b[
i__ + j * b_dim1]), ABS(r__2));
/* L20: */
}
if (notran) {
/* Compute ABS(A)*ABS(X) + ABS(B). */
if (upper) {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = k + j * x_dim1;
xk = (r__1 = x[i__3].r, ABS(r__1)) + (r__2 = r_imag(&
x[k + j * x_dim1]), ABS(r__2));
/* Computing MAX */
i__3 = 1, i__4 = k - *kd;
i__5 = k;
for (i__ = MAX(i__3,i__4); i__ <= i__5; ++i__) {
i__3 = *kd + 1 + i__ - k + k * ab_dim1;
rwork[i__] += ((r__1 = ab[i__3].r, ABS(r__1)) + (
r__2 = r_imag(&ab[*kd + 1 + i__ - k + k *
ab_dim1]), ABS(r__2))) * xk;
/* L30: */
}
/* L40: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__5 = k + j * x_dim1;
xk = (r__1 = x[i__5].r, ABS(r__1)) + (r__2 = r_imag(&
x[k + j * x_dim1]), ABS(r__2));
/* Computing MAX */
i__5 = 1, i__3 = k - *kd;
i__4 = k - 1;
for (i__ = MAX(i__5,i__3); i__ <= i__4; ++i__) {
i__5 = *kd + 1 + i__ - k + k * ab_dim1;
rwork[i__] += ((r__1 = ab[i__5].r, ABS(r__1)) + (
r__2 = r_imag(&ab[*kd + 1 + i__ - k + k *
ab_dim1]), ABS(r__2))) * xk;
/* L50: */
}
rwork[k] += xk;
/* L60: */
}
}
} else {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__4 = k + j * x_dim1;
xk = (r__1 = x[i__4].r, ABS(r__1)) + (r__2 = r_imag(&
x[k + j * x_dim1]), ABS(r__2));
/* Computing MIN */
i__5 = *n, i__3 = k + *kd;
i__4 = MIN(i__5,i__3);
for (i__ = k; i__ <= i__4; ++i__) {
i__5 = i__ + 1 - k + k * ab_dim1;
rwork[i__] += ((r__1 = ab[i__5].r, ABS(r__1)) + (
r__2 = r_imag(&ab[i__ + 1 - k + k *
ab_dim1]), ABS(r__2))) * xk;
/* L70: */
}
/* L80: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__4 = k + j * x_dim1;
xk = (r__1 = x[i__4].r, ABS(r__1)) + (r__2 = r_imag(&
x[k + j * x_dim1]), ABS(r__2));
/* Computing MIN */
i__5 = *n, i__3 = k + *kd;
i__4 = MIN(i__5,i__3);
for (i__ = k + 1; i__ <= i__4; ++i__) {
i__5 = i__ + 1 - k + k * ab_dim1;
rwork[i__] += ((r__1 = ab[i__5].r, ABS(r__1)) + (
r__2 = r_imag(&ab[i__ + 1 - k + k *
ab_dim1]), ABS(r__2))) * xk;
/* L90: */
}
rwork[k] += xk;
/* L100: */
}
}
}
} else {
/* Compute ABS(A**H)*ABS(X) + ABS(B). */
if (upper) {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
/* Computing MAX */
i__4 = 1, i__5 = k - *kd;
i__3 = k;
for (i__ = MAX(i__4,i__5); i__ <= i__3; ++i__) {
i__4 = *kd + 1 + i__ - k + k * ab_dim1;
i__5 = i__ + j * x_dim1;
s += ((r__1 = ab[i__4].r, ABS(r__1)) + (r__2 =
r_imag(&ab[*kd + 1 + i__ - k + k *
ab_dim1]), ABS(r__2))) * ((r__3 = x[i__5]
.r, ABS(r__3)) + (r__4 = r_imag(&x[i__ +
j * x_dim1]), ABS(r__4)));
/* L110: */
}
rwork[k] += s;
/* L120: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = k + j * x_dim1;
s = (r__1 = x[i__3].r, ABS(r__1)) + (r__2 = r_imag(&
x[k + j * x_dim1]), ABS(r__2));
/* Computing MAX */
i__3 = 1, i__4 = k - *kd;
i__5 = k - 1;
for (i__ = MAX(i__3,i__4); i__ <= i__5; ++i__) {
i__3 = *kd + 1 + i__ - k + k * ab_dim1;
i__4 = i__ + j * x_dim1;
s += ((r__1 = ab[i__3].r, ABS(r__1)) + (r__2 =
r_imag(&ab[*kd + 1 + i__ - k + k *
ab_dim1]), ABS(r__2))) * ((r__3 = x[i__4]
.r, ABS(r__3)) + (r__4 = r_imag(&x[i__ +
j * x_dim1]), ABS(r__4)));
/* L130: */
}
rwork[k] += s;
/* L140: */
}
}
} else {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
/* Computing MIN */
i__3 = *n, i__4 = k + *kd;
i__5 = MIN(i__3,i__4);
for (i__ = k; i__ <= i__5; ++i__) {
i__3 = i__ + 1 - k + k * ab_dim1;
i__4 = i__ + j * x_dim1;
s += ((r__1 = ab[i__3].r, ABS(r__1)) + (r__2 =
r_imag(&ab[i__ + 1 - k + k * ab_dim1]),
ABS(r__2))) * ((r__3 = x[i__4].r, ABS(
r__3)) + (r__4 = r_imag(&x[i__ + j *
x_dim1]), ABS(r__4)));
/* L150: */
}
rwork[k] += s;
/* L160: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__5 = k + j * x_dim1;
s = (r__1 = x[i__5].r, ABS(r__1)) + (r__2 = r_imag(&
x[k + j * x_dim1]), ABS(r__2));
/* Computing MIN */
i__3 = *n, i__4 = k + *kd;
i__5 = MIN(i__3,i__4);
for (i__ = k + 1; i__ <= i__5; ++i__) {
i__3 = i__ + 1 - k + k * ab_dim1;
i__4 = i__ + j * x_dim1;
s += ((r__1 = ab[i__3].r, ABS(r__1)) + (r__2 =
r_imag(&ab[i__ + 1 - k + k * ab_dim1]),
ABS(r__2))) * ((r__3 = x[i__4].r, ABS(
r__3)) + (r__4 = r_imag(&x[i__ + j *
x_dim1]), ABS(r__4)));
/* L170: */
}
rwork[k] += s;
/* L180: */
}
}
}
}
s = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
/* Computing MAX */
i__5 = i__;
r__3 = s, r__4 = ((r__1 = work[i__5].r, ABS(r__1)) + (r__2 =
r_imag(&work[i__]), ABS(r__2))) / rwork[i__];
s = MAX(r__3,r__4);
} else {
/* Computing MAX */
i__5 = i__;
r__3 = s, r__4 = ((r__1 = work[i__5].r, ABS(r__1)) + (r__2 =
r_imag(&work[i__]), ABS(r__2)) + safe1) / (rwork[i__]
+ safe1);
s = MAX(r__3,r__4);
}
/* L190: */
}
berr[j] = s;
/* Bound error from formula */
/* norm(X - XTRUE) / norm(X) .le. FERR = */
/* norm( ABS(inv(op(A)))* */
/* ( ABS(R) + NZ*EPS*( ABS(op(A))*ABS(X)+ABS(B) ))) / norm(X) */
/* where */
/* norm(Z) is the magnitude of the largest component of Z */
/* inv(op(A)) is the inverse of op(A) */
/* ABS(Z) is the componentwise absolute value of the matrix or */
/* vector Z */
/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
/* EPS is machine epsilon */
/* The i-th component of ABS(R)+NZ*EPS*(ABS(op(A))*ABS(X)+ABS(B)) */
/* is incremented by SAFE1 if the i-th component of */
/* ABS(op(A))*ABS(X) + ABS(B) is less than SAFE2. */
/* Use CLACN2 to estimate the infinity-norm of the matrix */
/* inv(op(A)) * diag(W), */
/* where W = ABS(R) + NZ*EPS*( ABS(op(A))*ABS(X)+ABS(B) ))) */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
i__5 = i__;
rwork[i__] = (r__1 = work[i__5].r, ABS(r__1)) + (r__2 =
r_imag(&work[i__]), ABS(r__2)) + nz * eps * rwork[
i__];
} else {
i__5 = i__;
rwork[i__] = (r__1 = work[i__5].r, ABS(r__1)) + (r__2 =
r_imag(&work[i__]), ABS(r__2)) + nz * eps * rwork[
i__] + safe1;
}
/* L200: */
}
kase = 0;
L210:
clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)**H). */
ctbsv_(uplo, transt, diag, n, kd, &ab[ab_offset], ldab, &work[
1], &c__1);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__5 = i__;
i__3 = i__;
i__4 = i__;
q__1.r = rwork[i__3] * work[i__4].r, q__1.i = rwork[i__3]
* work[i__4].i;
work[i__5].r = q__1.r, work[i__5].i = q__1.i;
/* L220: */
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__5 = i__;
i__3 = i__;
i__4 = i__;
q__1.r = rwork[i__3] * work[i__4].r, q__1.i = rwork[i__3]
* work[i__4].i;
work[i__5].r = q__1.r, work[i__5].i = q__1.i;
/* L230: */
}
ctbsv_(uplo, transn, diag, n, kd, &ab[ab_offset], ldab, &work[
1], &c__1);
}
goto L210;
}
/* Normalize error. */
lstres = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__5 = i__ + j * x_dim1;
r__3 = lstres, r__4 = (r__1 = x[i__5].r, ABS(r__1)) + (r__2 =
r_imag(&x[i__ + j * x_dim1]), ABS(r__2));
lstres = MAX(r__3,r__4);
/* L240: */
}
if (lstres != 0.f) {
ferr[j] /= lstres;
}
/* L250: */
}
return 0;
/* End of CTBRFS */
} /* ctbrfs_ */
/* Subroutine */ int chemm_(char *side, char *uplo, integer *m, integer *n,
complex *alpha, complex *a, integer *lda, complex *b, integer *ldb,
complex *beta, complex *c__, integer *ldc)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
i__3, i__4, i__5, i__6;
real r__1;
complex q__1, q__2, q__3, q__4, q__5;
/* Builtin functions */
void r_cnjg(complex *, complex *);
/* Local variables */
integer i__, j, k, info;
complex temp1, temp2;
extern logical lsame_(char *, char *);
integer nrowa;
logical upper;
extern /* Subroutine */ int xerbla_(char *, integer *);
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHEMM performs one of the matrix-matrix operations */
/* C := alpha*A*B + beta*C, */
/* or */
/* C := alpha*B*A + beta*C, */
/* where alpha and beta are scalars, A is an hermitian matrix and B and */
/* C are m by n matrices. */
/* Arguments */
/* ========== */
/* SIDE - CHARACTER*1. */
/* On entry, SIDE specifies whether the hermitian matrix A */
/* appears on the left or right in the operation as follows: */
/* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, */
/* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, */
/* Unchanged on exit. */
/* UPLO - CHARACTER*1. */
/* On entry, UPLO specifies whether the upper or lower */
/* triangular part of the hermitian matrix A is to be */
/* referenced as follows: */
/* UPLO = 'U' or 'u' Only the upper triangular part of the */
/* hermitian matrix is to be referenced. */
/* UPLO = 'L' or 'l' Only the lower triangular part of the */
/* hermitian matrix is to be referenced. */
/* Unchanged on exit. */
/* M - INTEGER. */
/* On entry, M specifies the number of rows of the matrix C. */
/* M must be at least zero. */
/* Unchanged on exit. */
/* N - INTEGER. */
/* On entry, N specifies the number of columns of the matrix C. */
/* N must be at least zero. */
/* Unchanged on exit. */
/* ALPHA - COMPLEX . */
/* On entry, ALPHA specifies the scalar alpha. */
/* Unchanged on exit. */
/* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is */
/* m when SIDE = 'L' or 'l' and is n otherwise. */
/* Before entry with SIDE = 'L' or 'l', the m by m part of */
/* the array A must contain the hermitian matrix, such that */
/* when UPLO = 'U' or 'u', the leading m by m upper triangular */
/* part of the array A must contain the upper triangular part */
/* of the hermitian matrix and the strictly lower triangular */
/* part of A is not referenced, and when UPLO = 'L' or 'l', */
/* the leading m by m lower triangular part of the array A */
/* must contain the lower triangular part of the hermitian */
/* matrix and the strictly upper triangular part of A is not */
/* referenced. */
/* Before entry with SIDE = 'R' or 'r', the n by n part of */
/* the array A must contain the hermitian matrix, such that */
/* when UPLO = 'U' or 'u', the leading n by n upper triangular */
/* part of the array A must contain the upper triangular part */
/* of the hermitian matrix and the strictly lower triangular */
/* part of A is not referenced, and when UPLO = 'L' or 'l', */
/* the leading n by n lower triangular part of the array A */
/* must contain the lower triangular part of the hermitian */
/* matrix and the strictly upper triangular part of A is not */
/* referenced. */
/* Note that the imaginary parts of the diagonal elements need */
/* not be set, they are assumed to be zero. */
/* Unchanged on exit. */
/* LDA - INTEGER. */
/* On entry, LDA specifies the first dimension of A as declared */
/* in the calling (sub) program. When SIDE = 'L' or 'l' then */
/* LDA must be at least max( 1, m ), otherwise LDA must be at */
/* least max( 1, n ). */
/* Unchanged on exit. */
/* B - COMPLEX array of DIMENSION ( LDB, n ). */
/* Before entry, the leading m by n part of the array B must */
/* contain the matrix B. */
/* Unchanged on exit. */
/* LDB - INTEGER. */
/* On entry, LDB specifies the first dimension of B as declared */
/* in the calling (sub) program. LDB must be at least */
/* max( 1, m ). */
/* Unchanged on exit. */
/* BETA - COMPLEX . */
/* On entry, BETA specifies the scalar beta. When BETA is */
/* supplied as zero then C need not be set on input. */
/* Unchanged on exit. */
/* C - COMPLEX array of DIMENSION ( LDC, n ). */
/* Before entry, the leading m by n part of the array C must */
/* contain the matrix C, except when beta is zero, in which */
/* case C need not be set on entry. */
/* On exit, the array C is overwritten by the m by n updated */
/* matrix. */
/* LDC - INTEGER. */
/* On entry, LDC specifies the first dimension of C as declared */
/* in the calling (sub) program. LDC must be at least */
/* max( 1, m ). */
/* Unchanged on exit. */
/* Level 3 Blas routine. */
/* -- Written on 8-February-1989. */
/* Jack Dongarra, Argonne National Laboratory. */
/* Iain Duff, AERE Harwell. */
/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
/* Sven Hammarling, Numerical Algorithms Group Ltd. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Parameters .. */
/* .. */
/* Set NROWA as the number of rows of A. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
/* Function Body */
if (lsame_(side, "L")) {
nrowa = *m;
} else {
nrowa = *n;
}
upper = lsame_(uplo, "U");
/* Test the input parameters. */
info = 0;
if (! lsame_(side, "L") && ! lsame_(side, "R")) {
info = 1;
} else if (! upper && ! lsame_(uplo, "L")) {
info = 2;
} else if (*m < 0) {
info = 3;
} else if (*n < 0) {
info = 4;
} else if (*lda < max(1,nrowa)) {
info = 7;
} else if (*ldb < max(1,*m)) {
info = 9;
} else if (*ldc < max(1,*m)) {
info = 12;
}
if (info != 0) {
xerbla_("CHEMM ", &info);
return 0;
}
/* Quick return if possible. */
if (*m == 0 || *n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r
== 1.f && beta->i == 0.f)) {
return 0;
}
/* And when alpha.eq.zero. */
if (alpha->r == 0.f && alpha->i == 0.f) {
if (beta->r == 0.f && beta->i == 0.f) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
c__[i__3].r = 0.f, c__[i__3].i = 0.f;
/* L10: */
}
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i,
q__1.i = beta->r * c__[i__4].i + beta->i * c__[
i__4].r;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
/* L30: */
}
/* L40: */
}
}
return 0;
}
/* Start the operations. */
if (lsame_(side, "L")) {
/* Form C := alpha*A*B + beta*C. */
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
q__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3]
.r;
temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f;
i__3 = i__ - 1;
for (k = 1; k <= i__3; ++k) {
i__4 = k + j * c_dim1;
i__5 = k + j * c_dim1;
i__6 = k + i__ * a_dim1;
q__2.r = temp1.r * a[i__6].r - temp1.i * a[i__6].i,
q__2.i = temp1.r * a[i__6].i + temp1.i * a[
i__6].r;
q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i +
q__2.i;
c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
i__4 = k + j * b_dim1;
r_cnjg(&q__3, &a[k + i__ * a_dim1]);
q__2.r = b[i__4].r * q__3.r - b[i__4].i * q__3.i,
q__2.i = b[i__4].r * q__3.i + b[i__4].i *
q__3.r;
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
temp2.r = q__1.r, temp2.i = q__1.i;
/* L50: */
}
if (beta->r == 0.f && beta->i == 0.f) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + i__ * a_dim1;
r__1 = a[i__4].r;
q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
q__3.r = alpha->r * temp2.r - alpha->i * temp2.i,
q__3.i = alpha->r * temp2.i + alpha->i *
temp2.r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
} else {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
.i, q__3.i = beta->r * c__[i__4].i + beta->i *
c__[i__4].r;
i__5 = i__ + i__ * a_dim1;
r__1 = a[i__5].r;
q__4.r = r__1 * temp1.r, q__4.i = r__1 * temp1.i;
q__2.r = q__3.r + q__4.r, q__2.i = q__3.i + q__4.i;
q__5.r = alpha->r * temp2.r - alpha->i * temp2.i,
q__5.i = alpha->r * temp2.i + alpha->i *
temp2.r;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
}
/* L60: */
}
/* L70: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
for (i__ = *m; i__ >= 1; --i__) {
i__2 = i__ + j * b_dim1;
q__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2].i,
q__1.i = alpha->r * b[i__2].i + alpha->i * b[i__2]
.r;
temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f;
i__2 = *m;
for (k = i__ + 1; k <= i__2; ++k) {
i__3 = k + j * c_dim1;
i__4 = k + j * c_dim1;
i__5 = k + i__ * a_dim1;
q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
q__2.i = temp1.r * a[i__5].i + temp1.i * a[
i__5].r;
q__1.r = c__[i__4].r + q__2.r, q__1.i = c__[i__4].i +
q__2.i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
i__3 = k + j * b_dim1;
r_cnjg(&q__3, &a[k + i__ * a_dim1]);
q__2.r = b[i__3].r * q__3.r - b[i__3].i * q__3.i,
q__2.i = b[i__3].r * q__3.i + b[i__3].i *
q__3.r;
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
temp2.r = q__1.r, temp2.i = q__1.i;
/* L80: */
}
if (beta->r == 0.f && beta->i == 0.f) {
i__2 = i__ + j * c_dim1;
i__3 = i__ + i__ * a_dim1;
r__1 = a[i__3].r;
q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
q__3.r = alpha->r * temp2.r - alpha->i * temp2.i,
q__3.i = alpha->r * temp2.i + alpha->i *
temp2.r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
} else {
i__2 = i__ + j * c_dim1;
i__3 = i__ + j * c_dim1;
q__3.r = beta->r * c__[i__3].r - beta->i * c__[i__3]
.i, q__3.i = beta->r * c__[i__3].i + beta->i *
c__[i__3].r;
i__4 = i__ + i__ * a_dim1;
r__1 = a[i__4].r;
q__4.r = r__1 * temp1.r, q__4.i = r__1 * temp1.i;
q__2.r = q__3.r + q__4.r, q__2.i = q__3.i + q__4.i;
q__5.r = alpha->r * temp2.r - alpha->i * temp2.i,
q__5.i = alpha->r * temp2.i + alpha->i *
temp2.r;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
}
/* L90: */
}
/* L100: */
}
}
} else {
/* Form C := alpha*B*A + beta*C. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j + j * a_dim1;
r__1 = a[i__2].r;
q__1.r = r__1 * alpha->r, q__1.i = r__1 * alpha->i;
temp1.r = q__1.r, temp1.i = q__1.i;
if (beta->r == 0.f && beta->i == 0.f) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * b_dim1;
q__1.r = temp1.r * b[i__4].r - temp1.i * b[i__4].i,
q__1.i = temp1.r * b[i__4].i + temp1.i * b[i__4]
.r;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
/* L110: */
}
} else {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
q__2.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i,
q__2.i = beta->r * c__[i__4].i + beta->i * c__[
i__4].r;
i__5 = i__ + j * b_dim1;
q__3.r = temp1.r * b[i__5].r - temp1.i * b[i__5].i,
q__3.i = temp1.r * b[i__5].i + temp1.i * b[i__5]
.r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
/* L120: */
}
}
i__2 = j - 1;
for (k = 1; k <= i__2; ++k) {
if (upper) {
i__3 = k + j * a_dim1;
q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
q__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3]
.r;
temp1.r = q__1.r, temp1.i = q__1.i;
} else {
r_cnjg(&q__2, &a[j + k * a_dim1]);
q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
alpha->r * q__2.i + alpha->i * q__2.r;
temp1.r = q__1.r, temp1.i = q__1.i;
}
i__3 = *m;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * c_dim1;
i__5 = i__ + j * c_dim1;
i__6 = i__ + k * b_dim1;
q__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i,
q__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6]
.r;
q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i +
q__2.i;
c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
/* L130: */
}
/* L140: */
}
i__2 = *n;
for (k = j + 1; k <= i__2; ++k) {
if (upper) {
r_cnjg(&q__2, &a[j + k * a_dim1]);
q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
alpha->r * q__2.i + alpha->i * q__2.r;
temp1.r = q__1.r, temp1.i = q__1.i;
} else {
i__3 = k + j * a_dim1;
q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
q__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3]
.r;
temp1.r = q__1.r, temp1.i = q__1.i;
}
i__3 = *m;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * c_dim1;
i__5 = i__ + j * c_dim1;
i__6 = i__ + k * b_dim1;
q__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i,
q__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6]
.r;
q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i +
q__2.i;
c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
/* L150: */
}
/* L160: */
}
/* L170: */
}
}
return 0;
/* End of CHEMM . */
} /* chemm_ */
/* Subroutine */ int dsyevd_(char *jobz, char *uplo, integer *n, doublereal *
a, integer *lda, doublereal *w, doublereal *work, integer *lwork,
integer *iwork, integer *liwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
/* Local variables */
doublereal eps;
integer inde;
doublereal anrm, rmin, rmax;
integer lopt;
doublereal sigma;
integer iinfo, lwmin, liopt;
logical lower, wantz;
integer indwk2, llwrk2;
integer iscale;
doublereal safmin;
doublereal bignum;
integer indtau;
integer indwrk, liwmin;
integer llwork;
doublereal smlnum;
logical lquery;
/* -- LAPACK driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DSYEVD computes all eigenvalues and, optionally, eigenvectors of a */
/* real symmetric matrix A. If eigenvectors are desired, it uses a */
/* divide and conquer algorithm. */
/* The divide and conquer algorithm makes very mild assumptions about */
/* floating point arithmetic. It will work on machines with a guard */
/* digit in add/subtract, or on those binary machines without guard */
/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
/* without guard digits, but we know of none. */
/* Because of large use of BLAS of level 3, DSYEVD needs N**2 more */
/* workspace than DSYEVX. */
/* 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. */
/* A (input/output) DOUBLE PRECISION 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, if JOBZ = 'V', then if INFO = 0, A contains the */
/* orthonormal eigenvectors of the matrix A. */
/* If JOBZ = 'N', then 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). */
/* W (output) DOUBLE PRECISION array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* WORK (workspace/output) DOUBLE PRECISION array, */
/* dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* If N <= 1, LWORK must be at least 1. */
/* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1. */
/* If JOBZ = 'V' and N > 1, LWORK must be at least */
/* 1 + 6*N + 2*N**2. */
/* 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 LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. */
/* If N <= 1, LIWORK must be at least 1. */
/* If JOBZ = 'N' and N > 1, LIWORK must be at least 1. */
/* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. */
/* If LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal 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: if INFO = i and JOBZ = 'N', then the algorithm failed */
/* to converge; i off-diagonal elements of an intermediate */
/* tridiagonal form did not converge to zero; */
/* if INFO = i and JOBZ = 'V', then the algorithm failed */
/* to compute an eigenvalue while working on the submatrix */
/* lying in rows and columns INFO/(N+1) through */
/* mod(INFO,N+1). */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Jeff Rutter, Computer Science Division, University of California */
/* at Berkeley, USA */
/* Modified by Francoise Tisseur, University of Tennessee. */
/* Modified description of INFO. Sven, 16 Feb 05. */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
--work;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V");
lower = lsame_(uplo, "L");
lquery = *lwork == -1 || *liwork == -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) {
if (*n <= 1) {
liwmin = 1;
lwmin = 1;
lopt = lwmin;
liopt = liwmin;
} else {
if (wantz) {
liwmin = *n * 5 + 3;
/* Computing 2nd power */
i__1 = *n;
lwmin = *n * 6 + 1 + (i__1 * i__1 << 1);
} else {
liwmin = 1;
lwmin = (*n << 1) + 1;
}
/* Computing MAX */
i__1 = lwmin, i__2 = (*n << 1) + ilaenv_(&c__1, "DSYTRD", uplo, n,
&c_n1, &c_n1, &c_n1);
lopt = max(i__1,i__2);
liopt = liwmin;
}
work[1] = (doublereal) lopt;
iwork[1] = liopt;
if (*lwork < lwmin && ! lquery) {
*info = -8;
} else if (*liwork < liwmin && ! lquery) {
*info = -10;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYEVD", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
w[1] = a[a_dim1 + 1];
if (wantz) {
a[a_dim1 + 1] = 1.;
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
rmax = sqrt(bignum);
/* Scale matrix to allowable range, if necessary. */
anrm = dlansy_("M", uplo, n, &a[a_offset], lda, &work[1]);
iscale = 0;
if (anrm > 0. && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
dlascl_(uplo, &c__0, &c__0, &c_b17, &sigma, n, n, &a[a_offset], lda,
info);
}
/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */
inde = 1;
indtau = inde + *n;
indwrk = indtau + *n;
llwork = *lwork - indwrk + 1;
indwk2 = indwrk + *n * *n;
llwrk2 = *lwork - indwk2 + 1;
dsytrd_(uplo, n, &a[a_offset], lda, &w[1], &work[inde], &work[indtau], &
work[indwrk], &llwork, &iinfo);
lopt = (integer) ((*n << 1) + work[indwrk]);
/* For eigenvalues only, call DSTERF. For eigenvectors, first call */
/* DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the */
/* tridiagonal matrix, then call DORMTR to multiply it by the */
/* Householder transformations stored in A. */
if (! wantz) {
dsterf_(n, &w[1], &work[inde], info);
} else {
dstedc_("I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], &
llwrk2, &iwork[1], liwork, info);
dormtr_("L", uplo, "N", n, n, &a[a_offset], lda, &work[indtau], &work[
indwrk], n, &work[indwk2], &llwrk2, &iinfo);
dlacpy_("A", n, n, &work[indwrk], n, &a[a_offset], lda);
/* Computing MAX */
/* Computing 2nd power */
i__3 = *n;
i__1 = lopt, i__2 = *n * 6 + 1 + (i__3 * i__3 << 1);
lopt = max(i__1,i__2);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (iscale == 1) {
d__1 = 1. / sigma;
dscal_(n, &d__1, &w[1], &c__1);
}
work[1] = (doublereal) lopt;
iwork[1] = liopt;
return 0;
/* End of DSYEVD */
} /* dsyevd_ */
/* Subroutine */ int cposvxx_(char *fact, char *uplo, integer *n, integer *
nrhs, complex *a, integer *lda, complex *af, integer *ldaf, char *
equed, real *s, complex *b, integer *ldb, complex *x, integer *ldx,
real *rcond, real *rpvgrw, real *berr, integer *n_err_bnds__, real *
err_bnds_norm__, real *err_bnds_comp__, integer *nparams, real *
params, complex *work, real *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
real r__1, r__2;
/* Local variables */
integer j;
real amax, smin, smax;
real scond;
logical equil, rcequ;
logical nofact;
real bignum;
integer infequ;
real smlnum;
/* -- LAPACK driver routine (version 3.2.1) -- */
/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/* -- Jason Riedy of Univ. of California Berkeley. -- */
/* -- April 2009 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley and NAG Ltd. -- */
/* Purpose */
/* ======= */
/* CPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T */
/* to compute the solution to a complex system of linear equations */
/* A * X = B, where A is an N-by-N symmetric positive definite matrix */
/* and X and B are N-by-NRHS matrices. */
/* If requested, both normwise and maximum componentwise error bounds */
/* are returned. CPOSVXX will return a solution with a tiny */
/* guaranteed error (O(eps) where eps is the working machine */
/* precision) unless the matrix is very ill-conditioned, in which */
/* case a warning is returned. Relevant condition numbers also are */
/* calculated and returned. */
/* CPOSVXX accepts user-provided factorizations and equilibration */
/* factors; see the definitions of the FACT and EQUED options. */
/* Solving with refinement and using a factorization from a previous */
/* CPOSVXX call will also produce a solution with either O(eps) */
/* errors or warnings, but we cannot make that claim for general */
/* user-provided factorizations and equilibration factors if they */
/* differ from what CPOSVXX would itself produce. */
/* Description */
/* =========== */
/* The following steps are performed: */
/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
/* the system: */
/* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B */
/* Whether or not the system will be equilibrated depends on the */
/* scaling of the matrix A, but if equilibration is used, A is */
/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */
/* factor the matrix A (after equilibration if FACT = 'E') as */
/* A = U**T* U, if UPLO = 'U', or */
/* A = L * L**T, if UPLO = 'L', */
/* where U is an upper triangular matrix and L is a lower triangular */
/* matrix. */
/* 3. If the leading i-by-i principal minor is not positive definite, */
/* then the routine returns with INFO = i. Otherwise, the factored */
/* form of A is used to estimate the condition number of the matrix */
/* A (see argument RCOND). If the reciprocal of the condition number */
/* is less than machine precision, the routine still goes on to solve */
/* for X and compute error bounds as described below. */
/* 4. The system of equations is solved for X using the factored form */
/* of A. */
/* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */
/* the routine will use iterative refinement to try to get a small */
/* error and error bounds. Refinement calculates the residual to at */
/* least twice the working precision. */
/* 6. If equilibration was used, the matrix X is premultiplied by */
/* diag(S) so that it solves the original system before */
/* equilibration. */
/* Arguments */
/* ========= */
/* Some optional parameters are bundled in the PARAMS array. These */
/* settings determine how refinement is performed, but often the */
/* defaults are acceptable. If the defaults are acceptable, users */
/* can pass NPARAMS = 0 which prevents the source code from accessing */
/* the PARAMS argument. */
/* FACT (input) CHARACTER*1 */
/* Specifies whether or not the factored form of the matrix A is */
/* supplied on entry, and if not, whether the matrix A should be */
/* equilibrated before it is factored. */
/* = 'F': On entry, AF contains the factored form of A. */
/* If EQUED is not 'N', the matrix A has been */
/* equilibrated with scaling factors given by S. */
/* A and AF are not modified. */
/* = 'N': The matrix A will be copied to AF and factored. */
/* = 'E': The matrix A will be equilibrated if necessary, then */
/* copied to AF and factored. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the symmetric matrix A, except if FACT = 'F' and EQUED = */
/* 'Y', then A must contain the equilibrated matrix */
/* diag(S)*A*diag(S). 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. A is */
/* not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED = */
/* 'N' on exit. */
/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
/* diag(S)*A*diag(S). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* AF (input or output) COMPLEX array, dimension (LDAF,N) */
/* If FACT = 'F', then AF is an input argument and on entry */
/* contains the triangular factor U or L from the Cholesky */
/* factorization A = U**T*U or A = L*L**T, in the same storage */
/* format as A. If EQUED .ne. 'N', then AF is the factored */
/* form of the equilibrated matrix diag(S)*A*diag(S). */
/* If FACT = 'N', then AF is an output argument and on exit */
/* returns the triangular factor U or L from the Cholesky */
/* factorization A = U**T*U or A = L*L**T of the original */
/* matrix A. */
/* If FACT = 'E', then AF is an output argument and on exit */
/* returns the triangular factor U or L from the Cholesky */
/* factorization A = U**T*U or A = L*L**T of the equilibrated */
/* matrix A (see the description of A for the form of the */
/* equilibrated matrix). */
/* LDAF (input) INTEGER */
/* The leading dimension of the array AF. LDAF >= max(1,N). */
/* EQUED (input or output) CHARACTER*1 */
/* Specifies the form of equilibration that was done. */
/* = 'N': No equilibration (always true if FACT = 'N'). */
/* = 'Y': Both row and column equilibration, i.e., A has been */
/* replaced by diag(S) * A * diag(S). */
/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
/* output argument. */
/* S (input or output) REAL array, dimension (N) */
/* The row scale factors for A. If EQUED = 'Y', A is multiplied on */
/* the left and right by diag(S). S is an input argument if FACT = */
/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */
/* = 'Y', each element of S must be positive. If S is output, each */
/* element of S is a power of the radix. If S is input, each element */
/* of S should be a power of the radix to ensure a reliable solution */
/* and error estimates. Scaling by powers of the radix does not cause */
/* rounding errors unless the result underflows or overflows. */
/* Rounding errors during scaling lead to refining with a matrix that */
/* is not equivalent to the input matrix, producing error estimates */
/* that may not be reliable. */
/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
/* On entry, the N-by-NRHS right hand side matrix B. */
/* On exit, */
/* if EQUED = 'N', B is not modified; */
/* if EQUED = 'Y', B is overwritten by diag(S)*B; */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (output) COMPLEX array, dimension (LDX,NRHS) */
/* If INFO = 0, the N-by-NRHS solution matrix X to the original */
/* system of equations. Note that A and B are modified on exit if */
/* EQUED .ne. 'N', and the solution to the equilibrated system is */
/* inv(diag(S))*X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* RCOND (output) REAL */
/* Reciprocal scaled condition number. This is an estimate of the */
/* reciprocal Skeel condition number of the matrix A after */
/* equilibration (if done). If this is less than the machine */
/* precision (in particular, if it is zero), the matrix is singular */
/* to working precision. Note that the error may still be small even */
/* if this number is very small and the matrix appears ill- */
/* conditioned. */
/* RPVGRW (output) REAL */
/* Reciprocal pivot growth. On exit, this contains the reciprocal */
/* pivot growth factor norm(A)/norm(U). The "max absolute element" */
/* norm is used. If this is much less than 1, then the stability of */
/* the LU factorization of the (equilibrated) matrix A could be poor. */
/* This also means that the solution X, estimated condition numbers, */
/* and error bounds could be unreliable. If factorization fails with */
/* 0<INFO<=N, then this contains the reciprocal pivot growth factor */
/* for the leading INFO columns of A. */
/* BERR (output) REAL array, dimension (NRHS) */
/* Componentwise relative backward error. This is the */
/* componentwise relative backward error of each solution vector X(j) */
/* (i.e., the smallest relative change in any element of A or B that */
/* makes X(j) an exact solution). */
/* N_ERR_BNDS (input) INTEGER */
/* Number of error bounds to return for each right hand side */
/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
/* ERR_BNDS_COMP below. */
/* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
/* For each right-hand side, this array contains information about */
/* various error bounds and condition numbers corresponding to the */
/* normwise relative error, which is defined as follows: */
/* Normwise relative error in the ith solution vector: */
/* max_j (abs(XTRUE(j,i) - X(j,i))) */
/* ------------------------------ */
/* max_j abs(X(j,i)) */
/* The array is indexed by the type of error information as described */
/* below. There currently are up to three pieces of information */
/* returned. */
/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
/* right-hand side. */
/* The second index in ERR_BNDS_NORM(:,err) contains the following */
/* three fields: */
/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
/* reciprocal condition number is less than the threshold */
/* sqrt(n) * slamch('Epsilon'). */
/* err = 2 "Guaranteed" error bound: The estimated forward error, */
/* almost certainly within a factor of 10 of the true error */
/* so long as the next entry is greater than the threshold */
/* sqrt(n) * slamch('Epsilon'). This error bound should only */
/* be trusted if the previous boolean is true. */
/* err = 3 Reciprocal condition number: Estimated normwise */
/* reciprocal condition number. Compared with the threshold */
/* sqrt(n) * slamch('Epsilon') to determine if the error */
/* estimate is "guaranteed". These reciprocal condition */
/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
/* appropriately scaled matrix Z. */
/* Let Z = S*A, where S scales each row by a power of the */
/* radix so all absolute row sums of Z are approximately 1. */
/* See Lapack Working Note 165 for further details and extra */
/* cautions. */
/* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
/* For each right-hand side, this array contains information about */
/* various error bounds and condition numbers corresponding to the */
/* componentwise relative error, which is defined as follows: */
/* Componentwise relative error in the ith solution vector: */
/* abs(XTRUE(j,i) - X(j,i)) */
/* max_j ---------------------- */
/* abs(X(j,i)) */
/* The array is indexed by the right-hand side i (on which the */
/* componentwise relative error depends), and the type of error */
/* information as described below. There currently are up to three */
/* pieces of information returned for each right-hand side. If */
/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
/* the first (:,N_ERR_BNDS) entries are returned. */
/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
/* right-hand side. */
/* The second index in ERR_BNDS_COMP(:,err) contains the following */
/* three fields: */
/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
/* reciprocal condition number is less than the threshold */
/* sqrt(n) * slamch('Epsilon'). */
/* err = 2 "Guaranteed" error bound: The estimated forward error, */
/* almost certainly within a factor of 10 of the true error */
/* so long as the next entry is greater than the threshold */
/* sqrt(n) * slamch('Epsilon'). This error bound should only */
/* be trusted if the previous boolean is true. */
/* err = 3 Reciprocal condition number: Estimated componentwise */
/* reciprocal condition number. Compared with the threshold */
/* sqrt(n) * slamch('Epsilon') to determine if the error */
/* estimate is "guaranteed". These reciprocal condition */
/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
/* appropriately scaled matrix Z. */
/* Let Z = S*(A*diag(x)), where x is the solution for the */
/* current right-hand side and S scales each row of */
/* A*diag(x) by a power of the radix so all absolute row */
/* sums of Z are approximately 1. */
/* See Lapack Working Note 165 for further details and extra */
/* cautions. */
/* NPARAMS (input) INTEGER */
/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
/* PARAMS array is never referenced and default values are used. */
/* PARAMS (input / output) REAL array, dimension NPARAMS */
/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
/* that entry will be filled with default value used for that */
/* parameter. Only positions up to NPARAMS are accessed; defaults */
/* are used for higher-numbered parameters. */
/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
/* refinement or not. */
/* Default: 1.0 */
/* = 0.0 : No refinement is performed, and no error bounds are */
/* computed. */
/* = 1.0 : Use the double-precision refinement algorithm, */
/* possibly with doubled-single computations if the */
/* compilation environment does not support DOUBLE */
/* PRECISION. */
/* (other values are reserved for future use) */
/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
/* computations allowed for refinement. */
/* Default: 10 */
/* Aggressive: Set to 100 to permit convergence using approximate */
/* factorizations or factorizations other than LU. If */
/* the factorization uses a technique other than */
/* Gaussian elimination, the guarantees in */
/* err_bnds_norm and err_bnds_comp may no longer be */
/* trustworthy. */
/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
/* will attempt to find a solution with small componentwise */
/* relative error in the double-precision algorithm. Positive */
/* is true, 0.0 is false. */
/* Default: 1.0 (attempt componentwise convergence) */
/* WORK (workspace) COMPLEX array, dimension (2*N) */
/* RWORK (workspace) REAL array, dimension (2*N) */
/* INFO (output) INTEGER */
/* = 0: Successful exit. The solution to every right-hand side is */
/* guaranteed. */
/* < 0: If INFO = -i, the i-th argument had an illegal value */
/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
/* has been completed, but the factor U is exactly singular, so */
/* the solution and error bounds could not be computed. RCOND = 0 */
/* is returned. */
/* = N+J: The solution corresponding to the Jth right-hand side is */
/* not guaranteed. The solutions corresponding to other right- */
/* hand sides K with K > J may not be guaranteed as well, but */
/* only the first such right-hand side is reported. If a small */
/* componentwise error is not requested (PARAMS(3) = 0.0) then */
/* the Jth right-hand side is the first with a normwise error */
/* bound that is not guaranteed (the smallest J such */
/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
/* the Jth right-hand side is the first with either a normwise or */
/* componentwise error bound that is not guaranteed (the smallest */
/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
/* about all of the right-hand sides check ERR_BNDS_NORM or */
/* ERR_BNDS_COMP. */
/* ================================================================== */
/* Parameter adjustments */
err_bnds_comp_dim1 = *nrhs;
err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
err_bnds_comp__ -= err_bnds_comp_offset;
err_bnds_norm_dim1 = *nrhs;
err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
err_bnds_norm__ -= err_bnds_norm_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--s;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--berr;
--params;
--work;
--rwork;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
if (nofact || equil) {
*(unsigned char *)equed = 'N';
rcequ = FALSE_;
} else {
rcequ = lsame_(equed, "Y");
}
/* Default is failure. If an input parameter is wrong or */
/* factorization fails, make everything look horrible. Only the */
/* pivot growth is set here, the rest is initialized in CPORFSX. */
*rpvgrw = 0.f;
/* Test the input parameters. PARAMS is not tested until CPORFSX. */
if (! nofact && ! equil && ! lsame_(fact, "F")) {
*info = -1;
} else if (! lsame_(uplo, "U") && ! lsame_(uplo,
"L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldaf < max(1,*n)) {
*info = -8;
} else if (lsame_(fact, "F") && ! (rcequ || lsame_(
equed, "N"))) {
*info = -9;
} else {
if (rcequ) {
smin = bignum;
smax = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
r__1 = smin, r__2 = s[j];
smin = dmin(r__1,r__2);
/* Computing MAX */
r__1 = smax, r__2 = s[j];
smax = dmax(r__1,r__2);
}
if (smin <= 0.f) {
*info = -10;
} else if (*n > 0) {
scond = dmax(smin,smlnum) / dmin(smax,bignum);
} else {
scond = 1.f;
}
}
if (*info == 0) {
if (*ldb < max(1,*n)) {
*info = -12;
} else if (*ldx < max(1,*n)) {
*info = -14;
}
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CPOSVXX", &i__1);
return 0;
}
if (equil) {
/* Compute row and column scalings to equilibrate the matrix A. */
cpoequb_(n, &a[a_offset], lda, &s[1], &scond, &amax, &infequ);
if (infequ == 0) {
/* Equilibrate the matrix. */
claqhe_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed);
rcequ = lsame_(equed, "Y");
}
}
/* Scale the right-hand side. */
if (rcequ) {
clascl2_(n, nrhs, &s[1], &b[b_offset], ldb);
}
if (nofact || equil) {
/* Compute the LU factorization of A. */
clacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
cpotrf_(uplo, n, &af[af_offset], ldaf, info);
/* Return if INFO is non-zero. */
if (*info > 0) {
/* Pivot in column INFO is exactly 0 */
/* Compute the reciprocal pivot growth factor of the */
/* leading rank-deficient INFO columns of A. */
*rpvgrw = cla_porpvgrw__(uplo, n, &a[a_offset], lda, &af[
af_offset], ldaf, &rwork[1], (ftnlen)1);
return 0;
}
}
/* Compute the reciprocal pivot growth factor RPVGRW. */
*rpvgrw = cla_porpvgrw__(uplo, n, &a[a_offset], lda, &af[af_offset], ldaf,
&rwork[1], (ftnlen)1);
/* Compute the solution matrix X. */
clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
cpotrs_(uplo, n, nrhs, &af[af_offset], ldaf, &x[x_offset], ldx, info);
/* Use iterative refinement to improve the computed solution and */
/* compute error bounds and backward error estimates for it. */
cporfsx_(uplo, equed, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &
s[1], &b[b_offset], ldb, &x[x_offset], ldx, rcond, &berr[1],
n_err_bnds__, &err_bnds_norm__[err_bnds_norm_offset], &
err_bnds_comp__[err_bnds_comp_offset], nparams, ¶ms[1], &work[
1], &rwork[1], info);
/* Scale solutions. */
if (rcequ) {
clascl2_(n, nrhs, &s[1], &x[x_offset], ldx);
}
return 0;
/* End of CPOSVXX */
} /* cposvxx_ */
/* Subroutine */ int zgemm_(char *transa, char *transb, integer *m, integer *
n, integer *k, doublecomplex *alpha, doublecomplex *a, integer *lda,
doublecomplex *b, integer *ldb, doublecomplex *beta, doublecomplex *
c__, integer *ldc)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
i__3, i__4, i__5, i__6;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j, l, info;
logical nota, notb;
doublecomplex temp;
logical conja, conjb;
integer ncola;
extern logical lsame_(char *, char *);
integer nrowa, nrowb;
extern /* Subroutine */ int xerbla_(char *, integer *);
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGEMM performs one of the matrix-matrix operations */
/* C := alpha*op( A )*op( B ) + beta*C, */
/* where op( X ) is one of */
/* op( X ) = X or op( X ) = X' or op( X ) = conjg( X' ), */
/* alpha and beta are scalars, and A, B and C are matrices, with op( A ) */
/* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. */
/* Arguments */
/* ========== */
/* TRANSA - CHARACTER*1. */
/* On entry, TRANSA specifies the form of op( A ) to be used in */
/* the matrix multiplication as follows: */
/* TRANSA = 'N' or 'n', op( A ) = A. */
/* TRANSA = 'T' or 't', op( A ) = A'. */
/* TRANSA = 'C' or 'c', op( A ) = conjg( A' ). */
/* Unchanged on exit. */
/* TRANSB - CHARACTER*1. */
/* On entry, TRANSB specifies the form of op( B ) to be used in */
/* the matrix multiplication as follows: */
/* TRANSB = 'N' or 'n', op( B ) = B. */
/* TRANSB = 'T' or 't', op( B ) = B'. */
/* TRANSB = 'C' or 'c', op( B ) = conjg( B' ). */
/* Unchanged on exit. */
/* M - INTEGER. */
/* On entry, M specifies the number of rows of the matrix */
/* op( A ) and of the matrix C. M must be at least zero. */
/* Unchanged on exit. */
/* N - INTEGER. */
/* On entry, N specifies the number of columns of the matrix */
/* op( B ) and the number of columns of the matrix C. N must be */
/* at least zero. */
/* Unchanged on exit. */
/* K - INTEGER. */
/* On entry, K specifies the number of columns of the matrix */
/* op( A ) and the number of rows of the matrix op( B ). K must */
/* be at least zero. */
/* Unchanged on exit. */
/* ALPHA - COMPLEX*16 . */
/* On entry, ALPHA specifies the scalar alpha. */
/* Unchanged on exit. */
/* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is */
/* k when TRANSA = 'N' or 'n', and is m otherwise. */
/* Before entry with TRANSA = 'N' or 'n', the leading m by k */
/* part of the array A must contain the matrix A, otherwise */
/* the leading k by m part of the array A must contain the */
/* matrix A. */
/* Unchanged on exit. */
/* LDA - INTEGER. */
/* On entry, LDA specifies the first dimension of A as declared */
/* in the calling (sub) program. When TRANSA = 'N' or 'n' then */
/* LDA must be at least max( 1, m ), otherwise LDA must be at */
/* least max( 1, k ). */
/* Unchanged on exit. */
/* B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is */
/* n when TRANSB = 'N' or 'n', and is k otherwise. */
/* Before entry with TRANSB = 'N' or 'n', the leading k by n */
/* part of the array B must contain the matrix B, otherwise */
/* the leading n by k part of the array B must contain the */
/* matrix B. */
/* Unchanged on exit. */
/* LDB - INTEGER. */
/* On entry, LDB specifies the first dimension of B as declared */
/* in the calling (sub) program. When TRANSB = 'N' or 'n' then */
/* LDB must be at least max( 1, k ), otherwise LDB must be at */
/* least max( 1, n ). */
/* Unchanged on exit. */
/* BETA - COMPLEX*16 . */
/* On entry, BETA specifies the scalar beta. When BETA is */
/* supplied as zero then C need not be set on input. */
/* Unchanged on exit. */
/* C - COMPLEX*16 array of DIMENSION ( LDC, n ). */
/* Before entry, the leading m by n part of the array C must */
/* contain the matrix C, except when beta is zero, in which */
/* case C need not be set on entry. */
/* On exit, the array C is overwritten by the m by n matrix */
/* ( alpha*op( A )*op( B ) + beta*C ). */
/* LDC - INTEGER. */
/* On entry, LDC specifies the first dimension of C as declared */
/* in the calling (sub) program. LDC must be at least */
/* max( 1, m ). */
/* Unchanged on exit. */
/* Level 3 Blas routine. */
/* -- Written on 8-February-1989. */
/* Jack Dongarra, Argonne National Laboratory. */
/* Iain Duff, AERE Harwell. */
/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
/* Sven Hammarling, Numerical Algorithms Group Ltd. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Parameters .. */
/* .. */
/* Set NOTA and NOTB as true if A and B respectively are not */
/* conjugated or transposed, set CONJA and CONJB as true if A and */
/* B respectively are to be transposed but not conjugated and set */
/* NROWA, NCOLA and NROWB as the number of rows and columns of A */
/* and the number of rows of B respectively. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
/* Function Body */
nota = lsame_(transa, "N");
notb = lsame_(transb, "N");
conja = lsame_(transa, "C");
conjb = lsame_(transb, "C");
if (nota) {
nrowa = *m;
ncola = *k;
} else {
nrowa = *k;
ncola = *m;
}
if (notb) {
nrowb = *k;
} else {
nrowb = *n;
}
/* Test the input parameters. */
info = 0;
if (! nota && ! conja && ! lsame_(transa, "T")) {
info = 1;
} else if (! notb && ! conjb && ! lsame_(transb, "T")) {
info = 2;
} else if (*m < 0) {
info = 3;
} else if (*n < 0) {
info = 4;
} else if (*k < 0) {
info = 5;
} else if (*lda < max(1,nrowa)) {
info = 8;
} else if (*ldb < max(1,nrowb)) {
info = 10;
} else if (*ldc < max(1,*m)) {
info = 13;
}
if (info != 0) {
xerbla_("ZGEMM ", &info);
return 0;
}
/* Quick return if possible. */
if (*m == 0 || *n == 0 || (alpha->r == 0. && alpha->i == 0. || *k == 0) &&
(beta->r == 1. && beta->i == 0.)) {
return 0;
}
/* And when alpha.eq.zero. */
if (alpha->r == 0. && alpha->i == 0.) {
if (beta->r == 0. && beta->i == 0.) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
c__[i__3].r = 0., c__[i__3].i = 0.;
/* L10: */
}
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i,
z__1.i = beta->r * c__[i__4].i + beta->i * c__[
i__4].r;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L30: */
}
/* L40: */
}
}
return 0;
}
/* Start the operations. */
if (notb) {
if (nota) {
/* Form C := alpha*A*B + beta*C. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (beta->r == 0. && beta->i == 0.) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
c__[i__3].r = 0., c__[i__3].i = 0.;
/* L50: */
}
} else if (beta->r != 1. || beta->i != 0.) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
.i, z__1.i = beta->r * c__[i__4].i + beta->i *
c__[i__4].r;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L60: */
}
}
i__2 = *k;
for (l = 1; l <= i__2; ++l) {
i__3 = l + j * b_dim1;
if (b[i__3].r != 0. || b[i__3].i != 0.) {
i__3 = l + j * b_dim1;
z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
z__1.i = alpha->r * b[i__3].i + alpha->i * b[
i__3].r;
temp.r = z__1.r, temp.i = z__1.i;
i__3 = *m;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * c_dim1;
i__5 = i__ + j * c_dim1;
i__6 = i__ + l * a_dim1;
z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
z__2.i = temp.r * a[i__6].i + temp.i * a[
i__6].r;
z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5]
.i + z__2.i;
c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
/* L70: */
}
}
/* L80: */
}
/* L90: */
}
} else if (conja) {
/* Form C := alpha*conjg( A' )*B + beta*C. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
temp.r = 0., temp.i = 0.;
i__3 = *k;
for (l = 1; l <= i__3; ++l) {
d_cnjg(&z__3, &a[l + i__ * a_dim1]);
i__4 = l + j * b_dim1;
z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i,
z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4]
.r;
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
/* L100: */
}
if (beta->r == 0. && beta->i == 0.) {
i__3 = i__ + j * c_dim1;
z__1.r = alpha->r * temp.r - alpha->i * temp.i,
z__1.i = alpha->r * temp.i + alpha->i *
temp.r;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
} else {
i__3 = i__ + j * c_dim1;
z__2.r = alpha->r * temp.r - alpha->i * temp.i,
z__2.i = alpha->r * temp.i + alpha->i *
temp.r;
i__4 = i__ + j * c_dim1;
z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
.i, z__3.i = beta->r * c__[i__4].i + beta->i *
c__[i__4].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
}
/* L110: */
}
/* L120: */
}
} else {
/* Form C := alpha*A'*B + beta*C */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
temp.r = 0., temp.i = 0.;
i__3 = *k;
for (l = 1; l <= i__3; ++l) {
i__4 = l + i__ * a_dim1;
i__5 = l + j * b_dim1;
z__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5]
.i, z__2.i = a[i__4].r * b[i__5].i + a[i__4]
.i * b[i__5].r;
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
/* L130: */
}
if (beta->r == 0. && beta->i == 0.) {
i__3 = i__ + j * c_dim1;
z__1.r = alpha->r * temp.r - alpha->i * temp.i,
z__1.i = alpha->r * temp.i + alpha->i *
temp.r;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
} else {
i__3 = i__ + j * c_dim1;
z__2.r = alpha->r * temp.r - alpha->i * temp.i,
z__2.i = alpha->r * temp.i + alpha->i *
temp.r;
i__4 = i__ + j * c_dim1;
z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
.i, z__3.i = beta->r * c__[i__4].i + beta->i *
c__[i__4].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
}
/* L140: */
}
/* L150: */
}
}
} else if (nota) {
if (conjb) {
/* Form C := alpha*A*conjg( B' ) + beta*C. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (beta->r == 0. && beta->i == 0.) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
c__[i__3].r = 0., c__[i__3].i = 0.;
/* L160: */
}
} else if (beta->r != 1. || beta->i != 0.) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
.i, z__1.i = beta->r * c__[i__4].i + beta->i *
c__[i__4].r;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L170: */
}
}
i__2 = *k;
for (l = 1; l <= i__2; ++l) {
i__3 = j + l * b_dim1;
if (b[i__3].r != 0. || b[i__3].i != 0.) {
d_cnjg(&z__2, &b[j + l * b_dim1]);
z__1.r = alpha->r * z__2.r - alpha->i * z__2.i,
z__1.i = alpha->r * z__2.i + alpha->i *
z__2.r;
temp.r = z__1.r, temp.i = z__1.i;
i__3 = *m;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * c_dim1;
i__5 = i__ + j * c_dim1;
i__6 = i__ + l * a_dim1;
z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
z__2.i = temp.r * a[i__6].i + temp.i * a[
i__6].r;
z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5]
.i + z__2.i;
c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
/* L180: */
}
}
/* L190: */
}
/* L200: */
}
} else {
/* Form C := alpha*A*B' + beta*C */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (beta->r == 0. && beta->i == 0.) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
c__[i__3].r = 0., c__[i__3].i = 0.;
/* L210: */
}
} else if (beta->r != 1. || beta->i != 0.) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
.i, z__1.i = beta->r * c__[i__4].i + beta->i *
c__[i__4].r;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L220: */
}
}
i__2 = *k;
for (l = 1; l <= i__2; ++l) {
i__3 = j + l * b_dim1;
if (b[i__3].r != 0. || b[i__3].i != 0.) {
i__3 = j + l * b_dim1;
z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
z__1.i = alpha->r * b[i__3].i + alpha->i * b[
i__3].r;
temp.r = z__1.r, temp.i = z__1.i;
i__3 = *m;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * c_dim1;
i__5 = i__ + j * c_dim1;
i__6 = i__ + l * a_dim1;
z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
z__2.i = temp.r * a[i__6].i + temp.i * a[
i__6].r;
z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5]
.i + z__2.i;
c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
/* L230: */
}
}
/* L240: */
}
/* L250: */
}
}
} else if (conja) {
if (conjb) {
/* Form C := alpha*conjg( A' )*conjg( B' ) + beta*C. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
temp.r = 0., temp.i = 0.;
i__3 = *k;
for (l = 1; l <= i__3; ++l) {
d_cnjg(&z__3, &a[l + i__ * a_dim1]);
d_cnjg(&z__4, &b[j + l * b_dim1]);
z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i =
z__3.r * z__4.i + z__3.i * z__4.r;
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
/* L260: */
}
if (beta->r == 0. && beta->i == 0.) {
i__3 = i__ + j * c_dim1;
z__1.r = alpha->r * temp.r - alpha->i * temp.i,
z__1.i = alpha->r * temp.i + alpha->i *
temp.r;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
} else {
i__3 = i__ + j * c_dim1;
z__2.r = alpha->r * temp.r - alpha->i * temp.i,
z__2.i = alpha->r * temp.i + alpha->i *
temp.r;
i__4 = i__ + j * c_dim1;
z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
.i, z__3.i = beta->r * c__[i__4].i + beta->i *
c__[i__4].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
}
/* L270: */
}
/* L280: */
}
} else {
/* Form C := alpha*conjg( A' )*B' + beta*C */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
temp.r = 0., temp.i = 0.;
i__3 = *k;
for (l = 1; l <= i__3; ++l) {
d_cnjg(&z__3, &a[l + i__ * a_dim1]);
i__4 = j + l * b_dim1;
z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i,
z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4]
.r;
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
/* L290: */
}
if (beta->r == 0. && beta->i == 0.) {
i__3 = i__ + j * c_dim1;
z__1.r = alpha->r * temp.r - alpha->i * temp.i,
z__1.i = alpha->r * temp.i + alpha->i *
temp.r;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
} else {
i__3 = i__ + j * c_dim1;
z__2.r = alpha->r * temp.r - alpha->i * temp.i,
z__2.i = alpha->r * temp.i + alpha->i *
temp.r;
i__4 = i__ + j * c_dim1;
z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
.i, z__3.i = beta->r * c__[i__4].i + beta->i *
c__[i__4].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
}
/* L300: */
}
/* L310: */
}
}
} else {
if (conjb) {
/* Form C := alpha*A'*conjg( B' ) + beta*C */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
temp.r = 0., temp.i = 0.;
i__3 = *k;
for (l = 1; l <= i__3; ++l) {
i__4 = l + i__ * a_dim1;
d_cnjg(&z__3, &b[j + l * b_dim1]);
z__2.r = a[i__4].r * z__3.r - a[i__4].i * z__3.i,
z__2.i = a[i__4].r * z__3.i + a[i__4].i *
z__3.r;
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
/* L320: */
}
if (beta->r == 0. && beta->i == 0.) {
i__3 = i__ + j * c_dim1;
z__1.r = alpha->r * temp.r - alpha->i * temp.i,
z__1.i = alpha->r * temp.i + alpha->i *
temp.r;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
} else {
i__3 = i__ + j * c_dim1;
z__2.r = alpha->r * temp.r - alpha->i * temp.i,
z__2.i = alpha->r * temp.i + alpha->i *
temp.r;
i__4 = i__ + j * c_dim1;
z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
.i, z__3.i = beta->r * c__[i__4].i + beta->i *
c__[i__4].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
}
/* L330: */
}
/* L340: */
}
} else {
/* Form C := alpha*A'*B' + beta*C */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
temp.r = 0., temp.i = 0.;
i__3 = *k;
for (l = 1; l <= i__3; ++l) {
i__4 = l + i__ * a_dim1;
i__5 = j + l * b_dim1;
z__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5]
.i, z__2.i = a[i__4].r * b[i__5].i + a[i__4]
.i * b[i__5].r;
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
/* L350: */
}
if (beta->r == 0. && beta->i == 0.) {
i__3 = i__ + j * c_dim1;
z__1.r = alpha->r * temp.r - alpha->i * temp.i,
z__1.i = alpha->r * temp.i + alpha->i *
temp.r;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
} else {
i__3 = i__ + j * c_dim1;
z__2.r = alpha->r * temp.r - alpha->i * temp.i,
z__2.i = alpha->r * temp.i + alpha->i *
temp.r;
i__4 = i__ + j * c_dim1;
z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
.i, z__3.i = beta->r * c__[i__4].i + beta->i *
c__[i__4].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
}
/* L360: */
}
/* L370: */
}
}
}
return 0;
/* End of ZGEMM . */
} /* zgemm_ */
/* Subroutine */ int sopgtr_(char *uplo, integer *n, real *ap, real *tau,
real *q, integer *ldq, 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
September 30, 1994
Purpose
=======
SOPGTR generates a real orthogonal matrix Q which is defined as the
product of n-1 elementary reflectors H(i) of order n, as returned by
SSPTRD using packed storage:
if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangular packed storage used in previous
call to SSPTRD;
= 'L': Lower triangular packed storage used in previous
call to SSPTRD.
N (input) INTEGER
The order of the matrix Q. N >= 0.
AP (input) REAL array, dimension (N*(N+1)/2)
The vectors which define the elementary reflectors, as
returned by SSPTRD.
TAU (input) REAL array, dimension (N-1)
TAU(i) must contain the scalar factor of the elementary
reflector H(i), as returned by SSPTRD.
Q (output) REAL array, dimension (LDQ,N)
The N-by-N orthogonal matrix Q.
LDQ (input) INTEGER
The leading dimension of the array Q. LDQ >= max(1,N).
WORK (workspace) REAL array, dimension (N-1)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input arguments
Parameter adjustments
Function Body */
/* System generated locals */
integer q_dim1, q_offset, i__1, i__2, i__3;
/* Local variables */
static integer i, j;
extern logical lsame_(char *, char *);
static integer iinfo;
static logical upper;
extern /* Subroutine */ int sorg2l_(integer *, integer *, integer *, real
*, integer *, real *, real *, integer *), sorg2r_(integer *,
integer *, integer *, real *, integer *, real *, real *, integer *
);
static integer ij;
extern /* Subroutine */ int xerbla_(char *, integer *);
#define AP(I) ap[(I)-1]
#define TAU(I) tau[(I)-1]
#define WORK(I) work[(I)-1]
#define Q(I,J) q[(I)-1 + ((J)-1)* ( *ldq)]
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldq < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SOPGTR", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (upper) {
/* Q was determined by a call to SSPTRD with UPLO = 'U'
Unpack the vectors which define the elementary reflectors an
d
set the last row and column of Q equal to those of the unit
matrix */
ij = 2;
i__1 = *n - 1;
for (j = 1; j <= *n-1; ++j) {
i__2 = j - 1;
for (i = 1; i <= j-1; ++i) {
Q(i,j) = AP(ij);
++ij;
/* L10: */
}
ij += 2;
Q(*n,j) = 0.f;
/* L20: */
}
i__1 = *n - 1;
for (i = 1; i <= *n-1; ++i) {
Q(i,*n) = 0.f;
/* L30: */
}
Q(*n,*n) = 1.f;
/* Generate Q(1:n-1,1:n-1) */
i__1 = *n - 1;
i__2 = *n - 1;
i__3 = *n - 1;
sorg2l_(&i__1, &i__2, &i__3, &Q(1,1), ldq, &TAU(1), &WORK(1), &
iinfo);
} else {
/* Q was determined by a call to SSPTRD with UPLO = 'L'.
Unpack the vectors which define the elementary reflectors an
d
set the first row and column of Q equal to those of the unit
matrix */
Q(1,1) = 1.f;
i__1 = *n;
for (i = 2; i <= *n; ++i) {
Q(i,1) = 0.f;
/* L40: */
}
ij = 3;
i__1 = *n;
for (j = 2; j <= *n; ++j) {
Q(1,j) = 0.f;
i__2 = *n;
for (i = j + 1; i <= *n; ++i) {
Q(i,j) = AP(ij);
++ij;
/* L50: */
}
ij += 2;
/* L60: */
}
if (*n > 1) {
/* Generate Q(2:n,2:n) */
i__1 = *n - 1;
i__2 = *n - 1;
i__3 = *n - 1;
sorg2r_(&i__1, &i__2, &i__3, &Q(2,2), ldq, &TAU(1),
&WORK(1), &iinfo);
}
}
return 0;
/* End of SOPGTR */
} /* sopgtr_ */
/* Subroutine */ int cgerq2_(integer *m, integer *n, complex *a, integer *lda,
complex *tau, complex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
/* Local variables */
integer i__, k;
complex alpha;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CGERQ2 computes an RQ factorization of a complex m by n matrix A: */
/* A = R * Q. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the m by n matrix A. */
/* On exit, if m <= n, the upper triangle of the subarray */
/* A(1:m,n-m+1:n) contains the m by m upper triangular matrix R; */
/* if m >= n, the elements on and above the (m-n)-th subdiagonal */
/* contain the m by n upper trapezoidal matrix R; the remaining */
/* elements, with the array TAU, represent the unitary matrix */
/* Q as a product of elementary reflectors (see Further */
/* Details). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* TAU (output) COMPLEX array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* WORK (workspace) COMPLEX array, dimension (M) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of elementary reflectors */
/* Q = H(1)' H(2)' . . . H(k)', where k = min(m,n). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a complex scalar, and v is a complex vector with */
/* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on */
/* exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i). */
/* ===================================================================== */
/* 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) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGERQ2", &i__1);
return 0;
}
k = min(*m,*n);
for (i__ = k; i__ >= 1; --i__) {
/* Generate elementary reflector H(i) to annihilate */
/* A(m-k+i,1:n-k+i-1) */
i__1 = *n - k + i__;
clacgv_(&i__1, &a[*m - k + i__ + a_dim1], lda);
i__1 = *m - k + i__ + (*n - k + i__) * a_dim1;
alpha.r = a[i__1].r, alpha.i = a[i__1].i;
i__1 = *n - k + i__;
clarfp_(&i__1, &alpha, &a[*m - k + i__ + a_dim1], lda, &tau[i__]);
/* Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right */
i__1 = *m - k + i__ + (*n - k + i__) * a_dim1;
a[i__1].r = 1.f, a[i__1].i = 0.f;
i__1 = *m - k + i__ - 1;
i__2 = *n - k + i__;
clarf_("Right", &i__1, &i__2, &a[*m - k + i__ + a_dim1], lda, &tau[
i__], &a[a_offset], lda, &work[1]);
i__1 = *m - k + i__ + (*n - k + i__) * a_dim1;
a[i__1].r = alpha.r, a[i__1].i = alpha.i;
i__1 = *n - k + i__ - 1;
clacgv_(&i__1, &a[*m - k + i__ + a_dim1], lda);
}
return 0;
/* End of CGERQ2 */
} /* cgerq2_ */
/* Subroutine */ int dgemv_(char *trans, integer *m, integer *n, doublereal *
alpha, doublereal *a, integer *lda, doublereal *x, integer *incx,
doublereal *beta, doublereal *y, integer *incy)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
/* Local variables */
static integer info;
static doublereal temp;
static integer lenx, leny, i__, j;
extern logical lsame_(char *, char *);
static integer ix, iy, jx, jy, kx, ky;
extern /* Subroutine */ int xerbla_(char *, integer *);
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
/* Purpose
=======
DGEMV performs one of the matrix-vector operations
y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y,
where alpha and beta are scalars, x and y are vectors and A is an
m by n matrix.
Parameters
==========
TRANS - CHARACTER*1.
On entry, TRANS specifies the operation to be performed as
follows:
TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
TRANS = 'T' or 't' y := alpha*A'*x + beta*y.
TRANS = 'C' or 'c' y := alpha*A'*x + beta*y.
Unchanged on exit.
M - INTEGER.
On entry, M specifies the number of rows of the matrix A.
M must be at least zero.
Unchanged on exit.
N - INTEGER.
On entry, N specifies the number of columns of the matrix A.
N must be at least zero.
Unchanged on exit.
ALPHA - DOUBLE PRECISION.
On entry, ALPHA specifies the scalar alpha.
Unchanged on exit.
A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
Before entry, the leading m by n part of the array A must
contain the matrix of coefficients.
Unchanged on exit.
LDA - INTEGER.
On entry, LDA specifies the first dimension of A as declared
in the calling (sub) program. LDA must be at least
max( 1, m ).
Unchanged on exit.
X - DOUBLE PRECISION array of DIMENSION at least
( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
and at least
( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
Before entry, the incremented array X must contain the
vector x.
Unchanged on exit.
INCX - INTEGER.
On entry, INCX specifies the increment for the elements of
X. INCX must not be zero.
Unchanged on exit.
BETA - DOUBLE PRECISION.
On entry, BETA specifies the scalar beta. When BETA is
supplied as zero then Y need not be set on input.
Unchanged on exit.
Y - DOUBLE PRECISION array of DIMENSION at least
( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
and at least
( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
Before entry with BETA non-zero, the incremented array Y
must contain the vector y. On exit, Y is overwritten by the
updated vector y.
INCY - INTEGER.
On entry, INCY specifies the increment for the elements of
Y. INCY must not be zero.
Unchanged on exit.
Level 2 Blas routine.
-- Written on 22-October-1986.
Jack Dongarra, Argonne National Lab.
Jeremy Du Croz, Nag Central Office.
Sven Hammarling, Nag Central Office.
Richard Hanson, Sandia National Labs.
Test the input parameters.
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--x;
--y;
/* Function Body */
info = 0;
if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C")
) {
info = 1;
} else if (*m < 0) {
info = 2;
} else if (*n < 0) {
info = 3;
} else if (*lda < max(1,*m)) {
info = 6;
} else if (*incx == 0) {
info = 8;
} else if (*incy == 0) {
info = 11;
}
if (info != 0) {
xerbla_("DGEMV ", &info);
return 0;
}
/* Quick return if possible. */
if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) {
return 0;
}
/* Set LENX and LENY, the lengths of the vectors x and y, and set
up the start points in X and Y. */
if (lsame_(trans, "N")) {
lenx = *n;
leny = *m;
} else {
lenx = *m;
leny = *n;
}
if (*incx > 0) {
kx = 1;
} else {
kx = 1 - (lenx - 1) * *incx;
}
if (*incy > 0) {
ky = 1;
} else {
ky = 1 - (leny - 1) * *incy;
}
/* Start the operations. In this version the elements of A are
accessed sequentially with one pass through A.
First form y := beta*y. */
if (*beta != 1.) {
if (*incy == 1) {
if (*beta == 0.) {
i__1 = leny;
for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = 0.;
/* L10: */
}
} else {
i__1 = leny;
for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = *beta * y[i__];
/* L20: */
}
}
} else {
iy = ky;
if (*beta == 0.) {
i__1 = leny;
for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = 0.;
iy += *incy;
/* L30: */
}
} else {
i__1 = leny;
for (i__ = 1; i__ <= i__1; ++i__) {
y[iy] = *beta * y[iy];
iy += *incy;
/* L40: */
}
}
}
}
if (*alpha == 0.) {
return 0;
}
if (lsame_(trans, "N")) {
/* Form y := alpha*A*x + y. */
jx = kx;
if (*incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (x[jx] != 0.) {
temp = *alpha * x[jx];
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
y[i__] += temp * a_ref(i__, j);
/* L50: */
}
}
jx += *incx;
/* L60: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (x[jx] != 0.) {
temp = *alpha * x[jx];
iy = ky;
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
y[iy] += temp * a_ref(i__, j);
iy += *incy;
/* L70: */
}
}
jx += *incx;
/* L80: */
}
}
} else {
/* Form y := alpha*A'*x + y. */
jy = ky;
if (*incx == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp = 0.;
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
temp += a_ref(i__, j) * x[i__];
/* L90: */
}
y[jy] += *alpha * temp;
jy += *incy;
/* L100: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp = 0.;
ix = kx;
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
temp += a_ref(i__, j) * x[ix];
ix += *incx;
/* L110: */
}
y[jy] += *alpha * temp;
jy += *incy;
/* L120: */
}
}
}
return 0;
/* End of DGEMV . */
} /* dgemv_ */
int cungql_(int *m, int *n, int *k, complex *a,
int *lda, complex *tau, complex *work, int *lwork, int *
info)
{
/* System generated locals */
int a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
/* Local variables */
int i__, j, l, ib, nb, kk, nx, iws, nbmin, iinfo;
extern int cung2l_(int *, int *, int *,
complex *, int *, complex *, complex *, int *), clarfb_(
char *, char *, char *, char *, int *, int *, int *,
complex *, int *, complex *, int *, complex *, int *,
complex *, int *), clarft_(
char *, char *, int *, int *, complex *, int *,
complex *, complex *, int *), xerbla_(char *,
int *);
extern int ilaenv_(int *, char *, char *, int *, int *,
int *, int *);
int ldwork, lwkopt;
int lquery;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CUNGQL generates an M-by-N complex matrix Q with orthonormal columns, */
/* which is defined as the last N columns of a product of K elementary */
/* reflectors of order M */
/* Q = H(k) . . . H(2) H(1) */
/* as returned by CGEQLF. */
/* 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) COMPLEX array, dimension (LDA,N) */
/* On entry, the (n-k+i)-th column must contain the vector which */
/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
/* returned by CGEQLF in the last 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) COMPLEX array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by CGEQLF. */
/* WORK (workspace/output) COMPLEX 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,N). */
/* For optimum performance LWORK >= N*NB, where NB is the */
/* optimal blocksize. */
/* 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 has an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External 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;
lquery = *lwork == -1;
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) {
if (*n == 0) {
lwkopt = 1;
} else {
nb = ilaenv_(&c__1, "CUNGQL", " ", m, n, k, &c_n1);
lwkopt = *n * nb;
}
work[1].r = (float) lwkopt, work[1].i = 0.f;
if (*lwork < MAX(1,*n) && ! lquery) {
*info = -8;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CUNGQL", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
return 0;
}
nbmin = 2;
nx = 0;
iws = *n;
if (nb > 1 && nb < *k) {
/* Determine when to cross over from blocked to unblocked code. */
/* Computing MAX */
i__1 = 0, i__2 = ilaenv_(&c__3, "CUNGQL", " ", m, n, k, &c_n1);
nx = MAX(i__1,i__2);
if (nx < *k) {
/* Determine if workspace is large enough for blocked code. */
ldwork = *n;
iws = ldwork * nb;
if (*lwork < iws) {
/* Not enough workspace to use optimal NB: reduce NB and */
/* determine the minimum value of NB. */
nb = *lwork / ldwork;
/* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, "CUNGQL", " ", m, n, k, &c_n1);
nbmin = MAX(i__1,i__2);
}
}
}
if (nb >= nbmin && nb < *k && nx < *k) {
/* Use blocked code after the first block. */
/* The last kk columns are handled by the block method. */
/* Computing MIN */
i__1 = *k, i__2 = (*k - nx + nb - 1) / nb * nb;
kk = MIN(i__1,i__2);
/* Set A(m-kk+1:m,1:n-kk) to zero. */
i__1 = *n - kk;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = *m - kk + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
/* L10: */
}
/* L20: */
}
} else {
kk = 0;
}
/* Use unblocked code for the first or only block. */
i__1 = *m - kk;
i__2 = *n - kk;
i__3 = *k - kk;
cung2l_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], &iinfo)
;
if (kk > 0) {
/* Use blocked code */
i__1 = *k;
i__2 = nb;
for (i__ = *k - kk + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
i__2) {
/* Computing MIN */
i__3 = nb, i__4 = *k - i__ + 1;
ib = MIN(i__3,i__4);
if (*n - *k + i__ > 1) {
/* Form the triangular factor of the block reflector */
/* H = H(i+ib-1) . . . H(i+1) H(i) */
i__3 = *m - *k + i__ + ib - 1;
clarft_("Backward", "Columnwise", &i__3, &ib, &a[(*n - *k +
i__) * a_dim1 + 1], lda, &tau[i__], &work[1], &ldwork);
/* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left */
i__3 = *m - *k + i__ + ib - 1;
i__4 = *n - *k + i__ - 1;
clarfb_("Left", "No transpose", "Backward", "Columnwise", &
i__3, &i__4, &ib, &a[(*n - *k + i__) * a_dim1 + 1],
lda, &work[1], &ldwork, &a[a_offset], lda, &work[ib +
1], &ldwork);
}
/* Apply H to rows 1:m-k+i+ib-1 of current block */
i__3 = *m - *k + i__ + ib - 1;
cung2l_(&i__3, &ib, &ib, &a[(*n - *k + i__) * a_dim1 + 1], lda, &
tau[i__], &work[1], &iinfo);
/* Set rows m-k+i+ib:m of current block to zero */
i__3 = *n - *k + i__ + ib - 1;
for (j = *n - *k + i__; j <= i__3; ++j) {
i__4 = *m;
for (l = *m - *k + i__ + ib; l <= i__4; ++l) {
i__5 = l + j * a_dim1;
a[i__5].r = 0.f, a[i__5].i = 0.f;
/* L30: */
}
/* L40: */
}
/* L50: */
}
}
work[1].r = (float) iws, work[1].i = 0.f;
return 0;
/* End of CUNGQL */
} /* cungql_ */
/* Subroutine */ int stprfs_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, real *ap, real *b, integer *ldb, real *x, integer *ldx,
real *ferr, real *berr, real *work, integer *iwork, integer *info,
ftnlen uplo_len, ftnlen trans_len, ftnlen diag_len)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3;
real r__1, r__2, r__3;
/* Local variables */
static integer i__, j, k;
static real s;
static integer kc;
static real xk;
static integer nz;
static real eps;
static integer kase;
static real safe1, safe2;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static logical upper;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), saxpy_(integer *, real *, real *, integer *, real *,
integer *), stpmv_(char *, char *, char *, integer *, real *,
real *, integer *, ftnlen, ftnlen, ftnlen), stpsv_(char *, char *,
char *, integer *, real *, real *, integer *, ftnlen, ftnlen,
ftnlen);
extern doublereal slamch_(char *, ftnlen);
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slacon_(
integer *, real *, real *, integer *, real *, integer *);
static logical notran;
static char transt[1];
static logical nounit;
static real lstres;
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* STPRFS provides error bounds and backward error estimates for the */
/* solution to a system of linear equations with a triangular packed */
/* coefficient matrix. */
/* The solution matrix X must be computed by STPTRS or some other */
/* means before entering this routine. STPRFS does not do iterative */
/* refinement because doing so cannot improve the backward error. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': A is upper triangular; */
/* = 'L': A is lower triangular. */
/* TRANS (input) CHARACTER*1 */
/* Specifies the form of the system of equations: */
/* = 'N': A * X = B (No transpose) */
/* = 'T': A**T * X = B (Transpose) */
/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
/* DIAG (input) CHARACTER*1 */
/* = 'N': A is non-unit triangular; */
/* = 'U': A is unit triangular. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* AP (input) REAL array, dimension (N*(N+1)/2) */
/* The upper or lower triangular matrix A, packed columnwise in */
/* a linear array. The j-th column of A is stored in the array */
/* AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
/* If DIAG = 'U', the diagonal elements of A are not referenced */
/* and are assumed to be 1. */
/* B (input) REAL array, dimension (LDB,NRHS) */
/* The right hand side matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (input) REAL array, dimension (LDX,NRHS) */
/* The solution matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* FERR (output) REAL array, dimension (NRHS) */
/* The estimated forward error bound for each solution vector */
/* X(j) (the j-th column of the solution matrix X). */
/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
/* is an estimated upper bound for the magnitude of the largest */
/* element in (X(j) - XTRUE) divided by the magnitude of the */
/* largest element in X(j). The estimate is as reliable as */
/* the estimate for RCOND, and is almost always a slight */
/* overestimate of the true error. */
/* BERR (output) REAL array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector X(j) (i.e., the smallest relative change in */
/* any element of A or B that makes X(j) an exact solution). */
/* WORK (workspace) REAL array, dimension (3*N) */
/* IWORK (workspace) INTEGER array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--iwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
notran = lsame_(trans, "N", (ftnlen)1, (ftnlen)1);
nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T", (ftnlen)1, (ftnlen)1) && !
lsame_(trans, "C", (ftnlen)1, (ftnlen)1)) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*nrhs < 0) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else if (*ldx < max(1,*n)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("STPRFS", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] = 0.f;
berr[j] = 0.f;
/* L10: */
}
return 0;
}
if (notran) {
*(unsigned char *)transt = 'T';
} else {
*(unsigned char *)transt = 'N';
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
eps = slamch_("Epsilon", (ftnlen)7);
safmin = slamch_("Safe minimum", (ftnlen)12);
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
/* Compute residual R = B - op(A) * X, */
/* where op(A) = A or A', depending on TRANS. */
scopy_(n, &x[j * x_dim1 + 1], &c__1, &work[*n + 1], &c__1);
stpmv_(uplo, trans, diag, n, &ap[1], &work[*n + 1], &c__1, (ftnlen)1,
(ftnlen)1, (ftnlen)1);
saxpy_(n, &c_b19, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
/* Compute componentwise relative backward error from formula */
/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
/* where abs(Z) is the componentwise absolute value of the matrix */
/* or vector Z. If the i-th component of the denominator is less */
/* than SAFE2, then SAFE1 is added to the i-th components of the */
/* numerator and denominator before dividing. */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] = (r__1 = b[i__ + j * b_dim1], dabs(r__1));
/* L20: */
}
if (notran) {
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
kc = 1;
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
i__3 = k;
for (i__ = 1; i__ <= i__3; ++i__) {
work[i__] += (r__1 = ap[kc + i__ - 1], dabs(r__1))
* xk;
/* L30: */
}
kc += k;
/* L40: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
work[i__] += (r__1 = ap[kc + i__ - 1], dabs(r__1))
* xk;
/* L50: */
}
work[k] += xk;
kc += k;
/* L60: */
}
}
} else {
kc = 1;
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
i__3 = *n;
for (i__ = k; i__ <= i__3; ++i__) {
work[i__] += (r__1 = ap[kc + i__ - k], dabs(r__1))
* xk;
/* L70: */
}
kc = kc + *n - k + 1;
/* L80: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
work[i__] += (r__1 = ap[kc + i__ - k], dabs(r__1))
* xk;
/* L90: */
}
work[k] += xk;
kc = kc + *n - k + 1;
/* L100: */
}
}
}
} else {
/* Compute abs(A')*abs(X) + abs(B). */
if (upper) {
kc = 1;
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
i__3 = k;
for (i__ = 1; i__ <= i__3; ++i__) {
s += (r__1 = ap[kc + i__ - 1], dabs(r__1)) * (
r__2 = x[i__ + j * x_dim1], dabs(r__2));
/* L110: */
}
work[k] += s;
kc += k;
/* L120: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = (r__1 = x[k + j * x_dim1], dabs(r__1));
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
s += (r__1 = ap[kc + i__ - 1], dabs(r__1)) * (
r__2 = x[i__ + j * x_dim1], dabs(r__2));
/* L130: */
}
work[k] += s;
kc += k;
/* L140: */
}
}
} else {
kc = 1;
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
i__3 = *n;
for (i__ = k; i__ <= i__3; ++i__) {
s += (r__1 = ap[kc + i__ - k], dabs(r__1)) * (
r__2 = x[i__ + j * x_dim1], dabs(r__2));
/* L150: */
}
work[k] += s;
kc = kc + *n - k + 1;
/* L160: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = (r__1 = x[k + j * x_dim1], dabs(r__1));
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
s += (r__1 = ap[kc + i__ - k], dabs(r__1)) * (
r__2 = x[i__ + j * x_dim1], dabs(r__2));
/* L170: */
}
work[k] += s;
kc = kc + *n - k + 1;
/* L180: */
}
}
}
}
s = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[i__] > safe2) {
/* Computing MAX */
r__2 = s, r__3 = (r__1 = work[*n + i__], dabs(r__1)) / work[
i__];
s = dmax(r__2,r__3);
} else {
/* Computing MAX */
r__2 = s, r__3 = ((r__1 = work[*n + i__], dabs(r__1)) + safe1)
/ (work[i__] + safe1);
s = dmax(r__2,r__3);
}
/* L190: */
}
berr[j] = s;
/* Bound error from formula */
/* norm(X - XTRUE) / norm(X) .le. FERR = */
/* norm( abs(inv(op(A)))* */
/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
/* where */
/* norm(Z) is the magnitude of the largest component of Z */
/* inv(op(A)) is the inverse of op(A) */
/* abs(Z) is the componentwise absolute value of the matrix or */
/* vector Z */
/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
/* EPS is machine epsilon */
/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
/* is incremented by SAFE1 if the i-th component of */
/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
/* Use SLACON to estimate the infinity-norm of the matrix */
/* inv(op(A)) * diag(W), */
/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[i__] > safe2) {
work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
work[i__];
} else {
work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
work[i__] + safe1;
}
/* L200: */
}
kase = 0;
L210:
slacon_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)'). */
stpsv_(uplo, transt, diag, n, &ap[1], &work[*n + 1], &c__1, (
ftnlen)1, (ftnlen)1, (ftnlen)1);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = work[i__] * work[*n + i__];
/* L220: */
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = work[i__] * work[*n + i__];
/* L230: */
}
stpsv_(uplo, trans, diag, n, &ap[1], &work[*n + 1], &c__1, (
ftnlen)1, (ftnlen)1, (ftnlen)1);
}
goto L210;
}
/* Normalize error. */
lstres = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
r__2 = lstres, r__3 = (r__1 = x[i__ + j * x_dim1], dabs(r__1));
lstres = dmax(r__2,r__3);
/* L240: */
}
if (lstres != 0.f) {
ferr[j] /= lstres;
}
/* L250: */
}
return 0;
/* End of STPRFS */
} /* stprfs_ */
/* Subroutine */ int dlagts_(integer *job, integer *n, doublereal *a,
doublereal *b, doublereal *c__, doublereal *d__, integer *in,
doublereal *y, doublereal *tol, integer *info)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2, d__3, d__4, d__5;
/* Builtin functions */
double d_sign(doublereal *, doublereal *);
/* Local variables */
integer k;
doublereal ak, eps, temp, pert, absak, sfmin;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal bignum;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAGTS may be used to solve one of the systems of equations */
/* (T - lambda*I)*x = y or (T - lambda*I)'*x = y, */
/* where T is an n by n tridiagonal matrix, for x, following the */
/* factorization of (T - lambda*I) as */
/* (T - lambda*I) = P*L*U , */
/* by routine DLAGTF. The choice of equation to be solved is */
/* controlled by the argument JOB, and in each case there is an option */
/* to perturb zero or very small diagonal elements of U, this option */
/* being intended for use in applications such as inverse iteration. */
/* Arguments */
/* ========= */
/* JOB (input) INTEGER */
/* Specifies the job to be performed by DLAGTS as follows: */
/* = 1: The equations (T - lambda*I)x = y are to be solved, */
/* but diagonal elements of U are not to be perturbed. */
/* = -1: The equations (T - lambda*I)x = y are to be solved */
/* and, if overflow would otherwise occur, the diagonal */
/* elements of U are to be perturbed. See argument TOL */
/* below. */
/* = 2: The equations (T - lambda*I)'x = y are to be solved, */
/* but diagonal elements of U are not to be perturbed. */
/* = -2: The equations (T - lambda*I)'x = y are to be solved */
/* and, if overflow would otherwise occur, the diagonal */
/* elements of U are to be perturbed. See argument TOL */
/* below. */
/* N (input) INTEGER */
/* The order of the matrix T. */
/* A (input) DOUBLE PRECISION array, dimension (N) */
/* On entry, A must contain the diagonal elements of U as */
/* returned from DLAGTF. */
/* B (input) DOUBLE PRECISION array, dimension (N-1) */
/* On entry, B must contain the first super-diagonal elements of */
/* U as returned from DLAGTF. */
/* C (input) DOUBLE PRECISION array, dimension (N-1) */
/* On entry, C must contain the sub-diagonal elements of L as */
/* returned from DLAGTF. */
/* D (input) DOUBLE PRECISION array, dimension (N-2) */
/* On entry, D must contain the second super-diagonal elements */
/* of U as returned from DLAGTF. */
/* IN (input) INTEGER array, dimension (N) */
/* On entry, IN must contain details of the matrix P as returned */
/* from DLAGTF. */
/* Y (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the right hand side vector y. */
/* On exit, Y is overwritten by the solution vector x. */
/* TOL (input/output) DOUBLE PRECISION */
/* On entry, with JOB .lt. 0, TOL should be the minimum */
/* perturbation to be made to very small diagonal elements of U. */
/* TOL should normally be chosen as about eps*norm(U), where eps */
/* is the relative machine precision, but if TOL is supplied as */
/* non-positive, then it is reset to eps*max( abs( u(i,j) ) ). */
/* If JOB .gt. 0 then TOL is not referenced. */
/* On exit, TOL is changed as described above, only if TOL is */
/* non-positive on entry. Otherwise TOL is unchanged. */
/* INFO (output) INTEGER */
/* = 0 : successful exit */
/* .lt. 0: if INFO = -i, the i-th argument had an illegal value */
/* .gt. 0: overflow would occur when computing the INFO(th) */
/* element of the solution vector x. This can only occur */
/* when JOB is supplied as positive and either means */
/* that a diagonal element of U is very small, or that */
/* the elements of the right-hand side vector y are very */
/* large. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--y;
--in;
--d__;
--c__;
--b;
--a;
/* Function Body */
*info = 0;
if (abs(*job) > 2 || *job == 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLAGTS", &i__1);
return 0;
}
if (*n == 0) {
return 0;
}
eps = dlamch_("Epsilon");
sfmin = dlamch_("Safe minimum");
bignum = 1. / sfmin;
if (*job < 0) {
if (*tol <= 0.) {
*tol = abs(a[1]);
if (*n > 1) {
/* Computing MAX */
d__1 = *tol, d__2 = abs(a[2]), d__1 = max(d__1,d__2), d__2 =
abs(b[1]);
*tol = max(d__1,d__2);
}
i__1 = *n;
for (k = 3; k <= i__1; ++k) {
/* Computing MAX */
d__4 = *tol, d__5 = (d__1 = a[k], abs(d__1)), d__4 = max(d__4,
d__5), d__5 = (d__2 = b[k - 1], abs(d__2)), d__4 =
max(d__4,d__5), d__5 = (d__3 = d__[k - 2], abs(d__3));
*tol = max(d__4,d__5);
/* L10: */
}
*tol *= eps;
if (*tol == 0.) {
*tol = eps;
}
}
}
if (abs(*job) == 1) {
i__1 = *n;
for (k = 2; k <= i__1; ++k) {
if (in[k - 1] == 0) {
y[k] -= c__[k - 1] * y[k - 1];
} else {
temp = y[k - 1];
y[k - 1] = y[k];
y[k] = temp - c__[k - 1] * y[k];
}
/* L20: */
}
if (*job == 1) {
for (k = *n; k >= 1; --k) {
if (k <= *n - 2) {
temp = y[k] - b[k] * y[k + 1] - d__[k] * y[k + 2];
} else if (k == *n - 1) {
temp = y[k] - b[k] * y[k + 1];
} else {
temp = y[k];
}
ak = a[k];
absak = abs(ak);
if (absak < 1.) {
if (absak < sfmin) {
if (absak == 0. || abs(temp) * sfmin > absak) {
*info = k;
return 0;
} else {
temp *= bignum;
ak *= bignum;
}
} else if (abs(temp) > absak * bignum) {
*info = k;
return 0;
}
}
y[k] = temp / ak;
/* L30: */
}
} else {
for (k = *n; k >= 1; --k) {
if (k <= *n - 2) {
temp = y[k] - b[k] * y[k + 1] - d__[k] * y[k + 2];
} else if (k == *n - 1) {
temp = y[k] - b[k] * y[k + 1];
} else {
temp = y[k];
}
ak = a[k];
pert = d_sign(tol, &ak);
L40:
absak = abs(ak);
if (absak < 1.) {
if (absak < sfmin) {
if (absak == 0. || abs(temp) * sfmin > absak) {
ak += pert;
pert *= 2;
goto L40;
} else {
temp *= bignum;
ak *= bignum;
}
} else if (abs(temp) > absak * bignum) {
ak += pert;
pert *= 2;
goto L40;
}
}
y[k] = temp / ak;
/* L50: */
}
}
} else {
/* Come to here if JOB = 2 or -2 */
if (*job == 2) {
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (k >= 3) {
temp = y[k] - b[k - 1] * y[k - 1] - d__[k - 2] * y[k - 2];
} else if (k == 2) {
temp = y[k] - b[k - 1] * y[k - 1];
} else {
temp = y[k];
}
ak = a[k];
absak = abs(ak);
if (absak < 1.) {
if (absak < sfmin) {
if (absak == 0. || abs(temp) * sfmin > absak) {
*info = k;
return 0;
} else {
temp *= bignum;
ak *= bignum;
}
} else if (abs(temp) > absak * bignum) {
*info = k;
return 0;
}
}
y[k] = temp / ak;
/* L60: */
}
} else {
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (k >= 3) {
temp = y[k] - b[k - 1] * y[k - 1] - d__[k - 2] * y[k - 2];
} else if (k == 2) {
temp = y[k] - b[k - 1] * y[k - 1];
} else {
temp = y[k];
}
ak = a[k];
pert = d_sign(tol, &ak);
L70:
absak = abs(ak);
if (absak < 1.) {
if (absak < sfmin) {
if (absak == 0. || abs(temp) * sfmin > absak) {
ak += pert;
pert *= 2;
goto L70;
} else {
temp *= bignum;
ak *= bignum;
}
} else if (abs(temp) > absak * bignum) {
ak += pert;
pert *= 2;
goto L70;
}
}
y[k] = temp / ak;
/* L80: */
}
}
for (k = *n; k >= 2; --k) {
if (in[k - 1] == 0) {
y[k - 1] -= c__[k - 1] * y[k];
} else {
temp = y[k - 1];
y[k - 1] = y[k];
y[k] = temp - c__[k - 1] * y[k];
}
/* L90: */
}
}
/* End of DLAGTS */
return 0;
} /* dlagts_ */
/* Subroutine */ int zhseqr_(char *job, char *compz, integer *n, integer *ilo,
integer *ihi, doublecomplex *h__, integer *ldh, doublecomplex *w,
doublecomplex *z__, integer *ldz, doublecomplex *work, integer *lwork,
integer *info)
{
/* System generated locals */
address a__1[2];
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3[2];
doublereal d__1, d__2, d__3;
doublecomplex z__1;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
doublecomplex hl[2401] /* was [49][49] */;
integer kbot, nmin;
extern logical lsame_(char *, char *);
logical initz;
doublecomplex workl[49];
logical wantt, wantz;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zlaqr0_(logical *, logical *,
integer *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *), xerbla_(char *, integer *
);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int zlahqr_(logical *, logical *, integer *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, integer *, doublecomplex *, integer *, integer *),
zlacpy_(char *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zlaset_(char *, integer *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
integer *);
logical lquery;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZHSEQR computes the eigenvalues of a Hessenberg matrix H */
/* and, optionally, the matrices T and Z from the Schur decomposition */
/* H = Z T Z**H, where T is an upper triangular matrix (the */
/* Schur form), and Z is the unitary matrix of Schur vectors. */
/* Optionally Z may be postmultiplied into an input unitary */
/* 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 unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. */
/* 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 unitary matrix Q on entry, and */
/* the product Q*Z is returned. */
/* N (input) INTEGER */
/* The order of the matrix H. N .GE. 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 ZGEBAL, and then passed to ZGEHRD */
/* when the matrix output by ZGEBAL is reduced to Hessenberg */
/* form. Otherwise ILO and IHI should be set to 1 and N */
/* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */
/* If N = 0, then ILO = 1 and IHI = 0. */
/* H (input/output) COMPLEX*16 array, dimension (LDH,N) */
/* On entry, the upper Hessenberg matrix H. */
/* On exit, if INFO = 0 and JOB = 'S', H contains the upper */
/* triangular matrix T from the Schur decomposition (the */
/* Schur form). If INFO = 0 and JOB = 'E', the contents of */
/* H are unspecified on exit. (The output value of H when */
/* INFO.GT.0 is given under the description of INFO below.) */
/* Unlike earlier versions of ZHSEQR, this subroutine may */
/* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1 */
/* or j = IHI+1, IHI+2, ... N. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH .GE. max(1,N). */
/* W (output) COMPLEX*16 array, dimension (N) */
/* The computed eigenvalues. If JOB = 'S', the eigenvalues are */
/* stored in the same order as on the diagonal of the Schur */
/* form returned in H, with W(i) = H(i,i). */
/* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) */
/* If COMPZ = 'N', Z is not referenced. */
/* If COMPZ = 'I', on entry Z need not be set and on exit, */
/* if INFO = 0, Z contains the unitary 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, */
/* if INFO = 0, Z contains Q*Z. */
/* Normally Q is the unitary matrix generated by ZUNGHR */
/* after the call to ZGEHRD which formed the Hessenberg matrix */
/* H. (The output value of Z when INFO.GT.0 is given under */
/* the description of INFO below.) */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. if COMPZ = 'I' or */
/* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. */
/* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns an estimate of */
/* the optimal value for LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK .GE. max(1,N) */
/* is sufficient and delivers very good and sometimes */
/* optimal performance. However, LWORK as large as 11*N */
/* may be required for optimal performance. A workspace */
/* query is recommended to determine the optimal workspace */
/* size. */
/* If LWORK = -1, then ZHSEQR does a workspace query. */
/* In this case, ZHSEQR checks the input parameters and */
/* estimates the optimal workspace size for the given */
/* values of N, ILO and IHI. The estimate is returned */
/* in WORK(1). No error message related to LWORK is */
/* issued by XERBLA. Neither H nor Z are accessed. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* .LT. 0: if INFO = -i, the i-th argument had an illegal */
/* value */
/* .GT. 0: if INFO = i, ZHSEQR failed to compute all of */
/* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */
/* and WI contain those eigenvalues which have been */
/* successfully computed. (Failures are rare.) */
/* If INFO .GT. 0 and JOB = 'E', then on exit, the */
/* remaining unconverged eigenvalues are the eigen- */
/* values of the upper Hessenberg matrix rows and */
/* columns ILO through INFO of the final, output */
/* value of H. */
/* If INFO .GT. 0 and JOB = 'S', then on exit */
/* (*) (initial value of H)*U = U*(final value of H) */
/* where U is a unitary matrix. The final */
/* value of H is upper Hessenberg and triangular in */
/* rows and columns INFO+1 through IHI. */
/* If INFO .GT. 0 and COMPZ = 'V', then on exit */
/* (final value of Z) = (initial value of Z)*U */
/* where U is the unitary matrix in (*) (regard- */
/* less of the value of JOB.) */
/* If INFO .GT. 0 and COMPZ = 'I', then on exit */
/* (final value of Z) = U */
/* where U is the unitary matrix in (*) (regard- */
/* less of the value of JOB.) */
/* If INFO .GT. 0 and COMPZ = 'N', then Z is not */
/* accessed. */
/* ================================================================ */
/* Default values supplied by */
/* ILAENV(ISPEC,'ZHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). */
/* It is suggested that these defaults be adjusted in order */
/* to attain best performance in each particular */
/* computational environment. */
/* ISPEC=12: The ZLAHQR vs ZLAQR0 crossover point. */
/* Default: 75. (Must be at least 11.) */
/* ISPEC=13: Recommended deflation window size. */
/* This depends on ILO, IHI and NS. NS is the */
/* number of simultaneous shifts returned */
/* by ILAENV(ISPEC=15). (See ISPEC=15 below.) */
/* The default for (IHI-ILO+1).LE.500 is NS. */
/* The default for (IHI-ILO+1).GT.500 is 3*NS/2. */
/* ISPEC=14: Nibble crossover point. (See IPARMQ for */
/* details.) Default: 14% of deflation window */
/* size. */
/* ISPEC=15: Number of simultaneous shifts in a multishift */
/* QR iteration. */
/* If IHI-ILO+1 is ... */
/* greater than ...but less ... the */
/* or equal to ... than default is */
/* 1 30 NS = 2(+) */
/* 30 60 NS = 4(+) */
/* 60 150 NS = 10(+) */
/* 150 590 NS = ** */
/* 590 3000 NS = 64 */
/* 3000 6000 NS = 128 */
/* 6000 infinity NS = 256 */
/* (+) By default some or all matrices of this order */
/* are passed to the implicit double shift routine */
/* ZLAHQR and this parameter is ignored. See */
/* ISPEC=12 above and comments in IPARMQ for */
/* details. */
/* (**) The asterisks (**) indicate an ad-hoc */
/* function of N increasing from 10 to 64. */
/* ISPEC=16: Select structured matrix multiply. */
/* If the number of simultaneous shifts (specified */
/* by ISPEC=15) is less than 14, then the default */
/* for ISPEC=16 is 0. Otherwise the default for */
/* ISPEC=16 is 2. */
/* ================================================================ */
/* Based on contributions by */
/* Karen Braman and Ralph Byers, Department of Mathematics, */
/* University of Kansas, USA */
/* ================================================================ */
/* References: */
/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
/* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */
/* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */
/* 929--947, 2002. */
/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
/* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */
/* of Matrix Analysis, volume 23, pages 948--973, 2002. */
/* ================================================================ */
/* .. Parameters .. */
/* ==== Matrices of order NTINY or smaller must be processed by */
/* . ZLAHQR because of insufficient subdiagonal scratch space. */
/* . (This is a hard limit.) ==== */
/* ==== NL allocates some local workspace to help small matrices */
/* . through a rare ZLAHQR failure. NL .GT. NTINY = 11 is */
/* . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom- */
/* . mended. (The default value of NMIN is 75.) Using NL = 49 */
/* . allows up to six simultaneous shifts and a 16-by-16 */
/* . deflation window. ==== */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* ==== Decode and check the input parameters. ==== */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
/* Function Body */
wantt = lsame_(job, "S");
initz = lsame_(compz, "I");
wantz = initz || lsame_(compz, "V");
d__1 = (doublereal) max(1,*n);
z__1.r = d__1, z__1.i = 0.;
work[1].r = z__1.r, work[1].i = z__1.i;
lquery = *lwork == -1;
*info = 0;
if (! lsame_(job, "E") && ! wantt) {
*info = -1;
} else if (! lsame_(compz, "N") && ! 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 = -10;
} else if (*lwork < max(1,*n) && ! lquery) {
*info = -12;
}
if (*info != 0) {
/* ==== Quick return in case of invalid argument. ==== */
i__1 = -(*info);
xerbla_("ZHSEQR", &i__1);
return 0;
} else if (*n == 0) {
/* ==== Quick return in case N = 0; nothing to do. ==== */
return 0;
} else if (lquery) {
/* ==== Quick return in case of a workspace query ==== */
zlaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1], ilo,
ihi, &z__[z_offset], ldz, &work[1], lwork, info);
/* ==== Ensure reported workspace size is backward-compatible with */
/* . previous LAPACK versions. ==== */
/* Computing MAX */
d__2 = work[1].r, d__3 = (doublereal) max(1,*n);
d__1 = max(d__2,d__3);
z__1.r = d__1, z__1.i = 0.;
work[1].r = z__1.r, work[1].i = z__1.i;
return 0;
} else {
/* ==== copy eigenvalues isolated by ZGEBAL ==== */
if (*ilo > 1) {
i__1 = *ilo - 1;
i__2 = *ldh + 1;
zcopy_(&i__1, &h__[h_offset], &i__2, &w[1], &c__1);
}
if (*ihi < *n) {
i__1 = *n - *ihi;
i__2 = *ldh + 1;
zcopy_(&i__1, &h__[*ihi + 1 + (*ihi + 1) * h_dim1], &i__2, &w[*
ihi + 1], &c__1);
}
/* ==== Initialize Z, if requested ==== */
if (initz) {
zlaset_("A", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
}
/* ==== Quick return if possible ==== */
if (*ilo == *ihi) {
i__1 = *ilo;
i__2 = *ilo + *ilo * h_dim1;
w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
return 0;
}
/* ==== ZLAHQR/ZLAQR0 crossover point ==== */
/* 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);
nmin = ilaenv_(&c__12, "ZHSEQR", ch__1, n, ilo, ihi, lwork);
nmin = max(11,nmin);
/* ==== ZLAQR0 for big matrices; ZLAHQR for small ones ==== */
if (*n > nmin) {
zlaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1],
ilo, ihi, &z__[z_offset], ldz, &work[1], lwork, info);
} else {
/* ==== Small matrix ==== */
zlahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1],
ilo, ihi, &z__[z_offset], ldz, info);
if (*info > 0) {
/* ==== A rare ZLAHQR failure! ZLAQR0 sometimes succeeds */
/* . when ZLAHQR fails. ==== */
kbot = *info;
if (*n >= 49) {
/* ==== Larger matrices have enough subdiagonal scratch */
/* . space to call ZLAQR0 directly. ==== */
zlaqr0_(&wantt, &wantz, n, ilo, &kbot, &h__[h_offset],
ldh, &w[1], ilo, ihi, &z__[z_offset], ldz, &work[
1], lwork, info);
} else {
/* ==== Tiny matrices don't have enough subdiagonal */
/* . scratch space to benefit from ZLAQR0. Hence, */
/* . tiny matrices must be copied into a larger */
/* . array before calling ZLAQR0. ==== */
zlacpy_("A", n, n, &h__[h_offset], ldh, hl, &c__49);
i__1 = *n + 1 + *n * 49 - 50;
hl[i__1].r = 0., hl[i__1].i = 0.;
i__1 = 49 - *n;
zlaset_("A", &c__49, &i__1, &c_b1, &c_b1, &hl[(*n + 1) *
49 - 49], &c__49);
zlaqr0_(&wantt, &wantz, &c__49, ilo, &kbot, hl, &c__49, &
w[1], ilo, ihi, &z__[z_offset], ldz, workl, &
c__49, info);
if (wantt || *info != 0) {
zlacpy_("A", n, n, hl, &c__49, &h__[h_offset], ldh);
}
}
}
}
/* ==== Clear out the trash, if necessary. ==== */
if ((wantt || *info != 0) && *n > 2) {
i__1 = *n - 2;
i__2 = *n - 2;
zlaset_("L", &i__1, &i__2, &c_b1, &c_b1, &h__[h_dim1 + 3], ldh);
}
/* ==== Ensure reported workspace size is backward-compatible with */
/* . previous LAPACK versions. ==== */
/* Computing MAX */
d__2 = (doublereal) max(1,*n), d__3 = work[1].r;
d__1 = max(d__2,d__3);
z__1.r = d__1, z__1.i = 0.;
work[1].r = z__1.r, work[1].i = z__1.i;
}
/* ==== End of ZHSEQR ==== */
return 0;
} /* zhseqr_ */
/* Subroutine */ int cstegr_(char *jobz, char *range, integer *n, real *d__,
real *e, real *vl, real *vu, integer *il, integer *iu, real *abstol,
integer *m, real *w, complex *z__, integer *ldz, integer *isuppz,
real *work, integer *lwork, integer *iwork, integer *liwork, integer *
info, ftnlen jobz_len, ftnlen range_len)
{
/* 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 i__, j, jj;
static real eps, tol, tmp;
static integer iend;
static real rmin, rmax;
static integer itmp;
static real tnrm, scale;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static integer iinfo;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
cswap_(integer *, complex *, integer *, complex *, integer *);
static integer lwmin;
static logical wantz, alleig;
static integer ibegin;
static logical indeig;
static integer iindbl;
static logical valeig;
extern doublereal slamch_(char *, ftnlen);
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *, ftnlen);
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
static real bignum;
static integer iindwk, indgrs, indwof;
extern /* Subroutine */ int clarrv_(integer *, real *, real *, integer *,
integer *, real *, integer *, real *, real *, complex *, integer *
, integer *, real *, integer *, integer *), slarre_(integer *,
real *, real *, real *, integer *, integer *, integer *, real *,
real *, real *, real *, integer *);
static real thresh;
static integer iinspl, indwrk, liwmin;
extern doublereal slanst_(char *, integer *, real *, real *, ftnlen);
static integer nsplit;
static real smlnum;
static logical lquery;
/* -- LAPACK computational routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CSTEGR computes selected eigenvalues and, optionally, eigenvectors */
/* of a real symmetric tridiagonal matrix T. Eigenvalues and */
/* eigenvectors can be selected by specifying either a range of values */
/* or a range of indices for the desired eigenvalues. The eigenvalues */
/* are computed 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 the i-th unreduced block of T, */
/* (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T */
/* is a relatively robust representation, */
/* (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high */
/* relative accuracy by the dqds algorithm, */
/* (c) If there is a cluster of close eigenvalues, "choose" sigma_i */
/* close to the cluster, and go to step (a), */
/* (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T, */
/* compute the corresponding eigenvector by forming a */
/* rank-revealing twisted factorization. */
/* The desired accuracy of the output can be specified by the input */
/* parameter ABSTOL. */
/* For more details, see "A new O(n^2) algorithm for the symmetric */
/* tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon, */
/* Computer Science Division Technical Report No. UCB/CSD-97-971, */
/* UC Berkeley, May 1997. */
/* Note 1 : Currently CSTEGR is only set up to find ALL the n */
/* eigenvalues and eigenvectors of T in O(n^2) time */
/* Note 2 : Currently the routine CSTEIN is called when an appropriate */
/* sigma_i cannot be chosen in step (c) above. CSTEIN invokes modified */
/* Gram-Schmidt when eigenvalues are close. */
/* Note 3 : CSTEGR works only on machines which follow ieee-754 */
/* floating-point standard in their handling of infinities and NaNs. */
/* Normal execution of CSTEGR may create NaNs and infinities and hence */
/* may abort due to a floating point exception in environments which */
/* do not conform to the ieee standard. */
/* 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. */
/* ********* Only RANGE = 'A' is currently supported ********************* */
/* 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 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; 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/eigenvectors. IF JOBZ = 'V', the eigenvalues and */
/* eigenvectors output have residual norms bounded by ABSTOL, */
/* and the dot products between different eigenvectors are */
/* bounded by ABSTOL. If ABSTOL is less than N*EPS*|T|, then */
/* N*EPS*|T| will be used in its place, where EPS is the */
/* machine precision and |T| is the 1-norm of the tridiagonal */
/* matrix. The eigenvalues are computed to an accuracy of */
/* EPS*|T| irrespective of ABSTOL. If high relative accuracy */
/* is important, set ABSTOL to DLAMCH( 'Safe minimum' ). */
/* See Barlow and 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) 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 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 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). */
/* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) ) */
/* The support of the eigenvectors in Z, i.e., the indices */
/* indicating the nonzero elements in Z. The i-th eigenvector */
/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */
/* ISUPPZ( 2*i ). */
/* WORK (workspace/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 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 LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal size of the IWORK array, */
/* returns this value as the first entry of the IWORK array, and */
/* no error message related to LIWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = 1, internal error in SLARRE, */
/* if INFO = 2, internal error in CLARRV. */
/* 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 */
/* ===================================================================== */
/* .. 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", (ftnlen)1, (ftnlen)1);
alleig = lsame_(range, "A", (ftnlen)1, (ftnlen)1);
valeig = lsame_(range, "V", (ftnlen)1, (ftnlen)1);
indeig = lsame_(range, "I", (ftnlen)1, (ftnlen)1);
lquery = *lwork == -1 || *liwork == -1;
lwmin = *n * 18;
liwmin = *n * 10;
*info = 0;
if (! (wantz || lsame_(jobz, "N", (ftnlen)1, (ftnlen)1))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
/* The following two lines need to be removed once the */
/* RANGE = 'V' and RANGE = 'I' options are provided. */
} else if (valeig || indeig) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (valeig && *n > 0 && *vu <= *vl) {
*info = -7;
} else if (indeig && *il < 1) {
*info = -8;
/* The following change should be made in DSTEVX also, otherwise */
/* IL can be specified as N+1 and IU as N. */
/* ELSE IF( INDEIG .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) THEN */
} else if (indeig && (*iu < *il || *iu > *n)) {
*info = -9;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -14;
} else if (*lwork < lwmin && ! lquery) {
*info = -17;
} else if (*liwork < liwmin && ! lquery) {
*info = -19;
}
if (*info == 0) {
work[1] = (real) lwmin;
iwork[1] = liwmin;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CSTEGR", &i__1, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (alleig || indeig) {
*m = 1;
w[1] = d__[1];
} else {
if (*vl < d__[1] && *vu >= d__[1]) {
*m = 1;
w[1] = d__[1];
}
}
if (wantz) {
i__1 = z_dim1 + 1;
z__[i__1].r = 1.f, z__[i__1].i = 0.f;
}
return 0;
}
/* Get machine constants. */
safmin = slamch_("Safe minimum", (ftnlen)12);
eps = slamch_("Precision", (ftnlen)9);
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. */
scale = 1.f;
tnrm = slanst_("M", n, &d__[1], &e[1], (ftnlen)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;
}
indgrs = 1;
indwof = (*n << 1) + 1;
indwrk = *n * 3 + 1;
iinspl = 1;
iindbl = *n + 1;
iindwk = (*n << 1) + 1;
claset_("Full", n, n, &c_b1, &c_b1, &z__[z_offset], ldz, (ftnlen)4);
/* Compute the desired eigenvalues of the tridiagonal after splitting */
/* into smaller subblocks if the corresponding of-diagonal elements */
/* are small */
thresh = eps * tnrm;
slarre_(n, &d__[1], &e[1], &thresh, &nsplit, &iwork[iinspl], m, &w[1], &
work[indwof], &work[indgrs], &work[indwrk], &iinfo);
if (iinfo != 0) {
*info = 1;
return 0;
}
if (wantz) {
/* Compute the desired eigenvectors corresponding to the computed */
/* eigenvalues */
/* Computing MAX */
r__1 = *abstol, r__2 = (real) (*n) * thresh;
tol = dmax(r__1,r__2);
ibegin = 1;
i__1 = nsplit;
for (i__ = 1; i__ <= i__1; ++i__) {
iend = iwork[iinspl + i__ - 1];
i__2 = iend;
for (j = ibegin; j <= i__2; ++j) {
iwork[iindbl + j - 1] = i__;
/* L10: */
}
ibegin = iend + 1;
/* L20: */
}
clarrv_(n, &d__[1], &e[1], &iwork[iinspl], m, &w[1], &iwork[iindbl], &
work[indgrs], &tol, &z__[z_offset], ldz, &isuppz[1], &work[
indwrk], &iwork[iindwk], &iinfo);
if (iinfo != 0) {
*info = 2;
return 0;
}
}
ibegin = 1;
i__1 = nsplit;
for (i__ = 1; i__ <= i__1; ++i__) {
iend = iwork[iinspl + i__ - 1];
i__2 = iend;
for (j = ibegin; j <= i__2; ++j) {
w[j] += work[indwof + i__ - 1];
/* L30: */
}
ibegin = iend + 1;
/* L40: */
}
/* 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 order, then sort them, along with */
/* eigenvectors. */
if (nsplit > 1) {
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) {
cswap_(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 CSTEGR */
} /* cstegr_ */
/* Subroutine */ int zsteqr_(char *compz, integer *n, doublereal *d,
doublereal *e, doublecomplex *z, integer *ldz, doublereal *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
September 30, 1994
Purpose
=======
ZSTEQR computes all eigenvalues and, optionally, eigenvectors of a
symmetric tridiagonal matrix using the implicit QL or QR method.
The eigenvectors of a full or band complex Hermitian matrix can also
be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this
matrix to tridiagonal form.
Arguments
=========
COMPZ (input) CHARACTER*1
= 'N': Compute eigenvalues only.
= 'V': Compute eigenvalues and eigenvectors of the original
Hermitian matrix. On entry, Z must contain the
unitary matrix used to reduce the original matrix
to tridiagonal form.
= 'I': Compute eigenvalues and eigenvectors of the
tridiagonal matrix. Z is initialized to the identity
matrix.
N (input) INTEGER
The order of the matrix. N >= 0.
D (input/output) DOUBLE PRECISION array, dimension (N)
On entry, the diagonal elements of the tridiagonal matrix.
On exit, if INFO = 0, the eigenvalues in ascending order.
E (input/output) DOUBLE PRECISION array, dimension (N-1)
On entry, the (n-1) subdiagonal elements of the tridiagonal
matrix.
On exit, E has been destroyed.
Z (input/output) COMPLEX*16 array, dimension (LDZ, N)
On entry, if COMPZ = 'V', then Z contains the unitary
matrix used in the reduction to tridiagonal form.
On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
orthonormal eigenvectors of the original Hermitian matrix,
and if COMPZ = 'I', Z contains the orthonormal eigenvectors
of the symmetric tridiagonal matrix.
If COMPZ = 'N', then Z is not referenced.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1, and if
eigenvectors are desired, then LDZ >= max(1,N).
WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))
If COMPZ = 'N', then WORK is not referenced.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: the algorithm has failed to find all the eigenvalues in
a total of 30*N iterations; if INFO = i, then i
elements of E have not converged to zero; on exit, D
and E contain the elements of a symmetric tridiagonal
matrix which is unitarily similar to the original
matrix.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static doublecomplex c_b1 = {0.,0.};
static doublecomplex c_b2 = {1.,0.};
static integer c__0 = 0;
static integer c__1 = 1;
static integer c__2 = 2;
static doublereal c_b41 = 1.;
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
static integer lend, jtot;
extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *);
static doublereal b, c, f, g;
static integer i, j, k, l, m;
static doublereal p, r, s;
extern logical lsame_(char *, char *);
static doublereal anorm;
extern /* Subroutine */ int zlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublecomplex *, integer *);
static integer l1;
extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), dlaev2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
static integer lendm1, lendp1;
extern doublereal dlapy2_(doublereal *, doublereal *);
static integer ii;
extern doublereal dlamch_(char *);
static integer mm, iscale;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
static doublereal safmin;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
static doublereal safmax;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
integer *);
static integer lendsv;
static doublereal ssfmin;
static integer nmaxit, icompz;
static doublereal ssfmax;
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
static integer lm1, mm1, nm1;
static doublereal rt1, rt2, eps;
static integer lsv;
static doublereal tst, eps2;
#define D(I) d[(I)-1]
#define E(I) e[(I)-1]
#define WORK(I) work[(I)-1]
#define Z(I,J) z[(I)-1 + ((J)-1)* ( *ldz)]
*info = 0;
if (lsame_(compz, "N")) {
icompz = 0;
} else if (lsame_(compz, "V")) {
icompz = 1;
} else if (lsame_(compz, "I")) {
icompz = 2;
} else {
icompz = -1;
}
if (icompz < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZSTEQR", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz == 2) {
i__1 = z_dim1 + 1;
Z(1,1).r = 1., Z(1,1).i = 0.;
}
return 0;
}
/* Determine the unit roundoff and over/underflow thresholds. */
eps = dlamch_("E");
/* Computing 2nd power */
d__1 = eps;
eps2 = d__1 * d__1;
safmin = dlamch_("S");
safmax = 1. / safmin;
ssfmax = sqrt(safmax) / 3.;
ssfmin = sqrt(safmin) / eps2;
/* Compute the eigenvalues and eigenvectors of the tridiagonal
matrix. */
if (icompz == 2) {
zlaset_("Full", n, n, &c_b1, &c_b2, &Z(1,1), ldz);
}
nmaxit = *n * 30;
jtot = 0;
/* Determine where the matrix splits and choose QL or QR iteration
for each block, according to whether top or bottom diagonal
element is smaller. */
l1 = 1;
nm1 = *n - 1;
L10:
if (l1 > *n) {
goto L160;
}
if (l1 > 1) {
E(l1 - 1) = 0.;
}
if (l1 <= nm1) {
i__1 = nm1;
for (m = l1; m <= nm1; ++m) {
tst = (d__1 = E(m), abs(d__1));
if (tst == 0.) {
goto L30;
}
if (tst <= sqrt((d__1 = D(m), abs(d__1))) * sqrt((d__2 = D(m + 1),
abs(d__2))) * eps) {
E(m) = 0.;
goto L30;
}
/* L20: */
}
}
m = *n;
L30:
l = l1;
lsv = l;
lend = m;
lendsv = lend;
l1 = m + 1;
if (lend == l) {
goto L10;
}
/* Scale submatrix in rows and columns L to LEND */
i__1 = lend - l + 1;
anorm = dlanst_("I", &i__1, &D(l), &E(l));
iscale = 0;
if (anorm == 0.) {
goto L10;
}
if (anorm > ssfmax) {
iscale = 1;
i__1 = lend - l + 1;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &D(l), n,
info);
i__1 = lend - l;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &E(l), n,
info);
} else if (anorm < ssfmin) {
iscale = 2;
i__1 = lend - l + 1;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &D(l), n,
info);
i__1 = lend - l;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &E(l), n,
info);
}
/* Choose between QL and QR iteration */
if ((d__1 = D(lend), abs(d__1)) < (d__2 = D(l), abs(d__2))) {
lend = lsv;
l = lendsv;
}
if (lend > l) {
/* QL Iteration
Look for small subdiagonal element. */
L40:
if (l != lend) {
lendm1 = lend - 1;
i__1 = lendm1;
for (m = l; m <= lendm1; ++m) {
/* Computing 2nd power */
d__2 = (d__1 = E(m), abs(d__1));
tst = d__2 * d__2;
if (tst <= eps2 * (d__1 = D(m), abs(d__1)) * (d__2 = D(m + 1),
abs(d__2)) + safmin) {
goto L60;
}
/* L50: */
}
}
m = lend;
L60:
if (m < lend) {
E(m) = 0.;
}
p = D(l);
if (m == l) {
goto L80;
}
/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
to compute its eigensystem. */
if (m == l + 1) {
if (icompz > 0) {
dlaev2_(&D(l), &E(l), &D(l + 1), &rt1, &rt2, &c, &s);
WORK(l) = c;
WORK(*n - 1 + l) = s;
zlasr_("R", "V", "B", n, &c__2, &WORK(l), &WORK(*n - 1 + l), &
Z(1,l), ldz);
} else {
dlae2_(&D(l), &E(l), &D(l + 1), &rt1, &rt2);
}
D(l) = rt1;
D(l + 1) = rt2;
E(l) = 0.;
l += 2;
if (l <= lend) {
goto L40;
}
goto L140;
}
if (jtot == nmaxit) {
goto L140;
}
++jtot;
/* Form shift. */
g = (D(l + 1) - p) / (E(l) * 2.);
r = dlapy2_(&g, &c_b41);
g = D(m) - p + E(l) / (g + d_sign(&r, &g));
s = 1.;
c = 1.;
p = 0.;
/* Inner loop */
mm1 = m - 1;
i__1 = l;
for (i = mm1; i >= l; --i) {
f = s * E(i);
b = c * E(i);
dlartg_(&g, &f, &c, &s, &r);
if (i != m - 1) {
E(i + 1) = r;
}
g = D(i + 1) - p;
r = (D(i) - g) * s + c * 2. * b;
p = s * r;
D(i + 1) = g + p;
g = c * r - b;
/* If eigenvectors are desired, then save rotations. */
if (icompz > 0) {
WORK(i) = c;
WORK(*n - 1 + i) = -s;
}
/* L70: */
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0) {
mm = m - l + 1;
zlasr_("R", "V", "B", n, &mm, &WORK(l), &WORK(*n - 1 + l), &Z(1,l), ldz);
}
D(l) -= p;
E(l) = g;
goto L40;
/* Eigenvalue found. */
L80:
D(l) = p;
++l;
if (l <= lend) {
goto L40;
}
goto L140;
} else {
/* QR Iteration
Look for small superdiagonal element. */
L90:
if (l != lend) {
lendp1 = lend + 1;
i__1 = lendp1;
for (m = l; m >= lendp1; --m) {
/* Computing 2nd power */
d__2 = (d__1 = E(m - 1), abs(d__1));
tst = d__2 * d__2;
if (tst <= eps2 * (d__1 = D(m), abs(d__1)) * (d__2 = D(m - 1),
abs(d__2)) + safmin) {
goto L110;
}
/* L100: */
}
}
m = lend;
L110:
if (m > lend) {
E(m - 1) = 0.;
}
p = D(l);
if (m == l) {
goto L130;
}
/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
to compute its eigensystem. */
if (m == l - 1) {
if (icompz > 0) {
dlaev2_(&D(l - 1), &E(l - 1), &D(l), &rt1, &rt2, &c, &s);
WORK(m) = c;
WORK(*n - 1 + m) = s;
zlasr_("R", "V", "F", n, &c__2, &WORK(m), &WORK(*n - 1 + m), &
Z(1,l-1), ldz);
} else {
dlae2_(&D(l - 1), &E(l - 1), &D(l), &rt1, &rt2);
}
D(l - 1) = rt1;
D(l) = rt2;
E(l - 1) = 0.;
l += -2;
if (l >= lend) {
goto L90;
}
goto L140;
}
if (jtot == nmaxit) {
goto L140;
}
++jtot;
/* Form shift. */
g = (D(l - 1) - p) / (E(l - 1) * 2.);
r = dlapy2_(&g, &c_b41);
g = D(m) - p + E(l - 1) / (g + d_sign(&r, &g));
s = 1.;
c = 1.;
p = 0.;
/* Inner loop */
lm1 = l - 1;
i__1 = lm1;
for (i = m; i <= lm1; ++i) {
f = s * E(i);
b = c * E(i);
dlartg_(&g, &f, &c, &s, &r);
if (i != m) {
E(i - 1) = r;
}
g = D(i) - p;
r = (D(i + 1) - g) * s + c * 2. * b;
p = s * r;
D(i) = g + p;
g = c * r - b;
/* If eigenvectors are desired, then save rotations. */
if (icompz > 0) {
WORK(i) = c;
WORK(*n - 1 + i) = s;
}
/* L120: */
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0) {
mm = l - m + 1;
zlasr_("R", "V", "F", n, &mm, &WORK(m), &WORK(*n - 1 + m), &Z(1,m), ldz);
}
D(l) -= p;
E(lm1) = g;
goto L90;
/* Eigenvalue found. */
L130:
D(l) = p;
--l;
if (l >= lend) {
goto L90;
}
goto L140;
}
/* Undo scaling if necessary */
L140:
if (iscale == 1) {
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &D(lsv), n,
info);
i__1 = lendsv - lsv;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &E(lsv), n,
info);
} else if (iscale == 2) {
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &D(lsv), n,
info);
i__1 = lendsv - lsv;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &E(lsv), n,
info);
}
/* Check for no convergence to an eigenvalue after a total
of N*MAXIT iterations. */
if (jtot == nmaxit) {
i__1 = *n - 1;
for (i = 1; i <= *n-1; ++i) {
if (E(i) != 0.) {
++(*info);
}
/* L150: */
}
return 0;
}
goto L10;
/* Order eigenvalues and eigenvectors. */
L160:
if (icompz == 0) {
/* Use Quick Sort */
dlasrt_("I", n, &D(1), info);
} else {
/* Use Selection Sort to minimize swaps of eigenvectors */
i__1 = *n;
for (ii = 2; ii <= *n; ++ii) {
i = ii - 1;
k = i;
p = D(i);
i__2 = *n;
for (j = ii; j <= *n; ++j) {
if (D(j) < p) {
k = j;
p = D(j);
}
/* L170: */
}
if (k != i) {
D(k) = D(i);
D(i) = p;
zswap_(n, &Z(1,i), &c__1, &Z(1,k), &
c__1);
}
/* L180: */
}
}
return 0;
/* End of ZSTEQR */
} /* zsteqr_ */
int cgelsy_(int *m, int *n, int *nrhs, complex *
a, int *lda, complex *b, int *ldb, int *jpvt, float *rcond,
int *rank, complex *work, int *lwork, float *rwork, int *
info)
{
/* System generated locals */
int a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
float r__1, r__2;
complex q__1;
/* Builtin functions */
double c_abs(complex *);
/* Local variables */
int i__, j;
complex c1, c2, s1, s2;
int nb, mn, nb1, nb2, nb3, nb4;
float anrm, bnrm, smin, smax;
int iascl, ibscl;
extern int ccopy_(int *, complex *, int *,
complex *, int *);
int ismin, ismax;
extern int ctrsm_(char *, char *, char *, char *,
int *, int *, complex *, complex *, int *, complex *,
int *), claic1_(int *,
int *, complex *, float *, complex *, complex *, float *,
complex *, complex *);
float wsize;
extern int cgeqp3_(int *, int *, complex *,
int *, int *, complex *, complex *, int *, float *,
int *), slabad_(float *, float *);
extern double clange_(char *, int *, int *, complex *,
int *, float *);
extern int clascl_(char *, int *, int *, float *,
float *, int *, int *, complex *, int *, int *);
extern double slamch_(char *);
extern int claset_(char *, int *, int *, complex
*, complex *, complex *, int *), xerbla_(char *,
int *);
extern int ilaenv_(int *, char *, char *, int *, int *,
int *, int *);
float bignum;
extern int cunmqr_(char *, char *, int *, int *,
int *, complex *, int *, complex *, complex *, int *,
complex *, int *, int *);
float sminpr, smaxpr, smlnum;
extern int cunmrz_(char *, char *, int *, int *,
int *, int *, complex *, int *, complex *, complex *,
int *, complex *, int *, int *);
int lwkopt;
int lquery;
extern int ctzrzf_(int *, int *, complex *,
int *, complex *, complex *, int *, int *);
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGELSY computes the minimum-norm solution to a complex linear least */
/* squares problem: */
/* minimize || A * X - B || */
/* using a complete orthogonal factorization of A. A is an M-by-N */
/* matrix which may be rank-deficient. */
/* Several right hand side vectors b and solution vectors x can be */
/* handled in a single call; they are stored as the columns of the */
/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
/* matrix X. */
/* The routine first computes a QR factorization with column pivoting: */
/* A * P = Q * [ R11 R12 ] */
/* [ 0 R22 ] */
/* with R11 defined as the largest leading submatrix whose estimated */
/* condition number is less than 1/RCOND. The order of R11, RANK, */
/* is the effective rank of A. */
/* Then, R22 is considered to be negligible, and R12 is annihilated */
/* by unitary transformations from the right, arriving at the */
/* complete orthogonal factorization: */
/* A * P = Q * [ T11 0 ] * Z */
/* [ 0 0 ] */
/* The minimum-norm solution is then */
/* X = P * Z' [ inv(T11)*Q1'*B ] */
/* [ 0 ] */
/* where Q1 consists of the first RANK columns of Q. */
/* This routine is basically identical to the original xGELSX except */
/* three differences: */
/* o The permutation of matrix B (the right hand side) is faster and */
/* more simple. */
/* o The call to the subroutine xGEQPF has been substituted by the */
/* the call to the subroutine xGEQP3. This subroutine is a Blas-3 */
/* version of the QR factorization with column pivoting. */
/* o Matrix B (the right hand side) is updated with Blas-3. */
/* 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. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of */
/* columns of matrices B and X. NRHS >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, A has been overwritten by details of its */
/* complete orthogonal factorization. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,M). */
/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
/* On entry, the M-by-NRHS right hand side matrix B. */
/* On exit, the N-by-NRHS solution matrix X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= MAX(1,M,N). */
/* JPVT (input/output) INTEGER array, dimension (N) */
/* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */
/* to the front of AP, otherwise column i is a free column. */
/* On exit, if JPVT(i) = k, then the i-th column of A*P */
/* was the k-th column of A. */
/* RCOND (input) REAL */
/* RCOND is used to determine the effective rank of A, which */
/* is defined as the order of the largest leading triangular */
/* submatrix R11 in the QR factorization with pivoting of A, */
/* whose estimated condition number < 1/RCOND. */
/* RANK (output) INTEGER */
/* The effective rank of A, i.e., the order of the submatrix */
/* R11. This is the same as the order of the submatrix T11 */
/* in the complete orthogonal factorization of A. */
/* WORK (workspace/output) COMPLEX 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. */
/* The unblocked strategy requires that: */
/* LWORK >= MN + MAX( 2*MN, N+1, MN+NRHS ) */
/* where MN = MIN(M,N). */
/* The block algorithm requires that: */
/* LWORK >= MN + MAX( 2*MN, NB*(N+1), MN+MN*NB, MN+NB*NRHS ) */
/* where NB is an upper bound on the blocksize returned */
/* by ILAENV for the routines CGEQP3, CTZRZF, CTZRQF, CUNMQR, */
/* and CUNMRZ. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* RWORK (workspace) REAL array, dimension (2*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
/* E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--jpvt;
--work;
--rwork;
/* Function Body */
mn = MIN(*m,*n);
ismin = mn + 1;
ismax = (mn << 1) + 1;
/* Test the input arguments. */
*info = 0;
nb1 = ilaenv_(&c__1, "CGEQRF", " ", m, n, &c_n1, &c_n1);
nb2 = ilaenv_(&c__1, "CGERQF", " ", m, n, &c_n1, &c_n1);
nb3 = ilaenv_(&c__1, "CUNMQR", " ", m, n, nrhs, &c_n1);
nb4 = ilaenv_(&c__1, "CUNMRQ", " ", m, n, nrhs, &c_n1);
/* Computing MAX */
i__1 = MAX(nb1,nb2), i__1 = MAX(i__1,nb3);
nb = MAX(i__1,nb4);
/* Computing MAX */
i__1 = 1, i__2 = mn + (*n << 1) + nb * (*n + 1), i__1 = MAX(i__1,i__2),
i__2 = (mn << 1) + nb * *nrhs;
lwkopt = MAX(i__1,i__2);
q__1.r = (float) lwkopt, q__1.i = 0.f;
work[1].r = q__1.r, work[1].i = q__1.i;
lquery = *lwork == -1;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < MAX(1,*m)) {
*info = -5;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = MAX(1,*m);
if (*ldb < MAX(i__1,*n)) {
*info = -7;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = mn << 1, i__2 = *n + 1, i__1 = MAX(i__1,i__2), i__2 = mn +
*nrhs;
if (*lwork < mn + MAX(i__1,i__2) && ! lquery) {
*info = -12;
}
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGELSY", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
/* Computing MIN */
i__1 = MIN(*m,*n);
if (MIN(i__1,*nrhs) == 0) {
*rank = 0;
return 0;
}
/* Get machine parameters */
smlnum = slamch_("S") / slamch_("P");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
/* Scale A, B if max entries outside range [SMLNUM,BIGNUM] */
anrm = clange_("M", m, n, &a[a_offset], lda, &rwork[1]);
iascl = 0;
if (anrm > 0.f && anrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
clascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
info);
iascl = 1;
} else if (anrm > bignum) {
/* Scale matrix norm down to BIGNUM */
clascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
info);
iascl = 2;
} else if (anrm == 0.f) {
/* Matrix all zero. Return zero solution. */
i__1 = MAX(*m,*n);
claset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
*rank = 0;
goto L70;
}
bnrm = clange_("M", m, nrhs, &b[b_offset], ldb, &rwork[1]);
ibscl = 0;
if (bnrm > 0.f && bnrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
clascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
info);
ibscl = 1;
} else if (bnrm > bignum) {
/* Scale matrix norm down to BIGNUM */
clascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
info);
ibscl = 2;
}
/* Compute QR factorization with column pivoting of A: */
/* A * P = Q * R */
i__1 = *lwork - mn;
cgeqp3_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], &i__1,
&rwork[1], info);
i__1 = mn + 1;
wsize = mn + work[i__1].r;
/* complex workspace: MN+NB*(N+1). float workspace 2*N. */
/* Details of Householder rotations stored in WORK(1:MN). */
/* Determine RANK using incremental condition estimation */
i__1 = ismin;
work[i__1].r = 1.f, work[i__1].i = 0.f;
i__1 = ismax;
work[i__1].r = 1.f, work[i__1].i = 0.f;
smax = c_abs(&a[a_dim1 + 1]);
smin = smax;
if (c_abs(&a[a_dim1 + 1]) == 0.f) {
*rank = 0;
i__1 = MAX(*m,*n);
claset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
goto L70;
} else {
*rank = 1;
}
L10:
if (*rank < mn) {
i__ = *rank + 1;
claic1_(&c__2, rank, &work[ismin], &smin, &a[i__ * a_dim1 + 1], &a[
i__ + i__ * a_dim1], &sminpr, &s1, &c1);
claic1_(&c__1, rank, &work[ismax], &smax, &a[i__ * a_dim1 + 1], &a[
i__ + i__ * a_dim1], &smaxpr, &s2, &c2);
if (smaxpr * *rcond <= sminpr) {
i__1 = *rank;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = ismin + i__ - 1;
i__3 = ismin + i__ - 1;
q__1.r = s1.r * work[i__3].r - s1.i * work[i__3].i, q__1.i =
s1.r * work[i__3].i + s1.i * work[i__3].r;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
i__2 = ismax + i__ - 1;
i__3 = ismax + i__ - 1;
q__1.r = s2.r * work[i__3].r - s2.i * work[i__3].i, q__1.i =
s2.r * work[i__3].i + s2.i * work[i__3].r;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L20: */
}
i__1 = ismin + *rank;
work[i__1].r = c1.r, work[i__1].i = c1.i;
i__1 = ismax + *rank;
work[i__1].r = c2.r, work[i__1].i = c2.i;
smin = sminpr;
smax = smaxpr;
++(*rank);
goto L10;
}
}
/* complex workspace: 3*MN. */
/* Logically partition R = [ R11 R12 ] */
/* [ 0 R22 ] */
/* where R11 = R(1:RANK,1:RANK) */
/* [R11,R12] = [ T11, 0 ] * Y */
if (*rank < *n) {
i__1 = *lwork - (mn << 1);
ctzrzf_(rank, n, &a[a_offset], lda, &work[mn + 1], &work[(mn << 1) +
1], &i__1, info);
}
/* complex workspace: 2*MN. */
/* Details of Householder rotations stored in WORK(MN+1:2*MN) */
/* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */
i__1 = *lwork - (mn << 1);
cunmqr_("Left", "Conjugate transpose", m, nrhs, &mn, &a[a_offset], lda, &
work[1], &b[b_offset], ldb, &work[(mn << 1) + 1], &i__1, info);
/* Computing MAX */
i__1 = (mn << 1) + 1;
r__1 = wsize, r__2 = (mn << 1) + work[i__1].r;
wsize = MAX(r__1,r__2);
/* complex workspace: 2*MN+NB*NRHS. */
/* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */
ctrsm_("Left", "Upper", "No transpose", "Non-unit", rank, nrhs, &c_b2, &a[
a_offset], lda, &b[b_offset], ldb);
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = *rank + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
b[i__3].r = 0.f, b[i__3].i = 0.f;
/* L30: */
}
/* L40: */
}
/* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS) */
if (*rank < *n) {
i__1 = *n - *rank;
i__2 = *lwork - (mn << 1);
cunmrz_("Left", "Conjugate transpose", n, nrhs, rank, &i__1, &a[
a_offset], lda, &work[mn + 1], &b[b_offset], ldb, &work[(mn <<
1) + 1], &i__2, info);
}
/* complex workspace: 2*MN+NRHS. */
/* B(1:N,1:NRHS) := P * B(1:N,1:NRHS) */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = jpvt[i__];
i__4 = i__ + j * b_dim1;
work[i__3].r = b[i__4].r, work[i__3].i = b[i__4].i;
/* L50: */
}
ccopy_(n, &work[1], &c__1, &b[j * b_dim1 + 1], &c__1);
/* L60: */
}
/* complex workspace: N. */
/* Undo scaling */
if (iascl == 1) {
clascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
info);
clascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset],
lda, info);
} else if (iascl == 2) {
clascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
info);
clascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset],
lda, info);
}
if (ibscl == 1) {
clascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
info);
} else if (ibscl == 2) {
clascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
info);
}
L70:
q__1.r = (float) lwkopt, q__1.i = 0.f;
work[1].r = q__1.r, work[1].i = q__1.i;
return 0;
/* End of CGELSY */
} /* cgelsy_ */
/* Subroutine */ int chbmv_(char *uplo, integer *n, integer *k, complex *
alpha, complex *a, integer *lda, complex *x, integer *incx, complex *
beta, complex *y, integer *incy, ftnlen uplo_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
real r__1;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
void r_cnjg(complex *, complex *);
/* Local variables */
integer i__, j, l, ix, iy, jx, jy, kx, ky, info;
complex temp1, temp2;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer kplus1;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHBMV performs the matrix-vector operation */
/* y := alpha*A*x + beta*y, */
/* where alpha and beta are scalars, x and y are n element vectors and */
/* A is an n by n hermitian band matrix, with k super-diagonals. */
/* Arguments */
/* ========== */
/* UPLO - CHARACTER*1. */
/* On entry, UPLO specifies whether the upper or lower */
/* triangular part of the band matrix A is being supplied as */
/* follows: */
/* UPLO = 'U' or 'u' The upper triangular part of A is */
/* being supplied. */
/* UPLO = 'L' or 'l' The lower triangular part of A is */
/* being supplied. */
/* Unchanged on exit. */
/* N - INTEGER. */
/* On entry, N specifies the order of the matrix A. */
/* N must be at least zero. */
/* Unchanged on exit. */
/* K - INTEGER. */
/* On entry, K specifies the number of super-diagonals of the */
/* matrix A. K must satisfy 0 .le. K. */
/* Unchanged on exit. */
/* ALPHA - COMPLEX . */
/* On entry, ALPHA specifies the scalar alpha. */
/* Unchanged on exit. */
/* A - COMPLEX array of DIMENSION ( LDA, n ). */
/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
/* by n part of the array A must contain the upper triangular */
/* band part of the hermitian matrix, supplied column by */
/* column, with the leading diagonal of the matrix in row */
/* ( k + 1 ) of the array, the first super-diagonal starting at */
/* position 2 in row k, and so on. The top left k by k triangle */
/* of the array A is not referenced. */
/* The following program segment will transfer the upper */
/* triangular part of a hermitian band matrix from conventional */
/* full matrix storage to band storage: */
/* DO 20, J = 1, N */
/* M = K + 1 - J */
/* DO 10, I = MAX( 1, J - K ), J */
/* A( M + I, J ) = matrix( I, J ) */
/* 10 CONTINUE */
/* 20 CONTINUE */
/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
/* by n part of the array A must contain the lower triangular */
/* band part of the hermitian matrix, supplied column by */
/* column, with the leading diagonal of the matrix in row 1 of */
/* the array, the first sub-diagonal starting at position 1 in */
/* row 2, and so on. The bottom right k by k triangle of the */
/* array A is not referenced. */
/* The following program segment will transfer the lower */
/* triangular part of a hermitian band matrix from conventional */
/* full matrix storage to band storage: */
/* DO 20, J = 1, N */
/* M = 1 - J */
/* DO 10, I = J, MIN( N, J + K ) */
/* A( M + I, J ) = matrix( I, J ) */
/* 10 CONTINUE */
/* 20 CONTINUE */
/* Note that the imaginary parts of the diagonal elements need */
/* not be set and are assumed to be zero. */
/* Unchanged on exit. */
/* LDA - INTEGER. */
/* On entry, LDA specifies the first dimension of A as declared */
/* in the calling (sub) program. LDA must be at least */
/* ( k + 1 ). */
/* Unchanged on exit. */
/* X - COMPLEX array of DIMENSION at least */
/* ( 1 + ( n - 1 )*abs( INCX ) ). */
/* Before entry, the incremented array X must contain the */
/* vector x. */
/* Unchanged on exit. */
/* INCX - INTEGER. */
/* On entry, INCX specifies the increment for the elements of */
/* X. INCX must not be zero. */
/* Unchanged on exit. */
/* BETA - COMPLEX . */
/* On entry, BETA specifies the scalar beta. */
/* Unchanged on exit. */
/* Y - COMPLEX array of DIMENSION at least */
/* ( 1 + ( n - 1 )*abs( INCY ) ). */
/* Before entry, the incremented array Y must contain the */
/* vector y. On exit, Y is overwritten by the updated vector y. */
/* INCY - INTEGER. */
/* On entry, INCY specifies the increment for the elements of */
/* Y. INCY must not be zero. */
/* Unchanged on exit. */
/* Further Details */
/* =============== */
/* Level 2 Blas routine. */
/* -- Written on 22-October-1986. */
/* Jack Dongarra, Argonne National Lab. */
/* Jeremy Du Croz, Nag Central Office. */
/* Sven Hammarling, Nag Central Office. */
/* Richard Hanson, Sandia National Labs. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--x;
--y;
/* Function Body */
info = 0;
if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (*n < 0) {
info = 2;
} else if (*k < 0) {
info = 3;
} else if (*lda < *k + 1) {
info = 6;
} else if (*incx == 0) {
info = 8;
} else if (*incy == 0) {
info = 11;
}
if (info != 0) {
xerbla_("CHBMV ", &info, (ftnlen)6);
return 0;
}
/* Quick return if possible. */
if (*n == 0 || (alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f &&
beta->i == 0.f))) {
return 0;
}
/* Set up the start points in X and Y. */
if (*incx > 0) {
kx = 1;
} else {
kx = 1 - (*n - 1) * *incx;
}
if (*incy > 0) {
ky = 1;
} else {
ky = 1 - (*n - 1) * *incy;
}
/* Start the operations. In this version the elements of the array A */
/* are accessed sequentially with one pass through A. */
/* First form y := beta*y. */
if (beta->r != 1.f || beta->i != 0.f) {
if (*incy == 1) {
if (beta->r == 0.f && beta->i == 0.f) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
y[i__2].r = 0.f, y[i__2].i = 0.f;
/* L10: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__;
q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
.r;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
/* L20: */
}
}
} else {
iy = ky;
if (beta->r == 0.f && beta->i == 0.f) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iy;
y[i__2].r = 0.f, y[i__2].i = 0.f;
iy += *incy;
/* L30: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iy;
i__3 = iy;
q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
.r;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
iy += *incy;
/* L40: */
}
}
}
}
if (alpha->r == 0.f && alpha->i == 0.f) {
return 0;
}
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/* Form y when upper triangle of A is stored. */
kplus1 = *k + 1;
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f;
l = kplus1 - j;
/* Computing MAX */
i__2 = 1, i__3 = j - *k;
i__4 = j - 1;
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
i__2 = i__;
i__3 = i__;
i__5 = l + i__ + j * a_dim1;
q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
.r;
q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
i__2 = i__;
q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i, q__2.i =
q__3.r * x[i__2].i + q__3.i * x[i__2].r;
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
temp2.r = q__1.r, temp2.i = q__1.i;
/* L50: */
}
i__4 = j;
i__2 = j;
i__3 = kplus1 + j * a_dim1;
r__1 = a[i__3].r;
q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i;
q__2.r = y[i__2].r + q__3.r, q__2.i = y[i__2].i + q__3.i;
q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
alpha->r * temp2.i + alpha->i * temp2.r;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
y[i__4].r = q__1.r, y[i__4].i = q__1.i;
/* L60: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__4 = jx;
q__1.r = alpha->r * x[i__4].r - alpha->i * x[i__4].i, q__1.i =
alpha->r * x[i__4].i + alpha->i * x[i__4].r;
temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f;
ix = kx;
iy = ky;
l = kplus1 - j;
/* Computing MAX */
i__4 = 1, i__2 = j - *k;
i__3 = j - 1;
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
i__4 = iy;
i__2 = iy;
i__5 = l + i__ + j * a_dim1;
q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
.r;
q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i;
y[i__4].r = q__1.r, y[i__4].i = q__1.i;
r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
i__4 = ix;
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 = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
temp2.r = q__1.r, temp2.i = q__1.i;
ix += *incx;
iy += *incy;
/* L70: */
}
i__3 = jy;
i__4 = jy;
i__2 = kplus1 + j * a_dim1;
r__1 = a[i__2].r;
q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i;
q__2.r = y[i__4].r + q__3.r, q__2.i = y[i__4].i + q__3.i;
q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
alpha->r * temp2.i + alpha->i * temp2.r;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
jx += *incx;
jy += *incy;
if (j > *k) {
kx += *incx;
ky += *incy;
}
/* L80: */
}
}
} else {
/* Form y when lower triangle of A is stored. */
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__3 = j;
q__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, q__1.i =
alpha->r * x[i__3].i + alpha->i * x[i__3].r;
temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f;
i__3 = j;
i__4 = j;
i__2 = j * a_dim1 + 1;
r__1 = a[i__2].r;
q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
l = 1 - j;
/* Computing MIN */
i__4 = *n, i__2 = j + *k;
i__3 = min(i__4,i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) {
i__4 = i__;
i__2 = i__;
i__5 = l + i__ + j * a_dim1;
q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
.r;
q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i;
y[i__4].r = q__1.r, y[i__4].i = q__1.i;
r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
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;
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
temp2.r = q__1.r, temp2.i = q__1.i;
/* L90: */
}
i__3 = j;
i__4 = j;
q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
alpha->r * temp2.i + alpha->i * temp2.r;
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
/* L100: */
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__3 = jx;
q__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, q__1.i =
alpha->r * x[i__3].i + alpha->i * x[i__3].r;
temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f;
i__3 = jy;
i__4 = jy;
i__2 = j * a_dim1 + 1;
r__1 = a[i__2].r;
q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
l = 1 - j;
ix = jx;
iy = jy;
/* Computing MIN */
i__4 = *n, i__2 = j + *k;
i__3 = min(i__4,i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) {
ix += *incx;
iy += *incy;
i__4 = iy;
i__2 = iy;
i__5 = l + i__ + j * a_dim1;
q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
.r;
q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i;
y[i__4].r = q__1.r, y[i__4].i = q__1.i;
r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
i__4 = ix;
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 = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
temp2.r = q__1.r, temp2.i = q__1.i;
/* L110: */
}
i__3 = jy;
i__4 = jy;
q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
alpha->r * temp2.i + alpha->i * temp2.r;
q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
y[i__3].r = q__1.r, y[i__3].i = q__1.i;
jx += *incx;
jy += *incy;
/* L120: */
}
}
}
return 0;
/* End of CHBMV . */
} /* chbmv_ */