/* 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 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 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_ */
