Subroutine */ int igraphdnaupd_(integer *ido, char *bmat, integer *n, char * which, integer *nev, doublereal *tol, doublereal *resid, integer *ncv, doublereal *v, integer *ldv, integer *iparam, integer *ipntr, doublereal *workd, doublereal *workl, integer *lworkl, integer *info) { /* Format strings */ static char fmt_1000[] = "(//,5x,\002===================================" "==========\002,/5x,\002= Nonsymmetric implicit Arnoldi update co" "de =\002,/5x,\002= Version Number: \002,\002 2.4\002,21x,\002 " "=\002,/5x,\002= Version Date: \002,\002 07/31/96\002,16x,\002 =" "\002,/5x,\002=============================================\002,/" "5x,\002= Summary of timing statistics =\002,/5x," "\002=============================================\002,//)"; static char fmt_1100[] = "(5x,\002Total number update iterations " " = \002,i5,/5x,\002Total number of OP*x operations " " = \002,i5,/5x,\002Total number of B*x operations = " "\002,i5,/5x,\002Total number of reorthogonalization steps = " "\002,i5,/5x,\002Total number of iterative refinement steps = " "\002,i5,/5x,\002Total number of restart steps = " "\002,i5,/5x,\002Total time in user OP*x operation = " "\002,f12.6,/5x,\002Total time in user B*x operation =" " \002,f12.6,/5x,\002Total time in Arnoldi update routine = " "\002,f12.6,/5x,\002Total time in naup2 routine =" " \002,f12.6,/5x,\002Total time in basic Arnoldi iteration loop = " "\002,f12.6,/5x,\002Total time in reorthogonalization phase =" " \002,f12.6,/5x,\002Total time in (re)start vector generation = " "\002,f12.6,/5x,\002Total time in Hessenberg eig. subproblem =" " \002,f12.6,/5x,\002Total time in getting the shifts = " "\002,f12.6,/5x,\002Total time in applying the shifts =" " \002,f12.6,/5x,\002Total time in convergence testing = " "\002,f12.6,/5x,\002Total time in computing final Ritz vectors =" " \002,f12.6/)"; /* System generated locals */ integer v_dim1, v_offset, i__1, i__2; /* Builtin functions */ integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), e_wsfe( void), do_fio(integer *, char *, ftnlen); /* Local variables */ integer j; real t0, t1; IGRAPH_F77_SAVE integer nb, ih, iq, np, iw, ldh, ldq; integer nbx = 0; IGRAPH_F77_SAVE integer nev0, mode; integer ierr; IGRAPH_F77_SAVE integer iupd, next; integer nopx = 0; IGRAPH_F77_SAVE integer levec; real trvec, tmvbx; IGRAPH_F77_SAVE integer ritzi; extern /* Subroutine */ int igraphdvout_(integer *, integer *, doublereal *, integer *, char *, ftnlen), igraphivout_(integer *, integer *, integer * , integer *, char *, ftnlen); IGRAPH_F77_SAVE integer ritzr; extern /* Subroutine */ int igraphdnaup2_(integer *, char *, integer *, char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *); real tnaup2, tgetv0; extern doublereal igraphdlamch_(char *); extern /* Subroutine */ int igraphsecond_(real *); integer logfil, ndigit; real tneigh; integer mnaupd = 0; IGRAPH_F77_SAVE integer ishift; integer nitref; IGRAPH_F77_SAVE integer bounds; real tnaupd; extern /* Subroutine */ int igraphdstatn_(void); real titref, tnaitr; IGRAPH_F77_SAVE integer msglvl; real tngets, tnapps, tnconv; IGRAPH_F77_SAVE integer mxiter; integer nrorth = 0, nrstrt = 0; real tmvopx; /* Fortran I/O blocks */ static cilist io___30 = { 0, 6, 0, fmt_1000, 0 }; static cilist io___31 = { 0, 6, 0, fmt_1100, 0 }; /* %----------------------------------------------------% | Include files for debugging and timing information | %----------------------------------------------------% %------------------% | Scalar Arguments | %------------------% %-----------------% | Array Arguments | %-----------------% %------------% | Parameters | %------------% %---------------% | Local Scalars | %---------------% %----------------------% | External Subroutines | %----------------------% %--------------------% | External Functions | %--------------------% %-----------------------% | Executable Statements | %-----------------------% Parameter adjustments */ --workd; --resid; v_dim1 = *ldv; v_offset = 1 + v_dim1; v -= v_offset; --iparam; --ipntr; --workl; /* Function Body */ if (*ido == 0) { /* %-------------------------------% | Initialize timing statistics | | & message level for debugging | %-------------------------------% */ igraphdstatn_(); igraphsecond_(&t0); msglvl = mnaupd; /* %----------------% | Error checking | %----------------% */ ierr = 0; ishift = iparam[1]; levec = iparam[2]; mxiter = iparam[3]; nb = iparam[4]; /* %--------------------------------------------% | Revision 2 performs only implicit restart. | %--------------------------------------------% */ iupd = 1; mode = iparam[7]; if (*n <= 0) { ierr = -1; } else if (*nev <= 0) { ierr = -2; } else if (*ncv <= *nev + 1 || *ncv > *n) { ierr = -3; } else if (mxiter <= 0) { ierr = -4; } else if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp( which, "SM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "LR", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "SR", (ftnlen)2, ( ftnlen)2) != 0 && s_cmp(which, "LI", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "SI", (ftnlen)2, (ftnlen)2) != 0) { ierr = -5; } else if (*(unsigned char *)bmat != 'I' && *(unsigned char *)bmat != 'G') { ierr = -6; } else /* if(complicated condition) */ { /* Computing 2nd power */ i__1 = *ncv; if (*lworkl < i__1 * i__1 * 3 + *ncv * 6) { ierr = -7; } else if (mode < 1 || mode > 5) { ierr = -10; } else if (mode == 1 && *(unsigned char *)bmat == 'G') { ierr = -11; } else if (ishift < 0 || ishift > 1) { ierr = -12; } } /* %------------% | Error Exit | %------------% */ if (ierr != 0) { *info = ierr; *ido = 99; goto L9000; } /* %------------------------% | Set default parameters | %------------------------% */ if (nb <= 0) { nb = 1; } if (*tol <= 0.) { *tol = igraphdlamch_("EpsMach"); } /* %----------------------------------------------% | NP is the number of additional steps to | | extend the length NEV Lanczos factorization. | | NEV0 is the local variable designating the | | size of the invariant subspace desired. | %----------------------------------------------% */ np = *ncv - *nev; nev0 = *nev; /* %-----------------------------% | Zero out internal workspace | %-----------------------------% Computing 2nd power */ i__2 = *ncv; i__1 = i__2 * i__2 * 3 + *ncv * 6; for (j = 1; j <= i__1; ++j) { workl[j] = 0.; /* L10: */ } /* %-------------------------------------------------------------% | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | | etc... and the remaining workspace. | | Also update pointer to be used on output. | | Memory is laid out as follows: | | workl(1:ncv*ncv) := generated Hessenberg matrix | | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary | | parts of ritz values | | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds | | workl(ncv*ncv+3*ncv+1:2*ncv*ncv+3*ncv) := rotation matrix Q | | workl(2*ncv*ncv+3*ncv+1:3*ncv*ncv+6*ncv) := workspace | | The final workspace is needed by subroutine dneigh called | | by dnaup2. Subroutine dneigh calls LAPACK routines for | | calculating eigenvalues and the last row of the eigenvector | | matrix. | %-------------------------------------------------------------% */ ldh = *ncv; ldq = *ncv; ih = 1; ritzr = ih + ldh * *ncv; ritzi = ritzr + *ncv; bounds = ritzi + *ncv; iq = bounds + *ncv; iw = iq + ldq * *ncv; /* Computing 2nd power */ i__1 = *ncv; next = iw + i__1 * i__1 + *ncv * 3; ipntr[4] = next; ipntr[5] = ih; ipntr[6] = ritzr; ipntr[7] = ritzi; ipntr[8] = bounds; ipntr[14] = iw; } /* %-------------------------------------------------------% | Carry out the Implicitly restarted Arnoldi Iteration. | %-------------------------------------------------------% */ igraphdnaup2_(ido, bmat, n, which, &nev0, &np, tol, &resid[1], &mode, &iupd, & ishift, &mxiter, &v[v_offset], ldv, &workl[ih], &ldh, &workl[ ritzr], &workl[ritzi], &workl[bounds], &workl[iq], &ldq, &workl[ iw], &ipntr[1], &workd[1], info); /* %--------------------------------------------------% | ido .ne. 99 implies use of reverse communication | | to compute operations involving OP or shifts. | %--------------------------------------------------% */ if (*ido == 3) { iparam[8] = np; } if (*ido != 99) { goto L9000; } iparam[3] = mxiter; iparam[5] = np; iparam[9] = nopx; iparam[10] = nbx; iparam[11] = nrorth; /* %------------------------------------% | Exit if there was an informational | | error within dnaup2. | %------------------------------------% */ if (*info < 0) { goto L9000; } if (*info == 2) { *info = 3; } if (msglvl > 0) { igraphivout_(&logfil, &c__1, &mxiter, &ndigit, "_naupd: Number of update i" "terations taken", (ftnlen)41); igraphivout_(&logfil, &c__1, &np, &ndigit, "_naupd: Number of wanted \"con" "verged\" Ritz values", (ftnlen)48); igraphdvout_(&logfil, &np, &workl[ritzr], &ndigit, "_naupd: Real part of t" "he final Ritz values", (ftnlen)42); igraphdvout_(&logfil, &np, &workl[ritzi], &ndigit, "_naupd: Imaginary part" " of the final Ritz values", (ftnlen)47); igraphdvout_(&logfil, &np, &workl[bounds], &ndigit, "_naupd: Associated Ri" "tz estimates", (ftnlen)33); } igraphsecond_(&t1); tnaupd = t1 - t0; if (msglvl > 0) { /* %--------------------------------------------------------% | Version Number & Version Date are defined in version.h | %--------------------------------------------------------% */ s_wsfe(&io___30); e_wsfe(); s_wsfe(&io___31); do_fio(&c__1, (char *)&mxiter, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&nopx, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&nbx, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&nrorth, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&nitref, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&nrstrt, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&tmvopx, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&tmvbx, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&tnaupd, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&tnaup2, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&tnaitr, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&titref, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&tgetv0, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&tneigh, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&tngets, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&tnapps, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&tnconv, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&trvec, (ftnlen)sizeof(real)); e_wsfe(); } L9000: return 0; /* %---------------% | End of dnaupd | %---------------% */ } /* igraphdnaupd_ */
Subroutine */ int igraphdgetv0_(integer *ido, char *bmat, integer *itry, logical *initv, integer *n, integer *j, doublereal *v, integer *ldv, doublereal *resid, doublereal *rnorm, integer *ipntr, doublereal * workd, integer *ierr) { /* Initialized data */ IGRAPH_F77_SAVE logical inits = TRUE_; /* System generated locals */ integer v_dim1, v_offset, i__1; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ real t0, t1, t2, t3; integer jj, nbx = 0; extern doublereal igraphddot_(integer *, doublereal *, integer *, doublereal *, integer *); IGRAPH_F77_SAVE integer iter; IGRAPH_F77_SAVE logical orth; integer nopx = 0; extern doublereal igraphdnrm2_(integer *, doublereal *, integer *); IGRAPH_F77_SAVE integer iseed[4]; extern /* Subroutine */ int igraphdgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *); integer idist; extern /* Subroutine */ int igraphdcopy_(integer *, doublereal *, integer *, doublereal *, integer *); IGRAPH_F77_SAVE logical first; real tmvbx = 0; extern /* Subroutine */ int igraphdvout_(integer *, integer *, doublereal *, integer *, char *, ftnlen); integer mgetv0 = 0; real tgetv0 = 0; IGRAPH_F77_SAVE doublereal rnorm0; extern /* Subroutine */ int igraphsecond_(real *); integer logfil, ndigit; extern /* Subroutine */ int igraphdlarnv_(integer *, integer *, integer *, doublereal *); IGRAPH_F77_SAVE integer msglvl; real tmvopx = 0; /* %----------------------------------------------------% | Include files for debugging and timing information | %----------------------------------------------------% %------------------% | Scalar Arguments | %------------------% %-----------------% | Array Arguments | %-----------------% %------------% | Parameters | %------------% %------------------------% | Local Scalars & Arrays | %------------------------% %----------------------% | External Subroutines | %----------------------% %--------------------% | External Functions | %--------------------% %---------------------% | Intrinsic Functions | %---------------------% %-----------------% | Data Statements | %-----------------% Parameter adjustments */ --workd; --resid; v_dim1 = *ldv; v_offset = 1 + v_dim1; v -= v_offset; --ipntr; /* Function Body %-----------------------% | Executable Statements | %-----------------------% %-----------------------------------% | Initialize the seed of the LAPACK | | random number generator | %-----------------------------------% */ if (inits) { iseed[0] = 1; iseed[1] = 3; iseed[2] = 5; iseed[3] = 7; inits = FALSE_; } if (*ido == 0) { /* %-------------------------------% | Initialize timing statistics | | & message level for debugging | %-------------------------------% */ igraphsecond_(&t0); msglvl = mgetv0; *ierr = 0; iter = 0; first = FALSE_; orth = FALSE_; /* %-----------------------------------------------------% | Possibly generate a random starting vector in RESID | | Use a LAPACK random number generator used by the | | matrix generation routines. | | idist = 1: uniform (0,1) distribution; | | idist = 2: uniform (-1,1) distribution; | | idist = 3: normal (0,1) distribution; | %-----------------------------------------------------% */ if (! (*initv)) { idist = 2; igraphdlarnv_(&idist, iseed, n, &resid[1]); } /* %----------------------------------------------------------% | Force the starting vector into the range of OP to handle | | the generalized problem when B is possibly (singular). | %----------------------------------------------------------% */ igraphsecond_(&t2); if (*(unsigned char *)bmat == 'G') { ++nopx; ipntr[1] = 1; ipntr[2] = *n + 1; igraphdcopy_(n, &resid[1], &c__1, &workd[1], &c__1); *ido = -1; goto L9000; } } /* %-----------------------------------------% | Back from computing OP*(initial-vector) | %-----------------------------------------% */ if (first) { goto L20; } /* %-----------------------------------------------% | Back from computing B*(orthogonalized-vector) | %-----------------------------------------------% */ if (orth) { goto L40; } if (*(unsigned char *)bmat == 'G') { igraphsecond_(&t3); tmvopx += t3 - t2; } /* %------------------------------------------------------% | Starting vector is now in the range of OP; r = OP*r; | | Compute B-norm of starting vector. | %------------------------------------------------------% */ igraphsecond_(&t2); first = TRUE_; if (*(unsigned char *)bmat == 'G') { ++nbx; igraphdcopy_(n, &workd[*n + 1], &c__1, &resid[1], &c__1); ipntr[1] = *n + 1; ipntr[2] = 1; *ido = 2; goto L9000; } else if (*(unsigned char *)bmat == 'I') { igraphdcopy_(n, &resid[1], &c__1, &workd[1], &c__1); } L20: if (*(unsigned char *)bmat == 'G') { igraphsecond_(&t3); tmvbx += t3 - t2; } first = FALSE_; if (*(unsigned char *)bmat == 'G') { rnorm0 = igraphddot_(n, &resid[1], &c__1, &workd[1], &c__1); rnorm0 = sqrt((abs(rnorm0))); } else if (*(unsigned char *)bmat == 'I') { rnorm0 = igraphdnrm2_(n, &resid[1], &c__1); } *rnorm = rnorm0; /* %---------------------------------------------% | Exit if this is the very first Arnoldi step | %---------------------------------------------% */ if (*j == 1) { goto L50; } /* %---------------------------------------------------------------- | Otherwise need to B-orthogonalize the starting vector against | | the current Arnoldi basis using Gram-Schmidt with iter. ref. | | This is the case where an invariant subspace is encountered | | in the middle of the Arnoldi factorization. | | | | s = V^{T}*B*r; r = r - V*s; | | | | Stopping criteria used for iter. ref. is discussed in | | Parlett's book, page 107 and in Gragg & Reichel TOMS paper. | %---------------------------------------------------------------% */ orth = TRUE_; L30: i__1 = *j - 1; igraphdgemv_("T", n, &i__1, &c_b24, &v[v_offset], ldv, &workd[1], &c__1, &c_b26, &workd[*n + 1], &c__1); i__1 = *j - 1; igraphdgemv_("N", n, &i__1, &c_b29, &v[v_offset], ldv, &workd[*n + 1], &c__1, & c_b24, &resid[1], &c__1); /* %----------------------------------------------------------% | Compute the B-norm of the orthogonalized starting vector | %----------------------------------------------------------% */ igraphsecond_(&t2); if (*(unsigned char *)bmat == 'G') { ++nbx; igraphdcopy_(n, &resid[1], &c__1, &workd[*n + 1], &c__1); ipntr[1] = *n + 1; ipntr[2] = 1; *ido = 2; goto L9000; } else if (*(unsigned char *)bmat == 'I') { igraphdcopy_(n, &resid[1], &c__1, &workd[1], &c__1); } L40: if (*(unsigned char *)bmat == 'G') { igraphsecond_(&t3); tmvbx += t3 - t2; } if (*(unsigned char *)bmat == 'G') { *rnorm = igraphddot_(n, &resid[1], &c__1, &workd[1], &c__1); *rnorm = sqrt((abs(*rnorm))); } else if (*(unsigned char *)bmat == 'I') { *rnorm = igraphdnrm2_(n, &resid[1], &c__1); } /* %--------------------------------------% | Check for further orthogonalization. | %--------------------------------------% */ if (msglvl > 2) { igraphdvout_(&logfil, &c__1, &rnorm0, &ndigit, "_getv0: re-orthonalization" " ; rnorm0 is", (ftnlen)38); igraphdvout_(&logfil, &c__1, rnorm, &ndigit, "_getv0: re-orthonalization ;" " rnorm is", (ftnlen)37); } if (*rnorm > rnorm0 * .717f) { goto L50; } ++iter; if (iter <= 1) { /* %-----------------------------------% | Perform iterative refinement step | %-----------------------------------% */ rnorm0 = *rnorm; goto L30; } else { /* %------------------------------------% | Iterative refinement step "failed" | %------------------------------------% */ i__1 = *n; for (jj = 1; jj <= i__1; ++jj) { resid[jj] = 0.; /* L45: */ } *rnorm = 0.; *ierr = -1; } L50: if (msglvl > 0) { igraphdvout_(&logfil, &c__1, rnorm, &ndigit, "_getv0: B-norm of initial / " "restarted starting vector", (ftnlen)53); } if (msglvl > 2) { igraphdvout_(&logfil, n, &resid[1], &ndigit, "_getv0: initial / restarted " "starting vector", (ftnlen)43); } *ido = 99; igraphsecond_(&t1); tgetv0 += t1 - t0; L9000: return 0; /* %---------------% | End of dgetv0 | %---------------% */ } /* igraphdgetv0_ */
/* ----------------------------------------------------------------------- */ /* 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 igraphdnapps_(integer *n, integer *kev, integer *np, doublereal *shiftr, doublereal *shifti, doublereal *v, integer *ldv, doublereal *h__, integer *ldh, doublereal *resid, doublereal *q, integer *ldq, doublereal *workl, doublereal *workd) { /* Initialized data */ IGRAPH_F77_SAVE logical first = TRUE_; /* System generated locals */ integer h_dim1, h_offset, v_dim1, v_offset, q_dim1, q_offset, i__1, i__2, i__3, i__4; doublereal d__1, d__2; /* Local variables */ doublereal c__, f, g; integer i__, j; doublereal r__, s, t, u[3]; real t0, t1; doublereal h11, h12, h21, h22, h32; integer jj, ir, nr; doublereal tau; IGRAPH_F77_SAVE doublereal ulp; doublereal tst1; integer iend; IGRAPH_F77_SAVE doublereal unfl, ovfl; extern /* Subroutine */ int igraphdscal_(integer *, doublereal *, doublereal *, integer *), igraphdlarf_(char *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *); logical cconj; extern /* Subroutine */ int igraphdgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *), igraphdcopy_(integer *, doublereal *, integer *, doublereal *, integer *), igraphdaxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *) , igraphdmout_(integer *, integer *, integer *, doublereal *, integer *, integer *, char *, ftnlen), igraphdvout_(integer *, integer *, doublereal *, integer *, char *, ftnlen), igraphivout_(integer *, integer *, integer *, integer *, char *, ftnlen); extern doublereal igraphdlapy2_(doublereal *, doublereal *); extern /* Subroutine */ int igraphdlabad_(doublereal *, doublereal *); extern doublereal igraphdlamch_(char *); extern /* Subroutine */ int igraphdlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *); doublereal sigmai; extern doublereal igraphdlanhs_(char *, integer *, doublereal *, integer *, doublereal *); extern /* Subroutine */ int igraphsecond_(real *), igraphdlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *), igraphdlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *), igraphdlartg_( doublereal *, doublereal *, doublereal *, doublereal *, doublereal *); integer logfil, ndigit; doublereal sigmar; integer mnapps = 0, msglvl; real tnapps = 0.; integer istart; IGRAPH_F77_SAVE doublereal smlnum; integer kplusp; /* %----------------------------------------------------% | Include files for debugging and timing information | %----------------------------------------------------% %------------------% | Scalar Arguments | %------------------% %-----------------% | Array Arguments | %-----------------% %------------% | Parameters | %------------% %------------------------% | Local Scalars & Arrays | %------------------------% %----------------------% | External Subroutines | %----------------------% %--------------------% | External Functions | %--------------------% %----------------------% | Intrinsics Functions | %----------------------% %----------------% | Data statments | %----------------% Parameter adjustments */ --workd; --resid; --workl; --shifti; --shiftr; v_dim1 = *ldv; v_offset = 1 + v_dim1; v -= v_offset; h_dim1 = *ldh; h_offset = 1 + h_dim1; h__ -= h_offset; q_dim1 = *ldq; q_offset = 1 + q_dim1; q -= q_offset; /* Function Body %-----------------------% | Executable Statements | %-----------------------% */ if (first) { /* %-----------------------------------------------% | Set machine-dependent constants for the | | stopping criterion. If norm(H) <= sqrt(OVFL), | | overflow should not occur. | | REFERENCE: LAPACK subroutine dlahqr | %-----------------------------------------------% */ unfl = igraphdlamch_("safe minimum"); ovfl = 1. / unfl; igraphdlabad_(&unfl, &ovfl); ulp = igraphdlamch_("precision"); smlnum = unfl * (*n / ulp); first = FALSE_; } /* %-------------------------------% | Initialize timing statistics | | & message level for debugging | %-------------------------------% */ igraphsecond_(&t0); msglvl = mnapps; kplusp = *kev + *np; /* %--------------------------------------------% | Initialize Q to the identity to accumulate | | the rotations and reflections | %--------------------------------------------% */ igraphdlaset_("All", &kplusp, &kplusp, &c_b5, &c_b6, &q[q_offset], ldq); /* %----------------------------------------------% | Quick return if there are no shifts to apply | %----------------------------------------------% */ if (*np == 0) { goto L9000; } /* %----------------------------------------------% | Chase the bulge with the application of each | | implicit shift. Each shift is applied to the | | whole matrix including each block. | %----------------------------------------------% */ cconj = FALSE_; i__1 = *np; for (jj = 1; jj <= i__1; ++jj) { sigmar = shiftr[jj]; sigmai = shifti[jj]; if (msglvl > 2) { igraphivout_(&logfil, &c__1, &jj, &ndigit, "_napps: shift number.", ( ftnlen)21); igraphdvout_(&logfil, &c__1, &sigmar, &ndigit, "_napps: The real part " "of the shift ", (ftnlen)35); igraphdvout_(&logfil, &c__1, &sigmai, &ndigit, "_napps: The imaginary " "part of the shift ", (ftnlen)40); } /* %-------------------------------------------------% | The following set of conditionals is necessary | | in order that complex conjugate pairs of shifts | | are applied together or not at all. | %-------------------------------------------------% */ if (cconj) { /* %-----------------------------------------% | cconj = .true. means the previous shift | | had non-zero imaginary part. | %-----------------------------------------% */ cconj = FALSE_; goto L110; } else if (jj < *np && abs(sigmai) > 0.) { /* %------------------------------------% | Start of a complex conjugate pair. | %------------------------------------% */ cconj = TRUE_; } else if (jj == *np && abs(sigmai) > 0.) { /* %----------------------------------------------% | The last shift has a nonzero imaginary part. | | Don't apply it; thus the order of the | | compressed H is order KEV+1 since only np-1 | | were applied. | %----------------------------------------------% */ ++(*kev); goto L110; } istart = 1; L20: /* %--------------------------------------------------% | if sigmai = 0 then | | Apply the jj-th shift ... | | else | | Apply the jj-th and (jj+1)-th together ... | | (Note that jj < np at this point in the code) | | end | | to the current block of H. The next do loop | | determines the current block ; | %--------------------------------------------------% */ i__2 = kplusp - 1; for (i__ = istart; i__ <= i__2; ++i__) { /* %----------------------------------------% | Check for splitting and deflation. Use | | a standard test as in the QR algorithm | | REFERENCE: LAPACK subroutine dlahqr | %----------------------------------------% */ tst1 = (d__1 = h__[i__ + i__ * h_dim1], abs(d__1)) + (d__2 = h__[ i__ + 1 + (i__ + 1) * h_dim1], abs(d__2)); if (tst1 == 0.) { i__3 = kplusp - jj + 1; tst1 = igraphdlanhs_("1", &i__3, &h__[h_offset], ldh, &workl[1]); } /* Computing MAX */ d__2 = ulp * tst1; if ((d__1 = h__[i__ + 1 + i__ * h_dim1], abs(d__1)) <= max(d__2, smlnum)) { if (msglvl > 0) { igraphivout_(&logfil, &c__1, &i__, &ndigit, "_napps: matrix sp" "litting at row/column no.", (ftnlen)42); igraphivout_(&logfil, &c__1, &jj, &ndigit, "_napps: matrix spl" "itting with shift number.", (ftnlen)43); igraphdvout_(&logfil, &c__1, &h__[i__ + 1 + i__ * h_dim1], & ndigit, "_napps: off diagonal element.", (ftnlen) 29); } iend = i__; h__[i__ + 1 + i__ * h_dim1] = 0.; goto L40; } /* L30: */ } iend = kplusp; L40: if (msglvl > 2) { igraphivout_(&logfil, &c__1, &istart, &ndigit, "_napps: Start of curre" "nt block ", (ftnlen)31); igraphivout_(&logfil, &c__1, &iend, &ndigit, "_napps: End of current b" "lock ", (ftnlen)29); } /* %------------------------------------------------% | No reason to apply a shift to block of order 1 | %------------------------------------------------% */ if (istart == iend) { goto L100; } /* %------------------------------------------------------% | If istart + 1 = iend then no reason to apply a | | complex conjugate pair of shifts on a 2 by 2 matrix. | %------------------------------------------------------% */ if (istart + 1 == iend && abs(sigmai) > 0.) { goto L100; } h11 = h__[istart + istart * h_dim1]; h21 = h__[istart + 1 + istart * h_dim1]; if (abs(sigmai) <= 0.) { /* %---------------------------------------------% | Real-valued shift ==> apply single shift QR | %---------------------------------------------% */ f = h11 - sigmar; g = h21; i__2 = iend - 1; for (i__ = istart; i__ <= i__2; ++i__) { /* %-----------------------------------------------------% | Contruct the plane rotation G to zero out the bulge | %-----------------------------------------------------% */ igraphdlartg_(&f, &g, &c__, &s, &r__); if (i__ > istart) { /* %-------------------------------------------% | The following ensures that h(1:iend-1,1), | | the first iend-2 off diagonal of elements | | H, remain non negative. | %-------------------------------------------% */ if (r__ < 0.) { r__ = -r__; c__ = -c__; s = -s; } h__[i__ + (i__ - 1) * h_dim1] = r__; h__[i__ + 1 + (i__ - 1) * h_dim1] = 0.; } /* %---------------------------------------------% | Apply rotation to the left of H; H <- G'*H | %---------------------------------------------% */ i__3 = kplusp; for (j = i__; j <= i__3; ++j) { t = c__ * h__[i__ + j * h_dim1] + s * h__[i__ + 1 + j * h_dim1]; h__[i__ + 1 + j * h_dim1] = -s * h__[i__ + j * h_dim1] + c__ * h__[i__ + 1 + j * h_dim1]; h__[i__ + j * h_dim1] = t; /* L50: */ } /* %---------------------------------------------% | Apply rotation to the right of H; H <- H*G | %---------------------------------------------% Computing MIN */ i__4 = i__ + 2; i__3 = min(i__4,iend); for (j = 1; j <= i__3; ++j) { t = c__ * h__[j + i__ * h_dim1] + s * h__[j + (i__ + 1) * h_dim1]; h__[j + (i__ + 1) * h_dim1] = -s * h__[j + i__ * h_dim1] + c__ * h__[j + (i__ + 1) * h_dim1]; h__[j + i__ * h_dim1] = t; /* L60: */ } /* %----------------------------------------------------% | Accumulate the rotation in the matrix Q; Q <- Q*G | %----------------------------------------------------% Computing MIN */ i__4 = j + jj; i__3 = min(i__4,kplusp); for (j = 1; j <= i__3; ++j) { t = c__ * q[j + i__ * q_dim1] + s * q[j + (i__ + 1) * q_dim1]; q[j + (i__ + 1) * q_dim1] = -s * q[j + i__ * q_dim1] + c__ * q[j + (i__ + 1) * q_dim1]; q[j + i__ * q_dim1] = t; /* L70: */ } /* %---------------------------% | Prepare for next rotation | %---------------------------% */ if (i__ < iend - 1) { f = h__[i__ + 1 + i__ * h_dim1]; g = h__[i__ + 2 + i__ * h_dim1]; } /* L80: */ } /* %-----------------------------------% | Finished applying the real shift. | %-----------------------------------% */ } else { /* %----------------------------------------------------% | Complex conjugate shifts ==> apply double shift QR | %----------------------------------------------------% */ h12 = h__[istart + (istart + 1) * h_dim1]; h22 = h__[istart + 1 + (istart + 1) * h_dim1]; h32 = h__[istart + 2 + (istart + 1) * h_dim1]; /* %---------------------------------------------------------% | Compute 1st column of (H - shift*I)*(H - conj(shift)*I) | %---------------------------------------------------------% */ s = sigmar * 2.f; t = igraphdlapy2_(&sigmar, &sigmai); u[0] = (h11 * (h11 - s) + t * t) / h21 + h12; u[1] = h11 + h22 - s; u[2] = h32; i__2 = iend - 1; for (i__ = istart; i__ <= i__2; ++i__) { /* Computing MIN */ i__3 = 3, i__4 = iend - i__ + 1; nr = min(i__3,i__4); /* %-----------------------------------------------------% | Construct Householder reflector G to zero out u(1). | | G is of the form I - tau*( 1 u )' * ( 1 u' ). | %-----------------------------------------------------% */ igraphdlarfg_(&nr, u, &u[1], &c__1, &tau); if (i__ > istart) { h__[i__ + (i__ - 1) * h_dim1] = u[0]; h__[i__ + 1 + (i__ - 1) * h_dim1] = 0.; if (i__ < iend - 1) { h__[i__ + 2 + (i__ - 1) * h_dim1] = 0.; } } u[0] = 1.; /* %--------------------------------------% | Apply the reflector to the left of H | %--------------------------------------% */ i__3 = kplusp - i__ + 1; igraphdlarf_("Left", &nr, &i__3, u, &c__1, &tau, &h__[i__ + i__ * h_dim1], ldh, &workl[1]); /* %---------------------------------------% | Apply the reflector to the right of H | %---------------------------------------% Computing MIN */ i__3 = i__ + 3; ir = min(i__3,iend); igraphdlarf_("Right", &ir, &nr, u, &c__1, &tau, &h__[i__ * h_dim1 + 1], ldh, &workl[1]); /* %-----------------------------------------------------% | Accumulate the reflector in the matrix Q; Q <- Q*G | %-----------------------------------------------------% */ igraphdlarf_("Right", &kplusp, &nr, u, &c__1, &tau, &q[i__ * q_dim1 + 1], ldq, &workl[1]); /* %----------------------------% | Prepare for next reflector | %----------------------------% */ if (i__ < iend - 1) { u[0] = h__[i__ + 1 + i__ * h_dim1]; u[1] = h__[i__ + 2 + i__ * h_dim1]; if (i__ < iend - 2) { u[2] = h__[i__ + 3 + i__ * h_dim1]; } } /* L90: */ } /* %--------------------------------------------% | Finished applying a complex pair of shifts | | to the current block | %--------------------------------------------% */ } L100: /* %---------------------------------------------------------% | Apply the same shift to the next block if there is any. | %---------------------------------------------------------% */ istart = iend + 1; if (iend < kplusp) { goto L20; } /* %---------------------------------------------% | Loop back to the top to get the next shift. | %---------------------------------------------% */ L110: ; } /* %--------------------------------------------------% | Perform a similarity transformation that makes | | sure that H will have non negative sub diagonals | %--------------------------------------------------% */ i__1 = *kev; for (j = 1; j <= i__1; ++j) { if (h__[j + 1 + j * h_dim1] < 0.) { i__2 = kplusp - j + 1; igraphdscal_(&i__2, &c_b43, &h__[j + 1 + j * h_dim1], ldh); /* Computing MIN */ i__3 = j + 2; i__2 = min(i__3,kplusp); igraphdscal_(&i__2, &c_b43, &h__[(j + 1) * h_dim1 + 1], &c__1); /* Computing MIN */ i__3 = j + *np + 1; i__2 = min(i__3,kplusp); igraphdscal_(&i__2, &c_b43, &q[(j + 1) * q_dim1 + 1], &c__1); } /* L120: */ } i__1 = *kev; for (i__ = 1; i__ <= i__1; ++i__) { /* %--------------------------------------------% | Final check for splitting and deflation. | | Use a standard test as in the QR algorithm | | REFERENCE: LAPACK subroutine dlahqr | %--------------------------------------------% */ tst1 = (d__1 = h__[i__ + i__ * h_dim1], abs(d__1)) + (d__2 = h__[i__ + 1 + (i__ + 1) * h_dim1], abs(d__2)); if (tst1 == 0.) { tst1 = igraphdlanhs_("1", kev, &h__[h_offset], ldh, &workl[1]); } /* Computing MAX */ d__1 = ulp * tst1; if (h__[i__ + 1 + i__ * h_dim1] <= max(d__1,smlnum)) { h__[i__ + 1 + i__ * h_dim1] = 0.; } /* L130: */ } /* %-------------------------------------------------% | Compute the (kev+1)-st column of (V*Q) and | | temporarily store the result in WORKD(N+1:2*N). | | This is needed in the residual update since we | | cannot GUARANTEE that the corresponding entry | | of H would be zero as in exact arithmetic. | %-------------------------------------------------% */ if (h__[*kev + 1 + *kev * h_dim1] > 0.) { igraphdgemv_("N", n, &kplusp, &c_b6, &v[v_offset], ldv, &q[(*kev + 1) * q_dim1 + 1], &c__1, &c_b5, &workd[*n + 1], &c__1); } /* %----------------------------------------------------------% | Compute column 1 to kev of (V*Q) in backward order | | taking advantage of the upper Hessenberg structure of Q. | %----------------------------------------------------------% */ i__1 = *kev; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = kplusp - i__ + 1; igraphdgemv_("N", n, &i__2, &c_b6, &v[v_offset], ldv, &q[(*kev - i__ + 1) * q_dim1 + 1], &c__1, &c_b5, &workd[1], &c__1); igraphdcopy_(n, &workd[1], &c__1, &v[(kplusp - i__ + 1) * v_dim1 + 1], & c__1); /* L140: */ } /* %-------------------------------------------------% | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | %-------------------------------------------------% */ igraphdlacpy_("A", n, kev, &v[(kplusp - *kev + 1) * v_dim1 + 1], ldv, &v[ v_offset], ldv); /* %--------------------------------------------------------------% | Copy the (kev+1)-st column of (V*Q) in the appropriate place | %--------------------------------------------------------------% */ if (h__[*kev + 1 + *kev * h_dim1] > 0.) { igraphdcopy_(n, &workd[*n + 1], &c__1, &v[(*kev + 1) * v_dim1 + 1], &c__1); } /* %-------------------------------------% | Update the residual vector: | | r <- sigmak*r + betak*v(:,kev+1) | | where | | sigmak = (e_{kplusp}'*Q)*e_{kev} | | betak = e_{kev+1}'*H*e_{kev} | %-------------------------------------% */ igraphdscal_(n, &q[kplusp + *kev * q_dim1], &resid[1], &c__1); if (h__[*kev + 1 + *kev * h_dim1] > 0.) { igraphdaxpy_(n, &h__[*kev + 1 + *kev * h_dim1], &v[(*kev + 1) * v_dim1 + 1], &c__1, &resid[1], &c__1); } if (msglvl > 1) { igraphdvout_(&logfil, &c__1, &q[kplusp + *kev * q_dim1], &ndigit, "_napps:" " sigmak = (e_{kev+p}^T*Q)*e_{kev}", (ftnlen)40); igraphdvout_(&logfil, &c__1, &h__[*kev + 1 + *kev * h_dim1], &ndigit, "_na" "pps: betak = e_{kev+1}^T*H*e_{kev}", (ftnlen)37); igraphivout_(&logfil, &c__1, kev, &ndigit, "_napps: Order of the final Hes" "senberg matrix ", (ftnlen)45); if (msglvl > 2) { igraphdmout_(&logfil, kev, kev, &h__[h_offset], ldh, &ndigit, "_napps:" " updated Hessenberg matrix H for next iteration", (ftnlen) 54); } } L9000: igraphsecond_(&t1); tnapps += t1 - t0; return 0; /* %---------------% | End of dnapps | %---------------% */ } /* igraphdnapps_ */
/* Subroutine */ int igraphdnaitr_(integer *ido, char *bmat, integer *n, integer *k, integer *np, integer *nb, doublereal *resid, doublereal *rnorm, doublereal *v, integer *ldv, doublereal *h__, integer *ldh, integer * ipntr, doublereal *workd, integer *info) { /* Initialized data */ static logical first = TRUE_; /* System generated locals */ integer h_dim1, h_offset, v_dim1, v_offset, i__1, i__2; doublereal d__1, d__2; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static integer i__, j; static real t0, t1, t2, t3, t4, t5; static integer jj, ipj, irj, ivj; static doublereal ulp, tst1; extern doublereal igraphddot_(integer *, doublereal *, integer *, doublereal *, integer *); static integer ierr, iter; static doublereal unfl, ovfl; static integer itry; extern doublereal igraphdnrm2_(integer *, doublereal *, integer *); static doublereal temp1; static logical orth1, orth2, step3, step4; static doublereal betaj; extern /* Subroutine */ int igraphdscal_(integer *, doublereal *, doublereal *, integer *), igraphdgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *); static integer infol; extern /* Subroutine */ int igraphdcopy_(integer *, doublereal *, integer *, doublereal *, integer *), igraphdaxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *), igraphdmout_(integer *, integer *, integer *, doublereal *, integer *, integer *, char *); static doublereal xtemp[2]; extern /* Subroutine */ int igraphdvout_(integer *, integer *, doublereal *, integer *, char *); static doublereal wnorm; extern /* Subroutine */ int igraphivout_(integer *, integer *, integer *, integer *, char *), igraphdgetv0_(integer *, char *, integer *, logical *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer * ), igraphdlabad_(doublereal *, doublereal *); static doublereal rnorm1; extern doublereal igraphdlamch_(char *); extern /* Subroutine */ int igraphdlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, integer *); extern doublereal igraphdlanhs_(char *, integer *, doublereal *, integer *, doublereal *); extern /* Subroutine */ int igraphsecond_(real *); static logical rstart; static integer msglvl; static doublereal smlnum; /* %----------------------------------------------------% */ /* | Include files for debugging and timing information | */ /* %----------------------------------------------------% */ /* \SCCS Information: @(#) */ /* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */ /* %---------------------------------% */ /* | See debug.doc for documentation | */ /* %---------------------------------% */ /* %------------------% */ /* | Scalar Arguments | */ /* %------------------% */ /* %--------------------------------% */ /* | See stat.doc for documentation | */ /* %--------------------------------% */ /* \SCCS Information: @(#) */ /* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */ /* %-----------------% */ /* | Array Arguments | */ /* %-----------------% */ /* %------------% */ /* | Parameters | */ /* %------------% */ /* %---------------% */ /* | Local Scalars | */ /* %---------------% */ /* %-----------------------% */ /* | Local Array Arguments | */ /* %-----------------------% */ /* %----------------------% */ /* | External Subroutines | */ /* %----------------------% */ /* %--------------------% */ /* | External Functions | */ /* %--------------------% */ /* %---------------------% */ /* | Intrinsic Functions | */ /* %---------------------% */ /* %-----------------% */ /* | Data statements | */ /* %-----------------% */ /* Parameter adjustments */ --workd; --resid; v_dim1 = *ldv; v_offset = 1 + v_dim1; v -= v_offset; h_dim1 = *ldh; h_offset = 1 + h_dim1; h__ -= h_offset; --ipntr; /* Function Body */ /* %-----------------------% */ /* | Executable Statements | */ /* %-----------------------% */ if (first) { /* %-----------------------------------------% */ /* | Set machine-dependent constants for the | */ /* | the splitting and deflation criterion. | */ /* | If norm(H) <= sqrt(OVFL), | */ /* | overflow should not occur. | */ /* | REFERENCE: LAPACK subroutine dlahqr | */ /* %-----------------------------------------% */ unfl = igraphdlamch_("safe minimum"); ovfl = 1. / unfl; igraphdlabad_(&unfl, &ovfl); ulp = igraphdlamch_("precision"); smlnum = unfl * (*n / ulp); first = FALSE_; } if (*ido == 0) { /* %-------------------------------% */ /* | Initialize timing statistics | */ /* | & message level for debugging | */ /* %-------------------------------% */ igraphsecond_(&t0); msglvl = debug_1.mnaitr; /* %------------------------------% */ /* | Initial call to this routine | */ /* %------------------------------% */ *info = 0; step3 = FALSE_; step4 = FALSE_; rstart = FALSE_; orth1 = FALSE_; orth2 = FALSE_; j = *k + 1; ipj = 1; irj = ipj + *n; ivj = irj + *n; } /* %-------------------------------------------------% */ /* | When in reverse communication mode one of: | */ /* | STEP3, STEP4, ORTH1, ORTH2, RSTART | */ /* | will be .true. when .... | */ /* | STEP3: return from computing OP*v_{j}. | */ /* | STEP4: return from computing B-norm of OP*v_{j} | */ /* | ORTH1: return from computing B-norm of r_{j+1} | */ /* | ORTH2: return from computing B-norm of | */ /* | correction to the residual vector. | */ /* | RSTART: return from OP computations needed by | */ /* | dgetv0. | */ /* %-------------------------------------------------% */ if (step3) { goto L50; } if (step4) { goto L60; } if (orth1) { goto L70; } if (orth2) { goto L90; } if (rstart) { goto L30; } /* %-----------------------------% */ /* | Else this is the first step | */ /* %-----------------------------% */ /* %--------------------------------------------------------------% */ /* | | */ /* | A R N O L D I I T E R A T I O N L O O P | */ /* | | */ /* | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | */ /* %--------------------------------------------------------------% */ L1000: if (msglvl > 1) { igraphivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: generat" "ing Arnoldi vector number"); igraphdvout_(&debug_1.logfil, &c__1, rnorm, &debug_1.ndigit, "_naitr: B-no" "rm of the current residual is"); } /* %---------------------------------------------------% */ /* | STEP 1: Check if the B norm of j-th residual | */ /* | vector is zero. Equivalent to determing whether | */ /* | an exact j-step Arnoldi factorization is present. | */ /* %---------------------------------------------------% */ betaj = *rnorm; if (*rnorm > 0.) { goto L40; } /* %---------------------------------------------------% */ /* | Invariant subspace found, generate a new starting | */ /* | vector which is orthogonal to the current Arnoldi | */ /* | basis and continue the iteration. | */ /* %---------------------------------------------------% */ if (msglvl > 0) { igraphivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: ****** " "RESTART AT STEP ******"); } /* %---------------------------------------------% */ /* | ITRY is the loop variable that controls the | */ /* | maximum amount of times that a restart is | */ /* | attempted. NRSTRT is used by stat.h | */ /* %---------------------------------------------% */ betaj = 0.; ++timing_1.nrstrt; itry = 1; L20: rstart = TRUE_; *ido = 0; L30: /* %--------------------------------------% */ /* | If in reverse communication mode and | */ /* | RSTART = .true. flow returns here. | */ /* %--------------------------------------% */ igraphdgetv0_(ido, bmat, &itry, &c_false, n, &j, &v[v_offset], ldv, &resid[1], rnorm, &ipntr[1], &workd[1], &ierr); if (*ido != 99) { goto L9000; } if (ierr < 0) { ++itry; if (itry <= 3) { goto L20; } /* %------------------------------------------------% */ /* | Give up after several restart attempts. | */ /* | Set INFO to the size of the invariant subspace | */ /* | which spans OP and exit. | */ /* %------------------------------------------------% */ *info = j - 1; igraphsecond_(&t1); timing_1.tnaitr += t1 - t0; *ido = 99; goto L9000; } L40: /* %---------------------------------------------------------% */ /* | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | */ /* | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | */ /* | when reciprocating a small RNORM, test against lower | */ /* | machine bound. | */ /* %---------------------------------------------------------% */ igraphdcopy_(n, &resid[1], &c__1, &v[j * v_dim1 + 1], &c__1); if (*rnorm >= unfl) { temp1 = 1. / *rnorm; igraphdscal_(n, &temp1, &v[j * v_dim1 + 1], &c__1); igraphdscal_(n, &temp1, &workd[ipj], &c__1); } else { /* %-----------------------------------------% */ /* | To scale both v_{j} and p_{j} carefully | */ /* | use LAPACK routine SLASCL | */ /* %-----------------------------------------% */ igraphdlascl_("General", &i__, &i__, rnorm, &c_b25, n, &c__1, &v[j * v_dim1 + 1], n, &infol); igraphdlascl_("General", &i__, &i__, rnorm, &c_b25, n, &c__1, &workd[ipj], n, &infol); } /* %------------------------------------------------------% */ /* | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | */ /* | Note that this is not quite yet r_{j}. See STEP 4 | */ /* %------------------------------------------------------% */ step3 = TRUE_; ++timing_1.nopx; igraphsecond_(&t2); igraphdcopy_(n, &v[j * v_dim1 + 1], &c__1, &workd[ivj], &c__1); ipntr[1] = ivj; ipntr[2] = irj; ipntr[3] = ipj; *ido = 1; /* %-----------------------------------% */ /* | Exit in order to compute OP*v_{j} | */ /* %-----------------------------------% */ goto L9000; L50: /* %----------------------------------% */ /* | Back from reverse communication; | */ /* | WORKD(IRJ:IRJ+N-1) := OP*v_{j} | */ /* | if step3 = .true. | */ /* %----------------------------------% */ igraphsecond_(&t3); timing_1.tmvopx += t3 - t2; step3 = FALSE_; /* %------------------------------------------% */ /* | Put another copy of OP*v_{j} into RESID. | */ /* %------------------------------------------% */ igraphdcopy_(n, &workd[irj], &c__1, &resid[1], &c__1); /* %---------------------------------------% */ /* | STEP 4: Finish extending the Arnoldi | */ /* | factorization to length j. | */ /* %---------------------------------------% */ igraphsecond_(&t2); if (*(unsigned char *)bmat == 'G') { ++timing_1.nbx; step4 = TRUE_; ipntr[1] = irj; ipntr[2] = ipj; *ido = 2; /* %-------------------------------------% */ /* | Exit in order to compute B*OP*v_{j} | */ /* %-------------------------------------% */ goto L9000; } else if (*(unsigned char *)bmat == 'I') { igraphdcopy_(n, &resid[1], &c__1, &workd[ipj], &c__1); } L60: /* %----------------------------------% */ /* | Back from reverse communication; | */ /* | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} | */ /* | if step4 = .true. | */ /* %----------------------------------% */ if (*(unsigned char *)bmat == 'G') { igraphsecond_(&t3); timing_1.tmvbx += t3 - t2; } step4 = FALSE_; /* %-------------------------------------% */ /* | The following is needed for STEP 5. | */ /* | Compute the B-norm of OP*v_{j}. | */ /* %-------------------------------------% */ if (*(unsigned char *)bmat == 'G') { wnorm = igraphddot_(n, &resid[1], &c__1, &workd[ipj], &c__1); wnorm = sqrt((abs(wnorm))); } else if (*(unsigned char *)bmat == 'I') { wnorm = igraphdnrm2_(n, &resid[1], &c__1); } /* %-----------------------------------------% */ /* | Compute the j-th residual corresponding | */ /* | to the j step factorization. | */ /* | Use Classical Gram Schmidt and compute: | */ /* | w_{j} <- V_{j}^T * B * OP * v_{j} | */ /* | r_{j} <- OP*v_{j} - V_{j} * w_{j} | */ /* %-----------------------------------------% */ /* %------------------------------------------% */ /* | Compute the j Fourier coefficients w_{j} | */ /* | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | */ /* %------------------------------------------% */ igraphdgemv_("T", n, &j, &c_b25, &v[v_offset], ldv, &workd[ipj], &c__1, &c_b47, &h__[j * h_dim1 + 1], &c__1); /* %--------------------------------------% */ /* | Orthogonalize r_{j} against V_{j}. | */ /* | RESID contains OP*v_{j}. See STEP 3. | */ /* %--------------------------------------% */ igraphdgemv_("N", n, &j, &c_b50, &v[v_offset], ldv, &h__[j * h_dim1 + 1], &c__1, &c_b25, &resid[1], &c__1); if (j > 1) { h__[j + (j - 1) * h_dim1] = betaj; } igraphsecond_(&t4); orth1 = TRUE_; igraphsecond_(&t2); if (*(unsigned char *)bmat == 'G') { ++timing_1.nbx; igraphdcopy_(n, &resid[1], &c__1, &workd[irj], &c__1); ipntr[1] = irj; ipntr[2] = ipj; *ido = 2; /* %----------------------------------% */ /* | Exit in order to compute B*r_{j} | */ /* %----------------------------------% */ goto L9000; } else if (*(unsigned char *)bmat == 'I') { igraphdcopy_(n, &resid[1], &c__1, &workd[ipj], &c__1); } L70: /* %---------------------------------------------------% */ /* | Back from reverse communication if ORTH1 = .true. | */ /* | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | */ /* %---------------------------------------------------% */ if (*(unsigned char *)bmat == 'G') { igraphsecond_(&t3); timing_1.tmvbx += t3 - t2; } orth1 = FALSE_; /* %------------------------------% */ /* | Compute the B-norm of r_{j}. | */ /* %------------------------------% */ if (*(unsigned char *)bmat == 'G') { *rnorm = igraphddot_(n, &resid[1], &c__1, &workd[ipj], &c__1); *rnorm = sqrt((abs(*rnorm))); } else if (*(unsigned char *)bmat == 'I') { *rnorm = igraphdnrm2_(n, &resid[1], &c__1); } /* %-----------------------------------------------------------% */ /* | STEP 5: Re-orthogonalization / Iterative refinement phase | */ /* | Maximum NITER_ITREF tries. | */ /* | | */ /* | s = V_{j}^T * B * r_{j} | */ /* | r_{j} = r_{j} - V_{j}*s | */ /* | alphaj = alphaj + s_{j} | */ /* | | */ /* | The stopping criteria used for iterative refinement is | */ /* | discussed in Parlett's book SEP, page 107 and in Gragg & | */ /* | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | */ /* | Determine if we need to correct the residual. The goal is | */ /* | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | */ /* | The following test determines whether the sine of the | */ /* | angle between OP*x and the computed residual is less | */ /* | than or equal to 0.717. | */ /* %-----------------------------------------------------------% */ if (*rnorm > wnorm * .717f) { goto L100; } iter = 0; ++timing_1.nrorth; /* %---------------------------------------------------% */ /* | Enter the Iterative refinement phase. If further | */ /* | refinement is necessary, loop back here. The loop | */ /* | variable is ITER. Perform a step of Classical | */ /* | Gram-Schmidt using all the Arnoldi vectors V_{j} | */ /* %---------------------------------------------------% */ L80: if (msglvl > 2) { xtemp[0] = wnorm; xtemp[1] = *rnorm; igraphdvout_(&debug_1.logfil, &c__2, xtemp, &debug_1.ndigit, "_naitr: re-o" "rthonalization; wnorm and rnorm are"); igraphdvout_(&debug_1.logfil, &j, &h__[j * h_dim1 + 1], &debug_1.ndigit, "_naitr: j-th column of H"); } /* %----------------------------------------------------% */ /* | Compute V_{j}^T * B * r_{j}. | */ /* | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | */ /* %----------------------------------------------------% */ igraphdgemv_("T", n, &j, &c_b25, &v[v_offset], ldv, &workd[ipj], &c__1, &c_b47, &workd[irj], &c__1); /* %---------------------------------------------% */ /* | Compute the correction to the residual: | */ /* | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | */ /* | The correction to H is v(:,1:J)*H(1:J,1:J) | */ /* | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. | */ /* %---------------------------------------------% */ igraphdgemv_("N", n, &j, &c_b50, &v[v_offset], ldv, &workd[irj], &c__1, &c_b25, &resid[1], &c__1); igraphdaxpy_(&j, &c_b25, &workd[irj], &c__1, &h__[j * h_dim1 + 1], &c__1); orth2 = TRUE_; igraphsecond_(&t2); if (*(unsigned char *)bmat == 'G') { ++timing_1.nbx; igraphdcopy_(n, &resid[1], &c__1, &workd[irj], &c__1); ipntr[1] = irj; ipntr[2] = ipj; *ido = 2; /* %-----------------------------------% */ /* | Exit in order to compute B*r_{j}. | */ /* | r_{j} is the corrected residual. | */ /* %-----------------------------------% */ goto L9000; } else if (*(unsigned char *)bmat == 'I') { igraphdcopy_(n, &resid[1], &c__1, &workd[ipj], &c__1); } L90: /* %---------------------------------------------------% */ /* | Back from reverse communication if ORTH2 = .true. | */ /* %---------------------------------------------------% */ if (*(unsigned char *)bmat == 'G') { igraphsecond_(&t3); timing_1.tmvbx += t3 - t2; } /* %-----------------------------------------------------% */ /* | Compute the B-norm of the corrected residual r_{j}. | */ /* %-----------------------------------------------------% */ if (*(unsigned char *)bmat == 'G') { rnorm1 = igraphddot_(n, &resid[1], &c__1, &workd[ipj], &c__1); rnorm1 = sqrt((abs(rnorm1))); } else if (*(unsigned char *)bmat == 'I') { rnorm1 = igraphdnrm2_(n, &resid[1], &c__1); } if (msglvl > 0 && iter > 0) { igraphivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: Iterati" "ve refinement for Arnoldi residual"); if (msglvl > 2) { xtemp[0] = *rnorm; xtemp[1] = rnorm1; igraphdvout_(&debug_1.logfil, &c__2, xtemp, &debug_1.ndigit, "_naitr: " "iterative refinement ; rnorm and rnorm1 are"); } } /* %-----------------------------------------% */ /* | Determine if we need to perform another | */ /* | step of re-orthogonalization. | */ /* %-----------------------------------------% */ if (rnorm1 > *rnorm * .717f) { /* %---------------------------------------% */ /* | No need for further refinement. | */ /* | The cosine of the angle between the | */ /* | corrected residual vector and the old | */ /* | residual vector is greater than 0.717 | */ /* | In other words the corrected residual | */ /* | and the old residual vector share an | */ /* | angle of less than arcCOS(0.717) | */ /* %---------------------------------------% */ *rnorm = rnorm1; } else { /* %-------------------------------------------% */ /* | Another step of iterative refinement step | */ /* | is required. NITREF is used by stat.h | */ /* %-------------------------------------------% */ ++timing_1.nitref; *rnorm = rnorm1; ++iter; if (iter <= 1) { goto L80; } /* %-------------------------------------------------% */ /* | Otherwise RESID is numerically in the span of V | */ /* %-------------------------------------------------% */ i__1 = *n; for (jj = 1; jj <= i__1; ++jj) { resid[jj] = 0.; /* L95: */ } *rnorm = 0.; } /* %----------------------------------------------% */ /* | Branch here directly if iterative refinement | */ /* | wasn't necessary or after at most NITER_REF | */ /* | steps of iterative refinement. | */ /* %----------------------------------------------% */ L100: rstart = FALSE_; orth2 = FALSE_; igraphsecond_(&t5); timing_1.titref += t5 - t4; /* %------------------------------------% */ /* | STEP 6: Update j = j+1; Continue | */ /* %------------------------------------% */ ++j; if (j > *k + *np) { igraphsecond_(&t1); timing_1.tnaitr += t1 - t0; *ido = 99; i__1 = *k + *np - 1; for (i__ = max(1,*k); i__ <= i__1; ++i__) { /* %--------------------------------------------% */ /* | Check for splitting and deflation. | */ /* | Use a standard test as in the QR algorithm | */ /* | REFERENCE: LAPACK subroutine dlahqr | */ /* %--------------------------------------------% */ tst1 = (d__1 = h__[i__ + i__ * h_dim1], abs(d__1)) + (d__2 = h__[ i__ + 1 + (i__ + 1) * h_dim1], abs(d__2)); if (tst1 == 0.) { i__2 = *k + *np; tst1 = igraphdlanhs_("1", &i__2, &h__[h_offset], ldh, &workd[*n + 1]); } /* Computing MAX */ d__2 = ulp * tst1; if ((d__1 = h__[i__ + 1 + i__ * h_dim1], abs(d__1)) <= max(d__2, smlnum)) { h__[i__ + 1 + i__ * h_dim1] = 0.; } /* L110: */ } if (msglvl > 2) { i__1 = *k + *np; i__2 = *k + *np; igraphdmout_(&debug_1.logfil, &i__1, &i__2, &h__[h_offset], ldh, & debug_1.ndigit, "_naitr: Final upper Hessenberg matrix H" " of order K+NP"); } goto L9000; } /* %--------------------------------------------------------% */ /* | Loop back to extend the factorization by another step. | */ /* %--------------------------------------------------------% */ goto L1000; /* %---------------------------------------------------------------% */ /* | | */ /* | E N D O F M A I N I T E R A T I O N L O O P | */ /* | | */ /* %---------------------------------------------------------------% */ L9000: return 0; /* %---------------% */ /* | End of igraphdnaitr | */ /* %---------------% */ } /* igraphdnaitr_ */
Subroutine */ int igraphdsgets_(integer *ishift, char *which, integer *kev, integer *np, doublereal *ritz, doublereal *bounds, doublereal *shifts) { /* System generated locals */ integer i__1; /* Builtin functions */ integer s_cmp(char *, char *, ftnlen, ftnlen); /* Local variables */ real t0, t1; integer kevd2; extern /* Subroutine */ int igraphdswap_(integer *, doublereal *, integer *, doublereal *, integer *), igraphdcopy_(integer *, doublereal *, integer *, doublereal *, integer *), igraphdvout_(integer *, integer *, doublereal *, integer *, char *, ftnlen), igraphivout_(integer *, integer *, integer *, integer *, char *, ftnlen), igraphsecond_(real *); integer logfil=0, ndigit, msgets=0, msglvl; real tsgets; extern /* Subroutine */ int igraphdsortr_(char *, logical *, integer *, doublereal *, doublereal *); /* %----------------------------------------------------% | Include files for debugging and timing information | %----------------------------------------------------% %------------------% | Scalar Arguments | %------------------% %-----------------% | Array Arguments | %-----------------% %------------% | Parameters | %------------% %---------------% | Local Scalars | %---------------% %----------------------% | External Subroutines | %----------------------% %---------------------% | Intrinsic Functions | %---------------------% %-----------------------% | Executable Statements | %-----------------------% %-------------------------------% | Initialize timing statistics | | & message level for debugging | %-------------------------------% Parameter adjustments */ --shifts; --bounds; --ritz; /* Function Body */ igraphsecond_(&t0); msglvl = msgets; if (s_cmp(which, "BE", (ftnlen)2, (ftnlen)2) == 0) { /* %-----------------------------------------------------% | Both ends of the spectrum are requested. | | Sort the eigenvalues into algebraically increasing | | order first then swap high end of the spectrum next | | to low end in appropriate locations. | | NOTE: when np < floor(kev/2) be careful not to swap | | overlapping locations. | %-----------------------------------------------------% */ i__1 = *kev + *np; igraphdsortr_("LA", &c_true, &i__1, &ritz[1], &bounds[1]); kevd2 = *kev / 2; if (*kev > 1) { i__1 = min(kevd2,*np); igraphdswap_(&i__1, &ritz[1], &c__1, &ritz[max(kevd2,*np) + 1], &c__1); i__1 = min(kevd2,*np); igraphdswap_(&i__1, &bounds[1], &c__1, &bounds[max(kevd2,*np) + 1], & c__1); } } else { /* %----------------------------------------------------% | LM, SM, LA, SA case. | | Sort the eigenvalues of H into the desired order | | and apply the resulting order to BOUNDS. | | The eigenvalues are sorted so that the wanted part | | are always in the last KEV locations. | %----------------------------------------------------% */ i__1 = *kev + *np; igraphdsortr_(which, &c_true, &i__1, &ritz[1], &bounds[1]); } if (*ishift == 1 && *np > 0) { /* %-------------------------------------------------------% | Sort the unwanted Ritz values used as shifts so that | | the ones with largest Ritz estimates are first. | | This will tend to minimize the effects of the | | forward instability of the iteration when the shifts | | are applied in subroutine dsapps. | %-------------------------------------------------------% */ igraphdsortr_("SM", &c_true, np, &bounds[1], &ritz[1]); igraphdcopy_(np, &ritz[1], &c__1, &shifts[1], &c__1); } igraphsecond_(&t1); tsgets += t1 - t0; if (msglvl > 0) { igraphivout_(&logfil, &c__1, kev, &ndigit, "_sgets: KEV is", (ftnlen)14); igraphivout_(&logfil, &c__1, np, &ndigit, "_sgets: NP is", (ftnlen)13); i__1 = *kev + *np; igraphdvout_(&logfil, &i__1, &ritz[1], &ndigit, "_sgets: Eigenvalues of cu" "rrent H matrix", (ftnlen)39); i__1 = *kev + *np; igraphdvout_(&logfil, &i__1, &bounds[1], &ndigit, "_sgets: Associated Ritz" " estimates", (ftnlen)33); } return 0; /* %---------------% | End of dsgets | %---------------% */ } /* igraphdsgets_ */
Subroutine */ int igraphdseigt_(doublereal *rnorm, integer *n, doublereal *h__, integer *ldh, doublereal *eig, doublereal *bounds, doublereal *workl, integer *ierr) { /* System generated locals */ integer h_dim1, h_offset, i__1; doublereal d__1; /* Local variables */ integer k; real t0, t1; extern /* Subroutine */ int igraphdcopy_(integer *, doublereal *, integer *, doublereal *, integer *), igraphdvout_(integer *, integer *, doublereal *, integer *, char *, ftnlen), igraphsecond_(real *); integer logfil, ndigit, mseigt = 0; extern /* Subroutine */ int igraphdstqrb_(integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *); real tseigt = 0.0; integer msglvl; /* %----------------------------------------------------% | Include files for debugging and timing information | %----------------------------------------------------% %------------------% | Scalar Arguments | %------------------% %-----------------% | Array Arguments | %-----------------% %------------% | Parameters | %------------% %---------------% | Local Scalars | %---------------% %----------------------% | External Subroutines | %----------------------% %-----------------------% | Executable Statements | %-----------------------% %-------------------------------% | Initialize timing statistics | | & message level for debugging | %-------------------------------% Parameter adjustments */ --workl; --bounds; --eig; h_dim1 = *ldh; h_offset = 1 + h_dim1; h__ -= h_offset; /* Function Body */ igraphsecond_(&t0); msglvl = mseigt; if (msglvl > 0) { igraphdvout_(&logfil, n, &h__[(h_dim1 << 1) + 1], &ndigit, "_seigt: main d" "iagonal of matrix H", (ftnlen)33); if (*n > 1) { i__1 = *n - 1; igraphdvout_(&logfil, &i__1, &h__[h_dim1 + 2], &ndigit, "_seigt: sub d" "iagonal of matrix H", (ftnlen)32); } } igraphdcopy_(n, &h__[(h_dim1 << 1) + 1], &c__1, &eig[1], &c__1); i__1 = *n - 1; igraphdcopy_(&i__1, &h__[h_dim1 + 2], &c__1, &workl[1], &c__1); igraphdstqrb_(n, &eig[1], &workl[1], &bounds[1], &workl[*n + 1], ierr); if (*ierr != 0) { goto L9000; } if (msglvl > 1) { igraphdvout_(&logfil, n, &bounds[1], &ndigit, "_seigt: last row of the eig" "envector matrix for H", (ftnlen)48); } /* %-----------------------------------------------% | Finally determine the error bounds associated | | with the n Ritz values of H. | %-----------------------------------------------% */ i__1 = *n; for (k = 1; k <= i__1; ++k) { bounds[k] = *rnorm * (d__1 = bounds[k], abs(d__1)); /* L30: */ } igraphsecond_(&t1); tseigt += t1 - t0; L9000: return 0; /* %---------------% | End of dseigt | %---------------% */ } /* igraphdseigt_ */
Subroutine */ int igraphdsaup2_(integer *ido, char *bmat, integer *n, char * which, integer *nev, integer *np, doublereal *tol, doublereal *resid, integer *mode, integer *iupd, integer *ishift, integer *mxiter, doublereal *v, integer *ldv, doublereal *h__, integer *ldh, doublereal *ritz, doublereal *bounds, doublereal *q, integer *ldq, doublereal *workl, integer *ipntr, doublereal *workd, integer *info) { /* System generated locals */ integer h_dim1, h_offset, q_dim1, q_offset, v_dim1, v_offset, i__1, i__2, i__3; doublereal d__1, d__2, d__3; /* Builtin functions */ double pow_dd(doublereal *, doublereal *); integer s_cmp(char *, char *, ftnlen, ftnlen); /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); double sqrt(doublereal); /* Local variables */ integer j; real t0, t1, t2, t3; integer kp[3]; IGRAPH_F77_SAVE integer np0; integer nbx = 0; IGRAPH_F77_SAVE integer nev0; extern doublereal igraphddot_(integer *, doublereal *, integer *, doublereal *, integer *); IGRAPH_F77_SAVE doublereal eps23; integer ierr; IGRAPH_F77_SAVE integer iter; doublereal temp; integer nevd2; extern doublereal igraphdnrm2_(integer *, doublereal *, integer *); IGRAPH_F77_SAVE logical getv0; integer nevm2; IGRAPH_F77_SAVE logical cnorm; extern /* Subroutine */ int igraphdcopy_(integer *, doublereal *, integer *, doublereal *, integer *), igraphdswap_(integer *, doublereal *, integer *, doublereal *, integer *); IGRAPH_F77_SAVE integer nconv; IGRAPH_F77_SAVE logical initv; IGRAPH_F77_SAVE doublereal rnorm; real tmvbx = 0.0; extern /* Subroutine */ int igraphdvout_(integer *, integer *, doublereal *, integer *, char *, ftnlen), igraphivout_(integer *, integer *, integer * , integer *, char *, ftnlen), igraphdgetv0_(integer *, char *, integer * , logical *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *); integer msaup2 = 0; real tsaup2; extern doublereal igraphdlamch_(char *); integer nevbef; extern /* Subroutine */ int igraphsecond_(real *); integer logfil, ndigit; extern /* Subroutine */ int igraphdseigt_(doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, integer *); IGRAPH_F77_SAVE logical update; extern /* Subroutine */ int igraphdsaitr_(integer *, char *, integer *, integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *, integer *, doublereal *, integer *), igraphdsgets_(integer *, char *, integer *, integer *, doublereal *, doublereal *, doublereal *), igraphdsapps_( integer *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *), igraphdsconv_(integer *, doublereal *, doublereal *, doublereal *, integer *); IGRAPH_F77_SAVE logical ushift; char wprime[2]; IGRAPH_F77_SAVE integer msglvl; integer nptemp; extern /* Subroutine */ int igraphdsortr_(char *, logical *, integer *, doublereal *, doublereal *); IGRAPH_F77_SAVE integer kplusp; /* %----------------------------------------------------% | Include files for debugging and timing information | %----------------------------------------------------% %------------------% | Scalar Arguments | %------------------% %-----------------% | Array Arguments | %-----------------% %------------% | Parameters | %------------% %---------------% | Local Scalars | %---------------% %----------------------% | External Subroutines | %----------------------% %--------------------% | External Functions | %--------------------% %---------------------% | Intrinsic Functions | %---------------------% %-----------------------% | Executable Statements | %-----------------------% Parameter adjustments */ --workd; --resid; --workl; --bounds; --ritz; v_dim1 = *ldv; v_offset = 1 + v_dim1; v -= v_offset; h_dim1 = *ldh; h_offset = 1 + h_dim1; h__ -= h_offset; q_dim1 = *ldq; q_offset = 1 + q_dim1; q -= q_offset; --ipntr; /* Function Body */ if (*ido == 0) { /* %-------------------------------% | Initialize timing statistics | | & message level for debugging | %-------------------------------% */ igraphsecond_(&t0); msglvl = msaup2; /* %---------------------------------% | Set machine dependent constant. | %---------------------------------% */ eps23 = igraphdlamch_("Epsilon-Machine"); eps23 = pow_dd(&eps23, &c_b3); /* %-------------------------------------% | nev0 and np0 are integer variables | | hold the initial values of NEV & NP | %-------------------------------------% */ nev0 = *nev; np0 = *np; /* %-------------------------------------% | kplusp is the bound on the largest | | Lanczos factorization built. | | nconv is the current number of | | "converged" eigenvlues. | | iter is the counter on the current | | iteration step. | %-------------------------------------% */ kplusp = nev0 + np0; nconv = 0; iter = 0; /* %--------------------------------------------% | Set flags for computing the first NEV steps | | of the Lanczos factorization. | %--------------------------------------------% */ getv0 = TRUE_; update = FALSE_; ushift = FALSE_; cnorm = FALSE_; if (*info != 0) { /* %--------------------------------------------% | User provides the initial residual vector. | %--------------------------------------------% */ initv = TRUE_; *info = 0; } else { initv = FALSE_; } } /* %---------------------------------------------% | Get a possibly random starting vector and | | force it into the range of the operator OP. | %---------------------------------------------% L10: */ if (getv0) { igraphdgetv0_(ido, bmat, &c__1, &initv, n, &c__1, &v[v_offset], ldv, &resid[ 1], &rnorm, &ipntr[1], &workd[1], info); if (*ido != 99) { goto L9000; } if (rnorm == 0.) { /* %-----------------------------------------% | The initial vector is zero. Error exit. | %-----------------------------------------% */ *info = -9; goto L1200; } getv0 = FALSE_; *ido = 0; } /* %------------------------------------------------------------% | Back from reverse communication: continue with update step | %------------------------------------------------------------% */ if (update) { goto L20; } /* %-------------------------------------------% | Back from computing user specified shifts | %-------------------------------------------% */ if (ushift) { goto L50; } /* %-------------------------------------% | Back from computing residual norm | | at the end of the current iteration | %-------------------------------------% */ if (cnorm) { goto L100; } /* %----------------------------------------------------------% | Compute the first NEV steps of the Lanczos factorization | %----------------------------------------------------------% */ igraphdsaitr_(ido, bmat, n, &c__0, &nev0, mode, &resid[1], &rnorm, &v[v_offset], ldv, &h__[h_offset], ldh, &ipntr[1], &workd[1], info); /* %---------------------------------------------------% | ido .ne. 99 implies use of reverse communication | | to compute operations involving OP and possibly B | %---------------------------------------------------% */ if (*ido != 99) { goto L9000; } if (*info > 0) { /* %-----------------------------------------------------% | dsaitr was unable to build an Lanczos factorization | | of length NEV0. INFO is returned with the size of | | the factorization built. Exit main loop. | %-----------------------------------------------------% */ *np = *info; *mxiter = iter; *info = -9999; goto L1200; } /* %--------------------------------------------------------------% | | | M A I N LANCZOS I T E R A T I O N L O O P | | Each iteration implicitly restarts the Lanczos | | factorization in place. | | | %--------------------------------------------------------------% */ L1000: ++iter; if (msglvl > 0) { igraphivout_(&logfil, &c__1, &iter, &ndigit, "_saup2: **** Start of major " "iteration number ****", (ftnlen)49); } if (msglvl > 1) { igraphivout_(&logfil, &c__1, nev, &ndigit, "_saup2: The length of the curr" "ent Lanczos factorization", (ftnlen)55); igraphivout_(&logfil, &c__1, np, &ndigit, "_saup2: Extend the Lanczos fact" "orization by", (ftnlen)43); } /* %------------------------------------------------------------% | Compute NP additional steps of the Lanczos factorization. | %------------------------------------------------------------% */ *ido = 0; L20: update = TRUE_; igraphdsaitr_(ido, bmat, n, nev, np, mode, &resid[1], &rnorm, &v[v_offset], ldv, &h__[h_offset], ldh, &ipntr[1], &workd[1], info); /* %---------------------------------------------------% | ido .ne. 99 implies use of reverse communication | | to compute operations involving OP and possibly B | %---------------------------------------------------% */ if (*ido != 99) { goto L9000; } if (*info > 0) { /* %-----------------------------------------------------% | dsaitr was unable to build an Lanczos factorization | | of length NEV0+NP0. INFO is returned with the size | | of the factorization built. Exit main loop. | %-----------------------------------------------------% */ *np = *info; *mxiter = iter; *info = -9999; goto L1200; } update = FALSE_; if (msglvl > 1) { igraphdvout_(&logfil, &c__1, &rnorm, &ndigit, "_saup2: Current B-norm of r" "esidual for factorization", (ftnlen)52); } /* %--------------------------------------------------------% | Compute the eigenvalues and corresponding error bounds | | of the current symmetric tridiagonal matrix. | %--------------------------------------------------------% */ igraphdseigt_(&rnorm, &kplusp, &h__[h_offset], ldh, &ritz[1], &bounds[1], & workl[1], &ierr); if (ierr != 0) { *info = -8; goto L1200; } /* %----------------------------------------------------% | Make a copy of eigenvalues and corresponding error | | bounds obtained from _seigt. | %----------------------------------------------------% */ igraphdcopy_(&kplusp, &ritz[1], &c__1, &workl[kplusp + 1], &c__1); igraphdcopy_(&kplusp, &bounds[1], &c__1, &workl[(kplusp << 1) + 1], &c__1); /* %---------------------------------------------------% | Select the wanted Ritz values and their bounds | | to be used in the convergence test. | | The selection is based on the requested number of | | eigenvalues instead of the current NEV and NP to | | prevent possible misconvergence. | | * Wanted Ritz values := RITZ(NP+1:NEV+NP) | | * Shifts := RITZ(1:NP) := WORKL(1:NP) | %---------------------------------------------------% */ *nev = nev0; *np = np0; igraphdsgets_(ishift, which, nev, np, &ritz[1], &bounds[1], &workl[1]); /* %-------------------% | Convergence test. | %-------------------% */ igraphdcopy_(nev, &bounds[*np + 1], &c__1, &workl[*np + 1], &c__1); igraphdsconv_(nev, &ritz[*np + 1], &workl[*np + 1], tol, &nconv); if (msglvl > 2) { kp[0] = *nev; kp[1] = *np; kp[2] = nconv; igraphivout_(&logfil, &c__3, kp, &ndigit, "_saup2: NEV, NP, NCONV are", ( ftnlen)26); igraphdvout_(&logfil, &kplusp, &ritz[1], &ndigit, "_saup2: The eigenvalues" " of H", (ftnlen)28); igraphdvout_(&logfil, &kplusp, &bounds[1], &ndigit, "_saup2: Ritz estimate" "s of the current NCV Ritz values", (ftnlen)53); } /* %---------------------------------------------------------% | Count the number of unwanted Ritz values that have zero | | Ritz estimates. If any Ritz estimates are equal to zero | | then a leading block of H of order equal to at least | | the number of Ritz values with zero Ritz estimates has | | split off. None of these Ritz values may be removed by | | shifting. Decrease NP the number of shifts to apply. If | | no shifts may be applied, then prepare to exit | %---------------------------------------------------------% */ nptemp = *np; i__1 = nptemp; for (j = 1; j <= i__1; ++j) { if (bounds[j] == 0.) { --(*np); ++(*nev); } /* L30: */ } if (nconv >= nev0 || iter > *mxiter || *np == 0) { /* %------------------------------------------------% | Prepare to exit. Put the converged Ritz values | | and corresponding bounds in RITZ(1:NCONV) and | | BOUNDS(1:NCONV) respectively. Then sort. Be | | careful when NCONV > NP since we don't want to | | swap overlapping locations. | %------------------------------------------------% */ if (s_cmp(which, "BE", (ftnlen)2, (ftnlen)2) == 0) { /* %-----------------------------------------------------% | Both ends of the spectrum are requested. | | Sort the eigenvalues into algebraically decreasing | | order first then swap low end of the spectrum next | | to high end in appropriate locations. | | NOTE: when np < floor(nev/2) be careful not to swap | | overlapping locations. | %-----------------------------------------------------% */ s_copy(wprime, "SA", (ftnlen)2, (ftnlen)2); igraphdsortr_(wprime, &c_true, &kplusp, &ritz[1], &bounds[1]) ; nevd2 = *nev / 2; nevm2 = *nev - nevd2; if (*nev > 1) { i__1 = min(nevd2,*np); /* Computing MAX */ i__2 = kplusp - nevd2 + 1, i__3 = kplusp - *np + 1; igraphdswap_(&i__1, &ritz[nevm2 + 1], &c__1, &ritz[max(i__2,i__3)], &c__1); i__1 = min(nevd2,*np); /* Computing MAX */ i__2 = kplusp - nevd2 + 1, i__3 = kplusp - *np; igraphdswap_(&i__1, &bounds[nevm2 + 1], &c__1, &bounds[max(i__2, i__3) + 1], &c__1); } } else { /* %--------------------------------------------------% | LM, SM, LA, SA case. | | Sort the eigenvalues of H into the an order that | | is opposite to WHICH, and apply the resulting | | order to BOUNDS. The eigenvalues are sorted so | | that the wanted part are always within the first | | NEV locations. | %--------------------------------------------------% */ if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "SM", (ftnlen)2, (ftnlen)2); } if (s_cmp(which, "SM", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "LM", (ftnlen)2, (ftnlen)2); } if (s_cmp(which, "LA", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "SA", (ftnlen)2, (ftnlen)2); } if (s_cmp(which, "SA", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "LA", (ftnlen)2, (ftnlen)2); } igraphdsortr_(wprime, &c_true, &kplusp, &ritz[1], &bounds[1]) ; } /* %--------------------------------------------------% | Scale the Ritz estimate of each Ritz value | | by 1 / max(eps23,magnitude of the Ritz value). | %--------------------------------------------------% */ i__1 = nev0; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ d__2 = eps23, d__3 = (d__1 = ritz[j], abs(d__1)); temp = max(d__2,d__3); bounds[j] /= temp; /* L35: */ } /* %----------------------------------------------------% | Sort the Ritz values according to the scaled Ritz | | esitmates. This will push all the converged ones | | towards the front of ritzr, ritzi, bounds | | (in the case when NCONV < NEV.) | %----------------------------------------------------% */ s_copy(wprime, "LA", (ftnlen)2, (ftnlen)2); igraphdsortr_(wprime, &c_true, &nev0, &bounds[1], &ritz[1]); /* %----------------------------------------------% | Scale the Ritz estimate back to its original | | value. | %----------------------------------------------% */ i__1 = nev0; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ d__2 = eps23, d__3 = (d__1 = ritz[j], abs(d__1)); temp = max(d__2,d__3); bounds[j] *= temp; /* L40: */ } /* %--------------------------------------------------% | Sort the "converged" Ritz values again so that | | the "threshold" values and their associated Ritz | | estimates appear at the appropriate position in | | ritz and bound. | %--------------------------------------------------% */ if (s_cmp(which, "BE", (ftnlen)2, (ftnlen)2) == 0) { /* %------------------------------------------------% | Sort the "converged" Ritz values in increasing | | order. The "threshold" values are in the | | middle. | %------------------------------------------------% */ s_copy(wprime, "LA", (ftnlen)2, (ftnlen)2); igraphdsortr_(wprime, &c_true, &nconv, &ritz[1], &bounds[1]); } else { /* %----------------------------------------------% | In LM, SM, LA, SA case, sort the "converged" | | Ritz values according to WHICH so that the | | "threshold" value appears at the front of | | ritz. | %----------------------------------------------% */ igraphdsortr_(which, &c_true, &nconv, &ritz[1], &bounds[1]); } /* %------------------------------------------% | Use h( 1,1 ) as storage to communicate | | rnorm to _seupd if needed | %------------------------------------------% */ h__[h_dim1 + 1] = rnorm; if (msglvl > 1) { igraphdvout_(&logfil, &kplusp, &ritz[1], &ndigit, "_saup2: Sorted Ritz" " values.", (ftnlen)27); igraphdvout_(&logfil, &kplusp, &bounds[1], &ndigit, "_saup2: Sorted ri" "tz estimates.", (ftnlen)30); } /* %------------------------------------% | Max iterations have been exceeded. | %------------------------------------% */ if (iter > *mxiter && nconv < *nev) { *info = 1; } /* %---------------------% | No shifts to apply. | %---------------------% */ if (*np == 0 && nconv < nev0) { *info = 2; } *np = nconv; goto L1100; } else if (nconv < *nev && *ishift == 1) { /* %---------------------------------------------------% | Do not have all the requested eigenvalues yet. | | To prevent possible stagnation, adjust the number | | of Ritz values and the shifts. | %---------------------------------------------------% */ nevbef = *nev; /* Computing MIN */ i__1 = nconv, i__2 = *np / 2; *nev += min(i__1,i__2); if (*nev == 1 && kplusp >= 6) { *nev = kplusp / 2; } else if (*nev == 1 && kplusp > 2) { *nev = 2; } *np = kplusp - *nev; /* %---------------------------------------% | If the size of NEV was just increased | | resort the eigenvalues. | %---------------------------------------% */ if (nevbef < *nev) { igraphdsgets_(ishift, which, nev, np, &ritz[1], &bounds[1], &workl[1]); } } if (msglvl > 0) { igraphivout_(&logfil, &c__1, &nconv, &ndigit, "_saup2: no. of \"converge" "d\" Ritz values at this iter.", (ftnlen)52); if (msglvl > 1) { kp[0] = *nev; kp[1] = *np; igraphivout_(&logfil, &c__2, kp, &ndigit, "_saup2: NEV and NP are", ( ftnlen)22); igraphdvout_(&logfil, nev, &ritz[*np + 1], &ndigit, "_saup2: \"wante" "d\" Ritz values.", (ftnlen)29); igraphdvout_(&logfil, nev, &bounds[*np + 1], &ndigit, "_saup2: Ritz es" "timates of the \"wanted\" values ", (ftnlen)46); } } if (*ishift == 0) { /* %-----------------------------------------------------% | User specified shifts: reverse communication to | | compute the shifts. They are returned in the first | | NP locations of WORKL. | %-----------------------------------------------------% */ ushift = TRUE_; *ido = 3; goto L9000; } L50: /* %------------------------------------% | Back from reverse communication; | | User specified shifts are returned | | in WORKL(1:*NP) | %------------------------------------% */ ushift = FALSE_; /* %---------------------------------------------------------% | Move the NP shifts to the first NP locations of RITZ to | | free up WORKL. This is for the non-exact shift case; | | in the exact shift case, dsgets already handles this. | %---------------------------------------------------------% */ if (*ishift == 0) { igraphdcopy_(np, &workl[1], &c__1, &ritz[1], &c__1); } if (msglvl > 2) { igraphivout_(&logfil, &c__1, np, &ndigit, "_saup2: The number of shifts to" " apply ", (ftnlen)38); igraphdvout_(&logfil, np, &workl[1], &ndigit, "_saup2: shifts selected", ( ftnlen)23); if (*ishift == 1) { igraphdvout_(&logfil, np, &bounds[1], &ndigit, "_saup2: corresponding " "Ritz estimates", (ftnlen)36); } } /* %---------------------------------------------------------% | Apply the NP0 implicit shifts by QR bulge chasing. | | Each shift is applied to the entire tridiagonal matrix. | | The first 2*N locations of WORKD are used as workspace. | | After dsapps is done, we have a Lanczos | | factorization of length NEV. | %---------------------------------------------------------% */ igraphdsapps_(n, nev, np, &ritz[1], &v[v_offset], ldv, &h__[h_offset], ldh, & resid[1], &q[q_offset], ldq, &workd[1]); /* %---------------------------------------------% | Compute the B-norm of the updated residual. | | Keep B*RESID in WORKD(1:N) to be used in | | the first step of the next call to dsaitr. | %---------------------------------------------% */ cnorm = TRUE_; igraphsecond_(&t2); if (*(unsigned char *)bmat == 'G') { ++nbx; igraphdcopy_(n, &resid[1], &c__1, &workd[*n + 1], &c__1); ipntr[1] = *n + 1; ipntr[2] = 1; *ido = 2; /* %----------------------------------% | Exit in order to compute B*RESID | %----------------------------------% */ goto L9000; } else if (*(unsigned char *)bmat == 'I') { igraphdcopy_(n, &resid[1], &c__1, &workd[1], &c__1); } L100: /* %----------------------------------% | Back from reverse communication; | | WORKD(1:N) := B*RESID | %----------------------------------% */ if (*(unsigned char *)bmat == 'G') { igraphsecond_(&t3); tmvbx += t3 - t2; } if (*(unsigned char *)bmat == 'G') { rnorm = igraphddot_(n, &resid[1], &c__1, &workd[1], &c__1); rnorm = sqrt((abs(rnorm))); } else if (*(unsigned char *)bmat == 'I') { rnorm = igraphdnrm2_(n, &resid[1], &c__1); } cnorm = FALSE_; /* L130: */ if (msglvl > 2) { igraphdvout_(&logfil, &c__1, &rnorm, &ndigit, "_saup2: B-norm of residual " "for NEV factorization", (ftnlen)48); igraphdvout_(&logfil, nev, &h__[(h_dim1 << 1) + 1], &ndigit, "_saup2: main" " diagonal of compressed H matrix", (ftnlen)44); i__1 = *nev - 1; igraphdvout_(&logfil, &i__1, &h__[h_dim1 + 2], &ndigit, "_saup2: subdiagon" "al of compressed H matrix", (ftnlen)42); } goto L1000; /* %---------------------------------------------------------------% | | | E N D O F M A I N I T E R A T I O N L O O P | | | %---------------------------------------------------------------% */ L1100: *mxiter = iter; *nev = nconv; L1200: *ido = 99; /* %------------% | Error exit | %------------% */ igraphsecond_(&t1); tsaup2 = t1 - t0; L9000: return 0; /* %---------------% | End of dsaup2 | %---------------% */ } /* igraphdsaup2_ */
Subroutine */ int igraphdsaupd_(integer *ido, char *bmat, integer *n, char * which, integer *nev, doublereal *tol, doublereal *resid, integer *ncv, doublereal *v, integer *ldv, integer *iparam, integer *ipntr, doublereal *workd, doublereal *workl, integer *lworkl, integer *info) { /* Format strings */ static char fmt_1000[] = "(//,5x,\002===================================" "=======\002,/5x,\002= Symmetric implicit Arnoldi update code " "=\002,/5x,\002= Version Number:\002,\002 2.4\002,19x,\002 =\002," "/5x,\002= Version Date: \002,\002 07/31/96\002,14x,\002 =\002,/" "5x,\002==========================================\002,/5x,\002= " "Summary of timing statistics =\002,/5x,\002===========" "===============================\002,//)"; static char fmt_1100[] = "(5x,\002Total number update iterations " " = \002,i5,/5x,\002Total number of OP*x operations " " = \002,i5,/5x,\002Total number of B*x operations = " "\002,i5,/5x,\002Total number of reorthogonalization steps = " "\002,i5,/5x,\002Total number of iterative refinement steps = " "\002,i5,/5x,\002Total number of restart steps = " "\002,i5,/5x,\002Total time in user OP*x operation = " "\002,f12.6,/5x,\002Total time in user B*x operation =" " \002,f12.6,/5x,\002Total time in Arnoldi update routine = " "\002,f12.6,/5x,\002Total time in saup2 routine =" " \002,f12.6,/5x,\002Total time in basic Arnoldi iteration loop = " "\002,f12.6,/5x,\002Total time in reorthogonalization phase =" " \002,f12.6,/5x,\002Total time in (re)start vector generation = " "\002,f12.6,/5x,\002Total time in trid eigenvalue subproblem =" " \002,f12.6,/5x,\002Total time in getting the shifts = " "\002,f12.6,/5x,\002Total time in applying the shifts =" " \002,f12.6,/5x,\002Total time in convergence testing = " "\002,f12.6)"; /* System generated locals */ integer v_dim1, v_offset, i__1, i__2; /* Builtin functions */ integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), e_wsfe( void), do_fio(integer *, char *, ftnlen); /* Local variables */ integer j; real t0, t1; IGRAPH_F77_SAVE integer nb, ih, iq, np, iw, ldh, ldq; integer nbx; IGRAPH_F77_SAVE integer nev0, mode, ierr, iupd, next; integer nopx; IGRAPH_F77_SAVE integer ritz; real tmvbx; extern /* Subroutine */ int igraphdvout_(integer *, integer *, doublereal *, integer *, char *, ftnlen), igraphivout_(integer *, integer *, integer * , integer *, char *, ftnlen), igraphdsaup2_(integer *, char *, integer * , char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *); real tgetv0, tsaup2; extern doublereal igraphdlamch_(char *); extern /* Subroutine */ int igraphsecond_(real *); integer logfil=0, ndigit; IGRAPH_F77_SAVE integer ishift; integer nitref, msaupd=0; IGRAPH_F77_SAVE integer bounds; real titref, tseigt, tsaupd; extern /* Subroutine */ int igraphdstats_(void); IGRAPH_F77_SAVE integer msglvl; real tsaitr; IGRAPH_F77_SAVE integer mxiter; real tsgets, tsapps; integer nrorth; real tsconv; integer nrstrt; real tmvopx; /* Fortran I/O blocks */ static cilist io___28 = { 0, 6, 0, fmt_1000, 0 }; static cilist io___29 = { 0, 6, 0, fmt_1100, 0 }; /* %----------------------------------------------------% | Include files for debugging and timing information | %----------------------------------------------------% %------------------% | Scalar Arguments | %------------------% %-----------------% | Array Arguments | %-----------------% %------------% | Parameters | %------------% %---------------% | Local Scalars | %---------------% %----------------------% | External Subroutines | %----------------------% %--------------------% | External Functions | %--------------------% %-----------------------% | Executable Statements | %-----------------------% Parameter adjustments */ --workd; --resid; v_dim1 = *ldv; v_offset = 1 + v_dim1; v -= v_offset; --iparam; --ipntr; --workl; /* Function Body */ if (*ido == 0) { /* %-------------------------------% | Initialize timing statistics | | & message level for debugging | %-------------------------------% */ igraphdstats_(); igraphsecond_(&t0); msglvl = msaupd; ierr = 0; ishift = iparam[1]; mxiter = iparam[3]; nb = iparam[4]; /* %--------------------------------------------% | Revision 2 performs only implicit restart. | %--------------------------------------------% */ iupd = 1; mode = iparam[7]; /* %----------------% | Error checking | %----------------% */ if (*n <= 0) { ierr = -1; } else if (*nev <= 0) { ierr = -2; } else if (*ncv <= *nev || *ncv > *n) { ierr = -3; } /* %----------------------------------------------% | NP is the number of additional steps to | | extend the length NEV Lanczos factorization. | %----------------------------------------------% */ np = *ncv - *nev; if (mxiter <= 0) { ierr = -4; } if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "SM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "LA", ( ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "SA", (ftnlen)2, ( ftnlen)2) != 0 && s_cmp(which, "BE", (ftnlen)2, (ftnlen)2) != 0) { ierr = -5; } if (*(unsigned char *)bmat != 'I' && *(unsigned char *)bmat != 'G') { ierr = -6; } /* Computing 2nd power */ i__1 = *ncv; if (*lworkl < i__1 * i__1 + (*ncv << 3)) { ierr = -7; } if (mode < 1 || mode > 5) { ierr = -10; } else if (mode == 1 && *(unsigned char *)bmat == 'G') { ierr = -11; } else if (ishift < 0 || ishift > 1) { ierr = -12; } else if (*nev == 1 && s_cmp(which, "BE", (ftnlen)2, (ftnlen)2) == 0) { ierr = -13; } /* %------------% | Error Exit | %------------% */ if (ierr != 0) { *info = ierr; *ido = 99; goto L9000; } /* %------------------------% | Set default parameters | %------------------------% */ if (nb <= 0) { nb = 1; } if (*tol <= 0.) { *tol = igraphdlamch_("EpsMach"); } /* %----------------------------------------------% | NP is the number of additional steps to | | extend the length NEV Lanczos factorization. | | NEV0 is the local variable designating the | | size of the invariant subspace desired. | %----------------------------------------------% */ np = *ncv - *nev; nev0 = *nev; /* %-----------------------------% | Zero out internal workspace | %-----------------------------% Computing 2nd power */ i__2 = *ncv; i__1 = i__2 * i__2 + (*ncv << 3); for (j = 1; j <= i__1; ++j) { workl[j] = 0.; /* L10: */ } /* %-------------------------------------------------------% | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | | etc... and the remaining workspace. | | Also update pointer to be used on output. | | Memory is laid out as follows: | | workl(1:2*ncv) := generated tridiagonal matrix | | workl(2*ncv+1:2*ncv+ncv) := ritz values | | workl(3*ncv+1:3*ncv+ncv) := computed error bounds | | workl(4*ncv+1:4*ncv+ncv*ncv) := rotation matrix Q | | workl(4*ncv+ncv*ncv+1:7*ncv+ncv*ncv) := workspace | %-------------------------------------------------------% */ ldh = *ncv; ldq = *ncv; ih = 1; ritz = ih + (ldh << 1); bounds = ritz + *ncv; iq = bounds + *ncv; /* Computing 2nd power */ i__1 = *ncv; iw = iq + i__1 * i__1; next = iw + *ncv * 3; ipntr[4] = next; ipntr[5] = ih; ipntr[6] = ritz; ipntr[7] = bounds; ipntr[11] = iw; } /* %-------------------------------------------------------% | Carry out the Implicitly restarted Lanczos Iteration. | %-------------------------------------------------------% */ igraphdsaup2_(ido, bmat, n, which, &nev0, &np, tol, &resid[1], &mode, &iupd, & ishift, &mxiter, &v[v_offset], ldv, &workl[ih], &ldh, &workl[ritz] , &workl[bounds], &workl[iq], &ldq, &workl[iw], &ipntr[1], &workd[ 1], info); /* %--------------------------------------------------% | ido .ne. 99 implies use of reverse communication | | to compute operations involving OP or shifts. | %--------------------------------------------------% */ if (*ido == 3) { iparam[8] = np; } if (*ido != 99) { goto L9000; } iparam[3] = mxiter; iparam[5] = np; iparam[9] = nopx; iparam[10] = nbx; iparam[11] = nrorth; /* %------------------------------------% | Exit if there was an informational | | error within dsaup2. | %------------------------------------% */ if (*info < 0) { goto L9000; } if (*info == 2) { *info = 3; } if (msglvl > 0) { igraphivout_(&logfil, &c__1, &mxiter, &ndigit, "_saupd: number of update i" "terations taken", (ftnlen)41); igraphivout_(&logfil, &c__1, &np, &ndigit, "_saupd: number of \"converge" "d\" Ritz values", (ftnlen)41); igraphdvout_(&logfil, &np, &workl[ritz], &ndigit, "_saupd: final Ritz valu" "es", (ftnlen)25); igraphdvout_(&logfil, &np, &workl[bounds], &ndigit, "_saupd: corresponding" " error bounds", (ftnlen)34); } igraphsecond_(&t1); tsaupd = t1 - t0; if (msglvl > 0) { /* %--------------------------------------------------------% | Version Number & Version Date are defined in version.h | %--------------------------------------------------------% */ s_wsfe(&io___28); e_wsfe(); s_wsfe(&io___29); do_fio(&c__1, (char *)&mxiter, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&nopx, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&nbx, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&nrorth, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&nitref, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&nrstrt, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&tmvopx, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&tmvbx, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&tsaupd, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&tsaup2, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&tsaitr, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&titref, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&tgetv0, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&tseigt, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&tsgets, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&tsapps, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&tsconv, (ftnlen)sizeof(real)); e_wsfe(); } L9000: return 0; /* %---------------% | End of dsaupd | %---------------% */ } /* igraphdsaupd_ */
/* ----------------------------------------------------------------------- */ /* Subroutine */ int igraphdseupd_(logical *rvec, char *howmny, logical * select, doublereal *d__, doublereal *z__, integer *ldz, doublereal * sigma, char *bmat, integer *n, char *which, integer *nev, doublereal * tol, doublereal *resid, integer *ncv, doublereal *v, integer *ldv, integer *iparam, integer *ipntr, doublereal *workd, doublereal *workl, integer *lworkl, integer *info) { /* System generated locals */ integer v_dim1, v_offset, z_dim1, z_offset, i__1; doublereal d__1, d__2, d__3; /* Builtin functions */ integer igraphs_cmp(char *, char *, ftnlen, ftnlen); /* Subroutine */ int igraphs_copy(char *, char *, ftnlen, ftnlen); double igraphpow_dd(doublereal *, doublereal *); /* Local variables */ static integer j, k, ih, jj, iq, np, iw; extern /* Subroutine */ int igraphdger_(integer *, integer *, doublereal * , doublereal *, integer *, doublereal *, integer *, doublereal *, integer *); static integer ibd, ihb, ihd, ldh; extern doublereal igraphdnrm2_(integer *, doublereal *, integer *); static integer ldq, irz; extern /* Subroutine */ int igraphdscal_(integer *, doublereal *, doublereal *, integer *), igraphdcopy_(integer *, doublereal *, integer *, doublereal *, integer *), igraphdvout_(integer *, integer *, doublereal *, integer *, char *), igraphivout_( integer *, integer *, integer *, integer *, char *), igraphdgeqr2_(integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *); static integer mode; static doublereal eps23; extern /* Subroutine */ int igraphdorm2r_(char *, char *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *); static integer ierr; static doublereal temp; static integer next; static char type__[6]; extern doublereal igraphdlamch_(char *); static integer ritz; extern /* Subroutine */ int igraphdlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *), igraphdsgets_(integer *, char *, integer *, integer *, doublereal *, doublereal *, doublereal *); static doublereal temp1; extern /* Subroutine */ int igraphdsteqr_(char *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *), igraphdsesrt_(char *, logical *, integer *, doublereal *, integer *, doublereal *, integer *), igraphdsortr_(char * , logical *, integer *, doublereal *, doublereal *); static logical reord; static integer nconv; static doublereal rnorm, bnorm2; static integer bounds, msglvl, ishift, numcnv, leftptr, rghtptr; /* %----------------------------------------------------% */ /* | Include files for debugging and timing information | */ /* %----------------------------------------------------% */ /* \SCCS Information: @(#) */ /* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */ /* %---------------------------------% */ /* | See debug.doc for documentation | */ /* %---------------------------------% */ /* %------------------% */ /* | Scalar Arguments | */ /* %------------------% */ /* %--------------------------------% */ /* | See stat.doc for documentation | */ /* %--------------------------------% */ /* \SCCS Information: @(#) */ /* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */ /* %-----------------% */ /* | Array Arguments | */ /* %-----------------% */ /* %------------% */ /* | Parameters | */ /* %------------% */ /* %---------------% */ /* | Local Scalars | */ /* %---------------% */ /* %----------------------% */ /* | External Subroutines | */ /* %----------------------% */ /* %--------------------% */ /* | External Functions | */ /* %--------------------% */ /* %---------------------% */ /* | Intrinsic Functions | */ /* %---------------------% */ /* %-----------------------% */ /* | Executable Statements | */ /* %-----------------------% */ /* %------------------------% */ /* | Set default parameters | */ /* %------------------------% */ /* Parameter adjustments */ --workd; --resid; z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --d__; --select; v_dim1 = *ldv; v_offset = 1 + v_dim1; v -= v_offset; --iparam; --ipntr; --workl; /* Function Body */ msglvl = debug_1.mseupd; mode = iparam[7]; nconv = iparam[5]; *info = 0; /* %--------------% */ /* | Quick return | */ /* %--------------% */ if (nconv == 0) { goto L9000; } ierr = 0; if (nconv <= 0) { ierr = -14; } if (*n <= 0) { ierr = -1; } if (*nev <= 0) { ierr = -2; } if (*ncv <= *nev || *ncv > *n) { ierr = -3; } if (igraphs_cmp(which, "LM", (ftnlen)2, (ftnlen)2) != 0 && igraphs_cmp(which, "SM", ( ftnlen)2, (ftnlen)2) != 0 && igraphs_cmp(which, "LA", (ftnlen)2, ( ftnlen)2) != 0 && igraphs_cmp(which, "SA", (ftnlen)2, (ftnlen)2) != 0 && igraphs_cmp(which, "BE", (ftnlen)2, (ftnlen)2) != 0) { ierr = -5; } if (*(unsigned char *)bmat != 'I' && *(unsigned char *)bmat != 'G') { ierr = -6; } if (*(unsigned char *)howmny != 'A' && *(unsigned char *)howmny != 'P' && *(unsigned char *)howmny != 'S' && *rvec) { ierr = -15; } if (*rvec && *(unsigned char *)howmny == 'S') { ierr = -16; } /* Computing 2nd power */ i__1 = *ncv; if (*rvec && *lworkl < i__1 * i__1 + (*ncv << 3)) { ierr = -7; } if (mode == 1 || mode == 2) { igraphs_copy(type__, "REGULR", (ftnlen)6, (ftnlen)6); } else if (mode == 3) { igraphs_copy(type__, "SHIFTI", (ftnlen)6, (ftnlen)6); } else if (mode == 4) { igraphs_copy(type__, "BUCKLE", (ftnlen)6, (ftnlen)6); } else if (mode == 5) { igraphs_copy(type__, "CAYLEY", (ftnlen)6, (ftnlen)6); } else { ierr = -10; } if (mode == 1 && *(unsigned char *)bmat == 'G') { ierr = -11; } if (*nev == 1 && igraphs_cmp(which, "BE", (ftnlen)2, (ftnlen)2) == 0) { ierr = -12; } /* %------------% */ /* | Error Exit | */ /* %------------% */ if (ierr != 0) { *info = ierr; goto L9000; } /* %-------------------------------------------------------% */ /* | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | */ /* | etc... and the remaining workspace. | */ /* | Also update pointer to be used on output. | */ /* | Memory is laid out as follows: | */ /* | workl(1:2*ncv) := generated tridiagonal matrix H | */ /* | The subdiagonal is stored in workl(2:ncv). | */ /* | The dead spot is workl(1) but upon exiting | */ /* | dsaupd stores the B-norm of the last residual | */ /* | vector in workl(1). We use this !!! | */ /* | workl(2*ncv+1:2*ncv+ncv) := ritz values | */ /* | The wanted values are in the first NCONV spots. | */ /* | workl(3*ncv+1:3*ncv+ncv) := computed Ritz estimates | */ /* | The wanted values are in the first NCONV spots. | */ /* | NOTE: workl(1:4*ncv) is set by dsaupd and is not | */ /* | modified by dseupd . | */ /* %-------------------------------------------------------% */ /* %-------------------------------------------------------% */ /* | The following is used and set by dseupd . | */ /* | workl(4*ncv+1:4*ncv+ncv) := used as workspace during | */ /* | computation of the eigenvectors of H. Stores | */ /* | the diagonal of H. Upon EXIT contains the NCV | */ /* | Ritz values of the original system. The first | */ /* | NCONV spots have the wanted values. If MODE = | */ /* | 1 or 2 then will equal workl(2*ncv+1:3*ncv). | */ /* | workl(5*ncv+1:5*ncv+ncv) := used as workspace during | */ /* | computation of the eigenvectors of H. Stores | */ /* | the subdiagonal of H. Upon EXIT contains the | */ /* | NCV corresponding Ritz estimates of the | */ /* | original system. The first NCONV spots have the | */ /* | wanted values. If MODE = 1,2 then will equal | */ /* | workl(3*ncv+1:4*ncv). | */ /* | workl(6*ncv+1:6*ncv+ncv*ncv) := orthogonal Q that is | */ /* | the eigenvector matrix for H as returned by | */ /* | dsteqr . Not referenced if RVEC = .False. | */ /* | Ordering follows that of workl(4*ncv+1:5*ncv) | */ /* | workl(6*ncv+ncv*ncv+1:6*ncv+ncv*ncv+2*ncv) := | */ /* | Workspace. Needed by dsteqr and by dseupd . | */ /* | GRAND total of NCV*(NCV+8) locations. | */ /* %-------------------------------------------------------% */ ih = ipntr[5]; ritz = ipntr[6]; bounds = ipntr[7]; ldh = *ncv; ldq = *ncv; ihd = bounds + ldh; ihb = ihd + ldh; iq = ihb + ldh; iw = iq + ldh * *ncv; next = iw + (*ncv << 1); ipntr[4] = next; ipntr[8] = ihd; ipntr[9] = ihb; ipntr[10] = iq; /* %----------------------------------------% */ /* | irz points to the Ritz values computed | */ /* | by _seigt before exiting _saup2. | */ /* | ibd points to the Ritz estimates | */ /* | computed by _seigt before exiting | */ /* | _saup2. | */ /* %----------------------------------------% */ irz = ipntr[11] + *ncv; ibd = irz + *ncv; /* %---------------------------------% */ /* | Set machine dependent constant. | */ /* %---------------------------------% */ eps23 = igraphdlamch_("Epsilon-Machine"); eps23 = igraphpow_dd(&eps23, &c_b21); /* %---------------------------------------% */ /* | RNORM is B-norm of the RESID(1:N). | */ /* | BNORM2 is the 2 norm of B*RESID(1:N). | */ /* | Upon exit of dsaupd WORKD(1:N) has | */ /* | B*RESID(1:N). | */ /* %---------------------------------------% */ rnorm = workl[ih]; if (*(unsigned char *)bmat == 'I') { bnorm2 = rnorm; } else if (*(unsigned char *)bmat == 'G') { bnorm2 = igraphdnrm2_(n, &workd[1], &c__1); } if (msglvl > 2) { igraphdvout_(&debug_1.logfil, ncv, &workl[irz], &debug_1.ndigit, "_seupd: Ritz values passed in from _SAUPD."); igraphdvout_(&debug_1.logfil, ncv, &workl[ibd], &debug_1.ndigit, "_seupd: Ritz estimates passed in from _SAUPD."); } if (*rvec) { reord = FALSE_; /* %---------------------------------------------------% */ /* | Use the temporary bounds array to store indices | */ /* | These will be used to mark the select array later | */ /* %---------------------------------------------------% */ i__1 = *ncv; for (j = 1; j <= i__1; ++j) { workl[bounds + j - 1] = (doublereal) j; select[j] = FALSE_; /* L10: */ } /* %-------------------------------------% */ /* | Select the wanted Ritz values. | */ /* | Sort the Ritz values so that the | */ /* | wanted ones appear at the tailing | */ /* | NEV positions of workl(irr) and | */ /* | workl(iri). Move the corresponding | */ /* | error estimates in workl(bound) | */ /* | accordingly. | */ /* %-------------------------------------% */ np = *ncv - *nev; ishift = 0; igraphdsgets_(&ishift, which, nev, &np, &workl[irz], &workl[bounds], & workl[1]); if (msglvl > 2) { igraphdvout_(&debug_1.logfil, ncv, &workl[irz], &debug_1.ndigit, "_seupd: Ritz values after calling _SGETS."); igraphdvout_(&debug_1.logfil, ncv, &workl[bounds], & debug_1.ndigit, "_seupd: Ritz value indices after callin" "g _SGETS."); } /* %-----------------------------------------------------% */ /* | Record indices of the converged wanted Ritz values | */ /* | Mark the select array for possible reordering | */ /* %-----------------------------------------------------% */ numcnv = 0; i__1 = *ncv; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ d__2 = eps23, d__3 = (d__1 = workl[irz + *ncv - j], abs(d__1)); temp1 = max(d__2,d__3); jj = (integer) workl[bounds + *ncv - j]; if (numcnv < nconv && workl[ibd + jj - 1] <= *tol * temp1) { select[jj] = TRUE_; ++numcnv; if (jj > *nev) { reord = TRUE_; } } /* L11: */ } /* %-----------------------------------------------------------% */ /* | Check the count (numcnv) of converged Ritz values with | */ /* | the number (nconv) reported by _saupd. If these two | */ /* | are different then there has probably been an error | */ /* | caused by incorrect passing of the _saupd data. | */ /* %-----------------------------------------------------------% */ if (msglvl > 2) { igraphivout_(&debug_1.logfil, &c__1, &numcnv, &debug_1.ndigit, "_seupd: Number of specified eigenvalues"); igraphivout_(&debug_1.logfil, &c__1, &nconv, &debug_1.ndigit, "_seupd: Number of \"converged\" eigenvalues") ; } if (numcnv != nconv) { *info = -17; goto L9000; } /* %-----------------------------------------------------------% */ /* | Call LAPACK routine _steqr to compute the eigenvalues and | */ /* | eigenvectors of the final symmetric tridiagonal matrix H. | */ /* | Initialize the eigenvector matrix Q to the identity. | */ /* %-----------------------------------------------------------% */ i__1 = *ncv - 1; igraphdcopy_(&i__1, &workl[ih + 1], &c__1, &workl[ihb], &c__1); igraphdcopy_(ncv, &workl[ih + ldh], &c__1, &workl[ihd], &c__1); igraphdsteqr_("Identity", ncv, &workl[ihd], &workl[ihb], &workl[iq], & ldq, &workl[iw], &ierr); if (ierr != 0) { *info = -8; goto L9000; } if (msglvl > 1) { igraphdcopy_(ncv, &workl[iq + *ncv - 1], &ldq, &workl[iw], &c__1); igraphdvout_(&debug_1.logfil, ncv, &workl[ihd], &debug_1.ndigit, "_seupd: NCV Ritz values of the final H matrix"); igraphdvout_(&debug_1.logfil, ncv, &workl[iw], &debug_1.ndigit, "_seupd: last row of the eigenvector matrix for H"); } if (reord) { /* %---------------------------------------------% */ /* | Reordered the eigenvalues and eigenvectors | */ /* | computed by _steqr so that the "converged" | */ /* | eigenvalues appear in the first NCONV | */ /* | positions of workl(ihd), and the associated | */ /* | eigenvectors appear in the first NCONV | */ /* | columns. | */ /* %---------------------------------------------% */ leftptr = 1; rghtptr = *ncv; if (*ncv == 1) { goto L30; } L20: if (select[leftptr]) { /* %-------------------------------------------% */ /* | Search, from the left, for the first Ritz | */ /* | value that has not converged. | */ /* %-------------------------------------------% */ ++leftptr; } else if (! select[rghtptr]) { /* %----------------------------------------------% */ /* | Search, from the right, the first Ritz value | */ /* | that has converged. | */ /* %----------------------------------------------% */ --rghtptr; } else { /* %----------------------------------------------% */ /* | Swap the Ritz value on the left that has not | */ /* | converged with the Ritz value on the right | */ /* | that has converged. Swap the associated | */ /* | eigenvector of the tridiagonal matrix H as | */ /* | well. | */ /* %----------------------------------------------% */ temp = workl[ihd + leftptr - 1]; workl[ihd + leftptr - 1] = workl[ihd + rghtptr - 1]; workl[ihd + rghtptr - 1] = temp; igraphdcopy_(ncv, &workl[iq + *ncv * (leftptr - 1)], &c__1, & workl[iw], &c__1); igraphdcopy_(ncv, &workl[iq + *ncv * (rghtptr - 1)], &c__1, & workl[iq + *ncv * (leftptr - 1)], &c__1); igraphdcopy_(ncv, &workl[iw], &c__1, &workl[iq + *ncv * ( rghtptr - 1)], &c__1); ++leftptr; --rghtptr; } if (leftptr < rghtptr) { goto L20; } L30: ; } if (msglvl > 2) { igraphdvout_(&debug_1.logfil, ncv, &workl[ihd], &debug_1.ndigit, "_seupd: The eigenvalues of H--reordered"); } /* %----------------------------------------% */ /* | Load the converged Ritz values into D. | */ /* %----------------------------------------% */ igraphdcopy_(&nconv, &workl[ihd], &c__1, &d__[1], &c__1); } else { /* %-----------------------------------------------------% */ /* | Ritz vectors not required. Load Ritz values into D. | */ /* %-----------------------------------------------------% */ igraphdcopy_(&nconv, &workl[ritz], &c__1, &d__[1], &c__1); igraphdcopy_(ncv, &workl[ritz], &c__1, &workl[ihd], &c__1); } /* %------------------------------------------------------------------% */ /* | Transform the Ritz values and possibly vectors and corresponding | */ /* | Ritz estimates of OP to those of A*x=lambda*B*x. The Ritz values | */ /* | (and corresponding data) are returned in ascending order. | */ /* %------------------------------------------------------------------% */ if (igraphs_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) { /* %---------------------------------------------------------% */ /* | Ascending sort of wanted Ritz values, vectors and error | */ /* | bounds. Not necessary if only Ritz values are desired. | */ /* %---------------------------------------------------------% */ if (*rvec) { igraphdsesrt_("LA", rvec, &nconv, &d__[1], ncv, &workl[iq], &ldq); } else { igraphdcopy_(ncv, &workl[bounds], &c__1, &workl[ihb], &c__1); } } else { /* %-------------------------------------------------------------% */ /* | * Make a copy of all the Ritz values. | */ /* | * Transform the Ritz values back to the original system. | */ /* | For TYPE = 'SHIFTI' the transformation is | */ /* | lambda = 1/theta + sigma | */ /* | For TYPE = 'BUCKLE' the transformation is | */ /* | lambda = sigma * theta / ( theta - 1 ) | */ /* | For TYPE = 'CAYLEY' the transformation is | */ /* | lambda = sigma * (theta + 1) / (theta - 1 ) | */ /* | where the theta are the Ritz values returned by dsaupd . | */ /* | NOTES: | */ /* | *The Ritz vectors are not affected by the transformation. | */ /* | They are only reordered. | */ /* %-------------------------------------------------------------% */ igraphdcopy_(ncv, &workl[ihd], &c__1, &workl[iw], &c__1); if (igraphs_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) { i__1 = *ncv; for (k = 1; k <= i__1; ++k) { workl[ihd + k - 1] = 1. / workl[ihd + k - 1] + *sigma; /* L40: */ } } else if (igraphs_cmp(type__, "BUCKLE", (ftnlen)6, (ftnlen)6) == 0) { i__1 = *ncv; for (k = 1; k <= i__1; ++k) { workl[ihd + k - 1] = *sigma * workl[ihd + k - 1] / (workl[ihd + k - 1] - 1.); /* L50: */ } } else if (igraphs_cmp(type__, "CAYLEY", (ftnlen)6, (ftnlen)6) == 0) { i__1 = *ncv; for (k = 1; k <= i__1; ++k) { workl[ihd + k - 1] = *sigma * (workl[ihd + k - 1] + 1.) / ( workl[ihd + k - 1] - 1.); /* L60: */ } } /* %-------------------------------------------------------------% */ /* | * Store the wanted NCONV lambda values into D. | */ /* | * Sort the NCONV wanted lambda in WORKL(IHD:IHD+NCONV-1) | */ /* | into ascending order and apply sort to the NCONV theta | */ /* | values in the transformed system. We will need this to | */ /* | compute Ritz estimates in the original system. | */ /* | * Finally sort the lambda`s into ascending order and apply | */ /* | to Ritz vectors if wanted. Else just sort lambda`s into | */ /* | ascending order. | */ /* | NOTES: | */ /* | *workl(iw:iw+ncv-1) contain the theta ordered so that they | */ /* | match the ordering of the lambda. We`ll use them again for | */ /* | Ritz vector purification. | */ /* %-------------------------------------------------------------% */ igraphdcopy_(&nconv, &workl[ihd], &c__1, &d__[1], &c__1); igraphdsortr_("LA", &c_true, &nconv, &workl[ihd], &workl[iw]); if (*rvec) { igraphdsesrt_("LA", rvec, &nconv, &d__[1], ncv, &workl[iq], &ldq); } else { igraphdcopy_(ncv, &workl[bounds], &c__1, &workl[ihb], &c__1); d__1 = bnorm2 / rnorm; igraphdscal_(ncv, &d__1, &workl[ihb], &c__1); igraphdsortr_("LA", &c_true, &nconv, &d__[1], &workl[ihb]); } } /* %------------------------------------------------% */ /* | Compute the Ritz vectors. Transform the wanted | */ /* | eigenvectors of the symmetric tridiagonal H by | */ /* | the Lanczos basis matrix V. | */ /* %------------------------------------------------% */ if (*rvec && *(unsigned char *)howmny == 'A') { /* %----------------------------------------------------------% */ /* | Compute the QR factorization of the matrix representing | */ /* | the wanted invariant subspace located in the first NCONV | */ /* | columns of workl(iq,ldq). | */ /* %----------------------------------------------------------% */ igraphdgeqr2_(ncv, &nconv, &workl[iq], &ldq, &workl[iw + *ncv], & workl[ihb], &ierr); /* %--------------------------------------------------------% */ /* | * Postmultiply V by Q. | */ /* | * Copy the first NCONV columns of VQ into Z. | */ /* | The N by NCONV matrix Z is now a matrix representation | */ /* | of the approximate invariant subspace associated with | */ /* | the Ritz values in workl(ihd). | */ /* %--------------------------------------------------------% */ igraphdorm2r_("Right", "Notranspose", n, ncv, &nconv, &workl[iq], & ldq, &workl[iw + *ncv], &v[v_offset], ldv, &workd[*n + 1], & ierr); igraphdlacpy_("All", n, &nconv, &v[v_offset], ldv, &z__[z_offset], ldz); /* %-----------------------------------------------------% */ /* | In order to compute the Ritz estimates for the Ritz | */ /* | values in both systems, need the last row of the | */ /* | eigenvector matrix. Remember, it`s in factored form | */ /* %-----------------------------------------------------% */ i__1 = *ncv - 1; for (j = 1; j <= i__1; ++j) { workl[ihb + j - 1] = 0.; /* L65: */ } workl[ihb + *ncv - 1] = 1.; igraphdorm2r_("Left", "Transpose", ncv, &c__1, &nconv, &workl[iq], & ldq, &workl[iw + *ncv], &workl[ihb], ncv, &temp, &ierr); } else if (*rvec && *(unsigned char *)howmny == 'S') { /* Not yet implemented. See remark 2 above. */ } if (igraphs_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0 && *rvec) { i__1 = *ncv; for (j = 1; j <= i__1; ++j) { workl[ihb + j - 1] = rnorm * (d__1 = workl[ihb + j - 1], abs(d__1) ); /* L70: */ } } else if (igraphs_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) != 0 && *rvec) { /* %-------------------------------------------------% */ /* | * Determine Ritz estimates of the theta. | */ /* | If RVEC = .true. then compute Ritz estimates | */ /* | of the theta. | */ /* | If RVEC = .false. then copy Ritz estimates | */ /* | as computed by dsaupd . | */ /* | * Determine Ritz estimates of the lambda. | */ /* %-------------------------------------------------% */ igraphdscal_(ncv, &bnorm2, &workl[ihb], &c__1); if (igraphs_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) { i__1 = *ncv; for (k = 1; k <= i__1; ++k) { /* Computing 2nd power */ d__2 = workl[iw + k - 1]; workl[ihb + k - 1] = (d__1 = workl[ihb + k - 1], abs(d__1)) / (d__2 * d__2); /* L80: */ } } else if (igraphs_cmp(type__, "BUCKLE", (ftnlen)6, (ftnlen)6) == 0) { i__1 = *ncv; for (k = 1; k <= i__1; ++k) { /* Computing 2nd power */ d__2 = workl[iw + k - 1] - 1.; workl[ihb + k - 1] = *sigma * (d__1 = workl[ihb + k - 1], abs( d__1)) / (d__2 * d__2); /* L90: */ } } else if (igraphs_cmp(type__, "CAYLEY", (ftnlen)6, (ftnlen)6) == 0) { i__1 = *ncv; for (k = 1; k <= i__1; ++k) { workl[ihb + k - 1] = (d__1 = workl[ihb + k - 1] / workl[iw + k - 1] * (workl[iw + k - 1] - 1.), abs(d__1)); /* L100: */ } } } if (igraphs_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) != 0 && msglvl > 1) { igraphdvout_(&debug_1.logfil, &nconv, &d__[1], &debug_1.ndigit, "_se" "upd: Untransformed converged Ritz values"); igraphdvout_(&debug_1.logfil, &nconv, &workl[ihb], &debug_1.ndigit, "_seupd: Ritz estimates of the untransformed Ritz values"); } else if (msglvl > 1) { igraphdvout_(&debug_1.logfil, &nconv, &d__[1], &debug_1.ndigit, "_se" "upd: Converged Ritz values"); igraphdvout_(&debug_1.logfil, &nconv, &workl[ihb], &debug_1.ndigit, "_seupd: Associated Ritz estimates"); } /* %-------------------------------------------------% */ /* | Ritz vector purification step. Formally perform | */ /* | one of inverse subspace iteration. Only used | */ /* | for MODE = 3,4,5. See reference 7 | */ /* %-------------------------------------------------% */ if (*rvec && (igraphs_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0 || igraphs_cmp( type__, "CAYLEY", (ftnlen)6, (ftnlen)6) == 0)) { i__1 = nconv - 1; for (k = 0; k <= i__1; ++k) { workl[iw + k] = workl[iq + k * ldq + *ncv - 1] / workl[iw + k]; /* L110: */ } } else if (*rvec && igraphs_cmp(type__, "BUCKLE", (ftnlen)6, (ftnlen)6) == 0) { i__1 = nconv - 1; for (k = 0; k <= i__1; ++k) { workl[iw + k] = workl[iq + k * ldq + *ncv - 1] / (workl[iw + k] - 1.); /* L120: */ } } if (igraphs_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) != 0) { igraphdger_(n, &nconv, &c_b110, &resid[1], &c__1, &workl[iw], &c__1, & z__[z_offset], ldz); } L9000: return 0; /* %---------------% */ /* | End of dseupd | */ /* %---------------% */ } /* igraphdseupd_ */
Subroutine */ int igraphdseupd_(logical *rvec, char *howmny, logical *select, doublereal *d__, doublereal *z__, integer *ldz, doublereal *sigma, char *bmat, integer *n, char *which, integer *nev, doublereal *tol, doublereal *resid, integer *ncv, doublereal *v, integer *ldv, integer *iparam, integer *ipntr, doublereal *workd, doublereal *workl, integer *lworkl, integer *info) { /* System generated locals */ integer v_dim1, v_offset, z_dim1, z_offset, i__1; doublereal d__1, d__2, d__3; /* Builtin functions */ integer s_cmp(char *, char *, ftnlen, ftnlen); /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); double pow_dd(doublereal *, doublereal *); /* Local variables */ integer j, k, ih, iq, iw; doublereal kv[2]; integer ibd, ihb, ihd, ldh, ilg, ldq, ism, irz; extern /* Subroutine */ int igraphdger_(integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *); integer mode; doublereal eps23; integer ierr; doublereal temp; integer next; char type__[6]; integer ritz; extern doublereal igraphdnrm2_(integer *, doublereal *, integer *); extern /* Subroutine */ int igraphdscal_(integer *, doublereal *, doublereal *, integer *); logical reord; extern /* Subroutine */ int igraphdcopy_(integer *, doublereal *, integer *, doublereal *, integer *); integer nconv; doublereal rnorm; extern /* Subroutine */ int igraphdvout_(integer *, integer *, doublereal *, integer *, char *, ftnlen), igraphivout_(integer *, integer *, integer * , integer *, char *, ftnlen), igraphdgeqr2_(integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *); doublereal bnorm2; extern /* Subroutine */ int igraphdorm2r_(char *, char *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *); doublereal thres1, thres2; extern doublereal igraphdlamch_(char *); extern /* Subroutine */ int igraphdlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *); integer logfil, ndigit, bounds, mseupd = 0; extern /* Subroutine */ int igraphdsteqr_(char *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *); integer msglvl, ktrord; extern /* Subroutine */ int igraphdsesrt_(char *, logical *, integer *, doublereal *, integer *, doublereal *, integer *), igraphdsortr_(char *, logical *, integer *, doublereal *, doublereal *); doublereal tempbnd; integer leftptr, rghtptr; /* %----------------------------------------------------% | Include files for debugging and timing information | %----------------------------------------------------% %------------------% | Scalar Arguments | %------------------% %-----------------% | Array Arguments | %-----------------% %------------% | Parameters | %------------% %---------------% | Local Scalars | %---------------% %--------------% | Local Arrays | %--------------% %----------------------% | External Subroutines | %----------------------% %--------------------% | External Functions | %--------------------% %---------------------% | Intrinsic Functions | %---------------------% %-----------------------% | Executable Statements | %-----------------------% %------------------------% | Set default parameters | %------------------------% Parameter adjustments */ --workd; --resid; z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --d__; --select; v_dim1 = *ldv; v_offset = 1 + v_dim1; v -= v_offset; --iparam; --ipntr; --workl; /* Function Body */ msglvl = mseupd; mode = iparam[7]; nconv = iparam[5]; *info = 0; /* %--------------% | Quick return | %--------------% */ if (nconv == 0) { goto L9000; } ierr = 0; if (nconv <= 0) { ierr = -14; } if (*n <= 0) { ierr = -1; } if (*nev <= 0) { ierr = -2; } if (*ncv <= *nev || *ncv > *n) { ierr = -3; } if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "SM", ( ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "LA", (ftnlen)2, ( ftnlen)2) != 0 && s_cmp(which, "SA", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "BE", (ftnlen)2, (ftnlen)2) != 0) { ierr = -5; } if (*(unsigned char *)bmat != 'I' && *(unsigned char *)bmat != 'G') { ierr = -6; } if (*(unsigned char *)howmny != 'A' && *(unsigned char *)howmny != 'P' && *(unsigned char *)howmny != 'S' && *rvec) { ierr = -15; } if (*rvec && *(unsigned char *)howmny == 'S') { ierr = -16; } /* Computing 2nd power */ i__1 = *ncv; if (*rvec && *lworkl < i__1 * i__1 + (*ncv << 3)) { ierr = -7; } if (mode == 1 || mode == 2) { s_copy(type__, "REGULR", (ftnlen)6, (ftnlen)6); } else if (mode == 3) { s_copy(type__, "SHIFTI", (ftnlen)6, (ftnlen)6); } else if (mode == 4) { s_copy(type__, "BUCKLE", (ftnlen)6, (ftnlen)6); } else if (mode == 5) { s_copy(type__, "CAYLEY", (ftnlen)6, (ftnlen)6); } else { ierr = -10; } if (mode == 1 && *(unsigned char *)bmat == 'G') { ierr = -11; } if (*nev == 1 && s_cmp(which, "BE", (ftnlen)2, (ftnlen)2) == 0) { ierr = -12; } /* %------------% | Error Exit | %------------% */ if (ierr != 0) { *info = ierr; goto L9000; } /* %-------------------------------------------------------% | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | | etc... and the remaining workspace. | | Also update pointer to be used on output. | | Memory is laid out as follows: | | workl(1:2*ncv) := generated tridiagonal matrix H | | The subdiagonal is stored in workl(2:ncv). | | The dead spot is workl(1) but upon exiting | | dsaupd stores the B-norm of the last residual | | vector in workl(1). We use this !!! | | workl(2*ncv+1:2*ncv+ncv) := ritz values | | The wanted values are in the first NCONV spots. | | workl(3*ncv+1:3*ncv+ncv) := computed Ritz estimates | | The wanted values are in the first NCONV spots. | | NOTE: workl(1:4*ncv) is set by dsaupd and is not | | modified by dseupd. | %-------------------------------------------------------% %-------------------------------------------------------% | The following is used and set by dseupd. | | workl(4*ncv+1:4*ncv+ncv) := used as workspace during | | computation of the eigenvectors of H. Stores | | the diagonal of H. Upon EXIT contains the NCV | | Ritz values of the original system. The first | | NCONV spots have the wanted values. If MODE = | | 1 or 2 then will equal workl(2*ncv+1:3*ncv). | | workl(5*ncv+1:5*ncv+ncv) := used as workspace during | | computation of the eigenvectors of H. Stores | | the subdiagonal of H. Upon EXIT contains the | | NCV corresponding Ritz estimates of the | | original system. The first NCONV spots have the | | wanted values. If MODE = 1,2 then will equal | | workl(3*ncv+1:4*ncv). | | workl(6*ncv+1:6*ncv+ncv*ncv) := orthogonal Q that is | | the eigenvector matrix for H as returned by | | dsteqr. Not referenced if RVEC = .False. | | Ordering follows that of workl(4*ncv+1:5*ncv) | | workl(6*ncv+ncv*ncv+1:6*ncv+ncv*ncv+2*ncv) := | | Workspace. Needed by dsteqr and by dseupd. | | GRAND total of NCV*(NCV+8) locations. | %-------------------------------------------------------% */ ih = ipntr[5]; ritz = ipntr[6]; bounds = ipntr[7]; ldh = *ncv; ldq = *ncv; ihd = bounds + ldh; ihb = ihd + ldh; iq = ihb + ldh; iw = iq + ldh * *ncv; next = iw + (*ncv << 1); ipntr[4] = next; ipntr[8] = ihd; ipntr[9] = ihb; ipntr[10] = iq; /* %----------------------------------------% | irz points to the Ritz values computed | | by _seigt before exiting _saup2. | | ibd points to the Ritz estimates | | computed by _seigt before exiting | | _saup2. | %----------------------------------------% */ irz = ipntr[11] + *ncv; ibd = irz + *ncv; /* %---------------------------------% | Set machine dependent constant. | %---------------------------------% */ eps23 = igraphdlamch_("Epsilon-Machine"); eps23 = pow_dd(&eps23, &c_b21); /* %---------------------------------------% | RNORM is B-norm of the RESID(1:N). | | BNORM2 is the 2 norm of B*RESID(1:N). | | Upon exit of dsaupd WORKD(1:N) has | | B*RESID(1:N). | %---------------------------------------% */ rnorm = workl[ih]; if (*(unsigned char *)bmat == 'I') { bnorm2 = rnorm; } else if (*(unsigned char *)bmat == 'G') { bnorm2 = igraphdnrm2_(n, &workd[1], &c__1); } if (*rvec) { /* %------------------------------------------------% | Get the converged Ritz value on the boundary. | | This value will be used to dermine whether we | | need to reorder the eigenvalues and | | eigenvectors comupted by _steqr, and is | | referred to as the "threshold" value. | | | | A Ritz value gamma is said to be a wanted | | one, if | | abs(gamma) .ge. threshold, when WHICH = 'LM'; | | abs(gamma) .le. threshold, when WHICH = 'SM'; | | gamma .ge. threshold, when WHICH = 'LA'; | | gamma .le. threshold, when WHICH = 'SA'; | | gamma .le. thres1 .or. gamma .ge. thres2 | | when WHICH = 'BE'; | | | | Note: converged Ritz values and associated | | Ritz estimates have been placed in the first | | NCONV locations in workl(ritz) and | | workl(bounds) respectively. They have been | | sorted (in _saup2) according to the WHICH | | selection criterion. (Except in the case | | WHICH = 'BE', they are sorted in an increasing | | order.) | %------------------------------------------------% */ if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(which, "SM", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(which, "LA", ( ftnlen)2, (ftnlen)2) == 0 || s_cmp(which, "SA", (ftnlen)2, ( ftnlen)2) == 0) { thres1 = workl[ritz]; if (msglvl > 2) { igraphdvout_(&logfil, &c__1, &thres1, &ndigit, "_seupd: Threshold " "eigenvalue used for re-ordering", (ftnlen)49); } } else if (s_cmp(which, "BE", (ftnlen)2, (ftnlen)2) == 0) { /* %------------------------------------------------% | Ritz values returned from _saup2 have been | | sorted in increasing order. Thus two | | "threshold" values (one for the small end, one | | for the large end) are in the middle. | %------------------------------------------------% */ ism = max(*nev,nconv) / 2; ilg = ism + 1; thres1 = workl[ism]; thres2 = workl[ilg]; if (msglvl > 2) { kv[0] = thres1; kv[1] = thres2; igraphdvout_(&logfil, &c__2, kv, &ndigit, "_seupd: Threshold eigen" "values used for re-ordering", (ftnlen)50); } } /* %----------------------------------------------------------% | Check to see if all converged Ritz values appear within | | the first NCONV diagonal elements returned from _seigt. | | This is done in the following way: | | | | 1) For each Ritz value obtained from _seigt, compare it | | with the threshold Ritz value computed above to | | determine whether it is a wanted one. | | | | 2) If it is wanted, then check the corresponding Ritz | | estimate to see if it has converged. If it has, set | | correponding entry in the logical array SELECT to | | .TRUE.. | | | | If SELECT(j) = .TRUE. and j > NCONV, then there is a | | converged Ritz value that does not appear at the top of | | the diagonal matrix computed by _seigt in _saup2. | | Reordering is needed. | %----------------------------------------------------------% */ reord = FALSE_; ktrord = 0; i__1 = *ncv - 1; for (j = 0; j <= i__1; ++j) { select[j + 1] = FALSE_; if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) == 0) { if ((d__1 = workl[irz + j], abs(d__1)) >= abs(thres1)) { /* Computing MAX */ d__2 = eps23, d__3 = (d__1 = workl[irz + j], abs(d__1)); tempbnd = max(d__2,d__3); if (workl[ibd + j] <= *tol * tempbnd) { select[j + 1] = TRUE_; } } } else if (s_cmp(which, "SM", (ftnlen)2, (ftnlen)2) == 0) { if ((d__1 = workl[irz + j], abs(d__1)) <= abs(thres1)) { /* Computing MAX */ d__2 = eps23, d__3 = (d__1 = workl[irz + j], abs(d__1)); tempbnd = max(d__2,d__3); if (workl[ibd + j] <= *tol * tempbnd) { select[j + 1] = TRUE_; } } } else if (s_cmp(which, "LA", (ftnlen)2, (ftnlen)2) == 0) { if (workl[irz + j] >= thres1) { /* Computing MAX */ d__2 = eps23, d__3 = (d__1 = workl[irz + j], abs(d__1)); tempbnd = max(d__2,d__3); if (workl[ibd + j] <= *tol * tempbnd) { select[j + 1] = TRUE_; } } } else if (s_cmp(which, "SA", (ftnlen)2, (ftnlen)2) == 0) { if (workl[irz + j] <= thres1) { /* Computing MAX */ d__2 = eps23, d__3 = (d__1 = workl[irz + j], abs(d__1)); tempbnd = max(d__2,d__3); if (workl[ibd + j] <= *tol * tempbnd) { select[j + 1] = TRUE_; } } } else if (s_cmp(which, "BE", (ftnlen)2, (ftnlen)2) == 0) { if (workl[irz + j] <= thres1 || workl[irz + j] >= thres2) { /* Computing MAX */ d__2 = eps23, d__3 = (d__1 = workl[irz + j], abs(d__1)); tempbnd = max(d__2,d__3); if (workl[ibd + j] <= *tol * tempbnd) { select[j + 1] = TRUE_; } } } if (j + 1 > nconv) { reord = select[j + 1] || reord; } if (select[j + 1]) { ++ktrord; } /* L10: */ } /* %-------------------------------------------% | If KTRORD .ne. NCONV, something is wrong. | %-------------------------------------------% */ if (msglvl > 2) { igraphivout_(&logfil, &c__1, &ktrord, &ndigit, "_seupd: Number of spec" "ified eigenvalues", (ftnlen)39); igraphivout_(&logfil, &c__1, &nconv, &ndigit, "_seupd: Number of \"con" "verged\" eigenvalues", (ftnlen)41); } /* %-----------------------------------------------------------% | Call LAPACK routine _steqr to compute the eigenvalues and | | eigenvectors of the final symmetric tridiagonal matrix H. | | Initialize the eigenvector matrix Q to the identity. | %-----------------------------------------------------------% */ i__1 = *ncv - 1; igraphdcopy_(&i__1, &workl[ih + 1], &c__1, &workl[ihb], &c__1); igraphdcopy_(ncv, &workl[ih + ldh], &c__1, &workl[ihd], &c__1); igraphdsteqr_("Identity", ncv, &workl[ihd], &workl[ihb], &workl[iq], &ldq, & workl[iw], &ierr); if (ierr != 0) { *info = -8; goto L9000; } if (msglvl > 1) { igraphdcopy_(ncv, &workl[iq + *ncv - 1], &ldq, &workl[iw], &c__1); igraphdvout_(&logfil, ncv, &workl[ihd], &ndigit, "_seupd: NCV Ritz val" "ues of the final H matrix", (ftnlen)45); igraphdvout_(&logfil, ncv, &workl[iw], &ndigit, "_seupd: last row of t" "he eigenvector matrix for H", (ftnlen)48); } if (reord) { /* %---------------------------------------------% | Reordered the eigenvalues and eigenvectors | | computed by _steqr so that the "converged" | | eigenvalues appear in the first NCONV | | positions of workl(ihd), and the associated | | eigenvectors appear in the first NCONV | | columns. | %---------------------------------------------% */ leftptr = 1; rghtptr = *ncv; if (*ncv == 1) { goto L30; } L20: if (select[leftptr]) { /* %-------------------------------------------% | Search, from the left, for the first Ritz | | value that has not converged. | %-------------------------------------------% */ ++leftptr; } else if (! select[rghtptr]) { /* %----------------------------------------------% | Search, from the right, the first Ritz value | | that has converged. | %----------------------------------------------% */ --rghtptr; } else { /* %----------------------------------------------% | Swap the Ritz value on the left that has not | | converged with the Ritz value on the right | | that has converged. Swap the associated | | eigenvector of the tridiagonal matrix H as | | well. | %----------------------------------------------% */ temp = workl[ihd + leftptr - 1]; workl[ihd + leftptr - 1] = workl[ihd + rghtptr - 1]; workl[ihd + rghtptr - 1] = temp; igraphdcopy_(ncv, &workl[iq + *ncv * (leftptr - 1)], &c__1, &workl[ iw], &c__1); igraphdcopy_(ncv, &workl[iq + *ncv * (rghtptr - 1)], &c__1, &workl[ iq + *ncv * (leftptr - 1)], &c__1); igraphdcopy_(ncv, &workl[iw], &c__1, &workl[iq + *ncv * (rghtptr - 1)], &c__1); ++leftptr; --rghtptr; } if (leftptr < rghtptr) { goto L20; } L30: ; } if (msglvl > 2) { igraphdvout_(&logfil, ncv, &workl[ihd], &ndigit, "_seupd: The eigenval" "ues of H--reordered", (ftnlen)39); } /* %----------------------------------------% | Load the converged Ritz values into D. | %----------------------------------------% */ igraphdcopy_(&nconv, &workl[ihd], &c__1, &d__[1], &c__1); } else { /* %-----------------------------------------------------% | Ritz vectors not required. Load Ritz values into D. | %-----------------------------------------------------% */ igraphdcopy_(&nconv, &workl[ritz], &c__1, &d__[1], &c__1); igraphdcopy_(ncv, &workl[ritz], &c__1, &workl[ihd], &c__1); } /* %------------------------------------------------------------------% | Transform the Ritz values and possibly vectors and corresponding | | Ritz estimates of OP to those of A*x=lambda*B*x. The Ritz values | | (and corresponding data) are returned in ascending order. | %------------------------------------------------------------------% */ if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) { /* %---------------------------------------------------------% | Ascending sort of wanted Ritz values, vectors and error | | bounds. Not necessary if only Ritz values are desired. | %---------------------------------------------------------% */ if (*rvec) { igraphdsesrt_("LA", rvec, &nconv, &d__[1], ncv, &workl[iq], &ldq); } else { igraphdcopy_(ncv, &workl[bounds], &c__1, &workl[ihb], &c__1); } } else { /* %-------------------------------------------------------------% | * Make a copy of all the Ritz values. | | * Transform the Ritz values back to the original system. | | For TYPE = 'SHIFTI' the transformation is | | lambda = 1/theta + sigma | | For TYPE = 'BUCKLE' the transformation is | | lambda = sigma * theta / ( theta - 1 ) | | For TYPE = 'CAYLEY' the transformation is | | lambda = sigma * (theta + 1) / (theta - 1 ) | | where the theta are the Ritz values returned by dsaupd. | | NOTES: | | *The Ritz vectors are not affected by the transformation. | | They are only reordered. | %-------------------------------------------------------------% */ igraphdcopy_(ncv, &workl[ihd], &c__1, &workl[iw], &c__1); if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) { i__1 = *ncv; for (k = 1; k <= i__1; ++k) { workl[ihd + k - 1] = 1. / workl[ihd + k - 1] + *sigma; /* L40: */ } } else if (s_cmp(type__, "BUCKLE", (ftnlen)6, (ftnlen)6) == 0) { i__1 = *ncv; for (k = 1; k <= i__1; ++k) { workl[ihd + k - 1] = *sigma * workl[ihd + k - 1] / (workl[ihd + k - 1] - 1.); /* L50: */ } } else if (s_cmp(type__, "CAYLEY", (ftnlen)6, (ftnlen)6) == 0) { i__1 = *ncv; for (k = 1; k <= i__1; ++k) { workl[ihd + k - 1] = *sigma * (workl[ihd + k - 1] + 1.) / ( workl[ihd + k - 1] - 1.); /* L60: */ } } /* %-------------------------------------------------------------% | * Store the wanted NCONV lambda values into D. | | * Sort the NCONV wanted lambda in WORKL(IHD:IHD+NCONV-1) | | into ascending order and apply sort to the NCONV theta | | values in the transformed system. We'll need this to | | compute Ritz estimates in the original system. | | * Finally sort the lambda's into ascending order and apply | | to Ritz vectors if wanted. Else just sort lambda's into | | ascending order. | | NOTES: | | *workl(iw:iw+ncv-1) contain the theta ordered so that they | | match the ordering of the lambda. We'll use them again for | | Ritz vector purification. | %-------------------------------------------------------------% */ igraphdcopy_(&nconv, &workl[ihd], &c__1, &d__[1], &c__1); igraphdsortr_("LA", &c_true, &nconv, &workl[ihd], &workl[iw]); if (*rvec) { igraphdsesrt_("LA", rvec, &nconv, &d__[1], ncv, &workl[iq], &ldq); } else { igraphdcopy_(ncv, &workl[bounds], &c__1, &workl[ihb], &c__1); d__1 = bnorm2 / rnorm; igraphdscal_(ncv, &d__1, &workl[ihb], &c__1); igraphdsortr_("LA", &c_true, &nconv, &d__[1], &workl[ihb]); } } /* %------------------------------------------------% | Compute the Ritz vectors. Transform the wanted | | eigenvectors of the symmetric tridiagonal H by | | the Lanczos basis matrix V. | %------------------------------------------------% */ if (*rvec && *(unsigned char *)howmny == 'A') { /* %----------------------------------------------------------% | Compute the QR factorization of the matrix representing | | the wanted invariant subspace located in the first NCONV | | columns of workl(iq,ldq). | %----------------------------------------------------------% */ igraphdgeqr2_(ncv, &nconv, &workl[iq], &ldq, &workl[iw + *ncv], &workl[ihb], &ierr); /* %--------------------------------------------------------% | * Postmultiply V by Q. | | * Copy the first NCONV columns of VQ into Z. | | The N by NCONV matrix Z is now a matrix representation | | of the approximate invariant subspace associated with | | the Ritz values in workl(ihd). | %--------------------------------------------------------% */ igraphdorm2r_("Right", "Notranspose", n, ncv, &nconv, &workl[iq], &ldq, & workl[iw + *ncv], &v[v_offset], ldv, &workd[*n + 1], &ierr); igraphdlacpy_("All", n, &nconv, &v[v_offset], ldv, &z__[z_offset], ldz); /* %-----------------------------------------------------% | In order to compute the Ritz estimates for the Ritz | | values in both systems, need the last row of the | | eigenvector matrix. Remember, it's in factored form | %-----------------------------------------------------% */ i__1 = *ncv - 1; for (j = 1; j <= i__1; ++j) { workl[ihb + j - 1] = 0.; /* L65: */ } workl[ihb + *ncv - 1] = 1.; igraphdorm2r_("Left", "Transpose", ncv, &c__1, &nconv, &workl[iq], &ldq, & workl[iw + *ncv], &workl[ihb], ncv, &temp, &ierr); } else if (*rvec && *(unsigned char *)howmny == 'S') { /* Not yet implemented. See remark 2 above. */ } if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0 && *rvec) { i__1 = *ncv; for (j = 1; j <= i__1; ++j) { workl[ihb + j - 1] = rnorm * (d__1 = workl[ihb + j - 1], abs(d__1) ); /* L70: */ } } else if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) != 0 && *rvec) { /* %-------------------------------------------------% | * Determine Ritz estimates of the theta. | | If RVEC = .true. then compute Ritz estimates | | of the theta. | | If RVEC = .false. then copy Ritz estimates | | as computed by dsaupd. | | * Determine Ritz estimates of the lambda. | %-------------------------------------------------% */ igraphdscal_(ncv, &bnorm2, &workl[ihb], &c__1); if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) { i__1 = *ncv; for (k = 1; k <= i__1; ++k) { /* Computing 2nd power */ d__2 = workl[iw + k - 1]; workl[ihb + k - 1] = (d__1 = workl[ihb + k - 1], abs(d__1)) / (d__2 * d__2); /* L80: */ } } else if (s_cmp(type__, "BUCKLE", (ftnlen)6, (ftnlen)6) == 0) { i__1 = *ncv; for (k = 1; k <= i__1; ++k) { /* Computing 2nd power */ d__2 = workl[iw + k - 1] - 1.; workl[ihb + k - 1] = *sigma * (d__1 = workl[ihb + k - 1], abs( d__1)) / (d__2 * d__2); /* L90: */ } } else if (s_cmp(type__, "CAYLEY", (ftnlen)6, (ftnlen)6) == 0) { i__1 = *ncv; for (k = 1; k <= i__1; ++k) { workl[ihb + k - 1] = (d__1 = workl[ihb + k - 1] / workl[iw + k - 1] * (workl[iw + k - 1] - 1.), abs(d__1)); /* L100: */ } } } if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) != 0 && msglvl > 1) { igraphdvout_(&logfil, &nconv, &d__[1], &ndigit, "_seupd: Untransformed con" "verged Ritz values", (ftnlen)43); igraphdvout_(&logfil, &nconv, &workl[ihb], &ndigit, "_seupd: Ritz estimate" "s of the untransformed Ritz values", (ftnlen)55); } else if (msglvl > 1) { igraphdvout_(&logfil, &nconv, &d__[1], &ndigit, "_seupd: Converged Ritz va" "lues", (ftnlen)29); igraphdvout_(&logfil, &nconv, &workl[ihb], &ndigit, "_seupd: Associated Ri" "tz estimates", (ftnlen)33); } /* %-------------------------------------------------% | Ritz vector purification step. Formally perform | | one of inverse subspace iteration. Only used | | for MODE = 3,4,5. See reference 7 | %-------------------------------------------------% */ if (*rvec && (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0 || s_cmp( type__, "CAYLEY", (ftnlen)6, (ftnlen)6) == 0)) { i__1 = nconv - 1; for (k = 0; k <= i__1; ++k) { workl[iw + k] = workl[iq + k * ldq + *ncv - 1] / workl[iw + k]; /* L110: */ } } else if (*rvec && s_cmp(type__, "BUCKLE", (ftnlen)6, (ftnlen)6) == 0) { i__1 = nconv - 1; for (k = 0; k <= i__1; ++k) { workl[iw + k] = workl[iq + k * ldq + *ncv - 1] / (workl[iw + k] - 1.); /* L120: */ } } if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) != 0) { igraphdger_(n, &nconv, &c_b119, &resid[1], &c__1, &workl[iw], &c__1, &z__[ z_offset], ldz); } L9000: return 0; /* %---------------% | End of dseupd | %---------------% */ } /* igraphdseupd_ */