/* Subroutine */ int dhseqr_(char *job, char *compz, integer *n, integer *ilo, integer *ihi, doublereal *h, integer *ldh, doublereal *wr, doublereal *wi, doublereal *z, integer *ldz, doublereal *work, integer *lwork, integer *info) { /* -- LAPACK routine (version 2.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= DHSEQR computes the eigenvalues of a real upper Hessenberg matrix H and, optionally, the matrices T and Z from the Schur decomposition H = Z T Z**T, where T is an upper quasi-triangular matrix (the Schur form), and Z is the orthogonal matrix of Schur vectors. Optionally Z may be postmultiplied into an input orthogonal matrix Q, so that this routine can give the Schur factorization of a matrix A which has been reduced to the Hessenberg form H by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. Arguments ========= JOB (input) CHARACTER*1 = 'E': compute eigenvalues only; = 'S': compute eigenvalues and the Schur form T. COMPZ (input) CHARACTER*1 = 'N': no Schur vectors are computed; = 'I': Z is initialized to the unit matrix and the matrix Z of Schur vectors of H is returned; = 'V': Z must contain an orthogonal matrix Q on entry, and the product Q*Z is returned. N (input) INTEGER The order of the matrix H. N >= 0. ILO (input) INTEGER IHI (input) INTEGER It is assumed that H is already upper triangular in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally set by a previous call to DGEBAL, and then passed to SGEHRD when the matrix output by DGEBAL is reduced to Hessenberg form. Otherwise ILO and IHI should be set to 1 and N respectively. 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. H (input/output) DOUBLE PRECISION array, dimension (LDH,N) On entry, the upper Hessenberg matrix H. On exit, if JOB = 'S', H contains the upper quasi-triangular matrix T from the Schur decomposition (the Schur form); 2-by-2 diagonal blocks (corresponding to complex conjugate pairs of eigenvalues) are returned in standard form, with H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. If JOB = 'E', the contents of H are unspecified on exit. LDH (input) INTEGER The leading dimension of the array H. LDH >= max(1,N). WR (output) DOUBLE PRECISION array, dimension (N) WI (output) DOUBLE PRECISION array, dimension (N) The real and imaginary parts, respectively, of the computed eigenvalues. If two eigenvalues are computed as a complex conjugate pair, they are stored in consecutive elements of WR and WI, say the i-th and (i+1)th, with WI(i) > 0 and WI(i+1) < 0. If JOB = 'S', the eigenvalues are stored in the same order as on the diagonal of the Schur form returned in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) If COMPZ = 'N': Z is not referenced. If COMPZ = 'I': on entry, Z need not be set, and on exit, Z contains the orthogonal matrix Z of the Schur vectors of H. If COMPZ = 'V': on entry Z must contain an N-by-N matrix Q, which is assumed to be equal to the unit matrix except for the submatrix Z(ILO:IHI,ILO:IHI); on exit Z contains Q*Z. Normally Q is the orthogonal matrix generated by DORGHR after the call to DGEHRD which formed the Hessenberg matrix H. LDZ (input) INTEGER The leading dimension of the array Z. LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise. WORK (workspace) DOUBLE PRECISION array, dimension (N) LWORK (input) INTEGER This argument is currently redundant. INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value > 0: if INFO = i, DHSEQR failed to compute all of the eigenvalues in a total of 30*(IHI-ILO+1) iterations; elements 1:ilo-1 and i+1:n of WR and WI contain those eigenvalues which have been successfully computed. ===================================================================== Decode and test the input parameters Parameter adjustments Function Body */ /* Table of constant values */ static doublereal c_b9 = 0.; static doublereal c_b10 = 1.; static integer c__4 = 4; static integer c_n1 = -1; static integer c__2 = 2; static integer c__8 = 8; static integer c__15 = 15; static logical c_false = FALSE_; static integer c__1 = 1; /* System generated locals */ address a__1[2]; integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3[2], i__4, i__5; doublereal d__1, d__2; char ch__1[2]; /* Builtin functions Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); /* Local variables */ static integer maxb; static doublereal absw; static integer ierr; static doublereal unfl, temp, ovfl; static integer i, j, k, l; static doublereal s[225] /* was [15][15] */, v[16]; extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, integer *); extern logical lsame_(char *, char *); extern /* Subroutine */ int dgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *); static integer itemp; extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *); static integer i1, i2; static logical initz, wantt, wantz; extern doublereal dlapy2_(doublereal *, doublereal *); extern /* Subroutine */ int dlabad_(doublereal *, doublereal *); static integer ii, nh; extern doublereal dlamch_(char *); extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *); static integer nr, ns; extern integer idamax_(integer *, doublereal *, integer *); static integer nv; extern doublereal dlanhs_(char *, integer *, doublereal *, integer *, doublereal *); extern /* Subroutine */ int dlahqr_(logical *, logical *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, integer *); static doublereal vv[16]; extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); extern /* Subroutine */ int dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *), dlarfx_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *), xerbla_(char *, integer *); static doublereal smlnum; static integer itn; static doublereal tau; static integer its; static doublereal ulp, tst1; #define S(I) s[(I)] #define WAS(I) was[(I)] #define V(I) v[(I)] #define VV(I) vv[(I)] #define WR(I) wr[(I)-1] #define WI(I) wi[(I)-1] #define WORK(I) work[(I)-1] #define H(I,J) h[(I)-1 + ((J)-1)* ( *ldh)] #define Z(I,J) z[(I)-1 + ((J)-1)* ( *ldz)] wantt = lsame_(job, "S"); initz = lsame_(compz, "I"); wantz = initz || lsame_(compz, "V"); *info = 0; if (! lsame_(job, "E") && ! wantt) { *info = -1; } else if (! lsame_(compz, "N") && ! wantz) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*ilo < 1 || *ilo > max(1,*n)) { *info = -4; } else if (*ihi < min(*ilo,*n) || *ihi > *n) { *info = -5; } else if (*ldh < max(1,*n)) { *info = -7; } else if (*ldz < 1 || wantz && *ldz < max(1,*n)) { *info = -11; } if (*info != 0) { i__1 = -(*info); xerbla_("DHSEQR", &i__1); return 0; } /* Initialize Z, if necessary */ if (initz) { dlaset_("Full", n, n, &c_b9, &c_b10, &Z(1,1), ldz); } /* Store the eigenvalues isolated by DGEBAL. */ i__1 = *ilo - 1; for (i = 1; i <= *ilo-1; ++i) { WR(i) = H(i,i); WI(i) = 0.; /* L10: */ } i__1 = *n; for (i = *ihi + 1; i <= *n; ++i) { WR(i) = H(i,i); WI(i) = 0.; /* L20: */ } /* Quick return if possible. */ if (*n == 0) { return 0; } if (*ilo == *ihi) { WR(*ilo) = H(*ilo,*ilo); WI(*ilo) = 0.; return 0; } /* Set rows and columns ILO to IHI to zero below the first subdiagonal. */ i__1 = *ihi - 2; for (j = *ilo; j <= *ihi-2; ++j) { i__2 = *n; for (i = j + 2; i <= *n; ++i) { H(i,j) = 0.; /* L30: */ } /* L40: */ } nh = *ihi - *ilo + 1; /* Determine the order of the multi-shift QR algorithm to be used. Writing concatenation */ i__3[0] = 1, a__1[0] = job; i__3[1] = 1, a__1[1] = compz; s_cat(ch__1, a__1, i__3, &c__2, 2L); ns = ilaenv_(&c__4, "DHSEQR", ch__1, n, ilo, ihi, &c_n1, 6L, 2L); /* Writing concatenation */ i__3[0] = 1, a__1[0] = job; i__3[1] = 1, a__1[1] = compz; s_cat(ch__1, a__1, i__3, &c__2, 2L); maxb = ilaenv_(&c__8, "DHSEQR", ch__1, n, ilo, ihi, &c_n1, 6L, 2L); if (ns <= 2 || ns > nh || maxb >= nh) { /* Use the standard double-shift algorithm */ dlahqr_(&wantt, &wantz, n, ilo, ihi, &H(1,1), ldh, &WR(1), &WI(1) , ilo, ihi, &Z(1,1), ldz, info); return 0; } maxb = max(3,maxb); /* Computing MIN */ i__1 = min(ns,maxb); ns = min(i__1,15); /* Now 2 < NS <= MAXB < NH. Set machine-dependent constants for the stopping criterion. If norm(H) <= sqrt(OVFL), overflow should not occur. */ unfl = dlamch_("Safe minimum"); ovfl = 1. / unfl; dlabad_(&unfl, &ovfl); ulp = dlamch_("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 being computed, I1 and I2 are set inside the main loop. */ if (wantt) { i1 = 1; i2 = *n; } /* ITN is the total number of multiple-shift 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 at most MAXB. 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; L50: l = *ilo; if (i < *ilo) { goto L170; } /* Perform multiple-shift QR iterations on rows and columns ILO to I until a submatrix of order at most MAXB splits off at the bottom because a subdiagonal element has become negligible. */ i__1 = itn; for (its = 0; its <= itn; ++its) { /* Look for a single small subdiagonal element. */ i__2 = l + 1; for (k = i; k >= l+1; --k) { tst1 = (d__1 = H(k-1,k-1), abs(d__1)) + (d__2 = H(k,k), abs(d__2)); if (tst1 == 0.) { i__4 = i - l + 1; tst1 = dlanhs_("1", &i__4, &H(l,l), ldh, &WORK(1)); } /* Computing MAX */ d__2 = ulp * tst1; if ((d__1 = H(k,k-1), abs(d__1)) <= max(d__2, smlnum)) { goto L70; } /* L60: */ } L70: l = k; if (l > *ilo) { /* H(L,L-1) is negligible. */ H(l,l-1) = 0.; } /* Exit from loop if a submatrix of order <= MAXB has split off . */ if (l >= i - maxb + 1) { goto L160; } /* Now the active submatrix is in rows and columns L to I. If eigenvalues only are being computed, only the active submatr ix need be transformed. */ if (! wantt) { i1 = l; i2 = i; } if (its == 20 || its == 30) { /* Exceptional shifts. */ i__2 = i; for (ii = i - ns + 1; ii <= i; ++ii) { WR(ii) = ((d__1 = H(ii,ii-1), abs(d__1)) + ( d__2 = H(ii,ii), abs(d__2))) * 1.5; WI(ii) = 0.; /* L80: */ } } else { /* Use eigenvalues of trailing submatrix of order NS as shifts. */ dlacpy_("Full", &ns, &ns, &H(i-ns+1,i-ns+1), ldh, s, &c__15); dlahqr_(&c_false, &c_false, &ns, &c__1, &ns, s, &c__15, &WR(i - ns + 1), &WI(i - ns + 1), &c__1, &ns, &Z(1,1), ldz, & ierr); if (ierr > 0) { /* If DLAHQR failed to compute all NS eigenvalues , use the unconverged diagonal elements as the remaining shifts. */ i__2 = ierr; for (ii = 1; ii <= ierr; ++ii) { WR(i - ns + ii) = S(ii + ii * 15 - 16); WI(i - ns + ii) = 0.; /* L90: */ } } } /* Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns)) where G is the Hessenberg submatrix H(L:I,L:I) and w is the vector of shifts (stored in WR and WI). The result is stored in the local array V. */ V(0) = 1.; i__2 = ns + 1; for (ii = 2; ii <= ns+1; ++ii) { V(ii - 1) = 0.; /* L100: */ } nv = 1; i__2 = i; for (j = i - ns + 1; j <= i; ++j) { if (WI(j) >= 0.) { if (WI(j) == 0.) { /* real shift */ i__4 = nv + 1; dcopy_(&i__4, v, &c__1, vv, &c__1); i__4 = nv + 1; d__1 = -WR(j); dgemv_("No transpose", &i__4, &nv, &c_b10, &H(l,l), ldh, vv, &c__1, &d__1, v, &c__1); ++nv; } else if (WI(j) > 0.) { /* complex conjugate pair of shifts */ i__4 = nv + 1; dcopy_(&i__4, v, &c__1, vv, &c__1); i__4 = nv + 1; d__1 = WR(j) * -2.; dgemv_("No transpose", &i__4, &nv, &c_b10, &H(l,l), ldh, v, &c__1, &d__1, vv, &c__1); i__4 = nv + 1; itemp = idamax_(&i__4, vv, &c__1); /* Computing MAX */ d__2 = (d__1 = VV(itemp - 1), abs(d__1)); temp = 1. / max(d__2,smlnum); i__4 = nv + 1; dscal_(&i__4, &temp, vv, &c__1); absw = dlapy2_(&WR(j), &WI(j)); temp = temp * absw * absw; i__4 = nv + 2; i__5 = nv + 1; dgemv_("No transpose", &i__4, &i__5, &c_b10, &H(l,l), ldh, vv, &c__1, &temp, v, &c__1); nv += 2; } /* Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero, reset it to the unit vector. */ itemp = idamax_(&nv, v, &c__1); temp = (d__1 = V(itemp - 1), abs(d__1)); if (temp == 0.) { V(0) = 1.; i__4 = nv; for (ii = 2; ii <= nv; ++ii) { V(ii - 1) = 0.; /* L110: */ } } else { temp = max(temp,smlnum); d__1 = 1. / temp; dscal_(&nv, &d__1, v, &c__1); } } /* L120: */ } /* Multiple-shift QR step */ i__2 = i - 1; for (k = l; k <= i-1; ++k) { /* The first iteration of this loop determines a reflect ion 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 t o restore the Hessenberg form in the (K-1)th column, an d thus chases the bulge one step toward the bottom of the ac tive submatrix. NR is the order of G. Computing MIN */ i__4 = ns + 1, i__5 = i - k + 1; nr = min(i__4,i__5); if (k > l) { dcopy_(&nr, &H(k,k-1), &c__1, v, &c__1); } dlarfg_(&nr, v, &V(1), &c__1, &tau); if (k > l) { H(k,k-1) = V(0); i__4 = i; for (ii = k + 1; ii <= i; ++ii) { H(ii,k-1) = 0.; /* L130: */ } } V(0) = 1.; /* Apply G from the left to transform the rows of the ma trix in columns K to I2. */ i__4 = i2 - k + 1; dlarfx_("Left", &nr, &i__4, v, &tau, &H(k,k), ldh, & WORK(1)); /* Apply G from the right to transform the columns of th e matrix in rows I1 to min(K+NR,I). Computing MIN */ i__5 = k + nr; i__4 = min(i__5,i) - i1 + 1; dlarfx_("Right", &i__4, &nr, v, &tau, &H(i1,k), ldh, & WORK(1)); if (wantz) { /* Accumulate transformations in the matrix Z */ dlarfx_("Right", &nh, &nr, v, &tau, &Z(*ilo,k), ldz, &WORK(1)); } /* L140: */ } /* L150: */ } /* Failure to converge in remaining number of iterations */ *info = i; return 0; L160: /* A submatrix of order <= MAXB in rows and columns L to I has split off. Use the double-shift QR algorithm to handle it. */ dlahqr_(&wantt, &wantz, n, &l, &i, &H(1,1), ldh, &WR(1), &WI(1), ilo, ihi, &Z(1,1), ldz, info); if (*info > 0) { return 0; } /* Decrement number of remaining iterations, and return to start of the main loop with a new value of I. */ itn -= its; i = l - 1; goto L50; L170: return 0; /* End of DHSEQR */ } /* dhseqr_ */
/* Subroutine */ int dlaexc_(logical *wantq, integer *n, doublereal *t, integer *ldt, doublereal *q, integer *ldq, integer *j1, integer *n1, integer *n2, doublereal *work, integer *info) { /* -- LAPACK auxiliary routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University February 29, 1992 Purpose ======= DLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in an upper quasi-triangular matrix T by an orthogonal similarity transformation. T must be in Schur canonical form, that is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has its diagonal elemnts equal and its off-diagonal elements of opposite sign. Arguments ========= WANTQ (input) LOGICAL = .TRUE. : accumulate the transformation in the matrix Q; = .FALSE.: do not accumulate the transformation. N (input) INTEGER The order of the matrix T. N >= 0. T (input/output) DOUBLE PRECISION array, dimension (LDT,N) On entry, the upper quasi-triangular matrix T, in Schur canonical form. On exit, the updated matrix T, again in Schur canonical form. LDT (input) INTEGER The leading dimension of the array T. LDT >= max(1,N). Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) On entry, if WANTQ is .TRUE., the orthogonal matrix Q. On exit, if WANTQ is .TRUE., the updated matrix Q. If WANTQ is .FALSE., Q is not referenced. LDQ (input) INTEGER The leading dimension of the array Q. LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N. J1 (input) INTEGER The index of the first row of the first block T11. N1 (input) INTEGER The order of the first block T11. N1 = 0, 1 or 2. N2 (input) INTEGER The order of the second block T22. N2 = 0, 1 or 2. WORK (workspace) DOUBLE PRECISION array, dimension (N) INFO (output) INTEGER = 0: successful exit = 1: the transformed matrix T would be too far from Schur form; the blocks are not swapped and T and Q are unchanged. ===================================================================== Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; static integer c__4 = 4; static logical c_false = FALSE_; static integer c_n1 = -1; static integer c__2 = 2; static integer c__3 = 3; /* System generated locals */ integer q_dim1, q_offset, t_dim1, t_offset, i__1; doublereal d__1, d__2, d__3, d__4, d__5, d__6; /* Local variables */ static integer ierr; static doublereal temp; extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *); static doublereal d__[16] /* was [4][4] */; static integer k; static doublereal u[3], scale, x[4] /* was [2][2] */, dnorm; static integer j2, j3, j4; static doublereal xnorm, u1[3], u2[3]; extern /* Subroutine */ int dlanv2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *), dlasy2_( logical *, logical *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *); static integer nd; static doublereal cs, t11, t22; extern doublereal dlamch_(char *); static doublereal t33; extern doublereal dlange_(char *, integer *, integer *, doublereal *, integer *, doublereal *); extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *); static doublereal sn; extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *), dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *), dlarfx_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *); static doublereal thresh, smlnum, wi1, wi2, wr1, wr2, eps, tau, tau1, tau2; #define d___ref(a_1,a_2) d__[(a_2)*4 + a_1 - 5] #define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1] #define t_ref(a_1,a_2) t[(a_2)*t_dim1 + a_1] #define x_ref(a_1,a_2) x[(a_2)*2 + a_1 - 3] t_dim1 = *ldt; t_offset = 1 + t_dim1 * 1; t -= t_offset; q_dim1 = *ldq; q_offset = 1 + q_dim1 * 1; q -= q_offset; --work; /* Function Body */ *info = 0; /* Quick return if possible */ if (*n == 0 || *n1 == 0 || *n2 == 0) { return 0; } if (*j1 + *n1 > *n) { return 0; } j2 = *j1 + 1; j3 = *j1 + 2; j4 = *j1 + 3; if (*n1 == 1 && *n2 == 1) { /* Swap two 1-by-1 blocks. */ t11 = t_ref(*j1, *j1); t22 = t_ref(j2, j2); /* Determine the transformation to perform the interchange. */ d__1 = t22 - t11; dlartg_(&t_ref(*j1, j2), &d__1, &cs, &sn, &temp); /* Apply transformation to the matrix T. */ if (j3 <= *n) { i__1 = *n - *j1 - 1; drot_(&i__1, &t_ref(*j1, j3), ldt, &t_ref(j2, j3), ldt, &cs, &sn); } i__1 = *j1 - 1; drot_(&i__1, &t_ref(1, *j1), &c__1, &t_ref(1, j2), &c__1, &cs, &sn); t_ref(*j1, *j1) = t22; t_ref(j2, j2) = t11; if (*wantq) { /* Accumulate transformation in the matrix Q. */ drot_(n, &q_ref(1, *j1), &c__1, &q_ref(1, j2), &c__1, &cs, &sn); } } else { /* Swapping involves at least one 2-by-2 block. Copy the diagonal block of order N1+N2 to the local array D and compute its norm. */ nd = *n1 + *n2; dlacpy_("Full", &nd, &nd, &t_ref(*j1, *j1), ldt, d__, &c__4); dnorm = dlange_("Max", &nd, &nd, d__, &c__4, &work[1]); /* Compute machine-dependent threshold for test for accepting swap. */ eps = dlamch_("P"); smlnum = dlamch_("S") / eps; /* Computing MAX */ d__1 = eps * 10. * dnorm; thresh = max(d__1,smlnum); /* Solve T11*X - X*T22 = scale*T12 for X. */ dlasy2_(&c_false, &c_false, &c_n1, n1, n2, d__, &c__4, &d___ref(*n1 + 1, *n1 + 1), &c__4, &d___ref(1, *n1 + 1), &c__4, &scale, x, & c__2, &xnorm, &ierr); /* Swap the adjacent diagonal blocks. */ k = *n1 + *n1 + *n2 - 3; switch (k) { case 1: goto L10; case 2: goto L20; case 3: goto L30; } L10: /* N1 = 1, N2 = 2: generate elementary reflector H so that: ( scale, X11, X12 ) H = ( 0, 0, * ) */ u[0] = scale; u[1] = x_ref(1, 1); u[2] = x_ref(1, 2); dlarfg_(&c__3, &u[2], u, &c__1, &tau); u[2] = 1.; t11 = t_ref(*j1, *j1); /* Perform swap provisionally on diagonal block in D. */ dlarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]); dlarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]); /* Test whether to reject swap. Computing MAX */ d__4 = (d__1 = d___ref(3, 1), abs(d__1)), d__5 = (d__2 = d___ref(3, 2) , abs(d__2)), d__4 = max(d__4,d__5), d__5 = (d__3 = d___ref(3, 3) - t11, abs(d__3)); if (max(d__4,d__5) > thresh) { goto L50; } /* Accept swap: apply transformation to the entire matrix T. */ i__1 = *n - *j1 + 1; dlarfx_("L", &c__3, &i__1, u, &tau, &t_ref(*j1, *j1), ldt, &work[1]); dlarfx_("R", &j2, &c__3, u, &tau, &t_ref(1, *j1), ldt, &work[1]); t_ref(j3, *j1) = 0.; t_ref(j3, j2) = 0.; t_ref(j3, j3) = t11; if (*wantq) { /* Accumulate transformation in the matrix Q. */ dlarfx_("R", n, &c__3, u, &tau, &q_ref(1, *j1), ldq, &work[1]); } goto L40; L20: /* N1 = 2, N2 = 1: generate elementary reflector H so that: H ( -X11 ) = ( * ) ( -X21 ) = ( 0 ) ( scale ) = ( 0 ) */ u[0] = -x_ref(1, 1); u[1] = -x_ref(2, 1); u[2] = scale; dlarfg_(&c__3, u, &u[1], &c__1, &tau); u[0] = 1.; t33 = t_ref(j3, j3); /* Perform swap provisionally on diagonal block in D. */ dlarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]); dlarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]); /* Test whether to reject swap. Computing MAX */ d__4 = (d__1 = d___ref(2, 1), abs(d__1)), d__5 = (d__2 = d___ref(3, 1) , abs(d__2)), d__4 = max(d__4,d__5), d__5 = (d__3 = d___ref(1, 1) - t33, abs(d__3)); if (max(d__4,d__5) > thresh) { goto L50; } /* Accept swap: apply transformation to the entire matrix T. */ dlarfx_("R", &j3, &c__3, u, &tau, &t_ref(1, *j1), ldt, &work[1]); i__1 = *n - *j1; dlarfx_("L", &c__3, &i__1, u, &tau, &t_ref(*j1, j2), ldt, &work[1]); t_ref(*j1, *j1) = t33; t_ref(j2, *j1) = 0.; t_ref(j3, *j1) = 0.; if (*wantq) { /* Accumulate transformation in the matrix Q. */ dlarfx_("R", n, &c__3, u, &tau, &q_ref(1, *j1), ldq, &work[1]); } goto L40; L30: /* N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so that: H(2) H(1) ( -X11 -X12 ) = ( * * ) ( -X21 -X22 ) ( 0 * ) ( scale 0 ) ( 0 0 ) ( 0 scale ) ( 0 0 ) */ u1[0] = -x_ref(1, 1); u1[1] = -x_ref(2, 1); u1[2] = scale; dlarfg_(&c__3, u1, &u1[1], &c__1, &tau1); u1[0] = 1.; temp = -tau1 * (x_ref(1, 2) + u1[1] * x_ref(2, 2)); u2[0] = -temp * u1[1] - x_ref(2, 2); u2[1] = -temp * u1[2]; u2[2] = scale; dlarfg_(&c__3, u2, &u2[1], &c__1, &tau2); u2[0] = 1.; /* Perform swap provisionally on diagonal block in D. */ dlarfx_("L", &c__3, &c__4, u1, &tau1, d__, &c__4, &work[1]) ; dlarfx_("R", &c__4, &c__3, u1, &tau1, d__, &c__4, &work[1]) ; dlarfx_("L", &c__3, &c__4, u2, &tau2, &d___ref(2, 1), &c__4, &work[1]); dlarfx_("R", &c__4, &c__3, u2, &tau2, &d___ref(1, 2), &c__4, &work[1]); /* Test whether to reject swap. Computing MAX */ d__5 = (d__1 = d___ref(3, 1), abs(d__1)), d__6 = (d__2 = d___ref(3, 2) , abs(d__2)), d__5 = max(d__5,d__6), d__6 = (d__3 = d___ref(4, 1), abs(d__3)), d__5 = max(d__5,d__6), d__6 = (d__4 = d___ref(4, 2), abs(d__4)); if (max(d__5,d__6) > thresh) { goto L50; } /* Accept swap: apply transformation to the entire matrix T. */ i__1 = *n - *j1 + 1; dlarfx_("L", &c__3, &i__1, u1, &tau1, &t_ref(*j1, *j1), ldt, &work[1]); dlarfx_("R", &j4, &c__3, u1, &tau1, &t_ref(1, *j1), ldt, &work[1]); i__1 = *n - *j1 + 1; dlarfx_("L", &c__3, &i__1, u2, &tau2, &t_ref(j2, *j1), ldt, &work[1]); dlarfx_("R", &j4, &c__3, u2, &tau2, &t_ref(1, j2), ldt, &work[1]); t_ref(j3, *j1) = 0.; t_ref(j3, j2) = 0.; t_ref(j4, *j1) = 0.; t_ref(j4, j2) = 0.; if (*wantq) { /* Accumulate transformation in the matrix Q. */ dlarfx_("R", n, &c__3, u1, &tau1, &q_ref(1, *j1), ldq, &work[1]); dlarfx_("R", n, &c__3, u2, &tau2, &q_ref(1, j2), ldq, &work[1]); } L40: if (*n2 == 2) { /* Standardize new 2-by-2 block T11 */ dlanv2_(&t_ref(*j1, *j1), &t_ref(*j1, j2), &t_ref(j2, *j1), & t_ref(j2, j2), &wr1, &wi1, &wr2, &wi2, &cs, &sn); i__1 = *n - *j1 - 1; drot_(&i__1, &t_ref(*j1, *j1 + 2), ldt, &t_ref(j2, *j1 + 2), ldt, &cs, &sn); i__1 = *j1 - 1; drot_(&i__1, &t_ref(1, *j1), &c__1, &t_ref(1, j2), &c__1, &cs, & sn); if (*wantq) { drot_(n, &q_ref(1, *j1), &c__1, &q_ref(1, j2), &c__1, &cs, & sn); } } if (*n1 == 2) { /* Standardize new 2-by-2 block T22 */ j3 = *j1 + *n2; j4 = j3 + 1; dlanv2_(&t_ref(j3, j3), &t_ref(j3, j4), &t_ref(j4, j3), &t_ref(j4, j4), &wr1, &wi1, &wr2, &wi2, &cs, &sn); if (j3 + 2 <= *n) { i__1 = *n - j3 - 1; drot_(&i__1, &t_ref(j3, j3 + 2), ldt, &t_ref(j4, j3 + 2), ldt, &cs, &sn); } i__1 = j3 - 1; drot_(&i__1, &t_ref(1, j3), &c__1, &t_ref(1, j4), &c__1, &cs, &sn) ; if (*wantq) { drot_(n, &q_ref(1, j3), &c__1, &q_ref(1, j4), &c__1, &cs, &sn) ; } } } return 0; /* Exit with INFO = 1 if swap was rejected. */ L50: *info = 1; return 0; /* End of DLAEXC */ } /* dlaexc_ */
/* Subroutine */ int dlaexc_(logical *wantq, integer *n, doublereal *t, integer *ldt, doublereal *q, integer *ldq, integer *j1, integer *n1, integer *n2, doublereal *work, integer *info) { /* System generated locals */ integer q_dim1, q_offset, t_dim1, t_offset, i__1; doublereal d__1, d__2, d__3; /* Local variables */ doublereal d__[16] /* was [4][4] */; integer k; doublereal u[3], x[4] /* was [2][2] */; integer j2, j3, j4; doublereal u1[3], u2[3]; integer nd; doublereal cs, t11, t22, t33, sn, wi1, wi2, wr1, wr2, eps, tau, tau1, tau2; integer ierr; doublereal temp; extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *); doublereal scale, dnorm, xnorm; extern /* Subroutine */ int dlanv2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *), dlasy2_( logical *, logical *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *); extern doublereal dlamch_(char *), dlange_(char *, integer *, integer *, doublereal *, integer *, doublereal *); extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *), dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *), dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *), dlarfx_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *); doublereal thresh, smlnum; /* -- LAPACK auxiliary routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* DLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in */ /* an upper quasi-triangular matrix T by an orthogonal similarity */ /* transformation. */ /* T must be in Schur canonical form, that is, block upper triangular */ /* with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block */ /* has its diagonal elemnts equal and its off-diagonal elements of */ /* opposite sign. */ /* Arguments */ /* ========= */ /* WANTQ (input) LOGICAL */ /* = .TRUE. : accumulate the transformation in the matrix Q; */ /* = .FALSE.: do not accumulate the transformation. */ /* N (input) INTEGER */ /* The order of the matrix T. N >= 0. */ /* T (input/output) DOUBLE PRECISION array, dimension (LDT,N) */ /* On entry, the upper quasi-triangular matrix T, in Schur */ /* canonical form. */ /* On exit, the updated matrix T, again in Schur canonical form. */ /* LDT (input) INTEGER */ /* The leading dimension of the array T. LDT >= max(1,N). */ /* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */ /* On entry, if WANTQ is .TRUE., the orthogonal matrix Q. */ /* On exit, if WANTQ is .TRUE., the updated matrix Q. */ /* If WANTQ is .FALSE., Q is not referenced. */ /* LDQ (input) INTEGER */ /* The leading dimension of the array Q. */ /* LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N. */ /* J1 (input) INTEGER */ /* The index of the first row of the first block T11. */ /* N1 (input) INTEGER */ /* The order of the first block T11. N1 = 0, 1 or 2. */ /* N2 (input) INTEGER */ /* The order of the second block T22. N2 = 0, 1 or 2. */ /* WORK (workspace) DOUBLE PRECISION array, dimension (N) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* = 1: the transformed matrix T would be too far from Schur */ /* form; the blocks are not swapped and T and Q are */ /* unchanged. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ t_dim1 = *ldt; t_offset = 1 + t_dim1; t -= t_offset; q_dim1 = *ldq; q_offset = 1 + q_dim1; q -= q_offset; --work; /* Function Body */ *info = 0; /* Quick return if possible */ if (*n == 0 || *n1 == 0 || *n2 == 0) { return 0; } if (*j1 + *n1 > *n) { return 0; } j2 = *j1 + 1; j3 = *j1 + 2; j4 = *j1 + 3; if (*n1 == 1 && *n2 == 1) { /* Swap two 1-by-1 blocks. */ t11 = t[*j1 + *j1 * t_dim1]; t22 = t[j2 + j2 * t_dim1]; /* Determine the transformation to perform the interchange. */ d__1 = t22 - t11; dlartg_(&t[*j1 + j2 * t_dim1], &d__1, &cs, &sn, &temp); /* Apply transformation to the matrix T. */ if (j3 <= *n) { i__1 = *n - *j1 - 1; drot_(&i__1, &t[*j1 + j3 * t_dim1], ldt, &t[j2 + j3 * t_dim1], ldt, &cs, &sn); } i__1 = *j1 - 1; drot_(&i__1, &t[*j1 * t_dim1 + 1], &c__1, &t[j2 * t_dim1 + 1], &c__1, &cs, &sn); t[*j1 + *j1 * t_dim1] = t22; t[j2 + j2 * t_dim1] = t11; if (*wantq) { /* Accumulate transformation in the matrix Q. */ drot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[j2 * q_dim1 + 1], &c__1, &cs, &sn); } } else { /* Swapping involves at least one 2-by-2 block. */ /* Copy the diagonal block of order N1+N2 to the local array D */ /* and compute its norm. */ nd = *n1 + *n2; dlacpy_("Full", &nd, &nd, &t[*j1 + *j1 * t_dim1], ldt, d__, &c__4); dnorm = dlange_("Max", &nd, &nd, d__, &c__4, &work[1]); /* Compute machine-dependent threshold for test for accepting */ /* swap. */ eps = dlamch_("P"); smlnum = dlamch_("S") / eps; /* Computing MAX */ d__1 = eps * 10. * dnorm; thresh = max(d__1,smlnum); /* Solve T11*X - X*T22 = scale*T12 for X. */ dlasy2_(&c_false, &c_false, &c_n1, n1, n2, d__, &c__4, &d__[*n1 + 1 + (*n1 + 1 << 2) - 5], &c__4, &d__[(*n1 + 1 << 2) - 4], &c__4, & scale, x, &c__2, &xnorm, &ierr); /* Swap the adjacent diagonal blocks. */ k = *n1 + *n1 + *n2 - 3; switch (k) { case 1: goto L10; case 2: goto L20; case 3: goto L30; } L10: /* N1 = 1, N2 = 2: generate elementary reflector H so that: */ /* ( scale, X11, X12 ) H = ( 0, 0, * ) */ u[0] = scale; u[1] = x[0]; u[2] = x[2]; dlarfg_(&c__3, &u[2], u, &c__1, &tau); u[2] = 1.; t11 = t[*j1 + *j1 * t_dim1]; /* Perform swap provisionally on diagonal block in D. */ dlarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]); dlarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]); /* Test whether to reject swap. */ /* Computing MAX */ d__2 = abs(d__[2]), d__3 = abs(d__[6]), d__2 = max(d__2,d__3), d__3 = (d__1 = d__[10] - t11, abs(d__1)); if (max(d__2,d__3) > thresh) { goto L50; } /* Accept swap: apply transformation to the entire matrix T. */ i__1 = *n - *j1 + 1; dlarfx_("L", &c__3, &i__1, u, &tau, &t[*j1 + *j1 * t_dim1], ldt, & work[1]); dlarfx_("R", &j2, &c__3, u, &tau, &t[*j1 * t_dim1 + 1], ldt, &work[1]); t[j3 + *j1 * t_dim1] = 0.; t[j3 + j2 * t_dim1] = 0.; t[j3 + j3 * t_dim1] = t11; if (*wantq) { /* Accumulate transformation in the matrix Q. */ dlarfx_("R", n, &c__3, u, &tau, &q[*j1 * q_dim1 + 1], ldq, &work[ 1]); } goto L40; L20: /* N1 = 2, N2 = 1: generate elementary reflector H so that: */ /* H ( -X11 ) = ( * ) */ /* ( -X21 ) = ( 0 ) */ /* ( scale ) = ( 0 ) */ u[0] = -x[0]; u[1] = -x[1]; u[2] = scale; dlarfg_(&c__3, u, &u[1], &c__1, &tau); u[0] = 1.; t33 = t[j3 + j3 * t_dim1]; /* Perform swap provisionally on diagonal block in D. */ dlarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]); dlarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]); /* Test whether to reject swap. */ /* Computing MAX */ d__2 = abs(d__[1]), d__3 = abs(d__[2]), d__2 = max(d__2,d__3), d__3 = (d__1 = d__[0] - t33, abs(d__1)); if (max(d__2,d__3) > thresh) { goto L50; } /* Accept swap: apply transformation to the entire matrix T. */ dlarfx_("R", &j3, &c__3, u, &tau, &t[*j1 * t_dim1 + 1], ldt, &work[1]); i__1 = *n - *j1; dlarfx_("L", &c__3, &i__1, u, &tau, &t[*j1 + j2 * t_dim1], ldt, &work[ 1]); t[*j1 + *j1 * t_dim1] = t33; t[j2 + *j1 * t_dim1] = 0.; t[j3 + *j1 * t_dim1] = 0.; if (*wantq) { /* Accumulate transformation in the matrix Q. */ dlarfx_("R", n, &c__3, u, &tau, &q[*j1 * q_dim1 + 1], ldq, &work[ 1]); } goto L40; L30: /* N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so */ /* that: */ /* H(2) H(1) ( -X11 -X12 ) = ( * * ) */ /* ( -X21 -X22 ) ( 0 * ) */ /* ( scale 0 ) ( 0 0 ) */ /* ( 0 scale ) ( 0 0 ) */ u1[0] = -x[0]; u1[1] = -x[1]; u1[2] = scale; dlarfg_(&c__3, u1, &u1[1], &c__1, &tau1); u1[0] = 1.; temp = -tau1 * (x[2] + u1[1] * x[3]); u2[0] = -temp * u1[1] - x[3]; u2[1] = -temp * u1[2]; u2[2] = scale; dlarfg_(&c__3, u2, &u2[1], &c__1, &tau2); u2[0] = 1.; /* Perform swap provisionally on diagonal block in D. */ dlarfx_("L", &c__3, &c__4, u1, &tau1, d__, &c__4, &work[1]) ; dlarfx_("R", &c__4, &c__3, u1, &tau1, d__, &c__4, &work[1]) ; dlarfx_("L", &c__3, &c__4, u2, &tau2, &d__[1], &c__4, &work[1]); dlarfx_("R", &c__4, &c__3, u2, &tau2, &d__[4], &c__4, &work[1]); /* Test whether to reject swap. */ /* Computing MAX */ d__1 = abs(d__[2]), d__2 = abs(d__[6]), d__1 = max(d__1,d__2), d__2 = abs(d__[3]), d__1 = max(d__1,d__2), d__2 = abs(d__[7]); if (max(d__1,d__2) > thresh) { goto L50; } /* Accept swap: apply transformation to the entire matrix T. */ i__1 = *n - *j1 + 1; dlarfx_("L", &c__3, &i__1, u1, &tau1, &t[*j1 + *j1 * t_dim1], ldt, & work[1]); dlarfx_("R", &j4, &c__3, u1, &tau1, &t[*j1 * t_dim1 + 1], ldt, &work[ 1]); i__1 = *n - *j1 + 1; dlarfx_("L", &c__3, &i__1, u2, &tau2, &t[j2 + *j1 * t_dim1], ldt, & work[1]); dlarfx_("R", &j4, &c__3, u2, &tau2, &t[j2 * t_dim1 + 1], ldt, &work[1] ); t[j3 + *j1 * t_dim1] = 0.; t[j3 + j2 * t_dim1] = 0.; t[j4 + *j1 * t_dim1] = 0.; t[j4 + j2 * t_dim1] = 0.; if (*wantq) { /* Accumulate transformation in the matrix Q. */ dlarfx_("R", n, &c__3, u1, &tau1, &q[*j1 * q_dim1 + 1], ldq, & work[1]); dlarfx_("R", n, &c__3, u2, &tau2, &q[j2 * q_dim1 + 1], ldq, &work[ 1]); } L40: if (*n2 == 2) { /* Standardize new 2-by-2 block T11 */ dlanv2_(&t[*j1 + *j1 * t_dim1], &t[*j1 + j2 * t_dim1], &t[j2 + * j1 * t_dim1], &t[j2 + j2 * t_dim1], &wr1, &wi1, &wr2, & wi2, &cs, &sn); i__1 = *n - *j1 - 1; drot_(&i__1, &t[*j1 + (*j1 + 2) * t_dim1], ldt, &t[j2 + (*j1 + 2) * t_dim1], ldt, &cs, &sn); i__1 = *j1 - 1; drot_(&i__1, &t[*j1 * t_dim1 + 1], &c__1, &t[j2 * t_dim1 + 1], & c__1, &cs, &sn); if (*wantq) { drot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[j2 * q_dim1 + 1], & c__1, &cs, &sn); } } if (*n1 == 2) { /* Standardize new 2-by-2 block T22 */ j3 = *j1 + *n2; j4 = j3 + 1; dlanv2_(&t[j3 + j3 * t_dim1], &t[j3 + j4 * t_dim1], &t[j4 + j3 * t_dim1], &t[j4 + j4 * t_dim1], &wr1, &wi1, &wr2, &wi2, & cs, &sn); if (j3 + 2 <= *n) { i__1 = *n - j3 - 1; drot_(&i__1, &t[j3 + (j3 + 2) * t_dim1], ldt, &t[j4 + (j3 + 2) * t_dim1], ldt, &cs, &sn); } i__1 = j3 - 1; drot_(&i__1, &t[j3 * t_dim1 + 1], &c__1, &t[j4 * t_dim1 + 1], & c__1, &cs, &sn); if (*wantq) { drot_(n, &q[j3 * q_dim1 + 1], &c__1, &q[j4 * q_dim1 + 1], & c__1, &cs, &sn); } } } return 0; /* Exit with INFO = 1 if swap was rejected. */ L50: *info = 1; return 0; /* End of DLAEXC */ } /* dlaexc_ */