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 igraphdlarfg_(integer *n, doublereal *alpha, doublereal *x,
integer *incx, doublereal *tau)
{
/* System generated locals */
integer i__1;
doublereal d__1;
/* Builtin functions */
double d_sign(doublereal *, doublereal *);
/* Local variables */
integer j, knt;
doublereal beta;
extern doublereal igraphdnrm2_(integer *, doublereal *, integer *);
extern /* Subroutine */ int igraphdscal_(integer *, doublereal *, doublereal *,
integer *);
doublereal xnorm;
extern doublereal igraphdlapy2_(doublereal *, doublereal *), igraphdlamch_(char *);
doublereal safmin, rsafmn;
/* -- 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
=====================================================================
Parameter adjustments */
--x;
/* Function Body */
if (*n <= 1) {
*tau = 0.;
return 0;
}
i__1 = *n - 1;
xnorm = igraphdnrm2_(&i__1, &x[1], incx);
if (xnorm == 0.) {
/* H = I */
*tau = 0.;
} else {
/* general case */
d__1 = igraphdlapy2_(alpha, &xnorm);
beta = -d_sign(&d__1, alpha);
safmin = igraphdlamch_("S") / igraphdlamch_("E");
knt = 0;
if (abs(beta) < safmin) {
/* XNORM, BETA may be inaccurate; scale X and recompute them */
rsafmn = 1. / safmin;
L10:
++knt;
i__1 = *n - 1;
igraphdscal_(&i__1, &rsafmn, &x[1], incx);
beta *= rsafmn;
*alpha *= rsafmn;
if (abs(beta) < safmin) {
goto L10;
}
/* New BETA is at most 1, at least SAFMIN */
i__1 = *n - 1;
xnorm = igraphdnrm2_(&i__1, &x[1], incx);
d__1 = igraphdlapy2_(alpha, &xnorm);
beta = -d_sign(&d__1, alpha);
}
*tau = (beta - *alpha) / beta;
i__1 = *n - 1;
d__1 = 1. / (*alpha - beta);
igraphdscal_(&i__1, &d__1, &x[1], incx);
/* If ALPHA is subnormal, it may lose relative accuracy */
i__1 = knt;
for (j = 1; j <= i__1; ++j) {
beta *= safmin;
/* L20: */
}
*alpha = beta;
}
return 0;
/* End of DLARFG */
} /* igraphdlarfg_ */
Subroutine */ int igraphdnapps_(integer *n, integer *kev, integer *np,
doublereal *shiftr, doublereal *shifti, doublereal *v, integer *ldv,
doublereal *h__, integer *ldh, doublereal *resid, doublereal *q,
integer *ldq, doublereal *workl, doublereal *workd)
{
/* Initialized data */
IGRAPH_F77_SAVE logical first = TRUE_;
/* System generated locals */
integer h_dim1, h_offset, v_dim1, v_offset, q_dim1, q_offset, i__1, i__2,
i__3, i__4;
doublereal d__1, d__2;
/* Local variables */
doublereal c__, f, g;
integer i__, j;
doublereal r__, s, t, u[3];
real t0, t1;
doublereal h11, h12, h21, h22, h32;
integer jj, ir, nr;
doublereal tau;
IGRAPH_F77_SAVE doublereal ulp;
doublereal tst1;
integer iend;
IGRAPH_F77_SAVE doublereal unfl, ovfl;
extern /* Subroutine */ int igraphdscal_(integer *, doublereal *, doublereal *,
integer *), igraphdlarf_(char *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, doublereal *);
logical cconj;
extern /* Subroutine */ int igraphdgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), igraphdcopy_(integer *,
doublereal *, integer *, doublereal *, integer *), igraphdaxpy_(integer
*, doublereal *, doublereal *, integer *, doublereal *, integer *)
, igraphdmout_(integer *, integer *, integer *, doublereal *, integer *,
integer *, char *, ftnlen), igraphdvout_(integer *, integer *,
doublereal *, integer *, char *, ftnlen), igraphivout_(integer *,
integer *, integer *, integer *, char *, ftnlen);
extern doublereal igraphdlapy2_(doublereal *, doublereal *);
extern /* Subroutine */ int igraphdlabad_(doublereal *, doublereal *);
extern doublereal igraphdlamch_(char *);
extern /* Subroutine */ int igraphdlarfg_(integer *, doublereal *, doublereal *,
integer *, doublereal *);
doublereal sigmai;
extern doublereal igraphdlanhs_(char *, integer *, doublereal *, integer *,
doublereal *);
extern /* Subroutine */ int igraphsecond_(real *), igraphdlacpy_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *), igraphdlaset_(char *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *), igraphdlartg_(
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
integer logfil, ndigit;
doublereal sigmar;
integer mnapps = 0, msglvl;
real tnapps = 0.;
integer istart;
IGRAPH_F77_SAVE doublereal smlnum;
integer kplusp;
/* %----------------------------------------------------%
| Include files for debugging and timing information |
%----------------------------------------------------%
%------------------%
| Scalar Arguments |
%------------------%
%-----------------%
| Array Arguments |
%-----------------%
%------------%
| Parameters |
%------------%
%------------------------%
| Local Scalars & Arrays |
%------------------------%
%----------------------%
| External Subroutines |
%----------------------%
%--------------------%
| External Functions |
%--------------------%
%----------------------%
| Intrinsics Functions |
%----------------------%
%----------------%
| Data statments |
%----------------%
Parameter adjustments */
--workd;
--resid;
--workl;
--shifti;
--shiftr;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
/* Function Body
%-----------------------%
| Executable Statements |
%-----------------------% */
if (first) {
/* %-----------------------------------------------%
| Set machine-dependent constants for the |
| stopping criterion. If norm(H) <= sqrt(OVFL), |
| overflow should not occur. |
| REFERENCE: LAPACK subroutine dlahqr |
%-----------------------------------------------% */
unfl = igraphdlamch_("safe minimum");
ovfl = 1. / unfl;
igraphdlabad_(&unfl, &ovfl);
ulp = igraphdlamch_("precision");
smlnum = unfl * (*n / ulp);
first = FALSE_;
}
/* %-------------------------------%
| Initialize timing statistics |
| & message level for debugging |
%-------------------------------% */
igraphsecond_(&t0);
msglvl = mnapps;
kplusp = *kev + *np;
/* %--------------------------------------------%
| Initialize Q to the identity to accumulate |
| the rotations and reflections |
%--------------------------------------------% */
igraphdlaset_("All", &kplusp, &kplusp, &c_b5, &c_b6, &q[q_offset], ldq);
/* %----------------------------------------------%
| Quick return if there are no shifts to apply |
%----------------------------------------------% */
if (*np == 0) {
goto L9000;
}
/* %----------------------------------------------%
| Chase the bulge with the application of each |
| implicit shift. Each shift is applied to the |
| whole matrix including each block. |
%----------------------------------------------% */
cconj = FALSE_;
i__1 = *np;
for (jj = 1; jj <= i__1; ++jj) {
sigmar = shiftr[jj];
sigmai = shifti[jj];
if (msglvl > 2) {
igraphivout_(&logfil, &c__1, &jj, &ndigit, "_napps: shift number.", (
ftnlen)21);
igraphdvout_(&logfil, &c__1, &sigmar, &ndigit, "_napps: The real part "
"of the shift ", (ftnlen)35);
igraphdvout_(&logfil, &c__1, &sigmai, &ndigit, "_napps: The imaginary "
"part of the shift ", (ftnlen)40);
}
/* %-------------------------------------------------%
| The following set of conditionals is necessary |
| in order that complex conjugate pairs of shifts |
| are applied together or not at all. |
%-------------------------------------------------% */
if (cconj) {
/* %-----------------------------------------%
| cconj = .true. means the previous shift |
| had non-zero imaginary part. |
%-----------------------------------------% */
cconj = FALSE_;
goto L110;
} else if (jj < *np && abs(sigmai) > 0.) {
/* %------------------------------------%
| Start of a complex conjugate pair. |
%------------------------------------% */
cconj = TRUE_;
} else if (jj == *np && abs(sigmai) > 0.) {
/* %----------------------------------------------%
| The last shift has a nonzero imaginary part. |
| Don't apply it; thus the order of the |
| compressed H is order KEV+1 since only np-1 |
| were applied. |
%----------------------------------------------% */
++(*kev);
goto L110;
}
istart = 1;
L20:
/* %--------------------------------------------------%
| if sigmai = 0 then |
| Apply the jj-th shift ... |
| else |
| Apply the jj-th and (jj+1)-th together ... |
| (Note that jj < np at this point in the code) |
| end |
| to the current block of H. The next do loop |
| determines the current block ; |
%--------------------------------------------------% */
i__2 = kplusp - 1;
for (i__ = istart; i__ <= i__2; ++i__) {
/* %----------------------------------------%
| Check for splitting and deflation. Use |
| a standard test as in the QR algorithm |
| REFERENCE: LAPACK subroutine dlahqr |
%----------------------------------------% */
tst1 = (d__1 = h__[i__ + i__ * h_dim1], abs(d__1)) + (d__2 = h__[
i__ + 1 + (i__ + 1) * h_dim1], abs(d__2));
if (tst1 == 0.) {
i__3 = kplusp - jj + 1;
tst1 = igraphdlanhs_("1", &i__3, &h__[h_offset], ldh, &workl[1]);
}
/* Computing MAX */
d__2 = ulp * tst1;
if ((d__1 = h__[i__ + 1 + i__ * h_dim1], abs(d__1)) <= max(d__2,
smlnum)) {
if (msglvl > 0) {
igraphivout_(&logfil, &c__1, &i__, &ndigit, "_napps: matrix sp"
"litting at row/column no.", (ftnlen)42);
igraphivout_(&logfil, &c__1, &jj, &ndigit, "_napps: matrix spl"
"itting with shift number.", (ftnlen)43);
igraphdvout_(&logfil, &c__1, &h__[i__ + 1 + i__ * h_dim1], &
ndigit, "_napps: off diagonal element.", (ftnlen)
29);
}
iend = i__;
h__[i__ + 1 + i__ * h_dim1] = 0.;
goto L40;
}
/* L30: */
}
iend = kplusp;
L40:
if (msglvl > 2) {
igraphivout_(&logfil, &c__1, &istart, &ndigit, "_napps: Start of curre"
"nt block ", (ftnlen)31);
igraphivout_(&logfil, &c__1, &iend, &ndigit, "_napps: End of current b"
"lock ", (ftnlen)29);
}
/* %------------------------------------------------%
| No reason to apply a shift to block of order 1 |
%------------------------------------------------% */
if (istart == iend) {
goto L100;
}
/* %------------------------------------------------------%
| If istart + 1 = iend then no reason to apply a |
| complex conjugate pair of shifts on a 2 by 2 matrix. |
%------------------------------------------------------% */
if (istart + 1 == iend && abs(sigmai) > 0.) {
goto L100;
}
h11 = h__[istart + istart * h_dim1];
h21 = h__[istart + 1 + istart * h_dim1];
if (abs(sigmai) <= 0.) {
/* %---------------------------------------------%
| Real-valued shift ==> apply single shift QR |
%---------------------------------------------% */
f = h11 - sigmar;
g = h21;
i__2 = iend - 1;
for (i__ = istart; i__ <= i__2; ++i__) {
/* %-----------------------------------------------------%
| Contruct the plane rotation G to zero out the bulge |
%-----------------------------------------------------% */
igraphdlartg_(&f, &g, &c__, &s, &r__);
if (i__ > istart) {
/* %-------------------------------------------%
| The following ensures that h(1:iend-1,1), |
| the first iend-2 off diagonal of elements |
| H, remain non negative. |
%-------------------------------------------% */
if (r__ < 0.) {
r__ = -r__;
c__ = -c__;
s = -s;
}
h__[i__ + (i__ - 1) * h_dim1] = r__;
h__[i__ + 1 + (i__ - 1) * h_dim1] = 0.;
}
/* %---------------------------------------------%
| Apply rotation to the left of H; H <- G'*H |
%---------------------------------------------% */
i__3 = kplusp;
for (j = i__; j <= i__3; ++j) {
t = c__ * h__[i__ + j * h_dim1] + s * h__[i__ + 1 + j *
h_dim1];
h__[i__ + 1 + j * h_dim1] = -s * h__[i__ + j * h_dim1] +
c__ * h__[i__ + 1 + j * h_dim1];
h__[i__ + j * h_dim1] = t;
/* L50: */
}
/* %---------------------------------------------%
| Apply rotation to the right of H; H <- H*G |
%---------------------------------------------%
Computing MIN */
i__4 = i__ + 2;
i__3 = min(i__4,iend);
for (j = 1; j <= i__3; ++j) {
t = c__ * h__[j + i__ * h_dim1] + s * h__[j + (i__ + 1) *
h_dim1];
h__[j + (i__ + 1) * h_dim1] = -s * h__[j + i__ * h_dim1]
+ c__ * h__[j + (i__ + 1) * h_dim1];
h__[j + i__ * h_dim1] = t;
/* L60: */
}
/* %----------------------------------------------------%
| Accumulate the rotation in the matrix Q; Q <- Q*G |
%----------------------------------------------------%
Computing MIN */
i__4 = j + jj;
i__3 = min(i__4,kplusp);
for (j = 1; j <= i__3; ++j) {
t = c__ * q[j + i__ * q_dim1] + s * q[j + (i__ + 1) *
q_dim1];
q[j + (i__ + 1) * q_dim1] = -s * q[j + i__ * q_dim1] +
c__ * q[j + (i__ + 1) * q_dim1];
q[j + i__ * q_dim1] = t;
/* L70: */
}
/* %---------------------------%
| Prepare for next rotation |
%---------------------------% */
if (i__ < iend - 1) {
f = h__[i__ + 1 + i__ * h_dim1];
g = h__[i__ + 2 + i__ * h_dim1];
}
/* L80: */
}
/* %-----------------------------------%
| Finished applying the real shift. |
%-----------------------------------% */
} else {
/* %----------------------------------------------------%
| Complex conjugate shifts ==> apply double shift QR |
%----------------------------------------------------% */
h12 = h__[istart + (istart + 1) * h_dim1];
h22 = h__[istart + 1 + (istart + 1) * h_dim1];
h32 = h__[istart + 2 + (istart + 1) * h_dim1];
/* %---------------------------------------------------------%
| Compute 1st column of (H - shift*I)*(H - conj(shift)*I) |
%---------------------------------------------------------% */
s = sigmar * 2.f;
t = igraphdlapy2_(&sigmar, &sigmai);
u[0] = (h11 * (h11 - s) + t * t) / h21 + h12;
u[1] = h11 + h22 - s;
u[2] = h32;
i__2 = iend - 1;
for (i__ = istart; i__ <= i__2; ++i__) {
/* Computing MIN */
i__3 = 3, i__4 = iend - i__ + 1;
nr = min(i__3,i__4);
/* %-----------------------------------------------------%
| Construct Householder reflector G to zero out u(1). |
| G is of the form I - tau*( 1 u )' * ( 1 u' ). |
%-----------------------------------------------------% */
igraphdlarfg_(&nr, u, &u[1], &c__1, &tau);
if (i__ > istart) {
h__[i__ + (i__ - 1) * h_dim1] = u[0];
h__[i__ + 1 + (i__ - 1) * h_dim1] = 0.;
if (i__ < iend - 1) {
h__[i__ + 2 + (i__ - 1) * h_dim1] = 0.;
}
}
u[0] = 1.;
/* %--------------------------------------%
| Apply the reflector to the left of H |
%--------------------------------------% */
i__3 = kplusp - i__ + 1;
igraphdlarf_("Left", &nr, &i__3, u, &c__1, &tau, &h__[i__ + i__ *
h_dim1], ldh, &workl[1]);
/* %---------------------------------------%
| Apply the reflector to the right of H |
%---------------------------------------%
Computing MIN */
i__3 = i__ + 3;
ir = min(i__3,iend);
igraphdlarf_("Right", &ir, &nr, u, &c__1, &tau, &h__[i__ * h_dim1 +
1], ldh, &workl[1]);
/* %-----------------------------------------------------%
| Accumulate the reflector in the matrix Q; Q <- Q*G |
%-----------------------------------------------------% */
igraphdlarf_("Right", &kplusp, &nr, u, &c__1, &tau, &q[i__ * q_dim1
+ 1], ldq, &workl[1]);
/* %----------------------------%
| Prepare for next reflector |
%----------------------------% */
if (i__ < iend - 1) {
u[0] = h__[i__ + 1 + i__ * h_dim1];
u[1] = h__[i__ + 2 + i__ * h_dim1];
if (i__ < iend - 2) {
u[2] = h__[i__ + 3 + i__ * h_dim1];
}
}
/* L90: */
}
/* %--------------------------------------------%
| Finished applying a complex pair of shifts |
| to the current block |
%--------------------------------------------% */
}
L100:
/* %---------------------------------------------------------%
| Apply the same shift to the next block if there is any. |
%---------------------------------------------------------% */
istart = iend + 1;
if (iend < kplusp) {
goto L20;
}
/* %---------------------------------------------%
| Loop back to the top to get the next shift. |
%---------------------------------------------% */
L110:
;
}
/* %--------------------------------------------------%
| Perform a similarity transformation that makes |
| sure that H will have non negative sub diagonals |
%--------------------------------------------------% */
i__1 = *kev;
for (j = 1; j <= i__1; ++j) {
if (h__[j + 1 + j * h_dim1] < 0.) {
i__2 = kplusp - j + 1;
igraphdscal_(&i__2, &c_b43, &h__[j + 1 + j * h_dim1], ldh);
/* Computing MIN */
i__3 = j + 2;
i__2 = min(i__3,kplusp);
igraphdscal_(&i__2, &c_b43, &h__[(j + 1) * h_dim1 + 1], &c__1);
/* Computing MIN */
i__3 = j + *np + 1;
i__2 = min(i__3,kplusp);
igraphdscal_(&i__2, &c_b43, &q[(j + 1) * q_dim1 + 1], &c__1);
}
/* L120: */
}
i__1 = *kev;
for (i__ = 1; i__ <= i__1; ++i__) {
/* %--------------------------------------------%
| Final check for splitting and deflation. |
| Use a standard test as in the QR algorithm |
| REFERENCE: LAPACK subroutine dlahqr |
%--------------------------------------------% */
tst1 = (d__1 = h__[i__ + i__ * h_dim1], abs(d__1)) + (d__2 = h__[i__
+ 1 + (i__ + 1) * h_dim1], abs(d__2));
if (tst1 == 0.) {
tst1 = igraphdlanhs_("1", kev, &h__[h_offset], ldh, &workl[1]);
}
/* Computing MAX */
d__1 = ulp * tst1;
if (h__[i__ + 1 + i__ * h_dim1] <= max(d__1,smlnum)) {
h__[i__ + 1 + i__ * h_dim1] = 0.;
}
/* L130: */
}
/* %-------------------------------------------------%
| Compute the (kev+1)-st column of (V*Q) and |
| temporarily store the result in WORKD(N+1:2*N). |
| This is needed in the residual update since we |
| cannot GUARANTEE that the corresponding entry |
| of H would be zero as in exact arithmetic. |
%-------------------------------------------------% */
if (h__[*kev + 1 + *kev * h_dim1] > 0.) {
igraphdgemv_("N", n, &kplusp, &c_b6, &v[v_offset], ldv, &q[(*kev + 1) *
q_dim1 + 1], &c__1, &c_b5, &workd[*n + 1], &c__1);
}
/* %----------------------------------------------------------%
| Compute column 1 to kev of (V*Q) in backward order |
| taking advantage of the upper Hessenberg structure of Q. |
%----------------------------------------------------------% */
i__1 = *kev;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = kplusp - i__ + 1;
igraphdgemv_("N", n, &i__2, &c_b6, &v[v_offset], ldv, &q[(*kev - i__ + 1) *
q_dim1 + 1], &c__1, &c_b5, &workd[1], &c__1);
igraphdcopy_(n, &workd[1], &c__1, &v[(kplusp - i__ + 1) * v_dim1 + 1], &
c__1);
/* L140: */
}
/* %-------------------------------------------------%
| Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). |
%-------------------------------------------------% */
igraphdlacpy_("A", n, kev, &v[(kplusp - *kev + 1) * v_dim1 + 1], ldv, &v[
v_offset], ldv);
/* %--------------------------------------------------------------%
| Copy the (kev+1)-st column of (V*Q) in the appropriate place |
%--------------------------------------------------------------% */
if (h__[*kev + 1 + *kev * h_dim1] > 0.) {
igraphdcopy_(n, &workd[*n + 1], &c__1, &v[(*kev + 1) * v_dim1 + 1], &c__1);
}
/* %-------------------------------------%
| Update the residual vector: |
| r <- sigmak*r + betak*v(:,kev+1) |
| where |
| sigmak = (e_{kplusp}'*Q)*e_{kev} |
| betak = e_{kev+1}'*H*e_{kev} |
%-------------------------------------% */
igraphdscal_(n, &q[kplusp + *kev * q_dim1], &resid[1], &c__1);
if (h__[*kev + 1 + *kev * h_dim1] > 0.) {
igraphdaxpy_(n, &h__[*kev + 1 + *kev * h_dim1], &v[(*kev + 1) * v_dim1 + 1],
&c__1, &resid[1], &c__1);
}
if (msglvl > 1) {
igraphdvout_(&logfil, &c__1, &q[kplusp + *kev * q_dim1], &ndigit, "_napps:"
" sigmak = (e_{kev+p}^T*Q)*e_{kev}", (ftnlen)40);
igraphdvout_(&logfil, &c__1, &h__[*kev + 1 + *kev * h_dim1], &ndigit, "_na"
"pps: betak = e_{kev+1}^T*H*e_{kev}", (ftnlen)37);
igraphivout_(&logfil, &c__1, kev, &ndigit, "_napps: Order of the final Hes"
"senberg matrix ", (ftnlen)45);
if (msglvl > 2) {
igraphdmout_(&logfil, kev, kev, &h__[h_offset], ldh, &ndigit, "_napps:"
" updated Hessenberg matrix H for next iteration", (ftnlen)
54);
}
}
L9000:
igraphsecond_(&t1);
tnapps += t1 - t0;
return 0;
/* %---------------%
| End of dnapps |
%---------------% */
} /* igraphdnapps_ */
/* 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 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 igraphdnaitr_(integer *ido, char *bmat, integer *n, integer *k,
integer *np, integer *nb, doublereal *resid, doublereal *rnorm,
doublereal *v, integer *ldv, doublereal *h__, integer *ldh, integer *
ipntr, doublereal *workd, integer *info)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer h_dim1, h_offset, v_dim1, v_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer i__, j;
static real t0, t1, t2, t3, t4, t5;
static integer jj, ipj, irj, ivj;
static doublereal ulp, tst1;
extern doublereal igraphddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static integer ierr, iter;
static doublereal unfl, ovfl;
static integer itry;
extern doublereal igraphdnrm2_(integer *, doublereal *, integer *);
static doublereal temp1;
static logical orth1, orth2, step3, step4;
static doublereal betaj;
extern /* Subroutine */ int igraphdscal_(integer *, doublereal *, doublereal *,
integer *), igraphdgemv_(char *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *);
static integer infol;
extern /* Subroutine */ int igraphdcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), igraphdaxpy_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *), igraphdmout_(integer
*, integer *, integer *, doublereal *, integer *, integer *, char
*);
static doublereal xtemp[2];
extern /* Subroutine */ int igraphdvout_(integer *, integer *, doublereal *,
integer *, char *);
static doublereal wnorm;
extern /* Subroutine */ int igraphivout_(integer *, integer *, integer *,
integer *, char *), igraphdgetv0_(integer *, char *, integer *,
logical *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *
), igraphdlabad_(doublereal *, doublereal *);
static doublereal rnorm1;
extern doublereal igraphdlamch_(char *);
extern /* Subroutine */ int igraphdlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
extern doublereal igraphdlanhs_(char *, integer *, doublereal *, integer *,
doublereal *);
extern /* Subroutine */ int igraphsecond_(real *);
static logical rstart;
static integer msglvl;
static doublereal smlnum;
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %---------------% */
/* | Local Scalars | */
/* %---------------% */
/* %-----------------------% */
/* | Local Array Arguments | */
/* %-----------------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %---------------------% */
/* | Intrinsic Functions | */
/* %---------------------% */
/* %-----------------% */
/* | Data statements | */
/* %-----------------% */
/* Parameter adjustments */
--workd;
--resid;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--ipntr;
/* Function Body */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
if (first) {
/* %-----------------------------------------% */
/* | Set machine-dependent constants for the | */
/* | the splitting and deflation criterion. | */
/* | If norm(H) <= sqrt(OVFL), | */
/* | overflow should not occur. | */
/* | REFERENCE: LAPACK subroutine dlahqr | */
/* %-----------------------------------------% */
unfl = igraphdlamch_("safe minimum");
ovfl = 1. / unfl;
igraphdlabad_(&unfl, &ovfl);
ulp = igraphdlamch_("precision");
smlnum = unfl * (*n / ulp);
first = FALSE_;
}
if (*ido == 0) {
/* %-------------------------------% */
/* | Initialize timing statistics | */
/* | & message level for debugging | */
/* %-------------------------------% */
igraphsecond_(&t0);
msglvl = debug_1.mnaitr;
/* %------------------------------% */
/* | Initial call to this routine | */
/* %------------------------------% */
*info = 0;
step3 = FALSE_;
step4 = FALSE_;
rstart = FALSE_;
orth1 = FALSE_;
orth2 = FALSE_;
j = *k + 1;
ipj = 1;
irj = ipj + *n;
ivj = irj + *n;
}
/* %-------------------------------------------------% */
/* | When in reverse communication mode one of: | */
/* | STEP3, STEP4, ORTH1, ORTH2, RSTART | */
/* | will be .true. when .... | */
/* | STEP3: return from computing OP*v_{j}. | */
/* | STEP4: return from computing B-norm of OP*v_{j} | */
/* | ORTH1: return from computing B-norm of r_{j+1} | */
/* | ORTH2: return from computing B-norm of | */
/* | correction to the residual vector. | */
/* | RSTART: return from OP computations needed by | */
/* | dgetv0. | */
/* %-------------------------------------------------% */
if (step3) {
goto L50;
}
if (step4) {
goto L60;
}
if (orth1) {
goto L70;
}
if (orth2) {
goto L90;
}
if (rstart) {
goto L30;
}
/* %-----------------------------% */
/* | Else this is the first step | */
/* %-----------------------------% */
/* %--------------------------------------------------------------% */
/* | | */
/* | A R N O L D I I T E R A T I O N L O O P | */
/* | | */
/* | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | */
/* %--------------------------------------------------------------% */
L1000:
if (msglvl > 1) {
igraphivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: generat"
"ing Arnoldi vector number");
igraphdvout_(&debug_1.logfil, &c__1, rnorm, &debug_1.ndigit, "_naitr: B-no"
"rm of the current residual is");
}
/* %---------------------------------------------------% */
/* | STEP 1: Check if the B norm of j-th residual | */
/* | vector is zero. Equivalent to determing whether | */
/* | an exact j-step Arnoldi factorization is present. | */
/* %---------------------------------------------------% */
betaj = *rnorm;
if (*rnorm > 0.) {
goto L40;
}
/* %---------------------------------------------------% */
/* | Invariant subspace found, generate a new starting | */
/* | vector which is orthogonal to the current Arnoldi | */
/* | basis and continue the iteration. | */
/* %---------------------------------------------------% */
if (msglvl > 0) {
igraphivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: ****** "
"RESTART AT STEP ******");
}
/* %---------------------------------------------% */
/* | ITRY is the loop variable that controls the | */
/* | maximum amount of times that a restart is | */
/* | attempted. NRSTRT is used by stat.h | */
/* %---------------------------------------------% */
betaj = 0.;
++timing_1.nrstrt;
itry = 1;
L20:
rstart = TRUE_;
*ido = 0;
L30:
/* %--------------------------------------% */
/* | If in reverse communication mode and | */
/* | RSTART = .true. flow returns here. | */
/* %--------------------------------------% */
igraphdgetv0_(ido, bmat, &itry, &c_false, n, &j, &v[v_offset], ldv, &resid[1],
rnorm, &ipntr[1], &workd[1], &ierr);
if (*ido != 99) {
goto L9000;
}
if (ierr < 0) {
++itry;
if (itry <= 3) {
goto L20;
}
/* %------------------------------------------------% */
/* | Give up after several restart attempts. | */
/* | Set INFO to the size of the invariant subspace | */
/* | which spans OP and exit. | */
/* %------------------------------------------------% */
*info = j - 1;
igraphsecond_(&t1);
timing_1.tnaitr += t1 - t0;
*ido = 99;
goto L9000;
}
L40:
/* %---------------------------------------------------------% */
/* | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | */
/* | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | */
/* | when reciprocating a small RNORM, test against lower | */
/* | machine bound. | */
/* %---------------------------------------------------------% */
igraphdcopy_(n, &resid[1], &c__1, &v[j * v_dim1 + 1], &c__1);
if (*rnorm >= unfl) {
temp1 = 1. / *rnorm;
igraphdscal_(n, &temp1, &v[j * v_dim1 + 1], &c__1);
igraphdscal_(n, &temp1, &workd[ipj], &c__1);
} else {
/* %-----------------------------------------% */
/* | To scale both v_{j} and p_{j} carefully | */
/* | use LAPACK routine SLASCL | */
/* %-----------------------------------------% */
igraphdlascl_("General", &i__, &i__, rnorm, &c_b25, n, &c__1, &v[j * v_dim1
+ 1], n, &infol);
igraphdlascl_("General", &i__, &i__, rnorm, &c_b25, n, &c__1, &workd[ipj],
n, &infol);
}
/* %------------------------------------------------------% */
/* | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | */
/* | Note that this is not quite yet r_{j}. See STEP 4 | */
/* %------------------------------------------------------% */
step3 = TRUE_;
++timing_1.nopx;
igraphsecond_(&t2);
igraphdcopy_(n, &v[j * v_dim1 + 1], &c__1, &workd[ivj], &c__1);
ipntr[1] = ivj;
ipntr[2] = irj;
ipntr[3] = ipj;
*ido = 1;
/* %-----------------------------------% */
/* | Exit in order to compute OP*v_{j} | */
/* %-----------------------------------% */
goto L9000;
L50:
/* %----------------------------------% */
/* | Back from reverse communication; | */
/* | WORKD(IRJ:IRJ+N-1) := OP*v_{j} | */
/* | if step3 = .true. | */
/* %----------------------------------% */
igraphsecond_(&t3);
timing_1.tmvopx += t3 - t2;
step3 = FALSE_;
/* %------------------------------------------% */
/* | Put another copy of OP*v_{j} into RESID. | */
/* %------------------------------------------% */
igraphdcopy_(n, &workd[irj], &c__1, &resid[1], &c__1);
/* %---------------------------------------% */
/* | STEP 4: Finish extending the Arnoldi | */
/* | factorization to length j. | */
/* %---------------------------------------% */
igraphsecond_(&t2);
if (*(unsigned char *)bmat == 'G') {
++timing_1.nbx;
step4 = TRUE_;
ipntr[1] = irj;
ipntr[2] = ipj;
*ido = 2;
/* %-------------------------------------% */
/* | Exit in order to compute B*OP*v_{j} | */
/* %-------------------------------------% */
goto L9000;
} else if (*(unsigned char *)bmat == 'I') {
igraphdcopy_(n, &resid[1], &c__1, &workd[ipj], &c__1);
}
L60:
/* %----------------------------------% */
/* | Back from reverse communication; | */
/* | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} | */
/* | if step4 = .true. | */
/* %----------------------------------% */
if (*(unsigned char *)bmat == 'G') {
igraphsecond_(&t3);
timing_1.tmvbx += t3 - t2;
}
step4 = FALSE_;
/* %-------------------------------------% */
/* | The following is needed for STEP 5. | */
/* | Compute the B-norm of OP*v_{j}. | */
/* %-------------------------------------% */
if (*(unsigned char *)bmat == 'G') {
wnorm = igraphddot_(n, &resid[1], &c__1, &workd[ipj], &c__1);
wnorm = sqrt((abs(wnorm)));
} else if (*(unsigned char *)bmat == 'I') {
wnorm = igraphdnrm2_(n, &resid[1], &c__1);
}
/* %-----------------------------------------% */
/* | Compute the j-th residual corresponding | */
/* | to the j step factorization. | */
/* | Use Classical Gram Schmidt and compute: | */
/* | w_{j} <- V_{j}^T * B * OP * v_{j} | */
/* | r_{j} <- OP*v_{j} - V_{j} * w_{j} | */
/* %-----------------------------------------% */
/* %------------------------------------------% */
/* | Compute the j Fourier coefficients w_{j} | */
/* | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | */
/* %------------------------------------------% */
igraphdgemv_("T", n, &j, &c_b25, &v[v_offset], ldv, &workd[ipj], &c__1, &c_b47,
&h__[j * h_dim1 + 1], &c__1);
/* %--------------------------------------% */
/* | Orthogonalize r_{j} against V_{j}. | */
/* | RESID contains OP*v_{j}. See STEP 3. | */
/* %--------------------------------------% */
igraphdgemv_("N", n, &j, &c_b50, &v[v_offset], ldv, &h__[j * h_dim1 + 1], &c__1,
&c_b25, &resid[1], &c__1);
if (j > 1) {
h__[j + (j - 1) * h_dim1] = betaj;
}
igraphsecond_(&t4);
orth1 = TRUE_;
igraphsecond_(&t2);
if (*(unsigned char *)bmat == 'G') {
++timing_1.nbx;
igraphdcopy_(n, &resid[1], &c__1, &workd[irj], &c__1);
ipntr[1] = irj;
ipntr[2] = ipj;
*ido = 2;
/* %----------------------------------% */
/* | Exit in order to compute B*r_{j} | */
/* %----------------------------------% */
goto L9000;
} else if (*(unsigned char *)bmat == 'I') {
igraphdcopy_(n, &resid[1], &c__1, &workd[ipj], &c__1);
}
L70:
/* %---------------------------------------------------% */
/* | Back from reverse communication if ORTH1 = .true. | */
/* | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | */
/* %---------------------------------------------------% */
if (*(unsigned char *)bmat == 'G') {
igraphsecond_(&t3);
timing_1.tmvbx += t3 - t2;
}
orth1 = FALSE_;
/* %------------------------------% */
/* | Compute the B-norm of r_{j}. | */
/* %------------------------------% */
if (*(unsigned char *)bmat == 'G') {
*rnorm = igraphddot_(n, &resid[1], &c__1, &workd[ipj], &c__1);
*rnorm = sqrt((abs(*rnorm)));
} else if (*(unsigned char *)bmat == 'I') {
*rnorm = igraphdnrm2_(n, &resid[1], &c__1);
}
/* %-----------------------------------------------------------% */
/* | STEP 5: Re-orthogonalization / Iterative refinement phase | */
/* | Maximum NITER_ITREF tries. | */
/* | | */
/* | s = V_{j}^T * B * r_{j} | */
/* | r_{j} = r_{j} - V_{j}*s | */
/* | alphaj = alphaj + s_{j} | */
/* | | */
/* | The stopping criteria used for iterative refinement is | */
/* | discussed in Parlett's book SEP, page 107 and in Gragg & | */
/* | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | */
/* | Determine if we need to correct the residual. The goal is | */
/* | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | */
/* | The following test determines whether the sine of the | */
/* | angle between OP*x and the computed residual is less | */
/* | than or equal to 0.717. | */
/* %-----------------------------------------------------------% */
if (*rnorm > wnorm * .717f) {
goto L100;
}
iter = 0;
++timing_1.nrorth;
/* %---------------------------------------------------% */
/* | Enter the Iterative refinement phase. If further | */
/* | refinement is necessary, loop back here. The loop | */
/* | variable is ITER. Perform a step of Classical | */
/* | Gram-Schmidt using all the Arnoldi vectors V_{j} | */
/* %---------------------------------------------------% */
L80:
if (msglvl > 2) {
xtemp[0] = wnorm;
xtemp[1] = *rnorm;
igraphdvout_(&debug_1.logfil, &c__2, xtemp, &debug_1.ndigit, "_naitr: re-o"
"rthonalization; wnorm and rnorm are");
igraphdvout_(&debug_1.logfil, &j, &h__[j * h_dim1 + 1], &debug_1.ndigit,
"_naitr: j-th column of H");
}
/* %----------------------------------------------------% */
/* | Compute V_{j}^T * B * r_{j}. | */
/* | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | */
/* %----------------------------------------------------% */
igraphdgemv_("T", n, &j, &c_b25, &v[v_offset], ldv, &workd[ipj], &c__1, &c_b47,
&workd[irj], &c__1);
/* %---------------------------------------------% */
/* | Compute the correction to the residual: | */
/* | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | */
/* | The correction to H is v(:,1:J)*H(1:J,1:J) | */
/* | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. | */
/* %---------------------------------------------% */
igraphdgemv_("N", n, &j, &c_b50, &v[v_offset], ldv, &workd[irj], &c__1, &c_b25,
&resid[1], &c__1);
igraphdaxpy_(&j, &c_b25, &workd[irj], &c__1, &h__[j * h_dim1 + 1], &c__1);
orth2 = TRUE_;
igraphsecond_(&t2);
if (*(unsigned char *)bmat == 'G') {
++timing_1.nbx;
igraphdcopy_(n, &resid[1], &c__1, &workd[irj], &c__1);
ipntr[1] = irj;
ipntr[2] = ipj;
*ido = 2;
/* %-----------------------------------% */
/* | Exit in order to compute B*r_{j}. | */
/* | r_{j} is the corrected residual. | */
/* %-----------------------------------% */
goto L9000;
} else if (*(unsigned char *)bmat == 'I') {
igraphdcopy_(n, &resid[1], &c__1, &workd[ipj], &c__1);
}
L90:
/* %---------------------------------------------------% */
/* | Back from reverse communication if ORTH2 = .true. | */
/* %---------------------------------------------------% */
if (*(unsigned char *)bmat == 'G') {
igraphsecond_(&t3);
timing_1.tmvbx += t3 - t2;
}
/* %-----------------------------------------------------% */
/* | Compute the B-norm of the corrected residual r_{j}. | */
/* %-----------------------------------------------------% */
if (*(unsigned char *)bmat == 'G') {
rnorm1 = igraphddot_(n, &resid[1], &c__1, &workd[ipj], &c__1);
rnorm1 = sqrt((abs(rnorm1)));
} else if (*(unsigned char *)bmat == 'I') {
rnorm1 = igraphdnrm2_(n, &resid[1], &c__1);
}
if (msglvl > 0 && iter > 0) {
igraphivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: Iterati"
"ve refinement for Arnoldi residual");
if (msglvl > 2) {
xtemp[0] = *rnorm;
xtemp[1] = rnorm1;
igraphdvout_(&debug_1.logfil, &c__2, xtemp, &debug_1.ndigit, "_naitr: "
"iterative refinement ; rnorm and rnorm1 are");
}
}
/* %-----------------------------------------% */
/* | Determine if we need to perform another | */
/* | step of re-orthogonalization. | */
/* %-----------------------------------------% */
if (rnorm1 > *rnorm * .717f) {
/* %---------------------------------------% */
/* | No need for further refinement. | */
/* | The cosine of the angle between the | */
/* | corrected residual vector and the old | */
/* | residual vector is greater than 0.717 | */
/* | In other words the corrected residual | */
/* | and the old residual vector share an | */
/* | angle of less than arcCOS(0.717) | */
/* %---------------------------------------% */
*rnorm = rnorm1;
} else {
/* %-------------------------------------------% */
/* | Another step of iterative refinement step | */
/* | is required. NITREF is used by stat.h | */
/* %-------------------------------------------% */
++timing_1.nitref;
*rnorm = rnorm1;
++iter;
if (iter <= 1) {
goto L80;
}
/* %-------------------------------------------------% */
/* | Otherwise RESID is numerically in the span of V | */
/* %-------------------------------------------------% */
i__1 = *n;
for (jj = 1; jj <= i__1; ++jj) {
resid[jj] = 0.;
/* L95: */
}
*rnorm = 0.;
}
/* %----------------------------------------------% */
/* | Branch here directly if iterative refinement | */
/* | wasn't necessary or after at most NITER_REF | */
/* | steps of iterative refinement. | */
/* %----------------------------------------------% */
L100:
rstart = FALSE_;
orth2 = FALSE_;
igraphsecond_(&t5);
timing_1.titref += t5 - t4;
/* %------------------------------------% */
/* | STEP 6: Update j = j+1; Continue | */
/* %------------------------------------% */
++j;
if (j > *k + *np) {
igraphsecond_(&t1);
timing_1.tnaitr += t1 - t0;
*ido = 99;
i__1 = *k + *np - 1;
for (i__ = max(1,*k); i__ <= i__1; ++i__) {
/* %--------------------------------------------% */
/* | Check for splitting and deflation. | */
/* | Use a standard test as in the QR algorithm | */
/* | REFERENCE: LAPACK subroutine dlahqr | */
/* %--------------------------------------------% */
tst1 = (d__1 = h__[i__ + i__ * h_dim1], abs(d__1)) + (d__2 = h__[
i__ + 1 + (i__ + 1) * h_dim1], abs(d__2));
if (tst1 == 0.) {
i__2 = *k + *np;
tst1 = igraphdlanhs_("1", &i__2, &h__[h_offset], ldh, &workd[*n + 1]);
}
/* Computing MAX */
d__2 = ulp * tst1;
if ((d__1 = h__[i__ + 1 + i__ * h_dim1], abs(d__1)) <= max(d__2,
smlnum)) {
h__[i__ + 1 + i__ * h_dim1] = 0.;
}
/* L110: */
}
if (msglvl > 2) {
i__1 = *k + *np;
i__2 = *k + *np;
igraphdmout_(&debug_1.logfil, &i__1, &i__2, &h__[h_offset], ldh, &
debug_1.ndigit, "_naitr: Final upper Hessenberg matrix H"
" of order K+NP");
}
goto L9000;
}
/* %--------------------------------------------------------% */
/* | Loop back to extend the factorization by another step. | */
/* %--------------------------------------------------------% */
goto L1000;
/* %---------------------------------------------------------------% */
/* | | */
/* | E N D O F M A I N I T E R A T I O N L O O P | */
/* | | */
/* %---------------------------------------------------------------% */
L9000:
return 0;
/* %---------------% */
/* | End of igraphdnaitr | */
/* %---------------% */
} /* igraphdnaitr_ */
/* ----------------------------------------------------------------------- */
/* Subroutine */ int igraphdneupd_(logical *rvec, char *howmny, logical *select,
doublereal *dr, doublereal *di, doublereal *z__, integer *ldz,
doublereal *sigmar, doublereal *sigmai, doublereal *workev, char *
bmat, integer *n, char *which, integer *nev, doublereal *tol,
doublereal *resid, integer *ncv, doublereal *v, integer *ldv, integer
*iparam, integer *ipntr, doublereal *workd, doublereal *workl,
integer *lworkl, integer *info)
{
/* System generated locals */
integer v_dim1, v_offset, z_dim1, z_offset, i__1;
doublereal d__1, d__2;
/* Builtin functions */
double igraphpow_dd(doublereal *, doublereal *);
integer igraphs_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int igraphs_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer j, k, ih, jj, np;
static doublereal vl[1] /* was [1][1] */;
static integer ibd, ldh, ldq, iri;
static doublereal sep;
static integer irr, wri, wrr;
extern /* Subroutine */ int igraphdger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static integer mode;
static doublereal eps23;
static integer ierr;
static doublereal temp;
static integer iwev;
static char type__[6];
extern doublereal igraphdnrm2_(integer *, doublereal *, integer *);
static doublereal temp1;
extern /* Subroutine */ int igraphdscal_(integer *, doublereal *, doublereal *,
integer *);
static integer ihbds, iconj;
extern /* Subroutine */ int igraphdgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
static doublereal conds;
static logical reord;
extern /* Subroutine */ int igraphdcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static integer nconv;
extern /* Subroutine */ int igraphdtrmm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *), igraphdmout_(
integer *, integer *, integer *, doublereal *, integer *, integer
*, char *);
static integer iwork[1];
static doublereal rnorm;
static integer ritzi;
extern /* Subroutine */ int igraphdvout_(integer *, integer *, doublereal *,
integer *, char *), igraphivout_(integer *, integer *, integer *
, integer *, char *);
static integer ritzr;
extern /* Subroutine */ int igraphdgeqr2_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
extern doublereal igraphdlapy2_(doublereal *, doublereal *);
extern /* Subroutine */ int igraphdorm2r_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
extern doublereal igraphdlamch_(char *);
static integer iheigi, iheigr, bounds, invsub, iuptri, msglvl, outncv,
ishift, numcnv;
extern /* Subroutine */ int igraphdlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
igraphdlahqr_(logical *, logical *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *), igraphdlaset_(char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *), igraphdtrevc_(char *, char *, logical *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, integer *, integer *, doublereal *, integer *
), igraphdtrsen_(char *, char *, logical *, integer *, doublereal
*, integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
integer *, integer *, integer *), igraphdngets_(integer
*, char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %---------------% */
/* | Local Scalars | */
/* %---------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %---------------------% */
/* | Intrinsic Functions | */
/* %---------------------% */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* %------------------------% */
/* | Set default parameters | */
/* %------------------------% */
/* Parameter adjustments */
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--workd;
--resid;
--di;
--dr;
--workev;
--select;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--iparam;
--ipntr;
--workl;
/* Function Body */
msglvl = debug_1.mneupd;
mode = iparam[7];
nconv = iparam[5];
*info = 0;
/* %---------------------------------% */
/* | Get machine dependent constant. | */
/* %---------------------------------% */
eps23 = igraphdlamch_("Epsilon-Machine");
eps23 = igraphpow_dd(&eps23, &c_b3);
/* %--------------% */
/* | Quick return | */
/* %--------------% */
ierr = 0;
if (nconv <= 0) {
ierr = -14;
} else if (*n <= 0) {
ierr = -1;
} else if (*nev <= 0) {
ierr = -2;
} else if (*ncv <= *nev + 1 || *ncv > *n) {
ierr = -3;
} else if (igraphs_cmp(which, "LM", (ftnlen)2, (ftnlen)2) != 0 && igraphs_cmp(which,
"SM", (ftnlen)2, (ftnlen)2) != 0 && igraphs_cmp(which, "LR", (ftnlen)2, (ftnlen)2
) != 0 && igraphs_cmp(which, "SR", (ftnlen)2, (ftnlen)2) != 0
&& igraphs_cmp(which, "LI", (ftnlen)2, (ftnlen)2) != 0 && igraphs_cmp(which,
"SI", (ftnlen)2, (ftnlen)2) != 0) {
ierr = -5;
} else if (*(unsigned char *)bmat != 'I' && *(unsigned char *)bmat != 'G')
{
ierr = -6;
} else /* if(complicated condition) */ {
/* Computing 2nd power */
i__1 = *ncv;
if (*lworkl < i__1 * i__1 * 3 + *ncv * 6) {
ierr = -7;
} else if (*(unsigned char *)howmny != 'A' && *(unsigned char *)
howmny != 'P' && *(unsigned char *)howmny != 'S' && *rvec) {
ierr = -13;
} else if (*(unsigned char *)howmny == 'S') {
ierr = -12;
}
}
if (mode == 1 || mode == 2) {
igraphs_copy(type__, "REGULR", (ftnlen)6, (ftnlen)6);
} else if (mode == 3 && *sigmai == 0.) {
igraphs_copy(type__, "SHIFTI", (ftnlen)6, (ftnlen)6);
} else if (mode == 3) {
igraphs_copy(type__, "REALPT", (ftnlen)6, (ftnlen)6);
} else if (mode == 4) {
igraphs_copy(type__, "IMAGPT", (ftnlen)6, (ftnlen)6);
} else {
ierr = -10;
}
if (mode == 1 && *(unsigned char *)bmat == 'G') {
ierr = -11;
}
/* %------------% */
/* | Error Exit | */
/* %------------% */
if (ierr != 0) {
*info = ierr;
goto L9000;
}
/* %--------------------------------------------------------% */
/* | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | */
/* | etc... and the remaining workspace. | */
/* | Also update pointer to be used on output. | */
/* | Memory is laid out as follows: | */
/* | workl(1:ncv*ncv) := generated Hessenberg matrix | */
/* | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary | */
/* | parts of ritz values | */
/* | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds | */
/* %--------------------------------------------------------% */
/* %-----------------------------------------------------------% */
/* | The following is used and set by DNEUPD . | */
/* | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | */
/* | real part of the Ritz values. | */
/* | workl(ncv*ncv+4*ncv+1:ncv*ncv+5*ncv) := The untransformed | */
/* | imaginary part of the Ritz values. | */
/* | workl(ncv*ncv+5*ncv+1:ncv*ncv+6*ncv) := The untransformed | */
/* | error bounds of the Ritz values | */
/* | workl(ncv*ncv+6*ncv+1:2*ncv*ncv+6*ncv) := Holds the upper | */
/* | quasi-triangular matrix for H | */
/* | workl(2*ncv*ncv+6*ncv+1: 3*ncv*ncv+6*ncv) := Holds the | */
/* | associated matrix representation of the invariant | */
/* | subspace for H. | */
/* | GRAND total of NCV * ( 3 * NCV + 6 ) locations. | */
/* %-----------------------------------------------------------% */
ih = ipntr[5];
ritzr = ipntr[6];
ritzi = ipntr[7];
bounds = ipntr[8];
ldh = *ncv;
ldq = *ncv;
iheigr = bounds + ldh;
iheigi = iheigr + ldh;
ihbds = iheigi + ldh;
iuptri = ihbds + ldh;
invsub = iuptri + ldh * *ncv;
ipntr[9] = iheigr;
ipntr[10] = iheigi;
ipntr[11] = ihbds;
ipntr[12] = iuptri;
ipntr[13] = invsub;
wrr = 1;
wri = *ncv + 1;
iwev = wri + *ncv;
/* %-----------------------------------------% */
/* | irr points to the REAL part of the Ritz | */
/* | values computed by _neigh before | */
/* | exiting _naup2. | */
/* | iri points to the IMAGINARY part of the | */
/* | Ritz values computed by _neigh | */
/* | before exiting _naup2. | */
/* | ibd points to the Ritz estimates | */
/* | computed by _neigh before exiting | */
/* | _naup2. | */
/* %-----------------------------------------% */
irr = ipntr[14] + *ncv * *ncv;
iri = irr + *ncv;
ibd = iri + *ncv;
/* %------------------------------------% */
/* | RNORM is B-norm of the RESID(1:N). | */
/* %------------------------------------% */
rnorm = workl[ih + 2];
workl[ih + 2] = 0.;
if (msglvl > 2) {
igraphdvout_(&debug_1.logfil, ncv, &workl[irr], &debug_1.ndigit, "_neupd: "
"Real part of Ritz values passed in from _NAUPD.");
igraphdvout_(&debug_1.logfil, ncv, &workl[iri], &debug_1.ndigit, "_neupd: "
"Imag part of Ritz values passed in from _NAUPD.");
igraphdvout_(&debug_1.logfil, ncv, &workl[ibd], &debug_1.ndigit, "_neupd: "
"Ritz estimates passed in from _NAUPD.");
}
if (*rvec) {
reord = FALSE_;
/* %---------------------------------------------------% */
/* | Use the temporary bounds array to store indices | */
/* | These will be used to mark the select array later | */
/* %---------------------------------------------------% */
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
workl[bounds + j - 1] = (doublereal) j;
select[j] = FALSE_;
/* L10: */
}
/* %-------------------------------------% */
/* | Select the wanted Ritz values. | */
/* | Sort the Ritz values so that the | */
/* | wanted ones appear at the tailing | */
/* | NEV positions of workl(irr) and | */
/* | workl(iri). Move the corresponding | */
/* | error estimates in workl(bound) | */
/* | accordingly. | */
/* %-------------------------------------% */
np = *ncv - *nev;
ishift = 0;
igraphdngets_(&ishift, which, nev, &np, &workl[irr], &workl[iri], &workl[
bounds], &workl[1], &workl[np + 1]);
if (msglvl > 2) {
igraphdvout_(&debug_1.logfil, ncv, &workl[irr], &debug_1.ndigit, "_neu"
"pd: Real part of Ritz values after calling _NGETS.");
igraphdvout_(&debug_1.logfil, ncv, &workl[iri], &debug_1.ndigit, "_neu"
"pd: Imag part of Ritz values after calling _NGETS.");
igraphdvout_(&debug_1.logfil, ncv, &workl[bounds], &debug_1.ndigit,
"_neupd: Ritz value indices after calling _NGETS.");
}
/* %-----------------------------------------------------% */
/* | Record indices of the converged wanted Ritz values | */
/* | Mark the select array for possible reordering | */
/* %-----------------------------------------------------% */
numcnv = 0;
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
d__1 = eps23, d__2 = igraphdlapy2_(&workl[irr + *ncv - j], &workl[iri +
*ncv - j]);
temp1 = max(d__1,d__2);
jj = (integer) workl[bounds + *ncv - j];
if (numcnv < nconv && workl[ibd + jj - 1] <= *tol * temp1) {
select[jj] = TRUE_;
++numcnv;
if (jj > *nev) {
reord = TRUE_;
}
}
/* L11: */
}
/* %-----------------------------------------------------------% */
/* | Check the count (numcnv) of converged Ritz values with | */
/* | the number (nconv) reported by igraphdnaupd. If these two | */
/* | are different then there has probably been an error | */
/* | caused by incorrect passing of the igraphdnaupd data. | */
/* %-----------------------------------------------------------% */
if (msglvl > 2) {
igraphivout_(&debug_1.logfil, &c__1, &numcnv, &debug_1.ndigit, "_neupd"
": Number of specified eigenvalues");
igraphivout_(&debug_1.logfil, &c__1, &nconv, &debug_1.ndigit, "_neupd:"
" Number of \"converged\" eigenvalues");
}
if (numcnv != nconv) {
*info = -15;
goto L9000;
}
/* %-----------------------------------------------------------% */
/* | Call LAPACK routine dlahqr to compute the real Schur form | */
/* | of the upper Hessenberg matrix returned by DNAUPD . | */
/* | Make a copy of the upper Hessenberg matrix. | */
/* | Initialize the Schur vector matrix Q to the identity. | */
/* %-----------------------------------------------------------% */
i__1 = ldh * *ncv;
igraphdcopy_(&i__1, &workl[ih], &c__1, &workl[iuptri], &c__1);
igraphdlaset_("All", ncv, ncv, &c_b37, &c_b38, &workl[invsub], &ldq);
igraphdlahqr_(&c_true, &c_true, ncv, &c__1, ncv, &workl[iuptri], &ldh, &
workl[iheigr], &workl[iheigi], &c__1, ncv, &workl[invsub], &
ldq, &ierr);
igraphdcopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &c__1);
if (ierr != 0) {
*info = -8;
goto L9000;
}
if (msglvl > 1) {
igraphdvout_(&debug_1.logfil, ncv, &workl[iheigr], &debug_1.ndigit,
"_neupd: Real part of the eigenvalues of H");
igraphdvout_(&debug_1.logfil, ncv, &workl[iheigi], &debug_1.ndigit,
"_neupd: Imaginary part of the Eigenvalues of H");
igraphdvout_(&debug_1.logfil, ncv, &workl[ihbds], &debug_1.ndigit,
"_neupd: Last row of the Schur vector matrix");
if (msglvl > 3) {
igraphdmout_(&debug_1.logfil, ncv, ncv, &workl[iuptri], &ldh, &
debug_1.ndigit, "_neupd: The upper quasi-triangular "
"matrix ");
}
}
if (reord) {
/* %-----------------------------------------------------% */
/* | Reorder the computed upper quasi-triangular matrix. | */
/* %-----------------------------------------------------% */
igraphdtrsen_("None", "V", &select[1], ncv, &workl[iuptri], &ldh, &
workl[invsub], &ldq, &workl[iheigr], &workl[iheigi], &
nconv, &conds, &sep, &workl[ihbds], ncv, iwork, &c__1, &
ierr);
if (ierr == 1) {
*info = 1;
goto L9000;
}
if (msglvl > 2) {
igraphdvout_(&debug_1.logfil, ncv, &workl[iheigr], &debug_1.ndigit,
"_neupd: Real part of the eigenvalues of H--reordered");
igraphdvout_(&debug_1.logfil, ncv, &workl[iheigi], &debug_1.ndigit,
"_neupd: Imag part of the eigenvalues of H--reordered");
if (msglvl > 3) {
igraphdmout_(&debug_1.logfil, ncv, ncv, &workl[iuptri], &ldq, &
debug_1.ndigit, "_neupd: Quasi-triangular matrix"
" after re-ordering");
}
}
}
/* %---------------------------------------% */
/* | Copy the last row of the Schur vector | */
/* | into workl(ihbds). This will be used | */
/* | to compute the Ritz estimates of | */
/* | converged Ritz values. | */
/* %---------------------------------------% */
igraphdcopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &c__1);
/* %----------------------------------------------------% */
/* | Place the computed eigenvalues of H into DR and DI | */
/* | if a spectral transformation was not used. | */
/* %----------------------------------------------------% */
if (igraphs_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) {
igraphdcopy_(&nconv, &workl[iheigr], &c__1, &dr[1], &c__1);
igraphdcopy_(&nconv, &workl[iheigi], &c__1, &di[1], &c__1);
}
/* %----------------------------------------------------------% */
/* | Compute the QR factorization of the matrix representing | */
/* | the wanted invariant subspace located in the first NCONV | */
/* | columns of workl(invsub,ldq). | */
/* %----------------------------------------------------------% */
igraphdgeqr2_(ncv, &nconv, &workl[invsub], &ldq, &workev[1], &workev[*ncv +
1], &ierr);
/* %---------------------------------------------------------% */
/* | * Postmultiply V by Q using dorm2r . | */
/* | * Copy the first NCONV columns of VQ into Z. | */
/* | * Postmultiply Z by R. | */
/* | The N by NCONV matrix Z is now a matrix representation | */
/* | of the approximate invariant subspace associated with | */
/* | the Ritz values in workl(iheigr) and workl(iheigi) | */
/* | The first NCONV columns of V are now approximate Schur | */
/* | vectors associated with the real upper quasi-triangular | */
/* | matrix of order NCONV in workl(iuptri) | */
/* %---------------------------------------------------------% */
igraphdorm2r_("Right", "Notranspose", n, ncv, &nconv, &workl[invsub], &ldq,
&workev[1], &v[v_offset], ldv, &workd[*n + 1], &ierr);
igraphdlacpy_("All", n, &nconv, &v[v_offset], ldv, &z__[z_offset], ldz);
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
/* %---------------------------------------------------% */
/* | Perform both a column and row scaling if the | */
/* | diagonal element of workl(invsub,ldq) is negative | */
/* | I'm lazy and don't take advantage of the upper | */
/* | quasi-triangular form of workl(iuptri,ldq) | */
/* | Note that since Q is orthogonal, R is a diagonal | */
/* | matrix consisting of plus or minus ones | */
/* %---------------------------------------------------% */
if (workl[invsub + (j - 1) * ldq + j - 1] < 0.) {
igraphdscal_(&nconv, &c_b64, &workl[iuptri + j - 1], &ldq);
igraphdscal_(&nconv, &c_b64, &workl[iuptri + (j - 1) * ldq], &c__1);
}
/* L20: */
}
if (*(unsigned char *)howmny == 'A') {
/* %--------------------------------------------% */
/* | Compute the NCONV wanted eigenvectors of T | */
/* | located in workl(iuptri,ldq). | */
/* %--------------------------------------------% */
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
if (j <= nconv) {
select[j] = TRUE_;
} else {
select[j] = FALSE_;
}
/* L30: */
}
igraphdtrevc_("Right", "Select", &select[1], ncv, &workl[iuptri], &ldq,
vl, &c__1, &workl[invsub], &ldq, ncv, &outncv, &workev[1],
&ierr);
if (ierr != 0) {
*info = -9;
goto L9000;
}
/* %------------------------------------------------% */
/* | Scale the returning eigenvectors so that their | */
/* | Euclidean norms are all one. LAPACK subroutine | */
/* | igraphdtrevc returns each eigenvector normalized so | */
/* | that the element of largest magnitude has | */
/* | magnitude 1; | */
/* %------------------------------------------------% */
iconj = 0;
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
if (workl[iheigi + j - 1] == 0.) {
/* %----------------------% */
/* | real eigenvalue case | */
/* %----------------------% */
temp = igraphdnrm2_(ncv, &workl[invsub + (j - 1) * ldq], &c__1);
d__1 = 1. / temp;
igraphdscal_(ncv, &d__1, &workl[invsub + (j - 1) * ldq], &c__1);
} else {
/* %-------------------------------------------% */
/* | Complex conjugate pair case. Note that | */
/* | since the real and imaginary part of | */
/* | the eigenvector are stored in consecutive | */
/* | columns, we further normalize by the | */
/* | square root of two. | */
/* %-------------------------------------------% */
if (iconj == 0) {
d__1 = igraphdnrm2_(ncv, &workl[invsub + (j - 1) * ldq], &
c__1);
d__2 = igraphdnrm2_(ncv, &workl[invsub + j * ldq], &c__1);
temp = igraphdlapy2_(&d__1, &d__2);
d__1 = 1. / temp;
igraphdscal_(ncv, &d__1, &workl[invsub + (j - 1) * ldq], &
c__1);
d__1 = 1. / temp;
igraphdscal_(ncv, &d__1, &workl[invsub + j * ldq], &c__1);
iconj = 1;
} else {
iconj = 0;
}
}
/* L40: */
}
igraphdgemv_("T", ncv, &nconv, &c_b38, &workl[invsub], &ldq, &workl[
ihbds], &c__1, &c_b37, &workev[1], &c__1);
iconj = 0;
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
if (workl[iheigi + j - 1] != 0.) {
/* %-------------------------------------------% */
/* | Complex conjugate pair case. Note that | */
/* | since the real and imaginary part of | */
/* | the eigenvector are stored in consecutive | */
/* %-------------------------------------------% */
if (iconj == 0) {
workev[j] = igraphdlapy2_(&workev[j], &workev[j + 1]);
workev[j + 1] = workev[j];
iconj = 1;
} else {
iconj = 0;
}
}
/* L45: */
}
if (msglvl > 2) {
igraphdcopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &
c__1);
igraphdvout_(&debug_1.logfil, ncv, &workl[ihbds], &debug_1.ndigit,
"_neupd: Last row of the eigenvector matrix for T");
if (msglvl > 3) {
igraphdmout_(&debug_1.logfil, ncv, ncv, &workl[invsub], &ldq, &
debug_1.ndigit, "_neupd: The eigenvector matrix "
"for T");
}
}
/* %---------------------------------------% */
/* | Copy Ritz estimates into workl(ihbds) | */
/* %---------------------------------------% */
igraphdcopy_(&nconv, &workev[1], &c__1, &workl[ihbds], &c__1);
/* %---------------------------------------------------------% */
/* | Compute the QR factorization of the eigenvector matrix | */
/* | associated with leading portion of T in the first NCONV | */
/* | columns of workl(invsub,ldq). | */
/* %---------------------------------------------------------% */
igraphdgeqr2_(ncv, &nconv, &workl[invsub], &ldq, &workev[1], &workev[*
ncv + 1], &ierr);
/* %----------------------------------------------% */
/* | * Postmultiply Z by Q. | */
/* | * Postmultiply Z by R. | */
/* | The N by NCONV matrix Z is now contains the | */
/* | Ritz vectors associated with the Ritz values | */
/* | in workl(iheigr) and workl(iheigi). | */
/* %----------------------------------------------% */
igraphdorm2r_("Right", "Notranspose", n, ncv, &nconv, &workl[invsub], &
ldq, &workev[1], &z__[z_offset], ldz, &workd[*n + 1], &
ierr);
igraphdtrmm_("Right", "Upper", "No transpose", "Non-unit", n, &nconv, &
c_b38, &workl[invsub], &ldq, &z__[z_offset], ldz);
}
} else {
/* %------------------------------------------------------% */
/* | An approximate invariant subspace is not needed. | */
/* | Place the Ritz values computed DNAUPD into DR and DI | */
/* %------------------------------------------------------% */
igraphdcopy_(&nconv, &workl[ritzr], &c__1, &dr[1], &c__1);
igraphdcopy_(&nconv, &workl[ritzi], &c__1, &di[1], &c__1);
igraphdcopy_(&nconv, &workl[ritzr], &c__1, &workl[iheigr], &c__1);
igraphdcopy_(&nconv, &workl[ritzi], &c__1, &workl[iheigi], &c__1);
igraphdcopy_(&nconv, &workl[bounds], &c__1, &workl[ihbds], &c__1);
}
/* %------------------------------------------------% */
/* | Transform the Ritz values and possibly vectors | */
/* | and corresponding error bounds of OP to those | */
/* | of A*x = lambda*B*x. | */
/* %------------------------------------------------% */
if (igraphs_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) {
if (*rvec) {
igraphdscal_(ncv, &rnorm, &workl[ihbds], &c__1);
}
} else {
/* %---------------------------------------% */
/* | A spectral transformation was used. | */
/* | * Determine the Ritz estimates of the | */
/* | Ritz values in the original system. | */
/* %---------------------------------------% */
if (igraphs_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) {
if (*rvec) {
igraphdscal_(ncv, &rnorm, &workl[ihbds], &c__1);
}
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
temp = igraphdlapy2_(&workl[iheigr + k - 1], &workl[iheigi + k - 1])
;
workl[ihbds + k - 1] = (d__1 = workl[ihbds + k - 1], abs(d__1)
) / temp / temp;
/* L50: */
}
} else if (igraphs_cmp(type__, "REALPT", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
/* L60: */
}
} else if (igraphs_cmp(type__, "IMAGPT", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
/* L70: */
}
}
/* %-----------------------------------------------------------% */
/* | * Transform the Ritz values back to the original system. | */
/* | For TYPE = 'SHIFTI' the transformation is | */
/* | lambda = 1/theta + sigma | */
/* | For TYPE = 'REALPT' or 'IMAGPT' the user must from | */
/* | Rayleigh quotients or a projection. See remark 3 above.| */
/* | NOTES: | */
/* | *The Ritz vectors are not affected by the transformation. | */
/* %-----------------------------------------------------------% */
if (igraphs_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
temp = igraphdlapy2_(&workl[iheigr + k - 1], &workl[iheigi + k - 1])
;
workl[iheigr + k - 1] = workl[iheigr + k - 1] / temp / temp +
*sigmar;
workl[iheigi + k - 1] = -workl[iheigi + k - 1] / temp / temp
+ *sigmai;
/* L80: */
}
igraphdcopy_(&nconv, &workl[iheigr], &c__1, &dr[1], &c__1);
igraphdcopy_(&nconv, &workl[iheigi], &c__1, &di[1], &c__1);
} else if (igraphs_cmp(type__, "REALPT", (ftnlen)6, (ftnlen)6) == 0 ||
igraphs_cmp(type__, "IMAGPT", (ftnlen)6, (ftnlen)6) == 0) {
igraphdcopy_(&nconv, &workl[iheigr], &c__1, &dr[1], &c__1);
igraphdcopy_(&nconv, &workl[iheigi], &c__1, &di[1], &c__1);
}
}
if (igraphs_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0 && msglvl > 1) {
igraphdvout_(&debug_1.logfil, &nconv, &dr[1], &debug_1.ndigit, "_neupd: Un"
"transformed real part of the Ritz valuess.");
igraphdvout_(&debug_1.logfil, &nconv, &di[1], &debug_1.ndigit, "_neupd: Un"
"transformed imag part of the Ritz valuess.");
igraphdvout_(&debug_1.logfil, &nconv, &workl[ihbds], &debug_1.ndigit, "_ne"
"upd: Ritz estimates of untransformed Ritz values.");
} else if (igraphs_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0 && msglvl >
1) {
igraphdvout_(&debug_1.logfil, &nconv, &dr[1], &debug_1.ndigit, "_neupd: Re"
"al parts of converged Ritz values.");
igraphdvout_(&debug_1.logfil, &nconv, &di[1], &debug_1.ndigit, "_neupd: Im"
"ag parts of converged Ritz values.");
igraphdvout_(&debug_1.logfil, &nconv, &workl[ihbds], &debug_1.ndigit, "_ne"
"upd: Associated Ritz estimates.");
}
/* %-------------------------------------------------% */
/* | Eigenvector Purification step. Formally perform | */
/* | one of inverse subspace iteration. Only used | */
/* | for MODE = 2. | */
/* %-------------------------------------------------% */
if (*rvec && *(unsigned char *)howmny == 'A' && igraphs_cmp(type__, "SHIFTI"
, (ftnlen)6, (ftnlen)6) == 0) {
/* %------------------------------------------------% */
/* | Purify the computed Ritz vectors by adding a | */
/* | little bit of the residual vector: | */
/* | T | */
/* | resid(:)*( e s ) / theta | */
/* | NCV | */
/* | where H s = s theta. Remember that when theta | */
/* | has nonzero imaginary part, the corresponding | */
/* | Ritz vector is stored across two columns of Z. | */
/* %------------------------------------------------% */
iconj = 0;
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
if (workl[iheigi + j - 1] == 0.) {
workev[j] = workl[invsub + (j - 1) * ldq + *ncv - 1] / workl[
iheigr + j - 1];
} else if (iconj == 0) {
temp = igraphdlapy2_(&workl[iheigr + j - 1], &workl[iheigi + j - 1])
;
workev[j] = (workl[invsub + (j - 1) * ldq + *ncv - 1] * workl[
iheigr + j - 1] + workl[invsub + j * ldq + *ncv - 1] *
workl[iheigi + j - 1]) / temp / temp;
workev[j + 1] = (workl[invsub + j * ldq + *ncv - 1] * workl[
iheigr + j - 1] - workl[invsub + (j - 1) * ldq + *ncv
- 1] * workl[iheigi + j - 1]) / temp / temp;
iconj = 1;
} else {
iconj = 0;
}
/* L110: */
}
/* %---------------------------------------% */
/* | Perform a rank one update to Z and | */
/* | purify all the Ritz vectors together. | */
/* %---------------------------------------% */
igraphdger_(n, &nconv, &c_b38, &resid[1], &c__1, &workev[1], &c__1, &z__[
z_offset], ldz);
}
L9000:
return 0;
/* %---------------% */
/* | End of DNEUPD | */
/* %---------------% */
} /* dneupd_ */
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 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 igraphdstein_(integer *n, doublereal *d__, doublereal *e,
integer *m, doublereal *w, integer *iblock, integer *isplit,
doublereal *z__, integer *ldz, doublereal *work, integer *iwork,
integer *ifail, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3, d__4, d__5;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, b1, j1, bn;
doublereal xj, scl, eps, sep, nrm, tol;
integer its;
doublereal xjm, ztr, eps1;
integer jblk, nblk;
extern doublereal igraphddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
integer jmax;
extern doublereal igraphdnrm2_(integer *, doublereal *, integer *);
extern /* Subroutine */ int igraphdscal_(integer *, doublereal *, doublereal *,
integer *);
integer iseed[4], gpind, iinfo;
extern doublereal igraphdasum_(integer *, doublereal *, integer *);
extern /* Subroutine */ int igraphdcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), igraphdaxpy_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
doublereal ortol;
integer indrv1, indrv2, indrv3, indrv4, indrv5;
extern doublereal igraphdlamch_(char *);
extern /* Subroutine */ int igraphdlagtf_(integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *
, integer *);
extern integer igraphidamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int igraphxerbla_(char *, integer *, ftnlen), igraphdlagts_(
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *, integer *);
integer nrmchk;
extern /* Subroutine */ int igraphdlarnv_(integer *, integer *, integer *,
doublereal *);
integer blksiz;
doublereal onenrm, dtpcrt, pertol;
/* -- 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;
--w;
--iblock;
--isplit;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--iwork;
--ifail;
/* Function Body */
*info = 0;
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
ifail[i__] = 0;
/* L10: */
}
if (*n < 0) {
*info = -1;
} else if (*m < 0 || *m > *n) {
*info = -4;
} else if (*ldz < max(1,*n)) {
*info = -9;
} else {
i__1 = *m;
for (j = 2; j <= i__1; ++j) {
if (iblock[j] < iblock[j - 1]) {
*info = -6;
goto L30;
}
if (iblock[j] == iblock[j - 1] && w[j] < w[j - 1]) {
*info = -5;
goto L30;
}
/* L20: */
}
L30:
;
}
if (*info != 0) {
i__1 = -(*info);
igraphxerbla_("DSTEIN", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *m == 0) {
return 0;
} else if (*n == 1) {
z__[z_dim1 + 1] = 1.;
return 0;
}
/* Get machine constants. */
eps = igraphdlamch_("Precision");
/* Initialize seed for random number generator DLARNV. */
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = 1;
/* L40: */
}
/* Initialize pointers. */
indrv1 = 0;
indrv2 = indrv1 + *n;
indrv3 = indrv2 + *n;
indrv4 = indrv3 + *n;
indrv5 = indrv4 + *n;
/* Compute eigenvectors of matrix blocks. */
j1 = 1;
i__1 = iblock[*m];
for (nblk = 1; nblk <= i__1; ++nblk) {
/* Find starting and ending indices of block nblk. */
if (nblk == 1) {
b1 = 1;
} else {
b1 = isplit[nblk - 1] + 1;
}
bn = isplit[nblk];
blksiz = bn - b1 + 1;
if (blksiz == 1) {
goto L60;
}
gpind = b1;
/* Compute reorthogonalization criterion and stopping criterion. */
onenrm = (d__1 = d__[b1], abs(d__1)) + (d__2 = e[b1], abs(d__2));
/* Computing MAX */
d__3 = onenrm, d__4 = (d__1 = d__[bn], abs(d__1)) + (d__2 = e[bn - 1],
abs(d__2));
onenrm = max(d__3,d__4);
i__2 = bn - 1;
for (i__ = b1 + 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__4 = onenrm, d__5 = (d__1 = d__[i__], abs(d__1)) + (d__2 = e[
i__ - 1], abs(d__2)) + (d__3 = e[i__], abs(d__3));
onenrm = max(d__4,d__5);
/* L50: */
}
ortol = onenrm * .001;
dtpcrt = sqrt(.1 / blksiz);
/* Loop through eigenvalues of block nblk. */
L60:
jblk = 0;
i__2 = *m;
for (j = j1; j <= i__2; ++j) {
if (iblock[j] != nblk) {
j1 = j;
goto L160;
}
++jblk;
xj = w[j];
/* Skip all the work if the block size is one. */
if (blksiz == 1) {
work[indrv1 + 1] = 1.;
goto L120;
}
/* If eigenvalues j and j-1 are too close, add a relatively
small perturbation. */
if (jblk > 1) {
eps1 = (d__1 = eps * xj, abs(d__1));
pertol = eps1 * 10.;
sep = xj - xjm;
if (sep < pertol) {
xj = xjm + pertol;
}
}
its = 0;
nrmchk = 0;
/* Get random starting vector. */
igraphdlarnv_(&c__2, iseed, &blksiz, &work[indrv1 + 1]);
/* Copy the matrix T so it won't be destroyed in factorization. */
igraphdcopy_(&blksiz, &d__[b1], &c__1, &work[indrv4 + 1], &c__1);
i__3 = blksiz - 1;
igraphdcopy_(&i__3, &e[b1], &c__1, &work[indrv2 + 2], &c__1);
i__3 = blksiz - 1;
igraphdcopy_(&i__3, &e[b1], &c__1, &work[indrv3 + 1], &c__1);
/* Compute LU factors with partial pivoting ( PT = LU ) */
tol = 0.;
igraphdlagtf_(&blksiz, &work[indrv4 + 1], &xj, &work[indrv2 + 2], &work[
indrv3 + 1], &tol, &work[indrv5 + 1], &iwork[1], &iinfo);
/* Update iteration count. */
L70:
++its;
if (its > 5) {
goto L100;
}
/* Normalize and scale the righthand side vector Pb.
Computing MAX */
d__2 = eps, d__3 = (d__1 = work[indrv4 + blksiz], abs(d__1));
scl = blksiz * onenrm * max(d__2,d__3) / igraphdasum_(&blksiz, &work[
indrv1 + 1], &c__1);
igraphdscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1);
/* Solve the system LU = Pb. */
igraphdlagts_(&c_n1, &blksiz, &work[indrv4 + 1], &work[indrv2 + 2], &
work[indrv3 + 1], &work[indrv5 + 1], &iwork[1], &work[
indrv1 + 1], &tol, &iinfo);
/* Reorthogonalize by modified Gram-Schmidt if eigenvalues are
close enough. */
if (jblk == 1) {
goto L90;
}
if ((d__1 = xj - xjm, abs(d__1)) > ortol) {
gpind = j;
}
if (gpind != j) {
i__3 = j - 1;
for (i__ = gpind; i__ <= i__3; ++i__) {
ztr = -igraphddot_(&blksiz, &work[indrv1 + 1], &c__1, &z__[b1 +
i__ * z_dim1], &c__1);
igraphdaxpy_(&blksiz, &ztr, &z__[b1 + i__ * z_dim1], &c__1, &
work[indrv1 + 1], &c__1);
/* L80: */
}
}
/* Check the infinity norm of the iterate. */
L90:
jmax = igraphidamax_(&blksiz, &work[indrv1 + 1], &c__1);
nrm = (d__1 = work[indrv1 + jmax], abs(d__1));
/* Continue for additional iterations after norm reaches
stopping criterion. */
if (nrm < dtpcrt) {
goto L70;
}
++nrmchk;
if (nrmchk < 3) {
goto L70;
}
goto L110;
/* If stopping criterion was not satisfied, update info and
store eigenvector number in array ifail. */
L100:
++(*info);
ifail[*info] = j;
/* Accept iterate as jth eigenvector. */
L110:
scl = 1. / igraphdnrm2_(&blksiz, &work[indrv1 + 1], &c__1);
jmax = igraphidamax_(&blksiz, &work[indrv1 + 1], &c__1);
if (work[indrv1 + jmax] < 0.) {
scl = -scl;
}
igraphdscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1);
L120:
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
z__[i__ + j * z_dim1] = 0.;
/* L130: */
}
i__3 = blksiz;
for (i__ = 1; i__ <= i__3; ++i__) {
z__[b1 + i__ - 1 + j * z_dim1] = work[indrv1 + i__];
/* L140: */
}
/* Save the shift to check eigenvalue spacing at next
iteration. */
xjm = xj;
/* L150: */
}
L160:
;
}
return 0;
/* End of DSTEIN */
} /* igraphdstein_ */
/* Subroutine */ int igraphdgetf2_(integer *m, integer *n, doublereal *a, integer *
lda, integer *ipiv, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
/* Local variables */
integer i__, j, jp;
extern /* Subroutine */ int igraphdger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *), igraphdscal_(integer *, doublereal *, doublereal *, integer
*);
doublereal sfmin;
extern /* Subroutine */ int igraphdswap_(integer *, doublereal *, integer *,
doublereal *, integer *);
extern doublereal igraphdlamch_(char *);
extern integer igraphidamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int igraphxerbla_(char *, integer *, ftnlen);
/* -- 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
=======
DGETF2 computes an LU factorization of a general m-by-n matrix A
using partial pivoting with row interchanges.
The factorization has the form
A = P * L * U
where P is a permutation matrix, L is lower triangular with unit
diagonal elements (lower trapezoidal if m > n), and U is upper
triangular (upper trapezoidal if m < n).
This is the right-looking Level 2 BLAS version of the algorithm.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the m by n matrix to be factored.
On exit, the factors L and U from the factorization
A = P*L*U; the unit diagonal elements of L are not stored.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
IPIV (output) INTEGER array, dimension (min(M,N))
The pivot indices; for 1 <= i <= min(M,N), row i of the
matrix was interchanged with row IPIV(i).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -k, the k-th argument had an illegal value
> 0: if INFO = k, U(k,k) is exactly zero. The factorization
has been completed, but the factor U is exactly
singular, and division by zero will occur if it is used
to solve a system of equations.
=====================================================================
Test the input parameters.
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
igraphxerbla_("DGETF2", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Compute machine safe minimum */
sfmin = igraphdlamch_("S");
i__1 = min(*m,*n);
for (j = 1; j <= i__1; ++j) {
/* Find pivot and test for singularity. */
i__2 = *m - j + 1;
jp = j - 1 + igraphidamax_(&i__2, &a[j + j * a_dim1], &c__1);
ipiv[j] = jp;
if (a[jp + j * a_dim1] != 0.) {
/* Apply the interchange to columns 1:N. */
if (jp != j) {
igraphdswap_(n, &a[j + a_dim1], lda, &a[jp + a_dim1], lda);
}
/* Compute elements J+1:M of J-th column. */
if (j < *m) {
if ((d__1 = a[j + j * a_dim1], abs(d__1)) >= sfmin) {
i__2 = *m - j;
d__1 = 1. / a[j + j * a_dim1];
igraphdscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1);
} else {
i__2 = *m - j;
for (i__ = 1; i__ <= i__2; ++i__) {
a[j + i__ + j * a_dim1] /= a[j + j * a_dim1];
/* L20: */
}
}
}
} else if (*info == 0) {
*info = j;
}
if (j < min(*m,*n)) {
/* Update trailing submatrix. */
i__2 = *m - j;
i__3 = *n - j;
igraphdger_(&i__2, &i__3, &c_b8, &a[j + 1 + j * a_dim1], &c__1, &a[j + (
j + 1) * a_dim1], lda, &a[j + 1 + (j + 1) * a_dim1], lda);
}
/* L10: */
}
return 0;
/* End of DGETF2 */
} /* igraphdgetf2_ */
/* ----------------------------------------------------------------------- */
/* Subroutine */ int igraphdseupd_(logical *rvec, char *howmny, logical *
select, doublereal *d__, doublereal *z__, integer *ldz, doublereal *
sigma, char *bmat, integer *n, char *which, integer *nev, doublereal *
tol, doublereal *resid, integer *ncv, doublereal *v, integer *ldv,
integer *iparam, integer *ipntr, doublereal *workd, doublereal *workl,
integer *lworkl, integer *info)
{
/* System generated locals */
integer v_dim1, v_offset, z_dim1, z_offset, i__1;
doublereal d__1, d__2, d__3;
/* Builtin functions */
integer igraphs_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int igraphs_copy(char *, char *, ftnlen, ftnlen);
double igraphpow_dd(doublereal *, doublereal *);
/* Local variables */
static integer j, k, ih, jj, iq, np, iw;
extern /* Subroutine */ int igraphdger_(integer *, integer *, doublereal *
, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static integer ibd, ihb, ihd, ldh;
extern doublereal igraphdnrm2_(integer *, doublereal *, integer *);
static integer ldq, irz;
extern /* Subroutine */ int igraphdscal_(integer *, doublereal *,
doublereal *, integer *), igraphdcopy_(integer *, doublereal *,
integer *, doublereal *, integer *), igraphdvout_(integer *,
integer *, doublereal *, integer *, char *), igraphivout_(
integer *, integer *, integer *, integer *, char *),
igraphdgeqr2_(integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
static integer mode;
static doublereal eps23;
extern /* Subroutine */ int igraphdorm2r_(char *, char *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
static integer ierr;
static doublereal temp;
static integer next;
static char type__[6];
extern doublereal igraphdlamch_(char *);
static integer ritz;
extern /* Subroutine */ int igraphdlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
igraphdsgets_(integer *, char *, integer *, integer *, doublereal
*, doublereal *, doublereal *);
static doublereal temp1;
extern /* Subroutine */ int igraphdsteqr_(char *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *), igraphdsesrt_(char *, logical *, integer *, doublereal *,
integer *, doublereal *, integer *), igraphdsortr_(char *
, logical *, integer *, doublereal *, doublereal *);
static logical reord;
static integer nconv;
static doublereal rnorm, bnorm2;
static integer bounds, msglvl, ishift, numcnv, leftptr, rghtptr;
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %---------------% */
/* | Local Scalars | */
/* %---------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %---------------------% */
/* | Intrinsic Functions | */
/* %---------------------% */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* %------------------------% */
/* | Set default parameters | */
/* %------------------------% */
/* Parameter adjustments */
--workd;
--resid;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--d__;
--select;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--iparam;
--ipntr;
--workl;
/* Function Body */
msglvl = debug_1.mseupd;
mode = iparam[7];
nconv = iparam[5];
*info = 0;
/* %--------------% */
/* | Quick return | */
/* %--------------% */
if (nconv == 0) {
goto L9000;
}
ierr = 0;
if (nconv <= 0) {
ierr = -14;
}
if (*n <= 0) {
ierr = -1;
}
if (*nev <= 0) {
ierr = -2;
}
if (*ncv <= *nev || *ncv > *n) {
ierr = -3;
}
if (igraphs_cmp(which, "LM", (ftnlen)2, (ftnlen)2) != 0 && igraphs_cmp(which, "SM", (
ftnlen)2, (ftnlen)2) != 0 && igraphs_cmp(which, "LA", (ftnlen)2, (
ftnlen)2) != 0 && igraphs_cmp(which, "SA", (ftnlen)2, (ftnlen)2) != 0 &&
igraphs_cmp(which, "BE", (ftnlen)2, (ftnlen)2) != 0) {
ierr = -5;
}
if (*(unsigned char *)bmat != 'I' && *(unsigned char *)bmat != 'G') {
ierr = -6;
}
if (*(unsigned char *)howmny != 'A' && *(unsigned char *)howmny != 'P' &&
*(unsigned char *)howmny != 'S' && *rvec) {
ierr = -15;
}
if (*rvec && *(unsigned char *)howmny == 'S') {
ierr = -16;
}
/* Computing 2nd power */
i__1 = *ncv;
if (*rvec && *lworkl < i__1 * i__1 + (*ncv << 3)) {
ierr = -7;
}
if (mode == 1 || mode == 2) {
igraphs_copy(type__, "REGULR", (ftnlen)6, (ftnlen)6);
} else if (mode == 3) {
igraphs_copy(type__, "SHIFTI", (ftnlen)6, (ftnlen)6);
} else if (mode == 4) {
igraphs_copy(type__, "BUCKLE", (ftnlen)6, (ftnlen)6);
} else if (mode == 5) {
igraphs_copy(type__, "CAYLEY", (ftnlen)6, (ftnlen)6);
} else {
ierr = -10;
}
if (mode == 1 && *(unsigned char *)bmat == 'G') {
ierr = -11;
}
if (*nev == 1 && igraphs_cmp(which, "BE", (ftnlen)2, (ftnlen)2) == 0) {
ierr = -12;
}
/* %------------% */
/* | Error Exit | */
/* %------------% */
if (ierr != 0) {
*info = ierr;
goto L9000;
}
/* %-------------------------------------------------------% */
/* | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | */
/* | etc... and the remaining workspace. | */
/* | Also update pointer to be used on output. | */
/* | Memory is laid out as follows: | */
/* | workl(1:2*ncv) := generated tridiagonal matrix H | */
/* | The subdiagonal is stored in workl(2:ncv). | */
/* | The dead spot is workl(1) but upon exiting | */
/* | dsaupd stores the B-norm of the last residual | */
/* | vector in workl(1). We use this !!! | */
/* | workl(2*ncv+1:2*ncv+ncv) := ritz values | */
/* | The wanted values are in the first NCONV spots. | */
/* | workl(3*ncv+1:3*ncv+ncv) := computed Ritz estimates | */
/* | The wanted values are in the first NCONV spots. | */
/* | NOTE: workl(1:4*ncv) is set by dsaupd and is not | */
/* | modified by dseupd . | */
/* %-------------------------------------------------------% */
/* %-------------------------------------------------------% */
/* | The following is used and set by dseupd . | */
/* | workl(4*ncv+1:4*ncv+ncv) := used as workspace during | */
/* | computation of the eigenvectors of H. Stores | */
/* | the diagonal of H. Upon EXIT contains the NCV | */
/* | Ritz values of the original system. The first | */
/* | NCONV spots have the wanted values. If MODE = | */
/* | 1 or 2 then will equal workl(2*ncv+1:3*ncv). | */
/* | workl(5*ncv+1:5*ncv+ncv) := used as workspace during | */
/* | computation of the eigenvectors of H. Stores | */
/* | the subdiagonal of H. Upon EXIT contains the | */
/* | NCV corresponding Ritz estimates of the | */
/* | original system. The first NCONV spots have the | */
/* | wanted values. If MODE = 1,2 then will equal | */
/* | workl(3*ncv+1:4*ncv). | */
/* | workl(6*ncv+1:6*ncv+ncv*ncv) := orthogonal Q that is | */
/* | the eigenvector matrix for H as returned by | */
/* | dsteqr . Not referenced if RVEC = .False. | */
/* | Ordering follows that of workl(4*ncv+1:5*ncv) | */
/* | workl(6*ncv+ncv*ncv+1:6*ncv+ncv*ncv+2*ncv) := | */
/* | Workspace. Needed by dsteqr and by dseupd . | */
/* | GRAND total of NCV*(NCV+8) locations. | */
/* %-------------------------------------------------------% */
ih = ipntr[5];
ritz = ipntr[6];
bounds = ipntr[7];
ldh = *ncv;
ldq = *ncv;
ihd = bounds + ldh;
ihb = ihd + ldh;
iq = ihb + ldh;
iw = iq + ldh * *ncv;
next = iw + (*ncv << 1);
ipntr[4] = next;
ipntr[8] = ihd;
ipntr[9] = ihb;
ipntr[10] = iq;
/* %----------------------------------------% */
/* | irz points to the Ritz values computed | */
/* | by _seigt before exiting _saup2. | */
/* | ibd points to the Ritz estimates | */
/* | computed by _seigt before exiting | */
/* | _saup2. | */
/* %----------------------------------------% */
irz = ipntr[11] + *ncv;
ibd = irz + *ncv;
/* %---------------------------------% */
/* | Set machine dependent constant. | */
/* %---------------------------------% */
eps23 = igraphdlamch_("Epsilon-Machine");
eps23 = igraphpow_dd(&eps23, &c_b21);
/* %---------------------------------------% */
/* | RNORM is B-norm of the RESID(1:N). | */
/* | BNORM2 is the 2 norm of B*RESID(1:N). | */
/* | Upon exit of dsaupd WORKD(1:N) has | */
/* | B*RESID(1:N). | */
/* %---------------------------------------% */
rnorm = workl[ih];
if (*(unsigned char *)bmat == 'I') {
bnorm2 = rnorm;
} else if (*(unsigned char *)bmat == 'G') {
bnorm2 = igraphdnrm2_(n, &workd[1], &c__1);
}
if (msglvl > 2) {
igraphdvout_(&debug_1.logfil, ncv, &workl[irz], &debug_1.ndigit,
"_seupd: Ritz values passed in from _SAUPD.");
igraphdvout_(&debug_1.logfil, ncv, &workl[ibd], &debug_1.ndigit,
"_seupd: Ritz estimates passed in from _SAUPD.");
}
if (*rvec) {
reord = FALSE_;
/* %---------------------------------------------------% */
/* | Use the temporary bounds array to store indices | */
/* | These will be used to mark the select array later | */
/* %---------------------------------------------------% */
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
workl[bounds + j - 1] = (doublereal) j;
select[j] = FALSE_;
/* L10: */
}
/* %-------------------------------------% */
/* | Select the wanted Ritz values. | */
/* | Sort the Ritz values so that the | */
/* | wanted ones appear at the tailing | */
/* | NEV positions of workl(irr) and | */
/* | workl(iri). Move the corresponding | */
/* | error estimates in workl(bound) | */
/* | accordingly. | */
/* %-------------------------------------% */
np = *ncv - *nev;
ishift = 0;
igraphdsgets_(&ishift, which, nev, &np, &workl[irz], &workl[bounds], &
workl[1]);
if (msglvl > 2) {
igraphdvout_(&debug_1.logfil, ncv, &workl[irz], &debug_1.ndigit,
"_seupd: Ritz values after calling _SGETS.");
igraphdvout_(&debug_1.logfil, ncv, &workl[bounds], &
debug_1.ndigit, "_seupd: Ritz value indices after callin"
"g _SGETS.");
}
/* %-----------------------------------------------------% */
/* | Record indices of the converged wanted Ritz values | */
/* | Mark the select array for possible reordering | */
/* %-----------------------------------------------------% */
numcnv = 0;
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
d__2 = eps23, d__3 = (d__1 = workl[irz + *ncv - j], abs(d__1));
temp1 = max(d__2,d__3);
jj = (integer) workl[bounds + *ncv - j];
if (numcnv < nconv && workl[ibd + jj - 1] <= *tol * temp1) {
select[jj] = TRUE_;
++numcnv;
if (jj > *nev) {
reord = TRUE_;
}
}
/* L11: */
}
/* %-----------------------------------------------------------% */
/* | Check the count (numcnv) of converged Ritz values with | */
/* | the number (nconv) reported by _saupd. If these two | */
/* | are different then there has probably been an error | */
/* | caused by incorrect passing of the _saupd data. | */
/* %-----------------------------------------------------------% */
if (msglvl > 2) {
igraphivout_(&debug_1.logfil, &c__1, &numcnv, &debug_1.ndigit,
"_seupd: Number of specified eigenvalues");
igraphivout_(&debug_1.logfil, &c__1, &nconv, &debug_1.ndigit,
"_seupd: Number of \"converged\" eigenvalues")
;
}
if (numcnv != nconv) {
*info = -17;
goto L9000;
}
/* %-----------------------------------------------------------% */
/* | Call LAPACK routine _steqr to compute the eigenvalues and | */
/* | eigenvectors of the final symmetric tridiagonal matrix H. | */
/* | Initialize the eigenvector matrix Q to the identity. | */
/* %-----------------------------------------------------------% */
i__1 = *ncv - 1;
igraphdcopy_(&i__1, &workl[ih + 1], &c__1, &workl[ihb], &c__1);
igraphdcopy_(ncv, &workl[ih + ldh], &c__1, &workl[ihd], &c__1);
igraphdsteqr_("Identity", ncv, &workl[ihd], &workl[ihb], &workl[iq], &
ldq, &workl[iw], &ierr);
if (ierr != 0) {
*info = -8;
goto L9000;
}
if (msglvl > 1) {
igraphdcopy_(ncv, &workl[iq + *ncv - 1], &ldq, &workl[iw], &c__1);
igraphdvout_(&debug_1.logfil, ncv, &workl[ihd], &debug_1.ndigit,
"_seupd: NCV Ritz values of the final H matrix");
igraphdvout_(&debug_1.logfil, ncv, &workl[iw], &debug_1.ndigit,
"_seupd: last row of the eigenvector matrix for H");
}
if (reord) {
/* %---------------------------------------------% */
/* | Reordered the eigenvalues and eigenvectors | */
/* | computed by _steqr so that the "converged" | */
/* | eigenvalues appear in the first NCONV | */
/* | positions of workl(ihd), and the associated | */
/* | eigenvectors appear in the first NCONV | */
/* | columns. | */
/* %---------------------------------------------% */
leftptr = 1;
rghtptr = *ncv;
if (*ncv == 1) {
goto L30;
}
L20:
if (select[leftptr]) {
/* %-------------------------------------------% */
/* | Search, from the left, for the first Ritz | */
/* | value that has not converged. | */
/* %-------------------------------------------% */
++leftptr;
} else if (! select[rghtptr]) {
/* %----------------------------------------------% */
/* | Search, from the right, the first Ritz value | */
/* | that has converged. | */
/* %----------------------------------------------% */
--rghtptr;
} else {
/* %----------------------------------------------% */
/* | Swap the Ritz value on the left that has not | */
/* | converged with the Ritz value on the right | */
/* | that has converged. Swap the associated | */
/* | eigenvector of the tridiagonal matrix H as | */
/* | well. | */
/* %----------------------------------------------% */
temp = workl[ihd + leftptr - 1];
workl[ihd + leftptr - 1] = workl[ihd + rghtptr - 1];
workl[ihd + rghtptr - 1] = temp;
igraphdcopy_(ncv, &workl[iq + *ncv * (leftptr - 1)], &c__1, &
workl[iw], &c__1);
igraphdcopy_(ncv, &workl[iq + *ncv * (rghtptr - 1)], &c__1, &
workl[iq + *ncv * (leftptr - 1)], &c__1);
igraphdcopy_(ncv, &workl[iw], &c__1, &workl[iq + *ncv * (
rghtptr - 1)], &c__1);
++leftptr;
--rghtptr;
}
if (leftptr < rghtptr) {
goto L20;
}
L30:
;
}
if (msglvl > 2) {
igraphdvout_(&debug_1.logfil, ncv, &workl[ihd], &debug_1.ndigit,
"_seupd: The eigenvalues of H--reordered");
}
/* %----------------------------------------% */
/* | Load the converged Ritz values into D. | */
/* %----------------------------------------% */
igraphdcopy_(&nconv, &workl[ihd], &c__1, &d__[1], &c__1);
} else {
/* %-----------------------------------------------------% */
/* | Ritz vectors not required. Load Ritz values into D. | */
/* %-----------------------------------------------------% */
igraphdcopy_(&nconv, &workl[ritz], &c__1, &d__[1], &c__1);
igraphdcopy_(ncv, &workl[ritz], &c__1, &workl[ihd], &c__1);
}
/* %------------------------------------------------------------------% */
/* | Transform the Ritz values and possibly vectors and corresponding | */
/* | Ritz estimates of OP to those of A*x=lambda*B*x. The Ritz values | */
/* | (and corresponding data) are returned in ascending order. | */
/* %------------------------------------------------------------------% */
if (igraphs_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) {
/* %---------------------------------------------------------% */
/* | Ascending sort of wanted Ritz values, vectors and error | */
/* | bounds. Not necessary if only Ritz values are desired. | */
/* %---------------------------------------------------------% */
if (*rvec) {
igraphdsesrt_("LA", rvec, &nconv, &d__[1], ncv, &workl[iq], &ldq);
} else {
igraphdcopy_(ncv, &workl[bounds], &c__1, &workl[ihb], &c__1);
}
} else {
/* %-------------------------------------------------------------% */
/* | * Make a copy of all the Ritz values. | */
/* | * Transform the Ritz values back to the original system. | */
/* | For TYPE = 'SHIFTI' the transformation is | */
/* | lambda = 1/theta + sigma | */
/* | For TYPE = 'BUCKLE' the transformation is | */
/* | lambda = sigma * theta / ( theta - 1 ) | */
/* | For TYPE = 'CAYLEY' the transformation is | */
/* | lambda = sigma * (theta + 1) / (theta - 1 ) | */
/* | where the theta are the Ritz values returned by dsaupd . | */
/* | NOTES: | */
/* | *The Ritz vectors are not affected by the transformation. | */
/* | They are only reordered. | */
/* %-------------------------------------------------------------% */
igraphdcopy_(ncv, &workl[ihd], &c__1, &workl[iw], &c__1);
if (igraphs_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
workl[ihd + k - 1] = 1. / workl[ihd + k - 1] + *sigma;
/* L40: */
}
} else if (igraphs_cmp(type__, "BUCKLE", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
workl[ihd + k - 1] = *sigma * workl[ihd + k - 1] / (workl[ihd
+ k - 1] - 1.);
/* L50: */
}
} else if (igraphs_cmp(type__, "CAYLEY", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
workl[ihd + k - 1] = *sigma * (workl[ihd + k - 1] + 1.) / (
workl[ihd + k - 1] - 1.);
/* L60: */
}
}
/* %-------------------------------------------------------------% */
/* | * Store the wanted NCONV lambda values into D. | */
/* | * Sort the NCONV wanted lambda in WORKL(IHD:IHD+NCONV-1) | */
/* | into ascending order and apply sort to the NCONV theta | */
/* | values in the transformed system. We will need this to | */
/* | compute Ritz estimates in the original system. | */
/* | * Finally sort the lambda`s into ascending order and apply | */
/* | to Ritz vectors if wanted. Else just sort lambda`s into | */
/* | ascending order. | */
/* | NOTES: | */
/* | *workl(iw:iw+ncv-1) contain the theta ordered so that they | */
/* | match the ordering of the lambda. We`ll use them again for | */
/* | Ritz vector purification. | */
/* %-------------------------------------------------------------% */
igraphdcopy_(&nconv, &workl[ihd], &c__1, &d__[1], &c__1);
igraphdsortr_("LA", &c_true, &nconv, &workl[ihd], &workl[iw]);
if (*rvec) {
igraphdsesrt_("LA", rvec, &nconv, &d__[1], ncv, &workl[iq], &ldq);
} else {
igraphdcopy_(ncv, &workl[bounds], &c__1, &workl[ihb], &c__1);
d__1 = bnorm2 / rnorm;
igraphdscal_(ncv, &d__1, &workl[ihb], &c__1);
igraphdsortr_("LA", &c_true, &nconv, &d__[1], &workl[ihb]);
}
}
/* %------------------------------------------------% */
/* | Compute the Ritz vectors. Transform the wanted | */
/* | eigenvectors of the symmetric tridiagonal H by | */
/* | the Lanczos basis matrix V. | */
/* %------------------------------------------------% */
if (*rvec && *(unsigned char *)howmny == 'A') {
/* %----------------------------------------------------------% */
/* | Compute the QR factorization of the matrix representing | */
/* | the wanted invariant subspace located in the first NCONV | */
/* | columns of workl(iq,ldq). | */
/* %----------------------------------------------------------% */
igraphdgeqr2_(ncv, &nconv, &workl[iq], &ldq, &workl[iw + *ncv], &
workl[ihb], &ierr);
/* %--------------------------------------------------------% */
/* | * Postmultiply V by Q. | */
/* | * Copy the first NCONV columns of VQ into Z. | */
/* | The N by NCONV matrix Z is now a matrix representation | */
/* | of the approximate invariant subspace associated with | */
/* | the Ritz values in workl(ihd). | */
/* %--------------------------------------------------------% */
igraphdorm2r_("Right", "Notranspose", n, ncv, &nconv, &workl[iq], &
ldq, &workl[iw + *ncv], &v[v_offset], ldv, &workd[*n + 1], &
ierr);
igraphdlacpy_("All", n, &nconv, &v[v_offset], ldv, &z__[z_offset],
ldz);
/* %-----------------------------------------------------% */
/* | In order to compute the Ritz estimates for the Ritz | */
/* | values in both systems, need the last row of the | */
/* | eigenvector matrix. Remember, it`s in factored form | */
/* %-----------------------------------------------------% */
i__1 = *ncv - 1;
for (j = 1; j <= i__1; ++j) {
workl[ihb + j - 1] = 0.;
/* L65: */
}
workl[ihb + *ncv - 1] = 1.;
igraphdorm2r_("Left", "Transpose", ncv, &c__1, &nconv, &workl[iq], &
ldq, &workl[iw + *ncv], &workl[ihb], ncv, &temp, &ierr);
} else if (*rvec && *(unsigned char *)howmny == 'S') {
/* Not yet implemented. See remark 2 above. */
}
if (igraphs_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0 && *rvec) {
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
workl[ihb + j - 1] = rnorm * (d__1 = workl[ihb + j - 1], abs(d__1)
);
/* L70: */
}
} else if (igraphs_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) != 0 && *rvec) {
/* %-------------------------------------------------% */
/* | * Determine Ritz estimates of the theta. | */
/* | If RVEC = .true. then compute Ritz estimates | */
/* | of the theta. | */
/* | If RVEC = .false. then copy Ritz estimates | */
/* | as computed by dsaupd . | */
/* | * Determine Ritz estimates of the lambda. | */
/* %-------------------------------------------------% */
igraphdscal_(ncv, &bnorm2, &workl[ihb], &c__1);
if (igraphs_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
/* Computing 2nd power */
d__2 = workl[iw + k - 1];
workl[ihb + k - 1] = (d__1 = workl[ihb + k - 1], abs(d__1)) /
(d__2 * d__2);
/* L80: */
}
} else if (igraphs_cmp(type__, "BUCKLE", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
/* Computing 2nd power */
d__2 = workl[iw + k - 1] - 1.;
workl[ihb + k - 1] = *sigma * (d__1 = workl[ihb + k - 1], abs(
d__1)) / (d__2 * d__2);
/* L90: */
}
} else if (igraphs_cmp(type__, "CAYLEY", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
workl[ihb + k - 1] = (d__1 = workl[ihb + k - 1] / workl[iw +
k - 1] * (workl[iw + k - 1] - 1.), abs(d__1));
/* L100: */
}
}
}
if (igraphs_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) != 0 && msglvl > 1) {
igraphdvout_(&debug_1.logfil, &nconv, &d__[1], &debug_1.ndigit, "_se"
"upd: Untransformed converged Ritz values");
igraphdvout_(&debug_1.logfil, &nconv, &workl[ihb], &debug_1.ndigit,
"_seupd: Ritz estimates of the untransformed Ritz values");
} else if (msglvl > 1) {
igraphdvout_(&debug_1.logfil, &nconv, &d__[1], &debug_1.ndigit, "_se"
"upd: Converged Ritz values");
igraphdvout_(&debug_1.logfil, &nconv, &workl[ihb], &debug_1.ndigit,
"_seupd: Associated Ritz estimates");
}
/* %-------------------------------------------------% */
/* | Ritz vector purification step. Formally perform | */
/* | one of inverse subspace iteration. Only used | */
/* | for MODE = 3,4,5. See reference 7 | */
/* %-------------------------------------------------% */
if (*rvec && (igraphs_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0 || igraphs_cmp(
type__, "CAYLEY", (ftnlen)6, (ftnlen)6) == 0)) {
i__1 = nconv - 1;
for (k = 0; k <= i__1; ++k) {
workl[iw + k] = workl[iq + k * ldq + *ncv - 1] / workl[iw + k];
/* L110: */
}
} else if (*rvec && igraphs_cmp(type__, "BUCKLE", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = nconv - 1;
for (k = 0; k <= i__1; ++k) {
workl[iw + k] = workl[iq + k * ldq + *ncv - 1] / (workl[iw + k] -
1.);
/* L120: */
}
}
if (igraphs_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) != 0) {
igraphdger_(n, &nconv, &c_b110, &resid[1], &c__1, &workl[iw], &c__1, &
z__[z_offset], ldz);
}
L9000:
return 0;
/* %---------------% */
/* | End of dseupd | */
/* %---------------% */
} /* igraphdseupd_ */
Subroutine */ int igraphdseupd_(logical *rvec, char *howmny, logical *select,
doublereal *d__, doublereal *z__, integer *ldz, doublereal *sigma,
char *bmat, integer *n, char *which, integer *nev, doublereal *tol,
doublereal *resid, integer *ncv, doublereal *v, integer *ldv, integer
*iparam, integer *ipntr, doublereal *workd, doublereal *workl,
integer *lworkl, integer *info)
{
/* System generated locals */
integer v_dim1, v_offset, z_dim1, z_offset, i__1;
doublereal d__1, d__2, d__3;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double pow_dd(doublereal *, doublereal *);
/* Local variables */
integer j, k, ih, iq, iw;
doublereal kv[2];
integer ibd, ihb, ihd, ldh, ilg, ldq, ism, irz;
extern /* Subroutine */ int igraphdger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
integer mode;
doublereal eps23;
integer ierr;
doublereal temp;
integer next;
char type__[6];
integer ritz;
extern doublereal igraphdnrm2_(integer *, doublereal *, integer *);
extern /* Subroutine */ int igraphdscal_(integer *, doublereal *, doublereal *,
integer *);
logical reord;
extern /* Subroutine */ int igraphdcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
integer nconv;
doublereal rnorm;
extern /* Subroutine */ int igraphdvout_(integer *, integer *, doublereal *,
integer *, char *, ftnlen), igraphivout_(integer *, integer *, integer *
, integer *, char *, ftnlen), igraphdgeqr2_(integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *);
doublereal bnorm2;
extern /* Subroutine */ int igraphdorm2r_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
doublereal thres1, thres2;
extern doublereal igraphdlamch_(char *);
extern /* Subroutine */ int igraphdlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *);
integer logfil, ndigit, bounds, mseupd = 0;
extern /* Subroutine */ int igraphdsteqr_(char *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *);
integer msglvl, ktrord;
extern /* Subroutine */ int igraphdsesrt_(char *, logical *, integer *,
doublereal *, integer *, doublereal *, integer *),
igraphdsortr_(char *, logical *, integer *, doublereal *, doublereal *);
doublereal tempbnd;
integer leftptr, rghtptr;
/* %----------------------------------------------------%
| Include files for debugging and timing information |
%----------------------------------------------------%
%------------------%
| Scalar Arguments |
%------------------%
%-----------------%
| Array Arguments |
%-----------------%
%------------%
| Parameters |
%------------%
%---------------%
| Local Scalars |
%---------------%
%--------------%
| Local Arrays |
%--------------%
%----------------------%
| External Subroutines |
%----------------------%
%--------------------%
| External Functions |
%--------------------%
%---------------------%
| Intrinsic Functions |
%---------------------%
%-----------------------%
| Executable Statements |
%-----------------------%
%------------------------%
| Set default parameters |
%------------------------%
Parameter adjustments */
--workd;
--resid;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--d__;
--select;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--iparam;
--ipntr;
--workl;
/* Function Body */
msglvl = mseupd;
mode = iparam[7];
nconv = iparam[5];
*info = 0;
/* %--------------%
| Quick return |
%--------------% */
if (nconv == 0) {
goto L9000;
}
ierr = 0;
if (nconv <= 0) {
ierr = -14;
}
if (*n <= 0) {
ierr = -1;
}
if (*nev <= 0) {
ierr = -2;
}
if (*ncv <= *nev || *ncv > *n) {
ierr = -3;
}
if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "SM", (
ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "LA", (ftnlen)2, (
ftnlen)2) != 0 && s_cmp(which, "SA", (ftnlen)2, (ftnlen)2) != 0 &&
s_cmp(which, "BE", (ftnlen)2, (ftnlen)2) != 0) {
ierr = -5;
}
if (*(unsigned char *)bmat != 'I' && *(unsigned char *)bmat != 'G') {
ierr = -6;
}
if (*(unsigned char *)howmny != 'A' && *(unsigned char *)howmny != 'P' &&
*(unsigned char *)howmny != 'S' && *rvec) {
ierr = -15;
}
if (*rvec && *(unsigned char *)howmny == 'S') {
ierr = -16;
}
/* Computing 2nd power */
i__1 = *ncv;
if (*rvec && *lworkl < i__1 * i__1 + (*ncv << 3)) {
ierr = -7;
}
if (mode == 1 || mode == 2) {
s_copy(type__, "REGULR", (ftnlen)6, (ftnlen)6);
} else if (mode == 3) {
s_copy(type__, "SHIFTI", (ftnlen)6, (ftnlen)6);
} else if (mode == 4) {
s_copy(type__, "BUCKLE", (ftnlen)6, (ftnlen)6);
} else if (mode == 5) {
s_copy(type__, "CAYLEY", (ftnlen)6, (ftnlen)6);
} else {
ierr = -10;
}
if (mode == 1 && *(unsigned char *)bmat == 'G') {
ierr = -11;
}
if (*nev == 1 && s_cmp(which, "BE", (ftnlen)2, (ftnlen)2) == 0) {
ierr = -12;
}
/* %------------%
| Error Exit |
%------------% */
if (ierr != 0) {
*info = ierr;
goto L9000;
}
/* %-------------------------------------------------------%
| Pointer into WORKL for address of H, RITZ, BOUNDS, Q |
| etc... and the remaining workspace. |
| Also update pointer to be used on output. |
| Memory is laid out as follows: |
| workl(1:2*ncv) := generated tridiagonal matrix H |
| The subdiagonal is stored in workl(2:ncv). |
| The dead spot is workl(1) but upon exiting |
| dsaupd stores the B-norm of the last residual |
| vector in workl(1). We use this !!! |
| workl(2*ncv+1:2*ncv+ncv) := ritz values |
| The wanted values are in the first NCONV spots. |
| workl(3*ncv+1:3*ncv+ncv) := computed Ritz estimates |
| The wanted values are in the first NCONV spots. |
| NOTE: workl(1:4*ncv) is set by dsaupd and is not |
| modified by dseupd. |
%-------------------------------------------------------%
%-------------------------------------------------------%
| The following is used and set by dseupd. |
| workl(4*ncv+1:4*ncv+ncv) := used as workspace during |
| computation of the eigenvectors of H. Stores |
| the diagonal of H. Upon EXIT contains the NCV |
| Ritz values of the original system. The first |
| NCONV spots have the wanted values. If MODE = |
| 1 or 2 then will equal workl(2*ncv+1:3*ncv). |
| workl(5*ncv+1:5*ncv+ncv) := used as workspace during |
| computation of the eigenvectors of H. Stores |
| the subdiagonal of H. Upon EXIT contains the |
| NCV corresponding Ritz estimates of the |
| original system. The first NCONV spots have the |
| wanted values. If MODE = 1,2 then will equal |
| workl(3*ncv+1:4*ncv). |
| workl(6*ncv+1:6*ncv+ncv*ncv) := orthogonal Q that is |
| the eigenvector matrix for H as returned by |
| dsteqr. Not referenced if RVEC = .False. |
| Ordering follows that of workl(4*ncv+1:5*ncv) |
| workl(6*ncv+ncv*ncv+1:6*ncv+ncv*ncv+2*ncv) := |
| Workspace. Needed by dsteqr and by dseupd. |
| GRAND total of NCV*(NCV+8) locations. |
%-------------------------------------------------------% */
ih = ipntr[5];
ritz = ipntr[6];
bounds = ipntr[7];
ldh = *ncv;
ldq = *ncv;
ihd = bounds + ldh;
ihb = ihd + ldh;
iq = ihb + ldh;
iw = iq + ldh * *ncv;
next = iw + (*ncv << 1);
ipntr[4] = next;
ipntr[8] = ihd;
ipntr[9] = ihb;
ipntr[10] = iq;
/* %----------------------------------------%
| irz points to the Ritz values computed |
| by _seigt before exiting _saup2. |
| ibd points to the Ritz estimates |
| computed by _seigt before exiting |
| _saup2. |
%----------------------------------------% */
irz = ipntr[11] + *ncv;
ibd = irz + *ncv;
/* %---------------------------------%
| Set machine dependent constant. |
%---------------------------------% */
eps23 = igraphdlamch_("Epsilon-Machine");
eps23 = pow_dd(&eps23, &c_b21);
/* %---------------------------------------%
| RNORM is B-norm of the RESID(1:N). |
| BNORM2 is the 2 norm of B*RESID(1:N). |
| Upon exit of dsaupd WORKD(1:N) has |
| B*RESID(1:N). |
%---------------------------------------% */
rnorm = workl[ih];
if (*(unsigned char *)bmat == 'I') {
bnorm2 = rnorm;
} else if (*(unsigned char *)bmat == 'G') {
bnorm2 = igraphdnrm2_(n, &workd[1], &c__1);
}
if (*rvec) {
/* %------------------------------------------------%
| Get the converged Ritz value on the boundary. |
| This value will be used to dermine whether we |
| need to reorder the eigenvalues and |
| eigenvectors comupted by _steqr, and is |
| referred to as the "threshold" value. |
| |
| A Ritz value gamma is said to be a wanted |
| one, if |
| abs(gamma) .ge. threshold, when WHICH = 'LM'; |
| abs(gamma) .le. threshold, when WHICH = 'SM'; |
| gamma .ge. threshold, when WHICH = 'LA'; |
| gamma .le. threshold, when WHICH = 'SA'; |
| gamma .le. thres1 .or. gamma .ge. thres2 |
| when WHICH = 'BE'; |
| |
| Note: converged Ritz values and associated |
| Ritz estimates have been placed in the first |
| NCONV locations in workl(ritz) and |
| workl(bounds) respectively. They have been |
| sorted (in _saup2) according to the WHICH |
| selection criterion. (Except in the case |
| WHICH = 'BE', they are sorted in an increasing |
| order.) |
%------------------------------------------------% */
if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(which,
"SM", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(which, "LA", (
ftnlen)2, (ftnlen)2) == 0 || s_cmp(which, "SA", (ftnlen)2, (
ftnlen)2) == 0) {
thres1 = workl[ritz];
if (msglvl > 2) {
igraphdvout_(&logfil, &c__1, &thres1, &ndigit, "_seupd: Threshold "
"eigenvalue used for re-ordering", (ftnlen)49);
}
} else if (s_cmp(which, "BE", (ftnlen)2, (ftnlen)2) == 0) {
/* %------------------------------------------------%
| Ritz values returned from _saup2 have been |
| sorted in increasing order. Thus two |
| "threshold" values (one for the small end, one |
| for the large end) are in the middle. |
%------------------------------------------------% */
ism = max(*nev,nconv) / 2;
ilg = ism + 1;
thres1 = workl[ism];
thres2 = workl[ilg];
if (msglvl > 2) {
kv[0] = thres1;
kv[1] = thres2;
igraphdvout_(&logfil, &c__2, kv, &ndigit, "_seupd: Threshold eigen"
"values used for re-ordering", (ftnlen)50);
}
}
/* %----------------------------------------------------------%
| Check to see if all converged Ritz values appear within |
| the first NCONV diagonal elements returned from _seigt. |
| This is done in the following way: |
| |
| 1) For each Ritz value obtained from _seigt, compare it |
| with the threshold Ritz value computed above to |
| determine whether it is a wanted one. |
| |
| 2) If it is wanted, then check the corresponding Ritz |
| estimate to see if it has converged. If it has, set |
| correponding entry in the logical array SELECT to |
| .TRUE.. |
| |
| If SELECT(j) = .TRUE. and j > NCONV, then there is a |
| converged Ritz value that does not appear at the top of |
| the diagonal matrix computed by _seigt in _saup2. |
| Reordering is needed. |
%----------------------------------------------------------% */
reord = FALSE_;
ktrord = 0;
i__1 = *ncv - 1;
for (j = 0; j <= i__1; ++j) {
select[j + 1] = FALSE_;
if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) == 0) {
if ((d__1 = workl[irz + j], abs(d__1)) >= abs(thres1)) {
/* Computing MAX */
d__2 = eps23, d__3 = (d__1 = workl[irz + j], abs(d__1));
tempbnd = max(d__2,d__3);
if (workl[ibd + j] <= *tol * tempbnd) {
select[j + 1] = TRUE_;
}
}
} else if (s_cmp(which, "SM", (ftnlen)2, (ftnlen)2) == 0) {
if ((d__1 = workl[irz + j], abs(d__1)) <= abs(thres1)) {
/* Computing MAX */
d__2 = eps23, d__3 = (d__1 = workl[irz + j], abs(d__1));
tempbnd = max(d__2,d__3);
if (workl[ibd + j] <= *tol * tempbnd) {
select[j + 1] = TRUE_;
}
}
} else if (s_cmp(which, "LA", (ftnlen)2, (ftnlen)2) == 0) {
if (workl[irz + j] >= thres1) {
/* Computing MAX */
d__2 = eps23, d__3 = (d__1 = workl[irz + j], abs(d__1));
tempbnd = max(d__2,d__3);
if (workl[ibd + j] <= *tol * tempbnd) {
select[j + 1] = TRUE_;
}
}
} else if (s_cmp(which, "SA", (ftnlen)2, (ftnlen)2) == 0) {
if (workl[irz + j] <= thres1) {
/* Computing MAX */
d__2 = eps23, d__3 = (d__1 = workl[irz + j], abs(d__1));
tempbnd = max(d__2,d__3);
if (workl[ibd + j] <= *tol * tempbnd) {
select[j + 1] = TRUE_;
}
}
} else if (s_cmp(which, "BE", (ftnlen)2, (ftnlen)2) == 0) {
if (workl[irz + j] <= thres1 || workl[irz + j] >= thres2) {
/* Computing MAX */
d__2 = eps23, d__3 = (d__1 = workl[irz + j], abs(d__1));
tempbnd = max(d__2,d__3);
if (workl[ibd + j] <= *tol * tempbnd) {
select[j + 1] = TRUE_;
}
}
}
if (j + 1 > nconv) {
reord = select[j + 1] || reord;
}
if (select[j + 1]) {
++ktrord;
}
/* L10: */
}
/* %-------------------------------------------%
| If KTRORD .ne. NCONV, something is wrong. |
%-------------------------------------------% */
if (msglvl > 2) {
igraphivout_(&logfil, &c__1, &ktrord, &ndigit, "_seupd: Number of spec"
"ified eigenvalues", (ftnlen)39);
igraphivout_(&logfil, &c__1, &nconv, &ndigit, "_seupd: Number of \"con"
"verged\" eigenvalues", (ftnlen)41);
}
/* %-----------------------------------------------------------%
| Call LAPACK routine _steqr to compute the eigenvalues and |
| eigenvectors of the final symmetric tridiagonal matrix H. |
| Initialize the eigenvector matrix Q to the identity. |
%-----------------------------------------------------------% */
i__1 = *ncv - 1;
igraphdcopy_(&i__1, &workl[ih + 1], &c__1, &workl[ihb], &c__1);
igraphdcopy_(ncv, &workl[ih + ldh], &c__1, &workl[ihd], &c__1);
igraphdsteqr_("Identity", ncv, &workl[ihd], &workl[ihb], &workl[iq], &ldq, &
workl[iw], &ierr);
if (ierr != 0) {
*info = -8;
goto L9000;
}
if (msglvl > 1) {
igraphdcopy_(ncv, &workl[iq + *ncv - 1], &ldq, &workl[iw], &c__1);
igraphdvout_(&logfil, ncv, &workl[ihd], &ndigit, "_seupd: NCV Ritz val"
"ues of the final H matrix", (ftnlen)45);
igraphdvout_(&logfil, ncv, &workl[iw], &ndigit, "_seupd: last row of t"
"he eigenvector matrix for H", (ftnlen)48);
}
if (reord) {
/* %---------------------------------------------%
| Reordered the eigenvalues and eigenvectors |
| computed by _steqr so that the "converged" |
| eigenvalues appear in the first NCONV |
| positions of workl(ihd), and the associated |
| eigenvectors appear in the first NCONV |
| columns. |
%---------------------------------------------% */
leftptr = 1;
rghtptr = *ncv;
if (*ncv == 1) {
goto L30;
}
L20:
if (select[leftptr]) {
/* %-------------------------------------------%
| Search, from the left, for the first Ritz |
| value that has not converged. |
%-------------------------------------------% */
++leftptr;
} else if (! select[rghtptr]) {
/* %----------------------------------------------%
| Search, from the right, the first Ritz value |
| that has converged. |
%----------------------------------------------% */
--rghtptr;
} else {
/* %----------------------------------------------%
| Swap the Ritz value on the left that has not |
| converged with the Ritz value on the right |
| that has converged. Swap the associated |
| eigenvector of the tridiagonal matrix H as |
| well. |
%----------------------------------------------% */
temp = workl[ihd + leftptr - 1];
workl[ihd + leftptr - 1] = workl[ihd + rghtptr - 1];
workl[ihd + rghtptr - 1] = temp;
igraphdcopy_(ncv, &workl[iq + *ncv * (leftptr - 1)], &c__1, &workl[
iw], &c__1);
igraphdcopy_(ncv, &workl[iq + *ncv * (rghtptr - 1)], &c__1, &workl[
iq + *ncv * (leftptr - 1)], &c__1);
igraphdcopy_(ncv, &workl[iw], &c__1, &workl[iq + *ncv * (rghtptr -
1)], &c__1);
++leftptr;
--rghtptr;
}
if (leftptr < rghtptr) {
goto L20;
}
L30:
;
}
if (msglvl > 2) {
igraphdvout_(&logfil, ncv, &workl[ihd], &ndigit, "_seupd: The eigenval"
"ues of H--reordered", (ftnlen)39);
}
/* %----------------------------------------%
| Load the converged Ritz values into D. |
%----------------------------------------% */
igraphdcopy_(&nconv, &workl[ihd], &c__1, &d__[1], &c__1);
} else {
/* %-----------------------------------------------------%
| Ritz vectors not required. Load Ritz values into D. |
%-----------------------------------------------------% */
igraphdcopy_(&nconv, &workl[ritz], &c__1, &d__[1], &c__1);
igraphdcopy_(ncv, &workl[ritz], &c__1, &workl[ihd], &c__1);
}
/* %------------------------------------------------------------------%
| Transform the Ritz values and possibly vectors and corresponding |
| Ritz estimates of OP to those of A*x=lambda*B*x. The Ritz values |
| (and corresponding data) are returned in ascending order. |
%------------------------------------------------------------------% */
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) {
/* %---------------------------------------------------------%
| Ascending sort of wanted Ritz values, vectors and error |
| bounds. Not necessary if only Ritz values are desired. |
%---------------------------------------------------------% */
if (*rvec) {
igraphdsesrt_("LA", rvec, &nconv, &d__[1], ncv, &workl[iq], &ldq);
} else {
igraphdcopy_(ncv, &workl[bounds], &c__1, &workl[ihb], &c__1);
}
} else {
/* %-------------------------------------------------------------%
| * Make a copy of all the Ritz values. |
| * Transform the Ritz values back to the original system. |
| For TYPE = 'SHIFTI' the transformation is |
| lambda = 1/theta + sigma |
| For TYPE = 'BUCKLE' the transformation is |
| lambda = sigma * theta / ( theta - 1 ) |
| For TYPE = 'CAYLEY' the transformation is |
| lambda = sigma * (theta + 1) / (theta - 1 ) |
| where the theta are the Ritz values returned by dsaupd. |
| NOTES: |
| *The Ritz vectors are not affected by the transformation. |
| They are only reordered. |
%-------------------------------------------------------------% */
igraphdcopy_(ncv, &workl[ihd], &c__1, &workl[iw], &c__1);
if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
workl[ihd + k - 1] = 1. / workl[ihd + k - 1] + *sigma;
/* L40: */
}
} else if (s_cmp(type__, "BUCKLE", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
workl[ihd + k - 1] = *sigma * workl[ihd + k - 1] / (workl[ihd
+ k - 1] - 1.);
/* L50: */
}
} else if (s_cmp(type__, "CAYLEY", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
workl[ihd + k - 1] = *sigma * (workl[ihd + k - 1] + 1.) / (
workl[ihd + k - 1] - 1.);
/* L60: */
}
}
/* %-------------------------------------------------------------%
| * Store the wanted NCONV lambda values into D. |
| * Sort the NCONV wanted lambda in WORKL(IHD:IHD+NCONV-1) |
| into ascending order and apply sort to the NCONV theta |
| values in the transformed system. We'll need this to |
| compute Ritz estimates in the original system. |
| * Finally sort the lambda's into ascending order and apply |
| to Ritz vectors if wanted. Else just sort lambda's into |
| ascending order. |
| NOTES: |
| *workl(iw:iw+ncv-1) contain the theta ordered so that they |
| match the ordering of the lambda. We'll use them again for |
| Ritz vector purification. |
%-------------------------------------------------------------% */
igraphdcopy_(&nconv, &workl[ihd], &c__1, &d__[1], &c__1);
igraphdsortr_("LA", &c_true, &nconv, &workl[ihd], &workl[iw]);
if (*rvec) {
igraphdsesrt_("LA", rvec, &nconv, &d__[1], ncv, &workl[iq], &ldq);
} else {
igraphdcopy_(ncv, &workl[bounds], &c__1, &workl[ihb], &c__1);
d__1 = bnorm2 / rnorm;
igraphdscal_(ncv, &d__1, &workl[ihb], &c__1);
igraphdsortr_("LA", &c_true, &nconv, &d__[1], &workl[ihb]);
}
}
/* %------------------------------------------------%
| Compute the Ritz vectors. Transform the wanted |
| eigenvectors of the symmetric tridiagonal H by |
| the Lanczos basis matrix V. |
%------------------------------------------------% */
if (*rvec && *(unsigned char *)howmny == 'A') {
/* %----------------------------------------------------------%
| Compute the QR factorization of the matrix representing |
| the wanted invariant subspace located in the first NCONV |
| columns of workl(iq,ldq). |
%----------------------------------------------------------% */
igraphdgeqr2_(ncv, &nconv, &workl[iq], &ldq, &workl[iw + *ncv], &workl[ihb],
&ierr);
/* %--------------------------------------------------------%
| * Postmultiply V by Q. |
| * Copy the first NCONV columns of VQ into Z. |
| The N by NCONV matrix Z is now a matrix representation |
| of the approximate invariant subspace associated with |
| the Ritz values in workl(ihd). |
%--------------------------------------------------------% */
igraphdorm2r_("Right", "Notranspose", n, ncv, &nconv, &workl[iq], &ldq, &
workl[iw + *ncv], &v[v_offset], ldv, &workd[*n + 1], &ierr);
igraphdlacpy_("All", n, &nconv, &v[v_offset], ldv, &z__[z_offset], ldz);
/* %-----------------------------------------------------%
| In order to compute the Ritz estimates for the Ritz |
| values in both systems, need the last row of the |
| eigenvector matrix. Remember, it's in factored form |
%-----------------------------------------------------% */
i__1 = *ncv - 1;
for (j = 1; j <= i__1; ++j) {
workl[ihb + j - 1] = 0.;
/* L65: */
}
workl[ihb + *ncv - 1] = 1.;
igraphdorm2r_("Left", "Transpose", ncv, &c__1, &nconv, &workl[iq], &ldq, &
workl[iw + *ncv], &workl[ihb], ncv, &temp, &ierr);
} else if (*rvec && *(unsigned char *)howmny == 'S') {
/* Not yet implemented. See remark 2 above. */
}
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0 && *rvec) {
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
workl[ihb + j - 1] = rnorm * (d__1 = workl[ihb + j - 1], abs(d__1)
);
/* L70: */
}
} else if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) != 0 && *rvec) {
/* %-------------------------------------------------%
| * Determine Ritz estimates of the theta. |
| If RVEC = .true. then compute Ritz estimates |
| of the theta. |
| If RVEC = .false. then copy Ritz estimates |
| as computed by dsaupd. |
| * Determine Ritz estimates of the lambda. |
%-------------------------------------------------% */
igraphdscal_(ncv, &bnorm2, &workl[ihb], &c__1);
if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
/* Computing 2nd power */
d__2 = workl[iw + k - 1];
workl[ihb + k - 1] = (d__1 = workl[ihb + k - 1], abs(d__1)) /
(d__2 * d__2);
/* L80: */
}
} else if (s_cmp(type__, "BUCKLE", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
/* Computing 2nd power */
d__2 = workl[iw + k - 1] - 1.;
workl[ihb + k - 1] = *sigma * (d__1 = workl[ihb + k - 1], abs(
d__1)) / (d__2 * d__2);
/* L90: */
}
} else if (s_cmp(type__, "CAYLEY", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
workl[ihb + k - 1] = (d__1 = workl[ihb + k - 1] / workl[iw +
k - 1] * (workl[iw + k - 1] - 1.), abs(d__1));
/* L100: */
}
}
}
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) != 0 && msglvl > 1) {
igraphdvout_(&logfil, &nconv, &d__[1], &ndigit, "_seupd: Untransformed con"
"verged Ritz values", (ftnlen)43);
igraphdvout_(&logfil, &nconv, &workl[ihb], &ndigit, "_seupd: Ritz estimate"
"s of the untransformed Ritz values", (ftnlen)55);
} else if (msglvl > 1) {
igraphdvout_(&logfil, &nconv, &d__[1], &ndigit, "_seupd: Converged Ritz va"
"lues", (ftnlen)29);
igraphdvout_(&logfil, &nconv, &workl[ihb], &ndigit, "_seupd: Associated Ri"
"tz estimates", (ftnlen)33);
}
/* %-------------------------------------------------%
| Ritz vector purification step. Formally perform |
| one of inverse subspace iteration. Only used |
| for MODE = 3,4,5. See reference 7 |
%-------------------------------------------------% */
if (*rvec && (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0 || s_cmp(
type__, "CAYLEY", (ftnlen)6, (ftnlen)6) == 0)) {
i__1 = nconv - 1;
for (k = 0; k <= i__1; ++k) {
workl[iw + k] = workl[iq + k * ldq + *ncv - 1] / workl[iw + k];
/* L110: */
}
} else if (*rvec && s_cmp(type__, "BUCKLE", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = nconv - 1;
for (k = 0; k <= i__1; ++k) {
workl[iw + k] = workl[iq + k * ldq + *ncv - 1] / (workl[iw + k] -
1.);
/* L120: */
}
}
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) != 0) {
igraphdger_(n, &nconv, &c_b119, &resid[1], &c__1, &workl[iw], &c__1, &z__[
z_offset], ldz);
}
L9000:
return 0;
/* %---------------%
| End of dseupd |
%---------------% */
} /* igraphdseupd_ */
/* 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_ */