/* Subroutine */ int igraphdstebz_(char *range, char *order, integer *n, doublereal
*vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol,
doublereal *d__, doublereal *e, integer *m, integer *nsplit,
doublereal *w, integer *iblock, integer *isplit, doublereal *work,
integer *iwork, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1, d__2, d__3, d__4, d__5;
/* Builtin functions */
double sqrt(doublereal), log(doublereal);
/* Local variables */
integer j, ib, jb, ie, je, nb;
doublereal gl;
integer im, in;
doublereal gu;
integer iw;
doublereal wl, wu;
integer nwl;
doublereal ulp, wlu, wul;
integer nwu;
doublereal tmp1, tmp2;
integer iend, ioff, iout, itmp1, jdisc;
extern logical igraphlsame_(char *, char *);
integer iinfo;
doublereal atoli;
integer iwoff;
doublereal bnorm;
integer itmax;
doublereal wkill, rtoli, tnorm;
extern doublereal igraphdlamch_(char *);
integer ibegin;
extern /* Subroutine */ int igraphdlaebz_(integer *, integer *, integer *,
integer *, integer *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
integer irange, idiscl;
doublereal safemn;
integer idumma[1];
extern /* Subroutine */ int igraphxerbla_(char *, integer *, ftnlen);
extern integer igraphilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
integer idiscu, iorder;
logical ncnvrg;
doublereal pivmin;
logical toofew;
/* -- LAPACK routine (version 3.3.1) --
-- LAPACK is a software package provided by Univ. of Tennessee, --
-- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-- April 2011 --
8-18-00: Increase FUDGE factor for T3E (eca)
Purpose
=======
DSTEBZ computes the eigenvalues of a symmetric tridiagonal
matrix T. The user may ask for all eigenvalues, all eigenvalues
in the half-open interval (VL, VU], or the IL-th through IU-th
eigenvalues.
To avoid overflow, the matrix must be scaled so that its
largest element is no greater than overflow**(1/2) *
underflow**(1/4) in absolute value, and for greatest
accuracy, it should not be much smaller than that.
See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
Matrix", Report CS41, Computer Science Dept., Stanford
University, July 21, 1966.
Arguments
=========
RANGE (input) CHARACTER*1
= 'A': ("All") all eigenvalues will be found.
= 'V': ("Value") all eigenvalues in the half-open interval
(VL, VU] will be found.
= 'I': ("Index") the IL-th through IU-th eigenvalues (of the
entire matrix) will be found.
ORDER (input) CHARACTER*1
= 'B': ("By Block") the eigenvalues will be grouped by
split-off block (see IBLOCK, ISPLIT) and
ordered from smallest to largest within
the block.
= 'E': ("Entire matrix")
the eigenvalues for the entire matrix
will be ordered from smallest to
largest.
N (input) INTEGER
The order of the tridiagonal matrix T. N >= 0.
VL (input) DOUBLE PRECISION
VU (input) DOUBLE PRECISION
If RANGE='V', the lower and upper bounds of the interval to
be searched for eigenvalues. Eigenvalues less than or equal
to VL, or greater than VU, will not be returned. 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) DOUBLE PRECISION
The absolute tolerance for the eigenvalues. An eigenvalue
(or cluster) is considered to be located if it has been
determined to lie in an interval whose width is ABSTOL or
less. If ABSTOL is less than or equal to zero, then ULP*|T|
will be used, where |T| means the 1-norm of T.
Eigenvalues will be computed most accurately when ABSTOL is
set to twice the underflow threshold 2*DLAMCH('S'), not zero.
D (input) DOUBLE PRECISION array, dimension (N)
The n diagonal elements of the tridiagonal matrix T.
E (input) DOUBLE PRECISION array, dimension (N-1)
The (n-1) off-diagonal elements of the tridiagonal matrix T.
M (output) INTEGER
The actual number of eigenvalues found. 0 <= M <= N.
(See also the description of INFO=2,3.)
NSPLIT (output) INTEGER
The number of diagonal blocks in the matrix T.
1 <= NSPLIT <= N.
W (output) DOUBLE PRECISION array, dimension (N)
On exit, the first M elements of W will contain the
eigenvalues. (DSTEBZ may use the remaining N-M elements as
workspace.)
IBLOCK (output) INTEGER array, dimension (N)
At each row/column j where E(j) is zero or small, the
matrix T is considered to split into a block diagonal
matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which
block (from 1 to the number of blocks) the eigenvalue W(i)
belongs. (DSTEBZ may use the remaining N-M elements as
workspace.)
ISPLIT (output) INTEGER array, dimension (N)
The splitting points, at which T breaks up into submatrices.
The first submatrix consists of rows/columns 1 to ISPLIT(1),
the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
etc., and the NSPLIT-th consists of rows/columns
ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
(Only the first NSPLIT elements will actually be used, but
since the user cannot know a priori what value NSPLIT will
have, N words must be reserved for ISPLIT.)
WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
IWORK (workspace) INTEGER array, dimension (3*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: some or all of the eigenvalues failed to converge or
were not computed:
=1 or 3: Bisection failed to converge for some
eigenvalues; these eigenvalues are flagged by a
negative block number. The effect is that the
eigenvalues may not be as accurate as the
absolute and relative tolerances. This is
generally caused by unexpectedly inaccurate
arithmetic.
=2 or 3: RANGE='I' only: Not all of the eigenvalues
IL:IU were found.
Effect: M < IU+1-IL
Cause: non-monotonic arithmetic, causing the
Sturm sequence to be non-monotonic.
Cure: recalculate, using RANGE='A', and pick
out eigenvalues IL:IU. In some cases,
increasing the PARAMETER "FUDGE" may
make things work.
= 4: RANGE='I', and the Gershgorin interval
initially used was too small. No eigenvalues
were computed.
Probable cause: your machine has sloppy
floating-point arithmetic.
Cure: Increase the PARAMETER "FUDGE",
recompile, and try again.
Internal Parameters
===================
RELFAC DOUBLE PRECISION, default = 2.0e0
The relative tolerance. An interval (a,b] lies within
"relative tolerance" if b-a < RELFAC*ulp*max(|a|,|b|),
where "ulp" is the machine precision (distance from 1 to
the next larger floating point number.)
FUDGE DOUBLE PRECISION, default = 2
A "fudge factor" to widen the Gershgorin intervals. Ideally,
a value of 1 should work, but on machines with sloppy
arithmetic, this needs to be larger. The default for
publicly released versions should be large enough to handle
the worst machine around. Note that this has no effect
on accuracy of the solution.
=====================================================================
Parameter adjustments */
--iwork;
--work;
--isplit;
--iblock;
--w;
--e;
--d__;
/* Function Body */
*info = 0;
/* Decode RANGE */
if (igraphlsame_(range, "A")) {
irange = 1;
} else if (igraphlsame_(range, "V")) {
irange = 2;
} else if (igraphlsame_(range, "I")) {
irange = 3;
} else {
irange = 0;
}
/* Decode ORDER */
if (igraphlsame_(order, "B")) {
iorder = 2;
} else if (igraphlsame_(order, "E")) {
iorder = 1;
} else {
iorder = 0;
}
/* Check for Errors */
if (irange <= 0) {
*info = -1;
} else if (iorder <= 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (irange == 2) {
if (*vl >= *vu) {
*info = -5;
}
} else if (irange == 3 && (*il < 1 || *il > max(1,*n))) {
*info = -6;
} else if (irange == 3 && (*iu < min(*n,*il) || *iu > *n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
igraphxerbla_("DSTEBZ", &i__1, (ftnlen)6);
return 0;
}
/* Initialize error flags */
*info = 0;
ncnvrg = FALSE_;
toofew = FALSE_;
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
/* Simplifications: */
if (irange == 3 && *il == 1 && *iu == *n) {
irange = 1;
}
/* Get machine constants
NB is the minimum vector length for vector bisection, or 0
if only scalar is to be done. */
safemn = igraphdlamch_("S");
ulp = igraphdlamch_("P");
rtoli = ulp * 2.;
nb = igraphilaenv_(&c__1, "DSTEBZ", " ", n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
if (nb <= 1) {
nb = 0;
}
/* Special Case when N=1 */
if (*n == 1) {
*nsplit = 1;
isplit[1] = 1;
if (irange == 2 && (*vl >= d__[1] || *vu < d__[1])) {
*m = 0;
} else {
w[1] = d__[1];
iblock[1] = 1;
*m = 1;
}
return 0;
}
/* Compute Splitting Points */
*nsplit = 1;
work[*n] = 0.;
pivmin = 1.;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
/* Computing 2nd power */
d__1 = e[j - 1];
tmp1 = d__1 * d__1;
/* Computing 2nd power */
d__2 = ulp;
if ((d__1 = d__[j] * d__[j - 1], abs(d__1)) * (d__2 * d__2) + safemn
> tmp1) {
isplit[*nsplit] = j - 1;
++(*nsplit);
work[j - 1] = 0.;
} else {
work[j - 1] = tmp1;
pivmin = max(pivmin,tmp1);
}
/* L10: */
}
isplit[*nsplit] = *n;
pivmin *= safemn;
/* Compute Interval and ATOLI */
if (irange == 3) {
/* RANGE='I': Compute the interval containing eigenvalues
IL through IU.
Compute Gershgorin interval for entire (split) matrix
and use it as the initial interval */
gu = d__[1];
gl = d__[1];
tmp1 = 0.;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
tmp2 = sqrt(work[j]);
/* Computing MAX */
d__1 = gu, d__2 = d__[j] + tmp1 + tmp2;
gu = max(d__1,d__2);
/* Computing MIN */
d__1 = gl, d__2 = d__[j] - tmp1 - tmp2;
gl = min(d__1,d__2);
tmp1 = tmp2;
/* L20: */
}
/* Computing MAX */
d__1 = gu, d__2 = d__[*n] + tmp1;
gu = max(d__1,d__2);
/* Computing MIN */
d__1 = gl, d__2 = d__[*n] - tmp1;
gl = min(d__1,d__2);
/* Computing MAX */
d__1 = abs(gl), d__2 = abs(gu);
tnorm = max(d__1,d__2);
gl = gl - tnorm * 2.1 * ulp * *n - pivmin * 4.2000000000000002;
gu = gu + tnorm * 2.1 * ulp * *n + pivmin * 2.1;
/* Compute Iteration parameters */
itmax = (integer) ((log(tnorm + pivmin) - log(pivmin)) / log(2.)) + 2;
if (*abstol <= 0.) {
atoli = ulp * tnorm;
} else {
atoli = *abstol;
}
work[*n + 1] = gl;
work[*n + 2] = gl;
work[*n + 3] = gu;
work[*n + 4] = gu;
work[*n + 5] = gl;
work[*n + 6] = gu;
iwork[1] = -1;
iwork[2] = -1;
iwork[3] = *n + 1;
iwork[4] = *n + 1;
iwork[5] = *il - 1;
iwork[6] = *iu;
igraphdlaebz_(&c__3, &itmax, n, &c__2, &c__2, &nb, &atoli, &rtoli, &pivmin,
&d__[1], &e[1], &work[1], &iwork[5], &work[*n + 1], &work[*n
+ 5], &iout, &iwork[1], &w[1], &iblock[1], &iinfo);
if (iwork[6] == *iu) {
wl = work[*n + 1];
wlu = work[*n + 3];
nwl = iwork[1];
wu = work[*n + 4];
wul = work[*n + 2];
nwu = iwork[4];
} else {
wl = work[*n + 2];
wlu = work[*n + 4];
nwl = iwork[2];
wu = work[*n + 3];
wul = work[*n + 1];
nwu = iwork[3];
}
if (nwl < 0 || nwl >= *n || nwu < 1 || nwu > *n) {
*info = 4;
return 0;
}
} else {
/* RANGE='A' or 'V' -- Set ATOLI
Computing MAX */
d__3 = abs(d__[1]) + abs(e[1]), d__4 = (d__1 = d__[*n], abs(d__1)) + (
d__2 = e[*n - 1], abs(d__2));
tnorm = max(d__3,d__4);
i__1 = *n - 1;
for (j = 2; j <= i__1; ++j) {
/* Computing MAX */
d__4 = tnorm, d__5 = (d__1 = d__[j], abs(d__1)) + (d__2 = e[j - 1]
, abs(d__2)) + (d__3 = e[j], abs(d__3));
tnorm = max(d__4,d__5);
/* L30: */
}
if (*abstol <= 0.) {
atoli = ulp * tnorm;
} else {
atoli = *abstol;
}
if (irange == 2) {
wl = *vl;
wu = *vu;
} else {
wl = 0.;
wu = 0.;
}
}
/* Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU.
NWL accumulates the number of eigenvalues .le. WL,
NWU accumulates the number of eigenvalues .le. WU */
*m = 0;
iend = 0;
*info = 0;
nwl = 0;
nwu = 0;
i__1 = *nsplit;
for (jb = 1; jb <= i__1; ++jb) {
ioff = iend;
ibegin = ioff + 1;
iend = isplit[jb];
in = iend - ioff;
if (in == 1) {
/* Special Case -- IN=1 */
if (irange == 1 || wl >= d__[ibegin] - pivmin) {
++nwl;
}
if (irange == 1 || wu >= d__[ibegin] - pivmin) {
++nwu;
}
if (irange == 1 || wl < d__[ibegin] - pivmin && wu >= d__[ibegin]
- pivmin) {
++(*m);
w[*m] = d__[ibegin];
iblock[*m] = jb;
}
} else {
/* General Case -- IN > 1
Compute Gershgorin Interval
and use it as the initial interval */
gu = d__[ibegin];
gl = d__[ibegin];
tmp1 = 0.;
i__2 = iend - 1;
for (j = ibegin; j <= i__2; ++j) {
tmp2 = (d__1 = e[j], abs(d__1));
/* Computing MAX */
d__1 = gu, d__2 = d__[j] + tmp1 + tmp2;
gu = max(d__1,d__2);
/* Computing MIN */
d__1 = gl, d__2 = d__[j] - tmp1 - tmp2;
gl = min(d__1,d__2);
tmp1 = tmp2;
/* L40: */
}
/* Computing MAX */
d__1 = gu, d__2 = d__[iend] + tmp1;
gu = max(d__1,d__2);
/* Computing MIN */
d__1 = gl, d__2 = d__[iend] - tmp1;
gl = min(d__1,d__2);
/* Computing MAX */
d__1 = abs(gl), d__2 = abs(gu);
bnorm = max(d__1,d__2);
gl = gl - bnorm * 2.1 * ulp * in - pivmin * 2.1;
gu = gu + bnorm * 2.1 * ulp * in + pivmin * 2.1;
/* Compute ATOLI for the current submatrix */
if (*abstol <= 0.) {
/* Computing MAX */
d__1 = abs(gl), d__2 = abs(gu);
atoli = ulp * max(d__1,d__2);
} else {
atoli = *abstol;
}
if (irange > 1) {
if (gu < wl) {
nwl += in;
nwu += in;
goto L70;
}
gl = max(gl,wl);
gu = min(gu,wu);
if (gl >= gu) {
goto L70;
}
}
/* Set Up Initial Interval */
work[*n + 1] = gl;
work[*n + in + 1] = gu;
igraphdlaebz_(&c__1, &c__0, &in, &in, &c__1, &nb, &atoli, &rtoli, &
pivmin, &d__[ibegin], &e[ibegin], &work[ibegin], idumma, &
work[*n + 1], &work[*n + (in << 1) + 1], &im, &iwork[1], &
w[*m + 1], &iblock[*m + 1], &iinfo);
nwl += iwork[1];
nwu += iwork[in + 1];
iwoff = *m - iwork[1];
/* Compute Eigenvalues */
itmax = (integer) ((log(gu - gl + pivmin) - log(pivmin)) / log(2.)
) + 2;
igraphdlaebz_(&c__2, &itmax, &in, &in, &c__1, &nb, &atoli, &rtoli, &
pivmin, &d__[ibegin], &e[ibegin], &work[ibegin], idumma, &
work[*n + 1], &work[*n + (in << 1) + 1], &iout, &iwork[1],
&w[*m + 1], &iblock[*m + 1], &iinfo);
/* Copy Eigenvalues Into W and IBLOCK
Use -JB for block number for unconverged eigenvalues. */
i__2 = iout;
for (j = 1; j <= i__2; ++j) {
tmp1 = (work[j + *n] + work[j + in + *n]) * .5;
/* Flag non-convergence. */
if (j > iout - iinfo) {
ncnvrg = TRUE_;
ib = -jb;
} else {
ib = jb;
}
i__3 = iwork[j + in] + iwoff;
for (je = iwork[j] + 1 + iwoff; je <= i__3; ++je) {
w[je] = tmp1;
iblock[je] = ib;
/* L50: */
}
/* L60: */
}
*m += im;
}
L70:
;
}
/* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
If NWL+1 < IL or NWU > IU, discard extra eigenvalues. */
if (irange == 3) {
im = 0;
idiscl = *il - 1 - nwl;
idiscu = nwu - *iu;
if (idiscl > 0 || idiscu > 0) {
i__1 = *m;
for (je = 1; je <= i__1; ++je) {
if (w[je] <= wlu && idiscl > 0) {
--idiscl;
} else if (w[je] >= wul && idiscu > 0) {
--idiscu;
} else {
++im;
w[im] = w[je];
iblock[im] = iblock[je];
}
/* L80: */
}
*m = im;
}
if (idiscl > 0 || idiscu > 0) {
/* Code to deal with effects of bad arithmetic:
Some low eigenvalues to be discarded are not in (WL,WLU],
or high eigenvalues to be discarded are not in (WUL,WU]
so just kill off the smallest IDISCL/largest IDISCU
eigenvalues, by simply finding the smallest/largest
eigenvalue(s).
(If N(w) is monotone non-decreasing, this should never
happen.) */
if (idiscl > 0) {
wkill = wu;
i__1 = idiscl;
for (jdisc = 1; jdisc <= i__1; ++jdisc) {
iw = 0;
i__2 = *m;
for (je = 1; je <= i__2; ++je) {
if (iblock[je] != 0 && (w[je] < wkill || iw == 0)) {
iw = je;
wkill = w[je];
}
/* L90: */
}
iblock[iw] = 0;
/* L100: */
}
}
if (idiscu > 0) {
wkill = wl;
i__1 = idiscu;
for (jdisc = 1; jdisc <= i__1; ++jdisc) {
iw = 0;
i__2 = *m;
for (je = 1; je <= i__2; ++je) {
if (iblock[je] != 0 && (w[je] > wkill || iw == 0)) {
iw = je;
wkill = w[je];
}
/* L110: */
}
iblock[iw] = 0;
/* L120: */
}
}
im = 0;
i__1 = *m;
for (je = 1; je <= i__1; ++je) {
if (iblock[je] != 0) {
++im;
w[im] = w[je];
iblock[im] = iblock[je];
}
/* L130: */
}
*m = im;
}
if (idiscl < 0 || idiscu < 0) {
toofew = TRUE_;
}
}
/* If ORDER='B', do nothing -- the eigenvalues are already sorted
by block.
If ORDER='E', sort the eigenvalues from smallest to largest */
if (iorder == 1 && *nsplit > 1) {
i__1 = *m - 1;
for (je = 1; je <= i__1; ++je) {
ie = 0;
tmp1 = w[je];
i__2 = *m;
for (j = je + 1; j <= i__2; ++j) {
if (w[j] < tmp1) {
ie = j;
tmp1 = w[j];
}
/* L140: */
}
if (ie != 0) {
itmp1 = iblock[ie];
w[ie] = w[je];
iblock[ie] = iblock[je];
w[je] = tmp1;
iblock[je] = itmp1;
}
/* L150: */
}
}
*info = 0;
if (ncnvrg) {
++(*info);
}
if (toofew) {
*info += 2;
}
return 0;
/* End of DSTEBZ */
} /* igraphdstebz_ */
/* Subroutine */ int igraphdgebal_(char *job, integer *n, doublereal *a, integer *
lda, integer *ilo, integer *ihi, doublereal *scale, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1, d__2;
/* Local variables */
doublereal c__, f, g;
integer i__, j, k, l, m;
doublereal r__, s, ca, ra;
integer ica, ira, iexc;
extern /* Subroutine */ int igraphdscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical igraphlsame_(char *, char *);
extern /* Subroutine */ int igraphdswap_(integer *, doublereal *, integer *,
doublereal *, integer *);
doublereal sfmin1, sfmin2, sfmax1, sfmax2;
extern doublereal igraphdlamch_(char *);
extern integer igraphidamax_(integer *, doublereal *, integer *);
extern logical igraphdisnan_(doublereal *);
extern /* Subroutine */ int igraphxerbla_(char *, integer *, ftnlen);
logical noconv;
/* -- LAPACK routine (version 3.2.2) --
-- LAPACK is a software package provided by Univ. of Tennessee, --
-- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
June 2010
Purpose
=======
DGEBAL balances a general real matrix A. This involves, first,
permuting A by a similarity transformation to isolate eigenvalues
in the first 1 to ILO-1 and last IHI+1 to N elements on the
diagonal; and second, applying a diagonal similarity transformation
to rows and columns ILO to IHI to make the rows and columns as
close in norm as possible. Both steps are optional.
Balancing may reduce the 1-norm of the matrix, and improve the
accuracy of the computed eigenvalues and/or eigenvectors.
Arguments
=========
JOB (input) CHARACTER*1
Specifies the operations to be performed on A:
= 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0
for i = 1,...,N;
= 'P': permute only;
= 'S': scale only;
= 'B': both permute and scale.
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the input matrix A.
On exit, A is overwritten by the balanced matrix.
If JOB = 'N', A is not referenced.
See Further Details.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
ILO (output) INTEGER
IHI (output) INTEGER
ILO and IHI are set to integers such that on exit
A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.
If JOB = 'N' or 'S', ILO = 1 and IHI = N.
SCALE (output) DOUBLE PRECISION array, dimension (N)
Details of the permutations and scaling factors applied to
A. If P(j) is the index of the row and column interchanged
with row and column j and D(j) is the scaling factor
applied to row and column j, then
SCALE(j) = P(j) for j = 1,...,ILO-1
= D(j) for j = ILO,...,IHI
= P(j) for j = IHI+1,...,N.
The order in which the interchanges are made is N to IHI+1,
then 1 to ILO-1.
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
Further Details
===============
The permutations consist of row and column interchanges which put
the matrix in the form
( T1 X Y )
P A P = ( 0 B Z )
( 0 0 T2 )
where T1 and T2 are upper triangular matrices whose eigenvalues lie
along the diagonal. The column indices ILO and IHI mark the starting
and ending columns of the submatrix B. Balancing consists of applying
a diagonal similarity transformation inv(D) * B * D to make the
1-norms of each row of B and its corresponding column nearly equal.
The output matrix is
( T1 X*D Y )
( 0 inv(D)*B*D inv(D)*Z ).
( 0 0 T2 )
Information about the permutations P and the diagonal matrix D is
returned in the vector SCALE.
This subroutine is based on the EISPACK routine BALANC.
Modified by Tzu-Yi Chen, Computer Science Division, University of
California at Berkeley, USA
=====================================================================
Test the input parameters
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--scale;
/* Function Body */
*info = 0;
if (! igraphlsame_(job, "N") && ! igraphlsame_(job, "P") && ! igraphlsame_(job, "S")
&& ! igraphlsame_(job, "B")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
igraphxerbla_("DGEBAL", &i__1, (ftnlen)6);
return 0;
}
k = 1;
l = *n;
if (*n == 0) {
goto L210;
}
if (igraphlsame_(job, "N")) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
scale[i__] = 1.;
/* L10: */
}
goto L210;
}
if (igraphlsame_(job, "S")) {
goto L120;
}
/* Permutation to isolate eigenvalues if possible */
goto L50;
/* Row and column exchange. */
L20:
scale[m] = (doublereal) j;
if (j == m) {
goto L30;
}
igraphdswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
i__1 = *n - k + 1;
igraphdswap_(&i__1, &a[j + k * a_dim1], lda, &a[m + k * a_dim1], lda);
L30:
switch (iexc) {
case 1:
goto L40;
case 2:
goto L80;
}
/* Search for rows isolating an eigenvalue and push them down. */
L40:
if (l == 1) {
goto L210;
}
--l;
L50:
for (j = l; j >= 1; --j) {
i__1 = l;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ == j) {
goto L60;
}
if (a[j + i__ * a_dim1] != 0.) {
goto L70;
}
L60:
;
}
m = l;
iexc = 1;
goto L20;
L70:
;
}
goto L90;
/* Search for columns isolating an eigenvalue and push them left. */
L80:
++k;
L90:
i__1 = l;
for (j = k; j <= i__1; ++j) {
i__2 = l;
for (i__ = k; i__ <= i__2; ++i__) {
if (i__ == j) {
goto L100;
}
if (a[i__ + j * a_dim1] != 0.) {
goto L110;
}
L100:
;
}
m = k;
iexc = 2;
goto L20;
L110:
;
}
L120:
i__1 = l;
for (i__ = k; i__ <= i__1; ++i__) {
scale[i__] = 1.;
/* L130: */
}
if (igraphlsame_(job, "P")) {
goto L210;
}
/* Balance the submatrix in rows K to L.
Iterative loop for norm reduction */
sfmin1 = igraphdlamch_("S") / igraphdlamch_("P");
sfmax1 = 1. / sfmin1;
sfmin2 = sfmin1 * 2.;
sfmax2 = 1. / sfmin2;
L140:
noconv = FALSE_;
i__1 = l;
for (i__ = k; i__ <= i__1; ++i__) {
c__ = 0.;
r__ = 0.;
i__2 = l;
for (j = k; j <= i__2; ++j) {
if (j == i__) {
goto L150;
}
c__ += (d__1 = a[j + i__ * a_dim1], abs(d__1));
r__ += (d__1 = a[i__ + j * a_dim1], abs(d__1));
L150:
;
}
ica = igraphidamax_(&l, &a[i__ * a_dim1 + 1], &c__1);
ca = (d__1 = a[ica + i__ * a_dim1], abs(d__1));
i__2 = *n - k + 1;
ira = igraphidamax_(&i__2, &a[i__ + k * a_dim1], lda);
ra = (d__1 = a[i__ + (ira + k - 1) * a_dim1], abs(d__1));
/* Guard against zero C or R due to underflow. */
if (c__ == 0. || r__ == 0.) {
goto L200;
}
g = r__ / 2.;
f = 1.;
s = c__ + r__;
L160:
/* Computing MAX */
d__1 = max(f,c__);
/* Computing MIN */
d__2 = min(r__,g);
if (c__ >= g || max(d__1,ca) >= sfmax2 || min(d__2,ra) <= sfmin2) {
goto L170;
}
d__1 = c__ + f + ca + r__ + g + ra;
if (igraphdisnan_(&d__1)) {
/* Exit if NaN to avoid infinite loop */
*info = -3;
i__2 = -(*info);
igraphxerbla_("DGEBAL", &i__2, (ftnlen)6);
return 0;
}
f *= 2.;
c__ *= 2.;
ca *= 2.;
r__ /= 2.;
g /= 2.;
ra /= 2.;
goto L160;
L170:
g = c__ / 2.;
L180:
/* Computing MIN */
d__1 = min(f,c__), d__1 = min(d__1,g);
if (g < r__ || max(r__,ra) >= sfmax2 || min(d__1,ca) <= sfmin2) {
goto L190;
}
f /= 2.;
c__ /= 2.;
g /= 2.;
ca /= 2.;
r__ *= 2.;
ra *= 2.;
goto L180;
/* Now balance. */
L190:
if (c__ + r__ >= s * .95) {
goto L200;
}
if (f < 1. && scale[i__] < 1.) {
if (f * scale[i__] <= sfmin1) {
goto L200;
}
}
if (f > 1. && scale[i__] > 1.) {
if (scale[i__] >= sfmax1 / f) {
goto L200;
}
}
g = 1. / f;
scale[i__] *= f;
noconv = TRUE_;
i__2 = *n - k + 1;
igraphdscal_(&i__2, &g, &a[i__ + k * a_dim1], lda);
igraphdscal_(&l, &f, &a[i__ * a_dim1 + 1], &c__1);
L200:
;
}
if (noconv) {
goto L140;
}
L210:
*ilo = k;
*ihi = l;
return 0;
/* End of DGEBAL */
} /* igraphdgebal_ */
/* Subroutine */ int igraphdgeevx_(char *balanc, char *jobvl, char *jobvr, char *
sense, integer *n, doublereal *a, integer *lda, doublereal *wr,
doublereal *wi, doublereal *vl, integer *ldvl, doublereal *vr,
integer *ldvr, integer *ilo, integer *ihi, doublereal *scale,
doublereal *abnrm, doublereal *rconde, doublereal *rcondv, doublereal
*work, integer *lwork, integer *iwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, k;
doublereal r__, cs, sn;
char job[1];
doublereal scl, dum[1], eps;
char side[1];
doublereal anrm;
integer ierr, itau;
extern /* Subroutine */ int igraphdrot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
integer iwrk, nout;
extern doublereal igraphdnrm2_(integer *, doublereal *, integer *);
extern /* Subroutine */ int igraphdscal_(integer *, doublereal *, doublereal *,
integer *);
integer icond;
extern logical igraphlsame_(char *, char *);
extern doublereal igraphdlapy2_(doublereal *, doublereal *);
extern /* Subroutine */ int igraphdlabad_(doublereal *, doublereal *), igraphdgebak_(
char *, char *, integer *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *),
igraphdgebal_(char *, integer *, doublereal *, integer *, integer *,
integer *, doublereal *, integer *);
logical scalea;
extern doublereal igraphdlamch_(char *);
doublereal cscale;
extern doublereal igraphdlange_(char *, integer *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int igraphdgehrd_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *), igraphdlascl_(char *, integer *, integer *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *);
extern integer igraphidamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int igraphdlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
igraphdlartg_(doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *), igraphxerbla_(char *, integer *, ftnlen);
logical select[1];
extern integer igraphilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
doublereal bignum;
extern /* Subroutine */ int igraphdorghr_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *), igraphdhseqr_(char *, char *, integer *, integer *, integer
*, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, integer *), igraphdtrevc_(char *, char *, logical *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, integer *, integer *, doublereal *, integer *), igraphdtrsna_(char *, char *, logical *, integer *, doublereal
*, integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, integer *);
integer minwrk, maxwrk;
logical wantvl, wntsnb;
integer hswork;
logical wntsne;
doublereal smlnum;
logical lquery, wantvr, wntsnn, wntsnv;
/* -- LAPACK driver routine (version 3.3.1) --
-- LAPACK is a software package provided by Univ. of Tennessee, --
-- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-- April 2011 --
Purpose
=======
DGEEVX computes for an N-by-N real nonsymmetric matrix A, the
eigenvalues and, optionally, the left and/or right eigenvectors.
Optionally also, it computes a balancing transformation to improve
the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
(RCONDE), and reciprocal condition numbers for the right
eigenvectors (RCONDV).
The right eigenvector v(j) of A satisfies
A * v(j) = lambda(j) * v(j)
where lambda(j) is its eigenvalue.
The left eigenvector u(j) of A satisfies
u(j)**T * A = lambda(j) * u(j)**T
where u(j)**T denotes the transpose of u(j).
The computed eigenvectors are normalized to have Euclidean norm
equal to 1 and largest component real.
Balancing a matrix means permuting the rows and columns to make it
more nearly upper triangular, and applying a diagonal similarity
transformation D * A * D**(-1), where D is a diagonal matrix, to
make its rows and columns closer in norm and the condition numbers
of its eigenvalues and eigenvectors smaller. The computed
reciprocal condition numbers correspond to the balanced matrix.
Permuting rows and columns will not change the condition numbers
(in exact arithmetic) but diagonal scaling will. For further
explanation of balancing, see section 4.10.2 of the LAPACK
Users' Guide.
Arguments
=========
BALANC (input) CHARACTER*1
Indicates how the input matrix should be diagonally scaled
and/or permuted to improve the conditioning of its
eigenvalues.
= 'N': Do not diagonally scale or permute;
= 'P': Perform permutations to make the matrix more nearly
upper triangular. Do not diagonally scale;
= 'S': Diagonally scale the matrix, i.e. replace A by
D*A*D**(-1), where D is a diagonal matrix chosen
to make the rows and columns of A more equal in
norm. Do not permute;
= 'B': Both diagonally scale and permute A.
Computed reciprocal condition numbers will be for the matrix
after balancing and/or permuting. Permuting does not change
condition numbers (in exact arithmetic), but balancing does.
JOBVL (input) CHARACTER*1
= 'N': left eigenvectors of A are not computed;
= 'V': left eigenvectors of A are computed.
If SENSE = 'E' or 'B', JOBVL must = 'V'.
JOBVR (input) CHARACTER*1
= 'N': right eigenvectors of A are not computed;
= 'V': right eigenvectors of A are computed.
If SENSE = 'E' or 'B', JOBVR must = 'V'.
SENSE (input) CHARACTER*1
Determines which reciprocal condition numbers are computed.
= 'N': None are computed;
= 'E': Computed for eigenvalues only;
= 'V': Computed for right eigenvectors only;
= 'B': Computed for eigenvalues and right eigenvectors.
If SENSE = 'E' or 'B', both left and right eigenvectors
must also be computed (JOBVL = 'V' and JOBVR = 'V').
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the N-by-N matrix A.
On exit, A has been overwritten. If JOBVL = 'V' or
JOBVR = 'V', A contains the real Schur form of the balanced
version of the input matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
WR (output) DOUBLE PRECISION array, dimension (N)
WI (output) DOUBLE PRECISION array, dimension (N)
WR and WI contain the real and imaginary parts,
respectively, of the computed eigenvalues. Complex
conjugate pairs of eigenvalues will appear consecutively
with the eigenvalue having the positive imaginary part
first.
VL (output) DOUBLE PRECISION array, dimension (LDVL,N)
If JOBVL = 'V', the left eigenvectors u(j) are stored one
after another in the columns of VL, in the same order
as their eigenvalues.
If JOBVL = 'N', VL is not referenced.
If the j-th eigenvalue is real, then u(j) = VL(:,j),
the j-th column of VL.
If the j-th and (j+1)-st eigenvalues form a complex
conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and
u(j+1) = VL(:,j) - i*VL(:,j+1).
LDVL (input) INTEGER
The leading dimension of the array VL. LDVL >= 1; if
JOBVL = 'V', LDVL >= N.
VR (output) DOUBLE PRECISION array, dimension (LDVR,N)
If JOBVR = 'V', the right eigenvectors v(j) are stored one
after another in the columns of VR, in the same order
as their eigenvalues.
If JOBVR = 'N', VR is not referenced.
If the j-th eigenvalue is real, then v(j) = VR(:,j),
the j-th column of VR.
If the j-th and (j+1)-st eigenvalues form a complex
conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and
v(j+1) = VR(:,j) - i*VR(:,j+1).
LDVR (input) INTEGER
The leading dimension of the array VR. LDVR >= 1, and if
JOBVR = 'V', LDVR >= N.
ILO (output) INTEGER
IHI (output) INTEGER
ILO and IHI are integer values determined when A was
balanced. The balanced A(i,j) = 0 if I > J and
J = 1,...,ILO-1 or I = IHI+1,...,N.
SCALE (output) DOUBLE PRECISION array, dimension (N)
Details of the permutations and scaling factors applied
when balancing A. If P(j) is the index of the row and column
interchanged with row and column j, and D(j) is the scaling
factor applied to row and column j, then
SCALE(J) = P(J), for J = 1,...,ILO-1
= D(J), for J = ILO,...,IHI
= P(J) for J = IHI+1,...,N.
The order in which the interchanges are made is N to IHI+1,
then 1 to ILO-1.
ABNRM (output) DOUBLE PRECISION
The one-norm of the balanced matrix (the maximum
of the sum of absolute values of elements of any column).
RCONDE (output) DOUBLE PRECISION array, dimension (N)
RCONDE(j) is the reciprocal condition number of the j-th
eigenvalue.
RCONDV (output) DOUBLE PRECISION array, dimension (N)
RCONDV(j) is the reciprocal condition number of the j-th
right eigenvector.
WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. If SENSE = 'N' or 'E',
LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V',
LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6).
For good performance, LWORK must generally be larger.
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
IWORK (workspace) INTEGER array, dimension (2*N-2)
If SENSE = 'N' or 'E', not referenced.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: if INFO = i, the QR algorithm failed to compute all the
eigenvalues, and no eigenvectors or condition numbers
have been computed; elements 1:ILO-1 and i+1:N of WR
and WI contain eigenvalues which have converged.
=====================================================================
Test the input arguments
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--wr;
--wi;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--scale;
--rconde;
--rcondv;
--work;
--iwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1;
wantvl = igraphlsame_(jobvl, "V");
wantvr = igraphlsame_(jobvr, "V");
wntsnn = igraphlsame_(sense, "N");
wntsne = igraphlsame_(sense, "E");
wntsnv = igraphlsame_(sense, "V");
wntsnb = igraphlsame_(sense, "B");
if (! (igraphlsame_(balanc, "N") || igraphlsame_(balanc, "S") || igraphlsame_(balanc, "P")
|| igraphlsame_(balanc, "B"))) {
*info = -1;
} else if (! wantvl && ! igraphlsame_(jobvl, "N")) {
*info = -2;
} else if (! wantvr && ! igraphlsame_(jobvr, "N")) {
*info = -3;
} else if (! (wntsnn || wntsne || wntsnb || wntsnv) || (wntsne || wntsnb)
&& ! (wantvl && wantvr)) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldvl < 1 || wantvl && *ldvl < *n) {
*info = -11;
} else if (*ldvr < 1 || wantvr && *ldvr < *n) {
*info = -13;
}
/* Compute workspace
(Note: Comments in the code beginning "Workspace:" describe the
minimal amount of workspace needed at that point in the code,
as well as the preferred amount for good performance.
NB refers to the optimal block size for the immediately
following subroutine, as returned by ILAENV.
HSWORK refers to the workspace preferred by DHSEQR, as
calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
the worst case.) */
if (*info == 0) {
if (*n == 0) {
minwrk = 1;
maxwrk = 1;
} else {
maxwrk = *n + *n * igraphilaenv_(&c__1, "DGEHRD", " ", n, &c__1, n, &
c__0, (ftnlen)6, (ftnlen)1);
if (wantvl) {
igraphdhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
1], &vl[vl_offset], ldvl, &work[1], &c_n1, info);
} else if (wantvr) {
igraphdhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
1], &vr[vr_offset], ldvr, &work[1], &c_n1, info);
} else {
if (wntsnn) {
igraphdhseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &wr[1],
&wi[1], &vr[vr_offset], ldvr, &work[1], &c_n1,
info);
} else {
igraphdhseqr_("S", "N", n, &c__1, n, &a[a_offset], lda, &wr[1],
&wi[1], &vr[vr_offset], ldvr, &work[1], &c_n1,
info);
}
}
hswork = (integer) work[1];
if (! wantvl && ! wantvr) {
minwrk = *n << 1;
if (! wntsnn) {
/* Computing MAX */
i__1 = minwrk, i__2 = *n * *n + *n * 6;
minwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,hswork);
if (! wntsnn) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *n + *n * 6;
maxwrk = max(i__1,i__2);
}
} else {
minwrk = *n * 3;
if (! wntsnn && ! wntsne) {
/* Computing MAX */
i__1 = minwrk, i__2 = *n * *n + *n * 6;
minwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,hswork);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + (*n - 1) * igraphilaenv_(&c__1, "DORGHR",
" ", n, &c__1, n, &c_n1, (ftnlen)6, (ftnlen)1);
maxwrk = max(i__1,i__2);
if (! wntsnn && ! wntsne) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *n + *n * 6;
maxwrk = max(i__1,i__2);
}
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3;
maxwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,minwrk);
}
work[1] = (doublereal) maxwrk;
if (*lwork < minwrk && ! lquery) {
*info = -21;
}
}
if (*info != 0) {
i__1 = -(*info);
igraphxerbla_("DGEEVX", &i__1, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = igraphdlamch_("P");
smlnum = igraphdlamch_("S");
bignum = 1. / smlnum;
igraphdlabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1. / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
icond = 0;
anrm = igraphdlange_("M", n, n, &a[a_offset], lda, dum);
scalea = FALSE_;
if (anrm > 0. && anrm < smlnum) {
scalea = TRUE_;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE_;
cscale = bignum;
}
if (scalea) {
igraphdlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
ierr);
}
/* Balance the matrix and compute ABNRM */
igraphdgebal_(balanc, n, &a[a_offset], lda, ilo, ihi, &scale[1], &ierr);
*abnrm = igraphdlange_("1", n, n, &a[a_offset], lda, dum);
if (scalea) {
dum[0] = *abnrm;
igraphdlascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &c__1, &
ierr);
*abnrm = dum[0];
}
/* Reduce to upper Hessenberg form
(Workspace: need 2*N, prefer N+N*NB) */
itau = 1;
iwrk = itau + *n;
i__1 = *lwork - iwrk + 1;
igraphdgehrd_(n, ilo, ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, &
ierr);
if (wantvl) {
/* Want left eigenvectors
Copy Householder vectors to VL */
*(unsigned char *)side = 'L';
igraphdlacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl)
;
/* Generate orthogonal matrix in VL
(Workspace: need 2*N-1, prefer N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
igraphdorghr_(n, ilo, ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], &
i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VL
(Workspace: need 1, prefer HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
igraphdhseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vl[
vl_offset], ldvl, &work[iwrk], &i__1, info);
if (wantvr) {
/* Want left and right eigenvectors
Copy Schur vectors to VR */
*(unsigned char *)side = 'B';
igraphdlacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
}
} else if (wantvr) {
/* Want right eigenvectors
Copy Householder vectors to VR */
*(unsigned char *)side = 'R';
igraphdlacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr)
;
/* Generate orthogonal matrix in VR
(Workspace: need 2*N-1, prefer N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
igraphdorghr_(n, ilo, ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], &
i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VR
(Workspace: need 1, prefer HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
igraphdhseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
} else {
/* Compute eigenvalues only
If condition numbers desired, compute Schur form */
if (wntsnn) {
*(unsigned char *)job = 'E';
} else {
*(unsigned char *)job = 'S';
}
/* (Workspace: need 1, prefer HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
igraphdhseqr_(job, "N", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
}
/* If INFO > 0 from DHSEQR, then quit */
if (*info > 0) {
goto L50;
}
if (wantvl || wantvr) {
/* Compute left and/or right eigenvectors
(Workspace: need 3*N) */
igraphdtrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
&vr[vr_offset], ldvr, n, &nout, &work[iwrk], &ierr);
}
/* Compute condition numbers if desired
(Workspace: need N*N+6*N unless SENSE = 'E') */
if (! wntsnn) {
igraphdtrsna_(sense, "A", select, n, &a[a_offset], lda, &vl[vl_offset],
ldvl, &vr[vr_offset], ldvr, &rconde[1], &rcondv[1], n, &nout,
&work[iwrk], n, &iwork[1], &icond);
}
if (wantvl) {
/* Undo balancing of left eigenvectors */
igraphdgebak_(balanc, "L", n, ilo, ihi, &scale[1], n, &vl[vl_offset], ldvl,
&ierr);
/* Normalize left eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wi[i__] == 0.) {
scl = 1. / igraphdnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
igraphdscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
} else if (wi[i__] > 0.) {
d__1 = igraphdnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
d__2 = igraphdnrm2_(n, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
scl = 1. / igraphdlapy2_(&d__1, &d__2);
igraphdscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
igraphdscal_(n, &scl, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* Computing 2nd power */
d__1 = vl[k + i__ * vl_dim1];
/* Computing 2nd power */
d__2 = vl[k + (i__ + 1) * vl_dim1];
work[k] = d__1 * d__1 + d__2 * d__2;
/* L10: */
}
k = igraphidamax_(n, &work[1], &c__1);
igraphdlartg_(&vl[k + i__ * vl_dim1], &vl[k + (i__ + 1) * vl_dim1],
&cs, &sn, &r__);
igraphdrot_(n, &vl[i__ * vl_dim1 + 1], &c__1, &vl[(i__ + 1) *
vl_dim1 + 1], &c__1, &cs, &sn);
vl[k + (i__ + 1) * vl_dim1] = 0.;
}
/* L20: */
}
}
if (wantvr) {
/* Undo balancing of right eigenvectors */
igraphdgebak_(balanc, "R", n, ilo, ihi, &scale[1], n, &vr[vr_offset], ldvr,
&ierr);
/* Normalize right eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wi[i__] == 0.) {
scl = 1. / igraphdnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
igraphdscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
} else if (wi[i__] > 0.) {
d__1 = igraphdnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
d__2 = igraphdnrm2_(n, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
scl = 1. / igraphdlapy2_(&d__1, &d__2);
igraphdscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
igraphdscal_(n, &scl, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* Computing 2nd power */
d__1 = vr[k + i__ * vr_dim1];
/* Computing 2nd power */
d__2 = vr[k + (i__ + 1) * vr_dim1];
work[k] = d__1 * d__1 + d__2 * d__2;
/* L30: */
}
k = igraphidamax_(n, &work[1], &c__1);
igraphdlartg_(&vr[k + i__ * vr_dim1], &vr[k + (i__ + 1) * vr_dim1],
&cs, &sn, &r__);
igraphdrot_(n, &vr[i__ * vr_dim1 + 1], &c__1, &vr[(i__ + 1) *
vr_dim1 + 1], &c__1, &cs, &sn);
vr[k + (i__ + 1) * vr_dim1] = 0.;
}
/* L40: */
}
}
/* Undo scaling if necessary */
L50:
if (scalea) {
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
igraphdlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[*info +
1], &i__2, &ierr);
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
igraphdlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[*info +
1], &i__2, &ierr);
if (*info == 0) {
if ((wntsnv || wntsnb) && icond == 0) {
igraphdlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &rcondv[
1], n, &ierr);
}
} else {
i__1 = *ilo - 1;
igraphdlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[1],
n, &ierr);
i__1 = *ilo - 1;
igraphdlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[1],
n, &ierr);
}
}
work[1] = (doublereal) maxwrk;
return 0;
/* End of DGEEVX */
} /* igraphdgeevx_ */
/* Subroutine */ int igraphdstemr_(char *jobz, char *range, integer *n, doublereal *
d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il,
integer *iu, integer *m, doublereal *w, doublereal *z__, integer *ldz,
integer *nzc, integer *isuppz, logical *tryrac, doublereal *work,
integer *lwork, integer *iwork, integer *liwork, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j;
doublereal r1, r2;
integer jj;
doublereal cs;
integer in;
doublereal sn, wl, wu;
integer iil, iiu;
doublereal eps, tmp;
integer indd, iend, jblk, wend;
doublereal rmin, rmax;
integer itmp;
doublereal tnrm;
extern /* Subroutine */ int igraphdlae2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *);
integer inde2, itmp2;
doublereal rtol1, rtol2;
extern /* Subroutine */ int igraphdscal_(integer *, doublereal *, doublereal *,
integer *);
doublereal scale;
integer indgp;
extern logical igraphlsame_(char *, char *);
integer iinfo, iindw, ilast;
extern /* Subroutine */ int igraphdcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), igraphdswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
integer lwmin;
logical wantz;
extern /* Subroutine */ int igraphdlaev2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
extern doublereal igraphdlamch_(char *);
logical alleig;
integer ibegin;
logical indeig;
integer iindbl;
logical valeig;
extern /* Subroutine */ int igraphdlarrc_(char *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
integer *, integer *, integer *), igraphdlarre_(char *,
integer *, doublereal *, doublereal *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *, integer *);
integer wbegin;
doublereal safmin;
extern /* Subroutine */ int igraphdlarrj_(integer *, doublereal *, doublereal *,
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *), igraphxerbla_(char *, integer *, ftnlen);
doublereal bignum;
integer inderr, iindwk, indgrs, offset;
extern doublereal igraphdlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int igraphdlarrr_(integer *, doublereal *, doublereal *,
integer *), igraphdlarrv_(integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, integer *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), igraphdlasrt_(char *, integer *, doublereal *,
integer *);
doublereal thresh;
integer iinspl, ifirst, indwrk, liwmin, nzcmin;
doublereal pivmin;
integer nsplit;
doublereal smlnum;
logical lquery, zquery;
/* -- LAPACK computational routine (version 3.2.2) --
-- LAPACK is a software package provided by Univ. of Tennessee, --
-- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-- June 2010 --
Purpose
=======
DSTEMR computes selected eigenvalues and, optionally, eigenvectors
of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
a well defined set of pairwise different real eigenvalues, the corresponding
real eigenvectors are pairwise orthogonal.
The spectrum may be computed either completely or partially by specifying
either an interval (VL,VU] or a range of indices IL:IU for the desired
eigenvalues.
Depending on the number of desired eigenvalues, these are computed either
by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are
computed by the use of various suitable L D L^T factorizations near clusters
of close eigenvalues (referred to as RRRs, Relatively Robust
Representations). An informal sketch of the algorithm follows.
For each unreduced block (submatrix) of T,
(a) Compute T - sigma I = L D L^T, so that L and D
define all the wanted eigenvalues to high relative accuracy.
This means that small relative changes in the entries of D and L
cause only small relative changes in the eigenvalues and
eigenvectors. The standard (unfactored) representation of the
tridiagonal matrix T does not have this property in general.
(b) Compute the eigenvalues to suitable accuracy.
If the eigenvectors are desired, the algorithm attains full
accuracy of the computed eigenvalues only right before
the corresponding vectors have to be computed, see steps c) and d).
(c) For each cluster of close eigenvalues, select a new
shift close to the cluster, find a new factorization, and refine
the shifted eigenvalues to suitable accuracy.
(d) For each eigenvalue with a large enough relative separation compute
the corresponding eigenvector by forming a rank revealing twisted
factorization. Go back to (c) for any clusters that remain.
For more details, see:
- Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
- Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
2004. Also LAPACK Working Note 154.
- Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
tridiagonal eigenvalue/eigenvector problem",
Computer Science Division Technical Report No. UCB/CSD-97-971,
UC Berkeley, May 1997.
Further Details
1.DSTEMR works only on machines which follow IEEE-754
floating-point standard in their handling of infinities and NaNs.
This permits the use of efficient inner loops avoiding a check for
zero divisors.
Arguments
=========
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
RANGE (input) CHARACTER*1
= 'A': all eigenvalues will be found.
= 'V': all eigenvalues in the half-open interval (VL,VU]
will be found.
= 'I': the IL-th through IU-th eigenvalues will be found.
N (input) INTEGER
The order of the matrix. N >= 0.
D (input/output) DOUBLE PRECISION array, dimension (N)
On entry, the N diagonal elements of the tridiagonal matrix
T. On exit, D is overwritten.
E (input/output) DOUBLE PRECISION array, dimension (N)
On entry, the (N-1) subdiagonal elements of the tridiagonal
matrix T in elements 1 to N-1 of E. E(N) need not be set on
input, but is used internally as workspace.
On exit, E is overwritten.
VL (input) DOUBLE PRECISION
VU (input) DOUBLE PRECISION
If RANGE='V', the lower and upper bounds of the interval to
be searched for eigenvalues. VL < VU.
Not referenced if RANGE = 'A' or 'I'.
IL (input) INTEGER
IU (input) INTEGER
If RANGE='I', the indices (in ascending order) of the
smallest and largest eigenvalues to be returned.
1 <= IL <= IU <= N, if N > 0.
Not referenced if RANGE = 'A' or 'V'.
M (output) INTEGER
The total number of eigenvalues found. 0 <= M <= N.
If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
W (output) DOUBLE PRECISION array, dimension (N)
The first M elements contain the selected eigenvalues in
ascending order.
Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
contain the orthonormal eigenvectors of the matrix T
corresponding to the selected eigenvalues, with the i-th
column of Z holding the eigenvector associated with W(i).
If JOBZ = 'N', then Z is not referenced.
Note: the user must ensure that at least max(1,M) columns are
supplied in the array Z; if RANGE = 'V', the exact value of M
is not known in advance and can be computed with a workspace
query by setting NZC = -1, see below.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1, and if
JOBZ = 'V', then LDZ >= max(1,N).
NZC (input) INTEGER
The number of eigenvectors to be held in the array Z.
If RANGE = 'A', then NZC >= max(1,N).
If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].
If RANGE = 'I', then NZC >= IU-IL+1.
If NZC = -1, then a workspace query is assumed; the
routine calculates the number of columns of the array Z that
are needed to hold the eigenvectors.
This value is returned as the first entry of the Z array, and
no error message related to NZC is issued by XERBLA.
ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
The support of the eigenvectors in Z, i.e., the indices
indicating the nonzero elements in Z. The i-th computed eigenvector
is nonzero only in elements ISUPPZ( 2*i-1 ) through
ISUPPZ( 2*i ). This is relevant in the case when the matrix
is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
TRYRAC (input/output) LOGICAL
If TRYRAC.EQ..TRUE., indicates that the code should check whether
the tridiagonal matrix defines its eigenvalues to high relative
accuracy. If so, the code uses relative-accuracy preserving
algorithms that might be (a bit) slower depending on the matrix.
If the matrix does not define its eigenvalues to high relative
accuracy, the code can uses possibly faster algorithms.
If TRYRAC.EQ..FALSE., the code is not required to guarantee
relatively accurate eigenvalues and can use the fastest possible
techniques.
On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix
does not define its eigenvalues to high relative accuracy.
WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal
(and minimal) LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= max(1,18*N)
if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
IWORK (workspace/output) INTEGER array, dimension (LIWORK)
On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
LIWORK (input) INTEGER
The dimension of the array IWORK. LIWORK >= max(1,10*N)
if the eigenvectors are desired, and LIWORK >= max(1,8*N)
if only the eigenvalues are to be computed.
If LIWORK = -1, then a workspace query is assumed; the
routine only calculates the optimal size of the IWORK array,
returns this value as the first entry of the IWORK array, and
no error message related to LIWORK is issued by XERBLA.
INFO (output) INTEGER
On exit, INFO
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = 1X, internal error in DLARRE,
if INFO = 2X, internal error in DLARRV.
Here, the digit X = ABS( IINFO ) < 10, where IINFO is
the nonzero error code returned by DLARRE or
DLARRV, respectively.
Further Details
===============
Based on contributions by
Beresford Parlett, University of California, Berkeley, USA
Jim Demmel, University of California, Berkeley, USA
Inderjit Dhillon, University of Texas, Austin, USA
Osni Marques, LBNL/NERSC, USA
Christof Voemel, University of California, Berkeley, USA
=====================================================================
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 = igraphlsame_(jobz, "V");
alleig = igraphlsame_(range, "A");
valeig = igraphlsame_(range, "V");
indeig = igraphlsame_(range, "I");
lquery = *lwork == -1 || *liwork == -1;
zquery = *nzc == -1;
/* DSTEMR needs WORK of size 6*N, IWORK of size 3*N.
In addition, DLARRE needs WORK of size 6*N, IWORK of size 5*N.
Furthermore, DLARRV needs WORK of size 12*N, IWORK of size 7*N. */
if (wantz) {
lwmin = *n * 18;
liwmin = *n * 10;
} else {
/* need less workspace if only the eigenvalues are wanted */
lwmin = *n * 12;
liwmin = *n << 3;
}
wl = 0.;
wu = 0.;
iil = 0;
iiu = 0;
if (valeig) {
/* We do not reference VL, VU in the cases RANGE = 'I','A'
The interval (WL, WU] contains all the wanted eigenvalues.
It is either given by the user or computed in DLARRE. */
wl = *vl;
wu = *vu;
} else if (indeig) {
/* We do not reference IL, IU in the cases RANGE = 'V','A' */
iil = *il;
iiu = *iu;
}
*info = 0;
if (! (wantz || igraphlsame_(jobz, "N"))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (valeig && *n > 0 && wu <= wl) {
*info = -7;
} else if (indeig && (iil < 1 || iil > *n)) {
*info = -8;
} else if (indeig && (iiu < iil || iiu > *n)) {
*info = -9;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -13;
} else if (*lwork < lwmin && ! lquery) {
*info = -17;
} else if (*liwork < liwmin && ! lquery) {
*info = -19;
}
/* Get machine constants. */
safmin = igraphdlamch_("Safe minimum");
eps = igraphdlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
rmax = min(d__1,d__2);
if (*info == 0) {
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
if (wantz && alleig) {
nzcmin = *n;
} else if (wantz && valeig) {
igraphdlarrc_("T", n, vl, vu, &d__[1], &e[1], &safmin, &nzcmin, &itmp, &
itmp2, info);
} else if (wantz && indeig) {
nzcmin = iiu - iil + 1;
} else {
/* WANTZ .EQ. FALSE. */
nzcmin = 0;
}
if (zquery && *info == 0) {
z__[z_dim1 + 1] = (doublereal) nzcmin;
} else if (*nzc < nzcmin && ! zquery) {
*info = -14;
}
}
if (*info != 0) {
i__1 = -(*info);
igraphxerbla_("DSTEMR", &i__1, (ftnlen)6);
return 0;
} else if (lquery || zquery) {
return 0;
}
/* Handle N = 0, 1, and 2 cases immediately */
*m = 0;
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (alleig || indeig) {
*m = 1;
w[1] = d__[1];
} else {
if (wl < d__[1] && wu >= d__[1]) {
*m = 1;
w[1] = d__[1];
}
}
if (wantz && ! zquery) {
z__[z_dim1 + 1] = 1.;
isuppz[1] = 1;
isuppz[2] = 1;
}
return 0;
}
if (*n == 2) {
if (! wantz) {
igraphdlae2_(&d__[1], &e[1], &d__[2], &r1, &r2);
} else if (wantz && ! zquery) {
igraphdlaev2_(&d__[1], &e[1], &d__[2], &r1, &r2, &cs, &sn);
}
if (alleig || valeig && r2 > wl && r2 <= wu || indeig && iil == 1) {
++(*m);
w[*m] = r2;
if (wantz && ! zquery) {
z__[*m * z_dim1 + 1] = -sn;
z__[*m * z_dim1 + 2] = cs;
/* Note: At most one of SN and CS can be zero. */
if (sn != 0.) {
if (cs != 0.) {
isuppz[(*m << 1) - 1] = 1;
isuppz[*m * 2] = 2;
} else {
isuppz[(*m << 1) - 1] = 1;
isuppz[*m * 2] = 1;
}
} else {
isuppz[(*m << 1) - 1] = 2;
isuppz[*m * 2] = 2;
}
}
}
if (alleig || valeig && r1 > wl && r1 <= wu || indeig && iiu == 2) {
++(*m);
w[*m] = r1;
if (wantz && ! zquery) {
z__[*m * z_dim1 + 1] = cs;
z__[*m * z_dim1 + 2] = sn;
/* Note: At most one of SN and CS can be zero. */
if (sn != 0.) {
if (cs != 0.) {
isuppz[(*m << 1) - 1] = 1;
isuppz[*m * 2] = 2;
} else {
isuppz[(*m << 1) - 1] = 1;
isuppz[*m * 2] = 1;
}
} else {
isuppz[(*m << 1) - 1] = 2;
isuppz[*m * 2] = 2;
}
}
}
return 0;
}
/* Continue with general N */
indgrs = 1;
inderr = (*n << 1) + 1;
indgp = *n * 3 + 1;
indd = (*n << 2) + 1;
inde2 = *n * 5 + 1;
indwrk = *n * 6 + 1;
iinspl = 1;
iindbl = *n + 1;
iindw = (*n << 1) + 1;
iindwk = *n * 3 + 1;
/* Scale matrix to allowable range, if necessary.
The allowable range is related to the PIVMIN parameter; see the
comments in DLARRD. The preference for scaling small values
up is heuristic; we expect users' matrices not to be close to the
RMAX threshold. */
scale = 1.;
tnrm = igraphdlanst_("M", n, &d__[1], &e[1]);
if (tnrm > 0. && tnrm < rmin) {
scale = rmin / tnrm;
} else if (tnrm > rmax) {
scale = rmax / tnrm;
}
if (scale != 1.) {
igraphdscal_(n, &scale, &d__[1], &c__1);
i__1 = *n - 1;
igraphdscal_(&i__1, &scale, &e[1], &c__1);
tnrm *= scale;
if (valeig) {
/* If eigenvalues in interval have to be found,
scale (WL, WU] accordingly */
wl *= scale;
wu *= scale;
}
}
/* Compute the desired eigenvalues of the tridiagonal after splitting
into smaller subblocks if the corresponding off-diagonal elements
are small
THRESH is the splitting parameter for DLARRE
A negative THRESH forces the old splitting criterion based on the
size of the off-diagonal. A positive THRESH switches to splitting
which preserves relative accuracy. */
if (*tryrac) {
/* Test whether the matrix warrants the more expensive relative approach. */
igraphdlarrr_(n, &d__[1], &e[1], &iinfo);
} else {
/* The user does not care about relative accurately eigenvalues */
iinfo = -1;
}
/* Set the splitting criterion */
if (iinfo == 0) {
thresh = eps;
} else {
thresh = -eps;
/* relative accuracy is desired but T does not guarantee it */
*tryrac = FALSE_;
}
if (*tryrac) {
/* Copy original diagonal, needed to guarantee relative accuracy */
igraphdcopy_(n, &d__[1], &c__1, &work[indd], &c__1);
}
/* Store the squares of the offdiagonal values of T */
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
/* Computing 2nd power */
d__1 = e[j];
work[inde2 + j - 1] = d__1 * d__1;
/* L5: */
}
/* Set the tolerance parameters for bisection */
if (! wantz) {
/* DLARRE computes the eigenvalues to full precision. */
rtol1 = eps * 4.;
rtol2 = eps * 4.;
} else {
/* DLARRE computes the eigenvalues to less than full precision.
DLARRV will refine the eigenvalue approximations, and we can
need less accurate initial bisection in DLARRE.
Note: these settings do only affect the subset case and DLARRE */
rtol1 = sqrt(eps);
/* Computing MAX */
d__1 = sqrt(eps) * .005, d__2 = eps * 4.;
rtol2 = max(d__1,d__2);
}
igraphdlarre_(range, n, &wl, &wu, &iil, &iiu, &d__[1], &e[1], &work[inde2], &
rtol1, &rtol2, &thresh, &nsplit, &iwork[iinspl], m, &w[1], &work[
inderr], &work[indgp], &iwork[iindbl], &iwork[iindw], &work[
indgrs], &pivmin, &work[indwrk], &iwork[iindwk], &iinfo);
if (iinfo != 0) {
*info = abs(iinfo) + 10;
return 0;
}
/* Note that if RANGE .NE. 'V', DLARRE computes bounds on the desired
part of the spectrum. All desired eigenvalues are contained in
(WL,WU] */
if (wantz) {
/* Compute the desired eigenvectors corresponding to the computed
eigenvalues */
igraphdlarrv_(n, &wl, &wu, &d__[1], &e[1], &pivmin, &iwork[iinspl], m, &
c__1, m, &c_b18, &rtol1, &rtol2, &w[1], &work[inderr], &work[
indgp], &iwork[iindbl], &iwork[iindw], &work[indgrs], &z__[
z_offset], ldz, &isuppz[1], &work[indwrk], &iwork[iindwk], &
iinfo);
if (iinfo != 0) {
*info = abs(iinfo) + 20;
return 0;
}
} else {
/* DLARRE computes eigenvalues of the (shifted) root representation
DLARRV returns the eigenvalues of the unshifted matrix.
However, if the eigenvectors are not desired by the user, we need
to apply the corresponding shifts from DLARRE to obtain the
eigenvalues of the original matrix. */
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
itmp = iwork[iindbl + j - 1];
w[j] += e[iwork[iinspl + itmp - 1]];
/* L20: */
}
}
if (*tryrac) {
/* Refine computed eigenvalues so that they are relatively accurate
with respect to the original matrix T. */
ibegin = 1;
wbegin = 1;
i__1 = iwork[iindbl + *m - 1];
for (jblk = 1; jblk <= i__1; ++jblk) {
iend = iwork[iinspl + jblk - 1];
in = iend - ibegin + 1;
wend = wbegin - 1;
/* check if any eigenvalues have to be refined in this block */
L36:
if (wend < *m) {
if (iwork[iindbl + wend] == jblk) {
++wend;
goto L36;
}
}
if (wend < wbegin) {
ibegin = iend + 1;
goto L39;
}
offset = iwork[iindw + wbegin - 1] - 1;
ifirst = iwork[iindw + wbegin - 1];
ilast = iwork[iindw + wend - 1];
rtol2 = eps * 4.;
igraphdlarrj_(&in, &work[indd + ibegin - 1], &work[inde2 + ibegin - 1],
&ifirst, &ilast, &rtol2, &offset, &w[wbegin], &work[
inderr + wbegin - 1], &work[indwrk], &iwork[iindwk], &
pivmin, &tnrm, &iinfo);
ibegin = iend + 1;
wbegin = wend + 1;
L39:
;
}
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (scale != 1.) {
d__1 = 1. / scale;
igraphdscal_(m, &d__1, &w[1], &c__1);
}
/* If eigenvalues are not in increasing order, then sort them,
possibly along with eigenvectors. */
if (nsplit > 1) {
if (! wantz) {
igraphdlasrt_("I", m, &w[1], &iinfo);
if (iinfo != 0) {
*info = 3;
return 0;
}
} else {
i__1 = *m - 1;
for (j = 1; j <= i__1; ++j) {
i__ = 0;
tmp = w[j];
i__2 = *m;
for (jj = j + 1; jj <= i__2; ++jj) {
if (w[jj] < tmp) {
i__ = jj;
tmp = w[jj];
}
/* L50: */
}
if (i__ != 0) {
w[i__] = w[j];
w[j] = tmp;
if (wantz) {
igraphdswap_(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] = (doublereal) lwmin;
iwork[1] = liwmin;
return 0;
/* End of DSTEMR */
} /* igraphdstemr_ */
/* Subroutine */ int igraphdlaset_(char *uplo, integer *m, integer *n, doublereal *
alpha, doublereal *beta, doublereal *a, integer *lda)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
static integer i__, j;
extern logical igraphlsame_(char *, char *);
/* -- LAPACK auxiliary routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASET initializes an m-by-n matrix A to BETA on the diagonal and */
/* ALPHA on the offdiagonals. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies the part of the matrix A to be set. */
/* = 'U': Upper triangular part is set; the strictly lower */
/* triangular part of A is not changed. */
/* = 'L': Lower triangular part is set; the strictly upper */
/* triangular part of A is not changed. */
/* Otherwise: All of the matrix A is set. */
/* 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. */
/* ALPHA (input) DOUBLE PRECISION */
/* The constant to which the offdiagonal elements are to be set. */
/* BETA (input) DOUBLE PRECISION */
/* The constant to which the diagonal elements are to be set. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On exit, the leading m-by-n submatrix of A is set as follows: */
/* if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, */
/* if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, */
/* otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, */
/* and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
if (igraphlsame_(uplo, "U")) {
/* Set the strictly upper triangular or trapezoidal part of the */
/* array to ALPHA. */
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
/* Computing MIN */
i__3 = j - 1;
i__2 = min(i__3,*m);
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = *alpha;
/* L10: */
}
/* L20: */
}
} else if (igraphlsame_(uplo, "L")) {
/* Set the strictly lower triangular or trapezoidal part of the */
/* array to ALPHA. */
i__1 = min(*m,*n);
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = j + 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = *alpha;
/* L30: */
}
/* L40: */
}
} else {
/* Set the leading m-by-n submatrix to ALPHA. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = *alpha;
/* L50: */
}
/* L60: */
}
}
/* Set the first min(M,N) diagonal elements to BETA. */
i__1 = min(*m,*n);
for (i__ = 1; i__ <= i__1; ++i__) {
a[i__ + i__ * a_dim1] = *beta;
/* L70: */
}
return 0;
/* End of DLASET */
} /* igraphdlaset_ */
Subroutine */ int igraphdgeevx_(char *balanc, char *jobvl, char *jobvr, char *
sense, integer *n, doublereal *a, integer *lda, doublereal *wr,
doublereal *wi, doublereal *vl, integer *ldvl, doublereal *vr,
integer *ldvr, integer *ilo, integer *ihi, doublereal *scale,
doublereal *abnrm, doublereal *rconde, doublereal *rcondv, doublereal
*work, integer *lwork, integer *iwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, k;
doublereal r__, cs, sn;
char job[1];
doublereal scl, dum[1], eps;
char side[1];
doublereal anrm;
integer ierr, itau;
extern /* Subroutine */ int igraphdrot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
integer iwrk, nout;
extern doublereal igraphdnrm2_(integer *, doublereal *, integer *);
extern /* Subroutine */ int igraphdscal_(integer *, doublereal *, doublereal *,
integer *);
integer icond;
extern logical igraphlsame_(char *, char *);
extern doublereal igraphdlapy2_(doublereal *, doublereal *);
extern /* Subroutine */ int igraphdlabad_(doublereal *, doublereal *), igraphdgebak_(
char *, char *, integer *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *),
igraphdgebal_(char *, integer *, doublereal *, integer *, integer *,
integer *, doublereal *, integer *);
logical scalea;
extern doublereal igraphdlamch_(char *);
doublereal cscale;
extern doublereal igraphdlange_(char *, integer *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int igraphdgehrd_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *), igraphdlascl_(char *, integer *, integer *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *);
extern integer igraphidamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int igraphdlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
igraphdlartg_(doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *), igraphxerbla_(char *, integer *, ftnlen);
logical select[1];
extern integer igraphilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
doublereal bignum;
extern /* Subroutine */ int igraphdorghr_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *), igraphdhseqr_(char *, char *, integer *, integer *, integer
*, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, integer *), igraphdtrevc_(char *, char *, logical *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, integer *, integer *, doublereal *, integer *), igraphdtrsna_(char *, char *, logical *, integer *, doublereal
*, integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, integer *);
integer minwrk, maxwrk;
logical wantvl, wntsnb;
integer hswork;
logical wntsne;
doublereal smlnum;
logical lquery, wantvr, wntsnn, wntsnv;
/* -- LAPACK driver routine (version 3.4.2) --
-- LAPACK is a software package provided by Univ. of Tennessee, --
-- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
September 2012
=====================================================================
Test the input arguments
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--wr;
--wi;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--scale;
--rconde;
--rcondv;
--work;
--iwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1;
wantvl = igraphlsame_(jobvl, "V");
wantvr = igraphlsame_(jobvr, "V");
wntsnn = igraphlsame_(sense, "N");
wntsne = igraphlsame_(sense, "E");
wntsnv = igraphlsame_(sense, "V");
wntsnb = igraphlsame_(sense, "B");
if (! (igraphlsame_(balanc, "N") || igraphlsame_(balanc, "S") || igraphlsame_(balanc, "P")
|| igraphlsame_(balanc, "B"))) {
*info = -1;
} else if (! wantvl && ! igraphlsame_(jobvl, "N")) {
*info = -2;
} else if (! wantvr && ! igraphlsame_(jobvr, "N")) {
*info = -3;
} else if (! (wntsnn || wntsne || wntsnb || wntsnv) || (wntsne || wntsnb)
&& ! (wantvl && wantvr)) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldvl < 1 || wantvl && *ldvl < *n) {
*info = -11;
} else if (*ldvr < 1 || wantvr && *ldvr < *n) {
*info = -13;
}
/* Compute workspace
(Note: Comments in the code beginning "Workspace:" describe the
minimal amount of workspace needed at that point in the code,
as well as the preferred amount for good performance.
NB refers to the optimal block size for the immediately
following subroutine, as returned by ILAENV.
HSWORK refers to the workspace preferred by DHSEQR, as
calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
the worst case.) */
if (*info == 0) {
if (*n == 0) {
minwrk = 1;
maxwrk = 1;
} else {
maxwrk = *n + *n * igraphilaenv_(&c__1, "DGEHRD", " ", n, &c__1, n, &
c__0, (ftnlen)6, (ftnlen)1);
if (wantvl) {
igraphdhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
1], &vl[vl_offset], ldvl, &work[1], &c_n1, info);
} else if (wantvr) {
igraphdhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
1], &vr[vr_offset], ldvr, &work[1], &c_n1, info);
} else {
if (wntsnn) {
igraphdhseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &wr[1],
&wi[1], &vr[vr_offset], ldvr, &work[1], &c_n1,
info);
} else {
igraphdhseqr_("S", "N", n, &c__1, n, &a[a_offset], lda, &wr[1],
&wi[1], &vr[vr_offset], ldvr, &work[1], &c_n1,
info);
}
}
hswork = (integer) work[1];
if (! wantvl && ! wantvr) {
minwrk = *n << 1;
if (! wntsnn) {
/* Computing MAX */
i__1 = minwrk, i__2 = *n * *n + *n * 6;
minwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,hswork);
if (! wntsnn) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *n + *n * 6;
maxwrk = max(i__1,i__2);
}
} else {
minwrk = *n * 3;
if (! wntsnn && ! wntsne) {
/* Computing MAX */
i__1 = minwrk, i__2 = *n * *n + *n * 6;
minwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,hswork);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + (*n - 1) * igraphilaenv_(&c__1, "DORGHR",
" ", n, &c__1, n, &c_n1, (ftnlen)6, (ftnlen)1);
maxwrk = max(i__1,i__2);
if (! wntsnn && ! wntsne) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *n + *n * 6;
maxwrk = max(i__1,i__2);
}
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3;
maxwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,minwrk);
}
work[1] = (doublereal) maxwrk;
if (*lwork < minwrk && ! lquery) {
*info = -21;
}
}
if (*info != 0) {
i__1 = -(*info);
igraphxerbla_("DGEEVX", &i__1, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = igraphdlamch_("P");
smlnum = igraphdlamch_("S");
bignum = 1. / smlnum;
igraphdlabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1. / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
icond = 0;
anrm = igraphdlange_("M", n, n, &a[a_offset], lda, dum);
scalea = FALSE_;
if (anrm > 0. && anrm < smlnum) {
scalea = TRUE_;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE_;
cscale = bignum;
}
if (scalea) {
igraphdlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
ierr);
}
/* Balance the matrix and compute ABNRM */
igraphdgebal_(balanc, n, &a[a_offset], lda, ilo, ihi, &scale[1], &ierr);
*abnrm = igraphdlange_("1", n, n, &a[a_offset], lda, dum);
if (scalea) {
dum[0] = *abnrm;
igraphdlascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &c__1, &
ierr);
*abnrm = dum[0];
}
/* Reduce to upper Hessenberg form
(Workspace: need 2*N, prefer N+N*NB) */
itau = 1;
iwrk = itau + *n;
i__1 = *lwork - iwrk + 1;
igraphdgehrd_(n, ilo, ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, &
ierr);
if (wantvl) {
/* Want left eigenvectors
Copy Householder vectors to VL */
*(unsigned char *)side = 'L';
igraphdlacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl)
;
/* Generate orthogonal matrix in VL
(Workspace: need 2*N-1, prefer N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
igraphdorghr_(n, ilo, ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], &
i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VL
(Workspace: need 1, prefer HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
igraphdhseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vl[
vl_offset], ldvl, &work[iwrk], &i__1, info);
if (wantvr) {
/* Want left and right eigenvectors
Copy Schur vectors to VR */
*(unsigned char *)side = 'B';
igraphdlacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
}
} else if (wantvr) {
/* Want right eigenvectors
Copy Householder vectors to VR */
*(unsigned char *)side = 'R';
igraphdlacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr)
;
/* Generate orthogonal matrix in VR
(Workspace: need 2*N-1, prefer N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
igraphdorghr_(n, ilo, ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], &
i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VR
(Workspace: need 1, prefer HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
igraphdhseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
} else {
/* Compute eigenvalues only
If condition numbers desired, compute Schur form */
if (wntsnn) {
*(unsigned char *)job = 'E';
} else {
*(unsigned char *)job = 'S';
}
/* (Workspace: need 1, prefer HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
igraphdhseqr_(job, "N", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
}
/* If INFO > 0 from DHSEQR, then quit */
if (*info > 0) {
goto L50;
}
if (wantvl || wantvr) {
/* Compute left and/or right eigenvectors
(Workspace: need 3*N) */
igraphdtrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
&vr[vr_offset], ldvr, n, &nout, &work[iwrk], &ierr);
}
/* Compute condition numbers if desired
(Workspace: need N*N+6*N unless SENSE = 'E') */
if (! wntsnn) {
igraphdtrsna_(sense, "A", select, n, &a[a_offset], lda, &vl[vl_offset],
ldvl, &vr[vr_offset], ldvr, &rconde[1], &rcondv[1], n, &nout,
&work[iwrk], n, &iwork[1], &icond);
}
if (wantvl) {
/* Undo balancing of left eigenvectors */
igraphdgebak_(balanc, "L", n, ilo, ihi, &scale[1], n, &vl[vl_offset], ldvl,
&ierr);
/* Normalize left eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wi[i__] == 0.) {
scl = 1. / igraphdnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
igraphdscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
} else if (wi[i__] > 0.) {
d__1 = igraphdnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
d__2 = igraphdnrm2_(n, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
scl = 1. / igraphdlapy2_(&d__1, &d__2);
igraphdscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
igraphdscal_(n, &scl, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* Computing 2nd power */
d__1 = vl[k + i__ * vl_dim1];
/* Computing 2nd power */
d__2 = vl[k + (i__ + 1) * vl_dim1];
work[k] = d__1 * d__1 + d__2 * d__2;
/* L10: */
}
k = igraphidamax_(n, &work[1], &c__1);
igraphdlartg_(&vl[k + i__ * vl_dim1], &vl[k + (i__ + 1) * vl_dim1],
&cs, &sn, &r__);
igraphdrot_(n, &vl[i__ * vl_dim1 + 1], &c__1, &vl[(i__ + 1) *
vl_dim1 + 1], &c__1, &cs, &sn);
vl[k + (i__ + 1) * vl_dim1] = 0.;
}
/* L20: */
}
}
if (wantvr) {
/* Undo balancing of right eigenvectors */
igraphdgebak_(balanc, "R", n, ilo, ihi, &scale[1], n, &vr[vr_offset], ldvr,
&ierr);
/* Normalize right eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wi[i__] == 0.) {
scl = 1. / igraphdnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
igraphdscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
} else if (wi[i__] > 0.) {
d__1 = igraphdnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
d__2 = igraphdnrm2_(n, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
scl = 1. / igraphdlapy2_(&d__1, &d__2);
igraphdscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
igraphdscal_(n, &scl, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* Computing 2nd power */
d__1 = vr[k + i__ * vr_dim1];
/* Computing 2nd power */
d__2 = vr[k + (i__ + 1) * vr_dim1];
work[k] = d__1 * d__1 + d__2 * d__2;
/* L30: */
}
k = igraphidamax_(n, &work[1], &c__1);
igraphdlartg_(&vr[k + i__ * vr_dim1], &vr[k + (i__ + 1) * vr_dim1],
&cs, &sn, &r__);
igraphdrot_(n, &vr[i__ * vr_dim1 + 1], &c__1, &vr[(i__ + 1) *
vr_dim1 + 1], &c__1, &cs, &sn);
vr[k + (i__ + 1) * vr_dim1] = 0.;
}
/* L40: */
}
}
/* Undo scaling if necessary */
L50:
if (scalea) {
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
igraphdlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[*info +
1], &i__2, &ierr);
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
igraphdlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[*info +
1], &i__2, &ierr);
if (*info == 0) {
if ((wntsnv || wntsnb) && icond == 0) {
igraphdlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &rcondv[
1], n, &ierr);
}
} else {
i__1 = *ilo - 1;
igraphdlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[1],
n, &ierr);
i__1 = *ilo - 1;
igraphdlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[1],
n, &ierr);
}
}
work[1] = (doublereal) maxwrk;
return 0;
/* End of DGEEVX */
} /* igraphdgeevx_ */
Subroutine */ int igraphdgetrs_(char *trans, integer *n, integer *nrhs,
doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer *
ldb, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1;
/* Local variables */
extern logical igraphlsame_(char *, char *);
extern /* Subroutine */ int igraphdtrsm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *), igraphxerbla_(
char *, integer *, ftnlen), igraphdlaswp_(integer *, doublereal *,
integer *, integer *, integer *, integer *, integer *);
logical notran;
/* -- LAPACK computational routine (version 3.4.0) --
-- LAPACK is a software package provided by Univ. of Tennessee, --
-- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
November 2011
=====================================================================
Test the input parameters.
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
notran = igraphlsame_(trans, "N");
if (! notran && ! igraphlsame_(trans, "T") && ! igraphlsame_(
trans, "C")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
igraphxerbla_("DGETRS", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
return 0;
}
if (notran) {
/* Solve A * X = B.
Apply row interchanges to the right hand sides. */
igraphdlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c__1);
/* Solve L*X = B, overwriting B with X. */
igraphdtrsm_("Left", "Lower", "No transpose", "Unit", n, nrhs, &c_b12, &a[
a_offset], lda, &b[b_offset], ldb);
/* Solve U*X = B, overwriting B with X. */
igraphdtrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b12, &
a[a_offset], lda, &b[b_offset], ldb);
} else {
/* Solve A**T * X = B.
Solve U**T *X = B, overwriting B with X. */
igraphdtrsm_("Left", "Upper", "Transpose", "Non-unit", n, nrhs, &c_b12, &a[
a_offset], lda, &b[b_offset], ldb);
/* Solve L**T *X = B, overwriting B with X. */
igraphdtrsm_("Left", "Lower", "Transpose", "Unit", n, nrhs, &c_b12, &a[
a_offset], lda, &b[b_offset], ldb);
/* Apply row interchanges to the solution vectors. */
igraphdlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c_n1);
}
return 0;
/* End of DGETRS */
} /* igraphdgetrs_ */
/* Subroutine */ int igraphdorm2l_(char *side, char *trans, integer *m, integer *n,
integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
c__, integer *ldc, doublereal *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
/* Local variables */
integer i__, i1, i2, i3, mi, ni, nq;
doublereal aii;
logical left;
extern /* Subroutine */ int igraphdlarf_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *);
extern logical igraphlsame_(char *, char *);
extern /* Subroutine */ int igraphxerbla_(char *, integer *, ftnlen);
logical notran;
/* -- LAPACK routine (version 3.3.1) --
-- LAPACK is a software package provided by Univ. of Tennessee, --
-- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-- April 2011 --
Purpose
=======
DORM2L overwrites the general real m by n matrix C with
Q * C if SIDE = 'L' and TRANS = 'N', or
Q**T * C if SIDE = 'L' and TRANS = 'T', or
C * Q if SIDE = 'R' and TRANS = 'N', or
C * Q**T if SIDE = 'R' and TRANS = 'T',
where Q is a real orthogonal matrix defined as the product of k
elementary reflectors
Q = H(k) . . . H(2) H(1)
as returned by DGEQLF. Q is of order m if SIDE = 'L' and of order n
if SIDE = 'R'.
Arguments
=========
SIDE (input) CHARACTER*1
= 'L': apply Q or Q**T from the Left
= 'R': apply Q or Q**T from the Right
TRANS (input) CHARACTER*1
= 'N': apply Q (No transpose)
= 'T': apply Q**T (Transpose)
M (input) INTEGER
The number of rows of the matrix C. M >= 0.
N (input) INTEGER
The number of columns of the matrix C. N >= 0.
K (input) INTEGER
The number of elementary reflectors whose product defines
the matrix Q.
If SIDE = 'L', M >= K >= 0;
if SIDE = 'R', N >= K >= 0.
A (input) DOUBLE PRECISION array, dimension (LDA,K)
The i-th column must contain the vector which defines the
elementary reflector H(i), for i = 1,2,...,k, as returned by
DGEQLF in the last k columns of its array argument A.
A is modified by the routine but restored on exit.
LDA (input) INTEGER
The leading dimension of the array A.
If SIDE = 'L', LDA >= max(1,M);
if SIDE = 'R', LDA >= max(1,N).
TAU (input) DOUBLE PRECISION array, dimension (K)
TAU(i) must contain the scalar factor of the elementary
reflector H(i), as returned by DGEQLF.
C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
On entry, the m by n matrix C.
On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
LDC (input) INTEGER
The leading dimension of the array C. LDC >= max(1,M).
WORK (workspace) DOUBLE PRECISION array, dimension
(N) if SIDE = 'L',
(M) if SIDE = 'R'
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input arguments
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = igraphlsame_(side, "L");
notran = igraphlsame_(trans, "N");
/* NQ is the order of Q */
if (left) {
nq = *m;
} else {
nq = *n;
}
if (! left && ! igraphlsame_(side, "R")) {
*info = -1;
} else if (! notran && ! igraphlsame_(trans, "T")) {
*info = -2;
} else if (*m < 0) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*k < 0 || *k > nq) {
*info = -5;
} else if (*lda < max(1,nq)) {
*info = -7;
} else if (*ldc < max(1,*m)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
igraphxerbla_("DORM2L", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0 || *k == 0) {
return 0;
}
if (left && notran || ! left && ! notran) {
i1 = 1;
i2 = *k;
i3 = 1;
} else {
i1 = *k;
i2 = 1;
i3 = -1;
}
if (left) {
ni = *n;
} else {
mi = *m;
}
i__1 = i2;
i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
if (left) {
/* H(i) is applied to C(1:m-k+i,1:n) */
mi = *m - *k + i__;
} else {
/* H(i) is applied to C(1:m,1:n-k+i) */
ni = *n - *k + i__;
}
/* Apply H(i) */
aii = a[nq - *k + i__ + i__ * a_dim1];
a[nq - *k + i__ + i__ * a_dim1] = 1.;
igraphdlarf_(side, &mi, &ni, &a[i__ * a_dim1 + 1], &c__1, &tau[i__], &c__[
c_offset], ldc, &work[1]);
a[nq - *k + i__ + i__ * a_dim1] = aii;
/* L10: */
}
return 0;
/* End of DORM2L */
} /* igraphdorm2l_ */
/* Subroutine */ int igraphdormql_(char *side, char *trans, integer *m, integer *n,
integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
c__, integer *ldc, doublereal *work, integer *lwork, integer *info)
{
/* System generated locals */
address a__1[2];
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
i__5;
char ch__1[2];
/* Builtin functions
Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
integer i__;
doublereal t[4160] /* was [65][64] */;
integer i1, i2, i3, ib, nb, mi, ni, nq, nw, iws;
logical left;
extern logical igraphlsame_(char *, char *);
integer nbmin, iinfo;
extern /* Subroutine */ int igraphdorm2l_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *), igraphdlarfb_(char
*, char *, char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *), igraphdlarft_(char *, char *, integer *, integer *, doublereal
*, integer *, doublereal *, doublereal *, integer *), igraphxerbla_(char *, integer *, ftnlen);
extern integer igraphilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
logical notran;
integer ldwork, lwkopt;
logical lquery;
/* -- LAPACK routine (version 3.3.1) --
-- LAPACK is a software package provided by Univ. of Tennessee, --
-- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-- April 2011 --
Purpose
=======
DORMQL overwrites the general real M-by-N matrix C with
SIDE = 'L' SIDE = 'R'
TRANS = 'N': Q * C C * Q
TRANS = 'T': Q**T * C C * Q**T
where Q is a real orthogonal matrix defined as the product of k
elementary reflectors
Q = H(k) . . . H(2) H(1)
as returned by DGEQLF. Q is of order M if SIDE = 'L' and of order N
if SIDE = 'R'.
Arguments
=========
SIDE (input) CHARACTER*1
= 'L': apply Q or Q**T from the Left;
= 'R': apply Q or Q**T from the Right.
TRANS (input) CHARACTER*1
= 'N': No transpose, apply Q;
= 'T': Transpose, apply Q**T.
M (input) INTEGER
The number of rows of the matrix C. M >= 0.
N (input) INTEGER
The number of columns of the matrix C. N >= 0.
K (input) INTEGER
The number of elementary reflectors whose product defines
the matrix Q.
If SIDE = 'L', M >= K >= 0;
if SIDE = 'R', N >= K >= 0.
A (input) DOUBLE PRECISION array, dimension (LDA,K)
The i-th column must contain the vector which defines the
elementary reflector H(i), for i = 1,2,...,k, as returned by
DGEQLF in the last k columns of its array argument A.
A is modified by the routine but restored on exit.
LDA (input) INTEGER
The leading dimension of the array A.
If SIDE = 'L', LDA >= max(1,M);
if SIDE = 'R', LDA >= max(1,N).
TAU (input) DOUBLE PRECISION array, dimension (K)
TAU(i) must contain the scalar factor of the elementary
reflector H(i), as returned by DGEQLF.
C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
On entry, the M-by-N matrix C.
On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
LDC (input) INTEGER
The leading dimension of the array C. LDC >= max(1,M).
WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK.
If SIDE = 'L', LWORK >= max(1,N);
if SIDE = 'R', LWORK >= max(1,M).
For optimum performance LWORK >= N*NB if SIDE = 'L', and
LWORK >= M*NB if SIDE = 'R', 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 had an illegal value
=====================================================================
Test the input arguments
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = igraphlsame_(side, "L");
notran = igraphlsame_(trans, "N");
lquery = *lwork == -1;
/* NQ is the order of Q and NW is the minimum dimension of WORK */
if (left) {
nq = *m;
nw = max(1,*n);
} else {
nq = *n;
nw = max(1,*m);
}
if (! left && ! igraphlsame_(side, "R")) {
*info = -1;
} else if (! notran && ! igraphlsame_(trans, "T")) {
*info = -2;
} else if (*m < 0) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*k < 0 || *k > nq) {
*info = -5;
} else if (*lda < max(1,nq)) {
*info = -7;
} else if (*ldc < max(1,*m)) {
*info = -10;
}
if (*info == 0) {
if (*m == 0 || *n == 0) {
lwkopt = 1;
} else {
/* Determine the block size. NB may be at most NBMAX, where
NBMAX is used to define the local array T.
Computing MIN
Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = 64, i__2 = igraphilaenv_(&c__1, "DORMQL", ch__1, m, n, k, &c_n1,
(ftnlen)6, (ftnlen)2);
nb = min(i__1,i__2);
lwkopt = nw * nb;
}
work[1] = (doublereal) lwkopt;
if (*lwork < nw && ! lquery) {
*info = -12;
}
}
if (*info != 0) {
i__1 = -(*info);
igraphxerbla_("DORMQL", &i__1, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
nbmin = 2;
ldwork = nw;
if (nb > 1 && nb < *k) {
iws = nw * nb;
if (*lwork < iws) {
nb = *lwork / ldwork;
/* Computing MAX
Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = 2, i__2 = igraphilaenv_(&c__2, "DORMQL", ch__1, m, n, k, &c_n1, (
ftnlen)6, (ftnlen)2);
nbmin = max(i__1,i__2);
}
} else {
iws = nw;
}
if (nb < nbmin || nb >= *k) {
/* Use unblocked code */
igraphdorm2l_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
c_offset], ldc, &work[1], &iinfo);
} else {
/* Use blocked code */
if (left && notran || ! left && ! notran) {
i1 = 1;
i2 = *k;
i3 = nb;
} else {
i1 = (*k - 1) / nb * nb + 1;
i2 = 1;
i3 = -nb;
}
if (left) {
ni = *n;
} else {
mi = *m;
}
i__1 = i2;
i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__4 = nb, i__5 = *k - i__ + 1;
ib = min(i__4,i__5);
/* Form the triangular factor of the block reflector
H = H(i+ib-1) . . . H(i+1) H(i) */
i__4 = nq - *k + i__ + ib - 1;
igraphdlarft_("Backward", "Columnwise", &i__4, &ib, &a[i__ * a_dim1 + 1]
, lda, &tau[i__], t, &c__65);
if (left) {
/* H or H**T is applied to C(1:m-k+i+ib-1,1:n) */
mi = *m - *k + i__ + ib - 1;
} else {
/* H or H**T is applied to C(1:m,1:n-k+i+ib-1) */
ni = *n - *k + i__ + ib - 1;
}
/* Apply H or H**T */
igraphdlarfb_(side, trans, "Backward", "Columnwise", &mi, &ni, &ib, &a[
i__ * a_dim1 + 1], lda, t, &c__65, &c__[c_offset], ldc, &
work[1], &ldwork);
/* L10: */
}
}
work[1] = (doublereal) lwkopt;
return 0;
/* End of DORMQL */
} /* igraphdormql_ */
/* Subroutine */ int igraphdsytrd_(char *uplo, integer *n, doublereal *a, integer *
lda, doublereal *d__, doublereal *e, doublereal *tau, doublereal *
work, integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
integer i__, j, nb, kk, nx, iws;
extern logical igraphlsame_(char *, char *);
integer nbmin, iinfo;
logical upper;
extern /* Subroutine */ int igraphdsytd2_(char *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, integer *), igraphdsyr2k_(char *, char *, integer *, integer *, doublereal
*, doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *), igraphdlatrd_(char *,
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, integer *), igraphxerbla_(char *,
integer *, ftnlen);
extern integer igraphilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
integer ldwork, lwkopt;
logical lquery;
/* -- LAPACK routine (version 3.3.1) --
-- LAPACK is a software package provided by Univ. of Tennessee, --
-- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-- April 2011 --
Purpose
=======
DSYTRD reduces a real symmetric matrix A to real symmetric
tridiagonal form T by an orthogonal similarity transformation:
Q**T * A * Q = T.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
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, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading N-by-N lower triangular part of A contains the lower
triangular part of the matrix A, and the strictly upper
triangular part of A is not referenced.
On exit, if UPLO = 'U', the diagonal and first superdiagonal
of A are overwritten by the corresponding elements of the
tridiagonal matrix T, and the elements above the first
superdiagonal, with the array TAU, represent the orthogonal
matrix Q as a product of elementary reflectors; if UPLO
= 'L', the diagonal and first subdiagonal of A are over-
written by the corresponding elements of the tridiagonal
matrix T, and the elements below the first subdiagonal, with
the array TAU, represent the orthogonal matrix Q as a product
of elementary reflectors. See Further Details.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
D (output) DOUBLE PRECISION array, dimension (N)
The diagonal elements of the tridiagonal matrix T:
D(i) = A(i,i).
E (output) DOUBLE PRECISION array, dimension (N-1)
The off-diagonal elements of the tridiagonal matrix T:
E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
TAU (output) DOUBLE PRECISION array, dimension (N-1)
The scalar factors of the elementary reflectors (see Further
Details).
WORK (workspace/output) DOUBLE PRECISION 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 >= 1.
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 had an illegal value
Further Details
===============
If UPLO = 'U', the matrix Q is represented as a product of elementary
reflectors
Q = H(n-1) . . . H(2) H(1).
Each H(i) has the form
H(i) = I - tau * v * v**T
where tau is a real scalar, and v is a real vector with
v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
A(1:i-1,i+1), and tau in TAU(i).
If UPLO = 'L', the matrix Q is represented as a product of elementary
reflectors
Q = H(1) H(2) . . . H(n-1).
Each H(i) has the form
H(i) = I - tau * v * v**T
where tau is a real scalar, and v is a real vector with
v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
and tau in TAU(i).
The contents of A on exit are illustrated by the following examples
with n = 5:
if UPLO = 'U': if UPLO = 'L':
( d e v2 v3 v4 ) ( d )
( d e v3 v4 ) ( e d )
( d e v4 ) ( v1 e d )
( d e ) ( v1 v2 e d )
( d ) ( v1 v2 v3 e d )
where d and e denote diagonal and off-diagonal elements of T, and vi
denotes an element of the vector defining H(i).
=====================================================================
Test the input parameters
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--d__;
--e;
--tau;
--work;
/* Function Body */
*info = 0;
upper = igraphlsame_(uplo, "U");
lquery = *lwork == -1;
if (! upper && ! igraphlsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
} else if (*lwork < 1 && ! lquery) {
*info = -9;
}
if (*info == 0) {
/* Determine the block size. */
nb = igraphilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6,
(ftnlen)1);
lwkopt = *n * nb;
work[1] = (doublereal) lwkopt;
}
if (*info != 0) {
i__1 = -(*info);
igraphxerbla_("DSYTRD", &i__1, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
work[1] = 1.;
return 0;
}
nx = *n;
iws = 1;
if (nb > 1 && nb < *n) {
/* Determine when to cross over from blocked to unblocked code
(last block is always handled by unblocked code).
Computing MAX */
i__1 = nb, i__2 = igraphilaenv_(&c__3, "DSYTRD", uplo, n, &c_n1, &c_n1, &
c_n1, (ftnlen)6, (ftnlen)1);
nx = max(i__1,i__2);
if (nx < *n) {
/* Determine if workspace is large enough for blocked code. */
ldwork = *n;
iws = ldwork * nb;
if (*lwork < iws) {
/* Not enough workspace to use optimal NB: determine the
minimum value of NB, and reduce NB or force use of
unblocked code by setting NX = N.
Computing MAX */
i__1 = *lwork / ldwork;
nb = max(i__1,1);
nbmin = igraphilaenv_(&c__2, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1,
(ftnlen)6, (ftnlen)1);
if (nb < nbmin) {
nx = *n;
}
}
} else {
nx = *n;
}
} else {
nb = 1;
}
if (upper) {
/* Reduce the upper triangle of A.
Columns 1:kk are handled by the unblocked method. */
kk = *n - (*n - nx + nb - 1) / nb * nb;
i__1 = kk + 1;
i__2 = -nb;
for (i__ = *n - nb + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
i__2) {
/* Reduce columns i:i+nb-1 to tridiagonal form and form the
matrix W which is needed to update the unreduced part of
the matrix */
i__3 = i__ + nb - 1;
igraphdlatrd_(uplo, &i__3, &nb, &a[a_offset], lda, &e[1], &tau[1], &
work[1], &ldwork);
/* Update the unreduced submatrix A(1:i-1,1:i-1), using an
update of the form: A := A - V*W**T - W*V**T */
i__3 = i__ - 1;
igraphdsyr2k_(uplo, "No transpose", &i__3, &nb, &c_b22, &a[i__ * a_dim1
+ 1], lda, &work[1], &ldwork, &c_b23, &a[a_offset], lda);
/* Copy superdiagonal elements back into A, and diagonal
elements into D */
i__3 = i__ + nb - 1;
for (j = i__; j <= i__3; ++j) {
a[j - 1 + j * a_dim1] = e[j - 1];
d__[j] = a[j + j * a_dim1];
/* L10: */
}
/* L20: */
}
/* Use unblocked code to reduce the last or only block */
igraphdsytd2_(uplo, &kk, &a[a_offset], lda, &d__[1], &e[1], &tau[1], &iinfo);
} else {
/* Reduce the lower triangle of A */
i__2 = *n - nx;
i__1 = nb;
for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
/* Reduce columns i:i+nb-1 to tridiagonal form and form the
matrix W which is needed to update the unreduced part of
the matrix */
i__3 = *n - i__ + 1;
igraphdlatrd_(uplo, &i__3, &nb, &a[i__ + i__ * a_dim1], lda, &e[i__], &
tau[i__], &work[1], &ldwork);
/* Update the unreduced submatrix A(i+ib:n,i+ib:n), using
an update of the form: A := A - V*W**T - W*V**T */
i__3 = *n - i__ - nb + 1;
igraphdsyr2k_(uplo, "No transpose", &i__3, &nb, &c_b22, &a[i__ + nb +
i__ * a_dim1], lda, &work[nb + 1], &ldwork, &c_b23, &a[
i__ + nb + (i__ + nb) * a_dim1], lda);
/* Copy subdiagonal elements back into A, and diagonal
elements into D */
i__3 = i__ + nb - 1;
for (j = i__; j <= i__3; ++j) {
a[j + 1 + j * a_dim1] = e[j];
d__[j] = a[j + j * a_dim1];
/* L30: */
}
/* L40: */
}
/* Use unblocked code to reduce the last or only block */
i__1 = *n - i__ + 1;
igraphdsytd2_(uplo, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__],
&tau[i__], &iinfo);
}
work[1] = (doublereal) lwkopt;
return 0;
/* End of DSYTRD */
} /* igraphdsytrd_ */
/* ===================================================================== */
/* Subroutine */ int igraphdlarft_(char *direct, char *storev, integer *n, integer *
k, doublereal *v, integer *ldv, doublereal *tau, doublereal *t,
integer *ldt)
{
/* System generated locals */
integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3;
doublereal d__1;
/* Local variables */
integer i__, j, prevlastv;
extern logical igraphlsame_(char *, char *);
extern /* Subroutine */ int igraphdgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
integer lastv;
extern /* Subroutine */ int igraphdtrmv_(char *, char *, char *, integer *,
doublereal *, integer *, doublereal *, integer *);
/* -- LAPACK auxiliary routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--tau;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
/* Function Body */
if (*n == 0) {
return 0;
}
if (igraphlsame_(direct, "F")) {
prevlastv = *n;
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
prevlastv = max(i__,prevlastv);
if (tau[i__] == 0.) {
/* H(i) = I */
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
t[j + i__ * t_dim1] = 0.;
}
} else {
/* general case */
if (igraphlsame_(storev, "C")) {
/* Skip any trailing zeros. */
lastv = *n;
L14:
if (v[lastv + i__ * v_dim1] != 0.) {
goto L15;
}
if (lastv == i__ + 1) {
goto L15;
}
--lastv;
goto L14;
L15:
/* DO LASTV = N, I+1, -1 */
/* IF( V( LASTV, I ).NE.ZERO ) EXIT */
/* END DO */
i__2 = i__ - 1;
for (j = 1; j <= i__2; ++j) {
t[j + i__ * t_dim1] = -tau[i__] * v[i__ + j * v_dim1];
}
j = min(lastv,prevlastv);
/* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) */
i__2 = j - i__;
i__3 = i__ - 1;
d__1 = -tau[i__];
igraphdgemv_("Transpose", &i__2, &i__3, &d__1, &v[i__ + 1 +
v_dim1], ldv, &v[i__ + 1 + i__ * v_dim1], &c__1, &
c_b8, &t[i__ * t_dim1 + 1], &c__1);
} else {
/* Skip any trailing zeros. */
lastv = *n;
L16:
if (v[i__ + lastv * v_dim1] != 0.) {
goto L17;
}
if (lastv == i__ + 1) {
goto L17;
}
--lastv;
goto L16;
L17:
/* DO LASTV = N, I+1, -1 */
/* IF( V( I, LASTV ).NE.ZERO ) EXIT */
/* END DO */
i__2 = i__ - 1;
for (j = 1; j <= i__2; ++j) {
t[j + i__ * t_dim1] = -tau[i__] * v[j + i__ * v_dim1];
}
j = min(lastv,prevlastv);
/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T */
i__2 = i__ - 1;
i__3 = j - i__;
d__1 = -tau[i__];
igraphdgemv_("No transpose", &i__2, &i__3, &d__1, &v[(i__ + 1) *
v_dim1 + 1], ldv, &v[i__ + (i__ + 1) * v_dim1],
ldv, &c_b8, &t[i__ * t_dim1 + 1], &c__1);
}
/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */
i__2 = i__ - 1;
igraphdtrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[
t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1);
t[i__ + i__ * t_dim1] = tau[i__];
if (i__ > 1) {
prevlastv = max(prevlastv,lastv);
} else {
prevlastv = lastv;
}
}
}
} else {
prevlastv = 1;
for (i__ = *k; i__ >= 1; --i__) {
if (tau[i__] == 0.) {
/* H(i) = I */
i__1 = *k;
for (j = i__; j <= i__1; ++j) {
t[j + i__ * t_dim1] = 0.;
}
} else {
/* general case */
if (i__ < *k) {
if (igraphlsame_(storev, "C")) {
/* Skip any leading zeros. */
lastv = 1;
L34:
if (v[lastv + i__ * v_dim1] != 0.) {
goto L35;
}
if (lastv == i__ - 1) {
goto L35;
}
++lastv;
goto L34;
L35:
/* DO LASTV = 1, I-1 */
/* IF( V( LASTV, I ).NE.ZERO ) EXIT */
/* END DO */
i__1 = *k;
for (j = i__ + 1; j <= i__1; ++j) {
t[j + i__ * t_dim1] = -tau[i__] * v[*n - *k + i__
+ j * v_dim1];
}
j = max(lastv,prevlastv);
/* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i) */
i__1 = *n - *k + i__ - j;
i__2 = *k - i__;
d__1 = -tau[i__];
igraphdgemv_("Transpose", &i__1, &i__2, &d__1, &v[j + (i__
+ 1) * v_dim1], ldv, &v[j + i__ * v_dim1], &
c__1, &c_b8, &t[i__ + 1 + i__ * t_dim1], &
c__1);
} else {
/* Skip any leading zeros. */
lastv = 1;
/* L36: */
if (v[i__ + lastv * v_dim1] != 0.) {
goto L37;
}
if (lastv == i__ - 1) {
goto L37;
}
++lastv;
L37:
/* DO LASTV = 1, I-1 */
/* IF( V( I, LASTV ).NE.ZERO ) EXIT */
/* END DO */
i__1 = *k;
for (j = i__ + 1; j <= i__1; ++j) {
t[j + i__ * t_dim1] = -tau[i__] * v[j + (*n - *k
+ i__) * v_dim1];
}
j = max(lastv,prevlastv);
/* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T */
i__1 = *k - i__;
i__2 = *n - *k + i__ - j;
d__1 = -tau[i__];
igraphdgemv_("No transpose", &i__1, &i__2, &d__1, &v[i__ +
1 + j * v_dim1], ldv, &v[i__ + j * v_dim1],
ldv, &c_b8, &t[i__ + 1 + i__ * t_dim1], &c__1
);
}
/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */
i__1 = *k - i__;
igraphdtrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__
+ 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ *
t_dim1], &c__1)
;
if (i__ > 1) {
prevlastv = min(prevlastv,lastv);
} else {
prevlastv = lastv;
}
}
t[i__ + i__ * t_dim1] = tau[i__];
}
}
}
return 0;
/* End of DLARFT */
} /* dlarft_ */
/* Subroutine */ int igraphdormhr_(char *side, char *trans, integer *m, integer *n,
integer *ilo, integer *ihi, doublereal *a, integer *lda, doublereal *
tau, doublereal *c__, integer *ldc, doublereal *work, integer *lwork,
integer *info)
{
/* System generated locals */
address a__1[2];
integer a_dim1, a_offset, c_dim1, c_offset, i__1[2], i__2;
char ch__1[2];
/* Builtin functions
Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
integer i1, i2, nb, mi, nh, ni, nq, nw;
logical left;
extern logical igraphlsame_(char *, char *);
integer iinfo;
extern /* Subroutine */ int igraphxerbla_(char *, integer *, ftnlen);
extern integer igraphilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int igraphdormqr_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *);
integer lwkopt;
logical lquery;
/* -- LAPACK routine (version 3.2) --
-- LAPACK is a software package provided by Univ. of Tennessee, --
-- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
November 2006
Purpose
=======
DORMHR overwrites the general real M-by-N matrix C with
SIDE = 'L' SIDE = 'R'
TRANS = 'N': Q * C C * Q
TRANS = 'T': Q**T * C C * Q**T
where Q is a real orthogonal matrix of order nq, with nq = m if
SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
IHI-ILO elementary reflectors, as returned by DGEHRD:
Q = H(ilo) H(ilo+1) . . . H(ihi-1).
Arguments
=========
SIDE (input) CHARACTER*1
= 'L': apply Q or Q**T from the Left;
= 'R': apply Q or Q**T from the Right.
TRANS (input) CHARACTER*1
= 'N': No transpose, apply Q;
= 'T': Transpose, apply Q**T.
M (input) INTEGER
The number of rows of the matrix C. M >= 0.
N (input) INTEGER
The number of columns of the matrix C. N >= 0.
ILO (input) INTEGER
IHI (input) INTEGER
ILO and IHI must have the same values as in the previous call
of DGEHRD. Q is equal to the unit matrix except in the
submatrix Q(ilo+1:ihi,ilo+1:ihi).
If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and
ILO = 1 and IHI = 0, if M = 0;
if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and
ILO = 1 and IHI = 0, if N = 0.
A (input) DOUBLE PRECISION array, dimension
(LDA,M) if SIDE = 'L'
(LDA,N) if SIDE = 'R'
The vectors which define the elementary reflectors, as
returned by DGEHRD.
LDA (input) INTEGER
The leading dimension of the array A.
LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
TAU (input) DOUBLE PRECISION array, dimension
(M-1) if SIDE = 'L'
(N-1) if SIDE = 'R'
TAU(i) must contain the scalar factor of the elementary
reflector H(i), as returned by DGEHRD.
C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
On entry, the M-by-N matrix C.
On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
LDC (input) INTEGER
The leading dimension of the array C. LDC >= max(1,M).
WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK.
If SIDE = 'L', LWORK >= max(1,N);
if SIDE = 'R', LWORK >= max(1,M).
For optimum performance LWORK >= N*NB if SIDE = 'L', and
LWORK >= M*NB if SIDE = 'R', 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 had an illegal value
=====================================================================
Test the input arguments
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
nh = *ihi - *ilo;
left = igraphlsame_(side, "L");
lquery = *lwork == -1;
/* NQ is the order of Q and NW is the minimum dimension of WORK */
if (left) {
nq = *m;
nw = *n;
} else {
nq = *n;
nw = *m;
}
if (! left && ! igraphlsame_(side, "R")) {
*info = -1;
} else if (! igraphlsame_(trans, "N") && ! igraphlsame_(trans,
"T")) {
*info = -2;
} else if (*m < 0) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*ilo < 1 || *ilo > max(1,nq)) {
*info = -5;
} else if (*ihi < min(*ilo,nq) || *ihi > nq) {
*info = -6;
} else if (*lda < max(1,nq)) {
*info = -8;
} else if (*ldc < max(1,*m)) {
*info = -11;
} else if (*lwork < max(1,nw) && ! lquery) {
*info = -13;
}
if (*info == 0) {
if (left) {
/* Writing concatenation */
i__1[0] = 1, a__1[0] = side;
i__1[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
nb = igraphilaenv_(&c__1, "DORMQR", ch__1, &nh, n, &nh, &c_n1, (ftnlen)
6, (ftnlen)2);
} else {
/* Writing concatenation */
i__1[0] = 1, a__1[0] = side;
i__1[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
nb = igraphilaenv_(&c__1, "DORMQR", ch__1, m, &nh, &nh, &c_n1, (ftnlen)
6, (ftnlen)2);
}
lwkopt = max(1,nw) * nb;
work[1] = (doublereal) lwkopt;
}
if (*info != 0) {
i__2 = -(*info);
igraphxerbla_("DORMHR", &i__2, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0 || nh == 0) {
work[1] = 1.;
return 0;
}
if (left) {
mi = nh;
ni = *n;
i1 = *ilo + 1;
i2 = 1;
} else {
mi = *m;
ni = nh;
i1 = 1;
i2 = *ilo + 1;
}
igraphdormqr_(side, trans, &mi, &ni, &nh, &a[*ilo + 1 + *ilo * a_dim1], lda, &
tau[*ilo], &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo);
work[1] = (doublereal) lwkopt;
return 0;
/* End of DORMHR */
} /* igraphdormhr_ */
Subroutine */ int igraphdormqr_(char *side, char *trans, integer *m, integer *n,
integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
c__, integer *ldc, doublereal *work, integer *lwork, integer *info)
{
/* System generated locals */
address a__1[2];
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
i__5;
char ch__1[2];
/* Builtin functions
Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
integer i__;
doublereal t[4160] /* was [65][64] */;
integer i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iws;
logical left;
extern logical igraphlsame_(char *, char *);
integer nbmin, iinfo;
extern /* Subroutine */ int igraphdorm2r_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *), igraphdlarfb_(char
*, char *, char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *), igraphdlarft_(char *, char *, integer *, integer *, doublereal
*, integer *, doublereal *, doublereal *, integer *), igraphxerbla_(char *, integer *, ftnlen);
extern integer igraphilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
logical notran;
integer ldwork, lwkopt;
logical lquery;
/* -- LAPACK computational routine (version 3.4.0) --
-- LAPACK is a software package provided by Univ. of Tennessee, --
-- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
November 2011
=====================================================================
Test the input arguments
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = igraphlsame_(side, "L");
notran = igraphlsame_(trans, "N");
lquery = *lwork == -1;
/* NQ is the order of Q and NW is the minimum dimension of WORK */
if (left) {
nq = *m;
nw = *n;
} else {
nq = *n;
nw = *m;
}
if (! left && ! igraphlsame_(side, "R")) {
*info = -1;
} else if (! notran && ! igraphlsame_(trans, "T")) {
*info = -2;
} else if (*m < 0) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*k < 0 || *k > nq) {
*info = -5;
} else if (*lda < max(1,nq)) {
*info = -7;
} else if (*ldc < max(1,*m)) {
*info = -10;
} else if (*lwork < max(1,nw) && ! lquery) {
*info = -12;
}
if (*info == 0) {
/* Determine the block size. NB may be at most NBMAX, where NBMAX
is used to define the local array T.
Computing MIN
Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = 64, i__2 = igraphilaenv_(&c__1, "DORMQR", ch__1, m, n, k, &c_n1, (
ftnlen)6, (ftnlen)2);
nb = min(i__1,i__2);
lwkopt = max(1,nw) * nb;
work[1] = (doublereal) lwkopt;
}
if (*info != 0) {
i__1 = -(*info);
igraphxerbla_("DORMQR", &i__1, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0 || *k == 0) {
work[1] = 1.;
return 0;
}
nbmin = 2;
ldwork = nw;
if (nb > 1 && nb < *k) {
iws = nw * nb;
if (*lwork < iws) {
nb = *lwork / ldwork;
/* Computing MAX
Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = 2, i__2 = igraphilaenv_(&c__2, "DORMQR", ch__1, m, n, k, &c_n1, (
ftnlen)6, (ftnlen)2);
nbmin = max(i__1,i__2);
}
} else {
iws = nw;
}
if (nb < nbmin || nb >= *k) {
/* Use unblocked code */
igraphdorm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
c_offset], ldc, &work[1], &iinfo);
} else {
/* Use blocked code */
if (left && ! notran || ! left && notran) {
i1 = 1;
i2 = *k;
i3 = nb;
} else {
i1 = (*k - 1) / nb * nb + 1;
i2 = 1;
i3 = -nb;
}
if (left) {
ni = *n;
jc = 1;
} else {
mi = *m;
ic = 1;
}
i__1 = i2;
i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__4 = nb, i__5 = *k - i__ + 1;
ib = min(i__4,i__5);
/* Form the triangular factor of the block reflector
H = H(i) H(i+1) . . . H(i+ib-1) */
i__4 = nq - i__ + 1;
igraphdlarft_("Forward", "Columnwise", &i__4, &ib, &a[i__ + i__ *
a_dim1], lda, &tau[i__], t, &c__65)
;
if (left) {
/* H or H**T is applied to C(i:m,1:n) */
mi = *m - i__ + 1;
ic = i__;
} else {
/* H or H**T is applied to C(1:m,i:n) */
ni = *n - i__ + 1;
jc = i__;
}
/* Apply H or H**T */
igraphdlarfb_(side, trans, "Forward", "Columnwise", &mi, &ni, &ib, &a[
i__ + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc *
c_dim1], ldc, &work[1], &ldwork);
/* L10: */
}
}
work[1] = (doublereal) lwkopt;
return 0;
/* End of DORMQR */
} /* igraphdormqr_ */
/* Subroutine */ int igraphdtrsen_(char *job, char *compq, logical *select, integer
*n, doublereal *t, integer *ldt, doublereal *q, integer *ldq,
doublereal *wr, doublereal *wi, integer *m, doublereal *s, doublereal
*sep, doublereal *work, integer *lwork, integer *iwork, integer *
liwork, integer *info)
{
/* System generated locals */
integer q_dim1, q_offset, t_dim1, t_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer k, n1, n2, kk, nn, ks;
doublereal est;
integer kase;
logical pair;
integer ierr;
logical swap;
doublereal scale;
extern logical igraphlsame_(char *, char *);
integer isave[3], lwmin;
logical wantq, wants;
doublereal rnorm;
extern /* Subroutine */ int igraphdlacn2_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *);
extern doublereal igraphdlange_(char *, integer *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int igraphdlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
igraphxerbla_(char *, integer *, ftnlen);
logical wantbh;
extern /* Subroutine */ int igraphdtrexc_(char *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, integer *,
doublereal *, integer *);
integer liwmin;
logical wantsp, lquery;
extern /* Subroutine */ int igraphdtrsyl_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *);
/* -- LAPACK routine (version 3.3.1) --
-- LAPACK is a software package provided by Univ. of Tennessee, --
-- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-- April 2011 --
Purpose
=======
DTRSEN reorders the real Schur factorization of a real matrix
A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in
the leading diagonal blocks of the upper quasi-triangular matrix T,
and the leading columns of Q form an orthonormal basis of the
corresponding right invariant subspace.
Optionally the routine computes the reciprocal condition numbers of
the cluster of eigenvalues and/or the invariant subspace.
T must be in Schur canonical form (as returned by DHSEQR), that is,
block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
2-by-2 diagonal block has its diagonal elemnts equal and its
off-diagonal elements of opposite sign.
Arguments
=========
JOB (input) CHARACTER*1
Specifies whether condition numbers are required for the
cluster of eigenvalues (S) or the invariant subspace (SEP):
= 'N': none;
= 'E': for eigenvalues only (S);
= 'V': for invariant subspace only (SEP);
= 'B': for both eigenvalues and invariant subspace (S and
SEP).
COMPQ (input) CHARACTER*1
= 'V': update the matrix Q of Schur vectors;
= 'N': do not update Q.
SELECT (input) LOGICAL array, dimension (N)
SELECT specifies the eigenvalues in the selected cluster. To
select a real eigenvalue w(j), SELECT(j) must be set to
.TRUE.. To select a complex conjugate pair of eigenvalues
w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,
either SELECT(j) or SELECT(j+1) or both must be set to
.TRUE.; a complex conjugate pair of eigenvalues must be
either both included in the cluster or both excluded.
N (input) INTEGER
The order of the matrix T. N >= 0.
T (input/output) DOUBLE PRECISION array, dimension (LDT,N)
On entry, the upper quasi-triangular matrix T, in Schur
canonical form.
On exit, T is overwritten by the reordered matrix T, again in
Schur canonical form, with the selected eigenvalues in the
leading diagonal blocks.
LDT (input) INTEGER
The leading dimension of the array T. LDT >= max(1,N).
Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
On exit, if COMPQ = 'V', Q has been postmultiplied by the
orthogonal transformation matrix which reorders T; the
leading M columns of Q form an orthonormal basis for the
specified invariant subspace.
If COMPQ = 'N', Q is not referenced.
LDQ (input) INTEGER
The leading dimension of the array Q.
LDQ >= 1; and if COMPQ = 'V', LDQ >= N.
WR (output) DOUBLE PRECISION array, dimension (N)
WI (output) DOUBLE PRECISION array, dimension (N)
The real and imaginary parts, respectively, of the reordered
eigenvalues of T. The eigenvalues are stored in the same
order as on the diagonal of T, with WR(i) = T(i,i) and, if
T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and
WI(i+1) = -WI(i). Note that if a complex eigenvalue is
sufficiently ill-conditioned, then its value may differ
significantly from its value before reordering.
M (output) INTEGER
The dimension of the specified invariant subspace.
0 < = M <= N.
S (output) DOUBLE PRECISION
If JOB = 'E' or 'B', S is a lower bound on the reciprocal
condition number for the selected cluster of eigenvalues.
S cannot underestimate the true reciprocal condition number
by more than a factor of sqrt(N). If M = 0 or N, S = 1.
If JOB = 'N' or 'V', S is not referenced.
SEP (output) DOUBLE PRECISION
If JOB = 'V' or 'B', SEP is the estimated reciprocal
condition number of the specified invariant subspace. If
M = 0 or N, SEP = norm(T).
If JOB = 'N' or 'E', SEP is not referenced.
WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK.
If JOB = 'N', LWORK >= max(1,N);
if JOB = 'E', LWORK >= max(1,M*(N-M));
if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
IWORK (workspace) 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 JOB = 'N' or 'E', LIWORK >= 1;
if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)).
If LIWORK = -1, then a workspace query is assumed; the
routine only calculates the optimal size of the IWORK array,
returns this value as the first entry of the IWORK array, and
no error message related to LIWORK is issued by XERBLA.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
= 1: reordering of T failed because some eigenvalues are too
close to separate (the problem is very ill-conditioned);
T may have been partially reordered, and WR and WI
contain the eigenvalues in the same order as in T; S and
SEP (if requested) are set to zero.
Further Details
===============
DTRSEN first collects the selected eigenvalues by computing an
orthogonal transformation Z to move them to the top left corner of T.
In other words, the selected eigenvalues are the eigenvalues of T11
in:
Z**T * T * Z = ( T11 T12 ) n1
( 0 T22 ) n2
n1 n2
where N = n1+n2 and Z**T means the transpose of Z. The first n1 columns
of Z span the specified invariant subspace of T.
If T has been obtained from the real Schur factorization of a matrix
A = Q*T*Q**T, then the reordered real Schur factorization of A is given
by A = (Q*Z)*(Z**T*T*Z)*(Q*Z)**T, and the first n1 columns of Q*Z span
the corresponding invariant subspace of A.
The reciprocal condition number of the average of the eigenvalues of
T11 may be returned in S. S lies between 0 (very badly conditioned)
and 1 (very well conditioned). It is computed as follows. First we
compute R so that
P = ( I R ) n1
( 0 0 ) n2
n1 n2
is the projector on the invariant subspace associated with T11.
R is the solution of the Sylvester equation:
T11*R - R*T22 = T12.
Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote
the two-norm of M. Then S is computed as the lower bound
(1 + F-norm(R)**2)**(-1/2)
on the reciprocal of 2-norm(P), the true reciprocal condition number.
S cannot underestimate 1 / 2-norm(P) by more than a factor of
sqrt(N).
An approximate error bound for the computed average of the
eigenvalues of T11 is
EPS * norm(T) / S
where EPS is the machine precision.
The reciprocal condition number of the right invariant subspace
spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.
SEP is defined as the separation of T11 and T22:
sep( T11, T22 ) = sigma-min( C )
where sigma-min(C) is the smallest singular value of the
n1*n2-by-n1*n2 matrix
C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )
I(m) is an m by m identity matrix, and kprod denotes the Kronecker
product. We estimate sigma-min(C) by the reciprocal of an estimate of
the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)
cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).
When SEP is small, small changes in T can cause large changes in
the invariant subspace. An approximate bound on the maximum angular
error in the computed right invariant subspace is
EPS * norm(T) / SEP
=====================================================================
Decode and test the input parameters
Parameter adjustments */
--select;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--wr;
--wi;
--work;
--iwork;
/* Function Body */
wantbh = igraphlsame_(job, "B");
wants = igraphlsame_(job, "E") || wantbh;
wantsp = igraphlsame_(job, "V") || wantbh;
wantq = igraphlsame_(compq, "V");
*info = 0;
lquery = *lwork == -1;
if (! igraphlsame_(job, "N") && ! wants && ! wantsp) {
*info = -1;
} else if (! igraphlsame_(compq, "N") && ! wantq) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*ldt < max(1,*n)) {
*info = -6;
} else if (*ldq < 1 || wantq && *ldq < *n) {
*info = -8;
} else {
/* Set M to the dimension of the specified invariant subspace,
and test LWORK and LIWORK. */
*m = 0;
pair = FALSE_;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (pair) {
pair = FALSE_;
} else {
if (k < *n) {
if (t[k + 1 + k * t_dim1] == 0.) {
if (select[k]) {
++(*m);
}
} else {
pair = TRUE_;
if (select[k] || select[k + 1]) {
*m += 2;
}
}
} else {
if (select[*n]) {
++(*m);
}
}
}
/* L10: */
}
n1 = *m;
n2 = *n - *m;
nn = n1 * n2;
if (wantsp) {
/* Computing MAX */
i__1 = 1, i__2 = nn << 1;
lwmin = max(i__1,i__2);
liwmin = max(1,nn);
} else if (igraphlsame_(job, "N")) {
lwmin = max(1,*n);
liwmin = 1;
} else if (igraphlsame_(job, "E")) {
lwmin = max(1,nn);
liwmin = 1;
}
if (*lwork < lwmin && ! lquery) {
*info = -15;
} else if (*liwork < liwmin && ! lquery) {
*info = -17;
}
}
if (*info == 0) {
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
}
if (*info != 0) {
i__1 = -(*info);
igraphxerbla_("DTRSEN", &i__1, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible. */
if (*m == *n || *m == 0) {
if (wants) {
*s = 1.;
}
if (wantsp) {
*sep = igraphdlange_("1", n, n, &t[t_offset], ldt, &work[1]);
}
goto L40;
}
/* Collect the selected blocks at the top-left corner of T. */
ks = 0;
pair = FALSE_;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (pair) {
pair = FALSE_;
} else {
swap = select[k];
if (k < *n) {
if (t[k + 1 + k * t_dim1] != 0.) {
pair = TRUE_;
swap = swap || select[k + 1];
}
}
if (swap) {
++ks;
/* Swap the K-th block to position KS. */
ierr = 0;
kk = k;
if (k != ks) {
igraphdtrexc_(compq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
kk, &ks, &work[1], &ierr);
}
if (ierr == 1 || ierr == 2) {
/* Blocks too close to swap: exit. */
*info = 1;
if (wants) {
*s = 0.;
}
if (wantsp) {
*sep = 0.;
}
goto L40;
}
if (pair) {
++ks;
}
}
}
/* L20: */
}
if (wants) {
/* Solve Sylvester equation for R:
T11*R - R*T22 = scale*T12 */
igraphdlacpy_("F", &n1, &n2, &t[(n1 + 1) * t_dim1 + 1], ldt, &work[1], &n1);
igraphdtrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + 1 + (n1
+ 1) * t_dim1], ldt, &work[1], &n1, &scale, &ierr);
/* Estimate the reciprocal of the condition number of the cluster
of eigenvalues. */
rnorm = igraphdlange_("F", &n1, &n2, &work[1], &n1, &work[1]);
if (rnorm == 0.) {
*s = 1.;
} else {
*s = scale / (sqrt(scale * scale / rnorm + rnorm) * sqrt(rnorm));
}
}
if (wantsp) {
/* Estimate sep(T11,T22). */
est = 0.;
kase = 0;
L30:
igraphdlacn2_(&nn, &work[nn + 1], &work[1], &iwork[1], &est, &kase, isave);
if (kase != 0) {
if (kase == 1) {
/* Solve T11*R - R*T22 = scale*X. */
igraphdtrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 +
1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, &
ierr);
} else {
/* Solve T11**T*R - R*T22**T = scale*X. */
igraphdtrsyl_("T", "T", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 +
1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, &
ierr);
}
goto L30;
}
*sep = scale / est;
}
L40:
/* Store the output eigenvalues in WR and WI. */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
wr[k] = t[k + k * t_dim1];
wi[k] = 0.;
/* L50: */
}
i__1 = *n - 1;
for (k = 1; k <= i__1; ++k) {
if (t[k + 1 + k * t_dim1] != 0.) {
wi[k] = sqrt((d__1 = t[k + (k + 1) * t_dim1], abs(d__1))) * sqrt((
d__2 = t[k + 1 + k * t_dim1], abs(d__2)));
wi[k + 1] = -wi[k];
}
/* L60: */
}
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
return 0;
/* End of DTRSEN */
} /* igraphdtrsen_ */
/* Subroutine */ int igraphdgebak_(char *job, char *side, integer *n, integer *ilo,
integer *ihi, doublereal *scale, integer *m, doublereal *v, integer *
ldv, integer *info)
{
/* System generated locals */
integer v_dim1, v_offset, i__1;
/* Local variables */
integer i__, k;
doublereal s;
integer ii;
extern /* Subroutine */ int igraphdscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical igraphlsame_(char *, char *);
extern /* Subroutine */ int igraphdswap_(integer *, doublereal *, integer *,
doublereal *, integer *);
logical leftv;
extern /* Subroutine */ int igraphxerbla_(char *, integer *, ftnlen);
logical rightv;
/* -- LAPACK routine (version 3.2) --
-- LAPACK is a software package provided by Univ. of Tennessee, --
-- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
November 2006
Purpose
=======
DGEBAK forms the right or left eigenvectors of a real general matrix
by backward transformation on the computed eigenvectors of the
balanced matrix output by DGEBAL.
Arguments
=========
JOB (input) CHARACTER*1
Specifies the type of backward transformation required:
= 'N', do nothing, return immediately;
= 'P', do backward transformation for permutation only;
= 'S', do backward transformation for scaling only;
= 'B', do backward transformations for both permutation and
scaling.
JOB must be the same as the argument JOB supplied to DGEBAL.
SIDE (input) CHARACTER*1
= 'R': V contains right eigenvectors;
= 'L': V contains left eigenvectors.
N (input) INTEGER
The number of rows of the matrix V. N >= 0.
ILO (input) INTEGER
IHI (input) INTEGER
The integers ILO and IHI determined by DGEBAL.
1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
SCALE (input) DOUBLE PRECISION array, dimension (N)
Details of the permutation and scaling factors, as returned
by DGEBAL.
M (input) INTEGER
The number of columns of the matrix V. M >= 0.
V (input/output) DOUBLE PRECISION array, dimension (LDV,M)
On entry, the matrix of right or left eigenvectors to be
transformed, as returned by DHSEIN or DTREVC.
On exit, V is overwritten by the transformed eigenvectors.
LDV (input) INTEGER
The leading dimension of the array V. LDV >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
=====================================================================
Decode and Test the input parameters
Parameter adjustments */
--scale;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
/* Function Body */
rightv = igraphlsame_(side, "R");
leftv = igraphlsame_(side, "L");
*info = 0;
if (! igraphlsame_(job, "N") && ! igraphlsame_(job, "P") && ! igraphlsame_(job, "S")
&& ! igraphlsame_(job, "B")) {
*info = -1;
} else if (! rightv && ! leftv) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ilo < 1 || *ilo > max(1,*n)) {
*info = -4;
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
*info = -5;
} else if (*m < 0) {
*info = -7;
} else if (*ldv < max(1,*n)) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
igraphxerbla_("DGEBAK", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*m == 0) {
return 0;
}
if (igraphlsame_(job, "N")) {
return 0;
}
if (*ilo == *ihi) {
goto L30;
}
/* Backward balance */
if (igraphlsame_(job, "S") || igraphlsame_(job, "B")) {
if (rightv) {
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
s = scale[i__];
igraphdscal_(m, &s, &v[i__ + v_dim1], ldv);
/* L10: */
}
}
if (leftv) {
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
s = 1. / scale[i__];
igraphdscal_(m, &s, &v[i__ + v_dim1], ldv);
/* L20: */
}
}
}
/* Backward permutation
For I = ILO-1 step -1 until 1,
IHI+1 step 1 until N do -- */
L30:
if (igraphlsame_(job, "P") || igraphlsame_(job, "B")) {
if (rightv) {
i__1 = *n;
for (ii = 1; ii <= i__1; ++ii) {
i__ = ii;
if (i__ >= *ilo && i__ <= *ihi) {
goto L40;
}
if (i__ < *ilo) {
i__ = *ilo - ii;
}
k = (integer) scale[i__];
if (k == i__) {
goto L40;
}
igraphdswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
L40:
;
}
}
if (leftv) {
i__1 = *n;
for (ii = 1; ii <= i__1; ++ii) {
i__ = ii;
if (i__ >= *ilo && i__ <= *ihi) {
goto L50;
}
if (i__ < *ilo) {
i__ = *ilo - ii;
}
k = (integer) scale[i__];
if (k == i__) {
goto L50;
}
igraphdswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
L50:
;
}
}
}
return 0;
/* End of DGEBAK */
} /* igraphdgebak_ */
/* Subroutine */ int igraphdsyrk_(char *uplo, char *trans, integer *n, integer *k,
doublereal *alpha, doublereal *a, integer *lda, doublereal *beta,
doublereal *c__, integer *ldc)
{
/* System generated locals */
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3;
/* Local variables */
integer i__, j, l, info;
doublereal temp;
extern logical igraphlsame_(char *, char *);
integer nrowa;
logical upper;
extern /* Subroutine */ int igraphxerbla_(char *, integer *, ftnlen);
/* Purpose
=======
DSYRK performs one of the symmetric rank k operations
C := alpha*A*A**T + beta*C,
or
C := alpha*A**T*A + beta*C,
where alpha and beta are scalars, C is an n by n symmetric matrix
and A is an n by k matrix in the first case and a k by n matrix
in the second case.
Arguments
==========
UPLO - CHARACTER*1.
On entry, UPLO specifies whether the upper or lower
triangular part of the array C is to be referenced as
follows:
UPLO = 'U' or 'u' Only the upper triangular part of C
is to be referenced.
UPLO = 'L' or 'l' Only the lower triangular part of C
is to be referenced.
Unchanged on exit.
TRANS - CHARACTER*1.
On entry, TRANS specifies the operation to be performed as
follows:
TRANS = 'N' or 'n' C := alpha*A*A**T + beta*C.
TRANS = 'T' or 't' C := alpha*A**T*A + beta*C.
TRANS = 'C' or 'c' C := alpha*A**T*A + beta*C.
Unchanged on exit.
N - INTEGER.
On entry, N specifies the order of the matrix C. N must be
at least zero.
Unchanged on exit.
K - INTEGER.
On entry with TRANS = 'N' or 'n', K specifies the number
of columns of the matrix A, and on entry with
TRANS = 'T' or 't' or 'C' or 'c', K specifies the number
of rows of the matrix A. K 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, ka ), where ka is
k when TRANS = 'N' or 'n', and is n otherwise.
Before entry with TRANS = 'N' or 'n', the leading n by k
part of the array A must contain the matrix A, otherwise
the leading k by n 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 TRANS = 'N' or 'n'
then LDA must be at least max( 1, n ), otherwise LDA must
be at least max( 1, k ).
Unchanged on exit.
BETA - DOUBLE PRECISION.
On entry, BETA specifies the scalar beta.
Unchanged on exit.
C - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
Before entry with UPLO = 'U' or 'u', the leading n by n
upper triangular part of the array C must contain the upper
triangular part of the symmetric matrix and the strictly
lower triangular part of C is not referenced. On exit, the
upper triangular part of the array C is overwritten by the
upper triangular part of the updated matrix.
Before entry with UPLO = 'L' or 'l', the leading n by n
lower triangular part of the array C must contain the lower
triangular part of the symmetric matrix and the strictly
upper triangular part of C is not referenced. On exit, the
lower triangular part of the array C is overwritten by the
lower triangular part of the 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, n ).
Unchanged on exit.
Further Details
===============
Level 3 Blas routine.
-- Written on 8-February-1989.
Jack Dongarra, Argonne National Laboratory.
Iain Duff, AERE Harwell.
Jeremy Du Croz, Numerical Algorithms Group Ltd.
Sven Hammarling, Numerical Algorithms Group Ltd.
=====================================================================
Test the input parameters.
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
/* Function Body */
if (igraphlsame_(trans, "N")) {
nrowa = *n;
} else {
nrowa = *k;
}
upper = igraphlsame_(uplo, "U");
info = 0;
if (! upper && ! igraphlsame_(uplo, "L")) {
info = 1;
} else if (! igraphlsame_(trans, "N") && ! igraphlsame_(trans,
"T") && ! igraphlsame_(trans, "C")) {
info = 2;
} else if (*n < 0) {
info = 3;
} else if (*k < 0) {
info = 4;
} else if (*lda < max(1,nrowa)) {
info = 7;
} else if (*ldc < max(1,*n)) {
info = 10;
}
if (info != 0) {
igraphxerbla_("DSYRK ", &info, (ftnlen)6);
return 0;
}
/* Quick return if possible. */
if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) {
return 0;
}
/* And when alpha.eq.zero. */
if (*alpha == 0.) {
if (upper) {
if (*beta == 0.) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
c__[i__ + j * c_dim1] = 0.;
/* L10: */
}
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
/* L30: */
}
/* L40: */
}
}
} else {
if (*beta == 0.) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
c__[i__ + j * c_dim1] = 0.;
/* L50: */
}
/* L60: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
/* L70: */
}
/* L80: */
}
}
}
return 0;
}
/* Start the operations. */
if (igraphlsame_(trans, "N")) {
/* Form C := alpha*A*A**T + beta*C. */
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (*beta == 0.) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
c__[i__ + j * c_dim1] = 0.;
/* L90: */
}
} else if (*beta != 1.) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
/* L100: */
}
}
i__2 = *k;
for (l = 1; l <= i__2; ++l) {
if (a[j + l * a_dim1] != 0.) {
temp = *alpha * a[j + l * a_dim1];
i__3 = j;
for (i__ = 1; i__ <= i__3; ++i__) {
c__[i__ + j * c_dim1] += temp * a[i__ + l *
a_dim1];
/* L110: */
}
}
/* L120: */
}
/* L130: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (*beta == 0.) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
c__[i__ + j * c_dim1] = 0.;
/* L140: */
}
} else if (*beta != 1.) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
/* L150: */
}
}
i__2 = *k;
for (l = 1; l <= i__2; ++l) {
if (a[j + l * a_dim1] != 0.) {
temp = *alpha * a[j + l * a_dim1];
i__3 = *n;
for (i__ = j; i__ <= i__3; ++i__) {
c__[i__ + j * c_dim1] += temp * a[i__ + l *
a_dim1];
/* L160: */
}
}
/* L170: */
}
/* L180: */
}
}
} else {
/* Form C := alpha*A**T*A + beta*C. */
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = 0.;
i__3 = *k;
for (l = 1; l <= i__3; ++l) {
temp += a[l + i__ * a_dim1] * a[l + j * a_dim1];
/* L190: */
}
if (*beta == 0.) {
c__[i__ + j * c_dim1] = *alpha * temp;
} else {
c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
i__ + j * c_dim1];
}
/* L200: */
}
/* L210: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
temp = 0.;
i__3 = *k;
for (l = 1; l <= i__3; ++l) {
temp += a[l + i__ * a_dim1] * a[l + j * a_dim1];
/* L220: */
}
if (*beta == 0.) {
c__[i__ + j * c_dim1] = *alpha * temp;
} else {
c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
i__ + j * c_dim1];
}
/* L230: */
}
/* L240: */
}
}
}
return 0;
/* End of DSYRK . */
} /* igraphdsyrk_ */
/* Subroutine */ int igraphdormtr_(char *side, char *uplo, char *trans, integer *m,
integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *
c__, integer *ldc, doublereal *work, integer *lwork, integer *info)
{
/* System generated locals */
address a__1[2];
integer a_dim1, a_offset, c_dim1, c_offset, i__1[2], i__2, i__3;
char ch__1[2];
/* Builtin functions
Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
integer i1, i2, nb, mi, ni, nq, nw;
logical left;
extern logical igraphlsame_(char *, char *);
integer iinfo;
logical upper;
extern /* Subroutine */ int igraphxerbla_(char *, integer *, ftnlen);
extern integer igraphilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int igraphdormql_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *),
igraphdormqr_(char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *);
integer lwkopt;
logical lquery;
/* -- LAPACK routine (version 3.2) --
-- LAPACK is a software package provided by Univ. of Tennessee, --
-- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
November 2006
Purpose
=======
DORMTR overwrites the general real M-by-N matrix C with
SIDE = 'L' SIDE = 'R'
TRANS = 'N': Q * C C * Q
TRANS = 'T': Q**T * C C * Q**T
where Q is a real orthogonal matrix of order nq, with nq = m if
SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
nq-1 elementary reflectors, as returned by DSYTRD:
if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
Arguments
=========
SIDE (input) CHARACTER*1
= 'L': apply Q or Q**T from the Left;
= 'R': apply Q or Q**T from the Right.
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A contains elementary reflectors
from DSYTRD;
= 'L': Lower triangle of A contains elementary reflectors
from DSYTRD.
TRANS (input) CHARACTER*1
= 'N': No transpose, apply Q;
= 'T': Transpose, apply Q**T.
M (input) INTEGER
The number of rows of the matrix C. M >= 0.
N (input) INTEGER
The number of columns of the matrix C. N >= 0.
A (input) DOUBLE PRECISION array, dimension
(LDA,M) if SIDE = 'L'
(LDA,N) if SIDE = 'R'
The vectors which define the elementary reflectors, as
returned by DSYTRD.
LDA (input) INTEGER
The leading dimension of the array A.
LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
TAU (input) DOUBLE PRECISION array, dimension
(M-1) if SIDE = 'L'
(N-1) if SIDE = 'R'
TAU(i) must contain the scalar factor of the elementary
reflector H(i), as returned by DSYTRD.
C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
On entry, the M-by-N matrix C.
On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
LDC (input) INTEGER
The leading dimension of the array C. LDC >= max(1,M).
WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK.
If SIDE = 'L', LWORK >= max(1,N);
if SIDE = 'R', LWORK >= max(1,M).
For optimum performance LWORK >= N*NB if SIDE = 'L', and
LWORK >= M*NB if SIDE = 'R', 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 had an illegal value
=====================================================================
Test the input arguments
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = igraphlsame_(side, "L");
upper = igraphlsame_(uplo, "U");
lquery = *lwork == -1;
/* NQ is the order of Q and NW is the minimum dimension of WORK */
if (left) {
nq = *m;
nw = *n;
} else {
nq = *n;
nw = *m;
}
if (! left && ! igraphlsame_(side, "R")) {
*info = -1;
} else if (! upper && ! igraphlsame_(uplo, "L")) {
*info = -2;
} else if (! igraphlsame_(trans, "N") && ! igraphlsame_(trans,
"T")) {
*info = -3;
} else if (*m < 0) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,nq)) {
*info = -7;
} else if (*ldc < max(1,*m)) {
*info = -10;
} else if (*lwork < max(1,nw) && ! lquery) {
*info = -12;
}
if (*info == 0) {
if (upper) {
if (left) {
/* Writing concatenation */
i__1[0] = 1, a__1[0] = side;
i__1[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
i__2 = *m - 1;
i__3 = *m - 1;
nb = igraphilaenv_(&c__1, "DORMQL", ch__1, &i__2, n, &i__3, &c_n1, (
ftnlen)6, (ftnlen)2);
} else {
/* Writing concatenation */
i__1[0] = 1, a__1[0] = side;
i__1[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
i__2 = *n - 1;
i__3 = *n - 1;
nb = igraphilaenv_(&c__1, "DORMQL", ch__1, m, &i__2, &i__3, &c_n1, (
ftnlen)6, (ftnlen)2);
}
} else {
if (left) {
/* Writing concatenation */
i__1[0] = 1, a__1[0] = side;
i__1[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
i__2 = *m - 1;
i__3 = *m - 1;
nb = igraphilaenv_(&c__1, "DORMQR", ch__1, &i__2, n, &i__3, &c_n1, (
ftnlen)6, (ftnlen)2);
} else {
/* Writing concatenation */
i__1[0] = 1, a__1[0] = side;
i__1[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
i__2 = *n - 1;
i__3 = *n - 1;
nb = igraphilaenv_(&c__1, "DORMQR", ch__1, m, &i__2, &i__3, &c_n1, (
ftnlen)6, (ftnlen)2);
}
}
lwkopt = max(1,nw) * nb;
work[1] = (doublereal) lwkopt;
}
if (*info != 0) {
i__2 = -(*info);
igraphxerbla_("DORMTR", &i__2, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0 || nq == 1) {
work[1] = 1.;
return 0;
}
if (left) {
mi = *m - 1;
ni = *n;
} else {
mi = *m;
ni = *n - 1;
}
if (upper) {
/* Q was determined by a call to DSYTRD with UPLO = 'U' */
i__2 = nq - 1;
igraphdormql_(side, trans, &mi, &ni, &i__2, &a[(a_dim1 << 1) + 1], lda, &
tau[1], &c__[c_offset], ldc, &work[1], lwork, &iinfo);
} else {
/* Q was determined by a call to DSYTRD with UPLO = 'L' */
if (left) {
i1 = 2;
i2 = 1;
} else {
i1 = 1;
i2 = 2;
}
i__2 = nq - 1;
igraphdormqr_(side, trans, &mi, &ni, &i__2, &a[a_dim1 + 2], lda, &tau[1], &
c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo);
}
work[1] = (doublereal) lwkopt;
return 0;
/* End of DORMTR */
} /* igraphdormtr_ */
Subroutine */ int igraphdsteqr_(char *compz, integer *n, doublereal *d__,
doublereal *e, doublereal *z__, integer *ldz, doublereal *work,
integer *info)
{
/* 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 */
doublereal b, c__, f, g;
integer i__, j, k, l, m;
doublereal p, r__, s;
integer l1, ii, mm, lm1, mm1, nm1;
doublereal rt1, rt2, eps;
integer lsv;
doublereal tst, eps2;
integer lend, jtot;
extern /* Subroutine */ int igraphdlae2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *);
extern logical igraphlsame_(char *, char *);
extern /* Subroutine */ int igraphdlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *);
doublereal anorm;
extern /* Subroutine */ int igraphdswap_(integer *, doublereal *, integer *,
doublereal *, integer *), igraphdlaev2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
integer lendm1, lendp1;
extern doublereal igraphdlapy2_(doublereal *, doublereal *), igraphdlamch_(char *);
integer iscale;
extern /* Subroutine */ int igraphdlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), igraphdlaset_(char *, integer *, integer
*, doublereal *, doublereal *, doublereal *, integer *);
doublereal safmin;
extern /* Subroutine */ int igraphdlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
doublereal safmax;
extern /* Subroutine */ int igraphxerbla_(char *, integer *, ftnlen);
extern doublereal igraphdlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int igraphdlasrt_(char *, integer *, doublereal *,
integer *);
integer lendsv;
doublereal ssfmin;
integer nmaxit, icompz;
doublereal ssfmax;
/* -- LAPACK computational routine (version 3.4.0) --
-- LAPACK is a software package provided by Univ. of Tennessee, --
-- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
November 2011
=====================================================================
Test the input parameters.
Parameter adjustments */
--d__;
--e;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
/* Function Body */
*info = 0;
if (igraphlsame_(compz, "N")) {
icompz = 0;
} else if (igraphlsame_(compz, "V")) {
icompz = 1;
} else if (igraphlsame_(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);
igraphxerbla_("DSTEQR", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz == 2) {
z__[z_dim1 + 1] = 1.;
}
return 0;
}
/* Determine the unit roundoff and over/underflow thresholds. */
eps = igraphdlamch_("E");
/* Computing 2nd power */
d__1 = eps;
eps2 = d__1 * d__1;
safmin = igraphdlamch_("S");
safmax = 1. / safmin;
ssfmax = sqrt(safmax) / 3.;
ssfmin = sqrt(safmin) / eps2;
/* Compute the eigenvalues and eigenvectors of the tridiagonal
matrix. */
if (icompz == 2) {
igraphdlaset_("Full", n, n, &c_b9, &c_b10, &z__[z_offset], 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 <= i__1; ++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 = igraphdlanst_("M", &i__1, &d__[l], &e[l]);
iscale = 0;
if (anorm == 0.) {
goto L10;
}
if (anorm > ssfmax) {
iscale = 1;
i__1 = lend - l + 1;
igraphdlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
igraphdlascl_("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;
igraphdlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
igraphdlascl_("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 <= i__1; ++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) {
igraphdlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s);
work[l] = c__;
work[*n - 1 + l] = s;
igraphdlasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], &
z__[l * z_dim1 + 1], ldz);
} else {
igraphdlae2_(&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__ = igraphdlapy2_(&g, &c_b10);
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__ >= i__1; --i__) {
f = s * e[i__];
b = c__ * e[i__];
igraphdlartg_(&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;
igraphdlasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l
* z_dim1 + 1], 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 >= i__1; --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) {
igraphdlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s)
;
work[m] = c__;
work[*n - 1 + m] = s;
igraphdlasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], &
z__[(l - 1) * z_dim1 + 1], ldz);
} else {
igraphdlae2_(&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__ = igraphdlapy2_(&g, &c_b10);
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__ <= i__1; ++i__) {
f = s * e[i__];
b = c__ * e[i__];
igraphdlartg_(&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;
igraphdlasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m
* z_dim1 + 1], 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;
igraphdlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
i__1 = lendsv - lsv;
igraphdlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n,
info);
} else if (iscale == 2) {
i__1 = lendsv - lsv + 1;
igraphdlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
i__1 = lendsv - lsv;
igraphdlascl_("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) {
goto L10;
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (e[i__] != 0.) {
++(*info);
}
/* L150: */
}
goto L190;
/* Order eigenvalues and eigenvectors. */
L160:
if (icompz == 0) {
/* Use Quick Sort */
igraphdlasrt_("I", n, &d__[1], info);
} else {
/* Use Selection Sort to minimize swaps of eigenvectors */
i__1 = *n;
for (ii = 2; ii <= i__1; ++ii) {
i__ = ii - 1;
k = i__;
p = d__[i__];
i__2 = *n;
for (j = ii; j <= i__2; ++j) {
if (d__[j] < p) {
k = j;
p = d__[j];
}
/* L170: */
}
if (k != i__) {
d__[k] = d__[i__];
d__[i__] = p;
igraphdswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1],
&c__1);
}
/* L180: */
}
}
L190:
return 0;
/* End of DSTEQR */
} /* igraphdsteqr_ */
Subroutine */ int igraphdstebz_(char *range, char *order, integer *n, doublereal
*vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol,
doublereal *d__, doublereal *e, integer *m, integer *nsplit,
doublereal *w, integer *iblock, integer *isplit, doublereal *work,
integer *iwork, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1, d__2, d__3, d__4, d__5;
/* Builtin functions */
double sqrt(doublereal), log(doublereal);
/* Local variables */
integer j, ib, jb, ie, je, nb;
doublereal gl;
integer im, in;
doublereal gu;
integer iw;
doublereal wl, wu;
integer nwl;
doublereal ulp, wlu, wul;
integer nwu;
doublereal tmp1, tmp2;
integer iend, ioff, iout, itmp1, jdisc;
extern logical igraphlsame_(char *, char *);
integer iinfo;
doublereal atoli;
integer iwoff;
doublereal bnorm;
integer itmax;
doublereal wkill, rtoli, tnorm;
extern doublereal igraphdlamch_(char *);
integer ibegin;
extern /* Subroutine */ int igraphdlaebz_(integer *, integer *, integer *,
integer *, integer *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
integer irange, idiscl;
doublereal safemn;
integer idumma[1];
extern /* Subroutine */ int igraphxerbla_(char *, integer *, ftnlen);
extern integer igraphilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
integer idiscu, iorder;
logical ncnvrg;
doublereal pivmin;
logical toofew;
/* -- LAPACK computational routine (version 3.4.0) --
-- LAPACK is a software package provided by Univ. of Tennessee, --
-- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
November 2011
=====================================================================
Parameter adjustments */
--iwork;
--work;
--isplit;
--iblock;
--w;
--e;
--d__;
/* Function Body */
*info = 0;
/* Decode RANGE */
if (igraphlsame_(range, "A")) {
irange = 1;
} else if (igraphlsame_(range, "V")) {
irange = 2;
} else if (igraphlsame_(range, "I")) {
irange = 3;
} else {
irange = 0;
}
/* Decode ORDER */
if (igraphlsame_(order, "B")) {
iorder = 2;
} else if (igraphlsame_(order, "E")) {
iorder = 1;
} else {
iorder = 0;
}
/* Check for Errors */
if (irange <= 0) {
*info = -1;
} else if (iorder <= 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (irange == 2) {
if (*vl >= *vu) {
*info = -5;
}
} else if (irange == 3 && (*il < 1 || *il > max(1,*n))) {
*info = -6;
} else if (irange == 3 && (*iu < min(*n,*il) || *iu > *n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
igraphxerbla_("DSTEBZ", &i__1, (ftnlen)6);
return 0;
}
/* Initialize error flags */
*info = 0;
ncnvrg = FALSE_;
toofew = FALSE_;
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
/* Simplifications: */
if (irange == 3 && *il == 1 && *iu == *n) {
irange = 1;
}
/* Get machine constants
NB is the minimum vector length for vector bisection, or 0
if only scalar is to be done. */
safemn = igraphdlamch_("S");
ulp = igraphdlamch_("P");
rtoli = ulp * 2.;
nb = igraphilaenv_(&c__1, "DSTEBZ", " ", n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
if (nb <= 1) {
nb = 0;
}
/* Special Case when N=1 */
if (*n == 1) {
*nsplit = 1;
isplit[1] = 1;
if (irange == 2 && (*vl >= d__[1] || *vu < d__[1])) {
*m = 0;
} else {
w[1] = d__[1];
iblock[1] = 1;
*m = 1;
}
return 0;
}
/* Compute Splitting Points */
*nsplit = 1;
work[*n] = 0.;
pivmin = 1.;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
/* Computing 2nd power */
d__1 = e[j - 1];
tmp1 = d__1 * d__1;
/* Computing 2nd power */
d__2 = ulp;
if ((d__1 = d__[j] * d__[j - 1], abs(d__1)) * (d__2 * d__2) + safemn
> tmp1) {
isplit[*nsplit] = j - 1;
++(*nsplit);
work[j - 1] = 0.;
} else {
work[j - 1] = tmp1;
pivmin = max(pivmin,tmp1);
}
/* L10: */
}
isplit[*nsplit] = *n;
pivmin *= safemn;
/* Compute Interval and ATOLI */
if (irange == 3) {
/* RANGE='I': Compute the interval containing eigenvalues
IL through IU.
Compute Gershgorin interval for entire (split) matrix
and use it as the initial interval */
gu = d__[1];
gl = d__[1];
tmp1 = 0.;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
tmp2 = sqrt(work[j]);
/* Computing MAX */
d__1 = gu, d__2 = d__[j] + tmp1 + tmp2;
gu = max(d__1,d__2);
/* Computing MIN */
d__1 = gl, d__2 = d__[j] - tmp1 - tmp2;
gl = min(d__1,d__2);
tmp1 = tmp2;
/* L20: */
}
/* Computing MAX */
d__1 = gu, d__2 = d__[*n] + tmp1;
gu = max(d__1,d__2);
/* Computing MIN */
d__1 = gl, d__2 = d__[*n] - tmp1;
gl = min(d__1,d__2);
/* Computing MAX */
d__1 = abs(gl), d__2 = abs(gu);
tnorm = max(d__1,d__2);
gl = gl - tnorm * 2.1 * ulp * *n - pivmin * 4.2000000000000002;
gu = gu + tnorm * 2.1 * ulp * *n + pivmin * 2.1;
/* Compute Iteration parameters */
itmax = (integer) ((log(tnorm + pivmin) - log(pivmin)) / log(2.)) + 2;
if (*abstol <= 0.) {
atoli = ulp * tnorm;
} else {
atoli = *abstol;
}
work[*n + 1] = gl;
work[*n + 2] = gl;
work[*n + 3] = gu;
work[*n + 4] = gu;
work[*n + 5] = gl;
work[*n + 6] = gu;
iwork[1] = -1;
iwork[2] = -1;
iwork[3] = *n + 1;
iwork[4] = *n + 1;
iwork[5] = *il - 1;
iwork[6] = *iu;
igraphdlaebz_(&c__3, &itmax, n, &c__2, &c__2, &nb, &atoli, &rtoli, &pivmin,
&d__[1], &e[1], &work[1], &iwork[5], &work[*n + 1], &work[*n
+ 5], &iout, &iwork[1], &w[1], &iblock[1], &iinfo);
if (iwork[6] == *iu) {
wl = work[*n + 1];
wlu = work[*n + 3];
nwl = iwork[1];
wu = work[*n + 4];
wul = work[*n + 2];
nwu = iwork[4];
} else {
wl = work[*n + 2];
wlu = work[*n + 4];
nwl = iwork[2];
wu = work[*n + 3];
wul = work[*n + 1];
nwu = iwork[3];
}
if (nwl < 0 || nwl >= *n || nwu < 1 || nwu > *n) {
*info = 4;
return 0;
}
} else {
/* RANGE='A' or 'V' -- Set ATOLI
Computing MAX */
d__3 = abs(d__[1]) + abs(e[1]), d__4 = (d__1 = d__[*n], abs(d__1)) + (
d__2 = e[*n - 1], abs(d__2));
tnorm = max(d__3,d__4);
i__1 = *n - 1;
for (j = 2; j <= i__1; ++j) {
/* Computing MAX */
d__4 = tnorm, d__5 = (d__1 = d__[j], abs(d__1)) + (d__2 = e[j - 1]
, abs(d__2)) + (d__3 = e[j], abs(d__3));
tnorm = max(d__4,d__5);
/* L30: */
}
if (*abstol <= 0.) {
atoli = ulp * tnorm;
} else {
atoli = *abstol;
}
if (irange == 2) {
wl = *vl;
wu = *vu;
} else {
wl = 0.;
wu = 0.;
}
}
/* Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU.
NWL accumulates the number of eigenvalues .le. WL,
NWU accumulates the number of eigenvalues .le. WU */
*m = 0;
iend = 0;
*info = 0;
nwl = 0;
nwu = 0;
i__1 = *nsplit;
for (jb = 1; jb <= i__1; ++jb) {
ioff = iend;
ibegin = ioff + 1;
iend = isplit[jb];
in = iend - ioff;
if (in == 1) {
/* Special Case -- IN=1 */
if (irange == 1 || wl >= d__[ibegin] - pivmin) {
++nwl;
}
if (irange == 1 || wu >= d__[ibegin] - pivmin) {
++nwu;
}
if (irange == 1 || wl < d__[ibegin] - pivmin && wu >= d__[ibegin]
- pivmin) {
++(*m);
w[*m] = d__[ibegin];
iblock[*m] = jb;
}
} else {
/* General Case -- IN > 1
Compute Gershgorin Interval
and use it as the initial interval */
gu = d__[ibegin];
gl = d__[ibegin];
tmp1 = 0.;
i__2 = iend - 1;
for (j = ibegin; j <= i__2; ++j) {
tmp2 = (d__1 = e[j], abs(d__1));
/* Computing MAX */
d__1 = gu, d__2 = d__[j] + tmp1 + tmp2;
gu = max(d__1,d__2);
/* Computing MIN */
d__1 = gl, d__2 = d__[j] - tmp1 - tmp2;
gl = min(d__1,d__2);
tmp1 = tmp2;
/* L40: */
}
/* Computing MAX */
d__1 = gu, d__2 = d__[iend] + tmp1;
gu = max(d__1,d__2);
/* Computing MIN */
d__1 = gl, d__2 = d__[iend] - tmp1;
gl = min(d__1,d__2);
/* Computing MAX */
d__1 = abs(gl), d__2 = abs(gu);
bnorm = max(d__1,d__2);
gl = gl - bnorm * 2.1 * ulp * in - pivmin * 2.1;
gu = gu + bnorm * 2.1 * ulp * in + pivmin * 2.1;
/* Compute ATOLI for the current submatrix */
if (*abstol <= 0.) {
/* Computing MAX */
d__1 = abs(gl), d__2 = abs(gu);
atoli = ulp * max(d__1,d__2);
} else {
atoli = *abstol;
}
if (irange > 1) {
if (gu < wl) {
nwl += in;
nwu += in;
goto L70;
}
gl = max(gl,wl);
gu = min(gu,wu);
if (gl >= gu) {
goto L70;
}
}
/* Set Up Initial Interval */
work[*n + 1] = gl;
work[*n + in + 1] = gu;
igraphdlaebz_(&c__1, &c__0, &in, &in, &c__1, &nb, &atoli, &rtoli, &
pivmin, &d__[ibegin], &e[ibegin], &work[ibegin], idumma, &
work[*n + 1], &work[*n + (in << 1) + 1], &im, &iwork[1], &
w[*m + 1], &iblock[*m + 1], &iinfo);
nwl += iwork[1];
nwu += iwork[in + 1];
iwoff = *m - iwork[1];
/* Compute Eigenvalues */
itmax = (integer) ((log(gu - gl + pivmin) - log(pivmin)) / log(2.)
) + 2;
igraphdlaebz_(&c__2, &itmax, &in, &in, &c__1, &nb, &atoli, &rtoli, &
pivmin, &d__[ibegin], &e[ibegin], &work[ibegin], idumma, &
work[*n + 1], &work[*n + (in << 1) + 1], &iout, &iwork[1],
&w[*m + 1], &iblock[*m + 1], &iinfo);
/* Copy Eigenvalues Into W and IBLOCK
Use -JB for block number for unconverged eigenvalues. */
i__2 = iout;
for (j = 1; j <= i__2; ++j) {
tmp1 = (work[j + *n] + work[j + in + *n]) * .5;
/* Flag non-convergence. */
if (j > iout - iinfo) {
ncnvrg = TRUE_;
ib = -jb;
} else {
ib = jb;
}
i__3 = iwork[j + in] + iwoff;
for (je = iwork[j] + 1 + iwoff; je <= i__3; ++je) {
w[je] = tmp1;
iblock[je] = ib;
/* L50: */
}
/* L60: */
}
*m += im;
}
L70:
;
}
/* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
If NWL+1 < IL or NWU > IU, discard extra eigenvalues. */
if (irange == 3) {
im = 0;
idiscl = *il - 1 - nwl;
idiscu = nwu - *iu;
if (idiscl > 0 || idiscu > 0) {
i__1 = *m;
for (je = 1; je <= i__1; ++je) {
if (w[je] <= wlu && idiscl > 0) {
--idiscl;
} else if (w[je] >= wul && idiscu > 0) {
--idiscu;
} else {
++im;
w[im] = w[je];
iblock[im] = iblock[je];
}
/* L80: */
}
*m = im;
}
if (idiscl > 0 || idiscu > 0) {
/* Code to deal with effects of bad arithmetic:
Some low eigenvalues to be discarded are not in (WL,WLU],
or high eigenvalues to be discarded are not in (WUL,WU]
so just kill off the smallest IDISCL/largest IDISCU
eigenvalues, by simply finding the smallest/largest
eigenvalue(s).
(If N(w) is monotone non-decreasing, this should never
happen.) */
if (idiscl > 0) {
wkill = wu;
i__1 = idiscl;
for (jdisc = 1; jdisc <= i__1; ++jdisc) {
iw = 0;
i__2 = *m;
for (je = 1; je <= i__2; ++je) {
if (iblock[je] != 0 && (w[je] < wkill || iw == 0)) {
iw = je;
wkill = w[je];
}
/* L90: */
}
iblock[iw] = 0;
/* L100: */
}
}
if (idiscu > 0) {
wkill = wl;
i__1 = idiscu;
for (jdisc = 1; jdisc <= i__1; ++jdisc) {
iw = 0;
i__2 = *m;
for (je = 1; je <= i__2; ++je) {
if (iblock[je] != 0 && (w[je] > wkill || iw == 0)) {
iw = je;
wkill = w[je];
}
/* L110: */
}
iblock[iw] = 0;
/* L120: */
}
}
im = 0;
i__1 = *m;
for (je = 1; je <= i__1; ++je) {
if (iblock[je] != 0) {
++im;
w[im] = w[je];
iblock[im] = iblock[je];
}
/* L130: */
}
*m = im;
}
if (idiscl < 0 || idiscu < 0) {
toofew = TRUE_;
}
}
/* If ORDER='B', do nothing -- the eigenvalues are already sorted
by block.
If ORDER='E', sort the eigenvalues from smallest to largest */
if (iorder == 1 && *nsplit > 1) {
i__1 = *m - 1;
for (je = 1; je <= i__1; ++je) {
ie = 0;
tmp1 = w[je];
i__2 = *m;
for (j = je + 1; j <= i__2; ++j) {
if (w[j] < tmp1) {
ie = j;
tmp1 = w[j];
}
/* L140: */
}
if (ie != 0) {
itmp1 = iblock[ie];
w[ie] = w[je];
iblock[ie] = iblock[je];
w[je] = tmp1;
iblock[je] = itmp1;
}
/* L150: */
}
}
*info = 0;
if (ncnvrg) {
++(*info);
}
if (toofew) {
*info += 2;
}
return 0;
/* End of DSTEBZ */
} /* igraphdstebz_ */
Subroutine */ int igraphdsyevr_(char *jobz, char *range, char *uplo, integer *n,
doublereal *a, integer *lda, doublereal *vl, doublereal *vu, integer *
il, integer *iu, doublereal *abstol, integer *m, doublereal *w,
doublereal *z__, integer *ldz, integer *isuppz, doublereal *work,
integer *lwork, integer *iwork, integer *liwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, nb, jj;
doublereal eps, vll, vuu, tmp1;
integer indd, inde;
doublereal anrm;
integer imax;
doublereal rmin, rmax;
integer inddd, indee;
extern /* Subroutine */ int igraphdscal_(integer *, doublereal *, doublereal *,
integer *);
doublereal sigma;
extern logical igraphlsame_(char *, char *);
integer iinfo;
char order[1];
integer indwk;
extern /* Subroutine */ int igraphdcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), igraphdswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
integer lwmin;
logical lower, wantz;
extern doublereal igraphdlamch_(char *);
logical alleig, indeig;
integer iscale, ieeeok, indibl, indifl;
logical valeig;
doublereal safmin;
extern integer igraphilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int igraphxerbla_(char *, integer *, ftnlen);
doublereal abstll, bignum;
integer indtau, indisp;
extern /* Subroutine */ int igraphdstein_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, integer *),
igraphdsterf_(integer *, doublereal *, doublereal *, integer *);
integer indiwo, indwkn;
extern doublereal igraphdlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int igraphdstebz_(char *, char *, integer *, doublereal
*, doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *),
igraphdstemr_(char *, char *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, integer *,
logical *, doublereal *, integer *, integer *, integer *, integer
*);
integer liwmin;
logical tryrac;
extern /* Subroutine */ int igraphdormtr_(char *, char *, char *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *);
integer llwrkn, llwork, nsplit;
doublereal smlnum;
extern /* Subroutine */ int igraphdsytrd_(char *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
integer *, integer *);
integer lwkopt;
logical lquery;
/* -- LAPACK driver routine (version 3.4.2) --
-- LAPACK is a software package provided by Univ. of Tennessee, --
-- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
September 2012
=====================================================================
Test the input parameters.
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--isuppz;
--work;
--iwork;
/* Function Body */
ieeeok = igraphilaenv_(&c__10, "DSYEVR", "N", &c__1, &c__2, &c__3, &c__4, (
ftnlen)6, (ftnlen)1);
lower = igraphlsame_(uplo, "L");
wantz = igraphlsame_(jobz, "V");
alleig = igraphlsame_(range, "A");
valeig = igraphlsame_(range, "V");
indeig = igraphlsame_(range, "I");
lquery = *lwork == -1 || *liwork == -1;
/* Computing MAX */
i__1 = 1, i__2 = *n * 26;
lwmin = max(i__1,i__2);
/* Computing MAX */
i__1 = 1, i__2 = *n * 10;
liwmin = max(i__1,i__2);
*info = 0;
if (! (wantz || igraphlsame_(jobz, "N"))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (! (lower || igraphlsame_(uplo, "U"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else {
if (valeig) {
if (*n > 0 && *vu <= *vl) {
*info = -8;
}
} else if (indeig) {
if (*il < 1 || *il > max(1,*n)) {
*info = -9;
} else if (*iu < min(*n,*il) || *iu > *n) {
*info = -10;
}
}
}
if (*info == 0) {
if (*ldz < 1 || wantz && *ldz < *n) {
*info = -15;
} else if (*lwork < lwmin && ! lquery) {
*info = -18;
} else if (*liwork < liwmin && ! lquery) {
*info = -20;
}
}
if (*info == 0) {
nb = igraphilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6,
(ftnlen)1);
/* Computing MAX */
i__1 = nb, i__2 = igraphilaenv_(&c__1, "DORMTR", uplo, n, &c_n1, &c_n1, &
c_n1, (ftnlen)6, (ftnlen)1);
nb = max(i__1,i__2);
/* Computing MAX */
i__1 = (nb + 1) * *n;
lwkopt = max(i__1,lwmin);
work[1] = (doublereal) lwkopt;
iwork[1] = liwmin;
}
if (*info != 0) {
i__1 = -(*info);
igraphxerbla_("DSYEVR", &i__1, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
work[1] = 1.;
return 0;
}
if (*n == 1) {
work[1] = 7.;
if (alleig || indeig) {
*m = 1;
w[1] = a[a_dim1 + 1];
} else {
if (*vl < a[a_dim1 + 1] && *vu >= a[a_dim1 + 1]) {
*m = 1;
w[1] = a[a_dim1 + 1];
}
}
if (wantz) {
z__[z_dim1 + 1] = 1.;
isuppz[1] = 1;
isuppz[2] = 1;
}
return 0;
}
/* Get machine constants. */
safmin = igraphdlamch_("Safe minimum");
eps = igraphdlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
rmax = min(d__1,d__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
abstll = *abstol;
if (valeig) {
vll = *vl;
vuu = *vu;
}
anrm = igraphdlansy_("M", uplo, n, &a[a_offset], lda, &work[1]);
if (anrm > 0. && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
if (lower) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j + 1;
igraphdscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1);
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
igraphdscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1);
/* L20: */
}
}
if (*abstol > 0.) {
abstll = *abstol * sigma;
}
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Initialize indices into workspaces. Note: The IWORK indices are
used only if DSTERF or DSTEMR fail.
WORK(INDTAU:INDTAU+N-1) stores the scalar factors of the
elementary reflectors used in DSYTRD. */
indtau = 1;
/* WORK(INDD:INDD+N-1) stores the tridiagonal's diagonal entries. */
indd = indtau + *n;
/* WORK(INDE:INDE+N-1) stores the off-diagonal entries of the
tridiagonal matrix from DSYTRD. */
inde = indd + *n;
/* WORK(INDDD:INDDD+N-1) is a copy of the diagonal entries over
-written by DSTEMR (the DSTERF path copies the diagonal to W). */
inddd = inde + *n;
/* WORK(INDEE:INDEE+N-1) is a copy of the off-diagonal entries over
-written while computing the eigenvalues in DSTERF and DSTEMR. */
indee = inddd + *n;
/* INDWK is the starting offset of the left-over workspace, and
LLWORK is the remaining workspace size. */
indwk = indee + *n;
llwork = *lwork - indwk + 1;
/* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and
stores the block indices of each of the M<=N eigenvalues. */
indibl = 1;
/* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and
stores the starting and finishing indices of each block. */
indisp = indibl + *n;
/* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors
that corresponding to eigenvectors that fail to converge in
DSTEIN. This information is discarded; if any fail, the driver
returns INFO > 0. */
indifl = indisp + *n;
/* INDIWO is the offset of the remaining integer workspace. */
indiwo = indifl + *n;
/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */
igraphdsytrd_(uplo, n, &a[a_offset], lda, &work[indd], &work[inde], &work[
indtau], &work[indwk], &llwork, &iinfo);
/* If all eigenvalues are desired
then call DSTERF or DSTEMR and DORMTR. */
if ((alleig || indeig && *il == 1 && *iu == *n) && ieeeok == 1) {
if (! wantz) {
igraphdcopy_(n, &work[indd], &c__1, &w[1], &c__1);
i__1 = *n - 1;
igraphdcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
igraphdsterf_(n, &w[1], &work[indee], info);
} else {
i__1 = *n - 1;
igraphdcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
igraphdcopy_(n, &work[indd], &c__1, &work[inddd], &c__1);
if (*abstol <= *n * 2. * eps) {
tryrac = TRUE_;
} else {
tryrac = FALSE_;
}
igraphdstemr_(jobz, "A", n, &work[inddd], &work[indee], vl, vu, il, iu,
m, &w[1], &z__[z_offset], ldz, n, &isuppz[1], &tryrac, &
work[indwk], lwork, &iwork[1], liwork, info);
/* Apply orthogonal matrix used in reduction to tridiagonal
form to eigenvectors returned by DSTEIN. */
if (wantz && *info == 0) {
indwkn = inde;
llwrkn = *lwork - indwkn + 1;
igraphdormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau]
, &z__[z_offset], ldz, &work[indwkn], &llwrkn, &iinfo);
}
}
if (*info == 0) {
/* Everything worked. Skip DSTEBZ/DSTEIN. IWORK(:) are
undefined. */
*m = *n;
goto L30;
}
*info = 0;
}
/* Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN.
Also call DSTEBZ and DSTEIN if DSTEMR fails. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
igraphdstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[
inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[
indwk], &iwork[indiwo], info);
if (wantz) {
igraphdstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[
indisp], &z__[z_offset], ldz, &work[indwk], &iwork[indiwo], &
iwork[indifl], info);
/* Apply orthogonal matrix used in reduction to tridiagonal
form to eigenvectors returned by DSTEIN. */
indwkn = inde;
llwrkn = *lwork - indwkn + 1;
igraphdormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[
z_offset], ldz, &work[indwkn], &llwrkn, &iinfo);
}
/* If matrix was scaled, then rescale eigenvalues appropriately.
Jump here if DSTEMR/DSTEIN succeeded. */
L30:
if (iscale == 1) {
if (*info == 0) {
imax = *m;
} else {
imax = *info - 1;
}
d__1 = 1. / sigma;
igraphdscal_(&imax, &d__1, &w[1], &c__1);
}
/* If eigenvalues are not in order, then sort them, along with
eigenvectors. Note: We do not sort the IFAIL portion of IWORK.
It may not be initialized (if DSTEMR/DSTEIN succeeded), and we do
not return this detailed information to the user. */
if (wantz) {
i__1 = *m - 1;
for (j = 1; j <= i__1; ++j) {
i__ = 0;
tmp1 = w[j];
i__2 = *m;
for (jj = j + 1; jj <= i__2; ++jj) {
if (w[jj] < tmp1) {
i__ = jj;
tmp1 = w[jj];
}
/* L40: */
}
if (i__ != 0) {
w[i__] = w[j];
w[j] = tmp1;
igraphdswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
&c__1);
}
/* L50: */
}
}
/* Set WORK(1) to optimal workspace size. */
work[1] = (doublereal) lwkopt;
iwork[1] = liwmin;
return 0;
/* End of DSYEVR */
} /* igraphdsyevr_ */
/* Subroutine */ int igraphdgemv_(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 i__, j, ix, iy, jx, jy, kx, ky, info;
static doublereal temp;
static integer lenx, leny;
extern logical igraphlsame_(char *, char *);
extern /* Subroutine */ int igraphxerbla_(char *, integer *);
/* .. Scalar Arguments .. */
/* .. Array Arguments .. */
/* .. */
/* 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. */
/* .. Parameters .. */
/* .. Local Scalars .. */
/* .. External Functions .. */
/* .. External Subroutines .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--x;
--y;
/* Function Body */
info = 0;
if (! igraphlsame_(trans, "N") && ! igraphlsame_(trans, "T") && ! igraphlsame_(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) {
igraphxerbla_("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 (igraphlsame_(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 (igraphlsame_(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[i__ + j * a_dim1];
/* 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[i__ + j * a_dim1];
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[i__ + j * a_dim1] * 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[i__ + j * a_dim1] * x[ix];
ix += *incx;
/* L110: */
}
y[jy] += *alpha * temp;
jy += *incy;
/* L120: */
}
}
}
return 0;
/* End of DGEMV . */
} /* igraphdgemv_ */
/* Subroutine */ int igraphdlarfx_(char *side, integer *m, integer *n, doublereal *
v, doublereal *tau, doublereal *c__, integer *ldc, doublereal *work)
{
/* System generated locals */
integer c_dim1, c_offset, i__1;
doublereal d__1;
/* Local variables */
static integer j;
static doublereal t1, t2, t3, t4, t5, t6, t7, t8, t9, v1, v2, v3, v4, v5,
v6, v7, v8, v9, t10, v10, sum;
extern /* Subroutine */ int igraphdger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
extern logical igraphlsame_(char *, char *);
extern /* Subroutine */ int igraphdgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
/* -- LAPACK auxiliary routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* February 29, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLARFX applies a real elementary reflector H to a real m by n */
/* matrix C, from either the left or the right. H is represented in the */
/* form */
/* H = I - tau * v * v' */
/* where tau is a real scalar and v is a real vector. */
/* If tau = 0, then H is taken to be the unit matrix */
/* This version uses inline code if H has order < 11. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'L': form H * C */
/* = 'R': form C * H */
/* M (input) INTEGER */
/* The number of rows of the matrix C. */
/* N (input) INTEGER */
/* The number of columns of the matrix C. */
/* V (input) DOUBLE PRECISION array, dimension (M) if SIDE = 'L' */
/* or (N) if SIDE = 'R' */
/* The vector v in the representation of H. */
/* TAU (input) DOUBLE PRECISION */
/* The value tau in the representation of H. */
/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
/* On entry, the m by n matrix C. */
/* On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
/* or C * H if SIDE = 'R'. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDA >= (1,M). */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (N) if SIDE = 'L' */
/* or (M) if SIDE = 'R' */
/* WORK is not referenced if H has order < 11. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--v;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
if (*tau == 0.) {
return 0;
}
if (igraphlsame_(side, "L")) {
/* Form H * C, where H has order m. */
switch (*m) {
case 1: goto L10;
case 2: goto L30;
case 3: goto L50;
case 4: goto L70;
case 5: goto L90;
case 6: goto L110;
case 7: goto L130;
case 8: goto L150;
case 9: goto L170;
case 10: goto L190;
}
/* Code for general M */
/* w := C'*v */
igraphdgemv_("Transpose", m, n, &c_b14, &c__[c_offset], ldc, &v[1], &c__1, &
c_b16, &work[1], &c__1);
/* C := C - tau * v * w' */
d__1 = -(*tau);
igraphdger_(m, n, &d__1, &v[1], &c__1, &work[1], &c__1, &c__[c_offset], ldc)
;
goto L410;
L10:
/* Special code for 1 x 1 Householder */
t1 = 1. - *tau * v[1] * v[1];
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
c__[j * c_dim1 + 1] = t1 * c__[j * c_dim1 + 1];
/* L20: */
}
goto L410;
L30:
/* Special code for 2 x 2 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
/* L40: */
}
goto L410;
L50:
/* Special code for 3 x 3 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
c__[j * c_dim1 + 3];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
/* L60: */
}
goto L410;
L70:
/* Special code for 4 x 4 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
c__[j * c_dim1 + 4] -= sum * t4;
/* L80: */
}
goto L410;
L90:
/* Special code for 5 x 5 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
j * c_dim1 + 5];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
c__[j * c_dim1 + 4] -= sum * t4;
c__[j * c_dim1 + 5] -= sum * t5;
/* L100: */
}
goto L410;
L110:
/* Special code for 6 x 6 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
c__[j * c_dim1 + 4] -= sum * t4;
c__[j * c_dim1 + 5] -= sum * t5;
c__[j * c_dim1 + 6] -= sum * t6;
/* L120: */
}
goto L410;
L130:
/* Special code for 7 x 7 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j *
c_dim1 + 7];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
c__[j * c_dim1 + 4] -= sum * t4;
c__[j * c_dim1 + 5] -= sum * t5;
c__[j * c_dim1 + 6] -= sum * t6;
c__[j * c_dim1 + 7] -= sum * t7;
/* L140: */
}
goto L410;
L150:
/* Special code for 8 x 8 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
v8 = v[8];
t8 = *tau * v8;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j *
c_dim1 + 7] + v8 * c__[j * c_dim1 + 8];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
c__[j * c_dim1 + 4] -= sum * t4;
c__[j * c_dim1 + 5] -= sum * t5;
c__[j * c_dim1 + 6] -= sum * t6;
c__[j * c_dim1 + 7] -= sum * t7;
c__[j * c_dim1 + 8] -= sum * t8;
/* L160: */
}
goto L410;
L170:
/* Special code for 9 x 9 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
v8 = v[8];
t8 = *tau * v8;
v9 = v[9];
t9 = *tau * v9;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j *
c_dim1 + 7] + v8 * c__[j * c_dim1 + 8] + v9 * c__[j *
c_dim1 + 9];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
c__[j * c_dim1 + 4] -= sum * t4;
c__[j * c_dim1 + 5] -= sum * t5;
c__[j * c_dim1 + 6] -= sum * t6;
c__[j * c_dim1 + 7] -= sum * t7;
c__[j * c_dim1 + 8] -= sum * t8;
c__[j * c_dim1 + 9] -= sum * t9;
/* L180: */
}
goto L410;
L190:
/* Special code for 10 x 10 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
v8 = v[8];
t8 = *tau * v8;
v9 = v[9];
t9 = *tau * v9;
v10 = v[10];
t10 = *tau * v10;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j *
c_dim1 + 7] + v8 * c__[j * c_dim1 + 8] + v9 * c__[j *
c_dim1 + 9] + v10 * c__[j * c_dim1 + 10];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
c__[j * c_dim1 + 4] -= sum * t4;
c__[j * c_dim1 + 5] -= sum * t5;
c__[j * c_dim1 + 6] -= sum * t6;
c__[j * c_dim1 + 7] -= sum * t7;
c__[j * c_dim1 + 8] -= sum * t8;
c__[j * c_dim1 + 9] -= sum * t9;
c__[j * c_dim1 + 10] -= sum * t10;
/* L200: */
}
goto L410;
} else {
/* Form C * H, where H has order n. */
switch (*n) {
case 1: goto L210;
case 2: goto L230;
case 3: goto L250;
case 4: goto L270;
case 5: goto L290;
case 6: goto L310;
case 7: goto L330;
case 8: goto L350;
case 9: goto L370;
case 10: goto L390;
}
/* Code for general N */
/* w := C * v */
igraphdgemv_("No transpose", m, n, &c_b14, &c__[c_offset], ldc, &v[1], &
c__1, &c_b16, &work[1], &c__1);
/* C := C - tau * w * v' */
d__1 = -(*tau);
igraphdger_(m, n, &d__1, &work[1], &c__1, &v[1], &c__1, &c__[c_offset], ldc)
;
goto L410;
L210:
/* Special code for 1 x 1 Householder */
t1 = 1. - *tau * v[1] * v[1];
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
c__[j + c_dim1] = t1 * c__[j + c_dim1];
/* L220: */
}
goto L410;
L230:
/* Special code for 2 x 2 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
/* L240: */
}
goto L410;
L250:
/* Special code for 3 x 3 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
c__[j + c_dim1 * 3];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
/* L260: */
}
goto L410;
L270:
/* Special code for 4 x 4 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
c__[j + (c_dim1 << 2)] -= sum * t4;
/* L280: */
}
goto L410;
L290:
/* Special code for 5 x 5 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
c__[j + c_dim1 * 5];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
c__[j + (c_dim1 << 2)] -= sum * t4;
c__[j + c_dim1 * 5] -= sum * t5;
/* L300: */
}
goto L410;
L310:
/* Special code for 6 x 6 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
c__[j + (c_dim1 << 2)] -= sum * t4;
c__[j + c_dim1 * 5] -= sum * t5;
c__[j + c_dim1 * 6] -= sum * t6;
/* L320: */
}
goto L410;
L330:
/* Special code for 7 x 7 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[
j + c_dim1 * 7];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
c__[j + (c_dim1 << 2)] -= sum * t4;
c__[j + c_dim1 * 5] -= sum * t5;
c__[j + c_dim1 * 6] -= sum * t6;
c__[j + c_dim1 * 7] -= sum * t7;
/* L340: */
}
goto L410;
L350:
/* Special code for 8 x 8 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
v8 = v[8];
t8 = *tau * v8;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[
j + c_dim1 * 7] + v8 * c__[j + (c_dim1 << 3)];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
c__[j + (c_dim1 << 2)] -= sum * t4;
c__[j + c_dim1 * 5] -= sum * t5;
c__[j + c_dim1 * 6] -= sum * t6;
c__[j + c_dim1 * 7] -= sum * t7;
c__[j + (c_dim1 << 3)] -= sum * t8;
/* L360: */
}
goto L410;
L370:
/* Special code for 9 x 9 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
v8 = v[8];
t8 = *tau * v8;
v9 = v[9];
t9 = *tau * v9;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[
j + c_dim1 * 7] + v8 * c__[j + (c_dim1 << 3)] + v9 * c__[
j + c_dim1 * 9];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
c__[j + (c_dim1 << 2)] -= sum * t4;
c__[j + c_dim1 * 5] -= sum * t5;
c__[j + c_dim1 * 6] -= sum * t6;
c__[j + c_dim1 * 7] -= sum * t7;
c__[j + (c_dim1 << 3)] -= sum * t8;
c__[j + c_dim1 * 9] -= sum * t9;
/* L380: */
}
goto L410;
L390:
/* Special code for 10 x 10 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
v8 = v[8];
t8 = *tau * v8;
v9 = v[9];
t9 = *tau * v9;
v10 = v[10];
t10 = *tau * v10;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[
j + c_dim1 * 7] + v8 * c__[j + (c_dim1 << 3)] + v9 * c__[
j + c_dim1 * 9] + v10 * c__[j + c_dim1 * 10];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
c__[j + (c_dim1 << 2)] -= sum * t4;
c__[j + c_dim1 * 5] -= sum * t5;
c__[j + c_dim1 * 6] -= sum * t6;
c__[j + c_dim1 * 7] -= sum * t7;
c__[j + (c_dim1 << 3)] -= sum * t8;
c__[j + c_dim1 * 9] -= sum * t9;
c__[j + c_dim1 * 10] -= sum * t10;
/* L400: */
}
goto L410;
}
L410:
return 0;
/* End of DLARFX */
} /* igraphdlarfx_ */
