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 igraphdlaexc_(logical *wantq, integer *n, doublereal *t,
integer *ldt, doublereal *q, integer *ldq, integer *j1, integer *n1,
integer *n2, doublereal *work, integer *info)
{
/* System generated locals */
integer q_dim1, q_offset, t_dim1, t_offset, i__1;
doublereal d__1, d__2, d__3;
/* Local variables */
doublereal d__[16] /* was [4][4] */;
integer k;
doublereal u[3], x[4] /* was [2][2] */;
integer j2, j3, j4;
doublereal u1[3], u2[3];
integer nd;
doublereal cs, t11, t22, t33, sn, wi1, wi2, wr1, wr2, eps, tau, tau1,
tau2;
integer ierr;
doublereal temp;
extern /* Subroutine */ int igraphdrot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
doublereal scale, dnorm, xnorm;
extern /* Subroutine */ int igraphdlanv2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *), igraphdlasy2_(
logical *, logical *, integer *, integer *, integer *, doublereal
*, integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *);
extern doublereal igraphdlamch_(char *), igraphdlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int igraphdlarfg_(integer *, doublereal *, doublereal *,
integer *, doublereal *), igraphdlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
igraphdlartg_(doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *), igraphdlarfx_(char *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *);
doublereal thresh, smlnum;
/* -- LAPACK auxiliary 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
=======
DLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in
an upper quasi-triangular matrix T by an orthogonal similarity
transformation.
T must be in Schur canonical form, that is, block upper triangular
with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block
has its diagonal elemnts equal and its off-diagonal elements of
opposite sign.
Arguments
=========
WANTQ (input) LOGICAL
= .TRUE. : accumulate the transformation in the matrix Q;
= .FALSE.: do not accumulate the transformation.
N (input) INTEGER
The order of the matrix T. N >= 0.
T (input/output) DOUBLE PRECISION array, dimension (LDT,N)
On entry, the upper quasi-triangular matrix T, in Schur
canonical form.
On exit, the updated matrix T, again in Schur canonical form.
LDT (input) INTEGER
The leading dimension of the array T. LDT >= max(1,N).
Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
On entry, if WANTQ is .TRUE., the orthogonal matrix Q.
On exit, if WANTQ is .TRUE., the updated matrix Q.
If WANTQ is .FALSE., Q is not referenced.
LDQ (input) INTEGER
The leading dimension of the array Q.
LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N.
J1 (input) INTEGER
The index of the first row of the first block T11.
N1 (input) INTEGER
The order of the first block T11. N1 = 0, 1 or 2.
N2 (input) INTEGER
The order of the second block T22. N2 = 0, 1 or 2.
WORK (workspace) DOUBLE PRECISION array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
= 1: the transformed matrix T would be too far from Schur
form; the blocks are not swapped and T and Q are
unchanged.
=====================================================================
Parameter adjustments */
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--work;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0 || *n1 == 0 || *n2 == 0) {
return 0;
}
if (*j1 + *n1 > *n) {
return 0;
}
j2 = *j1 + 1;
j3 = *j1 + 2;
j4 = *j1 + 3;
if (*n1 == 1 && *n2 == 1) {
/* Swap two 1-by-1 blocks. */
t11 = t[*j1 + *j1 * t_dim1];
t22 = t[j2 + j2 * t_dim1];
/* Determine the transformation to perform the interchange. */
d__1 = t22 - t11;
igraphdlartg_(&t[*j1 + j2 * t_dim1], &d__1, &cs, &sn, &temp);
/* Apply transformation to the matrix T. */
if (j3 <= *n) {
i__1 = *n - *j1 - 1;
igraphdrot_(&i__1, &t[*j1 + j3 * t_dim1], ldt, &t[j2 + j3 * t_dim1],
ldt, &cs, &sn);
}
i__1 = *j1 - 1;
igraphdrot_(&i__1, &t[*j1 * t_dim1 + 1], &c__1, &t[j2 * t_dim1 + 1], &c__1,
&cs, &sn);
t[*j1 + *j1 * t_dim1] = t22;
t[j2 + j2 * t_dim1] = t11;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
igraphdrot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[j2 * q_dim1 + 1], &c__1,
&cs, &sn);
}
} else {
/* Swapping involves at least one 2-by-2 block.
Copy the diagonal block of order N1+N2 to the local array D
and compute its norm. */
nd = *n1 + *n2;
igraphdlacpy_("Full", &nd, &nd, &t[*j1 + *j1 * t_dim1], ldt, d__, &c__4);
dnorm = igraphdlange_("Max", &nd, &nd, d__, &c__4, &work[1]);
/* Compute machine-dependent threshold for test for accepting
swap. */
eps = igraphdlamch_("P");
smlnum = igraphdlamch_("S") / eps;
/* Computing MAX */
d__1 = eps * 10. * dnorm;
thresh = max(d__1,smlnum);
/* Solve T11*X - X*T22 = scale*T12 for X. */
igraphdlasy2_(&c_false, &c_false, &c_n1, n1, n2, d__, &c__4, &d__[*n1 + 1 +
(*n1 + 1 << 2) - 5], &c__4, &d__[(*n1 + 1 << 2) - 4], &c__4, &
scale, x, &c__2, &xnorm, &ierr);
/* Swap the adjacent diagonal blocks. */
k = *n1 + *n1 + *n2 - 3;
switch (k) {
case 1: goto L10;
case 2: goto L20;
case 3: goto L30;
}
L10:
/* N1 = 1, N2 = 2: generate elementary reflector H so that:
( scale, X11, X12 ) H = ( 0, 0, * ) */
u[0] = scale;
u[1] = x[0];
u[2] = x[2];
igraphdlarfg_(&c__3, &u[2], u, &c__1, &tau);
u[2] = 1.;
t11 = t[*j1 + *j1 * t_dim1];
/* Perform swap provisionally on diagonal block in D. */
igraphdlarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
igraphdlarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
/* Test whether to reject swap.
Computing MAX */
d__2 = abs(d__[2]), d__3 = abs(d__[6]), d__2 = max(d__2,d__3), d__3 =
(d__1 = d__[10] - t11, abs(d__1));
if (max(d__2,d__3) > thresh) {
goto L50;
}
/* Accept swap: apply transformation to the entire matrix T. */
i__1 = *n - *j1 + 1;
igraphdlarfx_("L", &c__3, &i__1, u, &tau, &t[*j1 + *j1 * t_dim1], ldt, &
work[1]);
igraphdlarfx_("R", &j2, &c__3, u, &tau, &t[*j1 * t_dim1 + 1], ldt, &work[1]);
t[j3 + *j1 * t_dim1] = 0.;
t[j3 + j2 * t_dim1] = 0.;
t[j3 + j3 * t_dim1] = t11;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
igraphdlarfx_("R", n, &c__3, u, &tau, &q[*j1 * q_dim1 + 1], ldq, &work[
1]);
}
goto L40;
L20:
/* N1 = 2, N2 = 1: generate elementary reflector H so that:
H ( -X11 ) = ( * )
( -X21 ) = ( 0 )
( scale ) = ( 0 ) */
u[0] = -x[0];
u[1] = -x[1];
u[2] = scale;
igraphdlarfg_(&c__3, u, &u[1], &c__1, &tau);
u[0] = 1.;
t33 = t[j3 + j3 * t_dim1];
/* Perform swap provisionally on diagonal block in D. */
igraphdlarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
igraphdlarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
/* Test whether to reject swap.
Computing MAX */
d__2 = abs(d__[1]), d__3 = abs(d__[2]), d__2 = max(d__2,d__3), d__3 =
(d__1 = d__[0] - t33, abs(d__1));
if (max(d__2,d__3) > thresh) {
goto L50;
}
/* Accept swap: apply transformation to the entire matrix T. */
igraphdlarfx_("R", &j3, &c__3, u, &tau, &t[*j1 * t_dim1 + 1], ldt, &work[1]);
i__1 = *n - *j1;
igraphdlarfx_("L", &c__3, &i__1, u, &tau, &t[*j1 + j2 * t_dim1], ldt, &work[
1]);
t[*j1 + *j1 * t_dim1] = t33;
t[j2 + *j1 * t_dim1] = 0.;
t[j3 + *j1 * t_dim1] = 0.;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
igraphdlarfx_("R", n, &c__3, u, &tau, &q[*j1 * q_dim1 + 1], ldq, &work[
1]);
}
goto L40;
L30:
/* N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so
that:
H(2) H(1) ( -X11 -X12 ) = ( * * )
( -X21 -X22 ) ( 0 * )
( scale 0 ) ( 0 0 )
( 0 scale ) ( 0 0 ) */
u1[0] = -x[0];
u1[1] = -x[1];
u1[2] = scale;
igraphdlarfg_(&c__3, u1, &u1[1], &c__1, &tau1);
u1[0] = 1.;
temp = -tau1 * (x[2] + u1[1] * x[3]);
u2[0] = -temp * u1[1] - x[3];
u2[1] = -temp * u1[2];
u2[2] = scale;
igraphdlarfg_(&c__3, u2, &u2[1], &c__1, &tau2);
u2[0] = 1.;
/* Perform swap provisionally on diagonal block in D. */
igraphdlarfx_("L", &c__3, &c__4, u1, &tau1, d__, &c__4, &work[1])
;
igraphdlarfx_("R", &c__4, &c__3, u1, &tau1, d__, &c__4, &work[1])
;
igraphdlarfx_("L", &c__3, &c__4, u2, &tau2, &d__[1], &c__4, &work[1]);
igraphdlarfx_("R", &c__4, &c__3, u2, &tau2, &d__[4], &c__4, &work[1]);
/* Test whether to reject swap.
Computing MAX */
d__1 = abs(d__[2]), d__2 = abs(d__[6]), d__1 = max(d__1,d__2), d__2 =
abs(d__[3]), d__1 = max(d__1,d__2), d__2 = abs(d__[7]);
if (max(d__1,d__2) > thresh) {
goto L50;
}
/* Accept swap: apply transformation to the entire matrix T. */
i__1 = *n - *j1 + 1;
igraphdlarfx_("L", &c__3, &i__1, u1, &tau1, &t[*j1 + *j1 * t_dim1], ldt, &
work[1]);
igraphdlarfx_("R", &j4, &c__3, u1, &tau1, &t[*j1 * t_dim1 + 1], ldt, &work[
1]);
i__1 = *n - *j1 + 1;
igraphdlarfx_("L", &c__3, &i__1, u2, &tau2, &t[j2 + *j1 * t_dim1], ldt, &
work[1]);
igraphdlarfx_("R", &j4, &c__3, u2, &tau2, &t[j2 * t_dim1 + 1], ldt, &work[1]
);
t[j3 + *j1 * t_dim1] = 0.;
t[j3 + j2 * t_dim1] = 0.;
t[j4 + *j1 * t_dim1] = 0.;
t[j4 + j2 * t_dim1] = 0.;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
igraphdlarfx_("R", n, &c__3, u1, &tau1, &q[*j1 * q_dim1 + 1], ldq, &
work[1]);
igraphdlarfx_("R", n, &c__3, u2, &tau2, &q[j2 * q_dim1 + 1], ldq, &work[
1]);
}
L40:
if (*n2 == 2) {
/* Standardize new 2-by-2 block T11 */
igraphdlanv2_(&t[*j1 + *j1 * t_dim1], &t[*j1 + j2 * t_dim1], &t[j2 + *
j1 * t_dim1], &t[j2 + j2 * t_dim1], &wr1, &wi1, &wr2, &
wi2, &cs, &sn);
i__1 = *n - *j1 - 1;
igraphdrot_(&i__1, &t[*j1 + (*j1 + 2) * t_dim1], ldt, &t[j2 + (*j1 + 2)
* t_dim1], ldt, &cs, &sn);
i__1 = *j1 - 1;
igraphdrot_(&i__1, &t[*j1 * t_dim1 + 1], &c__1, &t[j2 * t_dim1 + 1], &
c__1, &cs, &sn);
if (*wantq) {
igraphdrot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[j2 * q_dim1 + 1], &
c__1, &cs, &sn);
}
}
if (*n1 == 2) {
/* Standardize new 2-by-2 block T22 */
j3 = *j1 + *n2;
j4 = j3 + 1;
igraphdlanv2_(&t[j3 + j3 * t_dim1], &t[j3 + j4 * t_dim1], &t[j4 + j3 *
t_dim1], &t[j4 + j4 * t_dim1], &wr1, &wi1, &wr2, &wi2, &
cs, &sn);
if (j3 + 2 <= *n) {
i__1 = *n - j3 - 1;
igraphdrot_(&i__1, &t[j3 + (j3 + 2) * t_dim1], ldt, &t[j4 + (j3 + 2)
* t_dim1], ldt, &cs, &sn);
}
i__1 = j3 - 1;
igraphdrot_(&i__1, &t[j3 * t_dim1 + 1], &c__1, &t[j4 * t_dim1 + 1], &
c__1, &cs, &sn);
if (*wantq) {
igraphdrot_(n, &q[j3 * q_dim1 + 1], &c__1, &q[j4 * q_dim1 + 1], &
c__1, &cs, &sn);
}
}
}
return 0;
/* Exit with INFO = 1 if swap was rejected. */
L50:
*info = 1;
return 0;
/* End of DLAEXC */
} /* igraphdlaexc_ */
Subroutine */ int igraphdnaupd_(integer *ido, 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)
{
/* Format strings */
static char fmt_1000[] = "(//,5x,\002==================================="
"==========\002,/5x,\002= Nonsymmetric implicit Arnoldi update co"
"de =\002,/5x,\002= Version Number: \002,\002 2.4\002,21x,\002 "
"=\002,/5x,\002= Version Date: \002,\002 07/31/96\002,16x,\002 ="
"\002,/5x,\002=============================================\002,/"
"5x,\002= Summary of timing statistics =\002,/5x,"
"\002=============================================\002,//)";
static char fmt_1100[] = "(5x,\002Total number update iterations "
" = \002,i5,/5x,\002Total number of OP*x operations "
" = \002,i5,/5x,\002Total number of B*x operations = "
"\002,i5,/5x,\002Total number of reorthogonalization steps = "
"\002,i5,/5x,\002Total number of iterative refinement steps = "
"\002,i5,/5x,\002Total number of restart steps = "
"\002,i5,/5x,\002Total time in user OP*x operation = "
"\002,f12.6,/5x,\002Total time in user B*x operation ="
" \002,f12.6,/5x,\002Total time in Arnoldi update routine = "
"\002,f12.6,/5x,\002Total time in naup2 routine ="
" \002,f12.6,/5x,\002Total time in basic Arnoldi iteration loop = "
"\002,f12.6,/5x,\002Total time in reorthogonalization phase ="
" \002,f12.6,/5x,\002Total time in (re)start vector generation = "
"\002,f12.6,/5x,\002Total time in Hessenberg eig. subproblem ="
" \002,f12.6,/5x,\002Total time in getting the shifts = "
"\002,f12.6,/5x,\002Total time in applying the shifts ="
" \002,f12.6,/5x,\002Total time in convergence testing = "
"\002,f12.6,/5x,\002Total time in computing final Ritz vectors ="
" \002,f12.6/)";
/* System generated locals */
integer v_dim1, v_offset, i__1, i__2;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), e_wsfe(
void), do_fio(integer *, char *, ftnlen);
/* Local variables */
integer j;
real t0, t1;
IGRAPH_F77_SAVE integer nb, ih, iq, np, iw, ldh, ldq;
integer nbx = 0;
IGRAPH_F77_SAVE integer nev0, mode;
integer ierr;
IGRAPH_F77_SAVE integer iupd, next;
integer nopx = 0;
IGRAPH_F77_SAVE integer levec;
real trvec, tmvbx;
IGRAPH_F77_SAVE integer ritzi;
extern /* Subroutine */ int igraphdvout_(integer *, integer *, doublereal *,
integer *, char *, ftnlen), igraphivout_(integer *, integer *, integer *
, integer *, char *, ftnlen);
IGRAPH_F77_SAVE integer ritzr;
extern /* Subroutine */ int igraphdnaup2_(integer *, char *, integer *, char *,
integer *, integer *, doublereal *, doublereal *, integer *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
real tnaup2, tgetv0;
extern doublereal igraphdlamch_(char *);
extern /* Subroutine */ int igraphsecond_(real *);
integer logfil, ndigit;
real tneigh;
integer mnaupd = 0;
IGRAPH_F77_SAVE integer ishift;
integer nitref;
IGRAPH_F77_SAVE integer bounds;
real tnaupd;
extern /* Subroutine */ int igraphdstatn_(void);
real titref, tnaitr;
IGRAPH_F77_SAVE integer msglvl;
real tngets, tnapps, tnconv;
IGRAPH_F77_SAVE integer mxiter;
integer nrorth = 0, nrstrt = 0;
real tmvopx;
/* Fortran I/O blocks */
static cilist io___30 = { 0, 6, 0, fmt_1000, 0 };
static cilist io___31 = { 0, 6, 0, fmt_1100, 0 };
/* %----------------------------------------------------%
| Include files for debugging and timing information |
%----------------------------------------------------%
%------------------%
| Scalar Arguments |
%------------------%
%-----------------%
| Array Arguments |
%-----------------%
%------------%
| Parameters |
%------------%
%---------------%
| Local Scalars |
%---------------%
%----------------------%
| External Subroutines |
%----------------------%
%--------------------%
| External Functions |
%--------------------%
%-----------------------%
| Executable Statements |
%-----------------------%
Parameter adjustments */
--workd;
--resid;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--iparam;
--ipntr;
--workl;
/* Function Body */
if (*ido == 0) {
/* %-------------------------------%
| Initialize timing statistics |
| & message level for debugging |
%-------------------------------% */
igraphdstatn_();
igraphsecond_(&t0);
msglvl = mnaupd;
/* %----------------%
| Error checking |
%----------------% */
ierr = 0;
ishift = iparam[1];
levec = iparam[2];
mxiter = iparam[3];
nb = iparam[4];
/* %--------------------------------------------%
| Revision 2 performs only implicit restart. |
%--------------------------------------------% */
iupd = 1;
mode = iparam[7];
if (*n <= 0) {
ierr = -1;
} else if (*nev <= 0) {
ierr = -2;
} else if (*ncv <= *nev + 1 || *ncv > *n) {
ierr = -3;
} else if (mxiter <= 0) {
ierr = -4;
} else if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(
which, "SM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "LR",
(ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "SR", (ftnlen)2, (
ftnlen)2) != 0 && s_cmp(which, "LI", (ftnlen)2, (ftnlen)2) !=
0 && s_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 (mode < 1 || mode > 5) {
ierr = -10;
} else if (mode == 1 && *(unsigned char *)bmat == 'G') {
ierr = -11;
} else if (ishift < 0 || ishift > 1) {
ierr = -12;
}
}
/* %------------%
| Error Exit |
%------------% */
if (ierr != 0) {
*info = ierr;
*ido = 99;
goto L9000;
}
/* %------------------------%
| Set default parameters |
%------------------------% */
if (nb <= 0) {
nb = 1;
}
if (*tol <= 0.) {
*tol = igraphdlamch_("EpsMach");
}
/* %----------------------------------------------%
| NP is the number of additional steps to |
| extend the length NEV Lanczos factorization. |
| NEV0 is the local variable designating the |
| size of the invariant subspace desired. |
%----------------------------------------------% */
np = *ncv - *nev;
nev0 = *nev;
/* %-----------------------------%
| Zero out internal workspace |
%-----------------------------%
Computing 2nd power */
i__2 = *ncv;
i__1 = i__2 * i__2 * 3 + *ncv * 6;
for (j = 1; j <= i__1; ++j) {
workl[j] = 0.;
/* L10: */
}
/* %-------------------------------------------------------------%
| 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 |
| workl(ncv*ncv+3*ncv+1:2*ncv*ncv+3*ncv) := rotation matrix Q |
| workl(2*ncv*ncv+3*ncv+1:3*ncv*ncv+6*ncv) := workspace |
| The final workspace is needed by subroutine dneigh called |
| by dnaup2. Subroutine dneigh calls LAPACK routines for |
| calculating eigenvalues and the last row of the eigenvector |
| matrix. |
%-------------------------------------------------------------% */
ldh = *ncv;
ldq = *ncv;
ih = 1;
ritzr = ih + ldh * *ncv;
ritzi = ritzr + *ncv;
bounds = ritzi + *ncv;
iq = bounds + *ncv;
iw = iq + ldq * *ncv;
/* Computing 2nd power */
i__1 = *ncv;
next = iw + i__1 * i__1 + *ncv * 3;
ipntr[4] = next;
ipntr[5] = ih;
ipntr[6] = ritzr;
ipntr[7] = ritzi;
ipntr[8] = bounds;
ipntr[14] = iw;
}
/* %-------------------------------------------------------%
| Carry out the Implicitly restarted Arnoldi Iteration. |
%-------------------------------------------------------% */
igraphdnaup2_(ido, bmat, n, which, &nev0, &np, tol, &resid[1], &mode, &iupd, &
ishift, &mxiter, &v[v_offset], ldv, &workl[ih], &ldh, &workl[
ritzr], &workl[ritzi], &workl[bounds], &workl[iq], &ldq, &workl[
iw], &ipntr[1], &workd[1], info);
/* %--------------------------------------------------%
| ido .ne. 99 implies use of reverse communication |
| to compute operations involving OP or shifts. |
%--------------------------------------------------% */
if (*ido == 3) {
iparam[8] = np;
}
if (*ido != 99) {
goto L9000;
}
iparam[3] = mxiter;
iparam[5] = np;
iparam[9] = nopx;
iparam[10] = nbx;
iparam[11] = nrorth;
/* %------------------------------------%
| Exit if there was an informational |
| error within dnaup2. |
%------------------------------------% */
if (*info < 0) {
goto L9000;
}
if (*info == 2) {
*info = 3;
}
if (msglvl > 0) {
igraphivout_(&logfil, &c__1, &mxiter, &ndigit, "_naupd: Number of update i"
"terations taken", (ftnlen)41);
igraphivout_(&logfil, &c__1, &np, &ndigit, "_naupd: Number of wanted \"con"
"verged\" Ritz values", (ftnlen)48);
igraphdvout_(&logfil, &np, &workl[ritzr], &ndigit, "_naupd: Real part of t"
"he final Ritz values", (ftnlen)42);
igraphdvout_(&logfil, &np, &workl[ritzi], &ndigit, "_naupd: Imaginary part"
" of the final Ritz values", (ftnlen)47);
igraphdvout_(&logfil, &np, &workl[bounds], &ndigit, "_naupd: Associated Ri"
"tz estimates", (ftnlen)33);
}
igraphsecond_(&t1);
tnaupd = t1 - t0;
if (msglvl > 0) {
/* %--------------------------------------------------------%
| Version Number & Version Date are defined in version.h |
%--------------------------------------------------------% */
s_wsfe(&io___30);
e_wsfe();
s_wsfe(&io___31);
do_fio(&c__1, (char *)&mxiter, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nopx, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nbx, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nrorth, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nitref, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nrstrt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&tmvopx, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&tmvbx, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&tnaupd, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&tnaup2, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&tnaitr, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&titref, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&tgetv0, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&tneigh, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&tngets, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&tnapps, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&tnconv, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&trvec, (ftnlen)sizeof(real));
e_wsfe();
}
L9000:
return 0;
/* %---------------%
| End of dnaupd |
%---------------% */
} /* igraphdnaupd_ */
Subroutine */ int igraphdlartg_(doublereal *f, doublereal *g, doublereal *cs,
doublereal *sn, doublereal *r__)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
/* Builtin functions */
double log(doublereal), pow_di(doublereal *, integer *), sqrt(doublereal);
/* Local variables */
integer i__;
doublereal f1, g1, eps, scale;
integer count;
doublereal safmn2, safmx2;
extern doublereal igraphdlamch_(char *);
doublereal safmin;
/* -- 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
=====================================================================
LOGICAL FIRST
SAVE FIRST, SAFMX2, SAFMIN, SAFMN2
DATA FIRST / .TRUE. /
IF( FIRST ) THEN */
safmin = igraphdlamch_("S");
eps = igraphdlamch_("E");
d__1 = igraphdlamch_("B");
i__1 = (integer) (log(safmin / eps) / log(igraphdlamch_("B")) / 2.);
safmn2 = pow_di(&d__1, &i__1);
safmx2 = 1. / safmn2;
/* FIRST = .FALSE.
END IF */
if (*g == 0.) {
*cs = 1.;
*sn = 0.;
*r__ = *f;
} else if (*f == 0.) {
*cs = 0.;
*sn = 1.;
*r__ = *g;
} else {
f1 = *f;
g1 = *g;
/* Computing MAX */
d__1 = abs(f1), d__2 = abs(g1);
scale = max(d__1,d__2);
if (scale >= safmx2) {
count = 0;
L10:
++count;
f1 *= safmn2;
g1 *= safmn2;
/* Computing MAX */
d__1 = abs(f1), d__2 = abs(g1);
scale = max(d__1,d__2);
if (scale >= safmx2) {
goto L10;
}
/* Computing 2nd power */
d__1 = f1;
/* Computing 2nd power */
d__2 = g1;
*r__ = sqrt(d__1 * d__1 + d__2 * d__2);
*cs = f1 / *r__;
*sn = g1 / *r__;
i__1 = count;
for (i__ = 1; i__ <= i__1; ++i__) {
*r__ *= safmx2;
/* L20: */
}
} else if (scale <= safmn2) {
count = 0;
L30:
++count;
f1 *= safmx2;
g1 *= safmx2;
/* Computing MAX */
d__1 = abs(f1), d__2 = abs(g1);
scale = max(d__1,d__2);
if (scale <= safmn2) {
goto L30;
}
/* Computing 2nd power */
d__1 = f1;
/* Computing 2nd power */
d__2 = g1;
*r__ = sqrt(d__1 * d__1 + d__2 * d__2);
*cs = f1 / *r__;
*sn = g1 / *r__;
i__1 = count;
for (i__ = 1; i__ <= i__1; ++i__) {
*r__ *= safmn2;
/* L40: */
}
} else {
/* Computing 2nd power */
d__1 = f1;
/* Computing 2nd power */
d__2 = g1;
*r__ = sqrt(d__1 * d__1 + d__2 * d__2);
*cs = f1 / *r__;
*sn = g1 / *r__;
}
if (abs(*f) > abs(*g) && *cs < 0.) {
*cs = -(*cs);
*sn = -(*sn);
*r__ = -(*r__);
}
}
return 0;
/* End of DLARTG */
} /* igraphdlartg_ */
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 igraphdlar1v_(integer *n, integer *b1, integer *bn, doublereal
*lambda, doublereal *d__, doublereal *l, doublereal *ld, doublereal *
lld, doublereal *pivmin, doublereal *gaptol, doublereal *z__, logical
*wantnc, integer *negcnt, doublereal *ztz, doublereal *mingma,
integer *r__, integer *isuppz, doublereal *nrminv, doublereal *resid,
doublereal *rqcorr, doublereal *work)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__;
doublereal s;
integer r1, r2;
doublereal eps, tmp;
integer neg1, neg2, indp, inds;
doublereal dplus;
extern doublereal igraphdlamch_(char *);
extern logical igraphdisnan_(doublereal *);
integer indlpl, indumn;
doublereal dminus;
logical sawnan1, sawnan2;
/* -- LAPACK auxiliary 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
=======
DLAR1V computes the (scaled) r-th column of the inverse of
the sumbmatrix in rows B1 through BN of the tridiagonal matrix
L D L**T - sigma I. When sigma is close to an eigenvalue, the
computed vector is an accurate eigenvector. Usually, r corresponds
to the index where the eigenvector is largest in magnitude.
The following steps accomplish this computation :
(a) Stationary qd transform, L D L**T - sigma I = L(+) D(+) L(+)**T,
(b) Progressive qd transform, L D L**T - sigma I = U(-) D(-) U(-)**T,
(c) Computation of the diagonal elements of the inverse of
L D L**T - sigma I by combining the above transforms, and choosing
r as the index where the diagonal of the inverse is (one of the)
largest in magnitude.
(d) Computation of the (scaled) r-th column of the inverse using the
twisted factorization obtained by combining the top part of the
the stationary and the bottom part of the progressive transform.
Arguments
=========
N (input) INTEGER
The order of the matrix L D L**T.
B1 (input) INTEGER
First index of the submatrix of L D L**T.
BN (input) INTEGER
Last index of the submatrix of L D L**T.
LAMBDA (input) DOUBLE PRECISION
The shift. In order to compute an accurate eigenvector,
LAMBDA should be a good approximation to an eigenvalue
of L D L**T.
L (input) DOUBLE PRECISION array, dimension (N-1)
The (n-1) subdiagonal elements of the unit bidiagonal matrix
L, in elements 1 to N-1.
D (input) DOUBLE PRECISION array, dimension (N)
The n diagonal elements of the diagonal matrix D.
LD (input) DOUBLE PRECISION array, dimension (N-1)
The n-1 elements L(i)*D(i).
LLD (input) DOUBLE PRECISION array, dimension (N-1)
The n-1 elements L(i)*L(i)*D(i).
PIVMIN (input) DOUBLE PRECISION
The minimum pivot in the Sturm sequence.
GAPTOL (input) DOUBLE PRECISION
Tolerance that indicates when eigenvector entries are negligible
w.r.t. their contribution to the residual.
Z (input/output) DOUBLE PRECISION array, dimension (N)
On input, all entries of Z must be set to 0.
On output, Z contains the (scaled) r-th column of the
inverse. The scaling is such that Z(R) equals 1.
WANTNC (input) LOGICAL
Specifies whether NEGCNT has to be computed.
NEGCNT (output) INTEGER
If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin
in the matrix factorization L D L**T, and NEGCNT = -1 otherwise.
ZTZ (output) DOUBLE PRECISION
The square of the 2-norm of Z.
MINGMA (output) DOUBLE PRECISION
The reciprocal of the largest (in magnitude) diagonal
element of the inverse of L D L**T - sigma I.
R (input/output) INTEGER
The twist index for the twisted factorization used to
compute Z.
On input, 0 <= R <= N. If R is input as 0, R is set to
the index where (L D L**T - sigma I)^{-1} is largest
in magnitude. If 1 <= R <= N, R is unchanged.
On output, R contains the twist index used to compute Z.
Ideally, R designates the position of the maximum entry in the
eigenvector.
ISUPPZ (output) INTEGER array, dimension (2)
The support of the vector in Z, i.e., the vector Z is
nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).
NRMINV (output) DOUBLE PRECISION
NRMINV = 1/SQRT( ZTZ )
RESID (output) DOUBLE PRECISION
The residual of the FP vector.
RESID = ABS( MINGMA )/SQRT( ZTZ )
RQCORR (output) DOUBLE PRECISION
The Rayleigh Quotient correction to LAMBDA.
RQCORR = MINGMA*TMP
WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
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
=====================================================================
Parameter adjustments */
--work;
--isuppz;
--z__;
--lld;
--ld;
--l;
--d__;
/* Function Body */
eps = igraphdlamch_("Precision");
if (*r__ == 0) {
r1 = *b1;
r2 = *bn;
} else {
r1 = *r__;
r2 = *r__;
}
/* Storage for LPLUS */
indlpl = 0;
/* Storage for UMINUS */
indumn = *n;
inds = (*n << 1) + 1;
indp = *n * 3 + 1;
if (*b1 == 1) {
work[inds] = 0.;
} else {
work[inds + *b1 - 1] = lld[*b1 - 1];
}
/* Compute the stationary transform (using the differential form)
until the index R2. */
sawnan1 = FALSE_;
neg1 = 0;
s = work[inds + *b1 - 1] - *lambda;
i__1 = r1 - 1;
for (i__ = *b1; i__ <= i__1; ++i__) {
dplus = d__[i__] + s;
work[indlpl + i__] = ld[i__] / dplus;
if (dplus < 0.) {
++neg1;
}
work[inds + i__] = s * work[indlpl + i__] * l[i__];
s = work[inds + i__] - *lambda;
/* L50: */
}
sawnan1 = igraphdisnan_(&s);
if (sawnan1) {
goto L60;
}
i__1 = r2 - 1;
for (i__ = r1; i__ <= i__1; ++i__) {
dplus = d__[i__] + s;
work[indlpl + i__] = ld[i__] / dplus;
work[inds + i__] = s * work[indlpl + i__] * l[i__];
s = work[inds + i__] - *lambda;
/* L51: */
}
sawnan1 = igraphdisnan_(&s);
L60:
if (sawnan1) {
/* Runs a slower version of the above loop if a NaN is detected */
neg1 = 0;
s = work[inds + *b1 - 1] - *lambda;
i__1 = r1 - 1;
for (i__ = *b1; i__ <= i__1; ++i__) {
dplus = d__[i__] + s;
if (abs(dplus) < *pivmin) {
dplus = -(*pivmin);
}
work[indlpl + i__] = ld[i__] / dplus;
if (dplus < 0.) {
++neg1;
}
work[inds + i__] = s * work[indlpl + i__] * l[i__];
if (work[indlpl + i__] == 0.) {
work[inds + i__] = lld[i__];
}
s = work[inds + i__] - *lambda;
/* L70: */
}
i__1 = r2 - 1;
for (i__ = r1; i__ <= i__1; ++i__) {
dplus = d__[i__] + s;
if (abs(dplus) < *pivmin) {
dplus = -(*pivmin);
}
work[indlpl + i__] = ld[i__] / dplus;
work[inds + i__] = s * work[indlpl + i__] * l[i__];
if (work[indlpl + i__] == 0.) {
work[inds + i__] = lld[i__];
}
s = work[inds + i__] - *lambda;
/* L71: */
}
}
/* Compute the progressive transform (using the differential form)
until the index R1 */
sawnan2 = FALSE_;
neg2 = 0;
work[indp + *bn - 1] = d__[*bn] - *lambda;
i__1 = r1;
for (i__ = *bn - 1; i__ >= i__1; --i__) {
dminus = lld[i__] + work[indp + i__];
tmp = d__[i__] / dminus;
if (dminus < 0.) {
++neg2;
}
work[indumn + i__] = l[i__] * tmp;
work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda;
/* L80: */
}
tmp = work[indp + r1 - 1];
sawnan2 = igraphdisnan_(&tmp);
if (sawnan2) {
/* Runs a slower version of the above loop if a NaN is detected */
neg2 = 0;
i__1 = r1;
for (i__ = *bn - 1; i__ >= i__1; --i__) {
dminus = lld[i__] + work[indp + i__];
if (abs(dminus) < *pivmin) {
dminus = -(*pivmin);
}
tmp = d__[i__] / dminus;
if (dminus < 0.) {
++neg2;
}
work[indumn + i__] = l[i__] * tmp;
work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda;
if (tmp == 0.) {
work[indp + i__ - 1] = d__[i__] - *lambda;
}
/* L100: */
}
}
/* Find the index (from R1 to R2) of the largest (in magnitude)
diagonal element of the inverse */
*mingma = work[inds + r1 - 1] + work[indp + r1 - 1];
if (*mingma < 0.) {
++neg1;
}
if (*wantnc) {
*negcnt = neg1 + neg2;
} else {
*negcnt = -1;
}
if (abs(*mingma) == 0.) {
*mingma = eps * work[inds + r1 - 1];
}
*r__ = r1;
i__1 = r2 - 1;
for (i__ = r1; i__ <= i__1; ++i__) {
tmp = work[inds + i__] + work[indp + i__];
if (tmp == 0.) {
tmp = eps * work[inds + i__];
}
if (abs(tmp) <= abs(*mingma)) {
*mingma = tmp;
*r__ = i__ + 1;
}
/* L110: */
}
/* Compute the FP vector: solve N^T v = e_r */
isuppz[1] = *b1;
isuppz[2] = *bn;
z__[*r__] = 1.;
*ztz = 1.;
/* Compute the FP vector upwards from R */
if (! sawnan1 && ! sawnan2) {
i__1 = *b1;
for (i__ = *r__ - 1; i__ >= i__1; --i__) {
z__[i__] = -(work[indlpl + i__] * z__[i__ + 1]);
if (((d__1 = z__[i__], abs(d__1)) + (d__2 = z__[i__ + 1], abs(
d__2))) * (d__3 = ld[i__], abs(d__3)) < *gaptol) {
z__[i__] = 0.;
isuppz[1] = i__ + 1;
goto L220;
}
*ztz += z__[i__] * z__[i__];
/* L210: */
}
L220:
;
} else {
/* Run slower loop if NaN occurred. */
i__1 = *b1;
for (i__ = *r__ - 1; i__ >= i__1; --i__) {
if (z__[i__ + 1] == 0.) {
z__[i__] = -(ld[i__ + 1] / ld[i__]) * z__[i__ + 2];
} else {
z__[i__] = -(work[indlpl + i__] * z__[i__ + 1]);
}
if (((d__1 = z__[i__], abs(d__1)) + (d__2 = z__[i__ + 1], abs(
d__2))) * (d__3 = ld[i__], abs(d__3)) < *gaptol) {
z__[i__] = 0.;
isuppz[1] = i__ + 1;
goto L240;
}
*ztz += z__[i__] * z__[i__];
/* L230: */
}
L240:
;
}
/* Compute the FP vector downwards from R in blocks of size BLKSIZ */
if (! sawnan1 && ! sawnan2) {
i__1 = *bn - 1;
for (i__ = *r__; i__ <= i__1; ++i__) {
z__[i__ + 1] = -(work[indumn + i__] * z__[i__]);
if (((d__1 = z__[i__], abs(d__1)) + (d__2 = z__[i__ + 1], abs(
d__2))) * (d__3 = ld[i__], abs(d__3)) < *gaptol) {
z__[i__ + 1] = 0.;
isuppz[2] = i__;
goto L260;
}
*ztz += z__[i__ + 1] * z__[i__ + 1];
/* L250: */
}
L260:
;
} else {
/* Run slower loop if NaN occurred. */
i__1 = *bn - 1;
for (i__ = *r__; i__ <= i__1; ++i__) {
if (z__[i__] == 0.) {
z__[i__ + 1] = -(ld[i__ - 1] / ld[i__]) * z__[i__ - 1];
} else {
z__[i__ + 1] = -(work[indumn + i__] * z__[i__]);
}
if (((d__1 = z__[i__], abs(d__1)) + (d__2 = z__[i__ + 1], abs(
d__2))) * (d__3 = ld[i__], abs(d__3)) < *gaptol) {
z__[i__ + 1] = 0.;
isuppz[2] = i__;
goto L280;
}
*ztz += z__[i__ + 1] * z__[i__ + 1];
/* L270: */
}
L280:
;
}
/* Compute quantities for convergence test */
tmp = 1. / *ztz;
*nrminv = sqrt(tmp);
*resid = abs(*mingma) * *nrminv;
*rqcorr = *mingma * tmp;
return 0;
/* End of DLAR1V */
} /* igraphdlar1v_ */
Subroutine */ int igraphdlarrr_(integer *n, doublereal *d__, doublereal *e,
integer *info)
{
/* System generated locals */
integer i__1;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__;
doublereal eps, tmp, tmp2, rmin;
extern doublereal igraphdlamch_(char *);
doublereal offdig, safmin;
logical yesrel;
doublereal smlnum, offdig2;
/* -- 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
=====================================================================
As a default, do NOT go for relative-accuracy preserving computations.
Parameter adjustments */
--e;
--d__;
/* Function Body */
*info = 1;
safmin = igraphdlamch_("Safe minimum");
eps = igraphdlamch_("Precision");
smlnum = safmin / eps;
rmin = sqrt(smlnum);
/* Tests for relative accuracy
Test for scaled diagonal dominance
Scale the diagonal entries to one and check whether the sum of the
off-diagonals is less than one
The sdd relative error bounds have a 1/(1- 2*x) factor in them,
x = max(OFFDIG + OFFDIG2), so when x is close to 1/2, no relative
accuracy is promised. In the notation of the code fragment below,
1/(1 - (OFFDIG + OFFDIG2)) is the condition number.
We don't think it is worth going into "sdd mode" unless the relative
condition number is reasonable, not 1/macheps.
The threshold should be compatible with other thresholds used in the
code. We set OFFDIG + OFFDIG2 <= .999 =: RELCOND, it corresponds
to losing at most 3 decimal digits: 1 / (1 - (OFFDIG + OFFDIG2)) <= 1000
instead of the current OFFDIG + OFFDIG2 < 1 */
yesrel = TRUE_;
offdig = 0.;
tmp = sqrt((abs(d__[1])));
if (tmp < rmin) {
yesrel = FALSE_;
}
if (! yesrel) {
goto L11;
}
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
tmp2 = sqrt((d__1 = d__[i__], abs(d__1)));
if (tmp2 < rmin) {
yesrel = FALSE_;
}
if (! yesrel) {
goto L11;
}
offdig2 = (d__1 = e[i__ - 1], abs(d__1)) / (tmp * tmp2);
if (offdig + offdig2 >= .999) {
yesrel = FALSE_;
}
if (! yesrel) {
goto L11;
}
tmp = tmp2;
offdig = offdig2;
/* L10: */
}
L11:
if (yesrel) {
*info = 0;
return 0;
} else {
}
/* *** MORE TO BE IMPLEMENTED ***
Test if the lower bidiagonal matrix L from T = L D L^T
(zero shift facto) is well conditioned
Test if the upper bidiagonal matrix U from T = U D U^T
(zero shift facto) is well conditioned.
In this case, the matrix needs to be flipped and, at the end
of the eigenvector computation, the flip needs to be applied
to the computed eigenvectors (and the support) */
return 0;
/* END OF DLARRR */
} /* igraphdlarrr_ */
/* Subroutine */ int igraphdlaqrb_(logical *wantt, integer *n, integer *ilo,
integer *ihi, doublereal *h__, integer *ldh, doublereal *wr,
doublereal *wi, doublereal *z__, integer *info)
{
/* System generated locals */
integer h_dim1, h_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
/* Local variables */
static integer i__, j, k, l, m;
static doublereal s, v[3];
static integer i1, i2;
static doublereal t1, t2, t3, v1, v2, v3, h00, h10, h11, h12, h21, h22,
h33, h44;
static integer nh;
static doublereal cs;
static integer nr;
static doublereal sn, h33s, h44s;
static integer itn, its;
static doublereal ulp, sum, tst1, h43h34, unfl, ovfl;
extern /* Subroutine */ int igraphdrot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
static doublereal work[1];
extern /* Subroutine */ int igraphdcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), igraphdlanv2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *), igraphdlabad_(
doublereal *, doublereal *);
extern doublereal igraphdlamch_(char *);
extern /* Subroutine */ int igraphdlarfg_(integer *, doublereal *, doublereal *,
integer *, doublereal *);
extern doublereal igraphdlanhs_(char *, integer *, doublereal *, integer *,
doublereal *);
static doublereal smlnum;
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %------------------------% */
/* | Local Scalars & Arrays | */
/* %------------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--wr;
--wi;
--z__;
/* Function Body */
*info = 0;
/* %--------------------------% */
/* | Quick return if possible | */
/* %--------------------------% */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
wr[*ilo] = h__[*ilo + *ilo * h_dim1];
wi[*ilo] = 0.;
return 0;
}
/* %---------------------------------------------% */
/* | Initialize the vector of last components of | */
/* | the Schur vectors for accumulation. | */
/* %---------------------------------------------% */
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
z__[j] = 0.;
/* L5: */
}
z__[*n] = 1.;
nh = *ihi - *ilo + 1;
/* %-------------------------------------------------------------% */
/* | Set machine-dependent constants for the stopping criterion. | */
/* | If norm(H) <= sqrt(OVFL), overflow should not occur. | */
/* %-------------------------------------------------------------% */
unfl = igraphdlamch_("safe minimum");
ovfl = 1. / unfl;
igraphdlabad_(&unfl, &ovfl);
ulp = igraphdlamch_("precision");
smlnum = unfl * (nh / ulp);
/* %---------------------------------------------------------------% */
/* | I1 and I2 are the indices of the first row and last column | */
/* | of H to which transformations must be applied. If eigenvalues | */
/* | only are computed, I1 and I2 are set inside the main loop. | */
/* | Zero out H(J+2,J) = ZERO for J=1:N if WANTT = .TRUE. | */
/* | else H(J+2,J) for J=ILO:IHI-ILO-1 if WANTT = .FALSE. | */
/* %---------------------------------------------------------------% */
if (*wantt) {
i1 = 1;
i2 = *n;
i__1 = i2 - 2;
for (i__ = 1; i__ <= i__1; ++i__) {
h__[i1 + i__ + 1 + i__ * h_dim1] = 0.;
/* L8: */
}
} else {
i__1 = *ihi - *ilo - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
h__[*ilo + i__ + 1 + (*ilo + i__ - 1) * h_dim1] = 0.;
/* L9: */
}
}
/* %---------------------------------------------------% */
/* | ITN is the total number of QR iterations allowed. | */
/* %---------------------------------------------------% */
itn = nh * 30;
/* ------------------------------------------------------------------ */
/* The main loop begins here. I is the loop index and decreases from */
/* IHI to ILO in steps of 1 or 2. Each iteration of the loop works */
/* with the active submatrix in rows and columns L to I. */
/* Eigenvalues I+1 to IHI have already converged. Either L = ILO or */
/* H(L,L-1) is negligible so that the matrix splits. */
/* ------------------------------------------------------------------ */
i__ = *ihi;
L10:
l = *ilo;
if (i__ < *ilo) {
goto L150;
}
/* %--------------------------------------------------------------% */
/* | Perform QR iterations on rows and columns ILO to I until a | */
/* | submatrix of order 1 or 2 splits off at the bottom because a | */
/* | subdiagonal element has become negligible. | */
/* %--------------------------------------------------------------% */
i__1 = itn;
for (its = 0; its <= i__1; ++its) {
/* %----------------------------------------------% */
/* | Look for a single small subdiagonal element. | */
/* %----------------------------------------------% */
i__2 = l + 1;
for (k = i__; k >= i__2; --k) {
tst1 = (d__1 = h__[k - 1 + (k - 1) * h_dim1], abs(d__1)) + (d__2 =
h__[k + k * h_dim1], abs(d__2));
if (tst1 == 0.) {
i__3 = i__ - l + 1;
tst1 = igraphdlanhs_("1", &i__3, &h__[l + l * h_dim1], ldh, work);
}
/* Computing MAX */
d__2 = ulp * tst1;
if ((d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)) <= max(d__2,
smlnum)) {
goto L30;
}
/* L20: */
}
L30:
l = k;
if (l > *ilo) {
/* %------------------------% */
/* | H(L,L-1) is negligible | */
/* %------------------------% */
h__[l + (l - 1) * h_dim1] = 0.;
}
/* %-------------------------------------------------------------% */
/* | Exit from loop if a submatrix of order 1 or 2 has split off | */
/* %-------------------------------------------------------------% */
if (l >= i__ - 1) {
goto L140;
}
/* %---------------------------------------------------------% */
/* | Now the active submatrix is in rows and columns L to I. | */
/* | If eigenvalues only are being computed, only the active | */
/* | submatrix need be transformed. | */
/* %---------------------------------------------------------% */
if (! (*wantt)) {
i1 = l;
i2 = i__;
}
if (its == 10 || its == 20) {
/* %-------------------% */
/* | Exceptional shift | */
/* %-------------------% */
s = (d__1 = h__[i__ + (i__ - 1) * h_dim1], abs(d__1)) + (d__2 =
h__[i__ - 1 + (i__ - 2) * h_dim1], abs(d__2));
h44 = s * .75;
h33 = h44;
h43h34 = s * -.4375 * s;
} else {
/* %-----------------------------------------% */
/* | Prepare to use Wilkinson's double shift | */
/* %-----------------------------------------% */
h44 = h__[i__ + i__ * h_dim1];
h33 = h__[i__ - 1 + (i__ - 1) * h_dim1];
h43h34 = h__[i__ + (i__ - 1) * h_dim1] * h__[i__ - 1 + i__ *
h_dim1];
}
/* %-----------------------------------------------------% */
/* | Look for two consecutive small subdiagonal elements | */
/* %-----------------------------------------------------% */
i__2 = l;
for (m = i__ - 2; m >= i__2; --m) {
/* %---------------------------------------------------------% */
/* | Determine the effect of starting the double-shift QR | */
/* | iteration at row M, and see if this would make H(M,M-1) | */
/* | negligible. | */
/* %---------------------------------------------------------% */
h11 = h__[m + m * h_dim1];
h22 = h__[m + 1 + (m + 1) * h_dim1];
h21 = h__[m + 1 + m * h_dim1];
h12 = h__[m + (m + 1) * h_dim1];
h44s = h44 - h11;
h33s = h33 - h11;
v1 = (h33s * h44s - h43h34) / h21 + h12;
v2 = h22 - h11 - h33s - h44s;
v3 = h__[m + 2 + (m + 1) * h_dim1];
s = abs(v1) + abs(v2) + abs(v3);
v1 /= s;
v2 /= s;
v3 /= s;
v[0] = v1;
v[1] = v2;
v[2] = v3;
if (m == l) {
goto L50;
}
h00 = h__[m - 1 + (m - 1) * h_dim1];
h10 = h__[m + (m - 1) * h_dim1];
tst1 = abs(v1) * (abs(h00) + abs(h11) + abs(h22));
if (abs(h10) * (abs(v2) + abs(v3)) <= ulp * tst1) {
goto L50;
}
/* L40: */
}
L50:
/* %----------------------% */
/* | Double-shift QR step | */
/* %----------------------% */
i__2 = i__ - 1;
for (k = m; k <= i__2; ++k) {
/* ------------------------------------------------------------ */
/* The first iteration of this loop determines a reflection G */
/* from the vector V and applies it from left and right to H, */
/* thus creating a nonzero bulge below the subdiagonal. */
/* Each subsequent iteration determines a reflection G to */
/* restore the Hessenberg form in the (K-1)th column, and thus */
/* chases the bulge one step toward the bottom of the active */
/* submatrix. NR is the order of G. */
/* ------------------------------------------------------------ */
/* Computing MIN */
i__3 = 3, i__4 = i__ - k + 1;
nr = min(i__3,i__4);
if (k > m) {
igraphdcopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
}
igraphdlarfg_(&nr, v, &v[1], &c__1, &t1);
if (k > m) {
h__[k + (k - 1) * h_dim1] = v[0];
h__[k + 1 + (k - 1) * h_dim1] = 0.;
if (k < i__ - 1) {
h__[k + 2 + (k - 1) * h_dim1] = 0.;
}
} else if (m > l) {
h__[k + (k - 1) * h_dim1] = -h__[k + (k - 1) * h_dim1];
}
v2 = v[1];
t2 = t1 * v2;
if (nr == 3) {
v3 = v[2];
t3 = t1 * v3;
/* %------------------------------------------------% */
/* | Apply G from the left to transform the rows of | */
/* | the matrix in columns K to I2. | */
/* %------------------------------------------------% */
i__3 = i2;
for (j = k; j <= i__3; ++j) {
sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1]
+ v3 * h__[k + 2 + j * h_dim1];
h__[k + j * h_dim1] -= sum * t1;
h__[k + 1 + j * h_dim1] -= sum * t2;
h__[k + 2 + j * h_dim1] -= sum * t3;
/* L60: */
}
/* %----------------------------------------------------% */
/* | Apply G from the right to transform the columns of | */
/* | the matrix in rows I1 to min(K+3,I). | */
/* %----------------------------------------------------% */
/* Computing MIN */
i__4 = k + 3;
i__3 = min(i__4,i__);
for (j = i1; j <= i__3; ++j) {
sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
+ v3 * h__[j + (k + 2) * h_dim1];
h__[j + k * h_dim1] -= sum * t1;
h__[j + (k + 1) * h_dim1] -= sum * t2;
h__[j + (k + 2) * h_dim1] -= sum * t3;
/* L70: */
}
/* %----------------------------------% */
/* | Accumulate transformations for Z | */
/* %----------------------------------% */
sum = z__[k] + v2 * z__[k + 1] + v3 * z__[k + 2];
z__[k] -= sum * t1;
z__[k + 1] -= sum * t2;
z__[k + 2] -= sum * t3;
} else if (nr == 2) {
/* %------------------------------------------------% */
/* | Apply G from the left to transform the rows of | */
/* | the matrix in columns K to I2. | */
/* %------------------------------------------------% */
i__3 = i2;
for (j = k; j <= i__3; ++j) {
sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1];
h__[k + j * h_dim1] -= sum * t1;
h__[k + 1 + j * h_dim1] -= sum * t2;
/* L90: */
}
/* %----------------------------------------------------% */
/* | Apply G from the right to transform the columns of | */
/* | the matrix in rows I1 to min(K+3,I). | */
/* %----------------------------------------------------% */
i__3 = i__;
for (j = i1; j <= i__3; ++j) {
sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
;
h__[j + k * h_dim1] -= sum * t1;
h__[j + (k + 1) * h_dim1] -= sum * t2;
/* L100: */
}
/* %----------------------------------% */
/* | Accumulate transformations for Z | */
/* %----------------------------------% */
sum = z__[k] + v2 * z__[k + 1];
z__[k] -= sum * t1;
z__[k + 1] -= sum * t2;
}
/* L120: */
}
/* L130: */
}
/* %-------------------------------------------------------% */
/* | Failure to converge in remaining number of iterations | */
/* %-------------------------------------------------------% */
*info = i__;
return 0;
L140:
if (l == i__) {
/* %------------------------------------------------------% */
/* | H(I,I-1) is negligible: one eigenvalue has converged | */
/* %------------------------------------------------------% */
wr[i__] = h__[i__ + i__ * h_dim1];
wi[i__] = 0.;
} else if (l == i__ - 1) {
/* %--------------------------------------------------------% */
/* | H(I-1,I-2) is negligible; | */
/* | a pair of eigenvalues have converged. | */
/* | | */
/* | Transform the 2-by-2 submatrix to standard Schur form, | */
/* | and compute and store the eigenvalues. | */
/* %--------------------------------------------------------% */
igraphdlanv2_(&h__[i__ - 1 + (i__ - 1) * h_dim1], &h__[i__ - 1 + i__ *
h_dim1], &h__[i__ + (i__ - 1) * h_dim1], &h__[i__ + i__ *
h_dim1], &wr[i__ - 1], &wi[i__ - 1], &wr[i__], &wi[i__], &cs,
&sn);
if (*wantt) {
/* %-----------------------------------------------------% */
/* | Apply the transformation to the rest of H and to Z, | */
/* | as required. | */
/* %-----------------------------------------------------% */
if (i2 > i__) {
i__1 = i2 - i__;
igraphdrot_(&i__1, &h__[i__ - 1 + (i__ + 1) * h_dim1], ldh, &h__[
i__ + (i__ + 1) * h_dim1], ldh, &cs, &sn);
}
i__1 = i__ - i1 - 1;
igraphdrot_(&i__1, &h__[i1 + (i__ - 1) * h_dim1], &c__1, &h__[i1 + i__ *
h_dim1], &c__1, &cs, &sn);
sum = cs * z__[i__ - 1] + sn * z__[i__];
z__[i__] = cs * z__[i__] - sn * z__[i__ - 1];
z__[i__ - 1] = sum;
}
}
/* %---------------------------------------------------------% */
/* | Decrement number of remaining iterations, and return to | */
/* | start of the main loop with new value of I. | */
/* %---------------------------------------------------------% */
itn -= its;
i__ = l - 1;
goto L10;
L150:
return 0;
/* %---------------% */
/* | End of igraphdlaqrb | */
/* %---------------% */
} /* igraphdlaqrb_ */
Subroutine */ int igraphdsaupd_(integer *ido, 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)
{
/* Format strings */
static char fmt_1000[] = "(//,5x,\002==================================="
"=======\002,/5x,\002= Symmetric implicit Arnoldi update code "
"=\002,/5x,\002= Version Number:\002,\002 2.4\002,19x,\002 =\002,"
"/5x,\002= Version Date: \002,\002 07/31/96\002,14x,\002 =\002,/"
"5x,\002==========================================\002,/5x,\002= "
"Summary of timing statistics =\002,/5x,\002==========="
"===============================\002,//)";
static char fmt_1100[] = "(5x,\002Total number update iterations "
" = \002,i5,/5x,\002Total number of OP*x operations "
" = \002,i5,/5x,\002Total number of B*x operations = "
"\002,i5,/5x,\002Total number of reorthogonalization steps = "
"\002,i5,/5x,\002Total number of iterative refinement steps = "
"\002,i5,/5x,\002Total number of restart steps = "
"\002,i5,/5x,\002Total time in user OP*x operation = "
"\002,f12.6,/5x,\002Total time in user B*x operation ="
" \002,f12.6,/5x,\002Total time in Arnoldi update routine = "
"\002,f12.6,/5x,\002Total time in saup2 routine ="
" \002,f12.6,/5x,\002Total time in basic Arnoldi iteration loop = "
"\002,f12.6,/5x,\002Total time in reorthogonalization phase ="
" \002,f12.6,/5x,\002Total time in (re)start vector generation = "
"\002,f12.6,/5x,\002Total time in trid eigenvalue subproblem ="
" \002,f12.6,/5x,\002Total time in getting the shifts = "
"\002,f12.6,/5x,\002Total time in applying the shifts ="
" \002,f12.6,/5x,\002Total time in convergence testing = "
"\002,f12.6)";
/* System generated locals */
integer v_dim1, v_offset, i__1, i__2;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), e_wsfe(
void), do_fio(integer *, char *, ftnlen);
/* Local variables */
integer j;
real t0, t1;
IGRAPH_F77_SAVE integer nb, ih, iq, np, iw, ldh, ldq;
integer nbx;
IGRAPH_F77_SAVE integer nev0, mode, ierr, iupd, next;
integer nopx;
IGRAPH_F77_SAVE integer ritz;
real tmvbx;
extern /* Subroutine */ int igraphdvout_(integer *, integer *, doublereal *,
integer *, char *, ftnlen), igraphivout_(integer *, integer *, integer *
, integer *, char *, ftnlen), igraphdsaup2_(integer *, char *, integer *
, char *, integer *, integer *, doublereal *, doublereal *,
integer *, integer *, integer *, integer *, doublereal *, integer
*, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
real tgetv0, tsaup2;
extern doublereal igraphdlamch_(char *);
extern /* Subroutine */ int igraphsecond_(real *);
integer logfil=0, ndigit;
IGRAPH_F77_SAVE integer ishift;
integer nitref, msaupd=0;
IGRAPH_F77_SAVE integer bounds;
real titref, tseigt, tsaupd;
extern /* Subroutine */ int igraphdstats_(void);
IGRAPH_F77_SAVE integer msglvl;
real tsaitr;
IGRAPH_F77_SAVE integer mxiter;
real tsgets, tsapps;
integer nrorth;
real tsconv;
integer nrstrt;
real tmvopx;
/* Fortran I/O blocks */
static cilist io___28 = { 0, 6, 0, fmt_1000, 0 };
static cilist io___29 = { 0, 6, 0, fmt_1100, 0 };
/* %----------------------------------------------------%
| Include files for debugging and timing information |
%----------------------------------------------------%
%------------------%
| Scalar Arguments |
%------------------%
%-----------------%
| Array Arguments |
%-----------------%
%------------%
| Parameters |
%------------%
%---------------%
| Local Scalars |
%---------------%
%----------------------%
| External Subroutines |
%----------------------%
%--------------------%
| External Functions |
%--------------------%
%-----------------------%
| Executable Statements |
%-----------------------%
Parameter adjustments */
--workd;
--resid;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--iparam;
--ipntr;
--workl;
/* Function Body */
if (*ido == 0) {
/* %-------------------------------%
| Initialize timing statistics |
| & message level for debugging |
%-------------------------------% */
igraphdstats_();
igraphsecond_(&t0);
msglvl = msaupd;
ierr = 0;
ishift = iparam[1];
mxiter = iparam[3];
nb = iparam[4];
/* %--------------------------------------------%
| Revision 2 performs only implicit restart. |
%--------------------------------------------% */
iupd = 1;
mode = iparam[7];
/* %----------------%
| Error checking |
%----------------% */
if (*n <= 0) {
ierr = -1;
} else if (*nev <= 0) {
ierr = -2;
} else if (*ncv <= *nev || *ncv > *n) {
ierr = -3;
}
/* %----------------------------------------------%
| NP is the number of additional steps to |
| extend the length NEV Lanczos factorization. |
%----------------------------------------------% */
np = *ncv - *nev;
if (mxiter <= 0) {
ierr = -4;
}
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;
}
/* Computing 2nd power */
i__1 = *ncv;
if (*lworkl < i__1 * i__1 + (*ncv << 3)) {
ierr = -7;
}
if (mode < 1 || mode > 5) {
ierr = -10;
} else if (mode == 1 && *(unsigned char *)bmat == 'G') {
ierr = -11;
} else if (ishift < 0 || ishift > 1) {
ierr = -12;
} else if (*nev == 1 && s_cmp(which, "BE", (ftnlen)2, (ftnlen)2) == 0)
{
ierr = -13;
}
/* %------------%
| Error Exit |
%------------% */
if (ierr != 0) {
*info = ierr;
*ido = 99;
goto L9000;
}
/* %------------------------%
| Set default parameters |
%------------------------% */
if (nb <= 0) {
nb = 1;
}
if (*tol <= 0.) {
*tol = igraphdlamch_("EpsMach");
}
/* %----------------------------------------------%
| NP is the number of additional steps to |
| extend the length NEV Lanczos factorization. |
| NEV0 is the local variable designating the |
| size of the invariant subspace desired. |
%----------------------------------------------% */
np = *ncv - *nev;
nev0 = *nev;
/* %-----------------------------%
| Zero out internal workspace |
%-----------------------------%
Computing 2nd power */
i__2 = *ncv;
i__1 = i__2 * i__2 + (*ncv << 3);
for (j = 1; j <= i__1; ++j) {
workl[j] = 0.;
/* L10: */
}
/* %-------------------------------------------------------%
| 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 |
| workl(2*ncv+1:2*ncv+ncv) := ritz values |
| workl(3*ncv+1:3*ncv+ncv) := computed error bounds |
| workl(4*ncv+1:4*ncv+ncv*ncv) := rotation matrix Q |
| workl(4*ncv+ncv*ncv+1:7*ncv+ncv*ncv) := workspace |
%-------------------------------------------------------% */
ldh = *ncv;
ldq = *ncv;
ih = 1;
ritz = ih + (ldh << 1);
bounds = ritz + *ncv;
iq = bounds + *ncv;
/* Computing 2nd power */
i__1 = *ncv;
iw = iq + i__1 * i__1;
next = iw + *ncv * 3;
ipntr[4] = next;
ipntr[5] = ih;
ipntr[6] = ritz;
ipntr[7] = bounds;
ipntr[11] = iw;
}
/* %-------------------------------------------------------%
| Carry out the Implicitly restarted Lanczos Iteration. |
%-------------------------------------------------------% */
igraphdsaup2_(ido, bmat, n, which, &nev0, &np, tol, &resid[1], &mode, &iupd, &
ishift, &mxiter, &v[v_offset], ldv, &workl[ih], &ldh, &workl[ritz]
, &workl[bounds], &workl[iq], &ldq, &workl[iw], &ipntr[1], &workd[
1], info);
/* %--------------------------------------------------%
| ido .ne. 99 implies use of reverse communication |
| to compute operations involving OP or shifts. |
%--------------------------------------------------% */
if (*ido == 3) {
iparam[8] = np;
}
if (*ido != 99) {
goto L9000;
}
iparam[3] = mxiter;
iparam[5] = np;
iparam[9] = nopx;
iparam[10] = nbx;
iparam[11] = nrorth;
/* %------------------------------------%
| Exit if there was an informational |
| error within dsaup2. |
%------------------------------------% */
if (*info < 0) {
goto L9000;
}
if (*info == 2) {
*info = 3;
}
if (msglvl > 0) {
igraphivout_(&logfil, &c__1, &mxiter, &ndigit, "_saupd: number of update i"
"terations taken", (ftnlen)41);
igraphivout_(&logfil, &c__1, &np, &ndigit, "_saupd: number of \"converge"
"d\" Ritz values", (ftnlen)41);
igraphdvout_(&logfil, &np, &workl[ritz], &ndigit, "_saupd: final Ritz valu"
"es", (ftnlen)25);
igraphdvout_(&logfil, &np, &workl[bounds], &ndigit, "_saupd: corresponding"
" error bounds", (ftnlen)34);
}
igraphsecond_(&t1);
tsaupd = t1 - t0;
if (msglvl > 0) {
/* %--------------------------------------------------------%
| Version Number & Version Date are defined in version.h |
%--------------------------------------------------------% */
s_wsfe(&io___28);
e_wsfe();
s_wsfe(&io___29);
do_fio(&c__1, (char *)&mxiter, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nopx, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nbx, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nrorth, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nitref, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nrstrt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&tmvopx, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&tmvbx, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&tsaupd, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&tsaup2, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&tsaitr, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&titref, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&tgetv0, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&tseigt, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&tsgets, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&tsapps, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&tsconv, (ftnlen)sizeof(real));
e_wsfe();
}
L9000:
return 0;
/* %---------------%
| End of dsaupd |
%---------------% */
} /* igraphdsaupd_ */
/* Subroutine */ int igraphdlaln2_(logical *ltrans, integer *na, integer *nw,
doublereal *smin, doublereal *ca, doublereal *a, integer *lda,
doublereal *d1, doublereal *d2, doublereal *b, integer *ldb,
doublereal *wr, doublereal *wi, doublereal *x, integer *ldx,
doublereal *scale, doublereal *xnorm, integer *info)
{
/* Initialized data */
static logical zswap[4] = { FALSE_,FALSE_,TRUE_,TRUE_ };
static logical rswap[4] = { FALSE_,TRUE_,FALSE_,TRUE_ };
static integer ipivot[16] /* was [4][4] */ = { 1,2,3,4,2,1,4,3,3,4,1,2,
4,3,2,1 };
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
IGRAPH_F77_SAVE doublereal equiv_0[4], equiv_1[4];
/* Local variables */
integer j;
#define ci (equiv_0)
#define cr (equiv_1)
doublereal bi1, bi2, br1, br2, xi1, xi2, xr1, xr2, ci21, ci22, cr21, cr22,
li21, csi, ui11, lr21, ui12, ui22;
#define civ (equiv_0)
doublereal csr, ur11, ur12, ur22;
#define crv (equiv_1)
doublereal bbnd, cmax, ui11r, ui12s, temp, ur11r, ur12s, u22abs;
integer icmax;
doublereal bnorm, cnorm, smini;
extern doublereal igraphdlamch_(char *);
extern /* Subroutine */ int igraphdladiv_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *);
doublereal bignum, smlnum;
/* -- LAPACK auxiliary 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
=======
DLALN2 solves a system of the form (ca A - w D ) X = s B
or (ca A**T - w D) X = s B with possible scaling ("s") and
perturbation of A. (A**T means A-transpose.)
A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA
real diagonal matrix, w is a real or complex value, and X and B are
NA x 1 matrices -- real if w is real, complex if w is complex. NA
may be 1 or 2.
If w is complex, X and B are represented as NA x 2 matrices,
the first column of each being the real part and the second
being the imaginary part.
"s" is a scaling factor (.LE. 1), computed by DLALN2, which is
so chosen that X can be computed without overflow. X is further
scaled if necessary to assure that norm(ca A - w D)*norm(X) is less
than overflow.
If both singular values of (ca A - w D) are less than SMIN,
SMIN*identity will be used instead of (ca A - w D). If only one
singular value is less than SMIN, one element of (ca A - w D) will be
perturbed enough to make the smallest singular value roughly SMIN.
If both singular values are at least SMIN, (ca A - w D) will not be
perturbed. In any case, the perturbation will be at most some small
multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values
are computed by infinity-norm approximations, and thus will only be
correct to a factor of 2 or so.
Note: all input quantities are assumed to be smaller than overflow
by a reasonable factor. (See BIGNUM.)
Arguments
==========
LTRANS (input) LOGICAL
=.TRUE.: A-transpose will be used.
=.FALSE.: A will be used (not transposed.)
NA (input) INTEGER
The size of the matrix A. It may (only) be 1 or 2.
NW (input) INTEGER
1 if "w" is real, 2 if "w" is complex. It may only be 1
or 2.
SMIN (input) DOUBLE PRECISION
The desired lower bound on the singular values of A. This
should be a safe distance away from underflow or overflow,
say, between (underflow/machine precision) and (machine
precision * overflow ). (See BIGNUM and ULP.)
CA (input) DOUBLE PRECISION
The coefficient c, which A is multiplied by.
A (input) DOUBLE PRECISION array, dimension (LDA,NA)
The NA x NA matrix A.
LDA (input) INTEGER
The leading dimension of A. It must be at least NA.
D1 (input) DOUBLE PRECISION
The 1,1 element in the diagonal matrix D.
D2 (input) DOUBLE PRECISION
The 2,2 element in the diagonal matrix D. Not used if NW=1.
B (input) DOUBLE PRECISION array, dimension (LDB,NW)
The NA x NW matrix B (right-hand side). If NW=2 ("w" is
complex), column 1 contains the real part of B and column 2
contains the imaginary part.
LDB (input) INTEGER
The leading dimension of B. It must be at least NA.
WR (input) DOUBLE PRECISION
The real part of the scalar "w".
WI (input) DOUBLE PRECISION
The imaginary part of the scalar "w". Not used if NW=1.
X (output) DOUBLE PRECISION array, dimension (LDX,NW)
The NA x NW matrix X (unknowns), as computed by DLALN2.
If NW=2 ("w" is complex), on exit, column 1 will contain
the real part of X and column 2 will contain the imaginary
part.
LDX (input) INTEGER
The leading dimension of X. It must be at least NA.
SCALE (output) DOUBLE PRECISION
The scale factor that B must be multiplied by to insure
that overflow does not occur when computing X. Thus,
(ca A - w D) X will be SCALE*B, not B (ignoring
perturbations of A.) It will be at most 1.
XNORM (output) DOUBLE PRECISION
The infinity-norm of X, when X is regarded as an NA x NW
real matrix.
INFO (output) INTEGER
An error flag. It will be set to zero if no error occurs,
a negative number if an argument is in error, or a positive
number if ca A - w D had to be perturbed.
The possible values are:
= 0: No error occurred, and (ca A - w D) did not have to be
perturbed.
= 1: (ca A - w D) had to be perturbed to make its smallest
(or only) singular value greater than SMIN.
NOTE: In the interests of speed, this routine does not
check the inputs for errors.
=====================================================================
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
/* Function Body
Compute BIGNUM */
smlnum = 2. * igraphdlamch_("Safe minimum");
bignum = 1. / smlnum;
smini = max(*smin,smlnum);
/* Don't check for input errors */
*info = 0;
/* Standard Initializations */
*scale = 1.;
if (*na == 1) {
/* 1 x 1 (i.e., scalar) system C X = B */
if (*nw == 1) {
/* Real 1x1 system.
C = ca A - w D */
csr = *ca * a[a_dim1 + 1] - *wr * *d1;
cnorm = abs(csr);
/* If | C | < SMINI, use C = SMINI */
if (cnorm < smini) {
csr = smini;
cnorm = smini;
*info = 1;
}
/* Check scaling for X = B / C */
bnorm = (d__1 = b[b_dim1 + 1], abs(d__1));
if (cnorm < 1. && bnorm > 1.) {
if (bnorm > bignum * cnorm) {
*scale = 1. / bnorm;
}
}
/* Compute X */
x[x_dim1 + 1] = b[b_dim1 + 1] * *scale / csr;
*xnorm = (d__1 = x[x_dim1 + 1], abs(d__1));
} else {
/* Complex 1x1 system (w is complex)
C = ca A - w D */
csr = *ca * a[a_dim1 + 1] - *wr * *d1;
csi = -(*wi) * *d1;
cnorm = abs(csr) + abs(csi);
/* If | C | < SMINI, use C = SMINI */
if (cnorm < smini) {
csr = smini;
csi = 0.;
cnorm = smini;
*info = 1;
}
/* Check scaling for X = B / C */
bnorm = (d__1 = b[b_dim1 + 1], abs(d__1)) + (d__2 = b[(b_dim1 <<
1) + 1], abs(d__2));
if (cnorm < 1. && bnorm > 1.) {
if (bnorm > bignum * cnorm) {
*scale = 1. / bnorm;
}
}
/* Compute X */
d__1 = *scale * b[b_dim1 + 1];
d__2 = *scale * b[(b_dim1 << 1) + 1];
igraphdladiv_(&d__1, &d__2, &csr, &csi, &x[x_dim1 + 1], &x[(x_dim1 << 1)
+ 1]);
*xnorm = (d__1 = x[x_dim1 + 1], abs(d__1)) + (d__2 = x[(x_dim1 <<
1) + 1], abs(d__2));
}
} else {
/* 2x2 System
Compute the real part of C = ca A - w D (or ca A**T - w D ) */
cr[0] = *ca * a[a_dim1 + 1] - *wr * *d1;
cr[3] = *ca * a[(a_dim1 << 1) + 2] - *wr * *d2;
if (*ltrans) {
cr[2] = *ca * a[a_dim1 + 2];
cr[1] = *ca * a[(a_dim1 << 1) + 1];
} else {
cr[1] = *ca * a[a_dim1 + 2];
cr[2] = *ca * a[(a_dim1 << 1) + 1];
}
if (*nw == 1) {
/* Real 2x2 system (w is real)
Find the largest element in C */
cmax = 0.;
icmax = 0;
for (j = 1; j <= 4; ++j) {
if ((d__1 = crv[j - 1], abs(d__1)) > cmax) {
cmax = (d__1 = crv[j - 1], abs(d__1));
icmax = j;
}
/* L10: */
}
/* If norm(C) < SMINI, use SMINI*identity. */
if (cmax < smini) {
/* Computing MAX */
d__3 = (d__1 = b[b_dim1 + 1], abs(d__1)), d__4 = (d__2 = b[
b_dim1 + 2], abs(d__2));
bnorm = max(d__3,d__4);
if (smini < 1. && bnorm > 1.) {
if (bnorm > bignum * smini) {
*scale = 1. / bnorm;
}
}
temp = *scale / smini;
x[x_dim1 + 1] = temp * b[b_dim1 + 1];
x[x_dim1 + 2] = temp * b[b_dim1 + 2];
*xnorm = temp * bnorm;
*info = 1;
return 0;
}
/* Gaussian elimination with complete pivoting. */
ur11 = crv[icmax - 1];
cr21 = crv[ipivot[(icmax << 2) - 3] - 1];
ur12 = crv[ipivot[(icmax << 2) - 2] - 1];
cr22 = crv[ipivot[(icmax << 2) - 1] - 1];
ur11r = 1. / ur11;
lr21 = ur11r * cr21;
ur22 = cr22 - ur12 * lr21;
/* If smaller pivot < SMINI, use SMINI */
if (abs(ur22) < smini) {
ur22 = smini;
*info = 1;
}
if (rswap[icmax - 1]) {
br1 = b[b_dim1 + 2];
br2 = b[b_dim1 + 1];
} else {
br1 = b[b_dim1 + 1];
br2 = b[b_dim1 + 2];
}
br2 -= lr21 * br1;
/* Computing MAX */
d__2 = (d__1 = br1 * (ur22 * ur11r), abs(d__1)), d__3 = abs(br2);
bbnd = max(d__2,d__3);
if (bbnd > 1. && abs(ur22) < 1.) {
if (bbnd >= bignum * abs(ur22)) {
*scale = 1. / bbnd;
}
}
xr2 = br2 * *scale / ur22;
xr1 = *scale * br1 * ur11r - xr2 * (ur11r * ur12);
if (zswap[icmax - 1]) {
x[x_dim1 + 1] = xr2;
x[x_dim1 + 2] = xr1;
} else {
x[x_dim1 + 1] = xr1;
x[x_dim1 + 2] = xr2;
}
/* Computing MAX */
d__1 = abs(xr1), d__2 = abs(xr2);
*xnorm = max(d__1,d__2);
/* Further scaling if norm(A) norm(X) > overflow */
if (*xnorm > 1. && cmax > 1.) {
if (*xnorm > bignum / cmax) {
temp = cmax / bignum;
x[x_dim1 + 1] = temp * x[x_dim1 + 1];
x[x_dim1 + 2] = temp * x[x_dim1 + 2];
*xnorm = temp * *xnorm;
*scale = temp * *scale;
}
}
} else {
/* Complex 2x2 system (w is complex)
Find the largest element in C */
ci[0] = -(*wi) * *d1;
ci[1] = 0.;
ci[2] = 0.;
ci[3] = -(*wi) * *d2;
cmax = 0.;
icmax = 0;
for (j = 1; j <= 4; ++j) {
if ((d__1 = crv[j - 1], abs(d__1)) + (d__2 = civ[j - 1], abs(
d__2)) > cmax) {
cmax = (d__1 = crv[j - 1], abs(d__1)) + (d__2 = civ[j - 1]
, abs(d__2));
icmax = j;
}
/* L20: */
}
/* If norm(C) < SMINI, use SMINI*identity. */
if (cmax < smini) {
/* Computing MAX */
d__5 = (d__1 = b[b_dim1 + 1], abs(d__1)) + (d__2 = b[(b_dim1
<< 1) + 1], abs(d__2)), d__6 = (d__3 = b[b_dim1 + 2],
abs(d__3)) + (d__4 = b[(b_dim1 << 1) + 2], abs(d__4));
bnorm = max(d__5,d__6);
if (smini < 1. && bnorm > 1.) {
if (bnorm > bignum * smini) {
*scale = 1. / bnorm;
}
}
temp = *scale / smini;
x[x_dim1 + 1] = temp * b[b_dim1 + 1];
x[x_dim1 + 2] = temp * b[b_dim1 + 2];
x[(x_dim1 << 1) + 1] = temp * b[(b_dim1 << 1) + 1];
x[(x_dim1 << 1) + 2] = temp * b[(b_dim1 << 1) + 2];
*xnorm = temp * bnorm;
*info = 1;
return 0;
}
/* Gaussian elimination with complete pivoting. */
ur11 = crv[icmax - 1];
ui11 = civ[icmax - 1];
cr21 = crv[ipivot[(icmax << 2) - 3] - 1];
ci21 = civ[ipivot[(icmax << 2) - 3] - 1];
ur12 = crv[ipivot[(icmax << 2) - 2] - 1];
ui12 = civ[ipivot[(icmax << 2) - 2] - 1];
cr22 = crv[ipivot[(icmax << 2) - 1] - 1];
ci22 = civ[ipivot[(icmax << 2) - 1] - 1];
if (icmax == 1 || icmax == 4) {
/* Code when off-diagonals of pivoted C are real */
if (abs(ur11) > abs(ui11)) {
temp = ui11 / ur11;
/* Computing 2nd power */
d__1 = temp;
ur11r = 1. / (ur11 * (d__1 * d__1 + 1.));
ui11r = -temp * ur11r;
} else {
temp = ur11 / ui11;
/* Computing 2nd power */
d__1 = temp;
ui11r = -1. / (ui11 * (d__1 * d__1 + 1.));
ur11r = -temp * ui11r;
}
lr21 = cr21 * ur11r;
li21 = cr21 * ui11r;
ur12s = ur12 * ur11r;
ui12s = ur12 * ui11r;
ur22 = cr22 - ur12 * lr21;
ui22 = ci22 - ur12 * li21;
} else {
/* Code when diagonals of pivoted C are real */
ur11r = 1. / ur11;
ui11r = 0.;
lr21 = cr21 * ur11r;
li21 = ci21 * ur11r;
ur12s = ur12 * ur11r;
ui12s = ui12 * ur11r;
ur22 = cr22 - ur12 * lr21 + ui12 * li21;
ui22 = -ur12 * li21 - ui12 * lr21;
}
u22abs = abs(ur22) + abs(ui22);
/* If smaller pivot < SMINI, use SMINI */
if (u22abs < smini) {
ur22 = smini;
ui22 = 0.;
*info = 1;
}
if (rswap[icmax - 1]) {
br2 = b[b_dim1 + 1];
br1 = b[b_dim1 + 2];
bi2 = b[(b_dim1 << 1) + 1];
bi1 = b[(b_dim1 << 1) + 2];
} else {
br1 = b[b_dim1 + 1];
br2 = b[b_dim1 + 2];
bi1 = b[(b_dim1 << 1) + 1];
bi2 = b[(b_dim1 << 1) + 2];
}
br2 = br2 - lr21 * br1 + li21 * bi1;
bi2 = bi2 - li21 * br1 - lr21 * bi1;
/* Computing MAX */
d__1 = (abs(br1) + abs(bi1)) * (u22abs * (abs(ur11r) + abs(ui11r))
), d__2 = abs(br2) + abs(bi2);
bbnd = max(d__1,d__2);
if (bbnd > 1. && u22abs < 1.) {
if (bbnd >= bignum * u22abs) {
*scale = 1. / bbnd;
br1 = *scale * br1;
bi1 = *scale * bi1;
br2 = *scale * br2;
bi2 = *scale * bi2;
}
}
igraphdladiv_(&br2, &bi2, &ur22, &ui22, &xr2, &xi2);
xr1 = ur11r * br1 - ui11r * bi1 - ur12s * xr2 + ui12s * xi2;
xi1 = ui11r * br1 + ur11r * bi1 - ui12s * xr2 - ur12s * xi2;
if (zswap[icmax - 1]) {
x[x_dim1 + 1] = xr2;
x[x_dim1 + 2] = xr1;
x[(x_dim1 << 1) + 1] = xi2;
x[(x_dim1 << 1) + 2] = xi1;
} else {
x[x_dim1 + 1] = xr1;
x[x_dim1 + 2] = xr2;
x[(x_dim1 << 1) + 1] = xi1;
x[(x_dim1 << 1) + 2] = xi2;
}
/* Computing MAX */
d__1 = abs(xr1) + abs(xi1), d__2 = abs(xr2) + abs(xi2);
*xnorm = max(d__1,d__2);
/* Further scaling if norm(A) norm(X) > overflow */
if (*xnorm > 1. && cmax > 1.) {
if (*xnorm > bignum / cmax) {
temp = cmax / bignum;
x[x_dim1 + 1] = temp * x[x_dim1 + 1];
x[x_dim1 + 2] = temp * x[x_dim1 + 2];
x[(x_dim1 << 1) + 1] = temp * x[(x_dim1 << 1) + 1];
x[(x_dim1 << 1) + 2] = temp * x[(x_dim1 << 1) + 2];
*xnorm = temp * *xnorm;
*scale = temp * *scale;
}
}
}
}
return 0;
/* End of DLALN2 */
} /* igraphdlaln2_ */
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 igraphdlarrf_(integer *n, doublereal *d__, doublereal *l,
doublereal *ld, integer *clstrt, integer *clend, doublereal *w,
doublereal *wgap, doublereal *werr, doublereal *spdiam, doublereal *
clgapl, doublereal *clgapr, doublereal *pivmin, doublereal *sigma,
doublereal *dplus, doublereal *lplus, doublereal *work, integer *info)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__;
doublereal s, bestshift, smlgrowth, eps, tmp, max1, max2, rrr1, rrr2,
znm2, growthbound, fail, fact, oldp;
integer indx;
doublereal prod;
integer ktry;
doublereal fail2, avgap, ldmax, rdmax;
integer shift;
extern /* Subroutine */ int igraphdcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
logical dorrr1;
extern doublereal igraphdlamch_(char *);
doublereal ldelta;
logical nofail;
doublereal mingap, lsigma, rdelta;
extern logical igraphdisnan_(doublereal *);
logical forcer;
doublereal rsigma, clwdth;
logical sawnan1, sawnan2, tryrrr1;
/* -- LAPACK auxiliary 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
=======
Given the initial representation L D L^T and its cluster of close
eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ...
W( CLEND ), DLARRF finds a new relatively robust representation
L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the
eigenvalues of L(+) D(+) L(+)^T is relatively isolated.
Arguments
=========
N (input) INTEGER
The order of the matrix (subblock, if the matrix splitted).
D (input) DOUBLE PRECISION array, dimension (N)
The N diagonal elements of the diagonal matrix D.
L (input) DOUBLE PRECISION array, dimension (N-1)
The (N-1) subdiagonal elements of the unit bidiagonal
matrix L.
LD (input) DOUBLE PRECISION array, dimension (N-1)
The (N-1) elements L(i)*D(i).
CLSTRT (input) INTEGER
The index of the first eigenvalue in the cluster.
CLEND (input) INTEGER
The index of the last eigenvalue in the cluster.
W (input) DOUBLE PRECISION array, dimension
dimension is >= (CLEND-CLSTRT+1)
The eigenvalue APPROXIMATIONS of L D L^T in ascending order.
W( CLSTRT ) through W( CLEND ) form the cluster of relatively
close eigenalues.
WGAP (input/output) DOUBLE PRECISION array, dimension
dimension is >= (CLEND-CLSTRT+1)
The separation from the right neighbor eigenvalue in W.
WERR (input) DOUBLE PRECISION array, dimension
dimension is >= (CLEND-CLSTRT+1)
WERR contain the semiwidth of the uncertainty
interval of the corresponding eigenvalue APPROXIMATION in W
SPDIAM (input) DOUBLE PRECISION
estimate of the spectral diameter obtained from the
Gerschgorin intervals
CLGAPL (input) DOUBLE PRECISION
CLGAPR (input) DOUBLE PRECISION
absolute gap on each end of the cluster.
Set by the calling routine to protect against shifts too close
to eigenvalues outside the cluster.
PIVMIN (input) DOUBLE PRECISION
The minimum pivot allowed in the Sturm sequence.
SIGMA (output) DOUBLE PRECISION
The shift used to form L(+) D(+) L(+)^T.
DPLUS (output) DOUBLE PRECISION array, dimension (N)
The N diagonal elements of the diagonal matrix D(+).
LPLUS (output) DOUBLE PRECISION array, dimension (N-1)
The first (N-1) elements of LPLUS contain the subdiagonal
elements of the unit bidiagonal matrix L(+).
WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
Workspace.
INFO (output) INTEGER
Signals processing OK (=0) or failure (=1)
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
=====================================================================
Parameter adjustments */
--work;
--lplus;
--dplus;
--werr;
--wgap;
--w;
--ld;
--l;
--d__;
/* Function Body */
*info = 0;
fact = 2.;
eps = igraphdlamch_("Precision");
shift = 0;
forcer = FALSE_;
/* Note that we cannot guarantee that for any of the shifts tried,
the factorization has a small or even moderate element growth.
There could be Ritz values at both ends of the cluster and despite
backing off, there are examples where all factorizations tried
(in IEEE mode, allowing zero pivots & infinities) have INFINITE
element growth.
For this reason, we should use PIVMIN in this subroutine so that at
least the L D L^T factorization exists. It can be checked afterwards
whether the element growth caused bad residuals/orthogonality.
Decide whether the code should accept the best among all
representations despite large element growth or signal INFO=1 */
nofail = TRUE_;
/* Compute the average gap length of the cluster */
clwdth = (d__1 = w[*clend] - w[*clstrt], abs(d__1)) + werr[*clend] + werr[
*clstrt];
avgap = clwdth / (doublereal) (*clend - *clstrt);
mingap = min(*clgapl,*clgapr);
/* Initial values for shifts to both ends of cluster
Computing MIN */
d__1 = w[*clstrt], d__2 = w[*clend];
lsigma = min(d__1,d__2) - werr[*clstrt];
/* Computing MAX */
d__1 = w[*clstrt], d__2 = w[*clend];
rsigma = max(d__1,d__2) + werr[*clend];
/* Use a small fudge to make sure that we really shift to the outside */
lsigma -= abs(lsigma) * 4. * eps;
rsigma += abs(rsigma) * 4. * eps;
/* Compute upper bounds for how much to back off the initial shifts */
ldmax = mingap * .25 + *pivmin * 2.;
rdmax = mingap * .25 + *pivmin * 2.;
/* Computing MAX */
d__1 = avgap, d__2 = wgap[*clstrt];
ldelta = max(d__1,d__2) / fact;
/* Computing MAX */
d__1 = avgap, d__2 = wgap[*clend - 1];
rdelta = max(d__1,d__2) / fact;
/* Initialize the record of the best representation found */
s = igraphdlamch_("S");
smlgrowth = 1. / s;
fail = (doublereal) (*n - 1) * mingap / (*spdiam * eps);
fail2 = (doublereal) (*n - 1) * mingap / (*spdiam * sqrt(eps));
bestshift = lsigma;
/* while (KTRY <= KTRYMAX) */
ktry = 0;
growthbound = *spdiam * 8.;
L5:
sawnan1 = FALSE_;
sawnan2 = FALSE_;
/* Ensure that we do not back off too much of the initial shifts */
ldelta = min(ldmax,ldelta);
rdelta = min(rdmax,rdelta);
/* Compute the element growth when shifting to both ends of the cluster
accept the shift if there is no element growth at one of the two ends
Left end */
s = -lsigma;
dplus[1] = d__[1] + s;
if (abs(dplus[1]) < *pivmin) {
dplus[1] = -(*pivmin);
/* Need to set SAWNAN1 because refined RRR test should not be used
in this case */
sawnan1 = TRUE_;
}
max1 = abs(dplus[1]);
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
lplus[i__] = ld[i__] / dplus[i__];
s = s * lplus[i__] * l[i__] - lsigma;
dplus[i__ + 1] = d__[i__ + 1] + s;
if ((d__1 = dplus[i__ + 1], abs(d__1)) < *pivmin) {
dplus[i__ + 1] = -(*pivmin);
/* Need to set SAWNAN1 because refined RRR test should not be used
in this case */
sawnan1 = TRUE_;
}
/* Computing MAX */
d__2 = max1, d__3 = (d__1 = dplus[i__ + 1], abs(d__1));
max1 = max(d__2,d__3);
/* L6: */
}
sawnan1 = sawnan1 || igraphdisnan_(&max1);
if (forcer || max1 <= growthbound && ! sawnan1) {
*sigma = lsigma;
shift = 1;
goto L100;
}
/* Right end */
s = -rsigma;
work[1] = d__[1] + s;
if (abs(work[1]) < *pivmin) {
work[1] = -(*pivmin);
/* Need to set SAWNAN2 because refined RRR test should not be used
in this case */
sawnan2 = TRUE_;
}
max2 = abs(work[1]);
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
work[*n + i__] = ld[i__] / work[i__];
s = s * work[*n + i__] * l[i__] - rsigma;
work[i__ + 1] = d__[i__ + 1] + s;
if ((d__1 = work[i__ + 1], abs(d__1)) < *pivmin) {
work[i__ + 1] = -(*pivmin);
/* Need to set SAWNAN2 because refined RRR test should not be used
in this case */
sawnan2 = TRUE_;
}
/* Computing MAX */
d__2 = max2, d__3 = (d__1 = work[i__ + 1], abs(d__1));
max2 = max(d__2,d__3);
/* L7: */
}
sawnan2 = sawnan2 || igraphdisnan_(&max2);
if (forcer || max2 <= growthbound && ! sawnan2) {
*sigma = rsigma;
shift = 2;
goto L100;
}
/* If we are at this point, both shifts led to too much element growth
Record the better of the two shifts (provided it didn't lead to NaN) */
if (sawnan1 && sawnan2) {
/* both MAX1 and MAX2 are NaN */
goto L50;
} else {
if (! sawnan1) {
indx = 1;
if (max1 <= smlgrowth) {
smlgrowth = max1;
bestshift = lsigma;
}
}
if (! sawnan2) {
if (sawnan1 || max2 <= max1) {
indx = 2;
}
if (max2 <= smlgrowth) {
smlgrowth = max2;
bestshift = rsigma;
}
}
}
/* If we are here, both the left and the right shift led to
element growth. If the element growth is moderate, then
we may still accept the representation, if it passes a
refined test for RRR. This test supposes that no NaN occurred.
Moreover, we use the refined RRR test only for isolated clusters. */
if (clwdth < mingap / 128. && min(max1,max2) < fail2 && ! sawnan1 && !
sawnan2) {
dorrr1 = TRUE_;
} else {
dorrr1 = FALSE_;
}
tryrrr1 = TRUE_;
if (tryrrr1 && dorrr1) {
if (indx == 1) {
tmp = (d__1 = dplus[*n], abs(d__1));
znm2 = 1.;
prod = 1.;
oldp = 1.;
for (i__ = *n - 1; i__ >= 1; --i__) {
if (prod <= eps) {
prod = dplus[i__ + 1] * work[*n + i__ + 1] / (dplus[i__] *
work[*n + i__]) * oldp;
} else {
prod *= (d__1 = work[*n + i__], abs(d__1));
}
oldp = prod;
/* Computing 2nd power */
d__1 = prod;
znm2 += d__1 * d__1;
/* Computing MAX */
d__2 = tmp, d__3 = (d__1 = dplus[i__] * prod, abs(d__1));
tmp = max(d__2,d__3);
/* L15: */
}
rrr1 = tmp / (*spdiam * sqrt(znm2));
if (rrr1 <= 8.) {
*sigma = lsigma;
shift = 1;
goto L100;
}
} else if (indx == 2) {
tmp = (d__1 = work[*n], abs(d__1));
znm2 = 1.;
prod = 1.;
oldp = 1.;
for (i__ = *n - 1; i__ >= 1; --i__) {
if (prod <= eps) {
prod = work[i__ + 1] * lplus[i__ + 1] / (work[i__] *
lplus[i__]) * oldp;
} else {
prod *= (d__1 = lplus[i__], abs(d__1));
}
oldp = prod;
/* Computing 2nd power */
d__1 = prod;
znm2 += d__1 * d__1;
/* Computing MAX */
d__2 = tmp, d__3 = (d__1 = work[i__] * prod, abs(d__1));
tmp = max(d__2,d__3);
/* L16: */
}
rrr2 = tmp / (*spdiam * sqrt(znm2));
if (rrr2 <= 8.) {
*sigma = rsigma;
shift = 2;
goto L100;
}
}
}
L50:
if (ktry < 1) {
/* If we are here, both shifts failed also the RRR test.
Back off to the outside
Computing MAX */
d__1 = lsigma - ldelta, d__2 = lsigma - ldmax;
lsigma = max(d__1,d__2);
/* Computing MIN */
d__1 = rsigma + rdelta, d__2 = rsigma + rdmax;
rsigma = min(d__1,d__2);
ldelta *= 2.;
rdelta *= 2.;
++ktry;
goto L5;
} else {
/* None of the representations investigated satisfied our
criteria. Take the best one we found. */
if (smlgrowth < fail || nofail) {
lsigma = bestshift;
rsigma = bestshift;
forcer = TRUE_;
goto L5;
} else {
*info = 1;
return 0;
}
}
L100:
if (shift == 1) {
} else if (shift == 2) {
/* store new L and D back into DPLUS, LPLUS */
igraphdcopy_(n, &work[1], &c__1, &dplus[1], &c__1);
i__1 = *n - 1;
igraphdcopy_(&i__1, &work[*n + 1], &c__1, &lplus[1], &c__1);
}
return 0;
/* End of DLARRF */
} /* igraphdlarrf_ */
/* 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 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 igraphdlarrf_(integer *n, doublereal *d__, doublereal *l,
doublereal *ld, integer *clstrt, integer *clend, doublereal *w,
doublereal *wgap, doublereal *werr, doublereal *spdiam, doublereal *
clgapl, doublereal *clgapr, doublereal *pivmin, doublereal *sigma,
doublereal *dplus, doublereal *lplus, doublereal *work, integer *info)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__;
doublereal s, bestshift, smlgrowth, eps, tmp, max1, max2, rrr1, rrr2,
znm2, growthbound, fail, fact, oldp;
integer indx;
doublereal prod;
integer ktry;
doublereal fail2, avgap, ldmax, rdmax;
integer shift;
extern /* Subroutine */ int igraphdcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
logical dorrr1;
extern doublereal igraphdlamch_(char *);
doublereal ldelta;
logical nofail;
doublereal mingap, lsigma, rdelta;
extern logical igraphdisnan_(doublereal *);
logical forcer;
doublereal rsigma, clwdth;
logical sawnan1, sawnan2, tryrrr1;
/* -- 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 */
--work;
--lplus;
--dplus;
--werr;
--wgap;
--w;
--ld;
--l;
--d__;
/* Function Body */
*info = 0;
fact = 2.;
eps = igraphdlamch_("Precision");
shift = 0;
forcer = FALSE_;
/* Note that we cannot guarantee that for any of the shifts tried,
the factorization has a small or even moderate element growth.
There could be Ritz values at both ends of the cluster and despite
backing off, there are examples where all factorizations tried
(in IEEE mode, allowing zero pivots & infinities) have INFINITE
element growth.
For this reason, we should use PIVMIN in this subroutine so that at
least the L D L^T factorization exists. It can be checked afterwards
whether the element growth caused bad residuals/orthogonality.
Decide whether the code should accept the best among all
representations despite large element growth or signal INFO=1 */
nofail = TRUE_;
/* Compute the average gap length of the cluster */
clwdth = (d__1 = w[*clend] - w[*clstrt], abs(d__1)) + werr[*clend] + werr[
*clstrt];
avgap = clwdth / (doublereal) (*clend - *clstrt);
mingap = min(*clgapl,*clgapr);
/* Initial values for shifts to both ends of cluster
Computing MIN */
d__1 = w[*clstrt], d__2 = w[*clend];
lsigma = min(d__1,d__2) - werr[*clstrt];
/* Computing MAX */
d__1 = w[*clstrt], d__2 = w[*clend];
rsigma = max(d__1,d__2) + werr[*clend];
/* Use a small fudge to make sure that we really shift to the outside */
lsigma -= abs(lsigma) * 4. * eps;
rsigma += abs(rsigma) * 4. * eps;
/* Compute upper bounds for how much to back off the initial shifts */
ldmax = mingap * .25 + *pivmin * 2.;
rdmax = mingap * .25 + *pivmin * 2.;
/* Computing MAX */
d__1 = avgap, d__2 = wgap[*clstrt];
ldelta = max(d__1,d__2) / fact;
/* Computing MAX */
d__1 = avgap, d__2 = wgap[*clend - 1];
rdelta = max(d__1,d__2) / fact;
/* Initialize the record of the best representation found */
s = igraphdlamch_("S");
smlgrowth = 1. / s;
fail = (doublereal) (*n - 1) * mingap / (*spdiam * eps);
fail2 = (doublereal) (*n - 1) * mingap / (*spdiam * sqrt(eps));
bestshift = lsigma;
/* while (KTRY <= KTRYMAX) */
ktry = 0;
growthbound = *spdiam * 8.;
L5:
sawnan1 = FALSE_;
sawnan2 = FALSE_;
/* Ensure that we do not back off too much of the initial shifts */
ldelta = min(ldmax,ldelta);
rdelta = min(rdmax,rdelta);
/* Compute the element growth when shifting to both ends of the cluster
accept the shift if there is no element growth at one of the two ends
Left end */
s = -lsigma;
dplus[1] = d__[1] + s;
if (abs(dplus[1]) < *pivmin) {
dplus[1] = -(*pivmin);
/* Need to set SAWNAN1 because refined RRR test should not be used
in this case */
sawnan1 = TRUE_;
}
max1 = abs(dplus[1]);
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
lplus[i__] = ld[i__] / dplus[i__];
s = s * lplus[i__] * l[i__] - lsigma;
dplus[i__ + 1] = d__[i__ + 1] + s;
if ((d__1 = dplus[i__ + 1], abs(d__1)) < *pivmin) {
dplus[i__ + 1] = -(*pivmin);
/* Need to set SAWNAN1 because refined RRR test should not be used
in this case */
sawnan1 = TRUE_;
}
/* Computing MAX */
d__2 = max1, d__3 = (d__1 = dplus[i__ + 1], abs(d__1));
max1 = max(d__2,d__3);
/* L6: */
}
sawnan1 = sawnan1 || igraphdisnan_(&max1);
if (forcer || max1 <= growthbound && ! sawnan1) {
*sigma = lsigma;
shift = 1;
goto L100;
}
/* Right end */
s = -rsigma;
work[1] = d__[1] + s;
if (abs(work[1]) < *pivmin) {
work[1] = -(*pivmin);
/* Need to set SAWNAN2 because refined RRR test should not be used
in this case */
sawnan2 = TRUE_;
}
max2 = abs(work[1]);
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
work[*n + i__] = ld[i__] / work[i__];
s = s * work[*n + i__] * l[i__] - rsigma;
work[i__ + 1] = d__[i__ + 1] + s;
if ((d__1 = work[i__ + 1], abs(d__1)) < *pivmin) {
work[i__ + 1] = -(*pivmin);
/* Need to set SAWNAN2 because refined RRR test should not be used
in this case */
sawnan2 = TRUE_;
}
/* Computing MAX */
d__2 = max2, d__3 = (d__1 = work[i__ + 1], abs(d__1));
max2 = max(d__2,d__3);
/* L7: */
}
sawnan2 = sawnan2 || igraphdisnan_(&max2);
if (forcer || max2 <= growthbound && ! sawnan2) {
*sigma = rsigma;
shift = 2;
goto L100;
}
/* If we are at this point, both shifts led to too much element growth
Record the better of the two shifts (provided it didn't lead to NaN) */
if (sawnan1 && sawnan2) {
/* both MAX1 and MAX2 are NaN */
goto L50;
} else {
if (! sawnan1) {
indx = 1;
if (max1 <= smlgrowth) {
smlgrowth = max1;
bestshift = lsigma;
}
}
if (! sawnan2) {
if (sawnan1 || max2 <= max1) {
indx = 2;
}
if (max2 <= smlgrowth) {
smlgrowth = max2;
bestshift = rsigma;
}
}
}
/* If we are here, both the left and the right shift led to
element growth. If the element growth is moderate, then
we may still accept the representation, if it passes a
refined test for RRR. This test supposes that no NaN occurred.
Moreover, we use the refined RRR test only for isolated clusters. */
if (clwdth < mingap / 128. && min(max1,max2) < fail2 && ! sawnan1 && !
sawnan2) {
dorrr1 = TRUE_;
} else {
dorrr1 = FALSE_;
}
tryrrr1 = TRUE_;
if (tryrrr1 && dorrr1) {
if (indx == 1) {
tmp = (d__1 = dplus[*n], abs(d__1));
znm2 = 1.;
prod = 1.;
oldp = 1.;
for (i__ = *n - 1; i__ >= 1; --i__) {
if (prod <= eps) {
prod = dplus[i__ + 1] * work[*n + i__ + 1] / (dplus[i__] *
work[*n + i__]) * oldp;
} else {
prod *= (d__1 = work[*n + i__], abs(d__1));
}
oldp = prod;
/* Computing 2nd power */
d__1 = prod;
znm2 += d__1 * d__1;
/* Computing MAX */
d__2 = tmp, d__3 = (d__1 = dplus[i__] * prod, abs(d__1));
tmp = max(d__2,d__3);
/* L15: */
}
rrr1 = tmp / (*spdiam * sqrt(znm2));
if (rrr1 <= 8.) {
*sigma = lsigma;
shift = 1;
goto L100;
}
} else if (indx == 2) {
tmp = (d__1 = work[*n], abs(d__1));
znm2 = 1.;
prod = 1.;
oldp = 1.;
for (i__ = *n - 1; i__ >= 1; --i__) {
if (prod <= eps) {
prod = work[i__ + 1] * lplus[i__ + 1] / (work[i__] *
lplus[i__]) * oldp;
} else {
prod *= (d__1 = lplus[i__], abs(d__1));
}
oldp = prod;
/* Computing 2nd power */
d__1 = prod;
znm2 += d__1 * d__1;
/* Computing MAX */
d__2 = tmp, d__3 = (d__1 = work[i__] * prod, abs(d__1));
tmp = max(d__2,d__3);
/* L16: */
}
rrr2 = tmp / (*spdiam * sqrt(znm2));
if (rrr2 <= 8.) {
*sigma = rsigma;
shift = 2;
goto L100;
}
}
}
L50:
if (ktry < 1) {
/* If we are here, both shifts failed also the RRR test.
Back off to the outside
Computing MAX */
d__1 = lsigma - ldelta, d__2 = lsigma - ldmax;
lsigma = max(d__1,d__2);
/* Computing MIN */
d__1 = rsigma + rdelta, d__2 = rsigma + rdmax;
rsigma = min(d__1,d__2);
ldelta *= 2.;
rdelta *= 2.;
++ktry;
goto L5;
} else {
/* None of the representations investigated satisfied our
criteria. Take the best one we found. */
if (smlgrowth < fail || nofail) {
lsigma = bestshift;
rsigma = bestshift;
forcer = TRUE_;
goto L5;
} else {
*info = 1;
return 0;
}
}
L100:
if (shift == 1) {
} else if (shift == 2) {
/* store new L and D back into DPLUS, LPLUS */
igraphdcopy_(n, &work[1], &c__1, &dplus[1], &c__1);
i__1 = *n - 1;
igraphdcopy_(&i__1, &work[*n + 1], &c__1, &lplus[1], &c__1);
}
return 0;
/* End of DLARRF */
} /* igraphdlarrf_ */
/* 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 igraphdsteqr_(char *compz, integer *n, doublereal *d__,
doublereal *e, doublereal *z__, integer *ldz, doublereal *work,
integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
doublereal b, c__, f, g;
integer i__, j, k, l, m;
doublereal p, r__, s;
integer l1, ii, mm, lm1, mm1, nm1;
doublereal rt1, rt2, eps;
integer lsv;
doublereal tst, eps2;
integer lend, jtot;
extern /* Subroutine */ int igraphdlae2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *);
extern logical igraphlsame_(char *, char *);
extern /* Subroutine */ int igraphdlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *);
doublereal anorm;
extern /* Subroutine */ int igraphdswap_(integer *, doublereal *, integer *,
doublereal *, integer *), igraphdlaev2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
integer lendm1, lendp1;
extern doublereal igraphdlapy2_(doublereal *, doublereal *), igraphdlamch_(char *);
integer iscale;
extern /* Subroutine */ int igraphdlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), igraphdlaset_(char *, integer *, integer
*, doublereal *, doublereal *, doublereal *, integer *);
doublereal safmin;
extern /* Subroutine */ int igraphdlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
doublereal safmax;
extern /* Subroutine */ int igraphxerbla_(char *, integer *, ftnlen);
extern doublereal igraphdlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int igraphdlasrt_(char *, integer *, doublereal *,
integer *);
integer lendsv;
doublereal ssfmin;
integer nmaxit, icompz;
doublereal ssfmax;
/* -- LAPACK computational routine (version 3.4.0) --
-- LAPACK is a software package provided by Univ. of Tennessee, --
-- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
November 2011
=====================================================================
Test the input parameters.
Parameter adjustments */
--d__;
--e;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
/* Function Body */
*info = 0;
if (igraphlsame_(compz, "N")) {
icompz = 0;
} else if (igraphlsame_(compz, "V")) {
icompz = 1;
} else if (igraphlsame_(compz, "I")) {
icompz = 2;
} else {
icompz = -1;
}
if (icompz < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
igraphxerbla_("DSTEQR", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz == 2) {
z__[z_dim1 + 1] = 1.;
}
return 0;
}
/* Determine the unit roundoff and over/underflow thresholds. */
eps = igraphdlamch_("E");
/* Computing 2nd power */
d__1 = eps;
eps2 = d__1 * d__1;
safmin = igraphdlamch_("S");
safmax = 1. / safmin;
ssfmax = sqrt(safmax) / 3.;
ssfmin = sqrt(safmin) / eps2;
/* Compute the eigenvalues and eigenvectors of the tridiagonal
matrix. */
if (icompz == 2) {
igraphdlaset_("Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz);
}
nmaxit = *n * 30;
jtot = 0;
/* Determine where the matrix splits and choose QL or QR iteration
for each block, according to whether top or bottom diagonal
element is smaller. */
l1 = 1;
nm1 = *n - 1;
L10:
if (l1 > *n) {
goto L160;
}
if (l1 > 1) {
e[l1 - 1] = 0.;
}
if (l1 <= nm1) {
i__1 = nm1;
for (m = l1; m <= i__1; ++m) {
tst = (d__1 = e[m], abs(d__1));
if (tst == 0.) {
goto L30;
}
if (tst <= sqrt((d__1 = d__[m], abs(d__1))) * sqrt((d__2 = d__[m
+ 1], abs(d__2))) * eps) {
e[m] = 0.;
goto L30;
}
/* L20: */
}
}
m = *n;
L30:
l = l1;
lsv = l;
lend = m;
lendsv = lend;
l1 = m + 1;
if (lend == l) {
goto L10;
}
/* Scale submatrix in rows and columns L to LEND */
i__1 = lend - l + 1;
anorm = igraphdlanst_("M", &i__1, &d__[l], &e[l]);
iscale = 0;
if (anorm == 0.) {
goto L10;
}
if (anorm > ssfmax) {
iscale = 1;
i__1 = lend - l + 1;
igraphdlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
igraphdlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n,
info);
} else if (anorm < ssfmin) {
iscale = 2;
i__1 = lend - l + 1;
igraphdlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
igraphdlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
info);
}
/* Choose between QL and QR iteration */
if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) {
lend = lsv;
l = lendsv;
}
if (lend > l) {
/* QL Iteration
Look for small subdiagonal element. */
L40:
if (l != lend) {
lendm1 = lend - 1;
i__1 = lendm1;
for (m = l; m <= i__1; ++m) {
/* Computing 2nd power */
d__2 = (d__1 = e[m], abs(d__1));
tst = d__2 * d__2;
if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m
+ 1], abs(d__2)) + safmin) {
goto L60;
}
/* L50: */
}
}
m = lend;
L60:
if (m < lend) {
e[m] = 0.;
}
p = d__[l];
if (m == l) {
goto L80;
}
/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
to compute its eigensystem. */
if (m == l + 1) {
if (icompz > 0) {
igraphdlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s);
work[l] = c__;
work[*n - 1 + l] = s;
igraphdlasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], &
z__[l * z_dim1 + 1], ldz);
} else {
igraphdlae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2);
}
d__[l] = rt1;
d__[l + 1] = rt2;
e[l] = 0.;
l += 2;
if (l <= lend) {
goto L40;
}
goto L140;
}
if (jtot == nmaxit) {
goto L140;
}
++jtot;
/* Form shift. */
g = (d__[l + 1] - p) / (e[l] * 2.);
r__ = igraphdlapy2_(&g, &c_b10);
g = d__[m] - p + e[l] / (g + d_sign(&r__, &g));
s = 1.;
c__ = 1.;
p = 0.;
/* Inner loop */
mm1 = m - 1;
i__1 = l;
for (i__ = mm1; i__ >= i__1; --i__) {
f = s * e[i__];
b = c__ * e[i__];
igraphdlartg_(&g, &f, &c__, &s, &r__);
if (i__ != m - 1) {
e[i__ + 1] = r__;
}
g = d__[i__ + 1] - p;
r__ = (d__[i__] - g) * s + c__ * 2. * b;
p = s * r__;
d__[i__ + 1] = g + p;
g = c__ * r__ - b;
/* If eigenvectors are desired, then save rotations. */
if (icompz > 0) {
work[i__] = c__;
work[*n - 1 + i__] = -s;
}
/* L70: */
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0) {
mm = m - l + 1;
igraphdlasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l
* z_dim1 + 1], ldz);
}
d__[l] -= p;
e[l] = g;
goto L40;
/* Eigenvalue found. */
L80:
d__[l] = p;
++l;
if (l <= lend) {
goto L40;
}
goto L140;
} else {
/* QR Iteration
Look for small superdiagonal element. */
L90:
if (l != lend) {
lendp1 = lend + 1;
i__1 = lendp1;
for (m = l; m >= i__1; --m) {
/* Computing 2nd power */
d__2 = (d__1 = e[m - 1], abs(d__1));
tst = d__2 * d__2;
if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m
- 1], abs(d__2)) + safmin) {
goto L110;
}
/* L100: */
}
}
m = lend;
L110:
if (m > lend) {
e[m - 1] = 0.;
}
p = d__[l];
if (m == l) {
goto L130;
}
/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
to compute its eigensystem. */
if (m == l - 1) {
if (icompz > 0) {
igraphdlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s)
;
work[m] = c__;
work[*n - 1 + m] = s;
igraphdlasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], &
z__[(l - 1) * z_dim1 + 1], ldz);
} else {
igraphdlae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2);
}
d__[l - 1] = rt1;
d__[l] = rt2;
e[l - 1] = 0.;
l += -2;
if (l >= lend) {
goto L90;
}
goto L140;
}
if (jtot == nmaxit) {
goto L140;
}
++jtot;
/* Form shift. */
g = (d__[l - 1] - p) / (e[l - 1] * 2.);
r__ = igraphdlapy2_(&g, &c_b10);
g = d__[m] - p + e[l - 1] / (g + d_sign(&r__, &g));
s = 1.;
c__ = 1.;
p = 0.;
/* Inner loop */
lm1 = l - 1;
i__1 = lm1;
for (i__ = m; i__ <= i__1; ++i__) {
f = s * e[i__];
b = c__ * e[i__];
igraphdlartg_(&g, &f, &c__, &s, &r__);
if (i__ != m) {
e[i__ - 1] = r__;
}
g = d__[i__] - p;
r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b;
p = s * r__;
d__[i__] = g + p;
g = c__ * r__ - b;
/* If eigenvectors are desired, then save rotations. */
if (icompz > 0) {
work[i__] = c__;
work[*n - 1 + i__] = s;
}
/* L120: */
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0) {
mm = l - m + 1;
igraphdlasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m
* z_dim1 + 1], ldz);
}
d__[l] -= p;
e[lm1] = g;
goto L90;
/* Eigenvalue found. */
L130:
d__[l] = p;
--l;
if (l >= lend) {
goto L90;
}
goto L140;
}
/* Undo scaling if necessary */
L140:
if (iscale == 1) {
i__1 = lendsv - lsv + 1;
igraphdlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
i__1 = lendsv - lsv;
igraphdlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n,
info);
} else if (iscale == 2) {
i__1 = lendsv - lsv + 1;
igraphdlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
i__1 = lendsv - lsv;
igraphdlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n,
info);
}
/* Check for no convergence to an eigenvalue after a total
of N*MAXIT iterations. */
if (jtot < nmaxit) {
goto L10;
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (e[i__] != 0.) {
++(*info);
}
/* L150: */
}
goto L190;
/* Order eigenvalues and eigenvectors. */
L160:
if (icompz == 0) {
/* Use Quick Sort */
igraphdlasrt_("I", n, &d__[1], info);
} else {
/* Use Selection Sort to minimize swaps of eigenvectors */
i__1 = *n;
for (ii = 2; ii <= i__1; ++ii) {
i__ = ii - 1;
k = i__;
p = d__[i__];
i__2 = *n;
for (j = ii; j <= i__2; ++j) {
if (d__[j] < p) {
k = j;
p = d__[j];
}
/* L170: */
}
if (k != i__) {
d__[k] = d__[i__];
d__[i__] = p;
igraphdswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1],
&c__1);
}
/* L180: */
}
}
L190:
return 0;
/* End of DSTEQR */
} /* igraphdsteqr_ */
/* Subroutine */ int igraphdstebz_(char *range, char *order, integer *n, doublereal
*vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol,
doublereal *d__, doublereal *e, integer *m, integer *nsplit,
doublereal *w, integer *iblock, integer *isplit, doublereal *work,
integer *iwork, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1, d__2, d__3, d__4, d__5;
/* Builtin functions */
double sqrt(doublereal), log(doublereal);
/* Local variables */
integer j, ib, jb, ie, je, nb;
doublereal gl;
integer im, in;
doublereal gu;
integer iw;
doublereal wl, wu;
integer nwl;
doublereal ulp, wlu, wul;
integer nwu;
doublereal tmp1, tmp2;
integer iend, ioff, iout, itmp1, jdisc;
extern logical igraphlsame_(char *, char *);
integer iinfo;
doublereal atoli;
integer iwoff;
doublereal bnorm;
integer itmax;
doublereal wkill, rtoli, tnorm;
extern doublereal igraphdlamch_(char *);
integer ibegin;
extern /* Subroutine */ int igraphdlaebz_(integer *, integer *, integer *,
integer *, integer *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
integer irange, idiscl;
doublereal safemn;
integer idumma[1];
extern /* Subroutine */ int igraphxerbla_(char *, integer *, ftnlen);
extern integer igraphilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
integer idiscu, iorder;
logical ncnvrg;
doublereal pivmin;
logical toofew;
/* -- LAPACK routine (version 3.3.1) --
-- LAPACK is a software package provided by Univ. of Tennessee, --
-- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-- April 2011 --
8-18-00: Increase FUDGE factor for T3E (eca)
Purpose
=======
DSTEBZ computes the eigenvalues of a symmetric tridiagonal
matrix T. The user may ask for all eigenvalues, all eigenvalues
in the half-open interval (VL, VU], or the IL-th through IU-th
eigenvalues.
To avoid overflow, the matrix must be scaled so that its
largest element is no greater than overflow**(1/2) *
underflow**(1/4) in absolute value, and for greatest
accuracy, it should not be much smaller than that.
See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
Matrix", Report CS41, Computer Science Dept., Stanford
University, July 21, 1966.
Arguments
=========
RANGE (input) CHARACTER*1
= 'A': ("All") all eigenvalues will be found.
= 'V': ("Value") all eigenvalues in the half-open interval
(VL, VU] will be found.
= 'I': ("Index") the IL-th through IU-th eigenvalues (of the
entire matrix) will be found.
ORDER (input) CHARACTER*1
= 'B': ("By Block") the eigenvalues will be grouped by
split-off block (see IBLOCK, ISPLIT) and
ordered from smallest to largest within
the block.
= 'E': ("Entire matrix")
the eigenvalues for the entire matrix
will be ordered from smallest to
largest.
N (input) INTEGER
The order of the tridiagonal matrix T. N >= 0.
VL (input) DOUBLE PRECISION
VU (input) DOUBLE PRECISION
If RANGE='V', the lower and upper bounds of the interval to
be searched for eigenvalues. Eigenvalues less than or equal
to VL, or greater than VU, will not be returned. VL < VU.
Not referenced if RANGE = 'A' or 'I'.
IL (input) INTEGER
IU (input) INTEGER
If RANGE='I', the indices (in ascending order) of the
smallest and largest eigenvalues to be returned.
1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
Not referenced if RANGE = 'A' or 'V'.
ABSTOL (input) DOUBLE PRECISION
The absolute tolerance for the eigenvalues. An eigenvalue
(or cluster) is considered to be located if it has been
determined to lie in an interval whose width is ABSTOL or
less. If ABSTOL is less than or equal to zero, then ULP*|T|
will be used, where |T| means the 1-norm of T.
Eigenvalues will be computed most accurately when ABSTOL is
set to twice the underflow threshold 2*DLAMCH('S'), not zero.
D (input) DOUBLE PRECISION array, dimension (N)
The n diagonal elements of the tridiagonal matrix T.
E (input) DOUBLE PRECISION array, dimension (N-1)
The (n-1) off-diagonal elements of the tridiagonal matrix T.
M (output) INTEGER
The actual number of eigenvalues found. 0 <= M <= N.
(See also the description of INFO=2,3.)
NSPLIT (output) INTEGER
The number of diagonal blocks in the matrix T.
1 <= NSPLIT <= N.
W (output) DOUBLE PRECISION array, dimension (N)
On exit, the first M elements of W will contain the
eigenvalues. (DSTEBZ may use the remaining N-M elements as
workspace.)
IBLOCK (output) INTEGER array, dimension (N)
At each row/column j where E(j) is zero or small, the
matrix T is considered to split into a block diagonal
matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which
block (from 1 to the number of blocks) the eigenvalue W(i)
belongs. (DSTEBZ may use the remaining N-M elements as
workspace.)
ISPLIT (output) INTEGER array, dimension (N)
The splitting points, at which T breaks up into submatrices.
The first submatrix consists of rows/columns 1 to ISPLIT(1),
the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
etc., and the NSPLIT-th consists of rows/columns
ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
(Only the first NSPLIT elements will actually be used, but
since the user cannot know a priori what value NSPLIT will
have, N words must be reserved for ISPLIT.)
WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
IWORK (workspace) INTEGER array, dimension (3*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: some or all of the eigenvalues failed to converge or
were not computed:
=1 or 3: Bisection failed to converge for some
eigenvalues; these eigenvalues are flagged by a
negative block number. The effect is that the
eigenvalues may not be as accurate as the
absolute and relative tolerances. This is
generally caused by unexpectedly inaccurate
arithmetic.
=2 or 3: RANGE='I' only: Not all of the eigenvalues
IL:IU were found.
Effect: M < IU+1-IL
Cause: non-monotonic arithmetic, causing the
Sturm sequence to be non-monotonic.
Cure: recalculate, using RANGE='A', and pick
out eigenvalues IL:IU. In some cases,
increasing the PARAMETER "FUDGE" may
make things work.
= 4: RANGE='I', and the Gershgorin interval
initially used was too small. No eigenvalues
were computed.
Probable cause: your machine has sloppy
floating-point arithmetic.
Cure: Increase the PARAMETER "FUDGE",
recompile, and try again.
Internal Parameters
===================
RELFAC DOUBLE PRECISION, default = 2.0e0
The relative tolerance. An interval (a,b] lies within
"relative tolerance" if b-a < RELFAC*ulp*max(|a|,|b|),
where "ulp" is the machine precision (distance from 1 to
the next larger floating point number.)
FUDGE DOUBLE PRECISION, default = 2
A "fudge factor" to widen the Gershgorin intervals. Ideally,
a value of 1 should work, but on machines with sloppy
arithmetic, this needs to be larger. The default for
publicly released versions should be large enough to handle
the worst machine around. Note that this has no effect
on accuracy of the solution.
=====================================================================
Parameter adjustments */
--iwork;
--work;
--isplit;
--iblock;
--w;
--e;
--d__;
/* Function Body */
*info = 0;
/* Decode RANGE */
if (igraphlsame_(range, "A")) {
irange = 1;
} else if (igraphlsame_(range, "V")) {
irange = 2;
} else if (igraphlsame_(range, "I")) {
irange = 3;
} else {
irange = 0;
}
/* Decode ORDER */
if (igraphlsame_(order, "B")) {
iorder = 2;
} else if (igraphlsame_(order, "E")) {
iorder = 1;
} else {
iorder = 0;
}
/* Check for Errors */
if (irange <= 0) {
*info = -1;
} else if (iorder <= 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (irange == 2) {
if (*vl >= *vu) {
*info = -5;
}
} else if (irange == 3 && (*il < 1 || *il > max(1,*n))) {
*info = -6;
} else if (irange == 3 && (*iu < min(*n,*il) || *iu > *n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
igraphxerbla_("DSTEBZ", &i__1, (ftnlen)6);
return 0;
}
/* Initialize error flags */
*info = 0;
ncnvrg = FALSE_;
toofew = FALSE_;
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
/* Simplifications: */
if (irange == 3 && *il == 1 && *iu == *n) {
irange = 1;
}
/* Get machine constants
NB is the minimum vector length for vector bisection, or 0
if only scalar is to be done. */
safemn = igraphdlamch_("S");
ulp = igraphdlamch_("P");
rtoli = ulp * 2.;
nb = igraphilaenv_(&c__1, "DSTEBZ", " ", n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
if (nb <= 1) {
nb = 0;
}
/* Special Case when N=1 */
if (*n == 1) {
*nsplit = 1;
isplit[1] = 1;
if (irange == 2 && (*vl >= d__[1] || *vu < d__[1])) {
*m = 0;
} else {
w[1] = d__[1];
iblock[1] = 1;
*m = 1;
}
return 0;
}
/* Compute Splitting Points */
*nsplit = 1;
work[*n] = 0.;
pivmin = 1.;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
/* Computing 2nd power */
d__1 = e[j - 1];
tmp1 = d__1 * d__1;
/* Computing 2nd power */
d__2 = ulp;
if ((d__1 = d__[j] * d__[j - 1], abs(d__1)) * (d__2 * d__2) + safemn
> tmp1) {
isplit[*nsplit] = j - 1;
++(*nsplit);
work[j - 1] = 0.;
} else {
work[j - 1] = tmp1;
pivmin = max(pivmin,tmp1);
}
/* L10: */
}
isplit[*nsplit] = *n;
pivmin *= safemn;
/* Compute Interval and ATOLI */
if (irange == 3) {
/* RANGE='I': Compute the interval containing eigenvalues
IL through IU.
Compute Gershgorin interval for entire (split) matrix
and use it as the initial interval */
gu = d__[1];
gl = d__[1];
tmp1 = 0.;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
tmp2 = sqrt(work[j]);
/* Computing MAX */
d__1 = gu, d__2 = d__[j] + tmp1 + tmp2;
gu = max(d__1,d__2);
/* Computing MIN */
d__1 = gl, d__2 = d__[j] - tmp1 - tmp2;
gl = min(d__1,d__2);
tmp1 = tmp2;
/* L20: */
}
/* Computing MAX */
d__1 = gu, d__2 = d__[*n] + tmp1;
gu = max(d__1,d__2);
/* Computing MIN */
d__1 = gl, d__2 = d__[*n] - tmp1;
gl = min(d__1,d__2);
/* Computing MAX */
d__1 = abs(gl), d__2 = abs(gu);
tnorm = max(d__1,d__2);
gl = gl - tnorm * 2.1 * ulp * *n - pivmin * 4.2000000000000002;
gu = gu + tnorm * 2.1 * ulp * *n + pivmin * 2.1;
/* Compute Iteration parameters */
itmax = (integer) ((log(tnorm + pivmin) - log(pivmin)) / log(2.)) + 2;
if (*abstol <= 0.) {
atoli = ulp * tnorm;
} else {
atoli = *abstol;
}
work[*n + 1] = gl;
work[*n + 2] = gl;
work[*n + 3] = gu;
work[*n + 4] = gu;
work[*n + 5] = gl;
work[*n + 6] = gu;
iwork[1] = -1;
iwork[2] = -1;
iwork[3] = *n + 1;
iwork[4] = *n + 1;
iwork[5] = *il - 1;
iwork[6] = *iu;
igraphdlaebz_(&c__3, &itmax, n, &c__2, &c__2, &nb, &atoli, &rtoli, &pivmin,
&d__[1], &e[1], &work[1], &iwork[5], &work[*n + 1], &work[*n
+ 5], &iout, &iwork[1], &w[1], &iblock[1], &iinfo);
if (iwork[6] == *iu) {
wl = work[*n + 1];
wlu = work[*n + 3];
nwl = iwork[1];
wu = work[*n + 4];
wul = work[*n + 2];
nwu = iwork[4];
} else {
wl = work[*n + 2];
wlu = work[*n + 4];
nwl = iwork[2];
wu = work[*n + 3];
wul = work[*n + 1];
nwu = iwork[3];
}
if (nwl < 0 || nwl >= *n || nwu < 1 || nwu > *n) {
*info = 4;
return 0;
}
} else {
/* RANGE='A' or 'V' -- Set ATOLI
Computing MAX */
d__3 = abs(d__[1]) + abs(e[1]), d__4 = (d__1 = d__[*n], abs(d__1)) + (
d__2 = e[*n - 1], abs(d__2));
tnorm = max(d__3,d__4);
i__1 = *n - 1;
for (j = 2; j <= i__1; ++j) {
/* Computing MAX */
d__4 = tnorm, d__5 = (d__1 = d__[j], abs(d__1)) + (d__2 = e[j - 1]
, abs(d__2)) + (d__3 = e[j], abs(d__3));
tnorm = max(d__4,d__5);
/* L30: */
}
if (*abstol <= 0.) {
atoli = ulp * tnorm;
} else {
atoli = *abstol;
}
if (irange == 2) {
wl = *vl;
wu = *vu;
} else {
wl = 0.;
wu = 0.;
}
}
/* Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU.
NWL accumulates the number of eigenvalues .le. WL,
NWU accumulates the number of eigenvalues .le. WU */
*m = 0;
iend = 0;
*info = 0;
nwl = 0;
nwu = 0;
i__1 = *nsplit;
for (jb = 1; jb <= i__1; ++jb) {
ioff = iend;
ibegin = ioff + 1;
iend = isplit[jb];
in = iend - ioff;
if (in == 1) {
/* Special Case -- IN=1 */
if (irange == 1 || wl >= d__[ibegin] - pivmin) {
++nwl;
}
if (irange == 1 || wu >= d__[ibegin] - pivmin) {
++nwu;
}
if (irange == 1 || wl < d__[ibegin] - pivmin && wu >= d__[ibegin]
- pivmin) {
++(*m);
w[*m] = d__[ibegin];
iblock[*m] = jb;
}
} else {
/* General Case -- IN > 1
Compute Gershgorin Interval
and use it as the initial interval */
gu = d__[ibegin];
gl = d__[ibegin];
tmp1 = 0.;
i__2 = iend - 1;
for (j = ibegin; j <= i__2; ++j) {
tmp2 = (d__1 = e[j], abs(d__1));
/* Computing MAX */
d__1 = gu, d__2 = d__[j] + tmp1 + tmp2;
gu = max(d__1,d__2);
/* Computing MIN */
d__1 = gl, d__2 = d__[j] - tmp1 - tmp2;
gl = min(d__1,d__2);
tmp1 = tmp2;
/* L40: */
}
/* Computing MAX */
d__1 = gu, d__2 = d__[iend] + tmp1;
gu = max(d__1,d__2);
/* Computing MIN */
d__1 = gl, d__2 = d__[iend] - tmp1;
gl = min(d__1,d__2);
/* Computing MAX */
d__1 = abs(gl), d__2 = abs(gu);
bnorm = max(d__1,d__2);
gl = gl - bnorm * 2.1 * ulp * in - pivmin * 2.1;
gu = gu + bnorm * 2.1 * ulp * in + pivmin * 2.1;
/* Compute ATOLI for the current submatrix */
if (*abstol <= 0.) {
/* Computing MAX */
d__1 = abs(gl), d__2 = abs(gu);
atoli = ulp * max(d__1,d__2);
} else {
atoli = *abstol;
}
if (irange > 1) {
if (gu < wl) {
nwl += in;
nwu += in;
goto L70;
}
gl = max(gl,wl);
gu = min(gu,wu);
if (gl >= gu) {
goto L70;
}
}
/* Set Up Initial Interval */
work[*n + 1] = gl;
work[*n + in + 1] = gu;
igraphdlaebz_(&c__1, &c__0, &in, &in, &c__1, &nb, &atoli, &rtoli, &
pivmin, &d__[ibegin], &e[ibegin], &work[ibegin], idumma, &
work[*n + 1], &work[*n + (in << 1) + 1], &im, &iwork[1], &
w[*m + 1], &iblock[*m + 1], &iinfo);
nwl += iwork[1];
nwu += iwork[in + 1];
iwoff = *m - iwork[1];
/* Compute Eigenvalues */
itmax = (integer) ((log(gu - gl + pivmin) - log(pivmin)) / log(2.)
) + 2;
igraphdlaebz_(&c__2, &itmax, &in, &in, &c__1, &nb, &atoli, &rtoli, &
pivmin, &d__[ibegin], &e[ibegin], &work[ibegin], idumma, &
work[*n + 1], &work[*n + (in << 1) + 1], &iout, &iwork[1],
&w[*m + 1], &iblock[*m + 1], &iinfo);
/* Copy Eigenvalues Into W and IBLOCK
Use -JB for block number for unconverged eigenvalues. */
i__2 = iout;
for (j = 1; j <= i__2; ++j) {
tmp1 = (work[j + *n] + work[j + in + *n]) * .5;
/* Flag non-convergence. */
if (j > iout - iinfo) {
ncnvrg = TRUE_;
ib = -jb;
} else {
ib = jb;
}
i__3 = iwork[j + in] + iwoff;
for (je = iwork[j] + 1 + iwoff; je <= i__3; ++je) {
w[je] = tmp1;
iblock[je] = ib;
/* L50: */
}
/* L60: */
}
*m += im;
}
L70:
;
}
/* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
If NWL+1 < IL or NWU > IU, discard extra eigenvalues. */
if (irange == 3) {
im = 0;
idiscl = *il - 1 - nwl;
idiscu = nwu - *iu;
if (idiscl > 0 || idiscu > 0) {
i__1 = *m;
for (je = 1; je <= i__1; ++je) {
if (w[je] <= wlu && idiscl > 0) {
--idiscl;
} else if (w[je] >= wul && idiscu > 0) {
--idiscu;
} else {
++im;
w[im] = w[je];
iblock[im] = iblock[je];
}
/* L80: */
}
*m = im;
}
if (idiscl > 0 || idiscu > 0) {
/* Code to deal with effects of bad arithmetic:
Some low eigenvalues to be discarded are not in (WL,WLU],
or high eigenvalues to be discarded are not in (WUL,WU]
so just kill off the smallest IDISCL/largest IDISCU
eigenvalues, by simply finding the smallest/largest
eigenvalue(s).
(If N(w) is monotone non-decreasing, this should never
happen.) */
if (idiscl > 0) {
wkill = wu;
i__1 = idiscl;
for (jdisc = 1; jdisc <= i__1; ++jdisc) {
iw = 0;
i__2 = *m;
for (je = 1; je <= i__2; ++je) {
if (iblock[je] != 0 && (w[je] < wkill || iw == 0)) {
iw = je;
wkill = w[je];
}
/* L90: */
}
iblock[iw] = 0;
/* L100: */
}
}
if (idiscu > 0) {
wkill = wl;
i__1 = idiscu;
for (jdisc = 1; jdisc <= i__1; ++jdisc) {
iw = 0;
i__2 = *m;
for (je = 1; je <= i__2; ++je) {
if (iblock[je] != 0 && (w[je] > wkill || iw == 0)) {
iw = je;
wkill = w[je];
}
/* L110: */
}
iblock[iw] = 0;
/* L120: */
}
}
im = 0;
i__1 = *m;
for (je = 1; je <= i__1; ++je) {
if (iblock[je] != 0) {
++im;
w[im] = w[je];
iblock[im] = iblock[je];
}
/* L130: */
}
*m = im;
}
if (idiscl < 0 || idiscu < 0) {
toofew = TRUE_;
}
}
/* If ORDER='B', do nothing -- the eigenvalues are already sorted
by block.
If ORDER='E', sort the eigenvalues from smallest to largest */
if (iorder == 1 && *nsplit > 1) {
i__1 = *m - 1;
for (je = 1; je <= i__1; ++je) {
ie = 0;
tmp1 = w[je];
i__2 = *m;
for (j = je + 1; j <= i__2; ++j) {
if (w[j] < tmp1) {
ie = j;
tmp1 = w[j];
}
/* L140: */
}
if (ie != 0) {
itmp1 = iblock[ie];
w[ie] = w[je];
iblock[ie] = iblock[je];
w[je] = tmp1;
iblock[je] = itmp1;
}
/* L150: */
}
}
*info = 0;
if (ncnvrg) {
++(*info);
}
if (toofew) {
*info += 2;
}
return 0;
/* End of DSTEBZ */
} /* igraphdstebz_ */
Subroutine */ int igraphdlasq6_(integer *i0, integer *n0, doublereal *z__,
integer *pp, doublereal *dmin__, doublereal *dmin1, doublereal *dmin2,
doublereal *dn, doublereal *dnm1, doublereal *dnm2)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
/* Local variables */
doublereal d__;
integer j4, j4p2;
doublereal emin, temp;
extern doublereal igraphdlamch_(char *);
doublereal safmin;
/* -- LAPACK computational 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 */
--z__;
/* Function Body */
if (*n0 - *i0 - 1 <= 0) {
return 0;
}
safmin = igraphdlamch_("Safe minimum");
j4 = (*i0 << 2) + *pp - 3;
emin = z__[j4 + 4];
d__ = z__[j4];
*dmin__ = d__;
if (*pp == 0) {
i__1 = *n0 - 3 << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
z__[j4 - 2] = d__ + z__[j4 - 1];
if (z__[j4 - 2] == 0.) {
z__[j4] = 0.;
d__ = z__[j4 + 1];
*dmin__ = d__;
emin = 0.;
} else if (safmin * z__[j4 + 1] < z__[j4 - 2] && safmin * z__[j4
- 2] < z__[j4 + 1]) {
temp = z__[j4 + 1] / z__[j4 - 2];
z__[j4] = z__[j4 - 1] * temp;
d__ *= temp;
} else {
z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]);
d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]);
}
*dmin__ = min(*dmin__,d__);
/* Computing MIN */
d__1 = emin, d__2 = z__[j4];
emin = min(d__1,d__2);
/* L10: */
}
} else {
i__1 = *n0 - 3 << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
z__[j4 - 3] = d__ + z__[j4];
if (z__[j4 - 3] == 0.) {
z__[j4 - 1] = 0.;
d__ = z__[j4 + 2];
*dmin__ = d__;
emin = 0.;
} else if (safmin * z__[j4 + 2] < z__[j4 - 3] && safmin * z__[j4
- 3] < z__[j4 + 2]) {
temp = z__[j4 + 2] / z__[j4 - 3];
z__[j4 - 1] = z__[j4] * temp;
d__ *= temp;
} else {
z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]);
d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]);
}
*dmin__ = min(*dmin__,d__);
/* Computing MIN */
d__1 = emin, d__2 = z__[j4 - 1];
emin = min(d__1,d__2);
/* L20: */
}
}
/* Unroll last two steps. */
*dnm2 = d__;
*dmin2 = *dmin__;
j4 = (*n0 - 2 << 2) - *pp;
j4p2 = j4 + (*pp << 1) - 1;
z__[j4 - 2] = *dnm2 + z__[j4p2];
if (z__[j4 - 2] == 0.) {
z__[j4] = 0.;
*dnm1 = z__[j4p2 + 2];
*dmin__ = *dnm1;
emin = 0.;
} else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] <
z__[j4p2 + 2]) {
temp = z__[j4p2 + 2] / z__[j4 - 2];
z__[j4] = z__[j4p2] * temp;
*dnm1 = *dnm2 * temp;
} else {
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]);
}
*dmin__ = min(*dmin__,*dnm1);
*dmin1 = *dmin__;
j4 += 4;
j4p2 = j4 + (*pp << 1) - 1;
z__[j4 - 2] = *dnm1 + z__[j4p2];
if (z__[j4 - 2] == 0.) {
z__[j4] = 0.;
*dn = z__[j4p2 + 2];
*dmin__ = *dn;
emin = 0.;
} else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] <
z__[j4p2 + 2]) {
temp = z__[j4p2 + 2] / z__[j4 - 2];
z__[j4] = z__[j4p2] * temp;
*dn = *dnm1 * temp;
} else {
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]);
}
*dmin__ = min(*dmin__,*dn);
z__[j4 + 2] = *dn;
z__[(*n0 << 2) - *pp] = emin;
return 0;
/* End of DLASQ6 */
} /* igraphdlasq6_ */
/* Subroutine */ int igraphdlaqr2_(logical *wantt, logical *wantz, integer *n,
integer *ktop, integer *kbot, integer *nw, doublereal *h__, integer *
ldh, integer *iloz, integer *ihiz, doublereal *z__, integer *ldz,
integer *ns, integer *nd, doublereal *sr, doublereal *si, doublereal *
v, integer *ldv, integer *nh, doublereal *t, integer *ldt, integer *
nv, doublereal *wv, integer *ldwv, doublereal *work, integer *lwork)
{
/* System generated locals */
integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1,
wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, k;
doublereal s, aa, bb, cc, dd, cs, sn;
integer jw;
doublereal evi, evk, foo;
integer kln;
doublereal tau, ulp;
integer lwk1, lwk2;
doublereal beta;
integer kend, kcol, info, ifst, ilst, ltop, krow;
extern /* Subroutine */ int igraphdlarf_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *), igraphdgemm_(char *, char *, integer *, integer *
, integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
logical bulge;
extern /* Subroutine */ int igraphdcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
integer infqr, kwtop;
extern /* Subroutine */ int igraphdlanv2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *), igraphdlabad_(
doublereal *, doublereal *);
extern doublereal igraphdlamch_(char *);
extern /* Subroutine */ int igraphdgehrd_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *), igraphdlarfg_(integer *, doublereal *, doublereal *,
integer *, doublereal *), igraphdlahqr_(logical *, logical *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *), igraphdlacpy_(char *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *);
doublereal safmin;
extern /* Subroutine */ int igraphdlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *);
doublereal safmax;
extern /* Subroutine */ int igraphdtrexc_(char *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, integer *,
doublereal *, integer *), igraphdormhr_(char *, char *, integer
*, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
integer *);
logical sorted;
doublereal smlnum;
integer lwkopt;
/* -- LAPACK auxiliary routine (version 3.2.2) --
Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..
-- June 2010 --
This subroutine is identical to DLAQR3 except that it avoids
recursion by calling DLAHQR instead of DLAQR4.
******************************************************************
Aggressive early deflation:
This subroutine accepts as input an upper Hessenberg matrix
H and performs an orthogonal similarity transformation
designed to detect and deflate fully converged eigenvalues from
a trailing principal submatrix. On output H has been over-
written by a new Hessenberg matrix that is a perturbation of
an orthogonal similarity transformation of H. It is to be
hoped that the final version of H has many zero subdiagonal
entries.
******************************************************************
WANTT (input) LOGICAL
If .TRUE., then the Hessenberg matrix H is fully updated
so that the quasi-triangular Schur factor may be
computed (in cooperation with the calling subroutine).
If .FALSE., then only enough of H is updated to preserve
the eigenvalues.
WANTZ (input) LOGICAL
If .TRUE., then the orthogonal matrix Z is updated so
so that the orthogonal Schur factor may be computed
(in cooperation with the calling subroutine).
If .FALSE., then Z is not referenced.
N (input) INTEGER
The order of the matrix H and (if WANTZ is .TRUE.) the
order of the orthogonal matrix Z.
KTOP (input) INTEGER
It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.
KBOT and KTOP together determine an isolated block
along the diagonal of the Hessenberg matrix.
KBOT (input) INTEGER
It is assumed without a check that either
KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together
determine an isolated block along the diagonal of the
Hessenberg matrix.
NW (input) INTEGER
Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).
H (input/output) DOUBLE PRECISION array, dimension (LDH,N)
On input the initial N-by-N section of H stores the
Hessenberg matrix undergoing aggressive early deflation.
On output H has been transformed by an orthogonal
similarity transformation, perturbed, and the returned
to Hessenberg form that (it is to be hoped) has some
zero subdiagonal entries.
LDH (input) integer
Leading dimension of H just as declared in the calling
subroutine. N .LE. LDH
ILOZ (input) INTEGER
IHIZ (input) INTEGER
Specify the rows of Z to which transformations must be
applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.
Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
IF WANTZ is .TRUE., then on output, the orthogonal
similarity transformation mentioned above has been
accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.
If WANTZ is .FALSE., then Z is unreferenced.
LDZ (input) integer
The leading dimension of Z just as declared in the
calling subroutine. 1 .LE. LDZ.
NS (output) integer
The number of unconverged (ie approximate) eigenvalues
returned in SR and SI that may be used as shifts by the
calling subroutine.
ND (output) integer
The number of converged eigenvalues uncovered by this
subroutine.
SR (output) DOUBLE PRECISION array, dimension (KBOT)
SI (output) DOUBLE PRECISION array, dimension (KBOT)
On output, the real and imaginary parts of approximate
eigenvalues that may be used for shifts are stored in
SR(KBOT-ND-NS+1) through SR(KBOT-ND) and
SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.
The real and imaginary parts of converged eigenvalues
are stored in SR(KBOT-ND+1) through SR(KBOT) and
SI(KBOT-ND+1) through SI(KBOT), respectively.
V (workspace) DOUBLE PRECISION array, dimension (LDV,NW)
An NW-by-NW work array.
LDV (input) integer scalar
The leading dimension of V just as declared in the
calling subroutine. NW .LE. LDV
NH (input) integer scalar
The number of columns of T. NH.GE.NW.
T (workspace) DOUBLE PRECISION array, dimension (LDT,NW)
LDT (input) integer
The leading dimension of T just as declared in the
calling subroutine. NW .LE. LDT
NV (input) integer
The number of rows of work array WV available for
workspace. NV.GE.NW.
WV (workspace) DOUBLE PRECISION array, dimension (LDWV,NW)
LDWV (input) integer
The leading dimension of W just as declared in the
calling subroutine. NW .LE. LDV
WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
On exit, WORK(1) is set to an estimate of the optimal value
of LWORK for the given values of N, NW, KTOP and KBOT.
LWORK (input) integer
The dimension of the work array WORK. LWORK = 2*NW
suffices, but greater efficiency may result from larger
values of LWORK.
If LWORK = -1, then a workspace query is assumed; DLAQR2
only estimates the optimal workspace size for the given
values of N, NW, KTOP and KBOT. The estimate is returned
in WORK(1). No error message related to LWORK is issued
by XERBLA. Neither H nor Z are accessed.
================================================================
Based on contributions by
Karen Braman and Ralph Byers, Department of Mathematics,
University of Kansas, USA
================================================================
==== Estimate optimal workspace. ====
Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--sr;
--si;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
wv_dim1 = *ldwv;
wv_offset = 1 + wv_dim1;
wv -= wv_offset;
--work;
/* Function Body
Computing MIN */
i__1 = *nw, i__2 = *kbot - *ktop + 1;
jw = min(i__1,i__2);
if (jw <= 2) {
lwkopt = 1;
} else {
/* ==== Workspace query call to DGEHRD ==== */
i__1 = jw - 1;
igraphdgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], &
c_n1, &info);
lwk1 = (integer) work[1];
/* ==== Workspace query call to DORMHR ==== */
i__1 = jw - 1;
igraphdormhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1],
&v[v_offset], ldv, &work[1], &c_n1, &info);
lwk2 = (integer) work[1];
/* ==== Optimal workspace ==== */
lwkopt = jw + max(lwk1,lwk2);
}
/* ==== Quick return in case of workspace query. ==== */
if (*lwork == -1) {
work[1] = (doublereal) lwkopt;
return 0;
}
/* ==== Nothing to do ...
... for an empty active block ... ==== */
*ns = 0;
*nd = 0;
work[1] = 1.;
if (*ktop > *kbot) {
return 0;
}
/* ... nor for an empty deflation window. ==== */
if (*nw < 1) {
return 0;
}
/* ==== Machine constants ==== */
safmin = igraphdlamch_("SAFE MINIMUM");
safmax = 1. / safmin;
igraphdlabad_(&safmin, &safmax);
ulp = igraphdlamch_("PRECISION");
smlnum = safmin * ((doublereal) (*n) / ulp);
/* ==== Setup deflation window ====
Computing MIN */
i__1 = *nw, i__2 = *kbot - *ktop + 1;
jw = min(i__1,i__2);
kwtop = *kbot - jw + 1;
if (kwtop == *ktop) {
s = 0.;
} else {
s = h__[kwtop + (kwtop - 1) * h_dim1];
}
if (*kbot == kwtop) {
/* ==== 1-by-1 deflation window: not much to do ==== */
sr[kwtop] = h__[kwtop + kwtop * h_dim1];
si[kwtop] = 0.;
*ns = 1;
*nd = 0;
/* Computing MAX */
d__2 = smlnum, d__3 = ulp * (d__1 = h__[kwtop + kwtop * h_dim1], abs(
d__1));
if (abs(s) <= max(d__2,d__3)) {
*ns = 0;
*nd = 1;
if (kwtop > *ktop) {
h__[kwtop + (kwtop - 1) * h_dim1] = 0.;
}
}
work[1] = 1.;
return 0;
}
/* ==== Convert to spike-triangular form. (In case of a
. rare QR failure, this routine continues to do
. aggressive early deflation using that part of
. the deflation window that converged using INFQR
. here and there to keep track.) ==== */
igraphdlacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset],
ldt);
i__1 = jw - 1;
i__2 = *ldh + 1;
i__3 = *ldt + 1;
igraphdcopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], &
i__3);
igraphdlaset_("A", &jw, &jw, &c_b12, &c_b13, &v[v_offset], ldv);
igraphdlahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[kwtop],
&si[kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr);
/* ==== DTREXC needs a clean margin near the diagonal ==== */
i__1 = jw - 3;
for (j = 1; j <= i__1; ++j) {
t[j + 2 + j * t_dim1] = 0.;
t[j + 3 + j * t_dim1] = 0.;
/* L10: */
}
if (jw > 2) {
t[jw + (jw - 2) * t_dim1] = 0.;
}
/* ==== Deflation detection loop ==== */
*ns = jw;
ilst = infqr + 1;
L20:
if (ilst <= *ns) {
if (*ns == 1) {
bulge = FALSE_;
} else {
bulge = t[*ns + (*ns - 1) * t_dim1] != 0.;
}
/* ==== Small spike tip test for deflation ==== */
if (! bulge) {
/* ==== Real eigenvalue ==== */
foo = (d__1 = t[*ns + *ns * t_dim1], abs(d__1));
if (foo == 0.) {
foo = abs(s);
}
/* Computing MAX */
d__2 = smlnum, d__3 = ulp * foo;
if ((d__1 = s * v[*ns * v_dim1 + 1], abs(d__1)) <= max(d__2,d__3))
{
/* ==== Deflatable ==== */
--(*ns);
} else {
/* ==== Undeflatable. Move it up out of the way.
. (DTREXC can not fail in this case.) ==== */
ifst = *ns;
igraphdtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
&ilst, &work[1], &info);
++ilst;
}
} else {
/* ==== Complex conjugate pair ==== */
foo = (d__3 = t[*ns + *ns * t_dim1], abs(d__3)) + sqrt((d__1 = t[*
ns + (*ns - 1) * t_dim1], abs(d__1))) * sqrt((d__2 = t[*
ns - 1 + *ns * t_dim1], abs(d__2)));
if (foo == 0.) {
foo = abs(s);
}
/* Computing MAX */
d__3 = (d__1 = s * v[*ns * v_dim1 + 1], abs(d__1)), d__4 = (d__2 =
s * v[(*ns - 1) * v_dim1 + 1], abs(d__2));
/* Computing MAX */
d__5 = smlnum, d__6 = ulp * foo;
if (max(d__3,d__4) <= max(d__5,d__6)) {
/* ==== Deflatable ==== */
*ns += -2;
} else {
/* ==== Undeflatable. Move them up out of the way.
. Fortunately, DTREXC does the right thing with
. ILST in case of a rare exchange failure. ==== */
ifst = *ns;
igraphdtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
&ilst, &work[1], &info);
ilst += 2;
}
}
/* ==== End deflation detection loop ==== */
goto L20;
}
/* ==== Return to Hessenberg form ==== */
if (*ns == 0) {
s = 0.;
}
if (*ns < jw) {
/* ==== sorting diagonal blocks of T improves accuracy for
. graded matrices. Bubble sort deals well with
. exchange failures. ==== */
sorted = FALSE_;
i__ = *ns + 1;
L30:
if (sorted) {
goto L50;
}
sorted = TRUE_;
kend = i__ - 1;
i__ = infqr + 1;
if (i__ == *ns) {
k = i__ + 1;
} else if (t[i__ + 1 + i__ * t_dim1] == 0.) {
k = i__ + 1;
} else {
k = i__ + 2;
}
L40:
if (k <= kend) {
if (k == i__ + 1) {
evi = (d__1 = t[i__ + i__ * t_dim1], abs(d__1));
} else {
evi = (d__3 = t[i__ + i__ * t_dim1], abs(d__3)) + sqrt((d__1 =
t[i__ + 1 + i__ * t_dim1], abs(d__1))) * sqrt((d__2 =
t[i__ + (i__ + 1) * t_dim1], abs(d__2)));
}
if (k == kend) {
evk = (d__1 = t[k + k * t_dim1], abs(d__1));
} else if (t[k + 1 + k * t_dim1] == 0.) {
evk = (d__1 = t[k + k * t_dim1], abs(d__1));
} else {
evk = (d__3 = t[k + k * t_dim1], abs(d__3)) + sqrt((d__1 = t[
k + 1 + k * t_dim1], abs(d__1))) * sqrt((d__2 = t[k +
(k + 1) * t_dim1], abs(d__2)));
}
if (evi >= evk) {
i__ = k;
} else {
sorted = FALSE_;
ifst = i__;
ilst = k;
igraphdtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
&ilst, &work[1], &info);
if (info == 0) {
i__ = ilst;
} else {
i__ = k;
}
}
if (i__ == kend) {
k = i__ + 1;
} else if (t[i__ + 1 + i__ * t_dim1] == 0.) {
k = i__ + 1;
} else {
k = i__ + 2;
}
goto L40;
}
goto L30;
L50:
;
}
/* ==== Restore shift/eigenvalue array from T ==== */
i__ = jw;
L60:
if (i__ >= infqr + 1) {
if (i__ == infqr + 1) {
sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1];
si[kwtop + i__ - 1] = 0.;
--i__;
} else if (t[i__ + (i__ - 1) * t_dim1] == 0.) {
sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1];
si[kwtop + i__ - 1] = 0.;
--i__;
} else {
aa = t[i__ - 1 + (i__ - 1) * t_dim1];
cc = t[i__ + (i__ - 1) * t_dim1];
bb = t[i__ - 1 + i__ * t_dim1];
dd = t[i__ + i__ * t_dim1];
igraphdlanv2_(&aa, &bb, &cc, &dd, &sr[kwtop + i__ - 2], &si[kwtop + i__
- 2], &sr[kwtop + i__ - 1], &si[kwtop + i__ - 1], &cs, &
sn);
i__ += -2;
}
goto L60;
}
if (*ns < jw || s == 0.) {
if (*ns > 1 && s != 0.) {
/* ==== Reflect spike back into lower triangle ==== */
igraphdcopy_(ns, &v[v_offset], ldv, &work[1], &c__1);
beta = work[1];
igraphdlarfg_(ns, &beta, &work[2], &c__1, &tau);
work[1] = 1.;
i__1 = jw - 2;
i__2 = jw - 2;
igraphdlaset_("L", &i__1, &i__2, &c_b12, &c_b12, &t[t_dim1 + 3], ldt);
igraphdlarf_("L", ns, &jw, &work[1], &c__1, &tau, &t[t_offset], ldt, &
work[jw + 1]);
igraphdlarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, &
work[jw + 1]);
igraphdlarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, &
work[jw + 1]);
i__1 = *lwork - jw;
igraphdgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1]
, &i__1, &info);
}
/* ==== Copy updated reduced window into place ==== */
if (kwtop > 1) {
h__[kwtop + (kwtop - 1) * h_dim1] = s * v[v_dim1 + 1];
}
igraphdlacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1]
, ldh);
i__1 = jw - 1;
i__2 = *ldt + 1;
i__3 = *ldh + 1;
igraphdcopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1],
&i__3);
/* ==== Accumulate orthogonal matrix in order update
. H and Z, if requested. ==== */
if (*ns > 1 && s != 0.) {
i__1 = *lwork - jw;
igraphdormhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1],
&v[v_offset], ldv, &work[jw + 1], &i__1, &info);
}
/* ==== Update vertical slab in H ==== */
if (*wantt) {
ltop = 1;
} else {
ltop = *ktop;
}
i__1 = kwtop - 1;
i__2 = *nv;
for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
i__2) {
/* Computing MIN */
i__3 = *nv, i__4 = kwtop - krow;
kln = min(i__3,i__4);
igraphdgemm_("N", "N", &kln, &jw, &jw, &c_b13, &h__[krow + kwtop *
h_dim1], ldh, &v[v_offset], ldv, &c_b12, &wv[wv_offset],
ldwv);
igraphdlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop *
h_dim1], ldh);
/* L70: */
}
/* ==== Update horizontal slab in H ==== */
if (*wantt) {
i__2 = *n;
i__1 = *nh;
for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2;
kcol += i__1) {
/* Computing MIN */
i__3 = *nh, i__4 = *n - kcol + 1;
kln = min(i__3,i__4);
igraphdgemm_("C", "N", &jw, &kln, &jw, &c_b13, &v[v_offset], ldv, &
h__[kwtop + kcol * h_dim1], ldh, &c_b12, &t[t_offset],
ldt);
igraphdlacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol *
h_dim1], ldh);
/* L80: */
}
}
/* ==== Update vertical slab in Z ==== */
if (*wantz) {
i__1 = *ihiz;
i__2 = *nv;
for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
i__2) {
/* Computing MIN */
i__3 = *nv, i__4 = *ihiz - krow + 1;
kln = min(i__3,i__4);
igraphdgemm_("N", "N", &kln, &jw, &jw, &c_b13, &z__[krow + kwtop *
z_dim1], ldz, &v[v_offset], ldv, &c_b12, &wv[
wv_offset], ldwv);
igraphdlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow +
kwtop * z_dim1], ldz);
/* L90: */
}
}
}
/* ==== Return the number of deflations ... ==== */
*nd = jw - *ns;
/* ==== ... and the number of shifts. (Subtracting
. INFQR from the spike length takes care
. of the case of a rare QR failure while
. calculating eigenvalues of the deflation
. window.) ==== */
*ns -= infqr;
/* ==== Return optimal workspace. ==== */
work[1] = (doublereal) lwkopt;
/* ==== End of DLAQR2 ==== */
return 0;
} /* igraphdlaqr2_ */
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 igraphdlar1v_(integer *n, integer *b1, integer *bn, doublereal
*lambda, doublereal *d__, doublereal *l, doublereal *ld, doublereal *
lld, doublereal *pivmin, doublereal *gaptol, doublereal *z__, logical
*wantnc, integer *negcnt, doublereal *ztz, doublereal *mingma,
integer *r__, integer *isuppz, doublereal *nrminv, doublereal *resid,
doublereal *rqcorr, doublereal *work)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__;
doublereal s;
integer r1, r2;
doublereal eps, tmp;
integer neg1, neg2, indp, inds;
doublereal dplus;
extern doublereal igraphdlamch_(char *);
extern logical igraphdisnan_(doublereal *);
integer indlpl, indumn;
doublereal dminus;
logical sawnan1, sawnan2;
/* -- 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 */
--work;
--isuppz;
--z__;
--lld;
--ld;
--l;
--d__;
/* Function Body */
eps = igraphdlamch_("Precision");
if (*r__ == 0) {
r1 = *b1;
r2 = *bn;
} else {
r1 = *r__;
r2 = *r__;
}
/* Storage for LPLUS */
indlpl = 0;
/* Storage for UMINUS */
indumn = *n;
inds = (*n << 1) + 1;
indp = *n * 3 + 1;
if (*b1 == 1) {
work[inds] = 0.;
} else {
work[inds + *b1 - 1] = lld[*b1 - 1];
}
/* Compute the stationary transform (using the differential form)
until the index R2. */
sawnan1 = FALSE_;
neg1 = 0;
s = work[inds + *b1 - 1] - *lambda;
i__1 = r1 - 1;
for (i__ = *b1; i__ <= i__1; ++i__) {
dplus = d__[i__] + s;
work[indlpl + i__] = ld[i__] / dplus;
if (dplus < 0.) {
++neg1;
}
work[inds + i__] = s * work[indlpl + i__] * l[i__];
s = work[inds + i__] - *lambda;
/* L50: */
}
sawnan1 = igraphdisnan_(&s);
if (sawnan1) {
goto L60;
}
i__1 = r2 - 1;
for (i__ = r1; i__ <= i__1; ++i__) {
dplus = d__[i__] + s;
work[indlpl + i__] = ld[i__] / dplus;
work[inds + i__] = s * work[indlpl + i__] * l[i__];
s = work[inds + i__] - *lambda;
/* L51: */
}
sawnan1 = igraphdisnan_(&s);
L60:
if (sawnan1) {
/* Runs a slower version of the above loop if a NaN is detected */
neg1 = 0;
s = work[inds + *b1 - 1] - *lambda;
i__1 = r1 - 1;
for (i__ = *b1; i__ <= i__1; ++i__) {
dplus = d__[i__] + s;
if (abs(dplus) < *pivmin) {
dplus = -(*pivmin);
}
work[indlpl + i__] = ld[i__] / dplus;
if (dplus < 0.) {
++neg1;
}
work[inds + i__] = s * work[indlpl + i__] * l[i__];
if (work[indlpl + i__] == 0.) {
work[inds + i__] = lld[i__];
}
s = work[inds + i__] - *lambda;
/* L70: */
}
i__1 = r2 - 1;
for (i__ = r1; i__ <= i__1; ++i__) {
dplus = d__[i__] + s;
if (abs(dplus) < *pivmin) {
dplus = -(*pivmin);
}
work[indlpl + i__] = ld[i__] / dplus;
work[inds + i__] = s * work[indlpl + i__] * l[i__];
if (work[indlpl + i__] == 0.) {
work[inds + i__] = lld[i__];
}
s = work[inds + i__] - *lambda;
/* L71: */
}
}
/* Compute the progressive transform (using the differential form)
until the index R1 */
sawnan2 = FALSE_;
neg2 = 0;
work[indp + *bn - 1] = d__[*bn] - *lambda;
i__1 = r1;
for (i__ = *bn - 1; i__ >= i__1; --i__) {
dminus = lld[i__] + work[indp + i__];
tmp = d__[i__] / dminus;
if (dminus < 0.) {
++neg2;
}
work[indumn + i__] = l[i__] * tmp;
work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda;
/* L80: */
}
tmp = work[indp + r1 - 1];
sawnan2 = igraphdisnan_(&tmp);
if (sawnan2) {
/* Runs a slower version of the above loop if a NaN is detected */
neg2 = 0;
i__1 = r1;
for (i__ = *bn - 1; i__ >= i__1; --i__) {
dminus = lld[i__] + work[indp + i__];
if (abs(dminus) < *pivmin) {
dminus = -(*pivmin);
}
tmp = d__[i__] / dminus;
if (dminus < 0.) {
++neg2;
}
work[indumn + i__] = l[i__] * tmp;
work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda;
if (tmp == 0.) {
work[indp + i__ - 1] = d__[i__] - *lambda;
}
/* L100: */
}
}
/* Find the index (from R1 to R2) of the largest (in magnitude)
diagonal element of the inverse */
*mingma = work[inds + r1 - 1] + work[indp + r1 - 1];
if (*mingma < 0.) {
++neg1;
}
if (*wantnc) {
*negcnt = neg1 + neg2;
} else {
*negcnt = -1;
}
if (abs(*mingma) == 0.) {
*mingma = eps * work[inds + r1 - 1];
}
*r__ = r1;
i__1 = r2 - 1;
for (i__ = r1; i__ <= i__1; ++i__) {
tmp = work[inds + i__] + work[indp + i__];
if (tmp == 0.) {
tmp = eps * work[inds + i__];
}
if (abs(tmp) <= abs(*mingma)) {
*mingma = tmp;
*r__ = i__ + 1;
}
/* L110: */
}
/* Compute the FP vector: solve N^T v = e_r */
isuppz[1] = *b1;
isuppz[2] = *bn;
z__[*r__] = 1.;
*ztz = 1.;
/* Compute the FP vector upwards from R */
if (! sawnan1 && ! sawnan2) {
i__1 = *b1;
for (i__ = *r__ - 1; i__ >= i__1; --i__) {
z__[i__] = -(work[indlpl + i__] * z__[i__ + 1]);
if (((d__1 = z__[i__], abs(d__1)) + (d__2 = z__[i__ + 1], abs(
d__2))) * (d__3 = ld[i__], abs(d__3)) < *gaptol) {
z__[i__] = 0.;
isuppz[1] = i__ + 1;
goto L220;
}
*ztz += z__[i__] * z__[i__];
/* L210: */
}
L220:
;
} else {
/* Run slower loop if NaN occurred. */
i__1 = *b1;
for (i__ = *r__ - 1; i__ >= i__1; --i__) {
if (z__[i__ + 1] == 0.) {
z__[i__] = -(ld[i__ + 1] / ld[i__]) * z__[i__ + 2];
} else {
z__[i__] = -(work[indlpl + i__] * z__[i__ + 1]);
}
if (((d__1 = z__[i__], abs(d__1)) + (d__2 = z__[i__ + 1], abs(
d__2))) * (d__3 = ld[i__], abs(d__3)) < *gaptol) {
z__[i__] = 0.;
isuppz[1] = i__ + 1;
goto L240;
}
*ztz += z__[i__] * z__[i__];
/* L230: */
}
L240:
;
}
/* Compute the FP vector downwards from R in blocks of size BLKSIZ */
if (! sawnan1 && ! sawnan2) {
i__1 = *bn - 1;
for (i__ = *r__; i__ <= i__1; ++i__) {
z__[i__ + 1] = -(work[indumn + i__] * z__[i__]);
if (((d__1 = z__[i__], abs(d__1)) + (d__2 = z__[i__ + 1], abs(
d__2))) * (d__3 = ld[i__], abs(d__3)) < *gaptol) {
z__[i__ + 1] = 0.;
isuppz[2] = i__;
goto L260;
}
*ztz += z__[i__ + 1] * z__[i__ + 1];
/* L250: */
}
L260:
;
} else {
/* Run slower loop if NaN occurred. */
i__1 = *bn - 1;
for (i__ = *r__; i__ <= i__1; ++i__) {
if (z__[i__] == 0.) {
z__[i__ + 1] = -(ld[i__ - 1] / ld[i__]) * z__[i__ - 1];
} else {
z__[i__ + 1] = -(work[indumn + i__] * z__[i__]);
}
if (((d__1 = z__[i__], abs(d__1)) + (d__2 = z__[i__ + 1], abs(
d__2))) * (d__3 = ld[i__], abs(d__3)) < *gaptol) {
z__[i__ + 1] = 0.;
isuppz[2] = i__;
goto L280;
}
*ztz += z__[i__ + 1] * z__[i__ + 1];
/* L270: */
}
L280:
;
}
/* Compute quantities for convergence test */
tmp = 1. / *ztz;
*nrminv = sqrt(tmp);
*resid = abs(*mingma) * *nrminv;
*rqcorr = *mingma * tmp;
return 0;
/* End of DLAR1V */
} /* igraphdlar1v_ */
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_ */
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 igraphdgebal_(char *job, integer *n, doublereal *a, integer *
lda, integer *ilo, integer *ihi, doublereal *scale, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1, d__2;
/* Local variables */
doublereal c__, f, g;
integer i__, j, k, l, m;
doublereal r__, s, ca, ra;
integer ica, ira, iexc;
extern /* Subroutine */ int igraphdscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical igraphlsame_(char *, char *);
extern /* Subroutine */ int igraphdswap_(integer *, doublereal *, integer *,
doublereal *, integer *);
doublereal sfmin1, sfmin2, sfmax1, sfmax2;
extern doublereal igraphdlamch_(char *);
extern integer igraphidamax_(integer *, doublereal *, integer *);
extern logical igraphdisnan_(doublereal *);
extern /* Subroutine */ int igraphxerbla_(char *, integer *, ftnlen);
logical noconv;
/* -- LAPACK routine (version 3.2.2) --
-- LAPACK is a software package provided by Univ. of Tennessee, --
-- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
June 2010
Purpose
=======
DGEBAL balances a general real matrix A. This involves, first,
permuting A by a similarity transformation to isolate eigenvalues
in the first 1 to ILO-1 and last IHI+1 to N elements on the
diagonal; and second, applying a diagonal similarity transformation
to rows and columns ILO to IHI to make the rows and columns as
close in norm as possible. Both steps are optional.
Balancing may reduce the 1-norm of the matrix, and improve the
accuracy of the computed eigenvalues and/or eigenvectors.
Arguments
=========
JOB (input) CHARACTER*1
Specifies the operations to be performed on A:
= 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0
for i = 1,...,N;
= 'P': permute only;
= 'S': scale only;
= 'B': both permute and scale.
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the input matrix A.
On exit, A is overwritten by the balanced matrix.
If JOB = 'N', A is not referenced.
See Further Details.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
ILO (output) INTEGER
IHI (output) INTEGER
ILO and IHI are set to integers such that on exit
A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.
If JOB = 'N' or 'S', ILO = 1 and IHI = N.
SCALE (output) DOUBLE PRECISION array, dimension (N)
Details of the permutations and scaling factors applied to
A. If P(j) is the index of the row and column interchanged
with row and column j and D(j) is the scaling factor
applied to row and column j, then
SCALE(j) = P(j) for j = 1,...,ILO-1
= D(j) for j = ILO,...,IHI
= P(j) for j = IHI+1,...,N.
The order in which the interchanges are made is N to IHI+1,
then 1 to ILO-1.
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
Further Details
===============
The permutations consist of row and column interchanges which put
the matrix in the form
( T1 X Y )
P A P = ( 0 B Z )
( 0 0 T2 )
where T1 and T2 are upper triangular matrices whose eigenvalues lie
along the diagonal. The column indices ILO and IHI mark the starting
and ending columns of the submatrix B. Balancing consists of applying
a diagonal similarity transformation inv(D) * B * D to make the
1-norms of each row of B and its corresponding column nearly equal.
The output matrix is
( T1 X*D Y )
( 0 inv(D)*B*D inv(D)*Z ).
( 0 0 T2 )
Information about the permutations P and the diagonal matrix D is
returned in the vector SCALE.
This subroutine is based on the EISPACK routine BALANC.
Modified by Tzu-Yi Chen, Computer Science Division, University of
California at Berkeley, USA
=====================================================================
Test the input parameters
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--scale;
/* Function Body */
*info = 0;
if (! igraphlsame_(job, "N") && ! igraphlsame_(job, "P") && ! igraphlsame_(job, "S")
&& ! igraphlsame_(job, "B")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
igraphxerbla_("DGEBAL", &i__1, (ftnlen)6);
return 0;
}
k = 1;
l = *n;
if (*n == 0) {
goto L210;
}
if (igraphlsame_(job, "N")) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
scale[i__] = 1.;
/* L10: */
}
goto L210;
}
if (igraphlsame_(job, "S")) {
goto L120;
}
/* Permutation to isolate eigenvalues if possible */
goto L50;
/* Row and column exchange. */
L20:
scale[m] = (doublereal) j;
if (j == m) {
goto L30;
}
igraphdswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
i__1 = *n - k + 1;
igraphdswap_(&i__1, &a[j + k * a_dim1], lda, &a[m + k * a_dim1], lda);
L30:
switch (iexc) {
case 1:
goto L40;
case 2:
goto L80;
}
/* Search for rows isolating an eigenvalue and push them down. */
L40:
if (l == 1) {
goto L210;
}
--l;
L50:
for (j = l; j >= 1; --j) {
i__1 = l;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ == j) {
goto L60;
}
if (a[j + i__ * a_dim1] != 0.) {
goto L70;
}
L60:
;
}
m = l;
iexc = 1;
goto L20;
L70:
;
}
goto L90;
/* Search for columns isolating an eigenvalue and push them left. */
L80:
++k;
L90:
i__1 = l;
for (j = k; j <= i__1; ++j) {
i__2 = l;
for (i__ = k; i__ <= i__2; ++i__) {
if (i__ == j) {
goto L100;
}
if (a[i__ + j * a_dim1] != 0.) {
goto L110;
}
L100:
;
}
m = k;
iexc = 2;
goto L20;
L110:
;
}
L120:
i__1 = l;
for (i__ = k; i__ <= i__1; ++i__) {
scale[i__] = 1.;
/* L130: */
}
if (igraphlsame_(job, "P")) {
goto L210;
}
/* Balance the submatrix in rows K to L.
Iterative loop for norm reduction */
sfmin1 = igraphdlamch_("S") / igraphdlamch_("P");
sfmax1 = 1. / sfmin1;
sfmin2 = sfmin1 * 2.;
sfmax2 = 1. / sfmin2;
L140:
noconv = FALSE_;
i__1 = l;
for (i__ = k; i__ <= i__1; ++i__) {
c__ = 0.;
r__ = 0.;
i__2 = l;
for (j = k; j <= i__2; ++j) {
if (j == i__) {
goto L150;
}
c__ += (d__1 = a[j + i__ * a_dim1], abs(d__1));
r__ += (d__1 = a[i__ + j * a_dim1], abs(d__1));
L150:
;
}
ica = igraphidamax_(&l, &a[i__ * a_dim1 + 1], &c__1);
ca = (d__1 = a[ica + i__ * a_dim1], abs(d__1));
i__2 = *n - k + 1;
ira = igraphidamax_(&i__2, &a[i__ + k * a_dim1], lda);
ra = (d__1 = a[i__ + (ira + k - 1) * a_dim1], abs(d__1));
/* Guard against zero C or R due to underflow. */
if (c__ == 0. || r__ == 0.) {
goto L200;
}
g = r__ / 2.;
f = 1.;
s = c__ + r__;
L160:
/* Computing MAX */
d__1 = max(f,c__);
/* Computing MIN */
d__2 = min(r__,g);
if (c__ >= g || max(d__1,ca) >= sfmax2 || min(d__2,ra) <= sfmin2) {
goto L170;
}
d__1 = c__ + f + ca + r__ + g + ra;
if (igraphdisnan_(&d__1)) {
/* Exit if NaN to avoid infinite loop */
*info = -3;
i__2 = -(*info);
igraphxerbla_("DGEBAL", &i__2, (ftnlen)6);
return 0;
}
f *= 2.;
c__ *= 2.;
ca *= 2.;
r__ /= 2.;
g /= 2.;
ra /= 2.;
goto L160;
L170:
g = c__ / 2.;
L180:
/* Computing MIN */
d__1 = min(f,c__), d__1 = min(d__1,g);
if (g < r__ || max(r__,ra) >= sfmax2 || min(d__1,ca) <= sfmin2) {
goto L190;
}
f /= 2.;
c__ /= 2.;
g /= 2.;
ca /= 2.;
r__ *= 2.;
ra *= 2.;
goto L180;
/* Now balance. */
L190:
if (c__ + r__ >= s * .95) {
goto L200;
}
if (f < 1. && scale[i__] < 1.) {
if (f * scale[i__] <= sfmin1) {
goto L200;
}
}
if (f > 1. && scale[i__] > 1.) {
if (scale[i__] >= sfmax1 / f) {
goto L200;
}
}
g = 1. / f;
scale[i__] *= f;
noconv = TRUE_;
i__2 = *n - k + 1;
igraphdscal_(&i__2, &g, &a[i__ + k * a_dim1], lda);
igraphdscal_(&l, &f, &a[i__ * a_dim1 + 1], &c__1);
L200:
;
}
if (noconv) {
goto L140;
}
L210:
*ilo = k;
*ihi = l;
return 0;
/* End of DGEBAL */
} /* igraphdgebal_ */
Subroutine */ int igraphdgeevx_(char *balanc, char *jobvl, char *jobvr, char *
sense, integer *n, doublereal *a, integer *lda, doublereal *wr,
doublereal *wi, doublereal *vl, integer *ldvl, doublereal *vr,
integer *ldvr, integer *ilo, integer *ihi, doublereal *scale,
doublereal *abnrm, doublereal *rconde, doublereal *rcondv, doublereal
*work, integer *lwork, integer *iwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, k;
doublereal r__, cs, sn;
char job[1];
doublereal scl, dum[1], eps;
char side[1];
doublereal anrm;
integer ierr, itau;
extern /* Subroutine */ int igraphdrot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
integer iwrk, nout;
extern doublereal igraphdnrm2_(integer *, doublereal *, integer *);
extern /* Subroutine */ int igraphdscal_(integer *, doublereal *, doublereal *,
integer *);
integer icond;
extern logical igraphlsame_(char *, char *);
extern doublereal igraphdlapy2_(doublereal *, doublereal *);
extern /* Subroutine */ int igraphdlabad_(doublereal *, doublereal *), igraphdgebak_(
char *, char *, integer *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *),
igraphdgebal_(char *, integer *, doublereal *, integer *, integer *,
integer *, doublereal *, integer *);
logical scalea;
extern doublereal igraphdlamch_(char *);
doublereal cscale;
extern doublereal igraphdlange_(char *, integer *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int igraphdgehrd_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *), igraphdlascl_(char *, integer *, integer *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *);
extern integer igraphidamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int igraphdlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
igraphdlartg_(doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *), igraphxerbla_(char *, integer *, ftnlen);
logical select[1];
extern integer igraphilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
doublereal bignum;
extern /* Subroutine */ int igraphdorghr_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *), igraphdhseqr_(char *, char *, integer *, integer *, integer
*, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, integer *), igraphdtrevc_(char *, char *, logical *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, integer *, integer *, doublereal *, integer *), igraphdtrsna_(char *, char *, logical *, integer *, doublereal
*, integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, integer *);
integer minwrk, maxwrk;
logical wantvl, wntsnb;
integer hswork;
logical wntsne;
doublereal smlnum;
logical lquery, wantvr, wntsnn, wntsnv;
/* -- LAPACK driver routine (version 3.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 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 igraphdstebz_(char *range, char *order, integer *n, doublereal
*vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol,
doublereal *d__, doublereal *e, integer *m, integer *nsplit,
doublereal *w, integer *iblock, integer *isplit, doublereal *work,
integer *iwork, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1, d__2, d__3, d__4, d__5;
/* Builtin functions */
double sqrt(doublereal), log(doublereal);
/* Local variables */
integer j, ib, jb, ie, je, nb;
doublereal gl;
integer im, in;
doublereal gu;
integer iw;
doublereal wl, wu;
integer nwl;
doublereal ulp, wlu, wul;
integer nwu;
doublereal tmp1, tmp2;
integer iend, ioff, iout, itmp1, jdisc;
extern logical igraphlsame_(char *, char *);
integer iinfo;
doublereal atoli;
integer iwoff;
doublereal bnorm;
integer itmax;
doublereal wkill, rtoli, tnorm;
extern doublereal igraphdlamch_(char *);
integer ibegin;
extern /* Subroutine */ int igraphdlaebz_(integer *, integer *, integer *,
integer *, integer *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
integer irange, idiscl;
doublereal safemn;
integer idumma[1];
extern /* Subroutine */ int igraphxerbla_(char *, integer *, ftnlen);
extern integer igraphilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
integer idiscu, iorder;
logical ncnvrg;
doublereal pivmin;
logical toofew;
/* -- LAPACK computational routine (version 3.4.0) --
-- LAPACK is a software package provided by Univ. of Tennessee, --
-- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
November 2011
=====================================================================
Parameter adjustments */
--iwork;
--work;
--isplit;
--iblock;
--w;
--e;
--d__;
/* Function Body */
*info = 0;
/* Decode RANGE */
if (igraphlsame_(range, "A")) {
irange = 1;
} else if (igraphlsame_(range, "V")) {
irange = 2;
} else if (igraphlsame_(range, "I")) {
irange = 3;
} else {
irange = 0;
}
/* Decode ORDER */
if (igraphlsame_(order, "B")) {
iorder = 2;
} else if (igraphlsame_(order, "E")) {
iorder = 1;
} else {
iorder = 0;
}
/* Check for Errors */
if (irange <= 0) {
*info = -1;
} else if (iorder <= 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (irange == 2) {
if (*vl >= *vu) {
*info = -5;
}
} else if (irange == 3 && (*il < 1 || *il > max(1,*n))) {
*info = -6;
} else if (irange == 3 && (*iu < min(*n,*il) || *iu > *n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
igraphxerbla_("DSTEBZ", &i__1, (ftnlen)6);
return 0;
}
/* Initialize error flags */
*info = 0;
ncnvrg = FALSE_;
toofew = FALSE_;
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
/* Simplifications: */
if (irange == 3 && *il == 1 && *iu == *n) {
irange = 1;
}
/* Get machine constants
NB is the minimum vector length for vector bisection, or 0
if only scalar is to be done. */
safemn = igraphdlamch_("S");
ulp = igraphdlamch_("P");
rtoli = ulp * 2.;
nb = igraphilaenv_(&c__1, "DSTEBZ", " ", n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
if (nb <= 1) {
nb = 0;
}
/* Special Case when N=1 */
if (*n == 1) {
*nsplit = 1;
isplit[1] = 1;
if (irange == 2 && (*vl >= d__[1] || *vu < d__[1])) {
*m = 0;
} else {
w[1] = d__[1];
iblock[1] = 1;
*m = 1;
}
return 0;
}
/* Compute Splitting Points */
*nsplit = 1;
work[*n] = 0.;
pivmin = 1.;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
/* Computing 2nd power */
d__1 = e[j - 1];
tmp1 = d__1 * d__1;
/* Computing 2nd power */
d__2 = ulp;
if ((d__1 = d__[j] * d__[j - 1], abs(d__1)) * (d__2 * d__2) + safemn
> tmp1) {
isplit[*nsplit] = j - 1;
++(*nsplit);
work[j - 1] = 0.;
} else {
work[j - 1] = tmp1;
pivmin = max(pivmin,tmp1);
}
/* L10: */
}
isplit[*nsplit] = *n;
pivmin *= safemn;
/* Compute Interval and ATOLI */
if (irange == 3) {
/* RANGE='I': Compute the interval containing eigenvalues
IL through IU.
Compute Gershgorin interval for entire (split) matrix
and use it as the initial interval */
gu = d__[1];
gl = d__[1];
tmp1 = 0.;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
tmp2 = sqrt(work[j]);
/* Computing MAX */
d__1 = gu, d__2 = d__[j] + tmp1 + tmp2;
gu = max(d__1,d__2);
/* Computing MIN */
d__1 = gl, d__2 = d__[j] - tmp1 - tmp2;
gl = min(d__1,d__2);
tmp1 = tmp2;
/* L20: */
}
/* Computing MAX */
d__1 = gu, d__2 = d__[*n] + tmp1;
gu = max(d__1,d__2);
/* Computing MIN */
d__1 = gl, d__2 = d__[*n] - tmp1;
gl = min(d__1,d__2);
/* Computing MAX */
d__1 = abs(gl), d__2 = abs(gu);
tnorm = max(d__1,d__2);
gl = gl - tnorm * 2.1 * ulp * *n - pivmin * 4.2000000000000002;
gu = gu + tnorm * 2.1 * ulp * *n + pivmin * 2.1;
/* Compute Iteration parameters */
itmax = (integer) ((log(tnorm + pivmin) - log(pivmin)) / log(2.)) + 2;
if (*abstol <= 0.) {
atoli = ulp * tnorm;
} else {
atoli = *abstol;
}
work[*n + 1] = gl;
work[*n + 2] = gl;
work[*n + 3] = gu;
work[*n + 4] = gu;
work[*n + 5] = gl;
work[*n + 6] = gu;
iwork[1] = -1;
iwork[2] = -1;
iwork[3] = *n + 1;
iwork[4] = *n + 1;
iwork[5] = *il - 1;
iwork[6] = *iu;
igraphdlaebz_(&c__3, &itmax, n, &c__2, &c__2, &nb, &atoli, &rtoli, &pivmin,
&d__[1], &e[1], &work[1], &iwork[5], &work[*n + 1], &work[*n
+ 5], &iout, &iwork[1], &w[1], &iblock[1], &iinfo);
if (iwork[6] == *iu) {
wl = work[*n + 1];
wlu = work[*n + 3];
nwl = iwork[1];
wu = work[*n + 4];
wul = work[*n + 2];
nwu = iwork[4];
} else {
wl = work[*n + 2];
wlu = work[*n + 4];
nwl = iwork[2];
wu = work[*n + 3];
wul = work[*n + 1];
nwu = iwork[3];
}
if (nwl < 0 || nwl >= *n || nwu < 1 || nwu > *n) {
*info = 4;
return 0;
}
} else {
/* RANGE='A' or 'V' -- Set ATOLI
Computing MAX */
d__3 = abs(d__[1]) + abs(e[1]), d__4 = (d__1 = d__[*n], abs(d__1)) + (
d__2 = e[*n - 1], abs(d__2));
tnorm = max(d__3,d__4);
i__1 = *n - 1;
for (j = 2; j <= i__1; ++j) {
/* Computing MAX */
d__4 = tnorm, d__5 = (d__1 = d__[j], abs(d__1)) + (d__2 = e[j - 1]
, abs(d__2)) + (d__3 = e[j], abs(d__3));
tnorm = max(d__4,d__5);
/* L30: */
}
if (*abstol <= 0.) {
atoli = ulp * tnorm;
} else {
atoli = *abstol;
}
if (irange == 2) {
wl = *vl;
wu = *vu;
} else {
wl = 0.;
wu = 0.;
}
}
/* Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU.
NWL accumulates the number of eigenvalues .le. WL,
NWU accumulates the number of eigenvalues .le. WU */
*m = 0;
iend = 0;
*info = 0;
nwl = 0;
nwu = 0;
i__1 = *nsplit;
for (jb = 1; jb <= i__1; ++jb) {
ioff = iend;
ibegin = ioff + 1;
iend = isplit[jb];
in = iend - ioff;
if (in == 1) {
/* Special Case -- IN=1 */
if (irange == 1 || wl >= d__[ibegin] - pivmin) {
++nwl;
}
if (irange == 1 || wu >= d__[ibegin] - pivmin) {
++nwu;
}
if (irange == 1 || wl < d__[ibegin] - pivmin && wu >= d__[ibegin]
- pivmin) {
++(*m);
w[*m] = d__[ibegin];
iblock[*m] = jb;
}
} else {
/* General Case -- IN > 1
Compute Gershgorin Interval
and use it as the initial interval */
gu = d__[ibegin];
gl = d__[ibegin];
tmp1 = 0.;
i__2 = iend - 1;
for (j = ibegin; j <= i__2; ++j) {
tmp2 = (d__1 = e[j], abs(d__1));
/* Computing MAX */
d__1 = gu, d__2 = d__[j] + tmp1 + tmp2;
gu = max(d__1,d__2);
/* Computing MIN */
d__1 = gl, d__2 = d__[j] - tmp1 - tmp2;
gl = min(d__1,d__2);
tmp1 = tmp2;
/* L40: */
}
/* Computing MAX */
d__1 = gu, d__2 = d__[iend] + tmp1;
gu = max(d__1,d__2);
/* Computing MIN */
d__1 = gl, d__2 = d__[iend] - tmp1;
gl = min(d__1,d__2);
/* Computing MAX */
d__1 = abs(gl), d__2 = abs(gu);
bnorm = max(d__1,d__2);
gl = gl - bnorm * 2.1 * ulp * in - pivmin * 2.1;
gu = gu + bnorm * 2.1 * ulp * in + pivmin * 2.1;
/* Compute ATOLI for the current submatrix */
if (*abstol <= 0.) {
/* Computing MAX */
d__1 = abs(gl), d__2 = abs(gu);
atoli = ulp * max(d__1,d__2);
} else {
atoli = *abstol;
}
if (irange > 1) {
if (gu < wl) {
nwl += in;
nwu += in;
goto L70;
}
gl = max(gl,wl);
gu = min(gu,wu);
if (gl >= gu) {
goto L70;
}
}
/* Set Up Initial Interval */
work[*n + 1] = gl;
work[*n + in + 1] = gu;
igraphdlaebz_(&c__1, &c__0, &in, &in, &c__1, &nb, &atoli, &rtoli, &
pivmin, &d__[ibegin], &e[ibegin], &work[ibegin], idumma, &
work[*n + 1], &work[*n + (in << 1) + 1], &im, &iwork[1], &
w[*m + 1], &iblock[*m + 1], &iinfo);
nwl += iwork[1];
nwu += iwork[in + 1];
iwoff = *m - iwork[1];
/* Compute Eigenvalues */
itmax = (integer) ((log(gu - gl + pivmin) - log(pivmin)) / log(2.)
) + 2;
igraphdlaebz_(&c__2, &itmax, &in, &in, &c__1, &nb, &atoli, &rtoli, &
pivmin, &d__[ibegin], &e[ibegin], &work[ibegin], idumma, &
work[*n + 1], &work[*n + (in << 1) + 1], &iout, &iwork[1],
&w[*m + 1], &iblock[*m + 1], &iinfo);
/* Copy Eigenvalues Into W and IBLOCK
Use -JB for block number for unconverged eigenvalues. */
i__2 = iout;
for (j = 1; j <= i__2; ++j) {
tmp1 = (work[j + *n] + work[j + in + *n]) * .5;
/* Flag non-convergence. */
if (j > iout - iinfo) {
ncnvrg = TRUE_;
ib = -jb;
} else {
ib = jb;
}
i__3 = iwork[j + in] + iwoff;
for (je = iwork[j] + 1 + iwoff; je <= i__3; ++je) {
w[je] = tmp1;
iblock[je] = ib;
/* L50: */
}
/* L60: */
}
*m += im;
}
L70:
;
}
/* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
If NWL+1 < IL or NWU > IU, discard extra eigenvalues. */
if (irange == 3) {
im = 0;
idiscl = *il - 1 - nwl;
idiscu = nwu - *iu;
if (idiscl > 0 || idiscu > 0) {
i__1 = *m;
for (je = 1; je <= i__1; ++je) {
if (w[je] <= wlu && idiscl > 0) {
--idiscl;
} else if (w[je] >= wul && idiscu > 0) {
--idiscu;
} else {
++im;
w[im] = w[je];
iblock[im] = iblock[je];
}
/* L80: */
}
*m = im;
}
if (idiscl > 0 || idiscu > 0) {
/* Code to deal with effects of bad arithmetic:
Some low eigenvalues to be discarded are not in (WL,WLU],
or high eigenvalues to be discarded are not in (WUL,WU]
so just kill off the smallest IDISCL/largest IDISCU
eigenvalues, by simply finding the smallest/largest
eigenvalue(s).
(If N(w) is monotone non-decreasing, this should never
happen.) */
if (idiscl > 0) {
wkill = wu;
i__1 = idiscl;
for (jdisc = 1; jdisc <= i__1; ++jdisc) {
iw = 0;
i__2 = *m;
for (je = 1; je <= i__2; ++je) {
if (iblock[je] != 0 && (w[je] < wkill || iw == 0)) {
iw = je;
wkill = w[je];
}
/* L90: */
}
iblock[iw] = 0;
/* L100: */
}
}
if (idiscu > 0) {
wkill = wl;
i__1 = idiscu;
for (jdisc = 1; jdisc <= i__1; ++jdisc) {
iw = 0;
i__2 = *m;
for (je = 1; je <= i__2; ++je) {
if (iblock[je] != 0 && (w[je] > wkill || iw == 0)) {
iw = je;
wkill = w[je];
}
/* L110: */
}
iblock[iw] = 0;
/* L120: */
}
}
im = 0;
i__1 = *m;
for (je = 1; je <= i__1; ++je) {
if (iblock[je] != 0) {
++im;
w[im] = w[je];
iblock[im] = iblock[je];
}
/* L130: */
}
*m = im;
}
if (idiscl < 0 || idiscu < 0) {
toofew = TRUE_;
}
}
/* If ORDER='B', do nothing -- the eigenvalues are already sorted
by block.
If ORDER='E', sort the eigenvalues from smallest to largest */
if (iorder == 1 && *nsplit > 1) {
i__1 = *m - 1;
for (je = 1; je <= i__1; ++je) {
ie = 0;
tmp1 = w[je];
i__2 = *m;
for (j = je + 1; j <= i__2; ++j) {
if (w[j] < tmp1) {
ie = j;
tmp1 = w[j];
}
/* L140: */
}
if (ie != 0) {
itmp1 = iblock[ie];
w[ie] = w[je];
iblock[ie] = iblock[je];
w[je] = tmp1;
iblock[je] = itmp1;
}
/* L150: */
}
}
*info = 0;
if (ncnvrg) {
++(*info);
}
if (toofew) {
*info += 2;
}
return 0;
/* End of DSTEBZ */
} /* igraphdstebz_ */
/* Subroutine */ int 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_ */
