/* Subroutine */ int igraphdnaitr_(integer *ido, char *bmat, integer *n, integer *k, integer *np, integer *nb, doublereal *resid, doublereal *rnorm, doublereal *v, integer *ldv, doublereal *h__, integer *ldh, integer * ipntr, doublereal *workd, integer *info) { /* Initialized data */ static logical first = TRUE_; /* System generated locals */ integer h_dim1, h_offset, v_dim1, v_offset, i__1, i__2; doublereal d__1, d__2; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static integer i__, j; static real t0, t1, t2, t3, t4, t5; static integer jj, ipj, irj, ivj; static doublereal ulp, tst1; extern doublereal igraphddot_(integer *, doublereal *, integer *, doublereal *, integer *); static integer ierr, iter; static doublereal unfl, ovfl; static integer itry; extern doublereal igraphdnrm2_(integer *, doublereal *, integer *); static doublereal temp1; static logical orth1, orth2, step3, step4; static doublereal betaj; extern /* Subroutine */ int igraphdscal_(integer *, doublereal *, doublereal *, integer *), igraphdgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *); static integer infol; extern /* Subroutine */ int igraphdcopy_(integer *, doublereal *, integer *, doublereal *, integer *), igraphdaxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *), igraphdmout_(integer *, integer *, integer *, doublereal *, integer *, integer *, char *); static doublereal xtemp[2]; extern /* Subroutine */ int igraphdvout_(integer *, integer *, doublereal *, integer *, char *); static doublereal wnorm; extern /* Subroutine */ int igraphivout_(integer *, integer *, integer *, integer *, char *), igraphdgetv0_(integer *, char *, integer *, logical *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer * ), igraphdlabad_(doublereal *, doublereal *); static doublereal rnorm1; extern doublereal igraphdlamch_(char *); extern /* Subroutine */ int igraphdlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, integer *); extern doublereal igraphdlanhs_(char *, integer *, doublereal *, integer *, doublereal *); extern /* Subroutine */ int igraphsecond_(real *); static logical rstart; static integer msglvl; static doublereal smlnum; /* %----------------------------------------------------% */ /* | Include files for debugging and timing information | */ /* %----------------------------------------------------% */ /* \SCCS Information: @(#) */ /* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */ /* %---------------------------------% */ /* | See debug.doc for documentation | */ /* %---------------------------------% */ /* %------------------% */ /* | Scalar Arguments | */ /* %------------------% */ /* %--------------------------------% */ /* | See stat.doc for documentation | */ /* %--------------------------------% */ /* \SCCS Information: @(#) */ /* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */ /* %-----------------% */ /* | Array Arguments | */ /* %-----------------% */ /* %------------% */ /* | Parameters | */ /* %------------% */ /* %---------------% */ /* | Local Scalars | */ /* %---------------% */ /* %-----------------------% */ /* | Local Array Arguments | */ /* %-----------------------% */ /* %----------------------% */ /* | External Subroutines | */ /* %----------------------% */ /* %--------------------% */ /* | External Functions | */ /* %--------------------% */ /* %---------------------% */ /* | Intrinsic Functions | */ /* %---------------------% */ /* %-----------------% */ /* | Data statements | */ /* %-----------------% */ /* Parameter adjustments */ --workd; --resid; v_dim1 = *ldv; v_offset = 1 + v_dim1; v -= v_offset; h_dim1 = *ldh; h_offset = 1 + h_dim1; h__ -= h_offset; --ipntr; /* Function Body */ /* %-----------------------% */ /* | Executable Statements | */ /* %-----------------------% */ if (first) { /* %-----------------------------------------% */ /* | Set machine-dependent constants for the | */ /* | the splitting and deflation criterion. | */ /* | If norm(H) <= sqrt(OVFL), | */ /* | overflow should not occur. | */ /* | REFERENCE: LAPACK subroutine dlahqr | */ /* %-----------------------------------------% */ unfl = igraphdlamch_("safe minimum"); ovfl = 1. / unfl; igraphdlabad_(&unfl, &ovfl); ulp = igraphdlamch_("precision"); smlnum = unfl * (*n / ulp); first = FALSE_; } if (*ido == 0) { /* %-------------------------------% */ /* | Initialize timing statistics | */ /* | & message level for debugging | */ /* %-------------------------------% */ igraphsecond_(&t0); msglvl = debug_1.mnaitr; /* %------------------------------% */ /* | Initial call to this routine | */ /* %------------------------------% */ *info = 0; step3 = FALSE_; step4 = FALSE_; rstart = FALSE_; orth1 = FALSE_; orth2 = FALSE_; j = *k + 1; ipj = 1; irj = ipj + *n; ivj = irj + *n; } /* %-------------------------------------------------% */ /* | When in reverse communication mode one of: | */ /* | STEP3, STEP4, ORTH1, ORTH2, RSTART | */ /* | will be .true. when .... | */ /* | STEP3: return from computing OP*v_{j}. | */ /* | STEP4: return from computing B-norm of OP*v_{j} | */ /* | ORTH1: return from computing B-norm of r_{j+1} | */ /* | ORTH2: return from computing B-norm of | */ /* | correction to the residual vector. | */ /* | RSTART: return from OP computations needed by | */ /* | dgetv0. | */ /* %-------------------------------------------------% */ if (step3) { goto L50; } if (step4) { goto L60; } if (orth1) { goto L70; } if (orth2) { goto L90; } if (rstart) { goto L30; } /* %-----------------------------% */ /* | Else this is the first step | */ /* %-----------------------------% */ /* %--------------------------------------------------------------% */ /* | | */ /* | A R N O L D I I T E R A T I O N L O O P | */ /* | | */ /* | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | */ /* %--------------------------------------------------------------% */ L1000: if (msglvl > 1) { igraphivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: generat" "ing Arnoldi vector number"); igraphdvout_(&debug_1.logfil, &c__1, rnorm, &debug_1.ndigit, "_naitr: B-no" "rm of the current residual is"); } /* %---------------------------------------------------% */ /* | STEP 1: Check if the B norm of j-th residual | */ /* | vector is zero. Equivalent to determing whether | */ /* | an exact j-step Arnoldi factorization is present. | */ /* %---------------------------------------------------% */ betaj = *rnorm; if (*rnorm > 0.) { goto L40; } /* %---------------------------------------------------% */ /* | Invariant subspace found, generate a new starting | */ /* | vector which is orthogonal to the current Arnoldi | */ /* | basis and continue the iteration. | */ /* %---------------------------------------------------% */ if (msglvl > 0) { igraphivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: ****** " "RESTART AT STEP ******"); } /* %---------------------------------------------% */ /* | ITRY is the loop variable that controls the | */ /* | maximum amount of times that a restart is | */ /* | attempted. NRSTRT is used by stat.h | */ /* %---------------------------------------------% */ betaj = 0.; ++timing_1.nrstrt; itry = 1; L20: rstart = TRUE_; *ido = 0; L30: /* %--------------------------------------% */ /* | If in reverse communication mode and | */ /* | RSTART = .true. flow returns here. | */ /* %--------------------------------------% */ igraphdgetv0_(ido, bmat, &itry, &c_false, n, &j, &v[v_offset], ldv, &resid[1], rnorm, &ipntr[1], &workd[1], &ierr); if (*ido != 99) { goto L9000; } if (ierr < 0) { ++itry; if (itry <= 3) { goto L20; } /* %------------------------------------------------% */ /* | Give up after several restart attempts. | */ /* | Set INFO to the size of the invariant subspace | */ /* | which spans OP and exit. | */ /* %------------------------------------------------% */ *info = j - 1; igraphsecond_(&t1); timing_1.tnaitr += t1 - t0; *ido = 99; goto L9000; } L40: /* %---------------------------------------------------------% */ /* | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | */ /* | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | */ /* | when reciprocating a small RNORM, test against lower | */ /* | machine bound. | */ /* %---------------------------------------------------------% */ igraphdcopy_(n, &resid[1], &c__1, &v[j * v_dim1 + 1], &c__1); if (*rnorm >= unfl) { temp1 = 1. / *rnorm; igraphdscal_(n, &temp1, &v[j * v_dim1 + 1], &c__1); igraphdscal_(n, &temp1, &workd[ipj], &c__1); } else { /* %-----------------------------------------% */ /* | To scale both v_{j} and p_{j} carefully | */ /* | use LAPACK routine SLASCL | */ /* %-----------------------------------------% */ igraphdlascl_("General", &i__, &i__, rnorm, &c_b25, n, &c__1, &v[j * v_dim1 + 1], n, &infol); igraphdlascl_("General", &i__, &i__, rnorm, &c_b25, n, &c__1, &workd[ipj], n, &infol); } /* %------------------------------------------------------% */ /* | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | */ /* | Note that this is not quite yet r_{j}. See STEP 4 | */ /* %------------------------------------------------------% */ step3 = TRUE_; ++timing_1.nopx; igraphsecond_(&t2); igraphdcopy_(n, &v[j * v_dim1 + 1], &c__1, &workd[ivj], &c__1); ipntr[1] = ivj; ipntr[2] = irj; ipntr[3] = ipj; *ido = 1; /* %-----------------------------------% */ /* | Exit in order to compute OP*v_{j} | */ /* %-----------------------------------% */ goto L9000; L50: /* %----------------------------------% */ /* | Back from reverse communication; | */ /* | WORKD(IRJ:IRJ+N-1) := OP*v_{j} | */ /* | if step3 = .true. | */ /* %----------------------------------% */ igraphsecond_(&t3); timing_1.tmvopx += t3 - t2; step3 = FALSE_; /* %------------------------------------------% */ /* | Put another copy of OP*v_{j} into RESID. | */ /* %------------------------------------------% */ igraphdcopy_(n, &workd[irj], &c__1, &resid[1], &c__1); /* %---------------------------------------% */ /* | STEP 4: Finish extending the Arnoldi | */ /* | factorization to length j. | */ /* %---------------------------------------% */ igraphsecond_(&t2); if (*(unsigned char *)bmat == 'G') { ++timing_1.nbx; step4 = TRUE_; ipntr[1] = irj; ipntr[2] = ipj; *ido = 2; /* %-------------------------------------% */ /* | Exit in order to compute B*OP*v_{j} | */ /* %-------------------------------------% */ goto L9000; } else if (*(unsigned char *)bmat == 'I') { igraphdcopy_(n, &resid[1], &c__1, &workd[ipj], &c__1); } L60: /* %----------------------------------% */ /* | Back from reverse communication; | */ /* | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} | */ /* | if step4 = .true. | */ /* %----------------------------------% */ if (*(unsigned char *)bmat == 'G') { igraphsecond_(&t3); timing_1.tmvbx += t3 - t2; } step4 = FALSE_; /* %-------------------------------------% */ /* | The following is needed for STEP 5. | */ /* | Compute the B-norm of OP*v_{j}. | */ /* %-------------------------------------% */ if (*(unsigned char *)bmat == 'G') { wnorm = igraphddot_(n, &resid[1], &c__1, &workd[ipj], &c__1); wnorm = sqrt((abs(wnorm))); } else if (*(unsigned char *)bmat == 'I') { wnorm = igraphdnrm2_(n, &resid[1], &c__1); } /* %-----------------------------------------% */ /* | Compute the j-th residual corresponding | */ /* | to the j step factorization. | */ /* | Use Classical Gram Schmidt and compute: | */ /* | w_{j} <- V_{j}^T * B * OP * v_{j} | */ /* | r_{j} <- OP*v_{j} - V_{j} * w_{j} | */ /* %-----------------------------------------% */ /* %------------------------------------------% */ /* | Compute the j Fourier coefficients w_{j} | */ /* | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | */ /* %------------------------------------------% */ igraphdgemv_("T", n, &j, &c_b25, &v[v_offset], ldv, &workd[ipj], &c__1, &c_b47, &h__[j * h_dim1 + 1], &c__1); /* %--------------------------------------% */ /* | Orthogonalize r_{j} against V_{j}. | */ /* | RESID contains OP*v_{j}. See STEP 3. | */ /* %--------------------------------------% */ igraphdgemv_("N", n, &j, &c_b50, &v[v_offset], ldv, &h__[j * h_dim1 + 1], &c__1, &c_b25, &resid[1], &c__1); if (j > 1) { h__[j + (j - 1) * h_dim1] = betaj; } igraphsecond_(&t4); orth1 = TRUE_; igraphsecond_(&t2); if (*(unsigned char *)bmat == 'G') { ++timing_1.nbx; igraphdcopy_(n, &resid[1], &c__1, &workd[irj], &c__1); ipntr[1] = irj; ipntr[2] = ipj; *ido = 2; /* %----------------------------------% */ /* | Exit in order to compute B*r_{j} | */ /* %----------------------------------% */ goto L9000; } else if (*(unsigned char *)bmat == 'I') { igraphdcopy_(n, &resid[1], &c__1, &workd[ipj], &c__1); } L70: /* %---------------------------------------------------% */ /* | Back from reverse communication if ORTH1 = .true. | */ /* | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | */ /* %---------------------------------------------------% */ if (*(unsigned char *)bmat == 'G') { igraphsecond_(&t3); timing_1.tmvbx += t3 - t2; } orth1 = FALSE_; /* %------------------------------% */ /* | Compute the B-norm of r_{j}. | */ /* %------------------------------% */ if (*(unsigned char *)bmat == 'G') { *rnorm = igraphddot_(n, &resid[1], &c__1, &workd[ipj], &c__1); *rnorm = sqrt((abs(*rnorm))); } else if (*(unsigned char *)bmat == 'I') { *rnorm = igraphdnrm2_(n, &resid[1], &c__1); } /* %-----------------------------------------------------------% */ /* | STEP 5: Re-orthogonalization / Iterative refinement phase | */ /* | Maximum NITER_ITREF tries. | */ /* | | */ /* | s = V_{j}^T * B * r_{j} | */ /* | r_{j} = r_{j} - V_{j}*s | */ /* | alphaj = alphaj + s_{j} | */ /* | | */ /* | The stopping criteria used for iterative refinement is | */ /* | discussed in Parlett's book SEP, page 107 and in Gragg & | */ /* | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | */ /* | Determine if we need to correct the residual. The goal is | */ /* | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | */ /* | The following test determines whether the sine of the | */ /* | angle between OP*x and the computed residual is less | */ /* | than or equal to 0.717. | */ /* %-----------------------------------------------------------% */ if (*rnorm > wnorm * .717f) { goto L100; } iter = 0; ++timing_1.nrorth; /* %---------------------------------------------------% */ /* | Enter the Iterative refinement phase. If further | */ /* | refinement is necessary, loop back here. The loop | */ /* | variable is ITER. Perform a step of Classical | */ /* | Gram-Schmidt using all the Arnoldi vectors V_{j} | */ /* %---------------------------------------------------% */ L80: if (msglvl > 2) { xtemp[0] = wnorm; xtemp[1] = *rnorm; igraphdvout_(&debug_1.logfil, &c__2, xtemp, &debug_1.ndigit, "_naitr: re-o" "rthonalization; wnorm and rnorm are"); igraphdvout_(&debug_1.logfil, &j, &h__[j * h_dim1 + 1], &debug_1.ndigit, "_naitr: j-th column of H"); } /* %----------------------------------------------------% */ /* | Compute V_{j}^T * B * r_{j}. | */ /* | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | */ /* %----------------------------------------------------% */ igraphdgemv_("T", n, &j, &c_b25, &v[v_offset], ldv, &workd[ipj], &c__1, &c_b47, &workd[irj], &c__1); /* %---------------------------------------------% */ /* | Compute the correction to the residual: | */ /* | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | */ /* | The correction to H is v(:,1:J)*H(1:J,1:J) | */ /* | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. | */ /* %---------------------------------------------% */ igraphdgemv_("N", n, &j, &c_b50, &v[v_offset], ldv, &workd[irj], &c__1, &c_b25, &resid[1], &c__1); igraphdaxpy_(&j, &c_b25, &workd[irj], &c__1, &h__[j * h_dim1 + 1], &c__1); orth2 = TRUE_; igraphsecond_(&t2); if (*(unsigned char *)bmat == 'G') { ++timing_1.nbx; igraphdcopy_(n, &resid[1], &c__1, &workd[irj], &c__1); ipntr[1] = irj; ipntr[2] = ipj; *ido = 2; /* %-----------------------------------% */ /* | Exit in order to compute B*r_{j}. | */ /* | r_{j} is the corrected residual. | */ /* %-----------------------------------% */ goto L9000; } else if (*(unsigned char *)bmat == 'I') { igraphdcopy_(n, &resid[1], &c__1, &workd[ipj], &c__1); } L90: /* %---------------------------------------------------% */ /* | Back from reverse communication if ORTH2 = .true. | */ /* %---------------------------------------------------% */ if (*(unsigned char *)bmat == 'G') { igraphsecond_(&t3); timing_1.tmvbx += t3 - t2; } /* %-----------------------------------------------------% */ /* | Compute the B-norm of the corrected residual r_{j}. | */ /* %-----------------------------------------------------% */ if (*(unsigned char *)bmat == 'G') { rnorm1 = igraphddot_(n, &resid[1], &c__1, &workd[ipj], &c__1); rnorm1 = sqrt((abs(rnorm1))); } else if (*(unsigned char *)bmat == 'I') { rnorm1 = igraphdnrm2_(n, &resid[1], &c__1); } if (msglvl > 0 && iter > 0) { igraphivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: Iterati" "ve refinement for Arnoldi residual"); if (msglvl > 2) { xtemp[0] = *rnorm; xtemp[1] = rnorm1; igraphdvout_(&debug_1.logfil, &c__2, xtemp, &debug_1.ndigit, "_naitr: " "iterative refinement ; rnorm and rnorm1 are"); } } /* %-----------------------------------------% */ /* | Determine if we need to perform another | */ /* | step of re-orthogonalization. | */ /* %-----------------------------------------% */ if (rnorm1 > *rnorm * .717f) { /* %---------------------------------------% */ /* | No need for further refinement. | */ /* | The cosine of the angle between the | */ /* | corrected residual vector and the old | */ /* | residual vector is greater than 0.717 | */ /* | In other words the corrected residual | */ /* | and the old residual vector share an | */ /* | angle of less than arcCOS(0.717) | */ /* %---------------------------------------% */ *rnorm = rnorm1; } else { /* %-------------------------------------------% */ /* | Another step of iterative refinement step | */ /* | is required. NITREF is used by stat.h | */ /* %-------------------------------------------% */ ++timing_1.nitref; *rnorm = rnorm1; ++iter; if (iter <= 1) { goto L80; } /* %-------------------------------------------------% */ /* | Otherwise RESID is numerically in the span of V | */ /* %-------------------------------------------------% */ i__1 = *n; for (jj = 1; jj <= i__1; ++jj) { resid[jj] = 0.; /* L95: */ } *rnorm = 0.; } /* %----------------------------------------------% */ /* | Branch here directly if iterative refinement | */ /* | wasn't necessary or after at most NITER_REF | */ /* | steps of iterative refinement. | */ /* %----------------------------------------------% */ L100: rstart = FALSE_; orth2 = FALSE_; igraphsecond_(&t5); timing_1.titref += t5 - t4; /* %------------------------------------% */ /* | STEP 6: Update j = j+1; Continue | */ /* %------------------------------------% */ ++j; if (j > *k + *np) { igraphsecond_(&t1); timing_1.tnaitr += t1 - t0; *ido = 99; i__1 = *k + *np - 1; for (i__ = max(1,*k); i__ <= i__1; ++i__) { /* %--------------------------------------------% */ /* | Check for splitting and deflation. | */ /* | Use a standard test as in the QR algorithm | */ /* | REFERENCE: LAPACK subroutine dlahqr | */ /* %--------------------------------------------% */ tst1 = (d__1 = h__[i__ + i__ * h_dim1], abs(d__1)) + (d__2 = h__[ i__ + 1 + (i__ + 1) * h_dim1], abs(d__2)); if (tst1 == 0.) { i__2 = *k + *np; tst1 = igraphdlanhs_("1", &i__2, &h__[h_offset], ldh, &workd[*n + 1]); } /* Computing MAX */ d__2 = ulp * tst1; if ((d__1 = h__[i__ + 1 + i__ * h_dim1], abs(d__1)) <= max(d__2, smlnum)) { h__[i__ + 1 + i__ * h_dim1] = 0.; } /* L110: */ } if (msglvl > 2) { i__1 = *k + *np; i__2 = *k + *np; igraphdmout_(&debug_1.logfil, &i__1, &i__2, &h__[h_offset], ldh, & debug_1.ndigit, "_naitr: Final upper Hessenberg matrix H" " of order K+NP"); } goto L9000; } /* %--------------------------------------------------------% */ /* | Loop back to extend the factorization by another step. | */ /* %--------------------------------------------------------% */ goto L1000; /* %---------------------------------------------------------------% */ /* | | */ /* | E N D O F M A I N I T E R A T I O N L O O P | */ /* | | */ /* %---------------------------------------------------------------% */ L9000: return 0; /* %---------------% */ /* | End of igraphdnaitr | */ /* %---------------% */ } /* igraphdnaitr_ */
Subroutine */ int igraphdnapps_(integer *n, integer *kev, integer *np, doublereal *shiftr, doublereal *shifti, doublereal *v, integer *ldv, doublereal *h__, integer *ldh, doublereal *resid, doublereal *q, integer *ldq, doublereal *workl, doublereal *workd) { /* Initialized data */ IGRAPH_F77_SAVE logical first = TRUE_; /* System generated locals */ integer h_dim1, h_offset, v_dim1, v_offset, q_dim1, q_offset, i__1, i__2, i__3, i__4; doublereal d__1, d__2; /* Local variables */ doublereal c__, f, g; integer i__, j; doublereal r__, s, t, u[3]; real t0, t1; doublereal h11, h12, h21, h22, h32; integer jj, ir, nr; doublereal tau; IGRAPH_F77_SAVE doublereal ulp; doublereal tst1; integer iend; IGRAPH_F77_SAVE doublereal unfl, ovfl; extern /* Subroutine */ int igraphdscal_(integer *, doublereal *, doublereal *, integer *), igraphdlarf_(char *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *); logical cconj; extern /* Subroutine */ int igraphdgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *), igraphdcopy_(integer *, doublereal *, integer *, doublereal *, integer *), igraphdaxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *) , igraphdmout_(integer *, integer *, integer *, doublereal *, integer *, integer *, char *, ftnlen), igraphdvout_(integer *, integer *, doublereal *, integer *, char *, ftnlen), igraphivout_(integer *, integer *, integer *, integer *, char *, ftnlen); extern doublereal igraphdlapy2_(doublereal *, doublereal *); extern /* Subroutine */ int igraphdlabad_(doublereal *, doublereal *); extern doublereal igraphdlamch_(char *); extern /* Subroutine */ int igraphdlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *); doublereal sigmai; extern doublereal igraphdlanhs_(char *, integer *, doublereal *, integer *, doublereal *); extern /* Subroutine */ int igraphsecond_(real *), igraphdlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *), igraphdlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *), igraphdlartg_( doublereal *, doublereal *, doublereal *, doublereal *, doublereal *); integer logfil, ndigit; doublereal sigmar; integer mnapps = 0, msglvl; real tnapps = 0.; integer istart; IGRAPH_F77_SAVE doublereal smlnum; integer kplusp; /* %----------------------------------------------------% | Include files for debugging and timing information | %----------------------------------------------------% %------------------% | Scalar Arguments | %------------------% %-----------------% | Array Arguments | %-----------------% %------------% | Parameters | %------------% %------------------------% | Local Scalars & Arrays | %------------------------% %----------------------% | External Subroutines | %----------------------% %--------------------% | External Functions | %--------------------% %----------------------% | Intrinsics Functions | %----------------------% %----------------% | Data statments | %----------------% Parameter adjustments */ --workd; --resid; --workl; --shifti; --shiftr; v_dim1 = *ldv; v_offset = 1 + v_dim1; v -= v_offset; h_dim1 = *ldh; h_offset = 1 + h_dim1; h__ -= h_offset; q_dim1 = *ldq; q_offset = 1 + q_dim1; q -= q_offset; /* Function Body %-----------------------% | Executable Statements | %-----------------------% */ if (first) { /* %-----------------------------------------------% | Set machine-dependent constants for the | | stopping criterion. If norm(H) <= sqrt(OVFL), | | overflow should not occur. | | REFERENCE: LAPACK subroutine dlahqr | %-----------------------------------------------% */ unfl = igraphdlamch_("safe minimum"); ovfl = 1. / unfl; igraphdlabad_(&unfl, &ovfl); ulp = igraphdlamch_("precision"); smlnum = unfl * (*n / ulp); first = FALSE_; } /* %-------------------------------% | Initialize timing statistics | | & message level for debugging | %-------------------------------% */ igraphsecond_(&t0); msglvl = mnapps; kplusp = *kev + *np; /* %--------------------------------------------% | Initialize Q to the identity to accumulate | | the rotations and reflections | %--------------------------------------------% */ igraphdlaset_("All", &kplusp, &kplusp, &c_b5, &c_b6, &q[q_offset], ldq); /* %----------------------------------------------% | Quick return if there are no shifts to apply | %----------------------------------------------% */ if (*np == 0) { goto L9000; } /* %----------------------------------------------% | Chase the bulge with the application of each | | implicit shift. Each shift is applied to the | | whole matrix including each block. | %----------------------------------------------% */ cconj = FALSE_; i__1 = *np; for (jj = 1; jj <= i__1; ++jj) { sigmar = shiftr[jj]; sigmai = shifti[jj]; if (msglvl > 2) { igraphivout_(&logfil, &c__1, &jj, &ndigit, "_napps: shift number.", ( ftnlen)21); igraphdvout_(&logfil, &c__1, &sigmar, &ndigit, "_napps: The real part " "of the shift ", (ftnlen)35); igraphdvout_(&logfil, &c__1, &sigmai, &ndigit, "_napps: The imaginary " "part of the shift ", (ftnlen)40); } /* %-------------------------------------------------% | The following set of conditionals is necessary | | in order that complex conjugate pairs of shifts | | are applied together or not at all. | %-------------------------------------------------% */ if (cconj) { /* %-----------------------------------------% | cconj = .true. means the previous shift | | had non-zero imaginary part. | %-----------------------------------------% */ cconj = FALSE_; goto L110; } else if (jj < *np && abs(sigmai) > 0.) { /* %------------------------------------% | Start of a complex conjugate pair. | %------------------------------------% */ cconj = TRUE_; } else if (jj == *np && abs(sigmai) > 0.) { /* %----------------------------------------------% | The last shift has a nonzero imaginary part. | | Don't apply it; thus the order of the | | compressed H is order KEV+1 since only np-1 | | were applied. | %----------------------------------------------% */ ++(*kev); goto L110; } istart = 1; L20: /* %--------------------------------------------------% | if sigmai = 0 then | | Apply the jj-th shift ... | | else | | Apply the jj-th and (jj+1)-th together ... | | (Note that jj < np at this point in the code) | | end | | to the current block of H. The next do loop | | determines the current block ; | %--------------------------------------------------% */ i__2 = kplusp - 1; for (i__ = istart; i__ <= i__2; ++i__) { /* %----------------------------------------% | Check for splitting and deflation. Use | | a standard test as in the QR algorithm | | REFERENCE: LAPACK subroutine dlahqr | %----------------------------------------% */ tst1 = (d__1 = h__[i__ + i__ * h_dim1], abs(d__1)) + (d__2 = h__[ i__ + 1 + (i__ + 1) * h_dim1], abs(d__2)); if (tst1 == 0.) { i__3 = kplusp - jj + 1; tst1 = igraphdlanhs_("1", &i__3, &h__[h_offset], ldh, &workl[1]); } /* Computing MAX */ d__2 = ulp * tst1; if ((d__1 = h__[i__ + 1 + i__ * h_dim1], abs(d__1)) <= max(d__2, smlnum)) { if (msglvl > 0) { igraphivout_(&logfil, &c__1, &i__, &ndigit, "_napps: matrix sp" "litting at row/column no.", (ftnlen)42); igraphivout_(&logfil, &c__1, &jj, &ndigit, "_napps: matrix spl" "itting with shift number.", (ftnlen)43); igraphdvout_(&logfil, &c__1, &h__[i__ + 1 + i__ * h_dim1], & ndigit, "_napps: off diagonal element.", (ftnlen) 29); } iend = i__; h__[i__ + 1 + i__ * h_dim1] = 0.; goto L40; } /* L30: */ } iend = kplusp; L40: if (msglvl > 2) { igraphivout_(&logfil, &c__1, &istart, &ndigit, "_napps: Start of curre" "nt block ", (ftnlen)31); igraphivout_(&logfil, &c__1, &iend, &ndigit, "_napps: End of current b" "lock ", (ftnlen)29); } /* %------------------------------------------------% | No reason to apply a shift to block of order 1 | %------------------------------------------------% */ if (istart == iend) { goto L100; } /* %------------------------------------------------------% | If istart + 1 = iend then no reason to apply a | | complex conjugate pair of shifts on a 2 by 2 matrix. | %------------------------------------------------------% */ if (istart + 1 == iend && abs(sigmai) > 0.) { goto L100; } h11 = h__[istart + istart * h_dim1]; h21 = h__[istart + 1 + istart * h_dim1]; if (abs(sigmai) <= 0.) { /* %---------------------------------------------% | Real-valued shift ==> apply single shift QR | %---------------------------------------------% */ f = h11 - sigmar; g = h21; i__2 = iend - 1; for (i__ = istart; i__ <= i__2; ++i__) { /* %-----------------------------------------------------% | Contruct the plane rotation G to zero out the bulge | %-----------------------------------------------------% */ igraphdlartg_(&f, &g, &c__, &s, &r__); if (i__ > istart) { /* %-------------------------------------------% | The following ensures that h(1:iend-1,1), | | the first iend-2 off diagonal of elements | | H, remain non negative. | %-------------------------------------------% */ if (r__ < 0.) { r__ = -r__; c__ = -c__; s = -s; } h__[i__ + (i__ - 1) * h_dim1] = r__; h__[i__ + 1 + (i__ - 1) * h_dim1] = 0.; } /* %---------------------------------------------% | Apply rotation to the left of H; H <- G'*H | %---------------------------------------------% */ i__3 = kplusp; for (j = i__; j <= i__3; ++j) { t = c__ * h__[i__ + j * h_dim1] + s * h__[i__ + 1 + j * h_dim1]; h__[i__ + 1 + j * h_dim1] = -s * h__[i__ + j * h_dim1] + c__ * h__[i__ + 1 + j * h_dim1]; h__[i__ + j * h_dim1] = t; /* L50: */ } /* %---------------------------------------------% | Apply rotation to the right of H; H <- H*G | %---------------------------------------------% Computing MIN */ i__4 = i__ + 2; i__3 = min(i__4,iend); for (j = 1; j <= i__3; ++j) { t = c__ * h__[j + i__ * h_dim1] + s * h__[j + (i__ + 1) * h_dim1]; h__[j + (i__ + 1) * h_dim1] = -s * h__[j + i__ * h_dim1] + c__ * h__[j + (i__ + 1) * h_dim1]; h__[j + i__ * h_dim1] = t; /* L60: */ } /* %----------------------------------------------------% | Accumulate the rotation in the matrix Q; Q <- Q*G | %----------------------------------------------------% Computing MIN */ i__4 = j + jj; i__3 = min(i__4,kplusp); for (j = 1; j <= i__3; ++j) { t = c__ * q[j + i__ * q_dim1] + s * q[j + (i__ + 1) * q_dim1]; q[j + (i__ + 1) * q_dim1] = -s * q[j + i__ * q_dim1] + c__ * q[j + (i__ + 1) * q_dim1]; q[j + i__ * q_dim1] = t; /* L70: */ } /* %---------------------------% | Prepare for next rotation | %---------------------------% */ if (i__ < iend - 1) { f = h__[i__ + 1 + i__ * h_dim1]; g = h__[i__ + 2 + i__ * h_dim1]; } /* L80: */ } /* %-----------------------------------% | Finished applying the real shift. | %-----------------------------------% */ } else { /* %----------------------------------------------------% | Complex conjugate shifts ==> apply double shift QR | %----------------------------------------------------% */ h12 = h__[istart + (istart + 1) * h_dim1]; h22 = h__[istart + 1 + (istart + 1) * h_dim1]; h32 = h__[istart + 2 + (istart + 1) * h_dim1]; /* %---------------------------------------------------------% | Compute 1st column of (H - shift*I)*(H - conj(shift)*I) | %---------------------------------------------------------% */ s = sigmar * 2.f; t = igraphdlapy2_(&sigmar, &sigmai); u[0] = (h11 * (h11 - s) + t * t) / h21 + h12; u[1] = h11 + h22 - s; u[2] = h32; i__2 = iend - 1; for (i__ = istart; i__ <= i__2; ++i__) { /* Computing MIN */ i__3 = 3, i__4 = iend - i__ + 1; nr = min(i__3,i__4); /* %-----------------------------------------------------% | Construct Householder reflector G to zero out u(1). | | G is of the form I - tau*( 1 u )' * ( 1 u' ). | %-----------------------------------------------------% */ igraphdlarfg_(&nr, u, &u[1], &c__1, &tau); if (i__ > istart) { h__[i__ + (i__ - 1) * h_dim1] = u[0]; h__[i__ + 1 + (i__ - 1) * h_dim1] = 0.; if (i__ < iend - 1) { h__[i__ + 2 + (i__ - 1) * h_dim1] = 0.; } } u[0] = 1.; /* %--------------------------------------% | Apply the reflector to the left of H | %--------------------------------------% */ i__3 = kplusp - i__ + 1; igraphdlarf_("Left", &nr, &i__3, u, &c__1, &tau, &h__[i__ + i__ * h_dim1], ldh, &workl[1]); /* %---------------------------------------% | Apply the reflector to the right of H | %---------------------------------------% Computing MIN */ i__3 = i__ + 3; ir = min(i__3,iend); igraphdlarf_("Right", &ir, &nr, u, &c__1, &tau, &h__[i__ * h_dim1 + 1], ldh, &workl[1]); /* %-----------------------------------------------------% | Accumulate the reflector in the matrix Q; Q <- Q*G | %-----------------------------------------------------% */ igraphdlarf_("Right", &kplusp, &nr, u, &c__1, &tau, &q[i__ * q_dim1 + 1], ldq, &workl[1]); /* %----------------------------% | Prepare for next reflector | %----------------------------% */ if (i__ < iend - 1) { u[0] = h__[i__ + 1 + i__ * h_dim1]; u[1] = h__[i__ + 2 + i__ * h_dim1]; if (i__ < iend - 2) { u[2] = h__[i__ + 3 + i__ * h_dim1]; } } /* L90: */ } /* %--------------------------------------------% | Finished applying a complex pair of shifts | | to the current block | %--------------------------------------------% */ } L100: /* %---------------------------------------------------------% | Apply the same shift to the next block if there is any. | %---------------------------------------------------------% */ istart = iend + 1; if (iend < kplusp) { goto L20; } /* %---------------------------------------------% | Loop back to the top to get the next shift. | %---------------------------------------------% */ L110: ; } /* %--------------------------------------------------% | Perform a similarity transformation that makes | | sure that H will have non negative sub diagonals | %--------------------------------------------------% */ i__1 = *kev; for (j = 1; j <= i__1; ++j) { if (h__[j + 1 + j * h_dim1] < 0.) { i__2 = kplusp - j + 1; igraphdscal_(&i__2, &c_b43, &h__[j + 1 + j * h_dim1], ldh); /* Computing MIN */ i__3 = j + 2; i__2 = min(i__3,kplusp); igraphdscal_(&i__2, &c_b43, &h__[(j + 1) * h_dim1 + 1], &c__1); /* Computing MIN */ i__3 = j + *np + 1; i__2 = min(i__3,kplusp); igraphdscal_(&i__2, &c_b43, &q[(j + 1) * q_dim1 + 1], &c__1); } /* L120: */ } i__1 = *kev; for (i__ = 1; i__ <= i__1; ++i__) { /* %--------------------------------------------% | Final check for splitting and deflation. | | Use a standard test as in the QR algorithm | | REFERENCE: LAPACK subroutine dlahqr | %--------------------------------------------% */ tst1 = (d__1 = h__[i__ + i__ * h_dim1], abs(d__1)) + (d__2 = h__[i__ + 1 + (i__ + 1) * h_dim1], abs(d__2)); if (tst1 == 0.) { tst1 = igraphdlanhs_("1", kev, &h__[h_offset], ldh, &workl[1]); } /* Computing MAX */ d__1 = ulp * tst1; if (h__[i__ + 1 + i__ * h_dim1] <= max(d__1,smlnum)) { h__[i__ + 1 + i__ * h_dim1] = 0.; } /* L130: */ } /* %-------------------------------------------------% | Compute the (kev+1)-st column of (V*Q) and | | temporarily store the result in WORKD(N+1:2*N). | | This is needed in the residual update since we | | cannot GUARANTEE that the corresponding entry | | of H would be zero as in exact arithmetic. | %-------------------------------------------------% */ if (h__[*kev + 1 + *kev * h_dim1] > 0.) { igraphdgemv_("N", n, &kplusp, &c_b6, &v[v_offset], ldv, &q[(*kev + 1) * q_dim1 + 1], &c__1, &c_b5, &workd[*n + 1], &c__1); } /* %----------------------------------------------------------% | Compute column 1 to kev of (V*Q) in backward order | | taking advantage of the upper Hessenberg structure of Q. | %----------------------------------------------------------% */ i__1 = *kev; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = kplusp - i__ + 1; igraphdgemv_("N", n, &i__2, &c_b6, &v[v_offset], ldv, &q[(*kev - i__ + 1) * q_dim1 + 1], &c__1, &c_b5, &workd[1], &c__1); igraphdcopy_(n, &workd[1], &c__1, &v[(kplusp - i__ + 1) * v_dim1 + 1], & c__1); /* L140: */ } /* %-------------------------------------------------% | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | %-------------------------------------------------% */ igraphdlacpy_("A", n, kev, &v[(kplusp - *kev + 1) * v_dim1 + 1], ldv, &v[ v_offset], ldv); /* %--------------------------------------------------------------% | Copy the (kev+1)-st column of (V*Q) in the appropriate place | %--------------------------------------------------------------% */ if (h__[*kev + 1 + *kev * h_dim1] > 0.) { igraphdcopy_(n, &workd[*n + 1], &c__1, &v[(*kev + 1) * v_dim1 + 1], &c__1); } /* %-------------------------------------% | Update the residual vector: | | r <- sigmak*r + betak*v(:,kev+1) | | where | | sigmak = (e_{kplusp}'*Q)*e_{kev} | | betak = e_{kev+1}'*H*e_{kev} | %-------------------------------------% */ igraphdscal_(n, &q[kplusp + *kev * q_dim1], &resid[1], &c__1); if (h__[*kev + 1 + *kev * h_dim1] > 0.) { igraphdaxpy_(n, &h__[*kev + 1 + *kev * h_dim1], &v[(*kev + 1) * v_dim1 + 1], &c__1, &resid[1], &c__1); } if (msglvl > 1) { igraphdvout_(&logfil, &c__1, &q[kplusp + *kev * q_dim1], &ndigit, "_napps:" " sigmak = (e_{kev+p}^T*Q)*e_{kev}", (ftnlen)40); igraphdvout_(&logfil, &c__1, &h__[*kev + 1 + *kev * h_dim1], &ndigit, "_na" "pps: betak = e_{kev+1}^T*H*e_{kev}", (ftnlen)37); igraphivout_(&logfil, &c__1, kev, &ndigit, "_napps: Order of the final Hes" "senberg matrix ", (ftnlen)45); if (msglvl > 2) { igraphdmout_(&logfil, kev, kev, &h__[h_offset], ldh, &ndigit, "_napps:" " updated Hessenberg matrix H for next iteration", (ftnlen) 54); } } L9000: igraphsecond_(&t1); tnapps += t1 - t0; return 0; /* %---------------% | End of dnapps | %---------------% */ } /* igraphdnapps_ */
/* Subroutine */ int igraphdlaqrb_(logical *wantt, integer *n, integer *ilo, integer *ihi, doublereal *h__, integer *ldh, doublereal *wr, doublereal *wi, doublereal *z__, integer *info) { /* System generated locals */ integer h_dim1, h_offset, i__1, i__2, i__3, i__4; doublereal d__1, d__2; /* Local variables */ static integer i__, j, k, l, m; static doublereal s, v[3]; static integer i1, i2; static doublereal t1, t2, t3, v1, v2, v3, h00, h10, h11, h12, h21, h22, h33, h44; static integer nh; static doublereal cs; static integer nr; static doublereal sn, h33s, h44s; static integer itn, its; static doublereal ulp, sum, tst1, h43h34, unfl, ovfl; extern /* Subroutine */ int igraphdrot_(integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *); static doublereal work[1]; extern /* Subroutine */ int igraphdcopy_(integer *, doublereal *, integer *, doublereal *, integer *), igraphdlanv2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *), igraphdlabad_( doublereal *, doublereal *); extern doublereal igraphdlamch_(char *); extern /* Subroutine */ int igraphdlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *); extern doublereal igraphdlanhs_(char *, integer *, doublereal *, integer *, doublereal *); static doublereal smlnum; /* %------------------% */ /* | Scalar Arguments | */ /* %------------------% */ /* %-----------------% */ /* | Array Arguments | */ /* %-----------------% */ /* %------------% */ /* | Parameters | */ /* %------------% */ /* %------------------------% */ /* | Local Scalars & Arrays | */ /* %------------------------% */ /* %--------------------% */ /* | External Functions | */ /* %--------------------% */ /* %----------------------% */ /* | External Subroutines | */ /* %----------------------% */ /* %-----------------------% */ /* | Executable Statements | */ /* %-----------------------% */ /* Parameter adjustments */ h_dim1 = *ldh; h_offset = 1 + h_dim1; h__ -= h_offset; --wr; --wi; --z__; /* Function Body */ *info = 0; /* %--------------------------% */ /* | Quick return if possible | */ /* %--------------------------% */ if (*n == 0) { return 0; } if (*ilo == *ihi) { wr[*ilo] = h__[*ilo + *ilo * h_dim1]; wi[*ilo] = 0.; return 0; } /* %---------------------------------------------% */ /* | Initialize the vector of last components of | */ /* | the Schur vectors for accumulation. | */ /* %---------------------------------------------% */ i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { z__[j] = 0.; /* L5: */ } z__[*n] = 1.; nh = *ihi - *ilo + 1; /* %-------------------------------------------------------------% */ /* | Set machine-dependent constants for the stopping criterion. | */ /* | If norm(H) <= sqrt(OVFL), overflow should not occur. | */ /* %-------------------------------------------------------------% */ unfl = igraphdlamch_("safe minimum"); ovfl = 1. / unfl; igraphdlabad_(&unfl, &ovfl); ulp = igraphdlamch_("precision"); smlnum = unfl * (nh / ulp); /* %---------------------------------------------------------------% */ /* | I1 and I2 are the indices of the first row and last column | */ /* | of H to which transformations must be applied. If eigenvalues | */ /* | only are computed, I1 and I2 are set inside the main loop. | */ /* | Zero out H(J+2,J) = ZERO for J=1:N if WANTT = .TRUE. | */ /* | else H(J+2,J) for J=ILO:IHI-ILO-1 if WANTT = .FALSE. | */ /* %---------------------------------------------------------------% */ if (*wantt) { i1 = 1; i2 = *n; i__1 = i2 - 2; for (i__ = 1; i__ <= i__1; ++i__) { h__[i1 + i__ + 1 + i__ * h_dim1] = 0.; /* L8: */ } } else { i__1 = *ihi - *ilo - 1; for (i__ = 1; i__ <= i__1; ++i__) { h__[*ilo + i__ + 1 + (*ilo + i__ - 1) * h_dim1] = 0.; /* L9: */ } } /* %---------------------------------------------------% */ /* | ITN is the total number of QR iterations allowed. | */ /* %---------------------------------------------------% */ itn = nh * 30; /* ------------------------------------------------------------------ */ /* The main loop begins here. I is the loop index and decreases from */ /* IHI to ILO in steps of 1 or 2. Each iteration of the loop works */ /* with the active submatrix in rows and columns L to I. */ /* Eigenvalues I+1 to IHI have already converged. Either L = ILO or */ /* H(L,L-1) is negligible so that the matrix splits. */ /* ------------------------------------------------------------------ */ i__ = *ihi; L10: l = *ilo; if (i__ < *ilo) { goto L150; } /* %--------------------------------------------------------------% */ /* | Perform QR iterations on rows and columns ILO to I until a | */ /* | submatrix of order 1 or 2 splits off at the bottom because a | */ /* | subdiagonal element has become negligible. | */ /* %--------------------------------------------------------------% */ i__1 = itn; for (its = 0; its <= i__1; ++its) { /* %----------------------------------------------% */ /* | Look for a single small subdiagonal element. | */ /* %----------------------------------------------% */ i__2 = l + 1; for (k = i__; k >= i__2; --k) { tst1 = (d__1 = h__[k - 1 + (k - 1) * h_dim1], abs(d__1)) + (d__2 = h__[k + k * h_dim1], abs(d__2)); if (tst1 == 0.) { i__3 = i__ - l + 1; tst1 = igraphdlanhs_("1", &i__3, &h__[l + l * h_dim1], ldh, work); } /* Computing MAX */ d__2 = ulp * tst1; if ((d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)) <= max(d__2, smlnum)) { goto L30; } /* L20: */ } L30: l = k; if (l > *ilo) { /* %------------------------% */ /* | H(L,L-1) is negligible | */ /* %------------------------% */ h__[l + (l - 1) * h_dim1] = 0.; } /* %-------------------------------------------------------------% */ /* | Exit from loop if a submatrix of order 1 or 2 has split off | */ /* %-------------------------------------------------------------% */ if (l >= i__ - 1) { goto L140; } /* %---------------------------------------------------------% */ /* | Now the active submatrix is in rows and columns L to I. | */ /* | If eigenvalues only are being computed, only the active | */ /* | submatrix need be transformed. | */ /* %---------------------------------------------------------% */ if (! (*wantt)) { i1 = l; i2 = i__; } if (its == 10 || its == 20) { /* %-------------------% */ /* | Exceptional shift | */ /* %-------------------% */ s = (d__1 = h__[i__ + (i__ - 1) * h_dim1], abs(d__1)) + (d__2 = h__[i__ - 1 + (i__ - 2) * h_dim1], abs(d__2)); h44 = s * .75; h33 = h44; h43h34 = s * -.4375 * s; } else { /* %-----------------------------------------% */ /* | Prepare to use Wilkinson's double shift | */ /* %-----------------------------------------% */ h44 = h__[i__ + i__ * h_dim1]; h33 = h__[i__ - 1 + (i__ - 1) * h_dim1]; h43h34 = h__[i__ + (i__ - 1) * h_dim1] * h__[i__ - 1 + i__ * h_dim1]; } /* %-----------------------------------------------------% */ /* | Look for two consecutive small subdiagonal elements | */ /* %-----------------------------------------------------% */ i__2 = l; for (m = i__ - 2; m >= i__2; --m) { /* %---------------------------------------------------------% */ /* | Determine the effect of starting the double-shift QR | */ /* | iteration at row M, and see if this would make H(M,M-1) | */ /* | negligible. | */ /* %---------------------------------------------------------% */ h11 = h__[m + m * h_dim1]; h22 = h__[m + 1 + (m + 1) * h_dim1]; h21 = h__[m + 1 + m * h_dim1]; h12 = h__[m + (m + 1) * h_dim1]; h44s = h44 - h11; h33s = h33 - h11; v1 = (h33s * h44s - h43h34) / h21 + h12; v2 = h22 - h11 - h33s - h44s; v3 = h__[m + 2 + (m + 1) * h_dim1]; s = abs(v1) + abs(v2) + abs(v3); v1 /= s; v2 /= s; v3 /= s; v[0] = v1; v[1] = v2; v[2] = v3; if (m == l) { goto L50; } h00 = h__[m - 1 + (m - 1) * h_dim1]; h10 = h__[m + (m - 1) * h_dim1]; tst1 = abs(v1) * (abs(h00) + abs(h11) + abs(h22)); if (abs(h10) * (abs(v2) + abs(v3)) <= ulp * tst1) { goto L50; } /* L40: */ } L50: /* %----------------------% */ /* | Double-shift QR step | */ /* %----------------------% */ i__2 = i__ - 1; for (k = m; k <= i__2; ++k) { /* ------------------------------------------------------------ */ /* The first iteration of this loop determines a reflection G */ /* from the vector V and applies it from left and right to H, */ /* thus creating a nonzero bulge below the subdiagonal. */ /* Each subsequent iteration determines a reflection G to */ /* restore the Hessenberg form in the (K-1)th column, and thus */ /* chases the bulge one step toward the bottom of the active */ /* submatrix. NR is the order of G. */ /* ------------------------------------------------------------ */ /* Computing MIN */ i__3 = 3, i__4 = i__ - k + 1; nr = min(i__3,i__4); if (k > m) { igraphdcopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1); } igraphdlarfg_(&nr, v, &v[1], &c__1, &t1); if (k > m) { h__[k + (k - 1) * h_dim1] = v[0]; h__[k + 1 + (k - 1) * h_dim1] = 0.; if (k < i__ - 1) { h__[k + 2 + (k - 1) * h_dim1] = 0.; } } else if (m > l) { h__[k + (k - 1) * h_dim1] = -h__[k + (k - 1) * h_dim1]; } v2 = v[1]; t2 = t1 * v2; if (nr == 3) { v3 = v[2]; t3 = t1 * v3; /* %------------------------------------------------% */ /* | Apply G from the left to transform the rows of | */ /* | the matrix in columns K to I2. | */ /* %------------------------------------------------% */ i__3 = i2; for (j = k; j <= i__3; ++j) { sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1] + v3 * h__[k + 2 + j * h_dim1]; h__[k + j * h_dim1] -= sum * t1; h__[k + 1 + j * h_dim1] -= sum * t2; h__[k + 2 + j * h_dim1] -= sum * t3; /* L60: */ } /* %----------------------------------------------------% */ /* | Apply G from the right to transform the columns of | */ /* | the matrix in rows I1 to min(K+3,I). | */ /* %----------------------------------------------------% */ /* Computing MIN */ i__4 = k + 3; i__3 = min(i__4,i__); for (j = i1; j <= i__3; ++j) { sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1] + v3 * h__[j + (k + 2) * h_dim1]; h__[j + k * h_dim1] -= sum * t1; h__[j + (k + 1) * h_dim1] -= sum * t2; h__[j + (k + 2) * h_dim1] -= sum * t3; /* L70: */ } /* %----------------------------------% */ /* | Accumulate transformations for Z | */ /* %----------------------------------% */ sum = z__[k] + v2 * z__[k + 1] + v3 * z__[k + 2]; z__[k] -= sum * t1; z__[k + 1] -= sum * t2; z__[k + 2] -= sum * t3; } else if (nr == 2) { /* %------------------------------------------------% */ /* | Apply G from the left to transform the rows of | */ /* | the matrix in columns K to I2. | */ /* %------------------------------------------------% */ i__3 = i2; for (j = k; j <= i__3; ++j) { sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1]; h__[k + j * h_dim1] -= sum * t1; h__[k + 1 + j * h_dim1] -= sum * t2; /* L90: */ } /* %----------------------------------------------------% */ /* | Apply G from the right to transform the columns of | */ /* | the matrix in rows I1 to min(K+3,I). | */ /* %----------------------------------------------------% */ i__3 = i__; for (j = i1; j <= i__3; ++j) { sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1] ; h__[j + k * h_dim1] -= sum * t1; h__[j + (k + 1) * h_dim1] -= sum * t2; /* L100: */ } /* %----------------------------------% */ /* | Accumulate transformations for Z | */ /* %----------------------------------% */ sum = z__[k] + v2 * z__[k + 1]; z__[k] -= sum * t1; z__[k + 1] -= sum * t2; } /* L120: */ } /* L130: */ } /* %-------------------------------------------------------% */ /* | Failure to converge in remaining number of iterations | */ /* %-------------------------------------------------------% */ *info = i__; return 0; L140: if (l == i__) { /* %------------------------------------------------------% */ /* | H(I,I-1) is negligible: one eigenvalue has converged | */ /* %------------------------------------------------------% */ wr[i__] = h__[i__ + i__ * h_dim1]; wi[i__] = 0.; } else if (l == i__ - 1) { /* %--------------------------------------------------------% */ /* | H(I-1,I-2) is negligible; | */ /* | a pair of eigenvalues have converged. | */ /* | | */ /* | Transform the 2-by-2 submatrix to standard Schur form, | */ /* | and compute and store the eigenvalues. | */ /* %--------------------------------------------------------% */ igraphdlanv2_(&h__[i__ - 1 + (i__ - 1) * h_dim1], &h__[i__ - 1 + i__ * h_dim1], &h__[i__ + (i__ - 1) * h_dim1], &h__[i__ + i__ * h_dim1], &wr[i__ - 1], &wi[i__ - 1], &wr[i__], &wi[i__], &cs, &sn); if (*wantt) { /* %-----------------------------------------------------% */ /* | Apply the transformation to the rest of H and to Z, | */ /* | as required. | */ /* %-----------------------------------------------------% */ if (i2 > i__) { i__1 = i2 - i__; igraphdrot_(&i__1, &h__[i__ - 1 + (i__ + 1) * h_dim1], ldh, &h__[ i__ + (i__ + 1) * h_dim1], ldh, &cs, &sn); } i__1 = i__ - i1 - 1; igraphdrot_(&i__1, &h__[i1 + (i__ - 1) * h_dim1], &c__1, &h__[i1 + i__ * h_dim1], &c__1, &cs, &sn); sum = cs * z__[i__ - 1] + sn * z__[i__]; z__[i__] = cs * z__[i__] - sn * z__[i__ - 1]; z__[i__ - 1] = sum; } } /* %---------------------------------------------------------% */ /* | Decrement number of remaining iterations, and return to | */ /* | start of the main loop with new value of I. | */ /* %---------------------------------------------------------% */ itn -= its; i__ = l - 1; goto L10; L150: return 0; /* %---------------% */ /* | End of igraphdlaqrb | */ /* %---------------% */ } /* igraphdlaqrb_ */