/* Subroutine */ int snaitr_(integer *ido, char *bmat, integer *n, integer *k, integer *np, integer *nb, real *resid, real *rnorm, real *v, integer *ldv, real *h__, integer *ldh, integer *ipntr, real *workd, integer * info, ftnlen bmat_len) { /* Initialized data */ static logical first = TRUE_; /* System generated locals */ integer h_dim1, h_offset, v_dim1, v_offset, i__1, i__2; real r__1, r__2; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static integer i__, j; static real t0, t1, t2, t3, t4, t5; static integer jj, ipj, irj, ivj; static real ulp, tst1; static integer ierr, iter; static real unfl, ovfl; extern doublereal sdot_(integer *, real *, integer *, real *, integer *); static integer itry; static real temp1; static logical orth1, orth2, step3, step4; extern doublereal snrm2_(integer *, real *, integer *); static real betaj; extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); static integer infol; extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *, ftnlen); static real xtemp[2]; extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, integer *); static real wnorm; extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *, real *, integer *), ivout_(integer *, integer *, integer *, integer *, char *, ftnlen), smout_(integer *, integer *, integer * , real *, integer *, integer *, char *, ftnlen), svout_(integer *, integer *, real *, integer *, char *, ftnlen), sgetv0_(integer *, char *, integer *, logical *, integer *, integer *, real *, integer *, real *, real *, integer *, real *, integer *, ftnlen); static real rnorm1; extern /* Subroutine */ int slabad_(real *, real *); extern doublereal slamch_(char *, ftnlen); extern /* Subroutine */ int second_(real *), slascl_(char *, integer *, integer *, real *, real *, integer *, integer *, real *, integer * , integer *, ftnlen); static logical rstart; static integer msglvl; static real smlnum; extern doublereal slanhs_(char *, integer *, real *, integer *, real *, 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 | */ /* %---------------% */ /* %-----------------------% */ /* | Local Array Arguments | */ /* %-----------------------% */ /* %----------------------% */ /* | External Subroutines | */ /* %----------------------% */ /* %--------------------% */ /* | External Functions | */ /* %--------------------% */ /* %---------------------% */ /* | Intrinsic Functions | */ /* %---------------------% */ /* %-----------------% */ /* | Data statements | */ /* %-----------------% */ /* Parameter adjustments */ --workd; --resid; v_dim1 = *ldv; v_offset = 1 + v_dim1; v -= v_offset; h_dim1 = *ldh; h_offset = 1 + h_dim1; h__ -= h_offset; --ipntr; /* Function Body */ /* %-----------------------% */ /* | Executable Statements | */ /* %-----------------------% */ if (first) { /* %-----------------------------------------% */ /* | Set machine-dependent constants for the | */ /* | the splitting and deflation criterion. | */ /* | If norm(H) <= sqrt(OVFL), | */ /* | overflow should not occur. | */ /* | REFERENCE: LAPACK subroutine slahqr | */ /* %-----------------------------------------% */ unfl = slamch_("safe minimum", (ftnlen)12); ovfl = 1.f / unfl; slabad_(&unfl, &ovfl); ulp = slamch_("precision", (ftnlen)9); smlnum = unfl * (*n / ulp); first = FALSE_; } if (*ido == 0) { /* %-------------------------------% */ /* | Initialize timing statistics | */ /* | & message level for debugging | */ /* %-------------------------------% */ second_(&t0); msglvl = debug_1.mnaitr; /* %------------------------------% */ /* | Initial call to this routine | */ /* %------------------------------% */ *info = 0; step3 = FALSE_; step4 = FALSE_; rstart = FALSE_; orth1 = FALSE_; orth2 = FALSE_; j = *k + 1; ipj = 1; irj = ipj + *n; ivj = irj + *n; } /* %-------------------------------------------------% */ /* | When in reverse communication mode one of: | */ /* | STEP3, STEP4, ORTH1, ORTH2, RSTART | */ /* | will be .true. when .... | */ /* | STEP3: return from computing OP*v_{j}. | */ /* | STEP4: return from computing B-norm of OP*v_{j} | */ /* | ORTH1: return from computing B-norm of r_{j+1} | */ /* | ORTH2: return from computing B-norm of | */ /* | correction to the residual vector. | */ /* | RSTART: return from OP computations needed by | */ /* | sgetv0. | */ /* %-------------------------------------------------% */ if (step3) { goto L50; } if (step4) { goto L60; } if (orth1) { goto L70; } if (orth2) { goto L90; } if (rstart) { goto L30; } /* %-----------------------------% */ /* | Else this is the first step | */ /* %-----------------------------% */ /* %--------------------------------------------------------------% */ /* | | */ /* | A R N O L D I I T E R A T I O N L O O P | */ /* | | */ /* | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | */ /* %--------------------------------------------------------------% */ L1000: if (msglvl > 1) { ivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: generat" "ing Arnoldi vector number", (ftnlen)40); svout_(&debug_1.logfil, &c__1, rnorm, &debug_1.ndigit, "_naitr: B-no" "rm of the current residual is", (ftnlen)41); } /* %---------------------------------------------------% */ /* | STEP 1: Check if the B norm of j-th residual | */ /* | vector is zero. Equivalent to determing whether | */ /* | an exact j-step Arnoldi factorization is present. | */ /* %---------------------------------------------------% */ betaj = *rnorm; if (*rnorm > 0.f) { goto L40; } /* %---------------------------------------------------% */ /* | Invariant subspace found, generate a new starting | */ /* | vector which is orthogonal to the current Arnoldi | */ /* | basis and continue the iteration. | */ /* %---------------------------------------------------% */ if (msglvl > 0) { ivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: ****** " "RESTART AT STEP ******", (ftnlen)37); } /* %---------------------------------------------% */ /* | ITRY is the loop variable that controls the | */ /* | maximum amount of times that a restart is | */ /* | attempted. NRSTRT is used by stat.h | */ /* %---------------------------------------------% */ betaj = 0.f; ++timing_1.nrstrt; itry = 1; L20: rstart = TRUE_; *ido = 0; L30: /* %--------------------------------------% */ /* | If in reverse communication mode and | */ /* | RSTART = .true. flow returns here. | */ /* %--------------------------------------% */ sgetv0_(ido, bmat, &itry, &c_false, n, &j, &v[v_offset], ldv, &resid[1], rnorm, &ipntr[1], &workd[1], &ierr, (ftnlen)1); if (*ido != 99) { goto L9000; } if (ierr < 0) { ++itry; if (itry <= 3) { goto L20; } /* %------------------------------------------------% */ /* | Give up after several restart attempts. | */ /* | Set INFO to the size of the invariant subspace | */ /* | which spans OP and exit. | */ /* %------------------------------------------------% */ *info = j - 1; second_(&t1); timing_1.tnaitr += t1 - t0; *ido = 99; goto L9000; } L40: /* %---------------------------------------------------------% */ /* | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | */ /* | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | */ /* | when reciprocating a small RNORM, test against lower | */ /* | machine bound. | */ /* %---------------------------------------------------------% */ scopy_(n, &resid[1], &c__1, &v[j * v_dim1 + 1], &c__1); if (*rnorm >= unfl) { temp1 = 1.f / *rnorm; sscal_(n, &temp1, &v[j * v_dim1 + 1], &c__1); sscal_(n, &temp1, &workd[ipj], &c__1); } else { /* %-----------------------------------------% */ /* | To scale both v_{j} and p_{j} carefully | */ /* | use LAPACK routine SLASCL | */ /* %-----------------------------------------% */ slascl_("General", &i__, &i__, rnorm, &c_b25, n, &c__1, &v[j * v_dim1 + 1], n, &infol, (ftnlen)7); slascl_("General", &i__, &i__, rnorm, &c_b25, n, &c__1, &workd[ipj], n, &infol, (ftnlen)7); } /* %------------------------------------------------------% */ /* | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | */ /* | Note that this is not quite yet r_{j}. See STEP 4 | */ /* %------------------------------------------------------% */ step3 = TRUE_; ++timing_1.nopx; second_(&t2); scopy_(n, &v[j * v_dim1 + 1], &c__1, &workd[ivj], &c__1); ipntr[1] = ivj; ipntr[2] = irj; ipntr[3] = ipj; *ido = 1; /* %-----------------------------------% */ /* | Exit in order to compute OP*v_{j} | */ /* %-----------------------------------% */ goto L9000; L50: /* %----------------------------------% */ /* | Back from reverse communication; | */ /* | WORKD(IRJ:IRJ+N-1) := OP*v_{j} | */ /* | if step3 = .true. | */ /* %----------------------------------% */ second_(&t3); timing_1.tmvopx += t3 - t2; step3 = FALSE_; /* %------------------------------------------% */ /* | Put another copy of OP*v_{j} into RESID. | */ /* %------------------------------------------% */ scopy_(n, &workd[irj], &c__1, &resid[1], &c__1); /* %---------------------------------------% */ /* | STEP 4: Finish extending the Arnoldi | */ /* | factorization to length j. | */ /* %---------------------------------------% */ second_(&t2); if (*(unsigned char *)bmat == 'G') { ++timing_1.nbx; step4 = TRUE_; ipntr[1] = irj; ipntr[2] = ipj; *ido = 2; /* %-------------------------------------% */ /* | Exit in order to compute B*OP*v_{j} | */ /* %-------------------------------------% */ goto L9000; } else if (*(unsigned char *)bmat == 'I') { scopy_(n, &resid[1], &c__1, &workd[ipj], &c__1); } L60: /* %----------------------------------% */ /* | Back from reverse communication; | */ /* | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} | */ /* | if step4 = .true. | */ /* %----------------------------------% */ if (*(unsigned char *)bmat == 'G') { second_(&t3); timing_1.tmvbx += t3 - t2; } step4 = FALSE_; /* %-------------------------------------% */ /* | The following is needed for STEP 5. | */ /* | Compute the B-norm of OP*v_{j}. | */ /* %-------------------------------------% */ if (*(unsigned char *)bmat == 'G') { wnorm = sdot_(n, &resid[1], &c__1, &workd[ipj], &c__1); wnorm = sqrt((dabs(wnorm))); } else if (*(unsigned char *)bmat == 'I') { wnorm = snrm2_(n, &resid[1], &c__1); } /* %-----------------------------------------% */ /* | Compute the j-th residual corresponding | */ /* | to the j step factorization. | */ /* | Use Classical Gram Schmidt and compute: | */ /* | w_{j} <- V_{j}^T * B * OP * v_{j} | */ /* | r_{j} <- OP*v_{j} - V_{j} * w_{j} | */ /* %-----------------------------------------% */ /* %------------------------------------------% */ /* | Compute the j Fourier coefficients w_{j} | */ /* | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | */ /* %------------------------------------------% */ sgemv_("T", n, &j, &c_b25, &v[v_offset], ldv, &workd[ipj], &c__1, &c_b47, &h__[j * h_dim1 + 1], &c__1, (ftnlen)1); /* %--------------------------------------% */ /* | Orthogonalize r_{j} against V_{j}. | */ /* | RESID contains OP*v_{j}. See STEP 3. | */ /* %--------------------------------------% */ sgemv_("N", n, &j, &c_b50, &v[v_offset], ldv, &h__[j * h_dim1 + 1], &c__1, &c_b25, &resid[1], &c__1, (ftnlen)1); if (j > 1) { h__[j + (j - 1) * h_dim1] = betaj; } second_(&t4); orth1 = TRUE_; second_(&t2); if (*(unsigned char *)bmat == 'G') { ++timing_1.nbx; scopy_(n, &resid[1], &c__1, &workd[irj], &c__1); ipntr[1] = irj; ipntr[2] = ipj; *ido = 2; /* %----------------------------------% */ /* | Exit in order to compute B*r_{j} | */ /* %----------------------------------% */ goto L9000; } else if (*(unsigned char *)bmat == 'I') { scopy_(n, &resid[1], &c__1, &workd[ipj], &c__1); } L70: /* %---------------------------------------------------% */ /* | Back from reverse communication if ORTH1 = .true. | */ /* | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | */ /* %---------------------------------------------------% */ if (*(unsigned char *)bmat == 'G') { second_(&t3); timing_1.tmvbx += t3 - t2; } orth1 = FALSE_; /* %------------------------------% */ /* | Compute the B-norm of r_{j}. | */ /* %------------------------------% */ if (*(unsigned char *)bmat == 'G') { *rnorm = sdot_(n, &resid[1], &c__1, &workd[ipj], &c__1); *rnorm = sqrt((dabs(*rnorm))); } else if (*(unsigned char *)bmat == 'I') { *rnorm = snrm2_(n, &resid[1], &c__1); } /* %-----------------------------------------------------------% */ /* | STEP 5: Re-orthogonalization / Iterative refinement phase | */ /* | Maximum NITER_ITREF tries. | */ /* | | */ /* | s = V_{j}^T * B * r_{j} | */ /* | r_{j} = r_{j} - V_{j}*s | */ /* | alphaj = alphaj + s_{j} | */ /* | | */ /* | The stopping criteria used for iterative refinement is | */ /* | discussed in Parlett's book SEP, page 107 and in Gragg & | */ /* | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | */ /* | Determine if we need to correct the residual. The goal is | */ /* | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | */ /* | The following test determines whether the sine of the | */ /* | angle between OP*x and the computed residual is less | */ /* | than or equal to 0.717. | */ /* %-----------------------------------------------------------% */ if (*rnorm > wnorm * .717f) { goto L100; } iter = 0; ++timing_1.nrorth; /* %---------------------------------------------------% */ /* | Enter the Iterative refinement phase. If further | */ /* | refinement is necessary, loop back here. The loop | */ /* | variable is ITER. Perform a step of Classical | */ /* | Gram-Schmidt using all the Arnoldi vectors V_{j} | */ /* %---------------------------------------------------% */ L80: if (msglvl > 2) { xtemp[0] = wnorm; xtemp[1] = *rnorm; svout_(&debug_1.logfil, &c__2, xtemp, &debug_1.ndigit, "_naitr: re-o" "rthonalization; wnorm and rnorm are", (ftnlen)47); svout_(&debug_1.logfil, &j, &h__[j * h_dim1 + 1], &debug_1.ndigit, "_naitr: j-th column of H", (ftnlen)24); } /* %----------------------------------------------------% */ /* | Compute V_{j}^T * B * r_{j}. | */ /* | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | */ /* %----------------------------------------------------% */ sgemv_("T", n, &j, &c_b25, &v[v_offset], ldv, &workd[ipj], &c__1, &c_b47, &workd[irj], &c__1, (ftnlen)1); /* %---------------------------------------------% */ /* | Compute the correction to the residual: | */ /* | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | */ /* | The correction to H is v(:,1:J)*H(1:J,1:J) | */ /* | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. | */ /* %---------------------------------------------% */ sgemv_("N", n, &j, &c_b50, &v[v_offset], ldv, &workd[irj], &c__1, &c_b25, &resid[1], &c__1, (ftnlen)1); saxpy_(&j, &c_b25, &workd[irj], &c__1, &h__[j * h_dim1 + 1], &c__1); orth2 = TRUE_; second_(&t2); if (*(unsigned char *)bmat == 'G') { ++timing_1.nbx; scopy_(n, &resid[1], &c__1, &workd[irj], &c__1); ipntr[1] = irj; ipntr[2] = ipj; *ido = 2; /* %-----------------------------------% */ /* | Exit in order to compute B*r_{j}. | */ /* | r_{j} is the corrected residual. | */ /* %-----------------------------------% */ goto L9000; } else if (*(unsigned char *)bmat == 'I') { scopy_(n, &resid[1], &c__1, &workd[ipj], &c__1); } L90: /* %---------------------------------------------------% */ /* | Back from reverse communication if ORTH2 = .true. | */ /* %---------------------------------------------------% */ if (*(unsigned char *)bmat == 'G') { second_(&t3); timing_1.tmvbx += t3 - t2; } /* %-----------------------------------------------------% */ /* | Compute the B-norm of the corrected residual r_{j}. | */ /* %-----------------------------------------------------% */ if (*(unsigned char *)bmat == 'G') { rnorm1 = sdot_(n, &resid[1], &c__1, &workd[ipj], &c__1); rnorm1 = sqrt((dabs(rnorm1))); } else if (*(unsigned char *)bmat == 'I') { rnorm1 = snrm2_(n, &resid[1], &c__1); } if (msglvl > 0 && iter > 0) { ivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: Iterati" "ve refinement for Arnoldi residual", (ftnlen)49); if (msglvl > 2) { xtemp[0] = *rnorm; xtemp[1] = rnorm1; svout_(&debug_1.logfil, &c__2, xtemp, &debug_1.ndigit, "_naitr: " "iterative refinement ; rnorm and rnorm1 are", (ftnlen)51); } } /* %-----------------------------------------% */ /* | Determine if we need to perform another | */ /* | step of re-orthogonalization. | */ /* %-----------------------------------------% */ if (rnorm1 > *rnorm * .717f) { /* %---------------------------------------% */ /* | No need for further refinement. | */ /* | The cosine of the angle between the | */ /* | corrected residual vector and the old | */ /* | residual vector is greater than 0.717 | */ /* | In other words the corrected residual | */ /* | and the old residual vector share an | */ /* | angle of less than arcCOS(0.717) | */ /* %---------------------------------------% */ *rnorm = rnorm1; } else { /* %-------------------------------------------% */ /* | Another step of iterative refinement step | */ /* | is required. NITREF is used by stat.h | */ /* %-------------------------------------------% */ ++timing_1.nitref; *rnorm = rnorm1; ++iter; if (iter <= 1) { goto L80; } /* %-------------------------------------------------% */ /* | Otherwise RESID is numerically in the span of V | */ /* %-------------------------------------------------% */ i__1 = *n; for (jj = 1; jj <= i__1; ++jj) { resid[jj] = 0.f; /* L95: */ } *rnorm = 0.f; } /* %----------------------------------------------% */ /* | Branch here directly if iterative refinement | */ /* | wasn't necessary or after at most NITER_REF | */ /* | steps of iterative refinement. | */ /* %----------------------------------------------% */ L100: rstart = FALSE_; orth2 = FALSE_; second_(&t5); timing_1.titref += t5 - t4; /* %------------------------------------% */ /* | STEP 6: Update j = j+1; Continue | */ /* %------------------------------------% */ ++j; if (j > *k + *np) { second_(&t1); timing_1.tnaitr += t1 - t0; *ido = 99; i__1 = *k + *np - 1; for (i__ = max(1,*k); i__ <= i__1; ++i__) { /* %--------------------------------------------% */ /* | Check for splitting and deflation. | */ /* | Use a standard test as in the QR algorithm | */ /* | REFERENCE: LAPACK subroutine slahqr | */ /* %--------------------------------------------% */ tst1 = (r__1 = h__[i__ + i__ * h_dim1], dabs(r__1)) + (r__2 = h__[ i__ + 1 + (i__ + 1) * h_dim1], dabs(r__2)); if (tst1 == 0.f) { i__2 = *k + *np; tst1 = slanhs_("1", &i__2, &h__[h_offset], ldh, &workd[*n + 1] , (ftnlen)1); } /* Computing MAX */ r__2 = ulp * tst1; if ((r__1 = h__[i__ + 1 + i__ * h_dim1], dabs(r__1)) <= dmax(r__2, smlnum)) { h__[i__ + 1 + i__ * h_dim1] = 0.f; } /* L110: */ } if (msglvl > 2) { i__1 = *k + *np; i__2 = *k + *np; smout_(&debug_1.logfil, &i__1, &i__2, &h__[h_offset], ldh, & debug_1.ndigit, "_naitr: Final upper Hessenberg matrix H" " of order K+NP", (ftnlen)53); } goto L9000; } /* %--------------------------------------------------------% */ /* | Loop back to extend the factorization by another step. | */ /* %--------------------------------------------------------% */ goto L1000; /* %---------------------------------------------------------------% */ /* | | */ /* | E N D O F M A I N I T E R A T I O N L O O P | */ /* | | */ /* %---------------------------------------------------------------% */ L9000: return 0; /* %---------------% */ /* | End of snaitr | */ /* %---------------% */ } /* snaitr_ */
/* Subroutine */ int ssapps_(integer *n, integer *kev, integer *np, real * shift, real *v, integer *ldv, real *h__, integer *ldh, real *resid, real *q, integer *ldq, real *workd) { /* Initialized data */ static logical first = TRUE_; /* System generated locals */ integer h_dim1, h_offset, q_dim1, q_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4; real r__1, r__2; /* Local variables */ static real c__, f, g; static integer i__, j; static real r__, s, a1, a2, a3, a4, t0, t1; static integer jj; static real big; static integer iend, itop; extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), sgemv_(char *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *, ftnlen), scopy_( integer *, real *, integer *, real *, integer *), saxpy_(integer * , real *, real *, integer *, real *, integer *), ivout_(integer *, integer *, integer *, integer *, char *, ftnlen), svout_(integer *, integer *, real *, integer *, char *, ftnlen); extern doublereal slamch_(char *, ftnlen); extern /* Subroutine */ int arscnd_(real *); static real epsmch; static integer istart, kplusp, msglvl; extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *, ftnlen), slartg_(real *, real *, real *, real *, real *), slaset_(char *, integer *, integer *, real *, real *, real *, integer *, 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 | */ /* %--------------------% */ /* %----------------------% */ /* | Intrinsics Functions | */ /* %----------------------% */ /* %----------------% */ /* | Data statments | */ /* %----------------% */ /* Parameter adjustments */ --workd; --resid; --shift; v_dim1 = *ldv; v_offset = 1 + v_dim1; v -= v_offset; h_dim1 = *ldh; h_offset = 1 + h_dim1; h__ -= h_offset; q_dim1 = *ldq; q_offset = 1 + q_dim1; q -= q_offset; /* Function Body */ /* %-----------------------% */ /* | Executable Statements | */ /* %-----------------------% */ if (first) { epsmch = slamch_("Epsilon-Machine", (ftnlen)15); first = FALSE_; } itop = 1; /* %-------------------------------% */ /* | Initialize timing statistics | */ /* | & message level for debugging | */ /* %-------------------------------% */ arscnd_(&t0); msglvl = debug_1.msapps; kplusp = *kev + *np; /* %----------------------------------------------% */ /* | Initialize Q to the identity matrix of order | */ /* | kplusp used to accumulate the rotations. | */ /* %----------------------------------------------% */ slaset_("All", &kplusp, &kplusp, &c_b4, &c_b5, &q[q_offset], ldq, (ftnlen) 3); /* %----------------------------------------------% */ /* | Quick return if there are no shifts to apply | */ /* %----------------------------------------------% */ if (*np == 0) { goto L9000; } /* %----------------------------------------------------------% */ /* | Apply the np shifts implicitly. Apply each shift to the | */ /* | whole matrix and not just to the submatrix from which it | */ /* | comes. | */ /* %----------------------------------------------------------% */ i__1 = *np; for (jj = 1; jj <= i__1; ++jj) { istart = itop; /* %----------------------------------------------------------% */ /* | Check for splitting and deflation. Currently we consider | */ /* | an off-diagonal element h(i+1,1) negligible if | */ /* | h(i+1,1) .le. epsmch*( |h(i,2)| + |h(i+1,2)| ) | */ /* | for i=1:KEV+NP-1. | */ /* | If above condition tests true then we set h(i+1,1) = 0. | */ /* | Note that h(1:KEV+NP,1) are assumed to be non negative. | */ /* %----------------------------------------------------------% */ L20: /* %------------------------------------------------% */ /* | The following loop exits early if we encounter | */ /* | a negligible off diagonal element. | */ /* %------------------------------------------------% */ i__2 = kplusp - 1; for (i__ = istart; i__ <= i__2; ++i__) { big = (r__1 = h__[i__ + (h_dim1 << 1)], dabs(r__1)) + (r__2 = h__[ i__ + 1 + (h_dim1 << 1)], dabs(r__2)); if (h__[i__ + 1 + h_dim1] <= epsmch * big) { if (msglvl > 0) { ivout_(&debug_1.logfil, &c__1, &i__, &debug_1.ndigit, "_sapps: deflation at row/column no.", (ftnlen)35) ; ivout_(&debug_1.logfil, &c__1, &jj, &debug_1.ndigit, "_sapps: occured before shift number.", (ftnlen) 36); svout_(&debug_1.logfil, &c__1, &h__[i__ + 1 + h_dim1], & debug_1.ndigit, "_sapps: the corresponding off d" "iagonal element", (ftnlen)46); } h__[i__ + 1 + h_dim1] = 0.f; iend = i__; goto L40; } /* L30: */ } iend = kplusp; L40: if (istart < iend) { /* %--------------------------------------------------------% */ /* | Construct the plane rotation G'(istart,istart+1,theta) | */ /* | that attempts to drive h(istart+1,1) to zero. | */ /* %--------------------------------------------------------% */ f = h__[istart + (h_dim1 << 1)] - shift[jj]; g = h__[istart + 1 + h_dim1]; slartg_(&f, &g, &c__, &s, &r__); /* %-------------------------------------------------------% */ /* | Apply rotation to the left and right of H; | */ /* | H <- G' * H * G, where G = G(istart,istart+1,theta). | */ /* | This will create a "bulge". | */ /* %-------------------------------------------------------% */ a1 = c__ * h__[istart + (h_dim1 << 1)] + s * h__[istart + 1 + h_dim1]; a2 = c__ * h__[istart + 1 + h_dim1] + s * h__[istart + 1 + ( h_dim1 << 1)]; a4 = c__ * h__[istart + 1 + (h_dim1 << 1)] - s * h__[istart + 1 + h_dim1]; a3 = c__ * h__[istart + 1 + h_dim1] - s * h__[istart + (h_dim1 << 1)]; h__[istart + (h_dim1 << 1)] = c__ * a1 + s * a2; h__[istart + 1 + (h_dim1 << 1)] = c__ * a4 - s * a3; h__[istart + 1 + h_dim1] = c__ * a3 + s * a4; /* %----------------------------------------------------% */ /* | Accumulate the rotation in the matrix Q; Q <- Q*G | */ /* %----------------------------------------------------% */ /* Computing MIN */ i__3 = istart + jj; i__2 = min(i__3,kplusp); for (j = 1; j <= i__2; ++j) { a1 = c__ * q[j + istart * q_dim1] + s * q[j + (istart + 1) * q_dim1]; q[j + (istart + 1) * q_dim1] = -s * q[j + istart * q_dim1] + c__ * q[j + (istart + 1) * q_dim1]; q[j + istart * q_dim1] = a1; /* L60: */ } /* %----------------------------------------------% */ /* | The following loop chases the bulge created. | */ /* | Note that the previous rotation may also be | */ /* | done within the following loop. But it is | */ /* | kept separate to make the distinction among | */ /* | the bulge chasing sweeps and the first plane | */ /* | rotation designed to drive h(istart+1,1) to | */ /* | zero. | */ /* %----------------------------------------------% */ i__2 = iend - 1; for (i__ = istart + 1; i__ <= i__2; ++i__) { /* %----------------------------------------------% */ /* | Construct the plane rotation G'(i,i+1,theta) | */ /* | that zeros the i-th bulge that was created | */ /* | by G(i-1,i,theta). g represents the bulge. | */ /* %----------------------------------------------% */ f = h__[i__ + h_dim1]; g = s * h__[i__ + 1 + h_dim1]; /* %----------------------------------% */ /* | Final update with G(i-1,i,theta) | */ /* %----------------------------------% */ h__[i__ + 1 + h_dim1] = c__ * h__[i__ + 1 + h_dim1]; slartg_(&f, &g, &c__, &s, &r__); /* %-------------------------------------------% */ /* | The following ensures that h(1:iend-1,1), | */ /* | the first iend-2 off diagonal of elements | */ /* | H, remain non negative. | */ /* %-------------------------------------------% */ if (r__ < 0.f) { r__ = -r__; c__ = -c__; s = -s; } /* %--------------------------------------------% */ /* | Apply rotation to the left and right of H; | */ /* | H <- G * H * G', where G = G(i,i+1,theta) | */ /* %--------------------------------------------% */ h__[i__ + h_dim1] = r__; a1 = c__ * h__[i__ + (h_dim1 << 1)] + s * h__[i__ + 1 + h_dim1]; a2 = c__ * h__[i__ + 1 + h_dim1] + s * h__[i__ + 1 + (h_dim1 << 1)]; a3 = c__ * h__[i__ + 1 + h_dim1] - s * h__[i__ + (h_dim1 << 1) ]; a4 = c__ * h__[i__ + 1 + (h_dim1 << 1)] - s * h__[i__ + 1 + h_dim1]; h__[i__ + (h_dim1 << 1)] = c__ * a1 + s * a2; h__[i__ + 1 + (h_dim1 << 1)] = c__ * a4 - s * a3; h__[i__ + 1 + h_dim1] = c__ * a3 + s * a4; /* %----------------------------------------------------% */ /* | Accumulate the rotation in the matrix Q; Q <- Q*G | */ /* %----------------------------------------------------% */ /* Computing MIN */ i__4 = i__ + jj; i__3 = min(i__4,kplusp); for (j = 1; j <= i__3; ++j) { a1 = c__ * q[j + i__ * q_dim1] + s * q[j + (i__ + 1) * q_dim1]; q[j + (i__ + 1) * q_dim1] = -s * q[j + i__ * q_dim1] + c__ * q[j + (i__ + 1) * q_dim1]; q[j + i__ * q_dim1] = a1; /* L50: */ } /* L70: */ } } /* %--------------------------% */ /* | Update the block pointer | */ /* %--------------------------% */ istart = iend + 1; /* %------------------------------------------% */ /* | Make sure that h(iend,1) is non-negative | */ /* | If not then set h(iend,1) <-- -h(iend,1) | */ /* | and negate the last column of Q. | */ /* | We have effectively carried out a | */ /* | similarity on transformation H | */ /* %------------------------------------------% */ if (h__[iend + h_dim1] < 0.f) { h__[iend + h_dim1] = -h__[iend + h_dim1]; sscal_(&kplusp, &c_b20, &q[iend * q_dim1 + 1], &c__1); } /* %--------------------------------------------------------% */ /* | Apply the same shift to the next block if there is any | */ /* %--------------------------------------------------------% */ if (iend < kplusp) { goto L20; } /* %-----------------------------------------------------% */ /* | Check if we can increase the the start of the block | */ /* %-----------------------------------------------------% */ i__2 = kplusp - 1; for (i__ = itop; i__ <= i__2; ++i__) { if (h__[i__ + 1 + h_dim1] > 0.f) { goto L90; } ++itop; /* L80: */ } /* %-----------------------------------% */ /* | Finished applying the jj-th shift | */ /* %-----------------------------------% */ L90: ; } /* %------------------------------------------% */ /* | All shifts have been applied. Check for | */ /* | more possible deflation that might occur | */ /* | after the last shift is applied. | */ /* %------------------------------------------% */ i__1 = kplusp - 1; for (i__ = itop; i__ <= i__1; ++i__) { big = (r__1 = h__[i__ + (h_dim1 << 1)], dabs(r__1)) + (r__2 = h__[i__ + 1 + (h_dim1 << 1)], dabs(r__2)); if (h__[i__ + 1 + h_dim1] <= epsmch * big) { if (msglvl > 0) { ivout_(&debug_1.logfil, &c__1, &i__, &debug_1.ndigit, "_sapp" "s: deflation at row/column no.", (ftnlen)35); svout_(&debug_1.logfil, &c__1, &h__[i__ + 1 + h_dim1], & debug_1.ndigit, "_sapps: the corresponding off diago" "nal element", (ftnlen)46); } h__[i__ + 1 + h_dim1] = 0.f; } /* L100: */ } /* %-------------------------------------------------% */ /* | Compute the (kev+1)-st column of (V*Q) and | */ /* | temporarily store the result in WORKD(N+1:2*N). | */ /* | This is not necessary if h(kev+1,1) = 0. | */ /* %-------------------------------------------------% */ if (h__[*kev + 1 + h_dim1] > 0.f) { sgemv_("N", n, &kplusp, &c_b5, &v[v_offset], ldv, &q[(*kev + 1) * q_dim1 + 1], &c__1, &c_b4, &workd[*n + 1], &c__1, (ftnlen)1); } /* %-------------------------------------------------------% */ /* | Compute column 1 to kev of (V*Q) in backward order | */ /* | taking advantage that Q is an upper triangular matrix | */ /* | with lower bandwidth np. | */ /* | Place results in v(:,kplusp-kev:kplusp) temporarily. | */ /* %-------------------------------------------------------% */ i__1 = *kev; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = kplusp - i__ + 1; sgemv_("N", n, &i__2, &c_b5, &v[v_offset], ldv, &q[(*kev - i__ + 1) * q_dim1 + 1], &c__1, &c_b4, &workd[1], &c__1, (ftnlen)1); scopy_(n, &workd[1], &c__1, &v[(kplusp - i__ + 1) * v_dim1 + 1], & c__1); /* L130: */ } /* %-------------------------------------------------% */ /* | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | */ /* %-------------------------------------------------% */ slacpy_("All", n, kev, &v[(*np + 1) * v_dim1 + 1], ldv, &v[v_offset], ldv, (ftnlen)3); /* %--------------------------------------------% */ /* | Copy the (kev+1)-st column of (V*Q) in the | */ /* | appropriate place if h(kev+1,1) .ne. zero. | */ /* %--------------------------------------------% */ if (h__[*kev + 1 + h_dim1] > 0.f) { scopy_(n, &workd[*n + 1], &c__1, &v[(*kev + 1) * v_dim1 + 1], &c__1); } /* %-------------------------------------% */ /* | Update the residual vector: | */ /* | r <- sigmak*r + betak*v(:,kev+1) | */ /* | where | */ /* | sigmak = (e_{kev+p}'*Q)*e_{kev} | */ /* | betak = e_{kev+1}'*H*e_{kev} | */ /* %-------------------------------------% */ sscal_(n, &q[kplusp + *kev * q_dim1], &resid[1], &c__1); if (h__[*kev + 1 + h_dim1] > 0.f) { saxpy_(n, &h__[*kev + 1 + h_dim1], &v[(*kev + 1) * v_dim1 + 1], &c__1, &resid[1], &c__1); } if (msglvl > 1) { svout_(&debug_1.logfil, &c__1, &q[kplusp + *kev * q_dim1], & debug_1.ndigit, "_sapps: sigmak of the updated residual vect" "or", (ftnlen)45); svout_(&debug_1.logfil, &c__1, &h__[*kev + 1 + h_dim1], & debug_1.ndigit, "_sapps: betak of the updated residual vector" , (ftnlen)44); svout_(&debug_1.logfil, kev, &h__[(h_dim1 << 1) + 1], &debug_1.ndigit, "_sapps: updated main diagonal of H for next iteration", ( ftnlen)53); if (*kev > 1) { i__1 = *kev - 1; svout_(&debug_1.logfil, &i__1, &h__[h_dim1 + 2], &debug_1.ndigit, "_sapps: updated sub diagonal of H for next iteration", ( ftnlen)52); } } arscnd_(&t1); timing_1.tsapps += t1 - t0; L9000: return 0; /* %---------------% */ /* | End of ssapps | */ /* %---------------% */ } /* ssapps_ */
/* ----------------------------------------------------------------------- */ /* Subroutine */ int sneupd_(logical *rvec, char *howmny, logical *select, real *dr, real *di, real *z__, integer *ldz, real *sigmar, real * sigmai, real *workev, char *bmat, integer *n, char *which, integer * nev, real *tol, real *resid, integer *ncv, real *v, integer *ldv, integer *iparam, integer *ipntr, real *workd, real *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; real r__1, r__2; doublereal d__1; /* Local variables */ static integer j, k, ih, jj, np; static real vl[1] /* was [1][1] */; static integer ibd, ldh, ldq, iri; static real sep; static integer irr, wri, wrr, mode; static real eps23; extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, integer *, real *, integer *, real *, integer *); static integer ierr; static real temp; static integer iwev; static char type__[6]; static real temp1; extern doublereal snrm2_(integer *, real *, integer *); static integer ihbds, iconj; extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); static real conds; static logical reord; extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *, ftnlen); static integer nconv, iwork[1]; static real rnorm; extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, integer *); static integer ritzi; extern /* Subroutine */ int strmm_(char *, char *, char *, char *, integer *, integer *, real *, real *, integer *, real *, integer * , ftnlen, ftnlen, ftnlen, ftnlen), ivout_(integer *, integer *, integer *, integer *, char *, ftnlen), smout_(integer *, integer * , integer *, real *, integer *, integer *, char *, ftnlen); static integer ritzr; extern /* Subroutine */ int svout_(integer *, integer *, real *, integer * , char *, ftnlen), sgeqr2_(integer *, integer *, real *, integer * , real *, real *, integer *); static integer nconv2; extern doublereal slapy2_(real *, real *); extern /* Subroutine */ int sorm2r_(char *, char *, integer *, integer *, integer *, real *, integer *, real *, real *, integer *, real *, integer *, ftnlen, ftnlen); static integer iheigi, iheigr, bounds, invsub, iuptri, msglvl, outncv, ishift, numcnv; extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *, ftnlen), slahqr_(logical *, logical *, integer *, integer *, integer *, real *, integer *, real *, real *, integer *, integer *, real *, integer *, integer *), slaset_(char *, integer *, integer *, real *, real *, real *, integer *, ftnlen), strevc_(char *, char *, logical *, integer *, real *, integer *, real *, integer *, real *, integer *, integer * , integer *, real *, integer *, ftnlen, ftnlen), strsen_(char *, char *, logical *, integer *, real *, integer *, real *, integer * , real *, real *, integer *, real *, real *, real *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); extern doublereal slamch_(char *, ftnlen); extern /* Subroutine */ int sngets_(integer *, char *, integer *, integer *, real *, real *, real *, real *, real *, 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 | */ /* %-----------------------% */ /* %------------------------% */ /* | Set default parameters | */ /* %------------------------% */ /* Parameter adjustments */ z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --workd; --resid; --di; --dr; --workev; --select; v_dim1 = *ldv; v_offset = 1 + v_dim1; v -= v_offset; --iparam; --ipntr; --workl; /* Function Body */ msglvl = debug_1.mneupd; mode = iparam[7]; nconv = iparam[5]; *info = 0; /* %---------------------------------% */ /* | Get machine dependent constant. | */ /* %---------------------------------% */ eps23 = slamch_("Epsilon-Machine", (ftnlen)15); d__1 = (doublereal) eps23; eps23 = pow_dd(&d__1, &c_b3); /* %--------------% */ /* | Quick return | */ /* %--------------% */ ierr = 0; if (nconv <= 0) { ierr = -14; } else if (*n <= 0) { ierr = -1; } else if (*nev <= 0) { ierr = -2; } else if (*ncv <= *nev + 1 || *ncv > *n) { ierr = -3; } else if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "SM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "LR", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "SR", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "LI", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "SI", (ftnlen)2, (ftnlen)2) != 0) { ierr = -5; } else if (*(unsigned char *)bmat != 'I' && *(unsigned char *)bmat != 'G') { ierr = -6; } else /* if(complicated condition) */ { /* Computing 2nd power */ i__1 = *ncv; if (*lworkl < i__1 * i__1 * 3 + *ncv * 6) { ierr = -7; } else if (*(unsigned char *)howmny != 'A' && *(unsigned char *) howmny != 'P' && *(unsigned char *)howmny != 'S' && *rvec) { ierr = -13; } else if (*(unsigned char *)howmny == 'S') { ierr = -12; } } if (mode == 1 || mode == 2) { s_copy(type__, "REGULR", (ftnlen)6, (ftnlen)6); } else if (mode == 3 && *sigmai == 0.f) { s_copy(type__, "SHIFTI", (ftnlen)6, (ftnlen)6); } else if (mode == 3) { s_copy(type__, "REALPT", (ftnlen)6, (ftnlen)6); } else if (mode == 4) { s_copy(type__, "IMAGPT", (ftnlen)6, (ftnlen)6); } else { ierr = -10; } if (mode == 1 && *(unsigned char *)bmat == 'G') { ierr = -11; } /* %------------% */ /* | Error Exit | */ /* %------------% */ if (ierr != 0) { *info = ierr; goto L9000; } /* %--------------------------------------------------------% */ /* | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | */ /* | etc... and the remaining workspace. | */ /* | Also update pointer to be used on output. | */ /* | Memory is laid out as follows: | */ /* | workl(1:ncv*ncv) := generated Hessenberg matrix | */ /* | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary | */ /* | parts of ritz values | */ /* | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds | */ /* %--------------------------------------------------------% */ /* %-----------------------------------------------------------% */ /* | The following is used and set by SNEUPD. | */ /* | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | */ /* | real part of the Ritz values. | */ /* | workl(ncv*ncv+4*ncv+1:ncv*ncv+5*ncv) := The untransformed | */ /* | imaginary part of the Ritz values. | */ /* | workl(ncv*ncv+5*ncv+1:ncv*ncv+6*ncv) := The untransformed | */ /* | error bounds of the Ritz values | */ /* | workl(ncv*ncv+6*ncv+1:2*ncv*ncv+6*ncv) := Holds the upper | */ /* | quasi-triangular matrix for H | */ /* | workl(2*ncv*ncv+6*ncv+1: 3*ncv*ncv+6*ncv) := Holds the | */ /* | associated matrix representation of the invariant | */ /* | subspace for H. | */ /* | GRAND total of NCV * ( 3 * NCV + 6 ) locations. | */ /* %-----------------------------------------------------------% */ ih = ipntr[5]; ritzr = ipntr[6]; ritzi = ipntr[7]; bounds = ipntr[8]; ldh = *ncv; ldq = *ncv; iheigr = bounds + ldh; iheigi = iheigr + ldh; ihbds = iheigi + ldh; iuptri = ihbds + ldh; invsub = iuptri + ldh * *ncv; ipntr[9] = iheigr; ipntr[10] = iheigi; ipntr[11] = ihbds; ipntr[12] = iuptri; ipntr[13] = invsub; wrr = 1; wri = *ncv + 1; iwev = wri + *ncv; /* %-----------------------------------------% */ /* | irr points to the REAL part of the Ritz | */ /* | values computed by _neigh before | */ /* | exiting _naup2. | */ /* | iri points to the IMAGINARY part of the | */ /* | Ritz values computed by _neigh | */ /* | before exiting _naup2. | */ /* | ibd points to the Ritz estimates | */ /* | computed by _neigh before exiting | */ /* | _naup2. | */ /* %-----------------------------------------% */ irr = ipntr[14] + *ncv * *ncv; iri = irr + *ncv; ibd = iri + *ncv; /* %------------------------------------% */ /* | RNORM is B-norm of the RESID(1:N). | */ /* %------------------------------------% */ rnorm = workl[ih + 2]; workl[ih + 2] = 0.f; if (msglvl > 2) { svout_(&debug_1.logfil, ncv, &workl[irr], &debug_1.ndigit, "_neupd: " "Real part of Ritz values passed in from _NAUPD.", (ftnlen)55); svout_(&debug_1.logfil, ncv, &workl[iri], &debug_1.ndigit, "_neupd: " "Imag part of Ritz values passed in from _NAUPD.", (ftnlen)55); svout_(&debug_1.logfil, ncv, &workl[ibd], &debug_1.ndigit, "_neupd: " "Ritz estimates passed in from _NAUPD.", (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] = (real) 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; sngets_(&ishift, which, nev, &np, &workl[irr], &workl[iri], &workl[ bounds], &workl[1], &workl[np + 1], (ftnlen)2); if (msglvl > 2) { svout_(&debug_1.logfil, ncv, &workl[irr], &debug_1.ndigit, "_neu" "pd: Real part of Ritz values after calling _NGETS.", ( ftnlen)54); svout_(&debug_1.logfil, ncv, &workl[iri], &debug_1.ndigit, "_neu" "pd: Imag part of Ritz values after calling _NGETS.", ( ftnlen)54); svout_(&debug_1.logfil, ncv, &workl[bounds], &debug_1.ndigit, "_neupd: Ritz value indices after calling _NGETS.", ( 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 */ r__1 = eps23, r__2 = slapy2_(&workl[irr + *ncv - j], &workl[iri + *ncv - j]); temp1 = dmax(r__1,r__2); jj = workl[bounds + *ncv - j]; if (numcnv < nconv && workl[ibd + jj - 1] <= *tol * temp1) { select[jj] = TRUE_; ++numcnv; if (jj > nconv) { reord = TRUE_; } } /* L11: */ } /* %-----------------------------------------------------------% */ /* | Check the count (numcnv) of converged Ritz values with | */ /* | the number (nconv) reported by dnaupd. If these two | */ /* | are different then there has probably been an error | */ /* | caused by incorrect passing of the dnaupd data. | */ /* %-----------------------------------------------------------% */ if (msglvl > 2) { ivout_(&debug_1.logfil, &c__1, &numcnv, &debug_1.ndigit, "_neupd" ": Number of specified eigenvalues", (ftnlen)39); ivout_(&debug_1.logfil, &c__1, &nconv, &debug_1.ndigit, "_neupd:" " Number of \"converged\" eigenvalues", (ftnlen)41); } if (numcnv != nconv) { *info = -15; goto L9000; } /* %-----------------------------------------------------------% */ /* | Call LAPACK routine slahqr to compute the real Schur form | */ /* | of the upper Hessenberg matrix returned by SNAUPD. | */ /* | Make a copy of the upper Hessenberg matrix. | */ /* | Initialize the Schur vector matrix Q to the identity. | */ /* %-----------------------------------------------------------% */ i__1 = ldh * *ncv; scopy_(&i__1, &workl[ih], &c__1, &workl[iuptri], &c__1); slaset_("All", ncv, ncv, &c_b37, &c_b38, &workl[invsub], &ldq, ( ftnlen)3); slahqr_(&c_true, &c_true, ncv, &c__1, ncv, &workl[iuptri], &ldh, & workl[iheigr], &workl[iheigi], &c__1, ncv, &workl[invsub], & ldq, &ierr); scopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &c__1); if (ierr != 0) { *info = -8; goto L9000; } if (msglvl > 1) { svout_(&debug_1.logfil, ncv, &workl[iheigr], &debug_1.ndigit, "_neupd: Real part of the eigenvalues of H", (ftnlen)41); svout_(&debug_1.logfil, ncv, &workl[iheigi], &debug_1.ndigit, "_neupd: Imaginary part of the Eigenvalues of H", (ftnlen) 46); svout_(&debug_1.logfil, ncv, &workl[ihbds], &debug_1.ndigit, "_neupd: Last row of the Schur vector matrix", (ftnlen)43) ; if (msglvl > 3) { smout_(&debug_1.logfil, ncv, ncv, &workl[iuptri], &ldh, & debug_1.ndigit, "_neupd: The upper quasi-triangular " "matrix ", (ftnlen)42); } } if (reord) { /* %-----------------------------------------------------% */ /* | Reorder the computed upper quasi-triangular matrix. | */ /* %-----------------------------------------------------% */ strsen_("None", "V", &select[1], ncv, &workl[iuptri], &ldh, & workl[invsub], &ldq, &workl[iheigr], &workl[iheigi], & nconv2, &conds, &sep, &workl[ihbds], ncv, iwork, &c__1, & ierr, (ftnlen)4, (ftnlen)1); if (nconv2 < nconv) { nconv = nconv2; } if (ierr == 1) { *info = 1; goto L9000; } if (msglvl > 2) { svout_(&debug_1.logfil, ncv, &workl[iheigr], &debug_1.ndigit, "_neupd: Real part of the eigenvalues of H--reordered" , (ftnlen)52); svout_(&debug_1.logfil, ncv, &workl[iheigi], &debug_1.ndigit, "_neupd: Imag part of the eigenvalues of H--reordered" , (ftnlen)52); if (msglvl > 3) { smout_(&debug_1.logfil, ncv, ncv, &workl[iuptri], &ldq, & debug_1.ndigit, "_neupd: Quasi-triangular matrix" " after re-ordering", (ftnlen)49); } } } /* %---------------------------------------% */ /* | Copy the last row of the Schur vector | */ /* | into workl(ihbds). This will be used | */ /* | to compute the Ritz estimates of | */ /* | converged Ritz values. | */ /* %---------------------------------------% */ scopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &c__1); /* %----------------------------------------------------% */ /* | Place the computed eigenvalues of H into DR and DI | */ /* | if a spectral transformation was not used. | */ /* %----------------------------------------------------% */ if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) { scopy_(&nconv, &workl[iheigr], &c__1, &dr[1], &c__1); scopy_(&nconv, &workl[iheigi], &c__1, &di[1], &c__1); } /* %----------------------------------------------------------% */ /* | Compute the QR factorization of the matrix representing | */ /* | the wanted invariant subspace located in the first NCONV | */ /* | columns of workl(invsub,ldq). | */ /* %----------------------------------------------------------% */ sgeqr2_(ncv, &nconv, &workl[invsub], &ldq, &workev[1], &workev[*ncv + 1], &ierr); /* %---------------------------------------------------------% */ /* | * Postmultiply V by Q using sorm2r. | */ /* | * Copy the first NCONV columns of VQ into Z. | */ /* | * Postmultiply Z by R. | */ /* | The N by NCONV matrix Z is now a matrix representation | */ /* | of the approximate invariant subspace associated with | */ /* | the Ritz values in workl(iheigr) and workl(iheigi) | */ /* | The first NCONV columns of V are now approximate Schur | */ /* | vectors associated with the real upper quasi-triangular | */ /* | matrix of order NCONV in workl(iuptri) | */ /* %---------------------------------------------------------% */ sorm2r_("Right", "Notranspose", n, ncv, &nconv, &workl[invsub], &ldq, &workev[1], &v[v_offset], ldv, &workd[*n + 1], &ierr, (ftnlen) 5, (ftnlen)11); slacpy_("All", n, &nconv, &v[v_offset], ldv, &z__[z_offset], ldz, ( ftnlen)3); i__1 = nconv; for (j = 1; j <= i__1; ++j) { /* %---------------------------------------------------% */ /* | Perform both a column and row scaling if the | */ /* | diagonal element of workl(invsub,ldq) is negative | */ /* | I'm lazy and don't take advantage of the upper | */ /* | quasi-triangular form of workl(iuptri,ldq) | */ /* | Note that since Q is orthogonal, R is a diagonal | */ /* | matrix consisting of plus or minus ones | */ /* %---------------------------------------------------% */ if (workl[invsub + (j - 1) * ldq + j - 1] < 0.f) { sscal_(&nconv, &c_b64, &workl[iuptri + j - 1], &ldq); sscal_(&nconv, &c_b64, &workl[iuptri + (j - 1) * ldq], &c__1); } /* L20: */ } if (*(unsigned char *)howmny == 'A') { /* %--------------------------------------------% */ /* | Compute the NCONV wanted eigenvectors of T | */ /* | located in workl(iuptri,ldq). | */ /* %--------------------------------------------% */ i__1 = *ncv; for (j = 1; j <= i__1; ++j) { if (j <= nconv) { select[j] = TRUE_; } else { select[j] = FALSE_; } /* L30: */ } strevc_("Right", "Select", &select[1], ncv, &workl[iuptri], &ldq, vl, &c__1, &workl[invsub], &ldq, ncv, &outncv, &workev[1], &ierr, (ftnlen)5, (ftnlen)6); if (ierr != 0) { *info = -9; goto L9000; } /* %------------------------------------------------% */ /* | Scale the returning eigenvectors so that their | */ /* | Euclidean norms are all one. LAPACK subroutine | */ /* | strevc returns each eigenvector normalized so | */ /* | that the element of largest magnitude has | */ /* | magnitude 1; | */ /* %------------------------------------------------% */ iconj = 0; i__1 = nconv; for (j = 1; j <= i__1; ++j) { if (workl[iheigi + j - 1] == 0.f) { /* %----------------------% */ /* | real eigenvalue case | */ /* %----------------------% */ temp = snrm2_(ncv, &workl[invsub + (j - 1) * ldq], &c__1); r__1 = 1.f / temp; sscal_(ncv, &r__1, &workl[invsub + (j - 1) * ldq], &c__1); } else { /* %-------------------------------------------% */ /* | Complex conjugate pair case. Note that | */ /* | since the real and imaginary part of | */ /* | the eigenvector are stored in consecutive | */ /* | columns, we further normalize by the | */ /* | square root of two. | */ /* %-------------------------------------------% */ if (iconj == 0) { r__1 = snrm2_(ncv, &workl[invsub + (j - 1) * ldq], & c__1); r__2 = snrm2_(ncv, &workl[invsub + j * ldq], &c__1); temp = slapy2_(&r__1, &r__2); r__1 = 1.f / temp; sscal_(ncv, &r__1, &workl[invsub + (j - 1) * ldq], & c__1); r__1 = 1.f / temp; sscal_(ncv, &r__1, &workl[invsub + j * ldq], &c__1); iconj = 1; } else { iconj = 0; } } /* L40: */ } sgemv_("T", ncv, &nconv, &c_b38, &workl[invsub], &ldq, &workl[ ihbds], &c__1, &c_b37, &workev[1], &c__1, (ftnlen)1); iconj = 0; i__1 = nconv; for (j = 1; j <= i__1; ++j) { if (workl[iheigi + j - 1] != 0.f) { /* %-------------------------------------------% */ /* | Complex conjugate pair case. Note that | */ /* | since the real and imaginary part of | */ /* | the eigenvector are stored in consecutive | */ /* %-------------------------------------------% */ if (iconj == 0) { workev[j] = slapy2_(&workev[j], &workev[j + 1]); workev[j + 1] = workev[j]; iconj = 1; } else { iconj = 0; } } /* L45: */ } if (msglvl > 2) { scopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], & c__1); svout_(&debug_1.logfil, ncv, &workl[ihbds], &debug_1.ndigit, "_neupd: Last row of the eigenvector matrix for T", ( ftnlen)48); if (msglvl > 3) { smout_(&debug_1.logfil, ncv, ncv, &workl[invsub], &ldq, & debug_1.ndigit, "_neupd: The eigenvector matrix " "for T", (ftnlen)36); } } /* %---------------------------------------% */ /* | Copy Ritz estimates into workl(ihbds) | */ /* %---------------------------------------% */ scopy_(&nconv, &workev[1], &c__1, &workl[ihbds], &c__1); /* %---------------------------------------------------------% */ /* | Compute the QR factorization of the eigenvector matrix | */ /* | associated with leading portion of T in the first NCONV | */ /* | columns of workl(invsub,ldq). | */ /* %---------------------------------------------------------% */ sgeqr2_(ncv, &nconv, &workl[invsub], &ldq, &workev[1], &workev[* ncv + 1], &ierr); /* %----------------------------------------------% */ /* | * Postmultiply Z by Q. | */ /* | * Postmultiply Z by R. | */ /* | The N by NCONV matrix Z is now contains the | */ /* | Ritz vectors associated with the Ritz values | */ /* | in workl(iheigr) and workl(iheigi). | */ /* %----------------------------------------------% */ sorm2r_("Right", "Notranspose", n, ncv, &nconv, &workl[invsub], & ldq, &workev[1], &z__[z_offset], ldz, &workd[*n + 1], & ierr, (ftnlen)5, (ftnlen)11); strmm_("Right", "Upper", "No transpose", "Non-unit", n, &nconv, & c_b38, &workl[invsub], &ldq, &z__[z_offset], ldz, (ftnlen) 5, (ftnlen)5, (ftnlen)12, (ftnlen)8); } } else { /* %------------------------------------------------------% */ /* | An approximate invariant subspace is not needed. | */ /* | Place the Ritz values computed SNAUPD into DR and DI | */ /* %------------------------------------------------------% */ scopy_(&nconv, &workl[ritzr], &c__1, &dr[1], &c__1); scopy_(&nconv, &workl[ritzi], &c__1, &di[1], &c__1); scopy_(&nconv, &workl[ritzr], &c__1, &workl[iheigr], &c__1); scopy_(&nconv, &workl[ritzi], &c__1, &workl[iheigi], &c__1); scopy_(&nconv, &workl[bounds], &c__1, &workl[ihbds], &c__1); } /* %------------------------------------------------% */ /* | Transform the Ritz values and possibly vectors | */ /* | and corresponding error bounds of OP to those | */ /* | of A*x = lambda*B*x. | */ /* %------------------------------------------------% */ if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) { if (*rvec) { sscal_(ncv, &rnorm, &workl[ihbds], &c__1); } } else { /* %---------------------------------------% */ /* | A spectral transformation was used. | */ /* | * Determine the Ritz estimates of the | */ /* | Ritz values in the original system. | */ /* %---------------------------------------% */ if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) { if (*rvec) { sscal_(ncv, &rnorm, &workl[ihbds], &c__1); } i__1 = *ncv; for (k = 1; k <= i__1; ++k) { temp = slapy2_(&workl[iheigr + k - 1], &workl[iheigi + k - 1]) ; workl[ihbds + k - 1] = (r__1 = workl[ihbds + k - 1], dabs( r__1)) / temp / temp; /* L50: */ } } else if (s_cmp(type__, "REALPT", (ftnlen)6, (ftnlen)6) == 0) { i__1 = *ncv; for (k = 1; k <= i__1; ++k) { /* L60: */ } } else if (s_cmp(type__, "IMAGPT", (ftnlen)6, (ftnlen)6) == 0) { i__1 = *ncv; for (k = 1; k <= i__1; ++k) { /* L70: */ } } /* %-----------------------------------------------------------% */ /* | * Transform the Ritz values back to the original system. | */ /* | For TYPE = 'SHIFTI' the transformation is | */ /* | lambda = 1/theta + sigma | */ /* | For TYPE = 'REALPT' or 'IMAGPT' the user must from | */ /* | Rayleigh quotients or a projection. See remark 3 above.| */ /* | NOTES: | */ /* | *The Ritz vectors are not affected by the transformation. | */ /* %-----------------------------------------------------------% */ if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) { i__1 = *ncv; for (k = 1; k <= i__1; ++k) { temp = slapy2_(&workl[iheigr + k - 1], &workl[iheigi + k - 1]) ; workl[iheigr + k - 1] = workl[iheigr + k - 1] / temp / temp + *sigmar; workl[iheigi + k - 1] = -workl[iheigi + k - 1] / temp / temp + *sigmai; /* L80: */ } scopy_(&nconv, &workl[iheigr], &c__1, &dr[1], &c__1); scopy_(&nconv, &workl[iheigi], &c__1, &di[1], &c__1); } else if (s_cmp(type__, "REALPT", (ftnlen)6, (ftnlen)6) == 0 || s_cmp(type__, "IMAGPT", (ftnlen)6, (ftnlen)6) == 0) { scopy_(&nconv, &workl[iheigr], &c__1, &dr[1], &c__1); scopy_(&nconv, &workl[iheigi], &c__1, &di[1], &c__1); } } if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0 && msglvl > 1) { svout_(&debug_1.logfil, &nconv, &dr[1], &debug_1.ndigit, "_neupd: Un" "transformed real part of the Ritz valuess.", (ftnlen)52); svout_(&debug_1.logfil, &nconv, &di[1], &debug_1.ndigit, "_neupd: Un" "transformed imag part of the Ritz valuess.", (ftnlen)52); svout_(&debug_1.logfil, &nconv, &workl[ihbds], &debug_1.ndigit, "_ne" "upd: Ritz estimates of untransformed Ritz values.", (ftnlen) 52); } else if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0 && msglvl > 1) { svout_(&debug_1.logfil, &nconv, &dr[1], &debug_1.ndigit, "_neupd: Re" "al parts of converged Ritz values.", (ftnlen)44); svout_(&debug_1.logfil, &nconv, &di[1], &debug_1.ndigit, "_neupd: Im" "ag parts of converged Ritz values.", (ftnlen)44); svout_(&debug_1.logfil, &nconv, &workl[ihbds], &debug_1.ndigit, "_ne" "upd: Associated Ritz estimates.", (ftnlen)34); } /* %-------------------------------------------------% */ /* | Eigenvector Purification step. Formally perform | */ /* | one of inverse subspace iteration. Only used | */ /* | for MODE = 2. | */ /* %-------------------------------------------------% */ if (*rvec && *(unsigned char *)howmny == 'A' && s_cmp(type__, "SHIFTI", ( ftnlen)6, (ftnlen)6) == 0) { /* %------------------------------------------------% */ /* | Purify the computed Ritz vectors by adding a | */ /* | little bit of the residual vector: | */ /* | T | */ /* | resid(:)*( e s ) / theta | */ /* | NCV | */ /* | where H s = s theta. Remember that when theta | */ /* | has nonzero imaginary part, the corresponding | */ /* | Ritz vector is stored across two columns of Z. | */ /* %------------------------------------------------% */ iconj = 0; i__1 = nconv; for (j = 1; j <= i__1; ++j) { if (workl[iheigi + j - 1] == 0.f) { workev[j] = workl[invsub + (j - 1) * ldq + *ncv - 1] / workl[ iheigr + j - 1]; } else if (iconj == 0) { temp = slapy2_(&workl[iheigr + j - 1], &workl[iheigi + j - 1]) ; workev[j] = (workl[invsub + (j - 1) * ldq + *ncv - 1] * workl[ iheigr + j - 1] + workl[invsub + j * ldq + *ncv - 1] * workl[iheigi + j - 1]) / temp / temp; workev[j + 1] = (workl[invsub + j * ldq + *ncv - 1] * workl[ iheigr + j - 1] - workl[invsub + (j - 1) * ldq + *ncv - 1] * workl[iheigi + j - 1]) / temp / temp; iconj = 1; } else { iconj = 0; } /* L110: */ } /* %---------------------------------------% */ /* | Perform a rank one update to Z and | */ /* | purify all the Ritz vectors together. | */ /* %---------------------------------------% */ sger_(n, &nconv, &c_b38, &resid[1], &c__1, &workev[1], &c__1, &z__[ z_offset], ldz); } L9000: return 0; /* %---------------% */ /* | End of SNEUPD | */ /* %---------------% */ } /* sneupd_ */
/* Subroutine */ int sseigt_(real *rnorm, integer *n, real *h__, integer *ldh, real *eig, real *bounds, real *workl, integer *ierr) { /* System generated locals */ integer h_dim1, h_offset, i__1; real r__1; /* Local variables */ static integer k; static real t0, t1; extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, integer *), svout_(integer *, integer *, real *, integer *, char * , ftnlen), second_(real *); static integer msglvl; extern /* Subroutine */ int sstqrb_(integer *, real *, real *, real *, real *, integer *); /* %----------------------------------------------------% */ /* | 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 | */ /* %----------------------% */ /* %-----------------------% */ /* | Executable Statements | */ /* %-----------------------% */ /* %-------------------------------% */ /* | Initialize timing statistics | */ /* | & message level for debugging | */ /* %-------------------------------% */ /* Parameter adjustments */ --workl; --bounds; --eig; h_dim1 = *ldh; h_offset = 1 + h_dim1; h__ -= h_offset; /* Function Body */ second_(&t0); msglvl = debug_1.mseigt; if (msglvl > 0) { svout_(&debug_1.logfil, n, &h__[(h_dim1 << 1) + 1], &debug_1.ndigit, "_seigt: main diagonal of matrix H", (ftnlen)33); if (*n > 1) { i__1 = *n - 1; svout_(&debug_1.logfil, &i__1, &h__[h_dim1 + 2], &debug_1.ndigit, "_seigt: sub diagonal of matrix H", (ftnlen)32); } } scopy_(n, &h__[(h_dim1 << 1) + 1], &c__1, &eig[1], &c__1); i__1 = *n - 1; scopy_(&i__1, &h__[h_dim1 + 2], &c__1, &workl[1], &c__1); sstqrb_(n, &eig[1], &workl[1], &bounds[1], &workl[*n + 1], ierr); if (*ierr != 0) { goto L9000; } if (msglvl > 1) { svout_(&debug_1.logfil, n, &bounds[1], &debug_1.ndigit, "_seigt: las" "t row of the eigenvector matrix for H", (ftnlen)48); } /* %-----------------------------------------------% */ /* | Finally determine the error bounds associated | */ /* | with the n Ritz values of H. | */ /* %-----------------------------------------------% */ i__1 = *n; for (k = 1; k <= i__1; ++k) { bounds[k] = *rnorm * (r__1 = bounds[k], dabs(r__1)); /* L30: */ } second_(&t1); timing_1.tseigt += t1 - t0; L9000: return 0; /* %---------------% */ /* | End of sseigt | */ /* %---------------% */ } /* sseigt_ */
/* Subroutine */ int snaup2_(integer *ido, char *bmat, integer *n, char * which, integer *nev, integer *np, real *tol, real *resid, integer * mode, integer *iupd, integer *ishift, integer *mxiter, real *v, integer *ldv, real *h__, integer *ldh, real *ritzr, real *ritzi, real *bounds, real *q, integer *ldq, real *workl, integer *ipntr, real * 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; real r__1, r__2; doublereal d__1; /* 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 */ static integer j; static real t0, t1, t2, t3; static integer kp[4], np0, nev0; static real eps23; static integer ierr, iter; static real temp; extern doublereal sdot_(integer *, real *, integer *, real *, integer *); static logical getv0; extern doublereal snrm2_(integer *, real *, integer *); static logical cnorm; static integer nconv; static logical initv; static real rnorm; extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, integer *), ivout_(integer *, integer *, integer *, integer *, char *, ftnlen), smout_(integer *, integer *, integer *, real *, integer *, integer *, char *, ftnlen), svout_(integer *, integer * , real *, integer *, char *, ftnlen), sgetv0_(integer *, char *, integer *, logical *, integer *, integer *, real *, integer *, real *, real *, integer *, real *, integer *, ftnlen); extern doublereal slapy2_(real *, real *); static integer nevbef; extern doublereal slamch_(char *, ftnlen); extern /* Subroutine */ int second_(real *); static logical update; static char wprime[2]; static logical ushift; static integer kplusp, msglvl, nptemp, numcnv; extern /* Subroutine */ int snaitr_(integer *, char *, integer *, integer *, integer *, integer *, real *, real *, real *, integer *, real * , integer *, integer *, real *, integer *, ftnlen), snconv_( integer *, real *, real *, real *, real *, integer *), sneigh_( real *, integer *, real *, integer *, real *, real *, real *, real *, integer *, real *, integer *), sngets_(integer *, char *, integer *, integer *, real *, real *, real *, real *, real *, ftnlen), snapps_(integer *, integer *, integer *, real *, real *, real *, integer *, real *, integer *, real *, real *, integer *, real *, real *), ssortc_(char *, logical *, integer *, real *, real *, real *, 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 | */ /* %---------------% */ /* %-----------------------% */ /* | Local array arguments | */ /* %-----------------------% */ /* %----------------------% */ /* | External Subroutines | */ /* %----------------------% */ /* %--------------------% */ /* | External Functions | */ /* %--------------------% */ /* %---------------------% */ /* | Intrinsic Functions | */ /* %---------------------% */ /* %-----------------------% */ /* | Executable Statements | */ /* %-----------------------% */ /* Parameter adjustments */ --workd; --resid; --workl; --bounds; --ritzi; --ritzr; 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) { second_(&t0); msglvl = debug_1.mnaup2; /* %-------------------------------------% */ /* | Get the machine dependent constant. | */ /* %-------------------------------------% */ eps23 = slamch_("Epsilon-Machine", (ftnlen)15); d__1 = (doublereal) eps23; eps23 = pow_dd(&d__1, &c_b3); 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 = *nev + *np; nconv = 0; iter = 0; /* %---------------------------------------% */ /* | Set flags for computing the first NEV | */ /* | steps of the Arnoldi 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) { sgetv0_(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.f) { /* %-----------------------------------------% */ /* | The initial vector is zero. Error exit. | */ /* %-----------------------------------------% */ *info = -9; goto L1100; } 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 Arnoldi factorization | */ /* %----------------------------------------------------------% */ snaitr_(ido, bmat, n, &c__0, nev, 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) { *np = *info; *mxiter = iter; *info = -9999; goto L1200; } /* %--------------------------------------------------------------% */ /* | | */ /* | M A I N ARNOLDI I T E R A T I O N L O O P | */ /* | Each iteration implicitly restarts the Arnoldi | */ /* | factorization in place. | */ /* | | */ /* %--------------------------------------------------------------% */ L1000: ++iter; if (msglvl > 0) { ivout_(&debug_1.logfil, &c__1, &iter, &debug_1.ndigit, "_naup2: ****" " Start of major iteration number ****", (ftnlen)49); } /* %-----------------------------------------------------------% */ /* | Compute NP additional steps of the Arnoldi factorization. | */ /* | Adjust NP since NEV might have been updated by last call | */ /* | to the shift application routine snapps. | */ /* %-----------------------------------------------------------% */ *np = kplusp - *nev; if (msglvl > 1) { ivout_(&debug_1.logfil, &c__1, nev, &debug_1.ndigit, "_naup2: The le" "ngth of the current Arnoldi factorization", (ftnlen)55); ivout_(&debug_1.logfil, &c__1, np, &debug_1.ndigit, "_naup2: Extend " "the Arnoldi factorization by", (ftnlen)43); } /* %-----------------------------------------------------------% */ /* | Compute NP additional steps of the Arnoldi factorization. | */ /* %-----------------------------------------------------------% */ *ido = 0; L20: update = TRUE_; snaitr_(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) { *np = *info; *mxiter = iter; *info = -9999; goto L1200; } update = FALSE_; if (msglvl > 1) { svout_(&debug_1.logfil, &c__1, &rnorm, &debug_1.ndigit, "_naup2: Cor" "responding B-norm of the residual", (ftnlen)44); } /* %--------------------------------------------------------% */ /* | Compute the eigenvalues and corresponding error bounds | */ /* | of the current upper Hessenberg matrix. | */ /* %--------------------------------------------------------% */ sneigh_(&rnorm, &kplusp, &h__[h_offset], ldh, &ritzr[1], &ritzi[1], & bounds[1], &q[q_offset], ldq, &workl[1], &ierr); if (ierr != 0) { *info = -8; goto L1200; } /* %----------------------------------------------------% */ /* | Make a copy of eigenvalues and corresponding error | */ /* | bounds obtained from sneigh. | */ /* %----------------------------------------------------% */ /* Computing 2nd power */ i__1 = kplusp; scopy_(&kplusp, &ritzr[1], &c__1, &workl[i__1 * i__1 + 1], &c__1); /* Computing 2nd power */ i__1 = kplusp; scopy_(&kplusp, &ritzi[1], &c__1, &workl[i__1 * i__1 + kplusp + 1], &c__1) ; /* Computing 2nd power */ i__1 = kplusp; scopy_(&kplusp, &bounds[1], &c__1, &workl[i__1 * i__1 + (kplusp << 1) + 1] , &c__1); /* %---------------------------------------------------% */ /* | Select the wanted Ritz values and their bounds | */ /* | to be used in the convergence test. | */ /* | The wanted part of the spectrum and corresponding | */ /* | error bounds are in the last NEV loc. of RITZR, | */ /* | RITZI and BOUNDS respectively. The variables NEV | */ /* | and NP may be updated if the NEV-th wanted Ritz | */ /* | value has a non zero imaginary part. In this case | */ /* | NEV is increased by one and NP decreased by one. | */ /* | NOTE: The last two arguments of sngets are no | */ /* | longer used as of version 2.1. | */ /* %---------------------------------------------------% */ *nev = nev0; *np = np0; numcnv = *nev; sngets_(ishift, which, nev, np, &ritzr[1], &ritzi[1], &bounds[1], &workl[ 1], &workl[*np + 1], (ftnlen)2); if (*nev == nev0 + 1) { numcnv = nev0 + 1; } /* %-------------------% */ /* | Convergence test. | */ /* %-------------------% */ scopy_(nev, &bounds[*np + 1], &c__1, &workl[(*np << 1) + 1], &c__1); snconv_(nev, &ritzr[*np + 1], &ritzi[*np + 1], &workl[(*np << 1) + 1], tol, &nconv); if (msglvl > 2) { kp[0] = *nev; kp[1] = *np; kp[2] = numcnv; kp[3] = nconv; ivout_(&debug_1.logfil, &c__4, kp, &debug_1.ndigit, "_naup2: NEV, NP" ", NUMCNV, NCONV are", (ftnlen)34); svout_(&debug_1.logfil, &kplusp, &ritzr[1], &debug_1.ndigit, "_naup2" ": Real part of the eigenvalues of H", (ftnlen)41); svout_(&debug_1.logfil, &kplusp, &ritzi[1], &debug_1.ndigit, "_naup2" ": Imaginary part of the eigenvalues of H", (ftnlen)46); svout_(&debug_1.logfil, &kplusp, &bounds[1], &debug_1.ndigit, "_naup" "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.f) { --(*np); ++(*nev); } /* L30: */ } if (nconv >= numcnv || iter > *mxiter || *np == 0) { if (msglvl > 4) { /* Computing 2nd power */ i__1 = kplusp; svout_(&debug_1.logfil, &kplusp, &workl[i__1 * i__1 + 1], & debug_1.ndigit, "_naup2: Real part of the eig computed b" "y _neigh:", (ftnlen)48); /* Computing 2nd power */ i__1 = kplusp; svout_(&debug_1.logfil, &kplusp, &workl[i__1 * i__1 + kplusp + 1], &debug_1.ndigit, "_naup2: Imag part of the eig computed" " by _neigh:", (ftnlen)48); /* Computing 2nd power */ i__1 = kplusp; svout_(&debug_1.logfil, &kplusp, &workl[i__1 * i__1 + (kplusp << 1) + 1], &debug_1.ndigit, "_naup2: Ritz eistmates comput" "ed by _neigh:", (ftnlen)42); } /* %------------------------------------------------% */ /* | 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 | */ /* %------------------------------------------------% */ /* %------------------------------------------% */ /* | Use h( 3,1 ) as storage to communicate | */ /* | rnorm to _neupd if needed | */ /* %------------------------------------------% */ h__[h_dim1 + 3] = rnorm; /* %----------------------------------------------% */ /* | To be consistent with sngets, we first do a | */ /* | pre-processing sort in order to keep complex | */ /* | conjugate pairs together. This is similar | */ /* | to the pre-processing sort used in sngets | */ /* | except that the sort is done in the opposite | */ /* | order. | */ /* %----------------------------------------------% */ if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "SR", (ftnlen)2, (ftnlen)2); } if (s_cmp(which, "SM", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "LR", (ftnlen)2, (ftnlen)2); } if (s_cmp(which, "LR", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "SM", (ftnlen)2, (ftnlen)2); } if (s_cmp(which, "SR", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "LM", (ftnlen)2, (ftnlen)2); } if (s_cmp(which, "LI", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "SM", (ftnlen)2, (ftnlen)2); } if (s_cmp(which, "SI", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "LM", (ftnlen)2, (ftnlen)2); } ssortc_(wprime, &c_true, &kplusp, &ritzr[1], &ritzi[1], &bounds[1], ( ftnlen)2); /* %----------------------------------------------% */ /* | Now sort Ritz values so that converged Ritz | */ /* | values appear within the first NEV locations | */ /* | of ritzr, ritzi and bounds, and the most | */ /* | desired one appears at the front. | */ /* %----------------------------------------------% */ 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, "LR", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "SR", (ftnlen)2, (ftnlen)2); } if (s_cmp(which, "SR", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "LR", (ftnlen)2, (ftnlen)2); } if (s_cmp(which, "LI", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "SI", (ftnlen)2, (ftnlen)2); } if (s_cmp(which, "SI", (ftnlen)2, (ftnlen)2) == 0) { s_copy(wprime, "LI", (ftnlen)2, (ftnlen)2); } ssortc_(wprime, &c_true, &kplusp, &ritzr[1], &ritzi[1], &bounds[1], ( ftnlen)2); /* %--------------------------------------------------% */ /* | Scale the Ritz estimate of each Ritz value | */ /* | by 1 / max(eps23,magnitude of the Ritz value). | */ /* %--------------------------------------------------% */ i__1 = numcnv; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ r__1 = eps23, r__2 = slapy2_(&ritzr[j], &ritzi[j]); temp = dmax(r__1,r__2); 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, "LR", (ftnlen)2, (ftnlen)2); ssortc_(wprime, &c_true, &numcnv, &bounds[1], &ritzr[1], &ritzi[1], ( ftnlen)2); /* %----------------------------------------------% */ /* | Scale the Ritz estimate back to its original | */ /* | value. | */ /* %----------------------------------------------% */ i__1 = numcnv; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ r__1 = eps23, r__2 = slapy2_(&ritzr[j], &ritzi[j]); temp = dmax(r__1,r__2); bounds[j] *= temp; /* L40: */ } /* %------------------------------------------------% */ /* | Sort the converged Ritz values again so that | */ /* | the "threshold" value appears at the front of | */ /* | ritzr, ritzi and bound. | */ /* %------------------------------------------------% */ ssortc_(which, &c_true, &nconv, &ritzr[1], &ritzi[1], &bounds[1], ( ftnlen)2); if (msglvl > 1) { svout_(&debug_1.logfil, &kplusp, &ritzr[1], &debug_1.ndigit, "_naup2: Sorted real part of the eigenvalues", (ftnlen)43) ; svout_(&debug_1.logfil, &kplusp, &ritzi[1], &debug_1.ndigit, "_naup2: Sorted imaginary part of the eigenvalues", ( ftnlen)48); svout_(&debug_1.logfil, &kplusp, &bounds[1], &debug_1.ndigit, "_naup2: Sorted ritz estimates.", (ftnlen)30); } /* %------------------------------------% */ /* | Max iterations have been exceeded. | */ /* %------------------------------------% */ if (iter > *mxiter && nconv < numcnv) { *info = 1; } /* %---------------------% */ /* | No shifts to apply. | */ /* %---------------------% */ if (*np == 0 && nconv < numcnv) { *info = 2; } *np = nconv; goto L1100; } else if (nconv < numcnv && *ishift == 1) { /* %-------------------------------------------------% */ /* | Do not have all the requested eigenvalues yet. | */ /* | To prevent possible stagnation, adjust the size | */ /* | of NEV. | */ /* %-------------------------------------------------% */ 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 > 3) { *nev = 2; } *np = kplusp - *nev; /* %---------------------------------------% */ /* | If the size of NEV was just increased | */ /* | resort the eigenvalues. | */ /* %---------------------------------------% */ if (nevbef < *nev) { sngets_(ishift, which, nev, np, &ritzr[1], &ritzi[1], &bounds[1], &workl[1], &workl[*np + 1], (ftnlen)2); } } if (msglvl > 0) { ivout_(&debug_1.logfil, &c__1, &nconv, &debug_1.ndigit, "_naup2: 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, "_naup2: NEV" " and NP are", (ftnlen)22); svout_(&debug_1.logfil, nev, &ritzr[*np + 1], &debug_1.ndigit, "_naup2: \"wanted\" Ritz values -- real part", (ftnlen)41) ; svout_(&debug_1.logfil, nev, &ritzi[*np + 1], &debug_1.ndigit, "_naup2: \"wanted\" Ritz values -- imag part", (ftnlen)41) ; svout_(&debug_1.logfil, nev, &bounds[*np + 1], &debug_1.ndigit, "_naup2: Ritz estimates of the \"wanted\" values ", ( ftnlen)46); } } if (*ishift == 0) { /* %-------------------------------------------------------% */ /* | User specified shifts: reverse comminucation to | */ /* | compute the shifts. They are returned in the first | */ /* | 2*NP locations of WORKL. | */ /* %-------------------------------------------------------% */ ushift = TRUE_; *ido = 3; goto L9000; } L50: /* %------------------------------------% */ /* | Back from reverse communication; | */ /* | User specified shifts are returned | */ /* | in WORKL(1:2*NP) | */ /* %------------------------------------% */ ushift = FALSE_; if (*ishift == 0) { /* %----------------------------------% */ /* | Move the NP shifts from WORKL to | */ /* | RITZR, RITZI to free up WORKL | */ /* | for non-exact shift case. | */ /* %----------------------------------% */ scopy_(np, &workl[1], &c__1, &ritzr[1], &c__1); scopy_(np, &workl[*np + 1], &c__1, &ritzi[1], &c__1); } if (msglvl > 2) { ivout_(&debug_1.logfil, &c__1, np, &debug_1.ndigit, "_naup2: The num" "ber of shifts to apply ", (ftnlen)38); svout_(&debug_1.logfil, np, &ritzr[1], &debug_1.ndigit, "_naup2: Rea" "l part of the shifts", (ftnlen)31); svout_(&debug_1.logfil, np, &ritzi[1], &debug_1.ndigit, "_naup2: Ima" "ginary part of the shifts", (ftnlen)36); if (*ishift == 1) { svout_(&debug_1.logfil, np, &bounds[1], &debug_1.ndigit, "_naup2" ": Ritz estimates of the shifts", (ftnlen)36); } } /* %---------------------------------------------------------% */ /* | Apply the NP implicit shifts by QR bulge chasing. | */ /* | Each shift is applied to the whole upper Hessenberg | */ /* | matrix H. | */ /* | The first 2*N locations of WORKD are used as workspace. | */ /* %---------------------------------------------------------% */ snapps_(n, nev, np, &ritzr[1], &ritzi[1], &v[v_offset], ldv, &h__[ h_offset], ldh, &resid[1], &q[q_offset], ldq, &workl[1], &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 snaitr. | */ /* %---------------------------------------------% */ cnorm = TRUE_; second_(&t2); if (*(unsigned char *)bmat == 'G') { ++timing_1.nbx; scopy_(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') { scopy_(n, &resid[1], &c__1, &workd[1], &c__1); } L100: /* %----------------------------------% */ /* | Back from reverse communication; | */ /* | WORKD(1:N) := B*RESID | */ /* %----------------------------------% */ if (*(unsigned char *)bmat == 'G') { second_(&t3); timing_1.tmvbx += t3 - t2; } if (*(unsigned char *)bmat == 'G') { rnorm = sdot_(n, &resid[1], &c__1, &workd[1], &c__1); rnorm = sqrt((dabs(rnorm))); } else if (*(unsigned char *)bmat == 'I') { rnorm = snrm2_(n, &resid[1], &c__1); } cnorm = FALSE_; if (msglvl > 2) { svout_(&debug_1.logfil, &c__1, &rnorm, &debug_1.ndigit, "_naup2: B-n" "orm of residual for compressed factorization", (ftnlen)55); smout_(&debug_1.logfil, nev, nev, &h__[h_offset], ldh, & debug_1.ndigit, "_naup2: Compressed upper Hessenberg matrix H" , (ftnlen)44); } 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 = numcnv; L1200: *ido = 99; /* %------------% */ /* | Error Exit | */ /* %------------% */ second_(&t1); timing_1.tnaup2 = t1 - t0; L9000: /* %---------------% */ /* | End of snaup2 | */ /* %---------------% */ return 0; } /* snaup2_ */
/* Subroutine */ int snapps_(integer *n, integer *kev, integer *np, real * shiftr, real *shifti, real *v, integer *ldv, real *h__, integer *ldh, real *resid, real *q, integer *ldq, real *workl, real *workd) { /* Initialized data */ static logical first = TRUE_; /* System generated locals */ integer h_dim1, h_offset, v_dim1, v_offset, q_dim1, q_offset, i__1, i__2, i__3, i__4; real r__1, r__2; /* Local variables */ static real c__, f, g; static integer i__, j; static real r__, s, t, u[3], t0, t1, h11, h12, h21, h22, h32; static integer jj, ir, nr; static real tau, ulp, tst1; static integer iend; static real unfl, ovfl; static logical cconj; extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), slarf_(char *, integer *, integer *, real *, integer *, real *, real *, integer *, real *, ftnlen), sgemv_(char *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *, ftnlen), scopy_(integer *, real *, integer *, real *, integer *), saxpy_(integer *, real *, real *, integer *, real *, integer *), ivout_(integer *, integer *, integer *, integer *, char *, ftnlen), smout_(integer *, integer *, integer * , real *, integer *, integer *, char *, ftnlen), svout_(integer *, integer *, real *, integer *, char *, ftnlen); extern doublereal slapy2_(real *, real *); extern /* Subroutine */ int slabad_(real *, real *); extern doublereal slamch_(char *, ftnlen); static real sigmai; extern /* Subroutine */ int second_(real *); static real sigmar; static integer istart, kplusp, msglvl; static real smlnum; extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *, ftnlen), slarfg_(integer *, real *, real *, integer *, real *), slaset_(char *, integer *, integer *, real *, real *, real *, integer *, ftnlen), slartg_(real *, real * , real *, real *, real *); extern doublereal slanhs_(char *, integer *, real *, integer *, real *, 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 & Arrays | */ /* %------------------------% */ /* %----------------------% */ /* | External Subroutines | */ /* %----------------------% */ /* %--------------------% */ /* | External Functions | */ /* %--------------------% */ /* %----------------------% */ /* | Intrinsics Functions | */ /* %----------------------% */ /* %----------------% */ /* | Data statments | */ /* %----------------% */ /* Parameter adjustments */ --workd; --resid; --workl; --shifti; --shiftr; v_dim1 = *ldv; v_offset = 1 + v_dim1; v -= v_offset; h_dim1 = *ldh; h_offset = 1 + h_dim1; h__ -= h_offset; q_dim1 = *ldq; q_offset = 1 + q_dim1; q -= q_offset; /* Function Body */ /* %-----------------------% */ /* | Executable Statements | */ /* %-----------------------% */ if (first) { /* %-----------------------------------------------% */ /* | Set machine-dependent constants for the | */ /* | stopping criterion. If norm(H) <= sqrt(OVFL), | */ /* | overflow should not occur. | */ /* | REFERENCE: LAPACK subroutine slahqr | */ /* %-----------------------------------------------% */ unfl = slamch_("safe minimum", (ftnlen)12); ovfl = 1.f / unfl; slabad_(&unfl, &ovfl); ulp = slamch_("precision", (ftnlen)9); smlnum = unfl * (*n / ulp); first = FALSE_; } /* %-------------------------------% */ /* | Initialize timing statistics | */ /* | & message level for debugging | */ /* %-------------------------------% */ second_(&t0); msglvl = debug_1.mnapps; kplusp = *kev + *np; /* %--------------------------------------------% */ /* | Initialize Q to the identity to accumulate | */ /* | the rotations and reflections | */ /* %--------------------------------------------% */ slaset_("All", &kplusp, &kplusp, &c_b5, &c_b6, &q[q_offset], ldq, (ftnlen) 3); /* %----------------------------------------------% */ /* | Quick return if there are no shifts to apply | */ /* %----------------------------------------------% */ if (*np == 0) { goto L9000; } /* %----------------------------------------------% */ /* | Chase the bulge with the application of each | */ /* | implicit shift. Each shift is applied to the | */ /* | whole matrix including each block. | */ /* %----------------------------------------------% */ cconj = FALSE_; i__1 = *np; for (jj = 1; jj <= i__1; ++jj) { sigmar = shiftr[jj]; sigmai = shifti[jj]; if (msglvl > 2) { ivout_(&debug_1.logfil, &c__1, &jj, &debug_1.ndigit, "_napps: sh" "ift number.", (ftnlen)21); svout_(&debug_1.logfil, &c__1, &sigmar, &debug_1.ndigit, "_napps" ": The real part of the shift ", (ftnlen)35); svout_(&debug_1.logfil, &c__1, &sigmai, &debug_1.ndigit, "_napps" ": The imaginary part of the shift ", (ftnlen)40); } /* %-------------------------------------------------% */ /* | The following set of conditionals is necessary | */ /* | in order that complex conjugate pairs of shifts | */ /* | are applied together or not at all. | */ /* %-------------------------------------------------% */ if (cconj) { /* %-----------------------------------------% */ /* | cconj = .true. means the previous shift | */ /* | had non-zero imaginary part. | */ /* %-----------------------------------------% */ cconj = FALSE_; goto L110; } else if (jj < *np && dabs(sigmai) > 0.f) { /* %------------------------------------% */ /* | Start of a complex conjugate pair. | */ /* %------------------------------------% */ cconj = TRUE_; } else if (jj == *np && dabs(sigmai) > 0.f) { /* %----------------------------------------------% */ /* | The last shift has a nonzero imaginary part. | */ /* | Don't apply it; thus the order of the | */ /* | compressed H is order KEV+1 since only np-1 | */ /* | were applied. | */ /* %----------------------------------------------% */ ++(*kev); goto L110; } istart = 1; L20: /* %--------------------------------------------------% */ /* | if sigmai = 0 then | */ /* | Apply the jj-th shift ... | */ /* | else | */ /* | Apply the jj-th and (jj+1)-th together ... | */ /* | (Note that jj < np at this point in the code) | */ /* | end | */ /* | to the current block of H. The next do loop | */ /* | determines the current block ; | */ /* %--------------------------------------------------% */ i__2 = kplusp - 1; for (i__ = istart; i__ <= i__2; ++i__) { /* %----------------------------------------% */ /* | Check for splitting and deflation. Use | */ /* | a standard test as in the QR algorithm | */ /* | REFERENCE: LAPACK subroutine slahqr | */ /* %----------------------------------------% */ tst1 = (r__1 = h__[i__ + i__ * h_dim1], dabs(r__1)) + (r__2 = h__[ i__ + 1 + (i__ + 1) * h_dim1], dabs(r__2)); if (tst1 == 0.f) { i__3 = kplusp - jj + 1; tst1 = slanhs_("1", &i__3, &h__[h_offset], ldh, &workl[1], ( ftnlen)1); } /* Computing MAX */ r__2 = ulp * tst1; if ((r__1 = h__[i__ + 1 + i__ * h_dim1], dabs(r__1)) <= dmax(r__2, smlnum)) { if (msglvl > 0) { ivout_(&debug_1.logfil, &c__1, &i__, &debug_1.ndigit, "_napps: matrix splitting at row/column no.", ( ftnlen)42); ivout_(&debug_1.logfil, &c__1, &jj, &debug_1.ndigit, "_napps: matrix splitting with shift number.", ( ftnlen)43); svout_(&debug_1.logfil, &c__1, &h__[i__ + 1 + i__ * h_dim1], &debug_1.ndigit, "_napps: off diagonal " "element.", (ftnlen)29); } iend = i__; h__[i__ + 1 + i__ * h_dim1] = 0.f; goto L40; } /* L30: */ } iend = kplusp; L40: if (msglvl > 2) { ivout_(&debug_1.logfil, &c__1, &istart, &debug_1.ndigit, "_napps" ": Start of current block ", (ftnlen)31); ivout_(&debug_1.logfil, &c__1, &iend, &debug_1.ndigit, "_napps: " "End of current block ", (ftnlen)29); } /* %------------------------------------------------% */ /* | No reason to apply a shift to block of order 1 | */ /* %------------------------------------------------% */ if (istart == iend) { goto L100; } /* %------------------------------------------------------% */ /* | If istart + 1 = iend then no reason to apply a | */ /* | complex conjugate pair of shifts on a 2 by 2 matrix. | */ /* %------------------------------------------------------% */ if (istart + 1 == iend && dabs(sigmai) > 0.f) { goto L100; } h11 = h__[istart + istart * h_dim1]; h21 = h__[istart + 1 + istart * h_dim1]; if (dabs(sigmai) <= 0.f) { /* %---------------------------------------------% */ /* | Real-valued shift ==> apply single shift QR | */ /* %---------------------------------------------% */ f = h11 - sigmar; g = h21; i__2 = iend - 1; for (i__ = istart; i__ <= i__2; ++i__) { /* %-----------------------------------------------------% */ /* | Contruct the plane rotation G to zero out the bulge | */ /* %-----------------------------------------------------% */ slartg_(&f, &g, &c__, &s, &r__); if (i__ > istart) { /* %-------------------------------------------% */ /* | The following ensures that h(1:iend-1,1), | */ /* | the first iend-2 off diagonal of elements | */ /* | H, remain non negative. | */ /* %-------------------------------------------% */ if (r__ < 0.f) { r__ = -r__; c__ = -c__; s = -s; } h__[i__ + (i__ - 1) * h_dim1] = r__; h__[i__ + 1 + (i__ - 1) * h_dim1] = 0.f; } /* %---------------------------------------------% */ /* | Apply rotation to the left of H; H <- G'*H | */ /* %---------------------------------------------% */ i__3 = kplusp; for (j = i__; j <= i__3; ++j) { t = c__ * h__[i__ + j * h_dim1] + s * h__[i__ + 1 + j * h_dim1]; h__[i__ + 1 + j * h_dim1] = -s * h__[i__ + j * h_dim1] + c__ * h__[i__ + 1 + j * h_dim1]; h__[i__ + j * h_dim1] = t; /* L50: */ } /* %---------------------------------------------% */ /* | Apply rotation to the right of H; H <- H*G | */ /* %---------------------------------------------% */ /* Computing MIN */ i__4 = i__ + 2; i__3 = min(i__4,iend); for (j = 1; j <= i__3; ++j) { t = c__ * h__[j + i__ * h_dim1] + s * h__[j + (i__ + 1) * h_dim1]; h__[j + (i__ + 1) * h_dim1] = -s * h__[j + i__ * h_dim1] + c__ * h__[j + (i__ + 1) * h_dim1]; h__[j + i__ * h_dim1] = t; /* L60: */ } /* %----------------------------------------------------% */ /* | Accumulate the rotation in the matrix Q; Q <- Q*G | */ /* %----------------------------------------------------% */ /* Computing MIN */ i__4 = i__ + jj; i__3 = min(i__4,kplusp); for (j = 1; j <= i__3; ++j) { t = c__ * q[j + i__ * q_dim1] + s * q[j + (i__ + 1) * q_dim1]; q[j + (i__ + 1) * q_dim1] = -s * q[j + i__ * q_dim1] + c__ * q[j + (i__ + 1) * q_dim1]; q[j + i__ * q_dim1] = t; /* L70: */ } /* %---------------------------% */ /* | Prepare for next rotation | */ /* %---------------------------% */ if (i__ < iend - 1) { f = h__[i__ + 1 + i__ * h_dim1]; g = h__[i__ + 2 + i__ * h_dim1]; } /* L80: */ } /* %-----------------------------------% */ /* | Finished applying the real shift. | */ /* %-----------------------------------% */ } else { /* %----------------------------------------------------% */ /* | Complex conjugate shifts ==> apply double shift QR | */ /* %----------------------------------------------------% */ h12 = h__[istart + (istart + 1) * h_dim1]; h22 = h__[istart + 1 + (istart + 1) * h_dim1]; h32 = h__[istart + 2 + (istart + 1) * h_dim1]; /* %---------------------------------------------------------% */ /* | Compute 1st column of (H - shift*I)*(H - conj(shift)*I) | */ /* %---------------------------------------------------------% */ s = sigmar * 2.f; t = slapy2_(&sigmar, &sigmai); u[0] = (h11 * (h11 - s) + t * t) / h21 + h12; u[1] = h11 + h22 - s; u[2] = h32; i__2 = iend - 1; for (i__ = istart; i__ <= i__2; ++i__) { /* Computing MIN */ i__3 = 3, i__4 = iend - i__ + 1; nr = min(i__3,i__4); /* %-----------------------------------------------------% */ /* | Construct Householder reflector G to zero out u(1). | */ /* | G is of the form I - tau*( 1 u )' * ( 1 u' ). | */ /* %-----------------------------------------------------% */ slarfg_(&nr, u, &u[1], &c__1, &tau); if (i__ > istart) { h__[i__ + (i__ - 1) * h_dim1] = u[0]; h__[i__ + 1 + (i__ - 1) * h_dim1] = 0.f; if (i__ < iend - 1) { h__[i__ + 2 + (i__ - 1) * h_dim1] = 0.f; } } u[0] = 1.f; /* %--------------------------------------% */ /* | Apply the reflector to the left of H | */ /* %--------------------------------------% */ i__3 = kplusp - i__ + 1; slarf_("Left", &nr, &i__3, u, &c__1, &tau, &h__[i__ + i__ * h_dim1], ldh, &workl[1], (ftnlen)4); /* %---------------------------------------% */ /* | Apply the reflector to the right of H | */ /* %---------------------------------------% */ /* Computing MIN */ i__3 = i__ + 3; ir = min(i__3,iend); slarf_("Right", &ir, &nr, u, &c__1, &tau, &h__[i__ * h_dim1 + 1], ldh, &workl[1], (ftnlen)5); /* %-----------------------------------------------------% */ /* | Accumulate the reflector in the matrix Q; Q <- Q*G | */ /* %-----------------------------------------------------% */ slarf_("Right", &kplusp, &nr, u, &c__1, &tau, &q[i__ * q_dim1 + 1], ldq, &workl[1], (ftnlen)5); /* %----------------------------% */ /* | Prepare for next reflector | */ /* %----------------------------% */ if (i__ < iend - 1) { u[0] = h__[i__ + 1 + i__ * h_dim1]; u[1] = h__[i__ + 2 + i__ * h_dim1]; if (i__ < iend - 2) { u[2] = h__[i__ + 3 + i__ * h_dim1]; } } /* L90: */ } /* %--------------------------------------------% */ /* | Finished applying a complex pair of shifts | */ /* | to the current block | */ /* %--------------------------------------------% */ } L100: /* %---------------------------------------------------------% */ /* | Apply the same shift to the next block if there is any. | */ /* %---------------------------------------------------------% */ istart = iend + 1; if (iend < kplusp) { goto L20; } /* %---------------------------------------------% */ /* | Loop back to the top to get the next shift. | */ /* %---------------------------------------------% */ L110: ; } /* %--------------------------------------------------% */ /* | Perform a similarity transformation that makes | */ /* | sure that H will have non negative sub diagonals | */ /* %--------------------------------------------------% */ i__1 = *kev; for (j = 1; j <= i__1; ++j) { if (h__[j + 1 + j * h_dim1] < 0.f) { i__2 = kplusp - j + 1; sscal_(&i__2, &c_b43, &h__[j + 1 + j * h_dim1], ldh); /* Computing MIN */ i__3 = j + 2; i__2 = min(i__3,kplusp); sscal_(&i__2, &c_b43, &h__[(j + 1) * h_dim1 + 1], &c__1); /* Computing MIN */ i__3 = j + *np + 1; i__2 = min(i__3,kplusp); sscal_(&i__2, &c_b43, &q[(j + 1) * q_dim1 + 1], &c__1); } /* L120: */ } i__1 = *kev; for (i__ = 1; i__ <= i__1; ++i__) { /* %--------------------------------------------% */ /* | Final check for splitting and deflation. | */ /* | Use a standard test as in the QR algorithm | */ /* | REFERENCE: LAPACK subroutine slahqr | */ /* %--------------------------------------------% */ tst1 = (r__1 = h__[i__ + i__ * h_dim1], dabs(r__1)) + (r__2 = h__[i__ + 1 + (i__ + 1) * h_dim1], dabs(r__2)); if (tst1 == 0.f) { tst1 = slanhs_("1", kev, &h__[h_offset], ldh, &workl[1], (ftnlen) 1); } /* Computing MAX */ r__1 = ulp * tst1; if (h__[i__ + 1 + i__ * h_dim1] <= dmax(r__1,smlnum)) { h__[i__ + 1 + i__ * h_dim1] = 0.f; } /* L130: */ } /* %-------------------------------------------------% */ /* | Compute the (kev+1)-st column of (V*Q) and | */ /* | temporarily store the result in WORKD(N+1:2*N). | */ /* | This is needed in the residual update since we | */ /* | cannot GUARANTEE that the corresponding entry | */ /* | of H would be zero as in exact arithmetic. | */ /* %-------------------------------------------------% */ if (h__[*kev + 1 + *kev * h_dim1] > 0.f) { sgemv_("N", n, &kplusp, &c_b6, &v[v_offset], ldv, &q[(*kev + 1) * q_dim1 + 1], &c__1, &c_b5, &workd[*n + 1], &c__1, (ftnlen)1); } /* %----------------------------------------------------------% */ /* | Compute column 1 to kev of (V*Q) in backward order | */ /* | taking advantage of the upper Hessenberg structure of Q. | */ /* %----------------------------------------------------------% */ i__1 = *kev; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = kplusp - i__ + 1; sgemv_("N", n, &i__2, &c_b6, &v[v_offset], ldv, &q[(*kev - i__ + 1) * q_dim1 + 1], &c__1, &c_b5, &workd[1], &c__1, (ftnlen)1); scopy_(n, &workd[1], &c__1, &v[(kplusp - i__ + 1) * v_dim1 + 1], & c__1); /* L140: */ } /* %-------------------------------------------------% */ /* | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | */ /* %-------------------------------------------------% */ slacpy_("A", n, kev, &v[(kplusp - *kev + 1) * v_dim1 + 1], ldv, &v[ v_offset], ldv, (ftnlen)1); /* %--------------------------------------------------------------% */ /* | Copy the (kev+1)-st column of (V*Q) in the appropriate place | */ /* %--------------------------------------------------------------% */ if (h__[*kev + 1 + *kev * h_dim1] > 0.f) { scopy_(n, &workd[*n + 1], &c__1, &v[(*kev + 1) * v_dim1 + 1], &c__1); } /* %-------------------------------------% */ /* | Update the residual vector: | */ /* | r <- sigmak*r + betak*v(:,kev+1) | */ /* | where | */ /* | sigmak = (e_{kplusp}'*Q)*e_{kev} | */ /* | betak = e_{kev+1}'*H*e_{kev} | */ /* %-------------------------------------% */ sscal_(n, &q[kplusp + *kev * q_dim1], &resid[1], &c__1); if (h__[*kev + 1 + *kev * h_dim1] > 0.f) { saxpy_(n, &h__[*kev + 1 + *kev * h_dim1], &v[(*kev + 1) * v_dim1 + 1], &c__1, &resid[1], &c__1); } if (msglvl > 1) { svout_(&debug_1.logfil, &c__1, &q[kplusp + *kev * q_dim1], & debug_1.ndigit, "_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}", ( ftnlen)40); svout_(&debug_1.logfil, &c__1, &h__[*kev + 1 + *kev * h_dim1], & debug_1.ndigit, "_napps: betak = e_{kev+1}^T*H*e_{kev}", ( ftnlen)37); ivout_(&debug_1.logfil, &c__1, kev, &debug_1.ndigit, "_napps: Order " "of the final Hessenberg matrix ", (ftnlen)45); if (msglvl > 2) { smout_(&debug_1.logfil, kev, kev, &h__[h_offset], ldh, & debug_1.ndigit, "_napps: updated Hessenberg matrix H for" " next iteration", (ftnlen)54); } } L9000: second_(&t1); timing_1.tnapps += t1 - t0; return 0; /* %---------------% */ /* | End of snapps | */ /* %---------------% */ } /* snapps_ */
/* Subroutine */ int ssaup2_(integer *ido, char *bmat, integer *n, char * which, integer *nev, integer *np, real *tol, real *resid, integer * mode, integer *iupd, integer *ishift, integer *mxiter, real *v, integer *ldv, real *h__, integer *ldh, real *ritz, real *bounds, real *q, integer *ldq, real *workl, integer *ipntr, real *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; real r__1, r__2, r__3; doublereal d__1; /* 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 */ static integer j; static real t0, t1, t2, t3; static integer kp[3], np0, nev0; static real eps23; static integer ierr, iter; static real temp; extern doublereal sdot_(integer *, real *, integer *, real *, integer *); static integer nevd2; static logical getv0; static integer nevm2; extern doublereal snrm2_(integer *, real *, integer *); static logical cnorm; static integer nconv; static logical initv; static real rnorm; extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, integer *), sswap_(integer *, real *, integer *, real *, integer * ), ivout_(integer *, integer *, integer *, integer *, char *, ftnlen), svout_(integer *, integer *, real *, integer *, char *, ftnlen), sgetv0_(integer *, char *, integer *, logical *, integer *, integer *, real *, integer *, real *, real *, integer *, real * , integer *, ftnlen); static integer nevbef; extern doublereal slamch_(char *, ftnlen); extern /* Subroutine */ int second_(real *); static logical update; static char wprime[2]; static logical ushift; static integer kplusp, msglvl, nptemp; extern /* Subroutine */ int ssaitr_(integer *, char *, integer *, integer *, integer *, integer *, real *, real *, real *, integer *, real * , integer *, integer *, real *, integer *, ftnlen), ssconv_( integer *, real *, real *, real *, integer *), sseigt_(real *, integer *, real *, integer *, real *, real *, real *, integer *), ssgets_(integer *, char *, integer *, integer *, real *, real *, real *, ftnlen), ssapps_(integer *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *, real *), ssortr_(char *, logical *, integer *, real *, real *, 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 | */ /* %-------------------------------% */ second_(&t0); msglvl = debug_1.msaup2; /* %---------------------------------% */ /* | Set machine dependent constant. | */ /* %---------------------------------% */ eps23 = slamch_("Epsilon-Machine", (ftnlen)15); d__1 = (doublereal) eps23; eps23 = pow_dd(&d__1, &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) { sgetv0_(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.f) { /* %-----------------------------------------% */ /* | 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 | */ /* %----------------------------------------------------------% */ ssaitr_(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) { /* %-----------------------------------------------------% */ /* | ssaitr 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_; ssaitr_(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) { /* %-----------------------------------------------------% */ /* | ssaitr 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) { svout_(&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. | */ /* %--------------------------------------------------------% */ sseigt_(&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. | */ /* %----------------------------------------------------% */ scopy_(&kplusp, &ritz[1], &c__1, &workl[kplusp + 1], &c__1); scopy_(&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; ssgets_(ishift, which, nev, np, &ritz[1], &bounds[1], &workl[1], (ftnlen) 2); /* %-------------------% */ /* | Convergence test. | */ /* %-------------------% */ scopy_(nev, &bounds[*np + 1], &c__1, &workl[*np + 1], &c__1); ssconv_(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); svout_(&debug_1.logfil, &kplusp, &ritz[1], &debug_1.ndigit, "_saup2:" " The eigenvalues of H", (ftnlen)28); svout_(&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.f) { --(*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); ssortr_(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; sswap_(&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; sswap_(&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); } ssortr_(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 */ r__2 = eps23, r__3 = (r__1 = ritz[j], dabs(r__1)); temp = dmax(r__2,r__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); ssortr_(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 */ r__2 = eps23, r__3 = (r__1 = ritz[j], dabs(r__1)); temp = dmax(r__2,r__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); ssortr_(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. | */ /* %----------------------------------------------% */ ssortr_(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) { svout_(&debug_1.logfil, &kplusp, &ritz[1], &debug_1.ndigit, "_sa" "up2: Sorted Ritz values.", (ftnlen)27); svout_(&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) { ssgets_(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); svout_(&debug_1.logfil, nev, &ritz[*np + 1], &debug_1.ndigit, "_saup2: \"wanted\" Ritz values.", (ftnlen)29); svout_(&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, ssgets already handles this. | */ /* %---------------------------------------------------------% */ if (*ishift == 0) { scopy_(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); svout_(&debug_1.logfil, np, &workl[1], &debug_1.ndigit, "_saup2: shi" "fts selected", (ftnlen)23); if (*ishift == 1) { svout_(&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 ssapps is done, we have a Lanczos | */ /* | factorization of length NEV. | */ /* %---------------------------------------------------------% */ ssapps_(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 ssaitr. | */ /* %---------------------------------------------% */ cnorm = TRUE_; second_(&t2); if (*(unsigned char *)bmat == 'G') { ++timing_1.nbx; scopy_(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') { scopy_(n, &resid[1], &c__1, &workd[1], &c__1); } L100: /* %----------------------------------% */ /* | Back from reverse communication; | */ /* | WORKD(1:N) := B*RESID | */ /* %----------------------------------% */ if (*(unsigned char *)bmat == 'G') { second_(&t3); timing_1.tmvbx += t3 - t2; } if (*(unsigned char *)bmat == 'G') { rnorm = sdot_(n, &resid[1], &c__1, &workd[1], &c__1); rnorm = sqrt((dabs(rnorm))); } else if (*(unsigned char *)bmat == 'I') { rnorm = snrm2_(n, &resid[1], &c__1); } cnorm = FALSE_; /* L130: */ if (msglvl > 2) { svout_(&debug_1.logfil, &c__1, &rnorm, &debug_1.ndigit, "_saup2: B-n" "orm of residual for NEV factorization", (ftnlen)48); svout_(&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; svout_(&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 | */ /* %------------% */ second_(&t1); timing_1.tsaup2 = t1 - t0; L9000: return 0; /* %---------------% */ /* | End of ssaup2 | */ /* %---------------% */ } /* ssaup2_ */
/* Subroutine */ int sngets_(integer *ishift, char *which, integer *kev, integer *np, real *ritzr, real *ritzi, real *bounds, real *shiftr, real *shifti, ftnlen which_len) { /* System generated locals */ integer i__1; /* Local variables */ static real t0, t1; extern /* Subroutine */ int ivout_(integer *, integer *, integer *, integer *, char *, ftnlen), svout_(integer *, integer *, real *, integer *, char *, ftnlen), arscnd_(real *); static integer msglvl; extern /* Subroutine */ int ssortc_(char *, logical *, integer *, real *, real *, real *, 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 | */ /* %----------------------% */ /* %----------------------% */ /* | Intrinsics Functions | */ /* %----------------------% */ /* %-----------------------% */ /* | Executable Statements | */ /* %-----------------------% */ /* %-------------------------------% */ /* | Initialize timing statistics | */ /* | & message level for debugging | */ /* %-------------------------------% */ /* Parameter adjustments */ --bounds; --ritzi; --ritzr; --shiftr; --shifti; /* Function Body */ arscnd_(&t0); msglvl = debug_1.mngets; /* %----------------------------------------------------% */ /* | LM, SM, LR, SR, LI, SI 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. | */ /* | We first do a pre-processing sort in order to keep | */ /* | complex conjugate pairs together | */ /* %----------------------------------------------------% */ if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) == 0) { i__1 = *kev + *np; ssortc_("LR", &c_true, &i__1, &ritzr[1], &ritzi[1], &bounds[1], ( ftnlen)2); } else if (s_cmp(which, "SM", (ftnlen)2, (ftnlen)2) == 0) { i__1 = *kev + *np; ssortc_("SR", &c_true, &i__1, &ritzr[1], &ritzi[1], &bounds[1], ( ftnlen)2); } else if (s_cmp(which, "LR", (ftnlen)2, (ftnlen)2) == 0) { i__1 = *kev + *np; ssortc_("LM", &c_true, &i__1, &ritzr[1], &ritzi[1], &bounds[1], ( ftnlen)2); } else if (s_cmp(which, "SR", (ftnlen)2, (ftnlen)2) == 0) { i__1 = *kev + *np; ssortc_("SM", &c_true, &i__1, &ritzr[1], &ritzi[1], &bounds[1], ( ftnlen)2); } else if (s_cmp(which, "LI", (ftnlen)2, (ftnlen)2) == 0) { i__1 = *kev + *np; ssortc_("LM", &c_true, &i__1, &ritzr[1], &ritzi[1], &bounds[1], ( ftnlen)2); } else if (s_cmp(which, "SI", (ftnlen)2, (ftnlen)2) == 0) { i__1 = *kev + *np; ssortc_("SM", &c_true, &i__1, &ritzr[1], &ritzi[1], &bounds[1], ( ftnlen)2); } i__1 = *kev + *np; ssortc_(which, &c_true, &i__1, &ritzr[1], &ritzi[1], &bounds[1], (ftnlen) 2); /* %-------------------------------------------------------% */ /* | Increase KEV by one if the ( ritzr(np),ritzi(np) ) | */ /* | = ( ritzr(np+1),-ritzi(np+1) ) and ritz(np) .ne. zero | */ /* | Accordingly decrease NP by one. In other words keep | */ /* | complex conjugate pairs together. | */ /* %-------------------------------------------------------% */ if (ritzr[*np + 1] - ritzr[*np] == 0.f && ritzi[*np + 1] + ritzi[*np] == 0.f) { --(*np); ++(*kev); } if (*ishift == 1) { /* %-------------------------------------------------------% */ /* | 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 they shifts | */ /* | are applied in subroutine snapps. | */ /* | Be careful and use 'SR' since we want to sort BOUNDS! | */ /* %-------------------------------------------------------% */ ssortc_("SR", &c_true, np, &bounds[1], &ritzr[1], &ritzi[1], (ftnlen) 2); } arscnd_(&t1); timing_1.tngets += t1 - t0; if (msglvl > 0) { ivout_(&debug_1.logfil, &c__1, kev, &debug_1.ndigit, "_ngets: KEV is", (ftnlen)14); ivout_(&debug_1.logfil, &c__1, np, &debug_1.ndigit, "_ngets: NP is", ( ftnlen)13); i__1 = *kev + *np; svout_(&debug_1.logfil, &i__1, &ritzr[1], &debug_1.ndigit, "_ngets: " "Eigenvalues of current H matrix -- real part", (ftnlen)52); i__1 = *kev + *np; svout_(&debug_1.logfil, &i__1, &ritzi[1], &debug_1.ndigit, "_ngets: " "Eigenvalues of current H matrix -- imag part", (ftnlen)52); i__1 = *kev + *np; svout_(&debug_1.logfil, &i__1, &bounds[1], &debug_1.ndigit, "_ngets:" " Ritz estimates of the current KEV+NP Ritz values", (ftnlen) 56); } return 0; /* %---------------% */ /* | End of sngets | */ /* %---------------% */ } /* sngets_ */
/* Subroutine */ int ssgets_(integer *ishift, char *which, integer *kev, integer *np, real *ritz, real *bounds, real *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 sswap_(integer *, real *, integer *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer * ), ivout_(integer *, integer *, integer *, integer *, char *, ftnlen), svout_(integer *, integer *, real *, integer *, char *, ftnlen), second_(real *); static integer msglvl; extern /* Subroutine */ int ssortr_(char *, logical *, integer *, real *, real *, 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 | */ /* %----------------------% */ /* %---------------------% */ /* | 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; ssortr_("LA", &c_true, &i__1, &ritz[1], &bounds[1], (ftnlen)2); kevd2 = *kev / 2; if (*kev > 1) { i__1 = min(kevd2,*np); sswap_(&i__1, &ritz[1], &c__1, &ritz[max(kevd2,*np) + 1], &c__1); i__1 = min(kevd2,*np); sswap_(&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; ssortr_(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 ssapps. | */ /* %-------------------------------------------------------% */ ssortr_("SM", &c_true, np, &bounds[1], &ritz[1], (ftnlen)2); scopy_(np, &ritz[1], &c__1, &shifts[1], &c__1); } second_(&t1); timing_1.tsgets += t1 - t0; if (msglvl > 0) { ivout_(&debug_1.logfil, &c__1, kev, &debug_1.ndigit, "_sgets: KEV is", (ftnlen)14); ivout_(&debug_1.logfil, &c__1, np, &debug_1.ndigit, "_sgets: NP is", ( ftnlen)13); i__1 = *kev + *np; svout_(&debug_1.logfil, &i__1, &ritz[1], &debug_1.ndigit, "_sgets: E" "igenvalues of current H matrix", (ftnlen)39); i__1 = *kev + *np; svout_(&debug_1.logfil, &i__1, &bounds[1], &debug_1.ndigit, "_sgets:" " Associated Ritz estimates", (ftnlen)33); } return 0; /* %---------------% */ /* | End of ssgets | */ /* %---------------% */ } /* ssgets_ */