/*< subroutine dsgets ( ishift, which, kev, np, ritz, bounds, shifts ) >*/
/* Subroutine */ int dsgets_(integer *ishift, char *which, integer *kev,
integer *np, doublereal *ritz, doublereal *bounds, doublereal *shifts,
ftnlen which_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
/* static real t0, t1; */
integer kevd2;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *), dcopy_(integer *, doublereal *, integer
*, doublereal *, integer *), second_(real *);
/* integer msglvl; */
extern /* Subroutine */ int dsortr_(char *, logical *, integer *,
doublereal *, doublereal *, ftnlen);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/*< include 'debug.h' >*/
/*< include 'stat.h' >*/
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/*< >*/
/*< character*2 which >*/
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/*< save t0, t1, t2, t3, t4, t5 >*/
/*< integer nopx, nbx, nrorth, nitref, nrstrt >*/
/*< >*/
/*< >*/
/*< integer ishift, kev, np >*/
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/*< >*/
/* %------------% */
/* | Parameters | */
/* %------------% */
/*< >*/
/*< parameter (one = 1.0D+0, zero = 0.0D+0) >*/
/* %---------------% */
/* | Local Scalars | */
/* %---------------% */
/*< integer kevd2, msglvl >*/
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/*< external dswap, dcopy, dsortr, second >*/
/* %---------------------% */
/* | Intrinsic Functions | */
/* %---------------------% */
/*< intrinsic max, min >*/
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* %-------------------------------% */
/* | Initialize timing statistics | */
/* | & message level for debugging | */
/* %-------------------------------% */
/*< call second (t0) >*/
/* Parameter adjustments */
--shifts;
--bounds;
--ritz;
/* Function Body */
/* second_(&t0); */
/*< msglvl = msgets >*/
/* msglvl = debug_1.msgets; */
/*< if (which .eq. 'BE') then >*/
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. | */
/* %-----------------------------------------------------% */
/*< call dsortr ('LA', .true., kev+np, ritz, bounds) >*/
i__1 = *kev + *np;
dsortr_("LA", &c_true, &i__1, &ritz[1], &bounds[1], (ftnlen)2);
/*< kevd2 = kev / 2 >*/
kevd2 = *kev / 2;
/*< if ( kev .gt. 1 ) then >*/
if (*kev > 1) {
/*< >*/
i__1 = min(kevd2,*np);
dswap_(&i__1, &ritz[1], &c__1, &ritz[max(kevd2,*np) + 1], &c__1);
/*< >*/
i__1 = min(kevd2,*np);
dswap_(&i__1, &bounds[1], &c__1, &bounds[max(kevd2,*np) + 1], &
c__1);
/*< end if >*/
}
/*< else >*/
} 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. | */
/* %----------------------------------------------------% */
/*< call dsortr (which, .true., kev+np, ritz, bounds) >*/
i__1 = *kev + *np;
dsortr_(which, &c_true, &i__1, &ritz[1], &bounds[1], (ftnlen)2);
/*< end if >*/
}
/*< if (ishift .eq. 1 .and. np .gt. 0) then >*/
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. | */
/* %-------------------------------------------------------% */
/*< call dsortr ('SM', .true., np, bounds, ritz) >*/
dsortr_("SM", &c_true, np, &bounds[1], &ritz[1], (ftnlen)2);
/*< call dcopy (np, ritz, 1, shifts, 1) >*/
dcopy_(np, &ritz[1], &c__1, &shifts[1], &c__1);
/*< end if >*/
}
/*< call second (t1) >*/
/* second_(&t1); */
/*< tsgets = tsgets + (t1 - t0) >*/
/* timing_1.tsgets += t1 - t0; */
/* if (msglvl .gt. 0) then */
/* call ivout (logfil, 1, kev, ndigit, '_sgets: KEV is') */
/* call ivout (logfil, 1, np, ndigit, '_sgets: NP is') */
/* call dvout (logfil, kev+np, ritz, ndigit, */
/* & '_sgets: Eigenvalues of current H matrix') */
/* call dvout (logfil, kev+np, bounds, ndigit, */
/* & '_sgets: Associated Ritz estimates') */
/* end if */
/*< return >*/
return 0;
/* %---------------% */
/* | End of dsgets | */
/* %---------------% */
/*< end >*/
} /* dsgets_ */
/* Subroutine */ int dsaup2_(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,
ftnlen bmat_len, ftnlen which_len)
{
/* 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;
/* Local variables */
static integer j;
static real t0, t1, t2, t3;
static integer kp[3], np0, nev0;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static doublereal eps23;
static integer ierr, iter;
static doublereal temp;
static integer nevd2;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static logical getv0;
static integer nevm2;
static logical cnorm;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
static integer nconv;
static logical initv;
static doublereal rnorm;
extern /* Subroutine */ int dvout_(integer *, integer *, doublereal *,
integer *, char *, ftnlen), ivout_(integer *, integer *, integer *
, integer *, char *, ftnlen), dgetv0_(integer *, char *, integer *
, logical *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
ftnlen);
extern doublereal dlamch_(char *, ftnlen);
static integer nevbef;
extern /* Subroutine */ int arscnd_(real *);
static logical update;
static char wprime[2];
static logical ushift;
static integer kplusp, msglvl, nptemp;
extern /* Subroutine */ int dsaitr_(integer *, char *, integer *, integer
*, integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
integer *, ftnlen), dsconv_(integer *, doublereal *, doublereal *,
doublereal *, integer *), dseigt_(doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *), dsgets_(integer *, char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, ftnlen), dsapps_(
integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *), dsortr_(char *, logical *, integer *,
doublereal *, doublereal *, ftnlen);
/* %----------------------------------------------------% */
/* | 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 | */
/* %-----------------------% */
/* 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 | */
/* %-------------------------------% */
arscnd_(&t0);
msglvl = debug_1.msaup2;
/* %---------------------------------% */
/* | Set machine dependent constant. | */
/* %---------------------------------% */
eps23 = dlamch_("Epsilon-Machine", (ftnlen)15);
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) {
dgetv0_(ido, bmat, &c__1, &initv, n, &c__1, &v[v_offset], ldv, &resid[
1], &rnorm, &ipntr[1], &workd[1], info, (ftnlen)1);
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 | */
/* %----------------------------------------------------------% */
dsaitr_(ido, bmat, n, &c__0, &nev0, mode, &resid[1], &rnorm, &v[v_offset],
ldv, &h__[h_offset], ldh, &ipntr[1], &workd[1], info, (ftnlen)1);
/* %---------------------------------------------------% */
/* | 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) {
ivout_(&debug_1.logfil, &c__1, &iter, &debug_1.ndigit, "_saup2: ****"
" Start of major iteration number ****", (ftnlen)49);
}
if (msglvl > 1) {
ivout_(&debug_1.logfil, &c__1, nev, &debug_1.ndigit, "_saup2: The le"
"ngth of the current Lanczos factorization", (ftnlen)55);
ivout_(&debug_1.logfil, &c__1, np, &debug_1.ndigit, "_saup2: Extend "
"the Lanczos factorization by", (ftnlen)43);
}
/* %------------------------------------------------------------% */
/* | Compute NP additional steps of the Lanczos factorization. | */
/* %------------------------------------------------------------% */
*ido = 0;
L20:
update = TRUE_;
dsaitr_(ido, bmat, n, nev, np, mode, &resid[1], &rnorm, &v[v_offset], ldv,
&h__[h_offset], ldh, &ipntr[1], &workd[1], info, (ftnlen)1);
/* %---------------------------------------------------% */
/* | 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) {
dvout_(&debug_1.logfil, &c__1, &rnorm, &debug_1.ndigit, "_saup2: Cur"
"rent B-norm of residual for factorization", (ftnlen)52);
}
/* %--------------------------------------------------------% */
/* | Compute the eigenvalues and corresponding error bounds | */
/* | of the current symmetric tridiagonal matrix. | */
/* %--------------------------------------------------------% */
dseigt_(&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. | */
/* %----------------------------------------------------% */
dcopy_(&kplusp, &ritz[1], &c__1, &workl[kplusp + 1], &c__1);
dcopy_(&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;
dsgets_(ishift, which, nev, np, &ritz[1], &bounds[1], &workl[1], (ftnlen)
2);
/* %-------------------% */
/* | Convergence test. | */
/* %-------------------% */
dcopy_(nev, &bounds[*np + 1], &c__1, &workl[*np + 1], &c__1);
dsconv_(nev, &ritz[*np + 1], &workl[*np + 1], tol, &nconv);
if (msglvl > 2) {
kp[0] = *nev;
kp[1] = *np;
kp[2] = nconv;
ivout_(&debug_1.logfil, &c__3, kp, &debug_1.ndigit, "_saup2: NEV, NP"
", NCONV are", (ftnlen)26);
dvout_(&debug_1.logfil, &kplusp, &ritz[1], &debug_1.ndigit, "_saup2:"
" The eigenvalues of H", (ftnlen)28);
dvout_(&debug_1.logfil, &kplusp, &bounds[1], &debug_1.ndigit, "_saup"
"2: Ritz estimates 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);
dsortr_(wprime, &c_true, &kplusp, &ritz[1], &bounds[1], (ftnlen)2)
;
nevd2 = nev0 / 2;
nevm2 = nev0 - nevd2;
if (*nev > 1) {
i__1 = min(nevd2,*np);
/* Computing MAX */
i__2 = kplusp - nevd2 + 1, i__3 = kplusp - *np + 1;
dswap_(&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 + 1;
dswap_(&i__1, &bounds[nevm2 + 1], &c__1, &bounds[max(i__2,
i__3)], &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);
}
dsortr_(wprime, &c_true, &kplusp, &ritz[1], &bounds[1], (ftnlen)2)
;
}
/* %--------------------------------------------------% */
/* | 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);
dsortr_(wprime, &c_true, &nev0, &bounds[1], &ritz[1], (ftnlen)2);
/* %----------------------------------------------% */
/* | 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);
dsortr_(wprime, &c_true, &nconv, &ritz[1], &bounds[1], (ftnlen)2);
} 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. | */
/* %----------------------------------------------% */
dsortr_(which, &c_true, &nconv, &ritz[1], &bounds[1], (ftnlen)2);
}
/* %------------------------------------------% */
/* | Use h( 1,1 ) as storage to communicate | */
/* | rnorm to _seupd if needed | */
/* %------------------------------------------% */
h__[h_dim1 + 1] = rnorm;
if (msglvl > 1) {
dvout_(&debug_1.logfil, &kplusp, &ritz[1], &debug_1.ndigit, "_sa"
"up2: Sorted Ritz values.", (ftnlen)27);
dvout_(&debug_1.logfil, &kplusp, &bounds[1], &debug_1.ndigit,
"_saup2: Sorted ritz 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) {
dsgets_(ishift, which, nev, np, &ritz[1], &bounds[1], &workl[1], (
ftnlen)2);
}
}
if (msglvl > 0) {
ivout_(&debug_1.logfil, &c__1, &nconv, &debug_1.ndigit, "_saup2: no."
" of \"converged\" Ritz values at this iter.", (ftnlen)52);
if (msglvl > 1) {
kp[0] = *nev;
kp[1] = *np;
ivout_(&debug_1.logfil, &c__2, kp, &debug_1.ndigit, "_saup2: NEV"
" and NP are", (ftnlen)22);
dvout_(&debug_1.logfil, nev, &ritz[*np + 1], &debug_1.ndigit,
"_saup2: \"wanted\" Ritz values.", (ftnlen)29);
dvout_(&debug_1.logfil, nev, &bounds[*np + 1], &debug_1.ndigit,
"_saup2: Ritz estimates 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) {
dcopy_(np, &workl[1], &c__1, &ritz[1], &c__1);
}
if (msglvl > 2) {
ivout_(&debug_1.logfil, &c__1, np, &debug_1.ndigit, "_saup2: The num"
"ber of shifts to apply ", (ftnlen)38);
dvout_(&debug_1.logfil, np, &workl[1], &debug_1.ndigit, "_saup2: shi"
"fts selected", (ftnlen)23);
if (*ishift == 1) {
dvout_(&debug_1.logfil, np, &bounds[1], &debug_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. | */
/* %---------------------------------------------------------% */
dsapps_(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_;
arscnd_(&t2);
if (*(unsigned char *)bmat == 'G') {
++timing_1.nbx;
dcopy_(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') {
dcopy_(n, &resid[1], &c__1, &workd[1], &c__1);
}
L100:
/* %----------------------------------% */
/* | Back from reverse communication; | */
/* | WORKD(1:N) := B*RESID | */
/* %----------------------------------% */
if (*(unsigned char *)bmat == 'G') {
arscnd_(&t3);
timing_1.tmvbx += t3 - t2;
}
if (*(unsigned char *)bmat == 'G') {
rnorm = ddot_(n, &resid[1], &c__1, &workd[1], &c__1);
rnorm = sqrt((abs(rnorm)));
} else if (*(unsigned char *)bmat == 'I') {
rnorm = dnrm2_(n, &resid[1], &c__1);
}
cnorm = FALSE_;
/* L130: */
if (msglvl > 2) {
dvout_(&debug_1.logfil, &c__1, &rnorm, &debug_1.ndigit, "_saup2: B-n"
"orm of residual for NEV factorization", (ftnlen)48);
dvout_(&debug_1.logfil, nev, &h__[(h_dim1 << 1) + 1], &debug_1.ndigit,
"_saup2: main diagonal of compressed H matrix", (ftnlen)44);
i__1 = *nev - 1;
dvout_(&debug_1.logfil, &i__1, &h__[h_dim1 + 2], &debug_1.ndigit,
"_saup2: subdiagonal 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 | */
/* %------------% */
arscnd_(&t1);
timing_1.tsaup2 = t1 - t0;
L9000:
return 0;
/* %---------------% */
/* | End of dsaup2 | */
/* %---------------% */
} /* dsaup2_ */
/* ----------------------------------------------------------------------- */
/* Subroutine */ int dseupd_(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, ftnlen howmny_len, ftnlen bmat_len,
ftnlen which_len)
{
/* 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 */
static integer j, k, ih, jj, iq, np, iw, ibd, ihb, ihd, ldh, ldq, irz;
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static integer mode;
static doublereal eps23;
static integer ierr;
static doublereal temp;
static integer next;
static char type__[6];
static integer ritz;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static doublereal temp1;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static logical reord;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static integer nconv;
static doublereal rnorm;
extern /* Subroutine */ int dvout_(integer *, integer *, doublereal *,
integer *, char *, ftnlen), ivout_(integer *, integer *, integer *
, integer *, char *, ftnlen), dgeqr2_(integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *);
static doublereal bnorm2;
extern /* Subroutine */ int dorm2r_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, ftnlen, ftnlen);
extern doublereal dlamch_(char *, ftnlen);
static integer bounds, msglvl, ishift, numcnv;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, ftnlen),
dsesrt_(char *, logical *, integer *, doublereal *, integer *,
doublereal *, integer *, ftnlen), dsteqr_(char *, integer *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
integer *, ftnlen), dsortr_(char *, logical *, integer *,
doublereal *, doublereal *, ftnlen), dsgets_(integer *, char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
ftnlen);
static integer 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 (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 = dlamch_("Epsilon-Machine", (ftnlen)15);
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 = dnrm2_(n, &workd[1], &c__1);
}
if (msglvl > 2) {
dvout_(&debug_1.logfil, ncv, &workl[irz], &debug_1.ndigit, "_seupd: "
"Ritz values passed in from _SAUPD.", (ftnlen)42);
dvout_(&debug_1.logfil, ncv, &workl[ibd], &debug_1.ndigit, "_seupd: "
"Ritz estimates passed in from _SAUPD.", (ftnlen)45);
}
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;
dsgets_(&ishift, which, nev, &np, &workl[irz], &workl[bounds], &workl[
1], (ftnlen)2);
if (msglvl > 2) {
dvout_(&debug_1.logfil, ncv, &workl[irz], &debug_1.ndigit, "_seu"
"pd: Ritz values after calling _SGETS.", (ftnlen)41);
dvout_(&debug_1.logfil, ncv, &workl[bounds], &debug_1.ndigit,
"_seupd: Ritz value indices after calling _SGETS.", (
ftnlen)48);
}
/* %-----------------------------------------------------% */
/* | 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) {
ivout_(&debug_1.logfil, &c__1, &numcnv, &debug_1.ndigit, "_seupd"
": Number of specified eigenvalues", (ftnlen)39);
ivout_(&debug_1.logfil, &c__1, &nconv, &debug_1.ndigit, "_seupd:"
" Number of \"converged\" eigenvalues", (ftnlen)41);
}
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;
dcopy_(&i__1, &workl[ih + 1], &c__1, &workl[ihb], &c__1);
dcopy_(ncv, &workl[ih + ldh], &c__1, &workl[ihd], &c__1);
dsteqr_("Identity", ncv, &workl[ihd], &workl[ihb], &workl[iq], &ldq, &
workl[iw], &ierr, (ftnlen)8);
if (ierr != 0) {
*info = -8;
goto L9000;
}
if (msglvl > 1) {
dcopy_(ncv, &workl[iq + *ncv - 1], &ldq, &workl[iw], &c__1);
dvout_(&debug_1.logfil, ncv, &workl[ihd], &debug_1.ndigit, "_seu"
"pd: NCV Ritz values of the final H matrix", (ftnlen)45);
dvout_(&debug_1.logfil, ncv, &workl[iw], &debug_1.ndigit, "_seup"
"d: last row of the 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;
dcopy_(ncv, &workl[iq + *ncv * (leftptr - 1)], &c__1, &workl[
iw], &c__1);
dcopy_(ncv, &workl[iq + *ncv * (rghtptr - 1)], &c__1, &workl[
iq + *ncv * (leftptr - 1)], &c__1);
dcopy_(ncv, &workl[iw], &c__1, &workl[iq + *ncv * (rghtptr -
1)], &c__1);
++leftptr;
--rghtptr;
}
if (leftptr < rghtptr) {
goto L20;
}
L30:
;
}
if (msglvl > 2) {
dvout_(&debug_1.logfil, ncv, &workl[ihd], &debug_1.ndigit, "_seu"
"pd: The eigenvalues of H--reordered", (ftnlen)39);
}
/* %----------------------------------------% */
/* | Load the converged Ritz values into D. | */
/* %----------------------------------------% */
dcopy_(&nconv, &workl[ihd], &c__1, &d__[1], &c__1);
} else {
/* %-----------------------------------------------------% */
/* | Ritz vectors not required. Load Ritz values into D. | */
/* %-----------------------------------------------------% */
dcopy_(&nconv, &workl[ritz], &c__1, &d__[1], &c__1);
dcopy_(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) {
dsesrt_("LA", rvec, &nconv, &d__[1], ncv, &workl[iq], &ldq, (
ftnlen)2);
} else {
dcopy_(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. | */
/* %-------------------------------------------------------------% */
dcopy_(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 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. | */
/* %-------------------------------------------------------------% */
dcopy_(&nconv, &workl[ihd], &c__1, &d__[1], &c__1);
dsortr_("LA", &c_true, &nconv, &workl[ihd], &workl[iw], (ftnlen)2);
if (*rvec) {
dsesrt_("LA", rvec, &nconv, &d__[1], ncv, &workl[iq], &ldq, (
ftnlen)2);
} else {
dcopy_(ncv, &workl[bounds], &c__1, &workl[ihb], &c__1);
d__1 = bnorm2 / rnorm;
dscal_(ncv, &d__1, &workl[ihb], &c__1);
dsortr_("LA", &c_true, &nconv, &d__[1], &workl[ihb], (ftnlen)2);
}
}
/* %------------------------------------------------% */
/* | 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). | */
/* %----------------------------------------------------------% */
dgeqr2_(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). | */
/* %--------------------------------------------------------% */
dorm2r_("Right", "Notranspose", n, ncv, &nconv, &workl[iq], &ldq, &
workl[iw + *ncv], &v[v_offset], ldv, &workd[*n + 1], &ierr, (
ftnlen)5, (ftnlen)11);
dlacpy_("All", n, &nconv, &v[v_offset], ldv, &z__[z_offset], ldz, (
ftnlen)3);
/* %-----------------------------------------------------% */
/* | 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.;
dorm2r_("Left", "Transpose", ncv, &c__1, &nconv, &workl[iq], &ldq, &
workl[iw + *ncv], &workl[ihb], ncv, &temp, &ierr, (ftnlen)4, (
ftnlen)9);
} 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. | */
/* %-------------------------------------------------% */
dscal_(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) {
dvout_(&debug_1.logfil, &nconv, &d__[1], &debug_1.ndigit, "_seupd: U"
"ntransformed converged Ritz values", (ftnlen)43);
dvout_(&debug_1.logfil, &nconv, &workl[ihb], &debug_1.ndigit, "_seup"
"d: Ritz estimates of the untransformed Ritz values", (ftnlen)
55);
} else if (msglvl > 1) {
dvout_(&debug_1.logfil, &nconv, &d__[1], &debug_1.ndigit, "_seupd: C"
"onverged Ritz values", (ftnlen)29);
dvout_(&debug_1.logfil, &nconv, &workl[ihb], &debug_1.ndigit, "_seup"
"d: Associated Ritz 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) {
dger_(n, &nconv, &c_b110, &resid[1], &c__1, &workl[iw], &c__1, &z__[
z_offset], ldz);
}
L9000:
return 0;
/* %---------------% */
/* | End of dseupd | */
/* %---------------% */
} /* dseupd_ */
/* Subroutine */ int pdsgets_(integer *comm, integer *ishift, char *which,
integer *kev, integer *np, doublereal *ritz, doublereal *bounds,
doublereal *shifts, ftnlen which_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
static real t0, t1;
static integer kevd2;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *), dcopy_(integer *, doublereal *, integer
*, doublereal *, integer *), second_(real *);
static integer msglvl;
extern /* Subroutine */ int dsortr_(char *, logical *, integer *,
doublereal *, doublereal *, ftnlen), pivout_(integer *, integer *,
integer *, integer *, integer *, char *, ftnlen), pdvout_(
integer *, integer *, integer *, doublereal *, integer *, char *,
ftnlen);
/* %--------------------% */
/* | MPI Communicator | */
/* %--------------------% */
/* %----------------------------------------------------% */
/* | 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 | */
/* %----------------------% */
/* %---------------------% */
/* | Intrinsic Functions | */
/* %---------------------% */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* %-------------------------------% */
/* | Initialize timing statistics | */
/* | & message level for debugging | */
/* %-------------------------------% */
/* Parameter adjustments */
--shifts;
--bounds;
--ritz;
/* Function Body */
second_(&t0);
msglvl = debug_1.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;
dsortr_("LA", &c_true, &i__1, &ritz[1], &bounds[1], (ftnlen)2);
kevd2 = *kev / 2;
if (*kev > 1) {
i__1 = min(kevd2,*np);
dswap_(&i__1, &ritz[1], &c__1, &ritz[max(kevd2,*np) + 1], &c__1);
i__1 = min(kevd2,*np);
dswap_(&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;
dsortr_(which, &c_true, &i__1, &ritz[1], &bounds[1], (ftnlen)2);
}
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 pdsapps. | */
/* %-------------------------------------------------------% */
dsortr_("SM", &c_true, np, &bounds[1], &ritz[1], (ftnlen)2);
dcopy_(np, &ritz[1], &c__1, &shifts[1], &c__1);
}
second_(&t1);
timing_1.tsgets += t1 - t0;
if (msglvl > 0) {
pivout_(comm, &debug_1.logfil, &c__1, kev, &debug_1.ndigit, "_sgets:"
" KEV is", (ftnlen)14);
pivout_(comm, &debug_1.logfil, &c__1, np, &debug_1.ndigit, "_sgets: "
"NP is", (ftnlen)13);
i__1 = *kev + *np;
pdvout_(comm, &debug_1.logfil, &i__1, &ritz[1], &debug_1.ndigit,
"_sgets: Eigenvalues of current H matrix", (ftnlen)39);
i__1 = *kev + *np;
pdvout_(comm, &debug_1.logfil, &i__1, &bounds[1], &debug_1.ndigit,
"_sgets: Associated Ritz estimates", (ftnlen)33);
}
return 0;
/* %----------------% */
/* | End of pdsgets | */
/* %----------------% */
} /* pdsgets_ */
/*< >*/
/* Subroutine */ int dsaup2_(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,
ftnlen bmat_len, ftnlen which_len)
{
/* 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;
/* static real t0, t1, t2, t3; */
/* integer kp[3]; */
static integer np0, nev0;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static doublereal eps23;
integer ierr;
static integer iter;
doublereal temp;
integer nevd2;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static logical getv0;
integer nevm2;
static logical cnorm;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
static integer nconv;
static logical initv;
static doublereal rnorm;
extern /* Subroutine */ int dgetv0_(integer *, char *, integer *, logical
*, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, ftnlen);
extern doublereal dlamch_(char *, ftnlen);
integer nevbef;
extern /* Subroutine */ int second_(real *);
static logical update;
char wprime[2];
static logical ushift;
static integer kplusp /*, msglvl */;
integer nptemp;
extern /* Subroutine */ int dsaitr_(integer *, char *, integer *, integer
*, integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
integer *, ftnlen), dsconv_(integer *, doublereal *, doublereal *,
doublereal *, integer *), dseigt_(doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *), dsgets_(integer *, char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, ftnlen), dsapps_(
integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *), dsortr_(char *, logical *, integer *,
doublereal *, doublereal *, ftnlen);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/*< include 'debug.h' >*/
/*< include 'stat.h' >*/
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/*< >*/
/*< character bmat*1, which*2 >*/
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/*< save t0, t1, t2, t3, t4, t5 >*/
/*< integer nopx, nbx, nrorth, nitref, nrstrt >*/
/*< >*/
/*< >*/
/*< >*/
/*< >*/
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/*< integer ipntr(3) >*/
/*< >*/
/* %------------% */
/* | Parameters | */
/* %------------% */
/*< >*/
/*< parameter (one = 1.0D+0, zero = 0.0D+0) >*/
/* %---------------% */
/* | Local Scalars | */
/* %---------------% */
/*< character wprime*2 >*/
/*< logical cnorm, getv0, initv, update, ushift >*/
/*< >*/
/*< >*/
/*< >*/
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/*< >*/
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/*< >*/
/*< external ddot, dnrm2, dlamch >*/
/* %---------------------% */
/* | Intrinsic Functions | */
/* %---------------------% */
/*< intrinsic min >*/
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/*< if (ido .eq. 0) then >*/
/* 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 | */
/* %-------------------------------% */
/*< call second (t0) >*/
/* second_(&t0); */
/*< msglvl = msaup2 >*/
/* msglvl = debug_1.msaup2; */
/* %---------------------------------% */
/* | Set machine dependent constant. | */
/* %---------------------------------% */
/*< eps23 = dlamch('Epsilon-Machine') >*/
eps23 = dlamch_("Epsilon-Machine", (ftnlen)15);
/*< eps23 = eps23**(2.0D+0/3.0D+0) >*/
eps23 = pow_dd(&eps23, &c_b3);
/* %-------------------------------------% */
/* | nev0 and np0 are integer variables | */
/* | hold the initial values of NEV & NP | */
/* %-------------------------------------% */
/*< nev0 = nev >*/
nev0 = *nev;
/*< np0 = np >*/
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 >*/
kplusp = nev0 + np0;
/*< nconv = 0 >*/
nconv = 0;
/*< iter = 0 >*/
iter = 0;
/* %--------------------------------------------% */
/* | Set flags for computing the first NEV steps | */
/* | of the Lanczos factorization. | */
/* %--------------------------------------------% */
/*< getv0 = .true. >*/
getv0 = TRUE_;
/*< update = .false. >*/
update = FALSE_;
/*< ushift = .false. >*/
ushift = FALSE_;
/*< cnorm = .false. >*/
cnorm = FALSE_;
/*< if (info .ne. 0) then >*/
if (*info != 0) {
/* %--------------------------------------------% */
/* | User provides the initial residual vector. | */
/* %--------------------------------------------% */
/*< initv = .true. >*/
initv = TRUE_;
/*< info = 0 >*/
*info = 0;
/*< else >*/
} else {
/*< initv = .false. >*/
initv = FALSE_;
/*< end if >*/
}
/*< end if >*/
}
/* %---------------------------------------------% */
/* | Get a possibly random starting vector and | */
/* | force it into the range of the operator OP. | */
/* %---------------------------------------------% */
/*< 10 continue >*/
/* L10: */
/*< if (getv0) then >*/
if (getv0) {
/*< >*/
dgetv0_(ido, bmat, &c__1, &initv, n, &c__1, &v[v_offset], ldv, &resid[
1], &rnorm, &ipntr[1], &workd[1], info, (ftnlen)1);
/*< if (ido .ne. 99) go to 9000 >*/
if (*ido != 99) {
goto L9000;
}
/*< if (rnorm .eq. zero) then >*/
if (rnorm == 0.) {
/* %-----------------------------------------% */
/* | The initial vector is zero. Error exit. | */
/* %-----------------------------------------% */
/*< info = -9 >*/
*info = -9;
/*< go to 1200 >*/
goto L1200;
/*< end if >*/
}
/*< getv0 = .false. >*/
getv0 = FALSE_;
/*< ido = 0 >*/
*ido = 0;
/*< end if >*/
}
/* %------------------------------------------------------------% */
/* | Back from reverse communication: continue with update step | */
/* %------------------------------------------------------------% */
/*< if (update) go to 20 >*/
if (update) {
goto L20;
}
/* %-------------------------------------------% */
/* | Back from computing user specified shifts | */
/* %-------------------------------------------% */
/*< if (ushift) go to 50 >*/
if (ushift) {
goto L50;
}
/* %-------------------------------------% */
/* | Back from computing residual norm | */
/* | at the end of the current iteration | */
/* %-------------------------------------% */
/*< if (cnorm) go to 100 >*/
if (cnorm) {
goto L100;
}
/* %----------------------------------------------------------% */
/* | Compute the first NEV steps of the Lanczos factorization | */
/* %----------------------------------------------------------% */
/*< >*/
dsaitr_(ido, bmat, n, &c__0, &nev0, mode, &resid[1], &rnorm, &v[v_offset],
ldv, &h__[h_offset], ldh, &ipntr[1], &workd[1], info, (ftnlen)1);
/* %---------------------------------------------------% */
/* | ido .ne. 99 implies use of reverse communication | */
/* | to compute operations involving OP and possibly B | */
/* %---------------------------------------------------% */
/*< if (ido .ne. 99) go to 9000 >*/
if (*ido != 99) {
goto L9000;
}
/*< if (info .gt. 0) then >*/
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 >*/
*np = *info;
/*< mxiter = iter >*/
*mxiter = iter;
/*< info = -9999 >*/
*info = -9999;
/*< go to 1200 >*/
goto L1200;
/*< end if >*/
}
/* %--------------------------------------------------------------% */
/* | | */
/* | 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. | */
/* | | */
/* %--------------------------------------------------------------% */
/*< 1000 continue >*/
L1000:
/*< iter = iter + 1 >*/
++iter;
/* if (msglvl .gt. 0) then */
/* call ivout (logfil, 1, iter, ndigit, */
/* & '_saup2: **** Start of major iteration number ****') */
/* end if */
/* if (msglvl .gt. 1) then */
/* call ivout (logfil, 1, nev, ndigit, */
/* & '_saup2: The length of the current Lanczos factorization') */
/* call ivout (logfil, 1, np, ndigit, */
/* & '_saup2: Extend the Lanczos factorization by') */
/* end if */
/* %------------------------------------------------------------% */
/* | Compute NP additional steps of the Lanczos factorization. | */
/* %------------------------------------------------------------% */
/*< ido = 0 >*/
*ido = 0;
/*< 20 continue >*/
L20:
/*< update = .true. >*/
update = TRUE_;
/*< >*/
dsaitr_(ido, bmat, n, nev, np, mode, &resid[1], &rnorm, &v[v_offset], ldv,
&h__[h_offset], ldh, &ipntr[1], &workd[1], info, (ftnlen)1);
/* %---------------------------------------------------% */
/* | ido .ne. 99 implies use of reverse communication | */
/* | to compute operations involving OP and possibly B | */
/* %---------------------------------------------------% */
/*< if (ido .ne. 99) go to 9000 >*/
if (*ido != 99) {
goto L9000;
}
/*< if (info .gt. 0) then >*/
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 >*/
*np = *info;
/*< mxiter = iter >*/
*mxiter = iter;
/*< info = -9999 >*/
*info = -9999;
/*< go to 1200 >*/
goto L1200;
/*< end if >*/
}
/*< update = .false. >*/
update = FALSE_;
/* if (msglvl .gt. 1) then */
/* call dvout (logfil, 1, rnorm, ndigit, */
/* & '_saup2: Current B-norm of residual for factorization') */
/* end if */
/* %--------------------------------------------------------% */
/* | Compute the eigenvalues and corresponding error bounds | */
/* | of the current symmetric tridiagonal matrix. | */
/* %--------------------------------------------------------% */
/*< call dseigt (rnorm, kplusp, h, ldh, ritz, bounds, workl, ierr) >*/
dseigt_(&rnorm, &kplusp, &h__[h_offset], ldh, &ritz[1], &bounds[1], &
workl[1], &ierr);
/*< if (ierr .ne. 0) then >*/
if (ierr != 0) {
/*< info = -8 >*/
*info = -8;
/*< go to 1200 >*/
goto L1200;
/*< end if >*/
}
/* %----------------------------------------------------% */
/* | Make a copy of eigenvalues and corresponding error | */
/* | bounds obtained from _seigt. | */
/* %----------------------------------------------------% */
/*< call dcopy(kplusp, ritz, 1, workl(kplusp+1), 1) >*/
dcopy_(&kplusp, &ritz[1], &c__1, &workl[kplusp + 1], &c__1);
/*< call dcopy(kplusp, bounds, 1, workl(2*kplusp+1), 1) >*/
dcopy_(&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 >*/
*nev = nev0;
/*< np = np0 >*/
*np = np0;
/*< call dsgets (ishift, which, nev, np, ritz, bounds, workl) >*/
dsgets_(ishift, which, nev, np, &ritz[1], &bounds[1], &workl[1], (ftnlen)
2);
/* %-------------------% */
/* | Convergence test. | */
/* %-------------------% */
/*< call dcopy (nev, bounds(np+1), 1, workl(np+1), 1) >*/
dcopy_(nev, &bounds[*np + 1], &c__1, &workl[*np + 1], &c__1);
/*< call dsconv (nev, ritz(np+1), workl(np+1), tol, nconv) >*/
dsconv_(nev, &ritz[*np + 1], &workl[*np + 1], tol, &nconv);
/*< if (msglvl .gt. 2) then >*/
/* if (msglvl > 2) { */
/*< kp(1) = nev >*/
/* kp[0] = *nev; */
/*< kp(2) = np >*/
/* kp[1] = *np; */
/*< kp(3) = nconv >*/
/* kp[2] = nconv; */
/* call ivout (logfil, 3, kp, ndigit, */
/* & '_saup2: NEV, NP, NCONV are') */
/* call dvout (logfil, kplusp, ritz, ndigit, */
/* & '_saup2: The eigenvalues of H') */
/* call dvout (logfil, kplusp, bounds, ndigit, */
/* & '_saup2: Ritz estimates of the current NCV Ritz values') */
/*< end if >*/
/* } */
/* %---------------------------------------------------------% */
/* | 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 >*/
nptemp = *np;
/*< do 30 j=1, nptemp >*/
i__1 = nptemp;
for (j = 1; j <= i__1; ++j) {
/*< if (bounds(j) .eq. zero) then >*/
if (bounds[j] == 0.) {
/*< np = np - 1 >*/
--(*np);
/*< nev = nev + 1 >*/
++(*nev);
/*< end if >*/
}
/*< 30 continue >*/
/* 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 (which .eq. 'BE') then >*/
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. | */
/* %-----------------------------------------------------% */
/*< wprime = 'SA' >*/
s_copy(wprime, "SA", (ftnlen)2, (ftnlen)2);
/*< call dsortr (wprime, .true., kplusp, ritz, bounds) >*/
dsortr_(wprime, &c_true, &kplusp, &ritz[1], &bounds[1], (ftnlen)2)
;
/*< nevd2 = nev / 2 >*/
nevd2 = *nev / 2;
/*< nevm2 = nev - nevd2 >*/
nevm2 = *nev - nevd2;
/*< if ( nev .gt. 1 ) then >*/
if (*nev > 1) {
/*< >*/
i__1 = min(nevd2,*np);
/* Computing MAX */
i__2 = kplusp - nevd2 + 1, i__3 = kplusp - *np + 1;
dswap_(&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;
dswap_(&i__1, &bounds[nevm2 + 1], &c__1, &bounds[max(i__2,
i__3) + 1], &c__1);
/*< end if >*/
}
/*< else >*/
} 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 (which .eq. 'LM') wprime = 'SM' >*/
if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "SM", (ftnlen)2, (ftnlen)2);
}
/*< if (which .eq. 'SM') wprime = 'LM' >*/
if (s_cmp(which, "SM", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "LM", (ftnlen)2, (ftnlen)2);
}
/*< if (which .eq. 'LA') wprime = 'SA' >*/
if (s_cmp(which, "LA", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "SA", (ftnlen)2, (ftnlen)2);
}
/*< if (which .eq. 'SA') wprime = 'LA' >*/
if (s_cmp(which, "SA", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "LA", (ftnlen)2, (ftnlen)2);
}
/*< call dsortr (wprime, .true., kplusp, ritz, bounds) >*/
dsortr_(wprime, &c_true, &kplusp, &ritz[1], &bounds[1], (ftnlen)2)
;
/*< end if >*/
}
/* %--------------------------------------------------% */
/* | Scale the Ritz estimate of each Ritz value | */
/* | by 1 / max(eps23,magnitude of the Ritz value). | */
/* %--------------------------------------------------% */
/*< do 35 j = 1, nev0 >*/
i__1 = nev0;
for (j = 1; j <= i__1; ++j) {
/*< temp = max( eps23, abs(ritz(j)) ) >*/
/* Computing MAX */
d__2 = eps23, d__3 = (d__1 = ritz[j], abs(d__1));
temp = max(d__2,d__3);
/*< bounds(j) = bounds(j)/temp >*/
bounds[j] /= temp;
/*< 35 continue >*/
/* 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.) | */
/* %----------------------------------------------------% */
/*< wprime = 'LA' >*/
s_copy(wprime, "LA", (ftnlen)2, (ftnlen)2);
/*< call dsortr(wprime, .true., nev0, bounds, ritz) >*/
dsortr_(wprime, &c_true, &nev0, &bounds[1], &ritz[1], (ftnlen)2);
/* %----------------------------------------------% */
/* | Scale the Ritz estimate back to its original | */
/* | value. | */
/* %----------------------------------------------% */
/*< do 40 j = 1, nev0 >*/
i__1 = nev0;
for (j = 1; j <= i__1; ++j) {
/*< temp = max( eps23, abs(ritz(j)) ) >*/
/* Computing MAX */
d__2 = eps23, d__3 = (d__1 = ritz[j], abs(d__1));
temp = max(d__2,d__3);
/*< bounds(j) = bounds(j)*temp >*/
bounds[j] *= temp;
/*< 40 continue >*/
/* 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 (which .eq. 'BE') then >*/
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. | */
/* %------------------------------------------------% */
/*< wprime = 'LA' >*/
s_copy(wprime, "LA", (ftnlen)2, (ftnlen)2);
/*< call dsortr(wprime, .true., nconv, ritz, bounds) >*/
dsortr_(wprime, &c_true, &nconv, &ritz[1], &bounds[1], (ftnlen)2);
/*< else >*/
} 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. | */
/* %----------------------------------------------% */
/*< call dsortr(which, .true., nconv, ritz, bounds) >*/
dsortr_(which, &c_true, &nconv, &ritz[1], &bounds[1], (ftnlen)2);
/*< end if >*/
}
/* %------------------------------------------% */
/* | Use h( 1,1 ) as storage to communicate | */
/* | rnorm to _seupd if needed | */
/* %------------------------------------------% */
/*< h(1,1) = rnorm >*/
h__[h_dim1 + 1] = rnorm;
/* if (msglvl .gt. 1) then */
/* call dvout (logfil, kplusp, ritz, ndigit, */
/* & '_saup2: Sorted Ritz values.') */
/* call dvout (logfil, kplusp, bounds, ndigit, */
/* & '_saup2: Sorted ritz estimates.') */
/* end if */
/* %------------------------------------% */
/* | Max iterations have been exceeded. | */
/* %------------------------------------% */
/*< if (iter .gt. mxiter .and. nconv .lt. nev) info = 1 >*/
if (iter > *mxiter && nconv < *nev) {
*info = 1;
}
/* %---------------------% */
/* | No shifts to apply. | */
/* %---------------------% */
/*< if (np .eq. 0 .and. nconv .lt. nev0) info = 2 >*/
if (*np == 0 && nconv < nev0) {
*info = 2;
}
/*< np = nconv >*/
*np = nconv;
/*< go to 1100 >*/
goto L1100;
/*< else if (nconv .lt. nev .and. ishift .eq. 1) then >*/
} 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 >*/
nevbef = *nev;
/*< nev = nev + min (nconv, np/2) >*/
/* Computing MIN */
i__1 = nconv, i__2 = *np / 2;
*nev += min(i__1,i__2);
/*< if (nev .eq. 1 .and. kplusp .ge. 6) then >*/
if (*nev == 1 && kplusp >= 6) {
/*< nev = kplusp / 2 >*/
*nev = kplusp / 2;
/*< else if (nev .eq. 1 .and. kplusp .gt. 2) then >*/
} else if (*nev == 1 && kplusp > 2) {
/*< nev = 2 >*/
*nev = 2;
/*< end if >*/
}
/*< np = kplusp - nev >*/
*np = kplusp - *nev;
/* %---------------------------------------% */
/* | If the size of NEV was just increased | */
/* | resort the eigenvalues. | */
/* %---------------------------------------% */
/*< >*/
if (nevbef < *nev) {
dsgets_(ishift, which, nev, np, &ritz[1], &bounds[1], &workl[1], (
ftnlen)2);
}
/*< end if >*/
}
/*< if (msglvl .gt. 0) then >*/
/* if (msglvl > 0) { */
/* call ivout (logfil, 1, nconv, ndigit, */
/* & '_saup2: no. of "converged" Ritz values at this iter.') */
/*< if (msglvl .gt. 1) then >*/
/* if (msglvl > 1) { */
/*< kp(1) = nev >*/
/* kp[0] = *nev; */
/*< kp(2) = np >*/
/* kp[1] = *np; */
/* call ivout (logfil, 2, kp, ndigit, */
/* & '_saup2: NEV and NP are') */
/* call dvout (logfil, nev, ritz(np+1), ndigit, */
/* & '_saup2: "wanted" Ritz values.') */
/* call dvout (logfil, nev, bounds(np+1), ndigit, */
/* & '_saup2: Ritz estimates of the "wanted" values ') */
/*< end if >*/
/* } */
/*< end if >*/
/* } */
/*< if (ishift .eq. 0) then >*/
if (*ishift == 0) {
/* %-----------------------------------------------------% */
/* | User specified shifts: reverse communication to | */
/* | compute the shifts. They are returned in the first | */
/* | NP locations of WORKL. | */
/* %-----------------------------------------------------% */
/*< ushift = .true. >*/
ushift = TRUE_;
/*< ido = 3 >*/
*ido = 3;
/*< go to 9000 >*/
goto L9000;
/*< end if >*/
}
/*< 50 continue >*/
L50:
/* %------------------------------------% */
/* | Back from reverse communication; | */
/* | User specified shifts are returned | */
/* | in WORKL(1:*NP) | */
/* %------------------------------------% */
/*< ushift = .false. >*/
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 .eq. 0) call dcopy (np, workl, 1, ritz, 1) >*/
if (*ishift == 0) {
dcopy_(np, &workl[1], &c__1, &ritz[1], &c__1);
}
/* if (msglvl .gt. 2) then */
/* call ivout (logfil, 1, np, ndigit, */
/* & '_saup2: The number of shifts to apply ') */
/* call dvout (logfil, np, workl, ndigit, */
/* & '_saup2: shifts selected') */
/* if (ishift .eq. 1) then */
/* call dvout (logfil, np, bounds, ndigit, */
/* & '_saup2: corresponding Ritz estimates') */
/* end if */
/* end if */
/* %---------------------------------------------------------% */
/* | 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. | */
/* %---------------------------------------------------------% */
/*< >*/
dsapps_(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. >*/
cnorm = TRUE_;
/*< call second (t2) >*/
/* second_(&t2); */
/*< if (bmat .eq. 'G') then >*/
if (*(unsigned char *)bmat == 'G') {
/*< nbx = nbx + 1 >*/
/* ++timing_1.nbx; */
/*< call dcopy (n, resid, 1, workd(n+1), 1) >*/
dcopy_(n, &resid[1], &c__1, &workd[*n + 1], &c__1);
/*< ipntr(1) = n + 1 >*/
ipntr[1] = *n + 1;
/*< ipntr(2) = 1 >*/
ipntr[2] = 1;
/*< ido = 2 >*/
*ido = 2;
/* %----------------------------------% */
/* | Exit in order to compute B*RESID | */
/* %----------------------------------% */
/*< go to 9000 >*/
goto L9000;
/*< else if (bmat .eq. 'I') then >*/
} else if (*(unsigned char *)bmat == 'I') {
/*< call dcopy (n, resid, 1, workd, 1) >*/
dcopy_(n, &resid[1], &c__1, &workd[1], &c__1);
/*< end if >*/
}
/*< 100 continue >*/
L100:
/* %----------------------------------% */
/* | Back from reverse communication; | */
/* | WORKD(1:N) := B*RESID | */
/* %----------------------------------% */
/*< if (bmat .eq. 'G') then >*/
if (*(unsigned char *)bmat == 'G') {
/*< call second (t3) >*/
/* second_(&t3); */
/*< tmvbx = tmvbx + (t3 - t2) >*/
/* timing_1.tmvbx += t3 - t2; */
/*< end if >*/
}
/*< if (bmat .eq. 'G') then >*/
if (*(unsigned char *)bmat == 'G') {
/*< rnorm = ddot (n, resid, 1, workd, 1) >*/
rnorm = ddot_(n, &resid[1], &c__1, &workd[1], &c__1);
/*< rnorm = sqrt(abs(rnorm)) >*/
rnorm = sqrt((abs(rnorm)));
/*< else if (bmat .eq. 'I') then >*/
} else if (*(unsigned char *)bmat == 'I') {
/*< rnorm = dnrm2(n, resid, 1) >*/
rnorm = dnrm2_(n, &resid[1], &c__1);
/*< end if >*/
}
/*< cnorm = .false. >*/
cnorm = FALSE_;
/*< 130 continue >*/
/* L130: */
/* if (msglvl .gt. 2) then */
/* call dvout (logfil, 1, rnorm, ndigit, */
/* & '_saup2: B-norm of residual for NEV factorization') */
/* call dvout (logfil, nev, h(1,2), ndigit, */
/* & '_saup2: main diagonal of compressed H matrix') */
/* call dvout (logfil, nev-1, h(2,1), ndigit, */
/* & '_saup2: subdiagonal of compressed H matrix') */
/* end if */
/*< go to 1000 >*/
goto L1000;
/* %---------------------------------------------------------------% */
/* | | */
/* | E N D O F M A I N I T E R A T I O N L O O P | */
/* | | */
/* %---------------------------------------------------------------% */
/*< 1100 continue >*/
L1100:
/*< mxiter = iter >*/
*mxiter = iter;
/*< nev = nconv >*/
*nev = nconv;
/*< 1200 continue >*/
L1200:
/*< ido = 99 >*/
*ido = 99;
/* %------------% */
/* | Error exit | */
/* %------------% */
/*< call second (t1) >*/
/* second_(&t1); */
/*< tsaup2 = t1 - t0 >*/
/* timing_1.tsaup2 = t1 - t0; */
/*< 9000 continue >*/
L9000:
/*< return >*/
return 0;
/* %---------------% */
/* | End of dsaup2 | */
/* %---------------% */
/*< end >*/
} /* dsaup2_ */
