/* ----------------------------------------------------------------------- */
/* 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 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 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 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 igraphdlarfx_(char *side, integer *m, integer *n, doublereal *
v, doublereal *tau, doublereal *c__, integer *ldc, doublereal *work)
{
/* System generated locals */
integer c_dim1, c_offset, i__1;
doublereal d__1;
/* Local variables */
static integer j;
static doublereal t1, t2, t3, t4, t5, t6, t7, t8, t9, v1, v2, v3, v4, v5,
v6, v7, v8, v9, t10, v10, sum;
extern /* Subroutine */ int igraphdger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
extern logical igraphlsame_(char *, char *);
extern /* Subroutine */ int igraphdgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
/* -- LAPACK auxiliary routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* February 29, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLARFX applies a real elementary reflector H to a real m by n */
/* matrix C, from either the left or the right. H is represented in the */
/* form */
/* H = I - tau * v * v' */
/* where tau is a real scalar and v is a real vector. */
/* If tau = 0, then H is taken to be the unit matrix */
/* This version uses inline code if H has order < 11. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'L': form H * C */
/* = 'R': form C * H */
/* M (input) INTEGER */
/* The number of rows of the matrix C. */
/* N (input) INTEGER */
/* The number of columns of the matrix C. */
/* V (input) DOUBLE PRECISION array, dimension (M) if SIDE = 'L' */
/* or (N) if SIDE = 'R' */
/* The vector v in the representation of H. */
/* TAU (input) DOUBLE PRECISION */
/* The value tau in the representation of H. */
/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
/* On entry, the m by n matrix C. */
/* On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
/* or C * H if SIDE = 'R'. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDA >= (1,M). */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (N) if SIDE = 'L' */
/* or (M) if SIDE = 'R' */
/* WORK is not referenced if H has order < 11. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--v;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
if (*tau == 0.) {
return 0;
}
if (igraphlsame_(side, "L")) {
/* Form H * C, where H has order m. */
switch (*m) {
case 1: goto L10;
case 2: goto L30;
case 3: goto L50;
case 4: goto L70;
case 5: goto L90;
case 6: goto L110;
case 7: goto L130;
case 8: goto L150;
case 9: goto L170;
case 10: goto L190;
}
/* Code for general M */
/* w := C'*v */
igraphdgemv_("Transpose", m, n, &c_b14, &c__[c_offset], ldc, &v[1], &c__1, &
c_b16, &work[1], &c__1);
/* C := C - tau * v * w' */
d__1 = -(*tau);
igraphdger_(m, n, &d__1, &v[1], &c__1, &work[1], &c__1, &c__[c_offset], ldc)
;
goto L410;
L10:
/* Special code for 1 x 1 Householder */
t1 = 1. - *tau * v[1] * v[1];
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
c__[j * c_dim1 + 1] = t1 * c__[j * c_dim1 + 1];
/* L20: */
}
goto L410;
L30:
/* Special code for 2 x 2 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
/* L40: */
}
goto L410;
L50:
/* Special code for 3 x 3 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
c__[j * c_dim1 + 3];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
/* L60: */
}
goto L410;
L70:
/* Special code for 4 x 4 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
c__[j * c_dim1 + 4] -= sum * t4;
/* L80: */
}
goto L410;
L90:
/* Special code for 5 x 5 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
j * c_dim1 + 5];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
c__[j * c_dim1 + 4] -= sum * t4;
c__[j * c_dim1 + 5] -= sum * t5;
/* L100: */
}
goto L410;
L110:
/* Special code for 6 x 6 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
c__[j * c_dim1 + 4] -= sum * t4;
c__[j * c_dim1 + 5] -= sum * t5;
c__[j * c_dim1 + 6] -= sum * t6;
/* L120: */
}
goto L410;
L130:
/* Special code for 7 x 7 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j *
c_dim1 + 7];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
c__[j * c_dim1 + 4] -= sum * t4;
c__[j * c_dim1 + 5] -= sum * t5;
c__[j * c_dim1 + 6] -= sum * t6;
c__[j * c_dim1 + 7] -= sum * t7;
/* L140: */
}
goto L410;
L150:
/* Special code for 8 x 8 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
v8 = v[8];
t8 = *tau * v8;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j *
c_dim1 + 7] + v8 * c__[j * c_dim1 + 8];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
c__[j * c_dim1 + 4] -= sum * t4;
c__[j * c_dim1 + 5] -= sum * t5;
c__[j * c_dim1 + 6] -= sum * t6;
c__[j * c_dim1 + 7] -= sum * t7;
c__[j * c_dim1 + 8] -= sum * t8;
/* L160: */
}
goto L410;
L170:
/* Special code for 9 x 9 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
v8 = v[8];
t8 = *tau * v8;
v9 = v[9];
t9 = *tau * v9;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j *
c_dim1 + 7] + v8 * c__[j * c_dim1 + 8] + v9 * c__[j *
c_dim1 + 9];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
c__[j * c_dim1 + 4] -= sum * t4;
c__[j * c_dim1 + 5] -= sum * t5;
c__[j * c_dim1 + 6] -= sum * t6;
c__[j * c_dim1 + 7] -= sum * t7;
c__[j * c_dim1 + 8] -= sum * t8;
c__[j * c_dim1 + 9] -= sum * t9;
/* L180: */
}
goto L410;
L190:
/* Special code for 10 x 10 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
v8 = v[8];
t8 = *tau * v8;
v9 = v[9];
t9 = *tau * v9;
v10 = v[10];
t10 = *tau * v10;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j *
c_dim1 + 7] + v8 * c__[j * c_dim1 + 8] + v9 * c__[j *
c_dim1 + 9] + v10 * c__[j * c_dim1 + 10];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
c__[j * c_dim1 + 4] -= sum * t4;
c__[j * c_dim1 + 5] -= sum * t5;
c__[j * c_dim1 + 6] -= sum * t6;
c__[j * c_dim1 + 7] -= sum * t7;
c__[j * c_dim1 + 8] -= sum * t8;
c__[j * c_dim1 + 9] -= sum * t9;
c__[j * c_dim1 + 10] -= sum * t10;
/* L200: */
}
goto L410;
} else {
/* Form C * H, where H has order n. */
switch (*n) {
case 1: goto L210;
case 2: goto L230;
case 3: goto L250;
case 4: goto L270;
case 5: goto L290;
case 6: goto L310;
case 7: goto L330;
case 8: goto L350;
case 9: goto L370;
case 10: goto L390;
}
/* Code for general N */
/* w := C * v */
igraphdgemv_("No transpose", m, n, &c_b14, &c__[c_offset], ldc, &v[1], &
c__1, &c_b16, &work[1], &c__1);
/* C := C - tau * w * v' */
d__1 = -(*tau);
igraphdger_(m, n, &d__1, &work[1], &c__1, &v[1], &c__1, &c__[c_offset], ldc)
;
goto L410;
L210:
/* Special code for 1 x 1 Householder */
t1 = 1. - *tau * v[1] * v[1];
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
c__[j + c_dim1] = t1 * c__[j + c_dim1];
/* L220: */
}
goto L410;
L230:
/* Special code for 2 x 2 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
/* L240: */
}
goto L410;
L250:
/* Special code for 3 x 3 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
c__[j + c_dim1 * 3];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
/* L260: */
}
goto L410;
L270:
/* Special code for 4 x 4 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
c__[j + (c_dim1 << 2)] -= sum * t4;
/* L280: */
}
goto L410;
L290:
/* Special code for 5 x 5 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
c__[j + c_dim1 * 5];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
c__[j + (c_dim1 << 2)] -= sum * t4;
c__[j + c_dim1 * 5] -= sum * t5;
/* L300: */
}
goto L410;
L310:
/* Special code for 6 x 6 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
c__[j + (c_dim1 << 2)] -= sum * t4;
c__[j + c_dim1 * 5] -= sum * t5;
c__[j + c_dim1 * 6] -= sum * t6;
/* L320: */
}
goto L410;
L330:
/* Special code for 7 x 7 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[
j + c_dim1 * 7];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
c__[j + (c_dim1 << 2)] -= sum * t4;
c__[j + c_dim1 * 5] -= sum * t5;
c__[j + c_dim1 * 6] -= sum * t6;
c__[j + c_dim1 * 7] -= sum * t7;
/* L340: */
}
goto L410;
L350:
/* Special code for 8 x 8 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
v8 = v[8];
t8 = *tau * v8;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[
j + c_dim1 * 7] + v8 * c__[j + (c_dim1 << 3)];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
c__[j + (c_dim1 << 2)] -= sum * t4;
c__[j + c_dim1 * 5] -= sum * t5;
c__[j + c_dim1 * 6] -= sum * t6;
c__[j + c_dim1 * 7] -= sum * t7;
c__[j + (c_dim1 << 3)] -= sum * t8;
/* L360: */
}
goto L410;
L370:
/* Special code for 9 x 9 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
v8 = v[8];
t8 = *tau * v8;
v9 = v[9];
t9 = *tau * v9;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[
j + c_dim1 * 7] + v8 * c__[j + (c_dim1 << 3)] + v9 * c__[
j + c_dim1 * 9];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
c__[j + (c_dim1 << 2)] -= sum * t4;
c__[j + c_dim1 * 5] -= sum * t5;
c__[j + c_dim1 * 6] -= sum * t6;
c__[j + c_dim1 * 7] -= sum * t7;
c__[j + (c_dim1 << 3)] -= sum * t8;
c__[j + c_dim1 * 9] -= sum * t9;
/* L380: */
}
goto L410;
L390:
/* Special code for 10 x 10 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
v8 = v[8];
t8 = *tau * v8;
v9 = v[9];
t9 = *tau * v9;
v10 = v[10];
t10 = *tau * v10;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[
j + c_dim1 * 7] + v8 * c__[j + (c_dim1 << 3)] + v9 * c__[
j + c_dim1 * 9] + v10 * c__[j + c_dim1 * 10];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
c__[j + (c_dim1 << 2)] -= sum * t4;
c__[j + c_dim1 * 5] -= sum * t5;
c__[j + c_dim1 * 6] -= sum * t6;
c__[j + c_dim1 * 7] -= sum * t7;
c__[j + (c_dim1 << 3)] -= sum * t8;
c__[j + c_dim1 * 9] -= sum * t9;
c__[j + c_dim1 * 10] -= sum * t10;
/* L400: */
}
goto L410;
}
L410:
return 0;
/* End of DLARFX */
} /* igraphdlarfx_ */
