/* Subroutine */ int zneigh_(doublereal *rnorm, integer *n, doublecomplex * h__, integer *ldh, doublecomplex *ritz, doublecomplex *bounds, doublecomplex *q, integer *ldq, doublecomplex *workl, doublereal * rwork, integer *ierr) { /* System generated locals */ integer h_dim1, h_offset, q_dim1, q_offset, i__1; doublereal d__1; /* Local variables */ static integer j; static real t0, t1; static doublecomplex vl[1]; static doublereal temp; extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), zmout_(integer *, integer *, integer *, doublecomplex *, integer *, integer *, char *, ftnlen), zvout_( integer *, integer *, doublecomplex *, integer *, char *, ftnlen); extern doublereal dznrm2_(integer *, doublecomplex *, integer *); extern /* Subroutine */ int second_(real *); static logical select[1]; static integer msglvl; extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, ftnlen), zlahqr_(logical *, logical *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, doublecomplex *, integer *, integer *), ztrevc_(char *, char *, logical *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, integer *, doublecomplex *, doublereal *, integer *, ftnlen, ftnlen), zdscal_(integer *, doublereal *, doublecomplex *, integer *), zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, 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 & Arrays | */ /* %------------------------% */ /* %----------------------% */ /* | External Subroutines | */ /* %----------------------% */ /* %--------------------% */ /* | External Functions | */ /* %--------------------% */ /* %-----------------------% */ /* | Executable Statements | */ /* %-----------------------% */ /* %-------------------------------% */ /* | Initialize timing statistics | */ /* | & message level for debugging | */ /* %-------------------------------% */ /* Parameter adjustments */ --rwork; --workl; --bounds; --ritz; h_dim1 = *ldh; h_offset = 1 + h_dim1; h__ -= h_offset; q_dim1 = *ldq; q_offset = 1 + q_dim1; q -= q_offset; /* Function Body */ second_(&t0); msglvl = debug_1.mceigh; if (msglvl > 2) { zmout_(&debug_1.logfil, n, n, &h__[h_offset], ldh, &debug_1.ndigit, "_neigh: Entering upper Hessenberg matrix H ", (ftnlen)43); } /* %----------------------------------------------------------% */ /* | 1. Compute the eigenvalues, the last components of the | */ /* | corresponding Schur vectors and the full Schur form T | */ /* | of the current upper Hessenberg matrix H. | */ /* | zlahqr returns the full Schur form of H | */ /* | in WORKL(1:N**2), and the Schur vectors in q. | */ /* %----------------------------------------------------------% */ zlacpy_("All", n, n, &h__[h_offset], ldh, &workl[1], n, (ftnlen)3); zlaset_("All", n, n, &c_b2, &c_b1, &q[q_offset], ldq, (ftnlen)3); zlahqr_(&c_true, &c_true, n, &c__1, n, &workl[1], ldh, &ritz[1], &c__1, n, &q[q_offset], ldq, ierr); if (*ierr != 0) { goto L9000; } zcopy_(n, &q[*n - 1 + q_dim1], ldq, &bounds[1], &c__1); if (msglvl > 1) { zvout_(&debug_1.logfil, n, &bounds[1], &debug_1.ndigit, "_neigh: las" "t row of the Schur matrix for H", (ftnlen)42); } /* %----------------------------------------------------------% */ /* | 2. Compute the eigenvectors of the full Schur form T and | */ /* | apply the Schur vectors to get the corresponding | */ /* | eigenvectors. | */ /* %----------------------------------------------------------% */ ztrevc_("Right", "Back", select, n, &workl[1], n, vl, n, &q[q_offset], ldq, n, n, &workl[*n * *n + 1], &rwork[1], ierr, (ftnlen)5, ( ftnlen)4); if (*ierr != 0) { goto L9000; } /* %------------------------------------------------% */ /* | Scale the returning eigenvectors so that their | */ /* | Euclidean norms are all one. LAPACK subroutine | */ /* | ztrevc returns each eigenvector normalized so | */ /* | that the element of largest magnitude has | */ /* | magnitude 1; here the magnitude of a complex | */ /* | number (x,y) is taken to be |x| + |y|. | */ /* %------------------------------------------------% */ i__1 = *n; for (j = 1; j <= i__1; ++j) { temp = dznrm2_(n, &q[j * q_dim1 + 1], &c__1); d__1 = 1. / temp; zdscal_(n, &d__1, &q[j * q_dim1 + 1], &c__1); /* L10: */ } if (msglvl > 1) { zcopy_(n, &q[*n + q_dim1], ldq, &workl[1], &c__1); zvout_(&debug_1.logfil, n, &workl[1], &debug_1.ndigit, "_neigh: Last" " row of the eigenvector matrix for H", (ftnlen)48); } /* %----------------------------% */ /* | Compute the Ritz estimates | */ /* %----------------------------% */ zcopy_(n, &q[*n + q_dim1], n, &bounds[1], &c__1); zdscal_(n, rnorm, &bounds[1], &c__1); if (msglvl > 2) { zvout_(&debug_1.logfil, n, &ritz[1], &debug_1.ndigit, "_neigh: The e" "igenvalues of H", (ftnlen)28); zvout_(&debug_1.logfil, n, &bounds[1], &debug_1.ndigit, "_neigh: Rit" "z estimates for the eigenvalues of H", (ftnlen)47); } second_(&t1); timing_1.tceigh += t1 - t0; L9000: return 0; /* %---------------% */ /* | End of zneigh | */ /* %---------------% */ } /* zneigh_ */
/* Subroutine */ int znaitr_(integer *ido, char *bmat, integer *n, integer *k, integer *np, integer *nb, doublecomplex *resid, doublereal *rnorm, doublecomplex *v, integer *ldv, doublecomplex *h__, integer *ldh, integer *ipntr, doublecomplex *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, i__3; doublereal d__1, d__2, d__3, d__4; doublecomplex z__1; /* Builtin functions */ double d_imag(doublecomplex *), sqrt(doublereal); /* Local variables */ static integer i__, j; static real t0, t1, t2, t3, t4, t5; static integer jj, ipj, irj, ivj; static doublereal ulp, tst1; static integer ierr, iter; static doublereal unfl, ovfl; static integer itry; static doublereal temp1; static logical orth1, orth2, step3, step4; static doublereal betaj; static integer infol; static doublecomplex cnorm; extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); static doublereal rtemp[2]; extern /* Subroutine */ int zgemv_(char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, ftnlen); static doublereal wnorm; extern /* Subroutine */ int dvout_(integer *, integer *, doublereal *, integer *, char *, ftnlen), zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), ivout_(integer *, integer *, integer *, integer *, char *, ftnlen), zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), zmout_(integer *, integer *, integer *, doublecomplex *, integer *, integer *, char *, ftnlen), zvout_(integer *, integer *, doublecomplex *, integer *, char *, ftnlen); extern doublereal dlapy2_(doublereal *, doublereal *); extern /* Subroutine */ int dlabad_(doublereal *, doublereal *); extern doublereal dznrm2_(integer *, doublecomplex *, integer *); static doublereal rnorm1; extern /* Subroutine */ int zgetv0_(integer *, char *, integer *, logical *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublereal *, integer *, doublecomplex *, integer *, ftnlen); extern doublereal dlamch_(char *, ftnlen); extern /* Subroutine */ int second_(real *), zdscal_(integer *, doublereal *, doublecomplex *, integer *); static logical rstart; static integer msglvl; static doublereal smlnum; extern doublereal zlanhs_(char *, integer *, doublecomplex *, integer *, doublecomplex *, ftnlen); extern /* Subroutine */ int zlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *, doublecomplex *, integer *, 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 Arrays | */ /* %--------------% */ /* %---------------% */ /* | Local Scalars | */ /* %---------------% */ /* %----------------------% */ /* | 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 zlahqr | */ /* %-----------------------------------------% */ unfl = dlamch_("safe minimum", (ftnlen)12); z__1.r = 1. / unfl, z__1.i = 0. / unfl; ovfl = z__1.r; dlabad_(&unfl, &ovfl); ulp = dlamch_("precision", (ftnlen)9); smlnum = unfl * (*n / ulp); first = FALSE_; } if (*ido == 0) { /* %-------------------------------% */ /* | Initialize timing statistics | */ /* | & message level for debugging | */ /* %-------------------------------% */ second_(&t0); msglvl = debug_1.mcaitr; /* %------------------------------% */ /* | 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 | */ /* | zgetv0. | */ /* %-------------------------------------------------% */ 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); dvout_(&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 determine whether | */ /* | an exact j-step Arnoldi factorization is present. | */ /* %---------------------------------------------------% */ betaj = *rnorm; if (*rnorm > 0.) { goto L40; } /* %---------------------------------------------------% */ /* | Invariant subspace found, generate a new starting | */ /* | vector which is orthogonal to the current Arnoldi | */ /* | basis and continue the iteration. | */ /* %---------------------------------------------------% */ if (msglvl > 0) { 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.; ++timing_1.nrstrt; itry = 1; L20: rstart = TRUE_; *ido = 0; L30: /* %--------------------------------------% */ /* | If in reverse communication mode and | */ /* | RSTART = .true. flow returns here. | */ /* %--------------------------------------% */ zgetv0_(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.tcaitr += 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. | */ /* %---------------------------------------------------------% */ zcopy_(n, &resid[1], &c__1, &v[j * v_dim1 + 1], &c__1); if (*rnorm >= unfl) { temp1 = 1. / *rnorm; zdscal_(n, &temp1, &v[j * v_dim1 + 1], &c__1); zdscal_(n, &temp1, &workd[ipj], &c__1); } else { /* %-----------------------------------------% */ /* | To scale both v_{j} and p_{j} carefully | */ /* | use LAPACK routine zlascl | */ /* %-----------------------------------------% */ zlascl_("General", &i__, &i__, rnorm, &c_b27, n, &c__1, &v[j * v_dim1 + 1], n, &infol, (ftnlen)7); zlascl_("General", &i__, &i__, rnorm, &c_b27, 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); zcopy_(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. | */ /* %------------------------------------------% */ zcopy_(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') { zcopy_(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') { zdotc_(&z__1, n, &resid[1], &c__1, &workd[ipj], &c__1); cnorm.r = z__1.r, cnorm.i = z__1.i; d__1 = cnorm.r; d__2 = d_imag(&cnorm); wnorm = sqrt(dlapy2_(&d__1, &d__2)); } else if (*(unsigned char *)bmat == 'I') { wnorm = dznrm2_(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}. | */ /* %------------------------------------------% */ zgemv_("C", n, &j, &c_b1, &v[v_offset], ldv, &workd[ipj], &c__1, &c_b2, & h__[j * h_dim1 + 1], &c__1, (ftnlen)1); /* %--------------------------------------% */ /* | Orthogonalize r_{j} against V_{j}. | */ /* | RESID contains OP*v_{j}. See STEP 3. | */ /* %--------------------------------------% */ z__1.r = -1., z__1.i = -0.; zgemv_("N", n, &j, &z__1, &v[v_offset], ldv, &h__[j * h_dim1 + 1], &c__1, &c_b1, &resid[1], &c__1, (ftnlen)1); if (j > 1) { i__1 = j + (j - 1) * h_dim1; z__1.r = betaj, z__1.i = 0.; h__[i__1].r = z__1.r, h__[i__1].i = z__1.i; } second_(&t4); orth1 = TRUE_; second_(&t2); if (*(unsigned char *)bmat == 'G') { ++timing_1.nbx; zcopy_(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') { zcopy_(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') { zdotc_(&z__1, n, &resid[1], &c__1, &workd[ipj], &c__1); cnorm.r = z__1.r, cnorm.i = z__1.i; d__1 = cnorm.r; d__2 = d_imag(&cnorm); *rnorm = sqrt(dlapy2_(&d__1, &d__2)); } else if (*(unsigned char *)bmat == 'I') { *rnorm = dznrm2_(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) { rtemp[0] = wnorm; rtemp[1] = *rnorm; dvout_(&debug_1.logfil, &c__2, rtemp, &debug_1.ndigit, "_naitr: re-o" "rthogonalization; wnorm and rnorm are", (ftnlen)49); zvout_(&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). | */ /* %----------------------------------------------------% */ zgemv_("C", n, &j, &c_b1, &v[v_offset], ldv, &workd[ipj], &c__1, &c_b2, & 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. | */ /* %---------------------------------------------% */ z__1.r = -1., z__1.i = -0.; zgemv_("N", n, &j, &z__1, &v[v_offset], ldv, &workd[irj], &c__1, &c_b1, & resid[1], &c__1, (ftnlen)1); zaxpy_(&j, &c_b1, &workd[irj], &c__1, &h__[j * h_dim1 + 1], &c__1); orth2 = TRUE_; second_(&t2); if (*(unsigned char *)bmat == 'G') { ++timing_1.nbx; zcopy_(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') { zcopy_(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') { zdotc_(&z__1, n, &resid[1], &c__1, &workd[ipj], &c__1); cnorm.r = z__1.r, cnorm.i = z__1.i; d__1 = cnorm.r; d__2 = d_imag(&cnorm); rnorm1 = sqrt(dlapy2_(&d__1, &d__2)); } else if (*(unsigned char *)bmat == 'I') { rnorm1 = dznrm2_(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) { rtemp[0] = *rnorm; rtemp[1] = rnorm1; dvout_(&debug_1.logfil, &c__2, rtemp, &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) { i__2 = jj; resid[i__2].r = 0., resid[i__2].i = 0.; /* L95: */ } *rnorm = 0.; } /* %----------------------------------------------% */ /* | Branch here directly if iterative refinement | */ /* | wasn't necessary or after at most NITER_REF | */ /* | steps of iterative refinement. | */ /* %----------------------------------------------% */ L100: rstart = FALSE_; orth2 = FALSE_; second_(&t5); timing_1.titref += t5 - t4; /* %------------------------------------% */ /* | STEP 6: Update j = j+1; Continue | */ /* %------------------------------------% */ ++j; if (j > *k + *np) { second_(&t1); timing_1.tcaitr += 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 zlahqr | */ /* %--------------------------------------------% */ i__2 = i__ + i__ * h_dim1; d__1 = h__[i__2].r; d__2 = d_imag(&h__[i__ + i__ * h_dim1]); i__3 = i__ + 1 + (i__ + 1) * h_dim1; d__3 = h__[i__3].r; d__4 = d_imag(&h__[i__ + 1 + (i__ + 1) * h_dim1]); tst1 = dlapy2_(&d__1, &d__2) + dlapy2_(&d__3, &d__4); if (tst1 == 0.) { i__2 = *k + *np; tst1 = zlanhs_("1", &i__2, &h__[h_offset], ldh, &workd[*n + 1] , (ftnlen)1); } i__2 = i__ + 1 + i__ * h_dim1; d__1 = h__[i__2].r; d__2 = d_imag(&h__[i__ + 1 + i__ * h_dim1]); /* Computing MAX */ d__3 = ulp * tst1; if (dlapy2_(&d__1, &d__2) <= max(d__3,smlnum)) { i__3 = i__ + 1 + i__ * h_dim1; h__[i__3].r = 0., h__[i__3].i = 0.; } /* L110: */ } if (msglvl > 2) { i__1 = *k + *np; i__2 = *k + *np; zmout_(&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 znaitr | */ /* %---------------% */ } /* znaitr_ */
/* ----------------------------------------------------------------------- */ /* Subroutine */ int zneupd_(logical *rvec, char *howmny, logical *select, doublecomplex *d__, doublecomplex *z__, integer *ldz, doublecomplex * sigma, doublecomplex *workev, char *bmat, integer *n, char *which, integer *nev, doublereal *tol, doublecomplex *resid, integer *ncv, doublecomplex *v, integer *ldv, integer *iparam, integer *ipntr, doublecomplex *workd, doublecomplex *workl, integer *lworkl, doublereal *rwork, 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, i__2; doublereal d__1, d__2, d__3, d__4; doublecomplex z__1, z__2; /* Builtin functions */ double pow_dd(doublereal *, doublereal *); integer s_cmp(char *, char *, ftnlen, ftnlen); /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); double d_imag(doublecomplex *); void z_div(doublecomplex *, doublecomplex *, doublecomplex *); /* Local variables */ static integer j, k, ih, jj, iq, np; static doublecomplex vl[1]; static integer wr, ibd, ldh, ldq; static doublereal sep; static integer irz, mode; static doublereal eps23; static integer ierr; static doublecomplex temp; static integer iwev; static char type__[6]; static integer ritz, iheig, ihbds; static doublereal conds; static logical reord; extern /* Subroutine */ int zscal_(integer *, doublecomplex *, doublecomplex *, integer *); static integer nconv; extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); static doublereal rtemp; static doublecomplex rnorm; extern /* Subroutine */ int zgeru_(integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), ivout_(integer *, integer *, integer *, integer *, char *, ftnlen), ztrmm_(char *, char *, char *, char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), zmout_(integer *, integer *, integer *, doublecomplex *, integer *, integer *, char *, ftnlen), zvout_( integer *, integer *, doublecomplex *, integer *, char *, ftnlen); extern doublereal dlapy2_(doublereal *, doublereal *); extern /* Subroutine */ int zgeqr2_(integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *); extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_( char *, ftnlen); extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, ftnlen, ftnlen); static integer bounds, invsub, iuptri, msglvl, outncv, numcnv, ishift; extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, ftnlen), zlahqr_(logical *, logical *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, doublecomplex *, integer *, integer *), zngets_(integer *, char * , integer *, integer *, doublecomplex *, doublecomplex *, ftnlen), zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, ftnlen), ztrsen_( char *, char *, logical *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublereal *, doublereal *, doublecomplex *, integer *, integer *, ftnlen, ftnlen), ztrevc_(char *, char *, logical *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, integer *, doublecomplex *, doublereal *, integer *, ftnlen, ftnlen), zdscal_(integer *, doublereal *, doublecomplex *, 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 | */ /* %----------------------% */ /* %--------------------% */ /* | External Functions | */ /* %--------------------% */ /* %-----------------------% */ /* | Executable Statements | */ /* %-----------------------% */ /* %------------------------% */ /* | Set default parameters | */ /* %------------------------% */ /* Parameter adjustments */ --workd; --resid; z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --d__; --rwork; --workev; --select; v_dim1 = *ldv; v_offset = 1 + v_dim1; v -= v_offset; --iparam; --ipntr; --workl; /* Function Body */ msglvl = debug_1.mceupd; mode = iparam[7]; nconv = iparam[5]; *info = 0; /* %---------------------------------% */ /* | Get machine dependent constant. | */ /* %---------------------------------% */ eps23 = dlamch_("Epsilon-Machine", (ftnlen)15); eps23 = pow_dd(&eps23, &c_b5); /* %-------------------------------% */ /* | Quick return | */ /* | Check for incompatible input | */ /* %-------------------------------% */ ierr = 0; if (nconv <= 0) { ierr = -14; } else if (*n <= 0) { ierr = -1; } else if (*nev <= 0) { ierr = -2; } else if (*ncv <= *nev || *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 << 2)) { 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) { s_copy(type__, "SHIFTI", (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, WORKEV, 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+ncv) := ritz values | */ /* | workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds | */ /* %--------------------------------------------------------% */ /* %-----------------------------------------------------------% */ /* | The following is used and set by ZNEUPD. | */ /* | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := The untransformed | */ /* | Ritz values. | */ /* | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | */ /* | error bounds of | */ /* | the Ritz values | */ /* | workl(ncv*ncv+4*ncv+1:2*ncv*ncv+4*ncv) := Holds the upper | */ /* | triangular matrix | */ /* | for H. | */ /* | workl(2*ncv*ncv+4*ncv+1: 3*ncv*ncv+4*ncv) := Holds the | */ /* | associated matrix | */ /* | representation of | */ /* | the invariant | */ /* | subspace for H. | */ /* | GRAND total of NCV * ( 3 * NCV + 4 ) locations. | */ /* %-----------------------------------------------------------% */ ih = ipntr[5]; ritz = ipntr[6]; iq = ipntr[7]; bounds = ipntr[8]; ldh = *ncv; ldq = *ncv; iheig = bounds + ldh; ihbds = iheig + ldh; iuptri = ihbds + ldh; invsub = iuptri + ldh * *ncv; ipntr[9] = iheig; ipntr[11] = ihbds; ipntr[12] = iuptri; ipntr[13] = invsub; wr = 1; iwev = wr + *ncv; /* %-----------------------------------------% */ /* | irz points to the Ritz values computed | */ /* | by _neigh before exiting _naup2. | */ /* | ibd points to the Ritz estimates | */ /* | computed by _neigh before exiting | */ /* | _naup2. | */ /* %-----------------------------------------% */ irz = ipntr[14] + *ncv * *ncv; ibd = irz + *ncv; /* %------------------------------------% */ /* | RNORM is B-norm of the RESID(1:N). | */ /* %------------------------------------% */ i__1 = ih + 2; rnorm.r = workl[i__1].r, rnorm.i = workl[i__1].i; i__1 = ih + 2; workl[i__1].r = 0., workl[i__1].i = 0.; if (msglvl > 2) { zvout_(&debug_1.logfil, ncv, &workl[irz], &debug_1.ndigit, "_neupd: " "Ritz values passed in from _NAUPD.", (ftnlen)42); zvout_(&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) { i__2 = bounds + j - 1; workl[i__2].r = (doublereal) j, workl[i__2].i = 0.; 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(ibd) | */ /* | accordingly. | */ /* %-------------------------------------% */ np = *ncv - *nev; ishift = 0; zngets_(&ishift, which, nev, &np, &workl[irz], &workl[bounds], ( ftnlen)2); if (msglvl > 2) { zvout_(&debug_1.logfil, ncv, &workl[irz], &debug_1.ndigit, "_neu" "pd: Ritz values after calling _NGETS.", (ftnlen)41); zvout_(&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 */ i__2 = irz + *ncv - j; d__3 = workl[i__2].r; d__4 = d_imag(&workl[irz + *ncv - j]); d__1 = eps23, d__2 = dlapy2_(&d__3, &d__4); rtemp = max(d__1,d__2); i__2 = bounds + *ncv - j; jj = (integer) workl[i__2].r; i__2 = ibd + jj - 1; d__1 = workl[i__2].r; d__2 = d_imag(&workl[ibd + jj - 1]); if (numcnv < nconv && dlapy2_(&d__1, &d__2) <= *tol * rtemp) { select[jj] = TRUE_; ++numcnv; if (jj > *nev) { 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 zlahqr to compute the Schur form | */ /* | of the upper Hessenberg matrix returned by ZNAUPD. | */ /* | Make a copy of the upper Hessenberg matrix. | */ /* | Initialize the Schur vector matrix Q to the identity. | */ /* %-------------------------------------------------------% */ i__1 = ldh * *ncv; zcopy_(&i__1, &workl[ih], &c__1, &workl[iuptri], &c__1); zlaset_("All", ncv, ncv, &c_b2, &c_b1, &workl[invsub], &ldq, (ftnlen) 3); zlahqr_(&c_true, &c_true, ncv, &c__1, ncv, &workl[iuptri], &ldh, & workl[iheig], &c__1, ncv, &workl[invsub], &ldq, &ierr); zcopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &c__1); if (ierr != 0) { *info = -8; goto L9000; } if (msglvl > 1) { zvout_(&debug_1.logfil, ncv, &workl[iheig], &debug_1.ndigit, "_neupd: Eigenvalues of H", (ftnlen)24); zvout_(&debug_1.logfil, ncv, &workl[ihbds], &debug_1.ndigit, "_neupd: Last row of the Schur vector matrix", (ftnlen)43) ; if (msglvl > 3) { zmout_(&debug_1.logfil, ncv, ncv, &workl[iuptri], &ldh, & debug_1.ndigit, "_neupd: The upper triangular matrix " , (ftnlen)36); } } if (reord) { /* %-----------------------------------------------% */ /* | Reorder the computed upper triangular matrix. | */ /* %-----------------------------------------------% */ ztrsen_("None", "V", &select[1], ncv, &workl[iuptri], &ldh, & workl[invsub], &ldq, &workl[iheig], &nconv, &conds, &sep, &workev[1], ncv, &ierr, (ftnlen)4, (ftnlen)1); if (ierr == 1) { *info = 1; goto L9000; } if (msglvl > 2) { zvout_(&debug_1.logfil, ncv, &workl[iheig], &debug_1.ndigit, "_neupd: Eigenvalues of H--reordered", (ftnlen)35); if (msglvl > 3) { zmout_(&debug_1.logfil, ncv, ncv, &workl[iuptri], &ldq, & debug_1.ndigit, "_neupd: Triangular matrix after" " re-ordering", (ftnlen)43); } } } /* %---------------------------------------------% */ /* | Copy the last row of the Schur basis matrix | */ /* | to workl(ihbds). This vector will be used | */ /* | to compute the Ritz estimates of converged | */ /* | Ritz values. | */ /* %---------------------------------------------% */ zcopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &c__1); /* %--------------------------------------------% */ /* | Place the computed eigenvalues of H into D | */ /* | if a spectral transformation was not used. | */ /* %--------------------------------------------% */ if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) { zcopy_(&nconv, &workl[iheig], &c__1, &d__[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). | */ /* %----------------------------------------------------------% */ zgeqr2_(ncv, &nconv, &workl[invsub], &ldq, &workev[1], &workev[*ncv + 1], &ierr); /* %--------------------------------------------------------% */ /* | * Postmultiply V by Q using zunm2r. | */ /* | * 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(iheig). The first NCONV | */ /* | columns of V are now approximate Schur vectors | */ /* | associated with the upper triangular matrix of order | */ /* | NCONV in workl(iuptri). | */ /* %--------------------------------------------------------% */ zunm2r_("Right", "Notranspose", n, ncv, &nconv, &workl[invsub], &ldq, &workev[1], &v[v_offset], ldv, &workd[*n + 1], &ierr, (ftnlen) 5, (ftnlen)11); zlacpy_("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 | */ /* | triangular form of workl(iuptri,ldq). | */ /* | Note that since Q is orthogonal, R is a diagonal | */ /* | matrix consisting of plus or minus ones. | */ /* %---------------------------------------------------% */ i__2 = invsub + (j - 1) * ldq + j - 1; if (workl[i__2].r < 0.) { z__1.r = -1., z__1.i = -0.; zscal_(&nconv, &z__1, &workl[iuptri + j - 1], &ldq); z__1.r = -1., z__1.i = -0.; zscal_(&nconv, &z__1, &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: */ } ztrevc_("Right", "Select", &select[1], ncv, &workl[iuptri], &ldq, vl, &c__1, &workl[invsub], &ldq, ncv, &outncv, &workev[1], &rwork[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 | */ /* | ztrevc returns each eigenvector normalized so | */ /* | that the element of largest magnitude has | */ /* | magnitude 1. | */ /* %------------------------------------------------% */ i__1 = nconv; for (j = 1; j <= i__1; ++j) { rtemp = dznrm2_(ncv, &workl[invsub + (j - 1) * ldq], &c__1); rtemp = 1. / rtemp; zdscal_(ncv, &rtemp, &workl[invsub + (j - 1) * ldq], &c__1); /* %------------------------------------------% */ /* | Ritz estimates can be obtained by taking | */ /* | the inner product of the last row of the | */ /* | Schur basis of H with eigenvectors of T. | */ /* | Note that the eigenvector matrix of T is | */ /* | upper triangular, thus the length of the | */ /* | inner product can be set to j. | */ /* %------------------------------------------% */ i__2 = j; zdotc_(&z__1, &j, &workl[ihbds], &c__1, &workl[invsub + (j - 1) * ldq], &c__1); workev[i__2].r = z__1.r, workev[i__2].i = z__1.i; /* L40: */ } if (msglvl > 2) { zcopy_(&nconv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &c__1); zvout_(&debug_1.logfil, &nconv, &workl[ihbds], & debug_1.ndigit, "_neupd: Last row of the eigenvector" " matrix for T", (ftnlen)48); if (msglvl > 3) { zmout_(&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) | */ /* %---------------------------------------% */ zcopy_(&nconv, &workev[1], &c__1, &workl[ihbds], &c__1); /* %----------------------------------------------% */ /* | The eigenvector matrix Q of T is triangular. | */ /* | Form Z*Q. | */ /* %----------------------------------------------% */ ztrmm_("Right", "Upper", "No transpose", "Non-unit", n, &nconv, & c_b1, &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 ZNAUPD into D. | */ /* %--------------------------------------------------% */ zcopy_(&nconv, &workl[ritz], &c__1, &d__[1], &c__1); zcopy_(&nconv, &workl[ritz], &c__1, &workl[iheig], &c__1); zcopy_(&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) { zscal_(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 (*rvec) { zscal_(ncv, &rnorm, &workl[ihbds], &c__1); } i__1 = *ncv; for (k = 1; k <= i__1; ++k) { i__2 = iheig + k - 1; temp.r = workl[i__2].r, temp.i = workl[i__2].i; i__2 = ihbds + k - 1; z_div(&z__2, &workl[ihbds + k - 1], &temp); z_div(&z__1, &z__2, &temp); workl[i__2].r = z__1.r, workl[i__2].i = z__1.i; /* L50: */ } } /* %-----------------------------------------------------------% */ /* | * Transform the Ritz values back to the original system. | */ /* | For TYPE = 'SHIFTI' the transformation is | */ /* | lambda = 1/theta + sigma | */ /* | NOTES: | */ /* | *The Ritz vectors are not affected by the transformation. | */ /* %-----------------------------------------------------------% */ if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) { i__1 = nconv; for (k = 1; k <= i__1; ++k) { i__2 = k; z_div(&z__2, &c_b1, &workl[iheig + k - 1]); z__1.r = z__2.r + sigma->r, z__1.i = z__2.i + sigma->i; d__[i__2].r = z__1.r, d__[i__2].i = z__1.i; /* L60: */ } } if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) != 0 && msglvl > 1) { zvout_(&debug_1.logfil, &nconv, &d__[1], &debug_1.ndigit, "_neupd: U" "ntransformed Ritz values.", (ftnlen)34); zvout_(&debug_1.logfil, &nconv, &workl[ihbds], &debug_1.ndigit, "_ne" "upd: Ritz estimates of the untransformed Ritz values.", ( ftnlen)56); } else if (msglvl > 1) { zvout_(&debug_1.logfil, &nconv, &d__[1], &debug_1.ndigit, "_neupd: C" "onverged Ritz values.", (ftnlen)30); zvout_(&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 = 3. See reference 3. | */ /* %-------------------------------------------------% */ 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. | */ /* %------------------------------------------------% */ i__1 = nconv; for (j = 1; j <= i__1; ++j) { i__2 = iheig + j - 1; if (workl[i__2].r != 0. || workl[i__2].i != 0.) { i__2 = j; z_div(&z__1, &workl[invsub + (j - 1) * ldq + *ncv - 1], & workl[iheig + j - 1]); workev[i__2].r = z__1.r, workev[i__2].i = z__1.i; } /* L100: */ } /* %---------------------------------------% */ /* | Perform a rank one update to Z and | */ /* | purify all the Ritz vectors together. | */ /* %---------------------------------------% */ zgeru_(n, &nconv, &c_b1, &resid[1], &c__1, &workev[1], &c__1, &z__[ z_offset], ldz); } L9000: return 0; /* %---------------% */ /* | End of zneupd| */ /* %---------------% */ } /* zneupd_ */