/* 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 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_ */