/* 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 igraphdsaup2_(integer *ido, char *bmat, integer *n, char *
which, integer *nev, integer *np, doublereal *tol, doublereal *resid,
integer *mode, integer *iupd, integer *ishift, integer *mxiter,
doublereal *v, integer *ldv, doublereal *h__, integer *ldh,
doublereal *ritz, doublereal *bounds, doublereal *q, integer *ldq,
doublereal *workl, integer *ipntr, doublereal *workd, integer *info)
{
/* System generated locals */
integer h_dim1, h_offset, q_dim1, q_offset, v_dim1, v_offset, i__1, i__2,
i__3;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double pow_dd(doublereal *, doublereal *);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double sqrt(doublereal);
/* Local variables */
integer j;
real t0, t1, t2, t3;
integer kp[3];
IGRAPH_F77_SAVE integer np0;
integer nbx = 0;
IGRAPH_F77_SAVE integer nev0;
extern doublereal igraphddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
IGRAPH_F77_SAVE doublereal eps23;
integer ierr;
IGRAPH_F77_SAVE integer iter;
doublereal temp;
integer nevd2;
extern doublereal igraphdnrm2_(integer *, doublereal *, integer *);
IGRAPH_F77_SAVE logical getv0;
integer nevm2;
IGRAPH_F77_SAVE logical cnorm;
extern /* Subroutine */ int igraphdcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), igraphdswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
IGRAPH_F77_SAVE integer nconv;
IGRAPH_F77_SAVE logical initv;
IGRAPH_F77_SAVE doublereal rnorm;
real tmvbx = 0.0;
extern /* Subroutine */ int igraphdvout_(integer *, integer *, doublereal *,
integer *, char *, ftnlen), igraphivout_(integer *, integer *, integer *
, integer *, char *, ftnlen), igraphdgetv0_(integer *, char *, integer *
, logical *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *);
integer msaup2 = 0;
real tsaup2;
extern doublereal igraphdlamch_(char *);
integer nevbef;
extern /* Subroutine */ int igraphsecond_(real *);
integer logfil, ndigit;
extern /* Subroutine */ int igraphdseigt_(doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, integer *);
IGRAPH_F77_SAVE logical update;
extern /* Subroutine */ int igraphdsaitr_(integer *, char *, integer *, integer
*, integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
integer *), igraphdsgets_(integer *, char *, integer *, integer
*, doublereal *, doublereal *, doublereal *), igraphdsapps_(
integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *), igraphdsconv_(integer *, doublereal *,
doublereal *, doublereal *, integer *);
IGRAPH_F77_SAVE logical ushift;
char wprime[2];
IGRAPH_F77_SAVE integer msglvl;
integer nptemp;
extern /* Subroutine */ int igraphdsortr_(char *, logical *, integer *,
doublereal *, doublereal *);
IGRAPH_F77_SAVE integer kplusp;
/* %----------------------------------------------------%
| Include files for debugging and timing information |
%----------------------------------------------------%
%------------------%
| Scalar Arguments |
%------------------%
%-----------------%
| Array Arguments |
%-----------------%
%------------%
| Parameters |
%------------%
%---------------%
| Local Scalars |
%---------------%
%----------------------%
| External Subroutines |
%----------------------%
%--------------------%
| External Functions |
%--------------------%
%---------------------%
| Intrinsic Functions |
%---------------------%
%-----------------------%
| Executable Statements |
%-----------------------%
Parameter adjustments */
--workd;
--resid;
--workl;
--bounds;
--ritz;
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;
--ipntr;
/* Function Body */
if (*ido == 0) {
/* %-------------------------------%
| Initialize timing statistics |
| & message level for debugging |
%-------------------------------% */
igraphsecond_(&t0);
msglvl = msaup2;
/* %---------------------------------%
| Set machine dependent constant. |
%---------------------------------% */
eps23 = igraphdlamch_("Epsilon-Machine");
eps23 = pow_dd(&eps23, &c_b3);
/* %-------------------------------------%
| nev0 and np0 are integer variables |
| hold the initial values of NEV & NP |
%-------------------------------------% */
nev0 = *nev;
np0 = *np;
/* %-------------------------------------%
| kplusp is the bound on the largest |
| Lanczos factorization built. |
| nconv is the current number of |
| "converged" eigenvlues. |
| iter is the counter on the current |
| iteration step. |
%-------------------------------------% */
kplusp = nev0 + np0;
nconv = 0;
iter = 0;
/* %--------------------------------------------%
| Set flags for computing the first NEV steps |
| of the Lanczos factorization. |
%--------------------------------------------% */
getv0 = TRUE_;
update = FALSE_;
ushift = FALSE_;
cnorm = FALSE_;
if (*info != 0) {
/* %--------------------------------------------%
| User provides the initial residual vector. |
%--------------------------------------------% */
initv = TRUE_;
*info = 0;
} else {
initv = FALSE_;
}
}
/* %---------------------------------------------%
| Get a possibly random starting vector and |
| force it into the range of the operator OP. |
%---------------------------------------------%
L10: */
if (getv0) {
igraphdgetv0_(ido, bmat, &c__1, &initv, n, &c__1, &v[v_offset], ldv, &resid[
1], &rnorm, &ipntr[1], &workd[1], info);
if (*ido != 99) {
goto L9000;
}
if (rnorm == 0.) {
/* %-----------------------------------------%
| The initial vector is zero. Error exit. |
%-----------------------------------------% */
*info = -9;
goto L1200;
}
getv0 = FALSE_;
*ido = 0;
}
/* %------------------------------------------------------------%
| Back from reverse communication: continue with update step |
%------------------------------------------------------------% */
if (update) {
goto L20;
}
/* %-------------------------------------------%
| Back from computing user specified shifts |
%-------------------------------------------% */
if (ushift) {
goto L50;
}
/* %-------------------------------------%
| Back from computing residual norm |
| at the end of the current iteration |
%-------------------------------------% */
if (cnorm) {
goto L100;
}
/* %----------------------------------------------------------%
| Compute the first NEV steps of the Lanczos factorization |
%----------------------------------------------------------% */
igraphdsaitr_(ido, bmat, n, &c__0, &nev0, mode, &resid[1], &rnorm, &v[v_offset],
ldv, &h__[h_offset], ldh, &ipntr[1], &workd[1], info);
/* %---------------------------------------------------%
| ido .ne. 99 implies use of reverse communication |
| to compute operations involving OP and possibly B |
%---------------------------------------------------% */
if (*ido != 99) {
goto L9000;
}
if (*info > 0) {
/* %-----------------------------------------------------%
| dsaitr was unable to build an Lanczos factorization |
| of length NEV0. INFO is returned with the size of |
| the factorization built. Exit main loop. |
%-----------------------------------------------------% */
*np = *info;
*mxiter = iter;
*info = -9999;
goto L1200;
}
/* %--------------------------------------------------------------%
| |
| M A I N LANCZOS I T E R A T I O N L O O P |
| Each iteration implicitly restarts the Lanczos |
| factorization in place. |
| |
%--------------------------------------------------------------% */
L1000:
++iter;
if (msglvl > 0) {
igraphivout_(&logfil, &c__1, &iter, &ndigit, "_saup2: **** Start of major "
"iteration number ****", (ftnlen)49);
}
if (msglvl > 1) {
igraphivout_(&logfil, &c__1, nev, &ndigit, "_saup2: The length of the curr"
"ent Lanczos factorization", (ftnlen)55);
igraphivout_(&logfil, &c__1, np, &ndigit, "_saup2: Extend the Lanczos fact"
"orization by", (ftnlen)43);
}
/* %------------------------------------------------------------%
| Compute NP additional steps of the Lanczos factorization. |
%------------------------------------------------------------% */
*ido = 0;
L20:
update = TRUE_;
igraphdsaitr_(ido, bmat, n, nev, np, mode, &resid[1], &rnorm, &v[v_offset], ldv,
&h__[h_offset], ldh, &ipntr[1], &workd[1], info);
/* %---------------------------------------------------%
| ido .ne. 99 implies use of reverse communication |
| to compute operations involving OP and possibly B |
%---------------------------------------------------% */
if (*ido != 99) {
goto L9000;
}
if (*info > 0) {
/* %-----------------------------------------------------%
| dsaitr was unable to build an Lanczos factorization |
| of length NEV0+NP0. INFO is returned with the size |
| of the factorization built. Exit main loop. |
%-----------------------------------------------------% */
*np = *info;
*mxiter = iter;
*info = -9999;
goto L1200;
}
update = FALSE_;
if (msglvl > 1) {
igraphdvout_(&logfil, &c__1, &rnorm, &ndigit, "_saup2: Current B-norm of r"
"esidual for factorization", (ftnlen)52);
}
/* %--------------------------------------------------------%
| Compute the eigenvalues and corresponding error bounds |
| of the current symmetric tridiagonal matrix. |
%--------------------------------------------------------% */
igraphdseigt_(&rnorm, &kplusp, &h__[h_offset], ldh, &ritz[1], &bounds[1], &
workl[1], &ierr);
if (ierr != 0) {
*info = -8;
goto L1200;
}
/* %----------------------------------------------------%
| Make a copy of eigenvalues and corresponding error |
| bounds obtained from _seigt. |
%----------------------------------------------------% */
igraphdcopy_(&kplusp, &ritz[1], &c__1, &workl[kplusp + 1], &c__1);
igraphdcopy_(&kplusp, &bounds[1], &c__1, &workl[(kplusp << 1) + 1], &c__1);
/* %---------------------------------------------------%
| Select the wanted Ritz values and their bounds |
| to be used in the convergence test. |
| The selection is based on the requested number of |
| eigenvalues instead of the current NEV and NP to |
| prevent possible misconvergence. |
| * Wanted Ritz values := RITZ(NP+1:NEV+NP) |
| * Shifts := RITZ(1:NP) := WORKL(1:NP) |
%---------------------------------------------------% */
*nev = nev0;
*np = np0;
igraphdsgets_(ishift, which, nev, np, &ritz[1], &bounds[1], &workl[1]);
/* %-------------------%
| Convergence test. |
%-------------------% */
igraphdcopy_(nev, &bounds[*np + 1], &c__1, &workl[*np + 1], &c__1);
igraphdsconv_(nev, &ritz[*np + 1], &workl[*np + 1], tol, &nconv);
if (msglvl > 2) {
kp[0] = *nev;
kp[1] = *np;
kp[2] = nconv;
igraphivout_(&logfil, &c__3, kp, &ndigit, "_saup2: NEV, NP, NCONV are", (
ftnlen)26);
igraphdvout_(&logfil, &kplusp, &ritz[1], &ndigit, "_saup2: The eigenvalues"
" of H", (ftnlen)28);
igraphdvout_(&logfil, &kplusp, &bounds[1], &ndigit, "_saup2: Ritz estimate"
"s of the current NCV Ritz values", (ftnlen)53);
}
/* %---------------------------------------------------------%
| Count the number of unwanted Ritz values that have zero |
| Ritz estimates. If any Ritz estimates are equal to zero |
| then a leading block of H of order equal to at least |
| the number of Ritz values with zero Ritz estimates has |
| split off. None of these Ritz values may be removed by |
| shifting. Decrease NP the number of shifts to apply. If |
| no shifts may be applied, then prepare to exit |
%---------------------------------------------------------% */
nptemp = *np;
i__1 = nptemp;
for (j = 1; j <= i__1; ++j) {
if (bounds[j] == 0.) {
--(*np);
++(*nev);
}
/* L30: */
}
if (nconv >= nev0 || iter > *mxiter || *np == 0) {
/* %------------------------------------------------%
| Prepare to exit. Put the converged Ritz values |
| and corresponding bounds in RITZ(1:NCONV) and |
| BOUNDS(1:NCONV) respectively. Then sort. Be |
| careful when NCONV > NP since we don't want to |
| swap overlapping locations. |
%------------------------------------------------% */
if (s_cmp(which, "BE", (ftnlen)2, (ftnlen)2) == 0) {
/* %-----------------------------------------------------%
| Both ends of the spectrum are requested. |
| Sort the eigenvalues into algebraically decreasing |
| order first then swap low end of the spectrum next |
| to high end in appropriate locations. |
| NOTE: when np < floor(nev/2) be careful not to swap |
| overlapping locations. |
%-----------------------------------------------------% */
s_copy(wprime, "SA", (ftnlen)2, (ftnlen)2);
igraphdsortr_(wprime, &c_true, &kplusp, &ritz[1], &bounds[1])
;
nevd2 = *nev / 2;
nevm2 = *nev - nevd2;
if (*nev > 1) {
i__1 = min(nevd2,*np);
/* Computing MAX */
i__2 = kplusp - nevd2 + 1, i__3 = kplusp - *np + 1;
igraphdswap_(&i__1, &ritz[nevm2 + 1], &c__1, &ritz[max(i__2,i__3)],
&c__1);
i__1 = min(nevd2,*np);
/* Computing MAX */
i__2 = kplusp - nevd2 + 1, i__3 = kplusp - *np;
igraphdswap_(&i__1, &bounds[nevm2 + 1], &c__1, &bounds[max(i__2,
i__3) + 1], &c__1);
}
} else {
/* %--------------------------------------------------%
| LM, SM, LA, SA case. |
| Sort the eigenvalues of H into the an order that |
| is opposite to WHICH, and apply the resulting |
| order to BOUNDS. The eigenvalues are sorted so |
| that the wanted part are always within the first |
| NEV locations. |
%--------------------------------------------------% */
if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "SM", (ftnlen)2, (ftnlen)2);
}
if (s_cmp(which, "SM", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "LM", (ftnlen)2, (ftnlen)2);
}
if (s_cmp(which, "LA", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "SA", (ftnlen)2, (ftnlen)2);
}
if (s_cmp(which, "SA", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "LA", (ftnlen)2, (ftnlen)2);
}
igraphdsortr_(wprime, &c_true, &kplusp, &ritz[1], &bounds[1])
;
}
/* %--------------------------------------------------%
| Scale the Ritz estimate of each Ritz value |
| by 1 / max(eps23,magnitude of the Ritz value). |
%--------------------------------------------------% */
i__1 = nev0;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
d__2 = eps23, d__3 = (d__1 = ritz[j], abs(d__1));
temp = max(d__2,d__3);
bounds[j] /= temp;
/* L35: */
}
/* %----------------------------------------------------%
| Sort the Ritz values according to the scaled Ritz |
| esitmates. This will push all the converged ones |
| towards the front of ritzr, ritzi, bounds |
| (in the case when NCONV < NEV.) |
%----------------------------------------------------% */
s_copy(wprime, "LA", (ftnlen)2, (ftnlen)2);
igraphdsortr_(wprime, &c_true, &nev0, &bounds[1], &ritz[1]);
/* %----------------------------------------------%
| Scale the Ritz estimate back to its original |
| value. |
%----------------------------------------------% */
i__1 = nev0;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
d__2 = eps23, d__3 = (d__1 = ritz[j], abs(d__1));
temp = max(d__2,d__3);
bounds[j] *= temp;
/* L40: */
}
/* %--------------------------------------------------%
| Sort the "converged" Ritz values again so that |
| the "threshold" values and their associated Ritz |
| estimates appear at the appropriate position in |
| ritz and bound. |
%--------------------------------------------------% */
if (s_cmp(which, "BE", (ftnlen)2, (ftnlen)2) == 0) {
/* %------------------------------------------------%
| Sort the "converged" Ritz values in increasing |
| order. The "threshold" values are in the |
| middle. |
%------------------------------------------------% */
s_copy(wprime, "LA", (ftnlen)2, (ftnlen)2);
igraphdsortr_(wprime, &c_true, &nconv, &ritz[1], &bounds[1]);
} else {
/* %----------------------------------------------%
| In LM, SM, LA, SA case, sort the "converged" |
| Ritz values according to WHICH so that the |
| "threshold" value appears at the front of |
| ritz. |
%----------------------------------------------% */
igraphdsortr_(which, &c_true, &nconv, &ritz[1], &bounds[1]);
}
/* %------------------------------------------%
| Use h( 1,1 ) as storage to communicate |
| rnorm to _seupd if needed |
%------------------------------------------% */
h__[h_dim1 + 1] = rnorm;
if (msglvl > 1) {
igraphdvout_(&logfil, &kplusp, &ritz[1], &ndigit, "_saup2: Sorted Ritz"
" values.", (ftnlen)27);
igraphdvout_(&logfil, &kplusp, &bounds[1], &ndigit, "_saup2: Sorted ri"
"tz estimates.", (ftnlen)30);
}
/* %------------------------------------%
| Max iterations have been exceeded. |
%------------------------------------% */
if (iter > *mxiter && nconv < *nev) {
*info = 1;
}
/* %---------------------%
| No shifts to apply. |
%---------------------% */
if (*np == 0 && nconv < nev0) {
*info = 2;
}
*np = nconv;
goto L1100;
} else if (nconv < *nev && *ishift == 1) {
/* %---------------------------------------------------%
| Do not have all the requested eigenvalues yet. |
| To prevent possible stagnation, adjust the number |
| of Ritz values and the shifts. |
%---------------------------------------------------% */
nevbef = *nev;
/* Computing MIN */
i__1 = nconv, i__2 = *np / 2;
*nev += min(i__1,i__2);
if (*nev == 1 && kplusp >= 6) {
*nev = kplusp / 2;
} else if (*nev == 1 && kplusp > 2) {
*nev = 2;
}
*np = kplusp - *nev;
/* %---------------------------------------%
| If the size of NEV was just increased |
| resort the eigenvalues. |
%---------------------------------------% */
if (nevbef < *nev) {
igraphdsgets_(ishift, which, nev, np, &ritz[1], &bounds[1], &workl[1]);
}
}
if (msglvl > 0) {
igraphivout_(&logfil, &c__1, &nconv, &ndigit, "_saup2: no. of \"converge"
"d\" Ritz values at this iter.", (ftnlen)52);
if (msglvl > 1) {
kp[0] = *nev;
kp[1] = *np;
igraphivout_(&logfil, &c__2, kp, &ndigit, "_saup2: NEV and NP are", (
ftnlen)22);
igraphdvout_(&logfil, nev, &ritz[*np + 1], &ndigit, "_saup2: \"wante"
"d\" Ritz values.", (ftnlen)29);
igraphdvout_(&logfil, nev, &bounds[*np + 1], &ndigit, "_saup2: Ritz es"
"timates of the \"wanted\" values ", (ftnlen)46);
}
}
if (*ishift == 0) {
/* %-----------------------------------------------------%
| User specified shifts: reverse communication to |
| compute the shifts. They are returned in the first |
| NP locations of WORKL. |
%-----------------------------------------------------% */
ushift = TRUE_;
*ido = 3;
goto L9000;
}
L50:
/* %------------------------------------%
| Back from reverse communication; |
| User specified shifts are returned |
| in WORKL(1:*NP) |
%------------------------------------% */
ushift = FALSE_;
/* %---------------------------------------------------------%
| Move the NP shifts to the first NP locations of RITZ to |
| free up WORKL. This is for the non-exact shift case; |
| in the exact shift case, dsgets already handles this. |
%---------------------------------------------------------% */
if (*ishift == 0) {
igraphdcopy_(np, &workl[1], &c__1, &ritz[1], &c__1);
}
if (msglvl > 2) {
igraphivout_(&logfil, &c__1, np, &ndigit, "_saup2: The number of shifts to"
" apply ", (ftnlen)38);
igraphdvout_(&logfil, np, &workl[1], &ndigit, "_saup2: shifts selected", (
ftnlen)23);
if (*ishift == 1) {
igraphdvout_(&logfil, np, &bounds[1], &ndigit, "_saup2: corresponding "
"Ritz estimates", (ftnlen)36);
}
}
/* %---------------------------------------------------------%
| Apply the NP0 implicit shifts by QR bulge chasing. |
| Each shift is applied to the entire tridiagonal matrix. |
| The first 2*N locations of WORKD are used as workspace. |
| After dsapps is done, we have a Lanczos |
| factorization of length NEV. |
%---------------------------------------------------------% */
igraphdsapps_(n, nev, np, &ritz[1], &v[v_offset], ldv, &h__[h_offset], ldh, &
resid[1], &q[q_offset], ldq, &workd[1]);
/* %---------------------------------------------%
| Compute the B-norm of the updated residual. |
| Keep B*RESID in WORKD(1:N) to be used in |
| the first step of the next call to dsaitr. |
%---------------------------------------------% */
cnorm = TRUE_;
igraphsecond_(&t2);
if (*(unsigned char *)bmat == 'G') {
++nbx;
igraphdcopy_(n, &resid[1], &c__1, &workd[*n + 1], &c__1);
ipntr[1] = *n + 1;
ipntr[2] = 1;
*ido = 2;
/* %----------------------------------%
| Exit in order to compute B*RESID |
%----------------------------------% */
goto L9000;
} else if (*(unsigned char *)bmat == 'I') {
igraphdcopy_(n, &resid[1], &c__1, &workd[1], &c__1);
}
L100:
/* %----------------------------------%
| Back from reverse communication; |
| WORKD(1:N) := B*RESID |
%----------------------------------% */
if (*(unsigned char *)bmat == 'G') {
igraphsecond_(&t3);
tmvbx += t3 - t2;
}
if (*(unsigned char *)bmat == 'G') {
rnorm = igraphddot_(n, &resid[1], &c__1, &workd[1], &c__1);
rnorm = sqrt((abs(rnorm)));
} else if (*(unsigned char *)bmat == 'I') {
rnorm = igraphdnrm2_(n, &resid[1], &c__1);
}
cnorm = FALSE_;
/* L130: */
if (msglvl > 2) {
igraphdvout_(&logfil, &c__1, &rnorm, &ndigit, "_saup2: B-norm of residual "
"for NEV factorization", (ftnlen)48);
igraphdvout_(&logfil, nev, &h__[(h_dim1 << 1) + 1], &ndigit, "_saup2: main"
" diagonal of compressed H matrix", (ftnlen)44);
i__1 = *nev - 1;
igraphdvout_(&logfil, &i__1, &h__[h_dim1 + 2], &ndigit, "_saup2: subdiagon"
"al of compressed H matrix", (ftnlen)42);
}
goto L1000;
/* %---------------------------------------------------------------%
| |
| E N D O F M A I N I T E R A T I O N L O O P |
| |
%---------------------------------------------------------------% */
L1100:
*mxiter = iter;
*nev = nconv;
L1200:
*ido = 99;
/* %------------%
| Error exit |
%------------% */
igraphsecond_(&t1);
tsaup2 = t1 - t0;
L9000:
return 0;
/* %---------------%
| End of dsaup2 |
%---------------% */
} /* igraphdsaup2_ */