/* Subroutine */ int cqlt01_(integer *m, integer *n, complex *a, complex *af, complex *q, complex *l, integer *lda, complex *tau, complex *work, integer *lwork, real *rwork, real *result) { /* System generated locals */ integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1, q_offset, i__1, i__2; /* Builtin functions Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); /* Local variables */ static integer info; extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *), cherk_(char *, char *, integer *, integer *, real *, complex *, integer *, real * , complex *, integer *); static real resid, anorm; static integer minmn; extern doublereal clange_(char *, integer *, integer *, complex *, integer *, real *); extern /* Subroutine */ int cgeqlf_(integer *, integer *, complex *, integer *, complex *, complex *, integer *, integer *); extern doublereal slamch_(char *); extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex *, integer *, complex *, integer *), claset_(char *, integer *, integer *, complex *, complex *, complex *, integer *); extern doublereal clansy_(char *, char *, integer *, complex *, integer *, real *); extern /* Subroutine */ int cungql_(integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, integer *); static real eps; #define l_subscr(a_1,a_2) (a_2)*l_dim1 + a_1 #define l_ref(a_1,a_2) l[l_subscr(a_1,a_2)] #define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1 #define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)] #define af_subscr(a_1,a_2) (a_2)*af_dim1 + a_1 #define af_ref(a_1,a_2) af[af_subscr(a_1,a_2)] /* -- LAPACK test routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= CQLT01 tests CGEQLF, which computes the QL factorization of an m-by-n matrix A, and partially tests CUNGQL which forms the m-by-m orthogonal matrix Q. CQLT01 compares L with Q'*A, and checks that Q is orthogonal. Arguments ========= M (input) INTEGER The number of rows of the matrix A. M >= 0. N (input) INTEGER The number of columns of the matrix A. N >= 0. A (input) COMPLEX array, dimension (LDA,N) The m-by-n matrix A. AF (output) COMPLEX array, dimension (LDA,N) Details of the QL factorization of A, as returned by CGEQLF. See CGEQLF for further details. Q (output) COMPLEX array, dimension (LDA,M) The m-by-m orthogonal matrix Q. L (workspace) COMPLEX array, dimension (LDA,max(M,N)) LDA (input) INTEGER The leading dimension of the arrays A, AF, Q and R. LDA >= max(M,N). TAU (output) COMPLEX array, dimension (min(M,N)) The scalar factors of the elementary reflectors, as returned by CGEQLF. WORK (workspace) COMPLEX array, dimension (LWORK) LWORK (input) INTEGER The dimension of the array WORK. RWORK (workspace) REAL array, dimension (M) RESULT (output) REAL array, dimension (2) The test ratios: RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS ) RESULT(2) = norm( I - Q'*Q ) / ( M * EPS ) ===================================================================== Parameter adjustments */ l_dim1 = *lda; l_offset = 1 + l_dim1 * 1; l -= l_offset; q_dim1 = *lda; q_offset = 1 + q_dim1 * 1; q -= q_offset; af_dim1 = *lda; af_offset = 1 + af_dim1 * 1; af -= af_offset; a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; --tau; --work; --rwork; --result; /* Function Body */ minmn = min(*m,*n); eps = slamch_("Epsilon"); /* Copy the matrix A to the array AF. */ clacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda); /* Factorize the matrix A in the array AF. */ s_copy(srnamc_1.srnamt, "CGEQLF", (ftnlen)6, (ftnlen)6); cgeqlf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info); /* Copy details of Q */ claset_("Full", m, m, &c_b1, &c_b1, &q[q_offset], lda); if (*m >= *n) { if (*n < *m && *n > 0) { i__1 = *m - *n; clacpy_("Full", &i__1, n, &af[af_offset], lda, &q_ref(1, *m - *n + 1), lda); } if (*n > 1) { i__1 = *n - 1; i__2 = *n - 1; clacpy_("Upper", &i__1, &i__2, &af_ref(*m - *n + 1, 2), lda, & q_ref(*m - *n + 1, *m - *n + 2), lda); } } else { if (*m > 1) { i__1 = *m - 1; i__2 = *m - 1; clacpy_("Upper", &i__1, &i__2, &af_ref(1, *n - *m + 2), lda, & q_ref(1, 2), lda); } } /* Generate the m-by-m matrix Q */ s_copy(srnamc_1.srnamt, "CUNGQL", (ftnlen)6, (ftnlen)6); cungql_(m, m, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info); /* Copy L */ claset_("Full", m, n, &c_b12, &c_b12, &l[l_offset], lda); if (*m >= *n) { if (*n > 0) { clacpy_("Lower", n, n, &af_ref(*m - *n + 1, 1), lda, &l_ref(*m - * n + 1, 1), lda); } } else { if (*n > *m && *m > 0) { i__1 = *n - *m; clacpy_("Full", m, &i__1, &af[af_offset], lda, &l[l_offset], lda); } if (*m > 0) { clacpy_("Lower", m, m, &af_ref(1, *n - *m + 1), lda, &l_ref(1, *n - *m + 1), lda); } } /* Compute L - Q'*A */ cgemm_("Conjugate transpose", "No transpose", m, n, m, &c_b19, &q[ q_offset], lda, &a[a_offset], lda, &c_b20, &l[l_offset], lda); /* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) . */ anorm = clange_("1", m, n, &a[a_offset], lda, &rwork[1]); resid = clange_("1", m, n, &l[l_offset], lda, &rwork[1]); if (anorm > 0.f) { result[1] = resid / (real) max(1,*m) / anorm / eps; } else { result[1] = 0.f; } /* Compute I - Q'*Q */ claset_("Full", m, m, &c_b12, &c_b20, &l[l_offset], lda); cherk_("Upper", "Conjugate transpose", m, m, &c_b28, &q[q_offset], lda, & c_b29, &l[l_offset], lda); /* Compute norm( I - Q'*Q ) / ( M * EPS ) . */ resid = clansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]); result[2] = resid / (real) max(1,*m) / eps; return 0; /* End of CQLT01 */ } /* cqlt01_ */
/* Subroutine */ int cdrgev_(integer *nsizes, integer *nn, integer *ntypes, logical *dotype, integer *iseed, real *thresh, integer *nounit, complex *a, integer *lda, complex *b, complex *s, complex *t, complex *q, integer *ldq, complex *z__, complex *qe, integer *ldqe, complex * alpha, complex *beta, complex *alpha1, complex *beta1, complex *work, integer *lwork, real *rwork, real *result, integer *info) { /* Initialized data */ static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2, 2,2,2,3 }; static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3, 2,3,2,1 }; static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1, 1,1,1,1 }; static logical lasign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, TRUE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,FALSE_, TRUE_,FALSE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,FALSE_ }; static logical lbsign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, FALSE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,FALSE_, TRUE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, FALSE_ }; static integer kz1[6] = { 0,1,2,1,3,3 }; static integer kz2[6] = { 0,0,1,2,1,1 }; static integer kadd[6] = { 0,0,0,0,3,2 }; static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4, 4,4,4,0 }; static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8, 8,8,8,8,8,0 }; static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3, 3,3,3,1 }; static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4, 4,4,4,1 }; static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2, 3,3,2,1 }; /* Format strings */ static char fmt_9999[] = "(\002 CDRGEV: \002,a,\002 returned INFO=\002,i" "6,\002.\002,/3x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED=" "(\002,3(i5,\002,\002),i5,\002)\002)"; static char fmt_9998[] = "(\002 CDRGEV: \002,a,\002 Eigenvectors from" " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of " "error=\002,0p,g10.3,\002,\002,3x,\002N=\002,i4,\002, JTYPE=\002," "i3,\002, ISEED=(\002,3(i4,\002,\002),i5,\002)\002)"; static char fmt_9997[] = "(/1x,a3,\002 -- Complex Generalized eigenvalue" " problem \002,\002driver\002)"; static char fmt_9996[] = "(\002 Matrix types (see CDRGEV for details):" " \002)"; static char fmt_9995[] = "(\002 Special Matrices:\002,23x,\002(J'=transp" "osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I" ") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag" "onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D," "I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l" "arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12=" "(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15" "=(D, reversed D)\002)"; static char fmt_9994[] = "(\002 Matrices Rotated by Random \002,a,\002 M" "atrices U, V:\002,/\002 16=Transposed Jordan Blocks " " 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp" "ha&beta \002,\002 20=arithmetic alpha, beta=0," "1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21" "=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002," "/\002 22=(large, small) \002,\00223=(small,large) 24=(smal" "l,small) 25=(large,large)\002,/\002 26=random O(1) matrices" ".\002)"; static char fmt_9993[] = "(/\002 Tests performed: \002,/\002 1 = max " "| ( b A - a B )'*l | / const.,\002,/\002 2 = | |VR(i)| - 1 | / u" "lp,\002,/\002 3 = max | ( b A - a B )*r | / const.\002,/\002 4 =" " | |VL(i)| - 1 | / ulp,\002,/\002 5 = 0 if W same no matter if r" " or l computed,\002,/\002 6 = 0 if l same no matter if l compute" "d,\002,/\002 7 = 0 if r same no matter if r computed,\002,/1x)"; static char fmt_9992[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2" ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002" ",0p,f8.2)"; static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2" ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002" ",1p,e10.3)"; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, qe_dim1, qe_offset, s_dim1, s_offset, t_dim1, t_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7; real r__1, r__2; complex q__1, q__2, q__3; /* Builtin functions */ double r_sign(real *, real *), c_abs(complex *); void r_cnjg(complex *, complex *); integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); /* Local variables */ static integer iadd, ierr, nmax, i__, j, n; static logical badnn; extern /* Subroutine */ int cget52_(logical *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, complex *, complex *, real *, real *), cggev_(char *, char *, integer *, complex *, integer *, complex *, integer *, complex *, complex *, complex *, integer *, complex *, integer *, complex *, integer *, real *, integer *); static real rmagn[4]; static complex ctemp; static integer nmats, jsize, nerrs, jtype, n1; extern /* Subroutine */ int clatm4_(integer *, integer *, integer *, integer *, logical *, real *, real *, real *, integer *, integer * , complex *, integer *), cunm2r_(char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *); static integer jc, nb, in; extern /* Subroutine */ int slabad_(real *, real *); static integer jr; extern /* Subroutine */ int clarfg_(integer *, complex *, complex *, integer *, complex *); extern /* Complex */ VOID clarnd_(complex *, integer *, integer *); extern doublereal slamch_(char *); extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex *, integer *, complex *, integer *), claset_(char *, integer *, integer *, complex *, complex *, complex *, integer *); static real safmin, safmax; static integer ioldsd[4]; extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer *, integer *), xerbla_(char *, integer *); static integer minwrk, maxwrk; static real ulpinv; static integer mtypes, ntestt; static real ulp; /* Fortran I/O blocks */ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___42 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___43 = { 0, 0, 0, fmt_9998, 0 }; static cilist io___44 = { 0, 0, 0, fmt_9998, 0 }; static cilist io___45 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___46 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___47 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___48 = { 0, 0, 0, fmt_9997, 0 }; static cilist io___49 = { 0, 0, 0, fmt_9996, 0 }; static cilist io___50 = { 0, 0, 0, fmt_9995, 0 }; static cilist io___51 = { 0, 0, 0, fmt_9994, 0 }; static cilist io___52 = { 0, 0, 0, fmt_9993, 0 }; static cilist io___53 = { 0, 0, 0, fmt_9992, 0 }; static cilist io___54 = { 0, 0, 0, fmt_9991, 0 }; #define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1 #define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)] #define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1 #define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)] #define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1 #define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)] #define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1 #define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)] #define qe_subscr(a_1,a_2) (a_2)*qe_dim1 + a_1 #define qe_ref(a_1,a_2) qe[qe_subscr(a_1,a_2)] /* -- LAPACK test routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University June 30, 1999 Purpose ======= CDRGEV checks the nonsymmetric generalized eigenvalue problem driver routine CGGEV. CGGEV computes for a pair of n-by-n nonsymmetric matrices (A,B) the generalized eigenvalues and, optionally, the left and right eigenvectors. A generalized eigenvalue for a pair of matrices (A,B) is a scalar w or a ratio alpha/beta = w, such that A - w*B is singular. It is usually represented as the pair (alpha,beta), as there is reasonalbe interpretation for beta=0, and even for both being zero. A right generalized eigenvector corresponding to a generalized eigenvalue w for a pair of matrices (A,B) is a vector r such that (A - wB) * r = 0. A left generalized eigenvector is a vector l such that l**H * (A - wB) = 0, where l**H is the conjugate-transpose of l. When CDRGEV is called, a number of matrix "sizes" ("n's") and a number of matrix "types" are specified. For each size ("n") and each type of matrix, a pair of matrices (A, B) will be generated and used for testing. For each matrix pair, the following tests will be performed and compared with the threshhold THRESH. Results from CGGEV: (1) max over all left eigenvalue/-vector pairs (alpha/beta,l) of | VL**H * (beta A - alpha B) |/( ulp max(|beta A|, |alpha B|) ) where VL**H is the conjugate-transpose of VL. (2) | |VL(i)| - 1 | / ulp and whether largest component real VL(i) denotes the i-th column of VL. (3) max over all left eigenvalue/-vector pairs (alpha/beta,r) of | (beta A - alpha B) * VR | / ( ulp max(|beta A|, |alpha B|) ) (4) | |VR(i)| - 1 | / ulp and whether largest component real VR(i) denotes the i-th column of VR. (5) W(full) = W(partial) W(full) denotes the eigenvalues computed when both l and r are also computed, and W(partial) denotes the eigenvalues computed when only W, only W and r, or only W and l are computed. (6) VL(full) = VL(partial) VL(full) denotes the left eigenvectors computed when both l and r are computed, and VL(partial) denotes the result when only l is computed. (7) VR(full) = VR(partial) VR(full) denotes the right eigenvectors computed when both l and r are also computed, and VR(partial) denotes the result when only l is computed. Test Matrices ---- -------- The sizes of the test matrices are specified by an array NN(1:NSIZES); the value of each element NN(j) specifies one size. The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. Currently, the list of possible types is: (1) ( 0, 0 ) (a pair of zero matrices) (2) ( I, 0 ) (an identity and a zero matrix) (3) ( 0, I ) (an identity and a zero matrix) (4) ( I, I ) (a pair of identity matrices) t t (5) ( J , J ) (a pair of transposed Jordan blocks) t ( I 0 ) (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) ( 0 I ) ( 0 J ) and I is a k x k identity and J a (k+1)x(k+1) Jordan block; k=(N-1)/2 (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal matrix with those diagonal entries.) (8) ( I, D ) (9) ( big*D, small*I ) where "big" is near overflow and small=1/big (10) ( small*D, big*I ) (11) ( big*I, small*D ) (12) ( small*I, big*D ) (13) ( big*D, big*I ) (14) ( small*D, small*I ) (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) t t (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices with random O(1) entries above the diagonal and diagonal entries diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = ( 0, N-3, N-4,..., 1, 0, 0 ) (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) s = machine precision. (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) N-5 (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) where r1,..., r(N-4) are random. (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) diag(T2) = ( 0, 1, ..., 1, 0, 0 ) (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) diag(T2) = ( 0, 1, ..., 1, 0, 0 ) (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) diag(T2) = ( 0, 1, ..., 1, 0, 0 ) (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) diag(T2) = ( 0, 1, ..., 1, 0, 0 ) (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular matrices. Arguments ========= NSIZES (input) INTEGER The number of sizes of matrices to use. If it is zero, CDRGES does nothing. NSIZES >= 0. NN (input) INTEGER array, dimension (NSIZES) An array containing the sizes to be used for the matrices. Zero values will be skipped. NN >= 0. NTYPES (input) INTEGER The number of elements in DOTYPE. If it is zero, CDRGEV does nothing. It must be at least zero. If it is MAXTYP+1 and NSIZES is 1, then an additional type, MAXTYP+1 is defined, which is to use whatever matrix is in A. This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. . DOTYPE (input) LOGICAL array, dimension (NTYPES) If DOTYPE(j) is .TRUE., then for each size in NN a matrix of that size and of type j will be generated. If NTYPES is smaller than the maximum number of types defined (PARAMETER MAXTYP), then types NTYPES+1 through MAXTYP will not be generated. If NTYPES is larger than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) will be ignored. ISEED (input/output) INTEGER array, dimension (4) On entry ISEED specifies the seed of the random number generator. The array elements should be between 0 and 4095; if not they will be reduced mod 4096. Also, ISEED(4) must be odd. The random number generator uses a linear congruential sequence limited to small integers, and so should produce machine independent random numbers. The values of ISEED are changed on exit, and can be used in the next call to CDRGES to continue the same random number sequence. THRESH (input) REAL A test will count as "failed" if the "error", computed as described above, exceeds THRESH. Note that the error is scaled to be O(1), so THRESH should be a reasonably small multiple of 1, e.g., 10 or 100. In particular, it should not depend on the precision (single vs. double) or the size of the matrix. It must be at least zero. NOUNIT (input) INTEGER The FORTRAN unit number for printing out error messages (e.g., if a routine returns IERR not equal to 0.) A (input/workspace) COMPLEX array, dimension(LDA, max(NN)) Used to hold the original A matrix. Used as input only if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and DOTYPE(MAXTYP+1)=.TRUE. LDA (input) INTEGER The leading dimension of A, B, S, and T. It must be at least 1 and at least max( NN ). B (input/workspace) COMPLEX array, dimension(LDA, max(NN)) Used to hold the original B matrix. Used as input only if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and DOTYPE(MAXTYP+1)=.TRUE. S (workspace) COMPLEX array, dimension (LDA, max(NN)) The Schur form matrix computed from A by CGGEV. On exit, S contains the Schur form matrix corresponding to the matrix in A. T (workspace) COMPLEX array, dimension (LDA, max(NN)) The upper triangular matrix computed from B by CGGEV. Q (workspace) COMPLEX array, dimension (LDQ, max(NN)) The (left) eigenvectors matrix computed by CGGEV. LDQ (input) INTEGER The leading dimension of Q and Z. It must be at least 1 and at least max( NN ). Z (workspace) COMPLEX array, dimension( LDQ, max(NN) ) The (right) orthogonal matrix computed by CGGEV. QE (workspace) COMPLEX array, dimension( LDQ, max(NN) ) QE holds the computed right or left eigenvectors. LDQE (input) INTEGER The leading dimension of QE. LDQE >= max(1,max(NN)). ALPHA (workspace) COMPLEX array, dimension (max(NN)) BETA (workspace) COMPLEX array, dimension (max(NN)) The generalized eigenvalues of (A,B) computed by CGGEV. ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th generalized eigenvalue of A and B. ALPHA1 (workspace) COMPLEX array, dimension (max(NN)) BETA1 (workspace) COMPLEX array, dimension (max(NN)) Like ALPHAR, ALPHAI, BETA, these arrays contain the eigenvalues of A and B, but those computed when CGGEV only computes a partial eigendecomposition, i.e. not the eigenvalues and left and right eigenvectors. WORK (workspace) COMPLEX array, dimension (LWORK) LWORK (input) INTEGER The number of entries in WORK. LWORK >= N*(N+1) RWORK (workspace) REAL array, dimension (8*N) Real workspace. RESULT (output) REAL array, dimension (2) The values computed by the tests described above. The values are currently limited to 1/ulp, to avoid overflow. INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value. > 0: A routine returned an error code. INFO is the absolute value of the INFO value returned. ===================================================================== Parameter adjustments */ --nn; --dotype; --iseed; t_dim1 = *lda; t_offset = 1 + t_dim1 * 1; t -= t_offset; s_dim1 = *lda; s_offset = 1 + s_dim1 * 1; s -= s_offset; b_dim1 = *lda; b_offset = 1 + b_dim1 * 1; b -= b_offset; a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; z_dim1 = *ldq; z_offset = 1 + z_dim1 * 1; z__ -= z_offset; q_dim1 = *ldq; q_offset = 1 + q_dim1 * 1; q -= q_offset; qe_dim1 = *ldqe; qe_offset = 1 + qe_dim1 * 1; qe -= qe_offset; --alpha; --beta; --alpha1; --beta1; --work; --rwork; --result; /* Function Body Check for errors */ *info = 0; badnn = FALSE_; nmax = 1; i__1 = *nsizes; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ i__2 = nmax, i__3 = nn[j]; nmax = max(i__2,i__3); if (nn[j] < 0) { badnn = TRUE_; } /* L10: */ } if (*nsizes < 0) { *info = -1; } else if (badnn) { *info = -2; } else if (*ntypes < 0) { *info = -3; } else if (*thresh < 0.f) { *info = -6; } else if (*lda <= 1 || *lda < nmax) { *info = -9; } else if (*ldq <= 1 || *ldq < nmax) { *info = -14; } else if (*ldqe <= 1 || *ldqe < nmax) { *info = -17; } /* Compute workspace (Note: Comments in the code beginning "Workspace:" describe the minimal amount of workspace needed at that point in the code, as well as the preferred amount for good performance. NB refers to the optimal block size for the immediately following subroutine, as returned by ILAENV. */ minwrk = 1; if (*info == 0 && *lwork >= 1) { minwrk = nmax * (nmax + 1); /* Computing MAX */ i__1 = 1, i__2 = ilaenv_(&c__1, "CGEQRF", " ", &nmax, &nmax, &c_n1, & c_n1, (ftnlen)6, (ftnlen)1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&c__1, "CUNMQR", "LC", &nmax, &nmax, &nmax, &c_n1, ( ftnlen)6, (ftnlen)2), i__1 = max(i__1,i__2), i__2 = ilaenv_(& c__1, "CUNGQR", " ", &nmax, &nmax, &nmax, &c_n1, (ftnlen)6, ( ftnlen)1); nb = max(i__1,i__2); /* Computing MAX */ i__1 = nmax << 1, i__2 = nmax * (nb + 1), i__1 = max(i__1,i__2), i__2 = nmax * (nmax + 1); maxwrk = max(i__1,i__2); work[1].r = (real) maxwrk, work[1].i = 0.f; } if (*lwork < minwrk) { *info = -23; } if (*info != 0) { i__1 = -(*info); xerbla_("CDRGEV", &i__1); return 0; } /* Quick return if possible */ if (*nsizes == 0 || *ntypes == 0) { return 0; } ulp = slamch_("Precision"); safmin = slamch_("Safe minimum"); safmin /= ulp; safmax = 1.f / safmin; slabad_(&safmin, &safmax); ulpinv = 1.f / ulp; /* The values RMAGN(2:3) depend on N, see below. */ rmagn[0] = 0.f; rmagn[1] = 1.f; /* Loop over sizes, types */ ntestt = 0; nerrs = 0; nmats = 0; i__1 = *nsizes; for (jsize = 1; jsize <= i__1; ++jsize) { n = nn[jsize]; n1 = max(1,n); rmagn[2] = safmax * ulp / (real) n1; rmagn[3] = safmin * ulpinv * n1; if (*nsizes != 1) { mtypes = min(26,*ntypes); } else { mtypes = min(27,*ntypes); } i__2 = mtypes; for (jtype = 1; jtype <= i__2; ++jtype) { if (! dotype[jtype]) { goto L210; } ++nmats; /* Save ISEED in case of an error. */ for (j = 1; j <= 4; ++j) { ioldsd[j - 1] = iseed[j]; /* L20: */ } /* Generate test matrices A and B Description of control parameters: KCLASS: =1 means w/o rotation, =2 means w/ rotation, =3 means random. KATYPE: the "type" to be passed to CLATM4 for computing A. KAZERO: the pattern of zeros on the diagonal for A: =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of non-zero entries.) KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), =2: large, =3: small. LASIGN: .TRUE. if the diagonal elements of A are to be multiplied by a random magnitude 1 number. KBTYPE, KBZERO, KBMAGN, LBSIGN: the same, but for B. KTRIAN: =0: don't fill in the upper triangle, =1: do. KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. RMAGN: used to implement KAMAGN and KBMAGN. */ if (mtypes > 26) { goto L100; } ierr = 0; if (kclass[jtype - 1] < 3) { /* Generate A (w/o rotation) */ if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) { in = ((n - 1) / 2 << 1) + 1; if (in != n) { claset_("Full", &n, &n, &c_b1, &c_b1, &a[a_offset], lda); } } else { in = n; } clatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1], &kz2[kazero[jtype - 1] - 1], &lasign[jtype - 1], & rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype - 1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[ a_offset], lda); iadd = kadd[kazero[jtype - 1] - 1]; if (iadd > 0 && iadd <= n) { i__3 = a_subscr(iadd, iadd); i__4 = kamagn[jtype - 1]; a[i__3].r = rmagn[i__4], a[i__3].i = 0.f; } /* Generate B (w/o rotation) */ if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) { in = ((n - 1) / 2 << 1) + 1; if (in != n) { claset_("Full", &n, &n, &c_b1, &c_b1, &b[b_offset], lda); } } else { in = n; } clatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1], &kz2[kbzero[jtype - 1] - 1], &lbsign[jtype - 1], & rmagn[kbmagn[jtype - 1]], &c_b28, &rmagn[ktrian[jtype - 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[ b_offset], lda); iadd = kadd[kbzero[jtype - 1] - 1]; if (iadd != 0 && iadd <= n) { i__3 = b_subscr(iadd, iadd); i__4 = kbmagn[jtype - 1]; b[i__3].r = rmagn[i__4], b[i__3].i = 0.f; } if (kclass[jtype - 1] == 2 && n > 0) { /* Include rotations Generate Q, Z as Householder transformations times a diagonal matrix. */ i__3 = n - 1; for (jc = 1; jc <= i__3; ++jc) { i__4 = n; for (jr = jc; jr <= i__4; ++jr) { i__5 = q_subscr(jr, jc); clarnd_(&q__1, &c__3, &iseed[1]); q[i__5].r = q__1.r, q[i__5].i = q__1.i; i__5 = z___subscr(jr, jc); clarnd_(&q__1, &c__3, &iseed[1]); z__[i__5].r = q__1.r, z__[i__5].i = q__1.i; /* L30: */ } i__4 = n + 1 - jc; clarfg_(&i__4, &q_ref(jc, jc), &q_ref(jc + 1, jc), & c__1, &work[jc]); i__4 = (n << 1) + jc; i__5 = q_subscr(jc, jc); r__2 = q[i__5].r; r__1 = r_sign(&c_b28, &r__2); work[i__4].r = r__1, work[i__4].i = 0.f; i__4 = q_subscr(jc, jc); q[i__4].r = 1.f, q[i__4].i = 0.f; i__4 = n + 1 - jc; clarfg_(&i__4, &z___ref(jc, jc), &z___ref(jc + 1, jc), &c__1, &work[n + jc]); i__4 = n * 3 + jc; i__5 = z___subscr(jc, jc); r__2 = z__[i__5].r; r__1 = r_sign(&c_b28, &r__2); work[i__4].r = r__1, work[i__4].i = 0.f; i__4 = z___subscr(jc, jc); z__[i__4].r = 1.f, z__[i__4].i = 0.f; /* L40: */ } clarnd_(&q__1, &c__3, &iseed[1]); ctemp.r = q__1.r, ctemp.i = q__1.i; i__3 = q_subscr(n, n); q[i__3].r = 1.f, q[i__3].i = 0.f; i__3 = n; work[i__3].r = 0.f, work[i__3].i = 0.f; i__3 = n * 3; r__1 = c_abs(&ctemp); q__1.r = ctemp.r / r__1, q__1.i = ctemp.i / r__1; work[i__3].r = q__1.r, work[i__3].i = q__1.i; clarnd_(&q__1, &c__3, &iseed[1]); ctemp.r = q__1.r, ctemp.i = q__1.i; i__3 = z___subscr(n, n); z__[i__3].r = 1.f, z__[i__3].i = 0.f; i__3 = n << 1; work[i__3].r = 0.f, work[i__3].i = 0.f; i__3 = n << 2; r__1 = c_abs(&ctemp); q__1.r = ctemp.r / r__1, q__1.i = ctemp.i / r__1; work[i__3].r = q__1.r, work[i__3].i = q__1.i; /* Apply the diagonal matrices */ i__3 = n; for (jc = 1; jc <= i__3; ++jc) { i__4 = n; for (jr = 1; jr <= i__4; ++jr) { i__5 = a_subscr(jr, jc); i__6 = (n << 1) + jr; r_cnjg(&q__3, &work[n * 3 + jc]); q__2.r = work[i__6].r * q__3.r - work[i__6].i * q__3.i, q__2.i = work[i__6].r * q__3.i + work[i__6].i * q__3.r; i__7 = a_subscr(jr, jc); q__1.r = q__2.r * a[i__7].r - q__2.i * a[i__7].i, q__1.i = q__2.r * a[i__7].i + q__2.i * a[ i__7].r; a[i__5].r = q__1.r, a[i__5].i = q__1.i; i__5 = b_subscr(jr, jc); i__6 = (n << 1) + jr; r_cnjg(&q__3, &work[n * 3 + jc]); q__2.r = work[i__6].r * q__3.r - work[i__6].i * q__3.i, q__2.i = work[i__6].r * q__3.i + work[i__6].i * q__3.r; i__7 = b_subscr(jr, jc); q__1.r = q__2.r * b[i__7].r - q__2.i * b[i__7].i, q__1.i = q__2.r * b[i__7].i + q__2.i * b[ i__7].r; b[i__5].r = q__1.r, b[i__5].i = q__1.i; /* L50: */ } /* L60: */ } i__3 = n - 1; cunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[ 1], &a[a_offset], lda, &work[(n << 1) + 1], &ierr); if (ierr != 0) { goto L90; } i__3 = n - 1; cunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, & work[n + 1], &a[a_offset], lda, &work[(n << 1) + 1], &ierr); if (ierr != 0) { goto L90; } i__3 = n - 1; cunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[ 1], &b[b_offset], lda, &work[(n << 1) + 1], &ierr); if (ierr != 0) { goto L90; } i__3 = n - 1; cunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, & work[n + 1], &b[b_offset], lda, &work[(n << 1) + 1], &ierr); if (ierr != 0) { goto L90; } } } else { /* Random matrices */ i__3 = n; for (jc = 1; jc <= i__3; ++jc) { i__4 = n; for (jr = 1; jr <= i__4; ++jr) { i__5 = a_subscr(jr, jc); i__6 = kamagn[jtype - 1]; clarnd_(&q__2, &c__4, &iseed[1]); q__1.r = rmagn[i__6] * q__2.r, q__1.i = rmagn[i__6] * q__2.i; a[i__5].r = q__1.r, a[i__5].i = q__1.i; i__5 = b_subscr(jr, jc); i__6 = kbmagn[jtype - 1]; clarnd_(&q__2, &c__4, &iseed[1]); q__1.r = rmagn[i__6] * q__2.r, q__1.i = rmagn[i__6] * q__2.i; b[i__5].r = q__1.r, b[i__5].i = q__1.i; /* L70: */ } /* L80: */ } } L90: if (ierr != 0) { io___40.ciunit = *nounit; s_wsfe(&io___40); do_fio(&c__1, "Generator", (ftnlen)9); do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(ierr); return 0; } L100: for (i__ = 1; i__ <= 7; ++i__) { result[i__] = -1.f; /* L110: */ } /* Call CGGEV to compute eigenvalues and eigenvectors. */ clacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda); clacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda); cggev_("V", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &alpha[ 1], &beta[1], &q[q_offset], ldq, &z__[z_offset], ldq, & work[1], lwork, &rwork[1], &ierr); if (ierr != 0 && ierr != n + 1) { result[1] = ulpinv; io___42.ciunit = *nounit; s_wsfe(&io___42); do_fio(&c__1, "CGGEV1", (ftnlen)6); do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(ierr); goto L190; } /* Do the tests (1) and (2) */ cget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &q[ q_offset], ldq, &alpha[1], &beta[1], &work[1], &rwork[1], &result[1]); if (result[2] > *thresh) { io___43.ciunit = *nounit; s_wsfe(&io___43); do_fio(&c__1, "Left", (ftnlen)4); do_fio(&c__1, "CGGEV1", (ftnlen)6); do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); } /* Do the tests (3) and (4) */ cget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &z__[ z_offset], ldq, &alpha[1], &beta[1], &work[1], &rwork[1], &result[3]); if (result[4] > *thresh) { io___44.ciunit = *nounit; s_wsfe(&io___44); do_fio(&c__1, "Right", (ftnlen)5); do_fio(&c__1, "CGGEV1", (ftnlen)6); do_fio(&c__1, (char *)&result[4], (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); } /* Do test (5) */ clacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda); clacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda); cggev_("N", "N", &n, &s[s_offset], lda, &t[t_offset], lda, & alpha1[1], &beta1[1], &q[q_offset], ldq, &z__[z_offset], ldq, &work[1], lwork, &rwork[1], &ierr); if (ierr != 0 && ierr != n + 1) { result[1] = ulpinv; io___45.ciunit = *nounit; s_wsfe(&io___45); do_fio(&c__1, "CGGEV2", (ftnlen)6); do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(ierr); goto L190; } i__3 = n; for (j = 1; j <= i__3; ++j) { i__4 = j; i__5 = j; i__6 = j; i__7 = j; if (alpha[i__4].r != alpha1[i__5].r || alpha[i__4].i != alpha1[i__5].i || (beta[i__6].r != beta1[i__7].r || beta[i__6].i != beta1[i__7].i)) { result[5] = ulpinv; } /* L120: */ } /* Do test (6): Compute eigenvalues and left eigenvectors, and test them */ clacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda); clacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda); cggev_("V", "N", &n, &s[s_offset], lda, &t[t_offset], lda, & alpha1[1], &beta1[1], &qe[qe_offset], ldqe, &z__[z_offset] , ldq, &work[1], lwork, &rwork[1], &ierr); if (ierr != 0 && ierr != n + 1) { result[1] = ulpinv; io___46.ciunit = *nounit; s_wsfe(&io___46); do_fio(&c__1, "CGGEV3", (ftnlen)6); do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(ierr); goto L190; } i__3 = n; for (j = 1; j <= i__3; ++j) { i__4 = j; i__5 = j; i__6 = j; i__7 = j; if (alpha[i__4].r != alpha1[i__5].r || alpha[i__4].i != alpha1[i__5].i || (beta[i__6].r != beta1[i__7].r || beta[i__6].i != beta1[i__7].i)) { result[6] = ulpinv; } /* L130: */ } i__3 = n; for (j = 1; j <= i__3; ++j) { i__4 = n; for (jc = 1; jc <= i__4; ++jc) { i__5 = q_subscr(j, jc); i__6 = qe_subscr(j, jc); if (q[i__5].r != qe[i__6].r || q[i__5].i != qe[i__6].i) { result[6] = ulpinv; } /* L140: */ } /* L150: */ } /* Do test (7): Compute eigenvalues and right eigenvectors, and test them */ clacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda); clacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda); cggev_("N", "V", &n, &s[s_offset], lda, &t[t_offset], lda, & alpha1[1], &beta1[1], &q[q_offset], ldq, &qe[qe_offset], ldqe, &work[1], lwork, &rwork[1], &ierr); if (ierr != 0 && ierr != n + 1) { result[1] = ulpinv; io___47.ciunit = *nounit; s_wsfe(&io___47); do_fio(&c__1, "CGGEV4", (ftnlen)6); do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(ierr); goto L190; } i__3 = n; for (j = 1; j <= i__3; ++j) { i__4 = j; i__5 = j; i__6 = j; i__7 = j; if (alpha[i__4].r != alpha1[i__5].r || alpha[i__4].i != alpha1[i__5].i || (beta[i__6].r != beta1[i__7].r || beta[i__6].i != beta1[i__7].i)) { result[7] = ulpinv; } /* L160: */ } i__3 = n; for (j = 1; j <= i__3; ++j) { i__4 = n; for (jc = 1; jc <= i__4; ++jc) { i__5 = z___subscr(j, jc); i__6 = qe_subscr(j, jc); if (z__[i__5].r != qe[i__6].r || z__[i__5].i != qe[i__6] .i) { result[7] = ulpinv; } /* L170: */ } /* L180: */ } /* End of Loop -- Check for RESULT(j) > THRESH */ L190: ntestt += 7; /* Print out tests which fail. */ for (jr = 1; jr <= 9; ++jr) { if (result[jr] >= *thresh) { /* If this is the first test to fail, print a header to the data file. */ if (nerrs == 0) { io___48.ciunit = *nounit; s_wsfe(&io___48); do_fio(&c__1, "CGV", (ftnlen)3); e_wsfe(); /* Matrix types */ io___49.ciunit = *nounit; s_wsfe(&io___49); e_wsfe(); io___50.ciunit = *nounit; s_wsfe(&io___50); e_wsfe(); io___51.ciunit = *nounit; s_wsfe(&io___51); do_fio(&c__1, "Orthogonal", (ftnlen)10); e_wsfe(); /* Tests performed */ io___52.ciunit = *nounit; s_wsfe(&io___52); e_wsfe(); } ++nerrs; if (result[jr] < 1e4f) { io___53.ciunit = *nounit; s_wsfe(&io___53); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)) ; do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof( integer)); do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof( real)); e_wsfe(); } else { io___54.ciunit = *nounit; s_wsfe(&io___54); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)) ; do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof( integer)); do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof( real)); e_wsfe(); } } /* L200: */ } L210: ; } /* L220: */ } /* Summary */ alasvm_("CGV", nounit, &nerrs, &ntestt, &c__0); work[1].r = (real) maxwrk, work[1].i = 0.f; return 0; /* End of CDRGEV */ } /* cdrgev_ */
/* Subroutine */ int ddrges_(integer *nsizes, integer *nn, integer *ntypes, logical *dotype, integer *iseed, doublereal *thresh, integer *nounit, doublereal *a, integer *lda, doublereal *b, doublereal *s, doublereal *t, doublereal *q, integer *ldq, doublereal *z__, doublereal *alphar, doublereal *alphai, doublereal *beta, doublereal *work, integer * lwork, doublereal *result, logical *bwork, integer *info) { /* Initialized data */ static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2, 2,2,2,3 }; static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3, 2,3,2,1 }; static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1, 1,1,1,1 }; static integer iasign[26] = { 0,0,0,0,0,0,2,0,2,2,0,0,2,2,2,0,2,0,0,0,2,2, 2,2,2,0 }; static integer ibsign[26] = { 0,0,0,0,0,0,0,2,0,0,2,2,0,0,2,0,2,0,0,0,0,0, 0,0,0,0 }; static integer kz1[6] = { 0,1,2,1,3,3 }; static integer kz2[6] = { 0,0,1,2,1,1 }; static integer kadd[6] = { 0,0,0,0,3,2 }; static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4, 4,4,4,0 }; static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8, 8,8,8,8,8,0 }; static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3, 3,3,3,1 }; static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4, 4,4,4,1 }; static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2, 3,3,2,1 }; /* Format strings */ static char fmt_9999[] = "(\002 DDRGES: \002,a,\002 returned INFO=\002,i" "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED=" "(\002,4(i4,\002,\002),i5,\002)\002)"; static char fmt_9998[] = "(\002 DDRGES: DGET53 returned INFO=\002,i1," "\002 for eigenvalue \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JT" "YPE=\002,i6,\002, ISEED=(\002,4(i4,\002,\002),i5,\002)\002)"; static char fmt_9997[] = "(\002 DDRGES: S not in Schur form at eigenvalu" "e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, " "ISEED=(\002,3(i5,\002,\002),i5,\002)\002)"; static char fmt_9996[] = "(/1x,a3,\002 -- Real Generalized Schur form dr" "iver\002)"; static char fmt_9995[] = "(\002 Matrix types (see DDRGES for details):" " \002)"; static char fmt_9994[] = "(\002 Special Matrices:\002,23x,\002(J'=transp" "osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I" ") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag" "onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D," "I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l" "arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12=" "(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15" "=(D, reversed D)\002)"; static char fmt_9993[] = "(\002 Matrices Rotated by Random \002,a,\002 M" "atrices U, V:\002,/\002 16=Transposed Jordan Blocks " " 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp" "ha&beta \002,\002 20=arithmetic alpha, beta=0," "1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21" "=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002," "/\002 22=(large, small) \002,\00223=(small,large) 24=(smal" "l,small) 25=(large,large)\002,/\002 26=random O(1) matrices" ".\002)"; static char fmt_9992[] = "(/\002 Tests performed: (S is Schur, T is tri" "angular, \002,\002Q and Z are \002,a,\002,\002,/19x,\002l and r " "are the appropriate left and right\002,/19x,\002eigenvectors, re" "sp., a is alpha, b is beta, and\002,/19x,a,\002 means \002,a," "\002.)\002,/\002 Without ordering: \002,/\002 1 = | A - Q S " "Z\002,a,\002 | / ( |A| n ulp ) 2 = | B - Q T Z\002,a,\002 |" " / ( |B| n ulp )\002,/\002 3 = | I - QQ\002,a,\002 | / ( n ulp " ") 4 = | I - ZZ\002,a,\002 | / ( n ulp )\002,/\002 5" " = A is in Schur form S\002,/\002 6 = difference between (alpha" ",beta)\002,\002 and diagonals of (S,T)\002,/\002 With ordering:" " \002,/\002 7 = | (A,B) - Q (S,T) Z\002,a,\002 | / ( |(A,B)| n " "ulp ) \002,/\002 8 = | I - QQ\002,a,\002 | / ( n ulp ) " " 9 = | I - ZZ\002,a,\002 | / ( n ulp )\002,/\002 10 = A is in" " Schur form S\002,/\002 11 = difference between (alpha,beta) and" " diagonals\002,\002 of (S,T)\002,/\002 12 = SDIM is the correct " "number of \002,\002selected eigenvalues\002,/)"; static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2" ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002" ",0p,f8.2)"; static char fmt_9990[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2" ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002" ",1p,d10.3)"; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, s_dim1, s_offset, t_dim1, t_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4; doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10; /* Builtin functions */ double d_sign(doublereal *, doublereal *); integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); /* Local variables */ static integer iadd, sdim, ierr, nmax, rsub; static char sort[1]; static doublereal temp1, temp2; static integer i__, j, n; static logical badnn; extern /* Subroutine */ int dget51_(integer *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *), dget53_( doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *), dget54_( integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *), dgges_(char *, char *, char *, L_fp, integer *, doublereal *, integer *, doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, logical *, integer *); static integer iinfo; static doublereal rmagn[4]; static integer nmats, jsize, nerrs, i1, jtype, ntest, n1, isort; extern /* Subroutine */ int dlatm4_(integer *, integer *, integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *), dorm2r_(char *, char *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *), dlabad_(doublereal *, doublereal *); static logical ilabad; static integer jc, nb, in; extern doublereal dlamch_(char *); static integer jr; extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *); extern doublereal dlarnd_(integer *, integer *); extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *); static doublereal safmin; static integer ioldsd[4]; static doublereal safmax; static integer knteig; extern logical dlctes_(doublereal *, doublereal *, doublereal *); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer *, integer *), dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *); static integer minwrk, maxwrk; static doublereal ulpinv; static integer mtypes, ntestt; static doublereal ulp; /* Fortran I/O blocks */ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___46 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___52 = { 0, 0, 0, fmt_9998, 0 }; static cilist io___53 = { 0, 0, 0, fmt_9997, 0 }; static cilist io___55 = { 0, 0, 0, fmt_9996, 0 }; static cilist io___56 = { 0, 0, 0, fmt_9995, 0 }; static cilist io___57 = { 0, 0, 0, fmt_9994, 0 }; static cilist io___58 = { 0, 0, 0, fmt_9993, 0 }; static cilist io___59 = { 0, 0, 0, fmt_9992, 0 }; static cilist io___60 = { 0, 0, 0, fmt_9991, 0 }; static cilist io___61 = { 0, 0, 0, fmt_9990, 0 }; #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] #define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1] #define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1] #define s_ref(a_1,a_2) s[(a_2)*s_dim1 + a_1] #define t_ref(a_1,a_2) t[(a_2)*t_dim1 + a_1] #define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1] /* -- LAPACK test routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University June 30, 1999 Purpose ======= DDRGES checks the nonsymmetric generalized eigenvalue (Schur form) problem driver DGGES. DGGES factors A and B as Q S Z' and Q T Z' , where ' means transpose, T is upper triangular, S is in generalized Schur form (block upper triangular, with 1x1 and 2x2 blocks on the diagonal, the 2x2 blocks corresponding to complex conjugate pairs of generalized eigenvalues), and Q and Z are orthogonal. It also computes the generalized eigenvalues (alpha(j),beta(j)), j=1,...,n, Thus, w(j) = alpha(j)/beta(j) is a root of the characteristic equation det( A - w(j) B ) = 0 Optionally it also reorder the eigenvalues so that a selected cluster of eigenvalues appears in the leading diagonal block of the Schur forms. When DDRGES is called, a number of matrix "sizes" ("N's") and a number of matrix "TYPES" are specified. For each size ("N") and each TYPE of matrix, a pair of matrices (A, B) will be generated and used for testing. For each matrix pair, the following 13 tests will be performed and compared with the threshhold THRESH except the tests (5), (11) and (13). (1) | A - Q S Z' | / ( |A| n ulp ) (no sorting of eigenvalues) (2) | B - Q T Z' | / ( |B| n ulp ) (no sorting of eigenvalues) (3) | I - QQ' | / ( n ulp ) (no sorting of eigenvalues) (4) | I - ZZ' | / ( n ulp ) (no sorting of eigenvalues) (5) if A is in Schur form (i.e. quasi-triangular form) (no sorting of eigenvalues) (6) if eigenvalues = diagonal blocks of the Schur form (S, T), i.e., test the maximum over j of D(j) where: if alpha(j) is real: |alpha(j) - S(j,j)| |beta(j) - T(j,j)| D(j) = ------------------------ + ----------------------- max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) if alpha(j) is complex: | det( s S - w T ) | D(j) = --------------------------------------------------- ulp max( s norm(S), |w| norm(T) )*norm( s S - w T ) and S and T are here the 2 x 2 diagonal blocks of S and T corresponding to the j-th and j+1-th eigenvalues. (no sorting of eigenvalues) (7) | (A,B) - Q (S,T) Z' | / ( | (A,B) | n ulp ) (with sorting of eigenvalues). (8) | I - QQ' | / ( n ulp ) (with sorting of eigenvalues). (9) | I - ZZ' | / ( n ulp ) (with sorting of eigenvalues). (10) if A is in Schur form (i.e. quasi-triangular form) (with sorting of eigenvalues). (11) if eigenvalues = diagonal blocks of the Schur form (S, T), i.e. test the maximum over j of D(j) where: if alpha(j) is real: |alpha(j) - S(j,j)| |beta(j) - T(j,j)| D(j) = ------------------------ + ----------------------- max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) if alpha(j) is complex: | det( s S - w T ) | D(j) = --------------------------------------------------- ulp max( s norm(S), |w| norm(T) )*norm( s S - w T ) and S and T are here the 2 x 2 diagonal blocks of S and T corresponding to the j-th and j+1-th eigenvalues. (with sorting of eigenvalues). (12) if sorting worked and SDIM is the number of eigenvalues which were SELECTed. Test Matrices ============= The sizes of the test matrices are specified by an array NN(1:NSIZES); the value of each element NN(j) specifies one size. The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. Currently, the list of possible types is: (1) ( 0, 0 ) (a pair of zero matrices) (2) ( I, 0 ) (an identity and a zero matrix) (3) ( 0, I ) (an identity and a zero matrix) (4) ( I, I ) (a pair of identity matrices) t t (5) ( J , J ) (a pair of transposed Jordan blocks) t ( I 0 ) (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) ( 0 I ) ( 0 J ) and I is a k x k identity and J a (k+1)x(k+1) Jordan block; k=(N-1)/2 (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal matrix with those diagonal entries.) (8) ( I, D ) (9) ( big*D, small*I ) where "big" is near overflow and small=1/big (10) ( small*D, big*I ) (11) ( big*I, small*D ) (12) ( small*I, big*D ) (13) ( big*D, big*I ) (14) ( small*D, small*I ) (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) t t (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices with random O(1) entries above the diagonal and diagonal entries diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = ( 0, N-3, N-4,..., 1, 0, 0 ) (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) s = machine precision. (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) N-5 (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) where r1,..., r(N-4) are random. (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) diag(T2) = ( 0, 1, ..., 1, 0, 0 ) (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) diag(T2) = ( 0, 1, ..., 1, 0, 0 ) (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) diag(T2) = ( 0, 1, ..., 1, 0, 0 ) (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) diag(T2) = ( 0, 1, ..., 1, 0, 0 ) (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular matrices. Arguments ========= NSIZES (input) INTEGER The number of sizes of matrices to use. If it is zero, DDRGES does nothing. NSIZES >= 0. NN (input) INTEGER array, dimension (NSIZES) An array containing the sizes to be used for the matrices. Zero values will be skipped. NN >= 0. NTYPES (input) INTEGER The number of elements in DOTYPE. If it is zero, DDRGES does nothing. It must be at least zero. If it is MAXTYP+1 and NSIZES is 1, then an additional type, MAXTYP+1 is defined, which is to use whatever matrix is in A on input. This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. . DOTYPE (input) LOGICAL array, dimension (NTYPES) If DOTYPE(j) is .TRUE., then for each size in NN a matrix of that size and of type j will be generated. If NTYPES is smaller than the maximum number of types defined (PARAMETER MAXTYP), then types NTYPES+1 through MAXTYP will not be generated. If NTYPES is larger than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) will be ignored. ISEED (input/output) INTEGER array, dimension (4) On entry ISEED specifies the seed of the random number generator. The array elements should be between 0 and 4095; if not they will be reduced mod 4096. Also, ISEED(4) must be odd. The random number generator uses a linear congruential sequence limited to small integers, and so should produce machine independent random numbers. The values of ISEED are changed on exit, and can be used in the next call to DDRGES to continue the same random number sequence. THRESH (input) DOUBLE PRECISION A test will count as "failed" if the "error", computed as described above, exceeds THRESH. Note that the error is scaled to be O(1), so THRESH should be a reasonably small multiple of 1, e.g., 10 or 100. In particular, it should not depend on the precision (single vs. double) or the size of the matrix. THRESH >= 0. NOUNIT (input) INTEGER The FORTRAN unit number for printing out error messages (e.g., if a routine returns IINFO not equal to 0.) A (input/workspace) DOUBLE PRECISION array, dimension(LDA, max(NN)) Used to hold the original A matrix. Used as input only if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and DOTYPE(MAXTYP+1)=.TRUE. LDA (input) INTEGER The leading dimension of A, B, S, and T. It must be at least 1 and at least max( NN ). B (input/workspace) DOUBLE PRECISION array, dimension(LDA, max(NN)) Used to hold the original B matrix. Used as input only if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and DOTYPE(MAXTYP+1)=.TRUE. S (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN)) The Schur form matrix computed from A by DGGES. On exit, S contains the Schur form matrix corresponding to the matrix in A. T (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN)) The upper triangular matrix computed from B by DGGES. Q (workspace) DOUBLE PRECISION array, dimension (LDQ, max(NN)) The (left) orthogonal matrix computed by DGGES. LDQ (input) INTEGER The leading dimension of Q and Z. It must be at least 1 and at least max( NN ). Z (workspace) DOUBLE PRECISION array, dimension( LDQ, max(NN) ) The (right) orthogonal matrix computed by DGGES. ALPHAR (workspace) DOUBLE PRECISION array, dimension (max(NN)) ALPHAI (workspace) DOUBLE PRECISION array, dimension (max(NN)) BETA (workspace) DOUBLE PRECISION array, dimension (max(NN)) The generalized eigenvalues of (A,B) computed by DGGES. ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th generalized eigenvalue of A and B. WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) LWORK (input) INTEGER The dimension of the array WORK. LWORK >= MAX( 10*(N+1), 3*N*N ), where N is the largest matrix dimension. RESULT (output) DOUBLE PRECISION array, dimension (15) The values computed by the tests described above. The values are currently limited to 1/ulp, to avoid overflow. BWORK (workspace) LOGICAL array, dimension (N) INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value. > 0: A routine returned an error code. INFO is the absolute value of the INFO value returned. ===================================================================== Parameter adjustments */ --nn; --dotype; --iseed; t_dim1 = *lda; t_offset = 1 + t_dim1 * 1; t -= t_offset; s_dim1 = *lda; s_offset = 1 + s_dim1 * 1; s -= s_offset; b_dim1 = *lda; b_offset = 1 + b_dim1 * 1; b -= b_offset; a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; z_dim1 = *ldq; z_offset = 1 + z_dim1 * 1; z__ -= z_offset; q_dim1 = *ldq; q_offset = 1 + q_dim1 * 1; q -= q_offset; --alphar; --alphai; --beta; --work; --result; --bwork; /* Function Body Check for errors */ *info = 0; badnn = FALSE_; nmax = 1; i__1 = *nsizes; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ i__2 = nmax, i__3 = nn[j]; nmax = max(i__2,i__3); if (nn[j] < 0) { badnn = TRUE_; } /* L10: */ } if (*nsizes < 0) { *info = -1; } else if (badnn) { *info = -2; } else if (*ntypes < 0) { *info = -3; } else if (*thresh < 0.) { *info = -6; } else if (*lda <= 1 || *lda < nmax) { *info = -9; } else if (*ldq <= 1 || *ldq < nmax) { *info = -14; } /* Compute workspace (Note: Comments in the code beginning "Workspace:" describe the minimal amount of workspace needed at that point in the code, as well as the preferred amount for good performance. NB refers to the optimal block size for the immediately following subroutine, as returned by ILAENV. */ minwrk = 1; if (*info == 0 && *lwork >= 1) { /* Computing MAX */ i__1 = (nmax + 1) * 10, i__2 = nmax * 3 * nmax; minwrk = max(i__1,i__2); /* Computing MAX */ i__1 = 1, i__2 = ilaenv_(&c__1, "DGEQRF", " ", &nmax, &nmax, &c_n1, & c_n1, (ftnlen)6, (ftnlen)1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&c__1, "DORMQR", "LT", &nmax, &nmax, &nmax, &c_n1, ( ftnlen)6, (ftnlen)2), i__1 = max(i__1,i__2), i__2 = ilaenv_(& c__1, "DORGQR", " ", &nmax, &nmax, &nmax, &c_n1, (ftnlen)6, ( ftnlen)1); nb = max(i__1,i__2); /* Computing MAX */ i__1 = (nmax + 1) * 10, i__2 = (nmax << 1) + nmax * nb, i__1 = max( i__1,i__2), i__2 = nmax * 3 * nmax; maxwrk = max(i__1,i__2); work[1] = (doublereal) maxwrk; } if (*lwork < minwrk) { *info = -20; } if (*info != 0) { i__1 = -(*info); xerbla_("DDRGES", &i__1); return 0; } /* Quick return if possible */ if (*nsizes == 0 || *ntypes == 0) { return 0; } safmin = dlamch_("Safe minimum"); ulp = dlamch_("Epsilon") * dlamch_("Base"); safmin /= ulp; safmax = 1. / safmin; dlabad_(&safmin, &safmax); ulpinv = 1. / ulp; /* The values RMAGN(2:3) depend on N, see below. */ rmagn[0] = 0.; rmagn[1] = 1.; /* Loop over matrix sizes */ ntestt = 0; nerrs = 0; nmats = 0; i__1 = *nsizes; for (jsize = 1; jsize <= i__1; ++jsize) { n = nn[jsize]; n1 = max(1,n); rmagn[2] = safmax * ulp / (doublereal) n1; rmagn[3] = safmin * ulpinv * (doublereal) n1; if (*nsizes != 1) { mtypes = min(26,*ntypes); } else { mtypes = min(27,*ntypes); } /* Loop over matrix types */ i__2 = mtypes; for (jtype = 1; jtype <= i__2; ++jtype) { if (! dotype[jtype]) { goto L180; } ++nmats; ntest = 0; /* Save ISEED in case of an error. */ for (j = 1; j <= 4; ++j) { ioldsd[j - 1] = iseed[j]; /* L20: */ } /* Initialize RESULT */ for (j = 1; j <= 13; ++j) { result[j] = 0.; /* L30: */ } /* Generate test matrices A and B Description of control parameters: KZLASS: =1 means w/o rotation, =2 means w/ rotation, =3 means random. KATYPE: the "type" to be passed to DLATM4 for computing A. KAZERO: the pattern of zeros on the diagonal for A: =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of non-zero entries.) KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), =2: large, =3: small. IASIGN: 1 if the diagonal elements of A are to be multiplied by a random magnitude 1 number, =2 if randomly chosen diagonal blocks are to be rotated to form 2x2 blocks. KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B. KTRIAN: =0: don't fill in the upper triangle, =1: do. KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. RMAGN: used to implement KAMAGN and KBMAGN. */ if (mtypes > 26) { goto L110; } iinfo = 0; if (kclass[jtype - 1] < 3) { /* Generate A (w/o rotation) */ if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) { in = ((n - 1) / 2 << 1) + 1; if (in != n) { dlaset_("Full", &n, &n, &c_b26, &c_b26, &a[a_offset], lda); } } else { in = n; } dlatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1], &kz2[kazero[jtype - 1] - 1], &iasign[jtype - 1], & rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype - 1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[ a_offset], lda); iadd = kadd[kazero[jtype - 1] - 1]; if (iadd > 0 && iadd <= n) { a_ref(iadd, iadd) = 1.; } /* Generate B (w/o rotation) */ if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) { in = ((n - 1) / 2 << 1) + 1; if (in != n) { dlaset_("Full", &n, &n, &c_b26, &c_b26, &b[b_offset], lda); } } else { in = n; } dlatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1], &kz2[kbzero[jtype - 1] - 1], &ibsign[jtype - 1], & rmagn[kbmagn[jtype - 1]], &c_b32, &rmagn[ktrian[jtype - 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[ b_offset], lda); iadd = kadd[kbzero[jtype - 1] - 1]; if (iadd != 0 && iadd <= n) { b_ref(iadd, iadd) = 1.; } if (kclass[jtype - 1] == 2 && n > 0) { /* Include rotations Generate Q, Z as Householder transformations times a diagonal matrix. */ i__3 = n - 1; for (jc = 1; jc <= i__3; ++jc) { i__4 = n; for (jr = jc; jr <= i__4; ++jr) { q_ref(jr, jc) = dlarnd_(&c__3, &iseed[1]); z___ref(jr, jc) = dlarnd_(&c__3, &iseed[1]); /* L40: */ } i__4 = n + 1 - jc; dlarfg_(&i__4, &q_ref(jc, jc), &q_ref(jc + 1, jc), & c__1, &work[jc]); work[(n << 1) + jc] = d_sign(&c_b32, &q_ref(jc, jc)); q_ref(jc, jc) = 1.; i__4 = n + 1 - jc; dlarfg_(&i__4, &z___ref(jc, jc), &z___ref(jc + 1, jc), &c__1, &work[n + jc]); work[n * 3 + jc] = d_sign(&c_b32, &z___ref(jc, jc)); z___ref(jc, jc) = 1.; /* L50: */ } q_ref(n, n) = 1.; work[n] = 0.; d__1 = dlarnd_(&c__2, &iseed[1]); work[n * 3] = d_sign(&c_b32, &d__1); z___ref(n, n) = 1.; work[n * 2] = 0.; d__1 = dlarnd_(&c__2, &iseed[1]); work[n * 4] = d_sign(&c_b32, &d__1); /* Apply the diagonal matrices */ i__3 = n; for (jc = 1; jc <= i__3; ++jc) { i__4 = n; for (jr = 1; jr <= i__4; ++jr) { a_ref(jr, jc) = work[(n << 1) + jr] * work[n * 3 + jc] * a_ref(jr, jc); b_ref(jr, jc) = work[(n << 1) + jr] * work[n * 3 + jc] * b_ref(jr, jc); /* L60: */ } /* L70: */ } i__3 = n - 1; dorm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[ 1], &a[a_offset], lda, &work[(n << 1) + 1], & iinfo); if (iinfo != 0) { goto L100; } i__3 = n - 1; dorm2r_("R", "T", &n, &n, &i__3, &z__[z_offset], ldq, & work[n + 1], &a[a_offset], lda, &work[(n << 1) + 1], &iinfo); if (iinfo != 0) { goto L100; } i__3 = n - 1; dorm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[ 1], &b[b_offset], lda, &work[(n << 1) + 1], & iinfo); if (iinfo != 0) { goto L100; } i__3 = n - 1; dorm2r_("R", "T", &n, &n, &i__3, &z__[z_offset], ldq, & work[n + 1], &b[b_offset], lda, &work[(n << 1) + 1], &iinfo); if (iinfo != 0) { goto L100; } } } else { /* Random matrices */ i__3 = n; for (jc = 1; jc <= i__3; ++jc) { i__4 = n; for (jr = 1; jr <= i__4; ++jr) { a_ref(jr, jc) = rmagn[kamagn[jtype - 1]] * dlarnd_(& c__2, &iseed[1]); b_ref(jr, jc) = rmagn[kbmagn[jtype - 1]] * dlarnd_(& c__2, &iseed[1]); /* L80: */ } /* L90: */ } } L100: if (iinfo != 0) { io___40.ciunit = *nounit; s_wsfe(&io___40); do_fio(&c__1, "Generator", (ftnlen)9); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); return 0; } L110: for (i__ = 1; i__ <= 13; ++i__) { result[i__] = -1.; /* L120: */ } /* Test with and without sorting of eigenvalues */ for (isort = 0; isort <= 1; ++isort) { if (isort == 0) { *(unsigned char *)sort = 'N'; rsub = 0; } else { *(unsigned char *)sort = 'S'; rsub = 5; } /* Call DGGES to compute H, T, Q, Z, alpha, and beta. */ dlacpy_("Full", &n, &n, &a[a_offset], lda, &s[s_offset], lda); dlacpy_("Full", &n, &n, &b[b_offset], lda, &t[t_offset], lda); ntest = rsub + 1 + isort; result[rsub + 1 + isort] = ulpinv; dgges_("V", "V", sort, (L_fp)dlctes_, &n, &s[s_offset], lda, & t[t_offset], lda, &sdim, &alphar[1], &alphai[1], & beta[1], &q[q_offset], ldq, &z__[z_offset], ldq, & work[1], lwork, &bwork[1], &iinfo); if (iinfo != 0 && iinfo != n + 2) { result[rsub + 1 + isort] = ulpinv; io___46.ciunit = *nounit; s_wsfe(&io___46); do_fio(&c__1, "DGGES", (ftnlen)5); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)) ; e_wsfe(); *info = abs(iinfo); goto L160; } ntest = rsub + 4; /* Do tests 1--4 (or tests 7--9 when reordering ) */ if (isort == 0) { dget51_(&c__1, &n, &a[a_offset], lda, &s[s_offset], lda, & q[q_offset], ldq, &z__[z_offset], ldq, &work[1], & result[1]); dget51_(&c__1, &n, &b[b_offset], lda, &t[t_offset], lda, & q[q_offset], ldq, &z__[z_offset], ldq, &work[1], & result[2]); } else { dget54_(&n, &a[a_offset], lda, &b[b_offset], lda, &s[ s_offset], lda, &t[t_offset], lda, &q[q_offset], ldq, &z__[z_offset], ldq, &work[1], &result[7]); } dget51_(&c__3, &n, &a[a_offset], lda, &t[t_offset], lda, &q[ q_offset], ldq, &q[q_offset], ldq, &work[1], &result[ rsub + 3]); dget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &z__[ z_offset], ldq, &z__[z_offset], ldq, &work[1], & result[rsub + 4]); /* Do test 5 and 6 (or Tests 10 and 11 when reordering): check Schur form of A and compare eigenvalues with diagonals. */ ntest = rsub + 6; temp1 = 0.; i__3 = n; for (j = 1; j <= i__3; ++j) { ilabad = FALSE_; if (alphai[j] == 0.) { /* Computing MAX */ d__7 = safmin, d__8 = (d__2 = alphar[j], abs(d__2)), d__7 = max(d__7,d__8), d__8 = (d__3 = s_ref(j, j), abs(d__3)); /* Computing MAX */ d__9 = safmin, d__10 = (d__5 = beta[j], abs(d__5)), d__9 = max(d__9,d__10), d__10 = (d__6 = t_ref( j, j), abs(d__6)); temp2 = ((d__1 = alphar[j] - s_ref(j, j), abs(d__1)) / max(d__7,d__8) + (d__4 = beta[j] - t_ref(j, j), abs(d__4)) / max(d__9,d__10)) / ulp; if (j < n) { if (s_ref(j + 1, j) != 0.) { ilabad = TRUE_; result[rsub + 5] = ulpinv; } } if (j > 1) { if (s_ref(j, j - 1) != 0.) { ilabad = TRUE_; result[rsub + 5] = ulpinv; } } } else { if (alphai[j] > 0.) { i1 = j; } else { i1 = j - 1; } if (i1 <= 0 || i1 >= n) { ilabad = TRUE_; } else if (i1 < n - 1) { if (s_ref(i1 + 2, i1 + 1) != 0.) { ilabad = TRUE_; result[rsub + 5] = ulpinv; } } else if (i1 > 1) { if (s_ref(i1, i1 - 1) != 0.) { ilabad = TRUE_; result[rsub + 5] = ulpinv; } } if (! ilabad) { dget53_(&s_ref(i1, i1), lda, &t_ref(i1, i1), lda, &beta[j], &alphar[j], &alphai[j], &temp2, &ierr); if (ierr >= 3) { io___52.ciunit = *nounit; s_wsfe(&io___52); do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof( integer)); do_fio(&c__1, (char *)&j, (ftnlen)sizeof( integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof( integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof( integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen) sizeof(integer)); e_wsfe(); *info = abs(ierr); } } else { temp2 = ulpinv; } } temp1 = max(temp1,temp2); if (ilabad) { io___53.ciunit = *nounit; s_wsfe(&io___53); do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)) ; do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof( integer)); e_wsfe(); } /* L130: */ } result[rsub + 6] = temp1; if (isort >= 1) { /* Do test 12 */ ntest = 12; result[12] = 0.; knteig = 0; i__3 = n; for (i__ = 1; i__ <= i__3; ++i__) { d__1 = -alphai[i__]; if (dlctes_(&alphar[i__], &alphai[i__], &beta[i__]) || dlctes_(&alphar[i__], &d__1, &beta[i__])) { ++knteig; } if (i__ < n) { d__1 = -alphai[i__ + 1]; d__2 = -alphai[i__]; if ((dlctes_(&alphar[i__ + 1], &alphai[i__ + 1], & beta[i__ + 1]) || dlctes_(&alphar[i__ + 1] , &d__1, &beta[i__ + 1])) && ! (dlctes_(& alphar[i__], &alphai[i__], &beta[i__]) || dlctes_(&alphar[i__], &d__2, &beta[i__])) && iinfo != n + 2) { result[12] = ulpinv; } } /* L140: */ } if (sdim != knteig) { result[12] = ulpinv; } } /* L150: */ } /* End of Loop -- Check for RESULT(j) > THRESH */ L160: ntestt += ntest; /* Print out tests which fail. */ i__3 = ntest; for (jr = 1; jr <= i__3; ++jr) { if (result[jr] >= *thresh) { /* If this is the first test to fail, print a header to the data file. */ if (nerrs == 0) { io___55.ciunit = *nounit; s_wsfe(&io___55); do_fio(&c__1, "DGS", (ftnlen)3); e_wsfe(); /* Matrix types */ io___56.ciunit = *nounit; s_wsfe(&io___56); e_wsfe(); io___57.ciunit = *nounit; s_wsfe(&io___57); e_wsfe(); io___58.ciunit = *nounit; s_wsfe(&io___58); do_fio(&c__1, "Orthogonal", (ftnlen)10); e_wsfe(); /* Tests performed */ io___59.ciunit = *nounit; s_wsfe(&io___59); do_fio(&c__1, "orthogonal", (ftnlen)10); do_fio(&c__1, "'", (ftnlen)1); do_fio(&c__1, "transpose", (ftnlen)9); for (j = 1; j <= 8; ++j) { do_fio(&c__1, "'", (ftnlen)1); } e_wsfe(); } ++nerrs; if (result[jr] < 1e4) { io___60.ciunit = *nounit; s_wsfe(&io___60); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)) ; do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof( integer)); do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof( doublereal)); e_wsfe(); } else { io___61.ciunit = *nounit; s_wsfe(&io___61); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)) ; do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof( integer)); do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof( doublereal)); e_wsfe(); } } /* L170: */ } L180: ; } /* L190: */ } /* Summary */ alasvm_("DGS", nounit, &nerrs, &ntestt, &c__0); work[1] = (doublereal) maxwrk; return 0; /* End of DDRGES */ } /* ddrges_ */
/* Subroutine */ int sgqrts_(integer *n, integer *m, integer *p, real *a, real *af, real *q, real *r__, integer *lda, real *taua, real *b, real *bf, real *z__, real *t, real *bwk, integer *ldb, real *taub, real * work, integer *lwork, real *rwork, real *result) { /* System generated locals */ integer a_dim1, a_offset, af_dim1, af_offset, r_dim1, r_offset, q_dim1, q_offset, b_dim1, b_offset, bf_dim1, bf_offset, t_dim1, t_offset, z_dim1, z_offset, bwk_dim1, bwk_offset, i__1, i__2; real r__1; /* Local variables */ static integer info; static real unfl, resid; extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *); static real anorm, bnorm; extern /* Subroutine */ int ssyrk_(char *, char *, integer *, integer *, real *, real *, integer *, real *, real *, integer *); extern doublereal slamch_(char *), slange_(char *, integer *, integer *, real *, integer *, real *); extern /* Subroutine */ int sggqrf_(integer *, integer *, integer *, real *, integer *, real *, real *, integer *, real *, real *, integer * , integer *), slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *), slaset_(char *, integer *, integer *, real *, real *, real *, integer *); extern doublereal slansy_(char *, char *, integer *, real *, integer *, real *); extern /* Subroutine */ int sorgqr_(integer *, integer *, integer *, real *, integer *, real *, real *, integer *, integer *), sorgrq_( integer *, integer *, integer *, real *, integer *, real *, real * , integer *, integer *); static real ulp; #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 z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1] #define af_ref(a_1,a_2) af[(a_2)*af_dim1 + a_1] #define bf_ref(a_1,a_2) bf[(a_2)*bf_dim1 + a_1] /* -- LAPACK test routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= SGQRTS tests SGGQRF, which computes the GQR factorization of an N-by-M matrix A and a N-by-P matrix B: A = Q*R and B = Q*T*Z. Arguments ========= N (input) INTEGER The number of rows of the matrices A and B. N >= 0. M (input) INTEGER The number of columns of the matrix A. M >= 0. P (input) INTEGER The number of columns of the matrix B. P >= 0. A (input) REAL array, dimension (LDA,M) The N-by-M matrix A. AF (output) REAL array, dimension (LDA,N) Details of the GQR factorization of A and B, as returned by SGGQRF, see SGGQRF for further details. Q (output) REAL array, dimension (LDA,N) The M-by-M orthogonal matrix Q. R (workspace) REAL array, dimension (LDA,MAX(M,N)) LDA (input) INTEGER The leading dimension of the arrays A, AF, R and Q. LDA >= max(M,N). TAUA (output) REAL array, dimension (min(M,N)) The scalar factors of the elementary reflectors, as returned by SGGQRF. B (input) REAL array, dimension (LDB,P) On entry, the N-by-P matrix A. BF (output) REAL array, dimension (LDB,N) Details of the GQR factorization of A and B, as returned by SGGQRF, see SGGQRF for further details. Z (output) REAL array, dimension (LDB,P) The P-by-P orthogonal matrix Z. T (workspace) REAL array, dimension (LDB,max(P,N)) BWK (workspace) REAL array, dimension (LDB,N) LDB (input) INTEGER The leading dimension of the arrays B, BF, Z and T. LDB >= max(P,N). TAUB (output) REAL array, dimension (min(P,N)) The scalar factors of the elementary reflectors, as returned by SGGRQF. WORK (workspace) REAL array, dimension (LWORK) LWORK (input) INTEGER The dimension of the array WORK, LWORK >= max(N,M,P)**2. RWORK (workspace) REAL array, dimension (max(N,M,P)) RESULT (output) REAL array, dimension (4) The test ratios: RESULT(1) = norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP) RESULT(2) = norm( T*Z - Q'*B ) / (MAX(P,N)*norm(B)*ULP) RESULT(3) = norm( I - Q'*Q ) / ( M*ULP ) RESULT(4) = norm( I - Z'*Z ) / ( P*ULP ) ===================================================================== Parameter adjustments */ r_dim1 = *lda; r_offset = 1 + r_dim1 * 1; r__ -= r_offset; q_dim1 = *lda; q_offset = 1 + q_dim1 * 1; q -= q_offset; af_dim1 = *lda; af_offset = 1 + af_dim1 * 1; af -= af_offset; a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; --taua; bwk_dim1 = *ldb; bwk_offset = 1 + bwk_dim1 * 1; bwk -= bwk_offset; t_dim1 = *ldb; t_offset = 1 + t_dim1 * 1; t -= t_offset; z_dim1 = *ldb; z_offset = 1 + z_dim1 * 1; z__ -= z_offset; bf_dim1 = *ldb; bf_offset = 1 + bf_dim1 * 1; bf -= bf_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; --taub; --work; --rwork; --result; /* Function Body */ ulp = slamch_("Precision"); unfl = slamch_("Safe minimum"); /* Copy the matrix A to the array AF. */ slacpy_("Full", n, m, &a[a_offset], lda, &af[af_offset], lda); slacpy_("Full", n, p, &b[b_offset], ldb, &bf[bf_offset], ldb); /* Computing MAX */ r__1 = slange_("1", n, m, &a[a_offset], lda, &rwork[1]); anorm = dmax(r__1,unfl); /* Computing MAX */ r__1 = slange_("1", n, p, &b[b_offset], ldb, &rwork[1]); bnorm = dmax(r__1,unfl); /* Factorize the matrices A and B in the arrays AF and BF. */ sggqrf_(n, m, p, &af[af_offset], lda, &taua[1], &bf[bf_offset], ldb, & taub[1], &work[1], lwork, &info); /* Generate the N-by-N matrix Q */ slaset_("Full", n, n, &c_b9, &c_b9, &q[q_offset], lda); i__1 = *n - 1; slacpy_("Lower", &i__1, m, &af_ref(2, 1), lda, &q_ref(2, 1), lda); i__1 = min(*n,*m); sorgqr_(n, n, &i__1, &q[q_offset], lda, &taua[1], &work[1], lwork, &info); /* Generate the P-by-P matrix Z */ slaset_("Full", p, p, &c_b9, &c_b9, &z__[z_offset], ldb); if (*n <= *p) { if (*n > 0 && *n < *p) { i__1 = *p - *n; slacpy_("Full", n, &i__1, &bf[bf_offset], ldb, &z___ref(*p - *n + 1, 1), ldb); } if (*n > 1) { i__1 = *n - 1; i__2 = *n - 1; slacpy_("Lower", &i__1, &i__2, &bf_ref(2, *p - *n + 1), ldb, & z___ref(*p - *n + 2, *p - *n + 1), ldb); } } else { if (*p > 1) { i__1 = *p - 1; i__2 = *p - 1; slacpy_("Lower", &i__1, &i__2, &bf_ref(*n - *p + 2, 1), ldb, & z___ref(2, 1), ldb); } } i__1 = min(*n,*p); sorgrq_(p, p, &i__1, &z__[z_offset], ldb, &taub[1], &work[1], lwork, & info); /* Copy R */ slaset_("Full", n, m, &c_b19, &c_b19, &r__[r_offset], lda); slacpy_("Upper", n, m, &af[af_offset], lda, &r__[r_offset], lda); /* Copy T */ slaset_("Full", n, p, &c_b19, &c_b19, &t[t_offset], ldb); if (*n <= *p) { slacpy_("Upper", n, n, &bf_ref(1, *p - *n + 1), ldb, &t_ref(1, *p - * n + 1), ldb); } else { i__1 = *n - *p; slacpy_("Full", &i__1, p, &bf[bf_offset], ldb, &t[t_offset], ldb); slacpy_("Upper", p, p, &bf_ref(*n - *p + 1, 1), ldb, &t_ref(*n - *p + 1, 1), ldb); } /* Compute R - Q'*A */ sgemm_("Transpose", "No transpose", n, m, n, &c_b30, &q[q_offset], lda, & a[a_offset], lda, &c_b31, &r__[r_offset], lda); /* Compute norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP ) . */ resid = slange_("1", n, m, &r__[r_offset], lda, &rwork[1]); if (anorm > 0.f) { /* Computing MAX */ i__1 = max(1,*m); result[1] = resid / (real) max(i__1,*n) / anorm / ulp; } else { result[1] = 0.f; } /* Compute T*Z - Q'*B */ sgemm_("No Transpose", "No transpose", n, p, p, &c_b31, &t[t_offset], ldb, &z__[z_offset], ldb, &c_b19, &bwk[bwk_offset], ldb); sgemm_("Transpose", "No transpose", n, p, n, &c_b30, &q[q_offset], lda, & b[b_offset], ldb, &c_b31, &bwk[bwk_offset], ldb); /* Compute norm( T*Z - Q'*B ) / ( MAX(P,N)*norm(A)*ULP ) . */ resid = slange_("1", n, p, &bwk[bwk_offset], ldb, &rwork[1]); if (bnorm > 0.f) { /* Computing MAX */ i__1 = max(1,*p); result[2] = resid / (real) max(i__1,*n) / bnorm / ulp; } else { result[2] = 0.f; } /* Compute I - Q'*Q */ slaset_("Full", n, n, &c_b19, &c_b31, &r__[r_offset], lda); ssyrk_("Upper", "Transpose", n, n, &c_b30, &q[q_offset], lda, &c_b31, & r__[r_offset], lda); /* Compute norm( I - Q'*Q ) / ( N * ULP ) . */ resid = slansy_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]); result[3] = resid / (real) max(1,*n) / ulp; /* Compute I - Z'*Z */ slaset_("Full", p, p, &c_b19, &c_b31, &t[t_offset], ldb); ssyrk_("Upper", "Transpose", p, p, &c_b30, &z__[z_offset], ldb, &c_b31, & t[t_offset], ldb); /* Compute norm( I - Z'*Z ) / ( P*ULP ) . */ resid = slansy_("1", "Upper", p, &t[t_offset], ldb, &rwork[1]); result[4] = resid / (real) max(1,*p) / ulp; return 0; /* End of SGQRTS */ } /* sgqrts_ */
/* 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 slqt02_(integer *m, integer *n, integer *k, real *a, real *af, real *q, real *l, integer *lda, real *tau, real *work, integer *lwork, real *rwork, real *result) { /* System generated locals */ integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1, q_offset, i__1; /* Builtin functions Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); /* Local variables */ static integer info; static real resid; extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *); static real anorm; extern /* Subroutine */ int ssyrk_(char *, char *, integer *, integer *, real *, real *, integer *, real *, real *, integer *); extern doublereal slamch_(char *), slange_(char *, integer *, integer *, real *, integer *, real *); extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *), slaset_(char *, integer *, integer *, real *, real *, real *, integer *), sorglq_( integer *, integer *, integer *, real *, integer *, real *, real * , integer *, integer *); extern doublereal slansy_(char *, char *, integer *, real *, integer *, real *); static real eps; #define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1] #define af_ref(a_1,a_2) af[(a_2)*af_dim1 + a_1] /* -- LAPACK test routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= SLQT02 tests SORGLQ, which generates an m-by-n matrix Q with orthonornmal rows that is defined as the product of k elementary reflectors. Given the LQ factorization of an m-by-n matrix A, SLQT02 generates the orthogonal matrix Q defined by the factorization of the first k rows of A; it compares L(1:k,1:m) with A(1:k,1:n)*Q(1:m,1:n)', and checks that the rows of Q are orthonormal. Arguments ========= M (input) INTEGER The number of rows of the matrix Q to be generated. M >= 0. N (input) INTEGER The number of columns of the matrix Q to be generated. N >= M >= 0. K (input) INTEGER The number of elementary reflectors whose product defines the matrix Q. M >= K >= 0. A (input) REAL array, dimension (LDA,N) The m-by-n matrix A which was factorized by SLQT01. AF (input) REAL array, dimension (LDA,N) Details of the LQ factorization of A, as returned by SGELQF. See SGELQF for further details. Q (workspace) REAL array, dimension (LDA,N) L (workspace) REAL array, dimension (LDA,M) LDA (input) INTEGER The leading dimension of the arrays A, AF, Q and L. LDA >= N. TAU (input) REAL array, dimension (M) The scalar factors of the elementary reflectors corresponding to the LQ factorization in AF. WORK (workspace) REAL array, dimension (LWORK) LWORK (input) INTEGER The dimension of the array WORK. RWORK (workspace) REAL array, dimension (M) RESULT (output) REAL array, dimension (2) The test ratios: RESULT(1) = norm( L - A*Q' ) / ( N * norm(A) * EPS ) RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) ===================================================================== Parameter adjustments */ l_dim1 = *lda; l_offset = 1 + l_dim1 * 1; l -= l_offset; q_dim1 = *lda; q_offset = 1 + q_dim1 * 1; q -= q_offset; af_dim1 = *lda; af_offset = 1 + af_dim1 * 1; af -= af_offset; a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; --tau; --work; --rwork; --result; /* Function Body */ eps = slamch_("Epsilon"); /* Copy the first k rows of the factorization to the array Q */ slaset_("Full", m, n, &c_b4, &c_b4, &q[q_offset], lda); i__1 = *n - 1; slacpy_("Upper", k, &i__1, &af_ref(1, 2), lda, &q_ref(1, 2), lda); /* Generate the first n columns of the matrix Q */ s_copy(srnamc_1.srnamt, "SORGLQ", (ftnlen)6, (ftnlen)6); sorglq_(m, n, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info); /* Copy L(1:k,1:m) */ slaset_("Full", k, m, &c_b9, &c_b9, &l[l_offset], lda); slacpy_("Lower", k, m, &af[af_offset], lda, &l[l_offset], lda); /* Compute L(1:k,1:m) - A(1:k,1:n) * Q(1:m,1:n)' */ sgemm_("No transpose", "Transpose", k, m, n, &c_b14, &a[a_offset], lda, & q[q_offset], lda, &c_b15, &l[l_offset], lda); /* Compute norm( L - A*Q' ) / ( N * norm(A) * EPS ) . */ anorm = slange_("1", k, n, &a[a_offset], lda, &rwork[1]); resid = slange_("1", k, m, &l[l_offset], lda, &rwork[1]); if (anorm > 0.f) { result[1] = resid / (real) max(1,*n) / anorm / eps; } else { result[1] = 0.f; } /* Compute I - Q*Q' */ slaset_("Full", m, m, &c_b9, &c_b15, &l[l_offset], lda); ssyrk_("Upper", "No transpose", m, n, &c_b14, &q[q_offset], lda, &c_b15, & l[l_offset], lda); /* Compute norm( I - Q*Q' ) / ( N * EPS ) . */ resid = slansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]); result[2] = resid / (real) max(1,*n) / eps; return 0; /* End of SLQT02 */ } /* slqt02_ */
/* Subroutine */ int cgrqts_(integer *m, integer *p, integer *n, complex *a, complex *af, complex *q, complex *r__, integer *lda, complex *taua, complex *b, complex *bf, complex *z__, complex *t, complex *bwk, integer *ldb, complex *taub, complex *work, integer *lwork, real * rwork, real *result) { /* System generated locals */ integer a_dim1, a_offset, af_dim1, af_offset, r_dim1, r_offset, q_dim1, q_offset, b_dim1, b_offset, bf_dim1, bf_offset, t_dim1, t_offset, z_dim1, z_offset, bwk_dim1, bwk_offset, i__1, i__2; real r__1; complex q__1; /* Local variables */ static integer info; static real unfl; extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *), cherk_(char *, char *, integer *, integer *, real *, complex *, integer *, real * , complex *, integer *); static real resid, anorm, bnorm; extern doublereal clange_(char *, integer *, integer *, complex *, integer *, real *), clanhe_(char *, char *, integer *, complex *, integer *, real *), slamch_(char *); extern /* Subroutine */ int cggrqf_(integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, complex *, integer *, integer *), clacpy_(char *, integer *, integer *, complex *, integer *, complex *, integer *), claset_(char *, integer *, integer *, complex *, complex *, complex *, integer *), cungqr_(integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, integer *), cungrq_(integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, integer *); static real ulp; #define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1 #define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)] #define r___subscr(a_1,a_2) (a_2)*r_dim1 + a_1 #define r___ref(a_1,a_2) r__[r___subscr(a_1,a_2)] #define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1 #define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)] #define af_subscr(a_1,a_2) (a_2)*af_dim1 + a_1 #define af_ref(a_1,a_2) af[af_subscr(a_1,a_2)] #define bf_subscr(a_1,a_2) (a_2)*bf_dim1 + a_1 #define bf_ref(a_1,a_2) bf[bf_subscr(a_1,a_2)] /* -- LAPACK test routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= CGRQTS tests CGGRQF, which computes the GRQ factorization of an M-by-N matrix A and a P-by-N matrix B: A = R*Q and B = Z*T*Q. Arguments ========= M (input) INTEGER The number of rows of the matrix A. M >= 0. P (input) INTEGER The number of rows of the matrix B. P >= 0. N (input) INTEGER The number of columns of the matrices A and B. N >= 0. A (input) COMPLEX array, dimension (LDA,N) The M-by-N matrix A. AF (output) COMPLEX array, dimension (LDA,N) Details of the GRQ factorization of A and B, as returned by CGGRQF, see CGGRQF for further details. Q (output) COMPLEX array, dimension (LDA,N) The N-by-N unitary matrix Q. R (workspace) COMPLEX array, dimension (LDA,MAX(M,N)) LDA (input) INTEGER The leading dimension of the arrays A, AF, R and Q. LDA >= max(M,N). TAUA (output) COMPLEX array, dimension (min(M,N)) The scalar factors of the elementary reflectors, as returned by SGGQRC. B (input) COMPLEX array, dimension (LDB,N) On entry, the P-by-N matrix A. BF (output) COMPLEX array, dimension (LDB,N) Details of the GQR factorization of A and B, as returned by CGGRQF, see CGGRQF for further details. Z (output) REAL array, dimension (LDB,P) The P-by-P unitary matrix Z. T (workspace) COMPLEX array, dimension (LDB,max(P,N)) BWK (workspace) COMPLEX array, dimension (LDB,N) LDB (input) INTEGER The leading dimension of the arrays B, BF, Z and T. LDB >= max(P,N). TAUB (output) COMPLEX array, dimension (min(P,N)) The scalar factors of the elementary reflectors, as returned by SGGRQF. WORK (workspace) COMPLEX array, dimension (LWORK) LWORK (input) INTEGER The dimension of the array WORK, LWORK >= max(M,P,N)**2. RWORK (workspace) REAL array, dimension (M) RESULT (output) REAL array, dimension (4) The test ratios: RESULT(1) = norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP) RESULT(2) = norm( T*Q - Z'*B ) / (MAX(P,N)*norm(B)*ULP) RESULT(3) = norm( I - Q'*Q ) / ( N*ULP ) RESULT(4) = norm( I - Z'*Z ) / ( P*ULP ) ===================================================================== Parameter adjustments */ r_dim1 = *lda; r_offset = 1 + r_dim1 * 1; r__ -= r_offset; q_dim1 = *lda; q_offset = 1 + q_dim1 * 1; q -= q_offset; af_dim1 = *lda; af_offset = 1 + af_dim1 * 1; af -= af_offset; a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; --taua; bwk_dim1 = *ldb; bwk_offset = 1 + bwk_dim1 * 1; bwk -= bwk_offset; t_dim1 = *ldb; t_offset = 1 + t_dim1 * 1; t -= t_offset; z_dim1 = *ldb; z_offset = 1 + z_dim1 * 1; z__ -= z_offset; bf_dim1 = *ldb; bf_offset = 1 + bf_dim1 * 1; bf -= bf_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; --taub; --work; --rwork; --result; /* Function Body */ ulp = slamch_("Precision"); unfl = slamch_("Safe minimum"); /* Copy the matrix A to the array AF. */ clacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda); clacpy_("Full", p, n, &b[b_offset], ldb, &bf[bf_offset], ldb); /* Computing MAX */ r__1 = clange_("1", m, n, &a[a_offset], lda, &rwork[1]); anorm = dmax(r__1,unfl); /* Computing MAX */ r__1 = clange_("1", p, n, &b[b_offset], ldb, &rwork[1]); bnorm = dmax(r__1,unfl); /* Factorize the matrices A and B in the arrays AF and BF. */ cggrqf_(m, p, n, &af[af_offset], lda, &taua[1], &bf[bf_offset], ldb, & taub[1], &work[1], lwork, &info); /* Generate the N-by-N matrix Q */ claset_("Full", n, n, &c_b3, &c_b3, &q[q_offset], lda); if (*m <= *n) { if (*m > 0 && *m < *n) { i__1 = *n - *m; clacpy_("Full", m, &i__1, &af[af_offset], lda, &q_ref(*n - *m + 1, 1), lda); } if (*m > 1) { i__1 = *m - 1; i__2 = *m - 1; clacpy_("Lower", &i__1, &i__2, &af_ref(2, *n - *m + 1), lda, & q_ref(*n - *m + 2, *n - *m + 1), lda); } } else { if (*n > 1) { i__1 = *n - 1; i__2 = *n - 1; clacpy_("Lower", &i__1, &i__2, &af_ref(*m - *n + 2, 1), lda, & q_ref(2, 1), lda); } } i__1 = min(*m,*n); cungrq_(n, n, &i__1, &q[q_offset], lda, &taua[1], &work[1], lwork, &info); /* Generate the P-by-P matrix Z */ claset_("Full", p, p, &c_b3, &c_b3, &z__[z_offset], ldb); if (*p > 1) { i__1 = *p - 1; clacpy_("Lower", &i__1, n, &bf_ref(2, 1), ldb, &z___ref(2, 1), ldb); } i__1 = min(*p,*n); cungqr_(p, p, &i__1, &z__[z_offset], ldb, &taub[1], &work[1], lwork, & info); /* Copy R */ claset_("Full", m, n, &c_b1, &c_b1, &r__[r_offset], lda); if (*m <= *n) { clacpy_("Upper", m, m, &af_ref(1, *n - *m + 1), lda, &r___ref(1, *n - *m + 1), lda); } else { i__1 = *m - *n; clacpy_("Full", &i__1, n, &af[af_offset], lda, &r__[r_offset], lda); clacpy_("Upper", n, n, &af_ref(*m - *n + 1, 1), lda, &r___ref(*m - *n + 1, 1), lda); } /* Copy T */ claset_("Full", p, n, &c_b1, &c_b1, &t[t_offset], ldb); clacpy_("Upper", p, n, &bf[bf_offset], ldb, &t[t_offset], ldb); /* Compute R - A*Q' */ q__1.r = -1.f, q__1.i = 0.f; cgemm_("No transpose", "Conjugate transpose", m, n, n, &q__1, &a[a_offset] , lda, &q[q_offset], lda, &c_b2, &r__[r_offset], lda); /* Compute norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP ) . */ resid = clange_("1", m, n, &r__[r_offset], lda, &rwork[1]); if (anorm > 0.f) { /* Computing MAX */ i__1 = max(1,*m); result[1] = resid / (real) max(i__1,*n) / anorm / ulp; } else { result[1] = 0.f; } /* Compute T*Q - Z'*B */ cgemm_("Conjugate transpose", "No transpose", p, n, p, &c_b2, &z__[ z_offset], ldb, &b[b_offset], ldb, &c_b1, &bwk[bwk_offset], ldb); q__1.r = -1.f, q__1.i = 0.f; cgemm_("No transpose", "No transpose", p, n, n, &c_b2, &t[t_offset], ldb, &q[q_offset], lda, &q__1, &bwk[bwk_offset], ldb); /* Compute norm( T*Q - Z'*B ) / ( MAX(P,N)*norm(A)*ULP ) . */ resid = clange_("1", p, n, &bwk[bwk_offset], ldb, &rwork[1]); if (bnorm > 0.f) { /* Computing MAX */ i__1 = max(1,*p); result[2] = resid / (real) max(i__1,*m) / bnorm / ulp; } else { result[2] = 0.f; } /* Compute I - Q*Q' */ claset_("Full", n, n, &c_b1, &c_b2, &r__[r_offset], lda); cherk_("Upper", "No Transpose", n, n, &c_b34, &q[q_offset], lda, &c_b35, & r__[r_offset], lda); /* Compute norm( I - Q'*Q ) / ( N * ULP ) . */ resid = clanhe_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]); result[3] = resid / (real) max(1,*n) / ulp; /* Compute I - Z'*Z */ claset_("Full", p, p, &c_b1, &c_b2, &t[t_offset], ldb); cherk_("Upper", "Conjugate transpose", p, p, &c_b34, &z__[z_offset], ldb, &c_b35, &t[t_offset], ldb); /* Compute norm( I - Z'*Z ) / ( P*ULP ) . */ resid = clanhe_("1", "Upper", p, &t[t_offset], ldb, &rwork[1]); result[4] = resid / (real) max(1,*p) / ulp; return 0; /* End of CGRQTS */ } /* cgrqts_ */
/* Subroutine */ int zqlt02_(integer *m, integer *n, integer *k, doublecomplex *a, doublecomplex *af, doublecomplex *q, doublecomplex * l, integer *lda, doublecomplex *tau, doublecomplex *work, integer * lwork, doublereal *rwork, doublereal *result) { /* System generated locals */ integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1, q_offset, i__1, i__2; /* Builtin functions Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); /* Local variables */ static integer info; static doublereal resid, anorm; extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zherk_(char *, char *, integer *, integer *, doublereal *, doublecomplex *, integer *, doublereal *, doublecomplex *, integer *); extern doublereal dlamch_(char *), zlange_(char *, integer *, integer *, doublecomplex *, integer *, doublereal *); extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *); extern doublereal zlansy_(char *, char *, integer *, doublecomplex *, integer *, doublereal *); extern /* Subroutine */ int zungql_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *); static doublereal eps; #define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1 #define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)] #define l_subscr(a_1,a_2) (a_2)*l_dim1 + a_1 #define l_ref(a_1,a_2) l[l_subscr(a_1,a_2)] #define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1 #define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)] #define af_subscr(a_1,a_2) (a_2)*af_dim1 + a_1 #define af_ref(a_1,a_2) af[af_subscr(a_1,a_2)] /* -- LAPACK test routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= ZQLT02 tests ZUNGQL, which generates an m-by-n matrix Q with orthonornmal columns that is defined as the product of k elementary reflectors. Given the QL factorization of an m-by-n matrix A, ZQLT02 generates the orthogonal matrix Q defined by the factorization of the last k columns of A; it compares L(m-n+1:m,n-k+1:n) with Q(1:m,m-n+1:m)'*A(1:m,n-k+1:n), and checks that the columns of Q are orthonormal. Arguments ========= M (input) INTEGER The number of rows of the matrix Q to be generated. M >= 0. N (input) INTEGER The number of columns of the matrix Q to be generated. M >= N >= 0. K (input) INTEGER The number of elementary reflectors whose product defines the matrix Q. N >= K >= 0. A (input) COMPLEX*16 array, dimension (LDA,N) The m-by-n matrix A which was factorized by ZQLT01. AF (input) COMPLEX*16 array, dimension (LDA,N) Details of the QL factorization of A, as returned by ZGEQLF. See ZGEQLF for further details. Q (workspace) COMPLEX*16 array, dimension (LDA,N) L (workspace) COMPLEX*16 array, dimension (LDA,N) LDA (input) INTEGER The leading dimension of the arrays A, AF, Q and L. LDA >= M. TAU (input) COMPLEX*16 array, dimension (N) The scalar factors of the elementary reflectors corresponding to the QL factorization in AF. WORK (workspace) COMPLEX*16 array, dimension (LWORK) LWORK (input) INTEGER The dimension of the array WORK. RWORK (workspace) DOUBLE PRECISION array, dimension (M) RESULT (output) DOUBLE PRECISION array, dimension (2) The test ratios: RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS ) RESULT(2) = norm( I - Q'*Q ) / ( M * EPS ) ===================================================================== Quick return if possible Parameter adjustments */ l_dim1 = *lda; l_offset = 1 + l_dim1 * 1; l -= l_offset; q_dim1 = *lda; q_offset = 1 + q_dim1 * 1; q -= q_offset; af_dim1 = *lda; af_offset = 1 + af_dim1 * 1; af -= af_offset; a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; --tau; --work; --rwork; --result; /* Function Body */ if (*m == 0 || *n == 0 || *k == 0) { result[1] = 0.; result[2] = 0.; return 0; } eps = dlamch_("Epsilon"); /* Copy the last k columns of the factorization to the array Q */ zlaset_("Full", m, n, &c_b1, &c_b1, &q[q_offset], lda); if (*k < *m) { i__1 = *m - *k; zlacpy_("Full", &i__1, k, &af_ref(1, *n - *k + 1), lda, &q_ref(1, *n - *k + 1), lda); } if (*k > 1) { i__1 = *k - 1; i__2 = *k - 1; zlacpy_("Upper", &i__1, &i__2, &af_ref(*m - *k + 1, *n - *k + 2), lda, &q_ref(*m - *k + 1, *n - *k + 2), lda); } /* Generate the last n columns of the matrix Q */ s_copy(srnamc_1.srnamt, "ZUNGQL", (ftnlen)6, (ftnlen)6); zungql_(m, n, k, &q[q_offset], lda, &tau[*n - *k + 1], &work[1], lwork, & info); /* Copy L(m-n+1:m,n-k+1:n) */ zlaset_("Full", n, k, &c_b9, &c_b9, &l_ref(*m - *n + 1, *n - *k + 1), lda); zlacpy_("Lower", k, k, &af_ref(*m - *k + 1, *n - *k + 1), lda, &l_ref(*m - *k + 1, *n - *k + 1), lda); /* Compute L(m-n+1:m,n-k+1:n) - Q(1:m,m-n+1:m)' * A(1:m,n-k+1:n) */ zgemm_("Conjugate transpose", "No transpose", n, k, m, &c_b14, &q[ q_offset], lda, &a_ref(1, *n - *k + 1), lda, &c_b15, &l_ref(*m - * n + 1, *n - *k + 1), lda); /* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) . */ anorm = zlange_("1", m, k, &a_ref(1, *n - *k + 1), lda, &rwork[1]); resid = zlange_("1", n, k, &l_ref(*m - *n + 1, *n - *k + 1), lda, &rwork[ 1]); if (anorm > 0.) { result[1] = resid / (doublereal) max(1,*m) / anorm / eps; } else { result[1] = 0.; } /* Compute I - Q'*Q */ zlaset_("Full", n, n, &c_b9, &c_b15, &l[l_offset], lda); zherk_("Upper", "Conjugate transpose", n, m, &c_b23, &q[q_offset], lda, & c_b24, &l[l_offset], lda); /* Compute norm( I - Q'*Q ) / ( M * EPS ) . */ resid = zlansy_("1", "Upper", n, &l[l_offset], lda, &rwork[1]); result[2] = resid / (doublereal) max(1,*m) / eps; return 0; /* End of ZQLT02 */ } /* zqlt02_ */
/* Subroutine */ int dlaed9_(integer *k, integer *kstart, integer *kstop, integer *n, doublereal *d__, doublereal *q, integer *ldq, doublereal * rho, doublereal *dlamda, doublereal *w, doublereal *s, integer *lds, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, Courant Institute, NAG Ltd., and Rice University September 30, 1994 Purpose ======= DLAED9 finds the roots of the secular equation, as defined by the values in D, Z, and RHO, between KSTART and KSTOP. It makes the appropriate calls to DLAED4 and then stores the new matrix of eigenvectors for use in calculating the next level of Z vectors. Arguments ========= K (input) INTEGER The number of terms in the rational function to be solved by DLAED4. K >= 0. KSTART (input) INTEGER KSTOP (input) INTEGER The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP are to be computed. 1 <= KSTART <= KSTOP <= K. N (input) INTEGER The number of rows and columns in the Q matrix. N >= K (delation may result in N > K). D (output) DOUBLE PRECISION array, dimension (N) D(I) contains the updated eigenvalues for KSTART <= I <= KSTOP. Q (workspace) DOUBLE PRECISION array, dimension (LDQ,N) LDQ (input) INTEGER The leading dimension of the array Q. LDQ >= max( 1, N ). RHO (input) DOUBLE PRECISION The value of the parameter in the rank one update equation. RHO >= 0 required. DLAMDA (input) DOUBLE PRECISION array, dimension (K) The first K elements of this array contain the old roots of the deflated updating problem. These are the poles of the secular equation. W (input) DOUBLE PRECISION array, dimension (K) The first K elements of this array contain the components of the deflation-adjusted updating vector. S (output) DOUBLE PRECISION array, dimension (LDS, K) Will contain the eigenvectors of the repaired matrix which will be stored for subsequent Z vector calculation and multiplied by the previously accumulated eigenvectors to update the system. LDS (input) INTEGER The leading dimension of S. LDS >= max( 1, K ). INFO (output) INTEGER = 0: successful exit. < 0: if INFO = -i, the i-th argument had an illegal value. > 0: if INFO = 1, an eigenvalue did not converge Further Details =============== Based on contributions by Jeff Rutter, Computer Science Division, University of California at Berkeley, USA ===================================================================== Test the input parameters. Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; /* System generated locals */ integer q_dim1, q_offset, s_dim1, s_offset, i__1, i__2; doublereal d__1; /* Builtin functions */ double sqrt(doublereal), d_sign(doublereal *, doublereal *); /* Local variables */ static doublereal temp; extern doublereal dnrm2_(integer *, doublereal *, integer *); static integer i__, j; extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *), dlaed4_(integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, integer *); extern doublereal dlamc3_(doublereal *, doublereal *); extern /* Subroutine */ int xerbla_(char *, integer *); #define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1] #define s_ref(a_1,a_2) s[(a_2)*s_dim1 + a_1] --d__; q_dim1 = *ldq; q_offset = 1 + q_dim1 * 1; q -= q_offset; --dlamda; --w; s_dim1 = *lds; s_offset = 1 + s_dim1 * 1; s -= s_offset; /* Function Body */ *info = 0; if (*k < 0) { *info = -1; } else if (*kstart < 1 || *kstart > max(1,*k)) { *info = -2; } else if (max(1,*kstop) < *kstart || *kstop > max(1,*k)) { *info = -3; } else if (*n < *k) { *info = -4; } else if (*ldq < max(1,*k)) { *info = -7; } else if (*lds < max(1,*k)) { *info = -12; } if (*info != 0) { i__1 = -(*info); xerbla_("DLAED9", &i__1); return 0; } /* Quick return if possible */ if (*k == 0) { return 0; } /* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can be computed with high relative accuracy (barring over/underflow). This is a problem on machines without a guard digit in add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), which on any of these machines zeros out the bottommost bit of DLAMDA(I) if it is 1; this makes the subsequent subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation occurs. On binary machines with a guard digit (almost all machines) it does not change DLAMDA(I) at all. On hexadecimal and decimal machines with a guard digit, it slightly changes the bottommost bits of DLAMDA(I). It does not account for hexadecimal or decimal machines without guard digits (we know of none). We use a subroutine call to compute 2*DLAMBDA(I) to prevent optimizing compilers from eliminating this code. */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { dlamda[i__] = dlamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__]; /* L10: */ } i__1 = *kstop; for (j = *kstart; j <= i__1; ++j) { dlaed4_(k, &j, &dlamda[1], &w[1], &q_ref(1, j), rho, &d__[j], info); /* If the zero finder fails, the computation is terminated. */ if (*info != 0) { goto L120; } /* L20: */ } if (*k == 1 || *k == 2) { i__1 = *k; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *k; for (j = 1; j <= i__2; ++j) { s_ref(j, i__) = q_ref(j, i__); /* L30: */ } /* L40: */ } goto L120; } /* Compute updated W. */ dcopy_(k, &w[1], &c__1, &s[s_offset], &c__1); /* Initialize W(I) = Q(I,I) */ i__1 = *ldq + 1; dcopy_(k, &q[q_offset], &i__1, &w[1], &c__1); i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { w[i__] *= q_ref(i__, j) / (dlamda[i__] - dlamda[j]); /* L50: */ } i__2 = *k; for (i__ = j + 1; i__ <= i__2; ++i__) { w[i__] *= q_ref(i__, j) / (dlamda[i__] - dlamda[j]); /* L60: */ } /* L70: */ } i__1 = *k; for (i__ = 1; i__ <= i__1; ++i__) { d__1 = sqrt(-w[i__]); w[i__] = d_sign(&d__1, &s_ref(i__, 1)); /* L80: */ } /* Compute eigenvectors of the modified rank-1 modification. */ i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *k; for (i__ = 1; i__ <= i__2; ++i__) { q_ref(i__, j) = w[i__] / q_ref(i__, j); /* L90: */ } temp = dnrm2_(k, &q_ref(1, j), &c__1); i__2 = *k; for (i__ = 1; i__ <= i__2; ++i__) { s_ref(i__, j) = q_ref(i__, j) / temp; /* L100: */ } /* L110: */ } L120: return 0; /* End of DLAED9 */ } /* dlaed9_ */
/* Subroutine */ int cqrt02_(integer *m, integer *n, integer *k, complex *a, complex *af, complex *q, complex *r__, integer *lda, complex *tau, complex *work, integer *lwork, real *rwork, real *result) { /* System generated locals */ integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1, r_offset, i__1; /* Builtin functions Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); /* Local variables */ static integer info; extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *), cherk_(char *, char *, integer *, integer *, real *, complex *, integer *, real * , complex *, integer *); static real resid, anorm; extern doublereal clange_(char *, integer *, integer *, complex *, integer *, real *), slamch_(char *); extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex *, integer *, complex *, integer *), claset_(char *, integer *, integer *, complex *, complex *, complex *, integer *); extern doublereal clansy_(char *, char *, integer *, complex *, integer *, real *); extern /* Subroutine */ int cungqr_(integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, integer *); static real eps; #define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1 #define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)] #define af_subscr(a_1,a_2) (a_2)*af_dim1 + a_1 #define af_ref(a_1,a_2) af[af_subscr(a_1,a_2)] /* -- LAPACK test routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= CQRT02 tests CUNGQR, which generates an m-by-n matrix Q with orthonornmal columns that is defined as the product of k elementary reflectors. Given the QR factorization of an m-by-n matrix A, CQRT02 generates the orthogonal matrix Q defined by the factorization of the first k columns of A; it compares R(1:n,1:k) with Q(1:m,1:n)'*A(1:m,1:k), and checks that the columns of Q are orthonormal. Arguments ========= M (input) INTEGER The number of rows of the matrix Q to be generated. M >= 0. N (input) INTEGER The number of columns of the matrix Q to be generated. M >= N >= 0. K (input) INTEGER The number of elementary reflectors whose product defines the matrix Q. N >= K >= 0. A (input) COMPLEX array, dimension (LDA,N) The m-by-n matrix A which was factorized by CQRT01. AF (input) COMPLEX array, dimension (LDA,N) Details of the QR factorization of A, as returned by CGEQRF. See CGEQRF for further details. Q (workspace) COMPLEX array, dimension (LDA,N) R (workspace) COMPLEX array, dimension (LDA,N) LDA (input) INTEGER The leading dimension of the arrays A, AF, Q and R. LDA >= M. TAU (input) COMPLEX array, dimension (N) The scalar factors of the elementary reflectors corresponding to the QR factorization in AF. WORK (workspace) COMPLEX array, dimension (LWORK) LWORK (input) INTEGER The dimension of the array WORK. RWORK (workspace) REAL array, dimension (M) RESULT (output) REAL array, dimension (2) The test ratios: RESULT(1) = norm( R - Q'*A ) / ( M * norm(A) * EPS ) RESULT(2) = norm( I - Q'*Q ) / ( M * EPS ) ===================================================================== Parameter adjustments */ r_dim1 = *lda; r_offset = 1 + r_dim1 * 1; r__ -= r_offset; q_dim1 = *lda; q_offset = 1 + q_dim1 * 1; q -= q_offset; af_dim1 = *lda; af_offset = 1 + af_dim1 * 1; af -= af_offset; a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; --tau; --work; --rwork; --result; /* Function Body */ eps = slamch_("Epsilon"); /* Copy the first k columns of the factorization to the array Q */ claset_("Full", m, n, &c_b1, &c_b1, &q[q_offset], lda); i__1 = *m - 1; clacpy_("Lower", &i__1, k, &af_ref(2, 1), lda, &q_ref(2, 1), lda); /* Generate the first n columns of the matrix Q */ s_copy(srnamc_1.srnamt, "CUNGQR", (ftnlen)6, (ftnlen)6); cungqr_(m, n, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info); /* Copy R(1:n,1:k) */ claset_("Full", n, k, &c_b8, &c_b8, &r__[r_offset], lda); clacpy_("Upper", n, k, &af[af_offset], lda, &r__[r_offset], lda); /* Compute R(1:n,1:k) - Q(1:m,1:n)' * A(1:m,1:k) */ cgemm_("Conjugate transpose", "No transpose", n, k, m, &c_b13, &q[ q_offset], lda, &a[a_offset], lda, &c_b14, &r__[r_offset], lda); /* Compute norm( R - Q'*A ) / ( M * norm(A) * EPS ) . */ anorm = clange_("1", m, k, &a[a_offset], lda, &rwork[1]); resid = clange_("1", n, k, &r__[r_offset], lda, &rwork[1]); if (anorm > 0.f) { result[1] = resid / (real) max(1,*m) / anorm / eps; } else { result[1] = 0.f; } /* Compute I - Q'*Q */ claset_("Full", n, n, &c_b8, &c_b14, &r__[r_offset], lda); cherk_("Upper", "Conjugate transpose", n, m, &c_b22, &q[q_offset], lda, & c_b23, &r__[r_offset], lda); /* Compute norm( I - Q'*Q ) / ( M * EPS ) . */ resid = clansy_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]); result[2] = resid / (real) max(1,*m) / eps; return 0; /* End of CQRT02 */ } /* cqrt02_ */
/* Subroutine */ int cdrvgg_(integer *nsizes, integer *nn, integer *ntypes, logical *dotype, integer *iseed, real *thresh, real *thrshn, integer * nounit, complex *a, integer *lda, complex *b, complex *s, complex *t, complex *s2, complex *t2, complex *q, integer *ldq, complex *z__, complex *alpha1, complex *beta1, complex *alpha2, complex *beta2, complex *vl, complex *vr, complex *work, integer *lwork, real *rwork, real *result, integer *info) { /* Initialized data */ static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2, 2,2,2,3 }; static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3, 2,3,2,1 }; static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1, 1,1,1,1 }; static logical lasign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, TRUE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,FALSE_, TRUE_,FALSE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,FALSE_ }; static logical lbsign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, FALSE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,FALSE_, TRUE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_, FALSE_ }; static integer kz1[6] = { 0,1,2,1,3,3 }; static integer kz2[6] = { 0,0,1,2,1,1 }; static integer kadd[6] = { 0,0,0,0,3,2 }; static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4, 4,4,4,0 }; static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8, 8,8,8,8,8,0 }; static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3, 3,3,3,1 }; static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4, 4,4,4,1 }; static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2, 3,3,2,1 }; /* Format strings */ static char fmt_9999[] = "(\002 CDRVGG: \002,a,\002 returned INFO=\002,i" "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED=" "(\002,3(i5,\002,\002),i5,\002)\002)"; static char fmt_9998[] = "(\002 CDRVGG: \002,a,\002 Eigenvectors from" " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of " "error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002," "i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)"; static char fmt_9997[] = "(/1x,a3,\002 -- Complex Generalized eigenvalue" " problem driver\002)"; static char fmt_9996[] = "(\002 Matrix types (see CDRVGG for details):" " \002)"; static char fmt_9995[] = "(\002 Special Matrices:\002,23x,\002(J'=transp" "osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I" ") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag" "onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D," "I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l" "arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12=" "(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15" "=(D, reversed D)\002)"; static char fmt_9994[] = "(\002 Matrices Rotated by Random \002,a,\002 M" "atrices U, V:\002,/\002 16=Transposed Jordan Blocks " " 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp" "ha&beta \002,\002 20=arithmetic alpha, beta=0," "1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21" "=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002," "/\002 22=(large, small) \002,\00223=(small,large) 24=(smal" "l,small) 25=(large,large)\002,/\002 26=random O(1) matrices" ".\002)"; static char fmt_9993[] = "(/\002 Tests performed: (S is Schur, T is tri" "angular, \002,\002Q and Z are \002,a,\002,\002,/20x,\002l and r " "are the appropriate left and right\002,/19x,\002eigenvectors, re" "sp., a is alpha, b is beta, and\002,/19x,a,\002 means \002,a," "\002.)\002,/\002 1 = | A - Q S Z\002,a,\002 | / ( |A| n ulp ) " " 2 = | B - Q T Z\002,a,\002 | / ( |B| n ulp )\002,/\002 3 = | " "I - QQ\002,a,\002 | / ( n ulp ) 4 = | I - ZZ\002,a" ",\002 | / ( n ulp )\002,/\002 5 = difference between (alpha,beta" ") and diagonals of\002,\002 (S,T)\002,/\002 6 = max | ( b A - a " "B )\002,a,\002 l | / const. 7 = max | ( b A - a B ) r | / cons" "t.\002,/1x)"; static char fmt_9992[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2" ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002" ",0p,f8.2)"; static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2" ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002" ",1p,e10.3)"; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, s_dim1, s_offset, s2_dim1, s2_offset, t_dim1, t_offset, t2_dim1, t2_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10, i__11; real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10, r__11, r__12, r__13, r__14, r__15, r__16; complex q__1, q__2, q__3, q__4; /* Builtin functions */ double r_sign(real *, real *), c_abs(complex *); void r_cnjg(complex *, complex *); integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); double r_imag(complex *); /* Local variables */ static integer iadd, nmax; static real temp1, temp2; static integer j, n; static logical badnn; extern /* Subroutine */ int cgegs_(char *, char *, integer *, complex *, integer *, complex *, integer *, complex *, complex *, complex *, integer *, complex *, integer *, complex *, integer *, real *, integer *), cgegv_(char *, char *, integer *, complex *, integer *, complex *, integer *, complex *, complex *, complex *, integer *, complex *, integer *, complex *, integer *, real *, integer *), cget51_(integer *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, real *, real *), cget52_(logical *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, complex *, complex *, real *, real *); static real dumma[4]; static integer iinfo; static real rmagn[4]; static complex ctemp; static integer nmats, jsize, nerrs, i1, jtype, ntest, n1; extern /* Subroutine */ int clatm4_(integer *, integer *, integer *, integer *, logical *, real *, real *, real *, integer *, integer * , complex *, integer *), cunm2r_(char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *); static integer jc, nb; extern /* Subroutine */ int slabad_(real *, real *); static integer in, jr; extern /* Subroutine */ int clarfg_(integer *, complex *, complex *, integer *, complex *); static integer ns; extern /* Complex */ VOID clarnd_(complex *, integer *, integer *); extern doublereal slamch_(char *); extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex *, integer *, complex *, integer *); static real safmin, safmax; static integer ioldsd[4]; extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer *, integer *), claset_(char *, integer *, integer *, complex *, complex *, complex *, integer *), xerbla_(char *, integer *); static real ulpinv; static integer lwkopt, mtypes, ntestt, nbz; static real ulp; /* Fortran I/O blocks */ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___44 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___47 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___49 = { 0, 0, 0, fmt_9998, 0 }; static cilist io___50 = { 0, 0, 0, fmt_9998, 0 }; static cilist io___51 = { 0, 0, 0, fmt_9997, 0 }; static cilist io___52 = { 0, 0, 0, fmt_9996, 0 }; static cilist io___53 = { 0, 0, 0, fmt_9995, 0 }; static cilist io___54 = { 0, 0, 0, fmt_9994, 0 }; static cilist io___55 = { 0, 0, 0, fmt_9993, 0 }; static cilist io___56 = { 0, 0, 0, fmt_9992, 0 }; static cilist io___57 = { 0, 0, 0, fmt_9991, 0 }; #define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1 #define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)] #define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1 #define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)] #define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1 #define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)] #define s_subscr(a_1,a_2) (a_2)*s_dim1 + a_1 #define s_ref(a_1,a_2) s[s_subscr(a_1,a_2)] #define t_subscr(a_1,a_2) (a_2)*t_dim1 + a_1 #define t_ref(a_1,a_2) t[t_subscr(a_1,a_2)] #define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1 #define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)] /* -- LAPACK test routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= CDRVGG checks the nonsymmetric generalized eigenvalue driver routines. T T T CGEGS factors A and B as Q S Z and Q T Z , where means transpose, T is upper triangular, S is in generalized Schur form (upper triangular), and Q and Z are unitary. It also computes the generalized eigenvalues (alpha(1),beta(1)), ..., (alpha(n),beta(n)), where alpha(j)=S(j,j) and beta(j)=T(j,j) -- thus, w(j) = alpha(j)/beta(j) is a root of the generalized eigenvalue problem det( A - w(j) B ) = 0 and m(j) = beta(j)/alpha(j) is a root of the essentially equivalent problem det( m(j) A - B ) = 0 CGEGV computes the generalized eigenvalues (alpha(1),beta(1)), ..., (alpha(n),beta(n)), the matrix L whose columns contain the generalized left eigenvectors l, and the matrix R whose columns contain the generalized right eigenvectors r for the pair (A,B). When CDRVGG is called, a number of matrix "sizes" ("n's") and a number of matrix "types" are specified. For each size ("n") and each type of matrix, one matrix will be generated and used to test the nonsymmetric eigenroutines. For each matrix, 7 tests will be performed and compared with the threshhold THRESH: Results from CGEGS: H (1) | A - Q S Z | / ( |A| n ulp ) H (2) | B - Q T Z | / ( |B| n ulp ) H (3) | I - QQ | / ( n ulp ) H (4) | I - ZZ | / ( n ulp ) (5) maximum over j of D(j) where: |alpha(j) - S(j,j)| |beta(j) - T(j,j)| D(j) = ------------------------ + ----------------------- max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) Results from CGEGV: (6) max over all left eigenvalue/-vector pairs (beta/alpha,l) of | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) ) where l**H is the conjugate tranpose of l. (7) max over all right eigenvalue/-vector pairs (beta/alpha,r) of | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) ) Test Matrices ---- -------- The sizes of the test matrices are specified by an array NN(1:NSIZES); the value of each element NN(j) specifies one size. The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. Currently, the list of possible types is: (1) ( 0, 0 ) (a pair of zero matrices) (2) ( I, 0 ) (an identity and a zero matrix) (3) ( 0, I ) (an identity and a zero matrix) (4) ( I, I ) (a pair of identity matrices) t t (5) ( J , J ) (a pair of transposed Jordan blocks) t ( I 0 ) (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) ( 0 I ) ( 0 J ) and I is a k x k identity and J a (k+1)x(k+1) Jordan block; k=(N-1)/2 (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal matrix with those diagonal entries.) (8) ( I, D ) (9) ( big*D, small*I ) where "big" is near overflow and small=1/big (10) ( small*D, big*I ) (11) ( big*I, small*D ) (12) ( small*I, big*D ) (13) ( big*D, big*I ) (14) ( small*D, small*I ) (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) t t (16) Q ( J , J ) Z where Q and Z are random unitary matrices. (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices with random O(1) entries above the diagonal and diagonal entries diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = ( 0, N-3, N-4,..., 1, 0, 0 ) (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) s = machine precision. (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) N-5 (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) where r1,..., r(N-4) are random. (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) diag(T2) = ( 0, 1, ..., 1, 0, 0 ) (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) diag(T2) = ( 0, 1, ..., 1, 0, 0 ) (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) diag(T2) = ( 0, 1, ..., 1, 0, 0 ) (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) diag(T2) = ( 0, 1, ..., 1, 0, 0 ) (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular matrices. Arguments ========= NSIZES (input) INTEGER The number of sizes of matrices to use. If it is zero, CDRVGG does nothing. It must be at least zero. NN (input) INTEGER array, dimension (NSIZES) An array containing the sizes to be used for the matrices. Zero values will be skipped. The values must be at least zero. NTYPES (input) INTEGER The number of elements in DOTYPE. If it is zero, CDRVGG does nothing. It must be at least zero. If it is MAXTYP+1 and NSIZES is 1, then an additional type, MAXTYP+1 is defined, which is to use whatever matrix is in A. This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. . DOTYPE (input) LOGICAL array, dimension (NTYPES) If DOTYPE(j) is .TRUE., then for each size in NN a matrix of that size and of type j will be generated. If NTYPES is smaller than the maximum number of types defined (PARAMETER MAXTYP), then types NTYPES+1 through MAXTYP will not be generated. If NTYPES is larger than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) will be ignored. ISEED (input/output) INTEGER array, dimension (4) On entry ISEED specifies the seed of the random number generator. The array elements should be between 0 and 4095; if not they will be reduced mod 4096. Also, ISEED(4) must be odd. The random number generator uses a linear congruential sequence limited to small integers, and so should produce machine independent random numbers. The values of ISEED are changed on exit, and can be used in the next call to CDRVGG to continue the same random number sequence. THRESH (input) REAL A test will count as "failed" if the "error", computed as described above, exceeds THRESH. Note that the error is scaled to be O(1), so THRESH should be a reasonably small multiple of 1, e.g., 10 or 100. In particular, it should not depend on the precision (single vs. double) or the size of the matrix. It must be at least zero. THRSHN (input) REAL Threshhold for reporting eigenvector normalization error. If the normalization of any eigenvector differs from 1 by more than THRSHN*ulp, then a special error message will be printed. (This is handled separately from the other tests, since only a compiler or programming error should cause an error message, at least if THRSHN is at least 5--10.) NOUNIT (input) INTEGER The FORTRAN unit number for printing out error messages (e.g., if a routine returns IINFO not equal to 0.) A (input/workspace) COMPLEX array, dimension (LDA, max(NN)) Used to hold the original A matrix. Used as input only if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and DOTYPE(MAXTYP+1)=.TRUE. LDA (input) INTEGER The leading dimension of A, B, S, T, S2, and T2. It must be at least 1 and at least max( NN ). B (input/workspace) COMPLEX array, dimension (LDA, max(NN)) Used to hold the original B matrix. Used as input only if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and DOTYPE(MAXTYP+1)=.TRUE. S (workspace) COMPLEX array, dimension (LDA, max(NN)) The upper triangular matrix computed from A by CGEGS. T (workspace) COMPLEX array, dimension (LDA, max(NN)) The upper triangular matrix computed from B by CGEGS. S2 (workspace) COMPLEX array, dimension (LDA, max(NN)) The matrix computed from A by CGEGV. This will be the Schur (upper triangular) form of some matrix related to A, but will not, in general, be the same as S. T2 (workspace) COMPLEX array, dimension (LDA, max(NN)) The matrix computed from B by CGEGV. This will be the Schur form of some matrix related to B, but will not, in general, be the same as T. Q (workspace) COMPLEX array, dimension (LDQ, max(NN)) The (left) unitary matrix computed by CGEGS. LDQ (input) INTEGER The leading dimension of Q, Z, VL, and VR. It must be at least 1 and at least max( NN ). Z (workspace) COMPLEX array, dimension (LDQ, max(NN)) The (right) unitary matrix computed by CGEGS. ALPHA1 (workspace) COMPLEX array, dimension (max(NN)) BETA1 (workspace) COMPLEX array, dimension (max(NN)) The generalized eigenvalues of (A,B) computed by CGEGS. ALPHA1(k) / BETA1(k) is the k-th generalized eigenvalue of the matrices in A and B. ALPHA2 (workspace) COMPLEX array, dimension (max(NN)) BETA2 (workspace) COMPLEX array, dimension (max(NN)) The generalized eigenvalues of (A,B) computed by CGEGV. ALPHA2(k) / BETA2(k) is the k-th generalized eigenvalue of the matrices in A and B. VL (workspace) COMPLEX array, dimension (LDQ, max(NN)) The (lower triangular) left eigenvector matrix for the matrices in A and B. VR (workspace) COMPLEX array, dimension (LDQ, max(NN)) The (upper triangular) right eigenvector matrix for the matrices in A and B. WORK (workspace) COMPLEX array, dimension (LWORK) LWORK (input) INTEGER The number of entries in WORK. This must be at least MAX( 2*N, N*(NB+1), (k+1)*(2*k+N+1) ), where "k" is the sum of the blocksize and number-of-shifts for CHGEQZ, and NB is the greatest of the blocksizes for CGEQRF, CUNMQR, and CUNGQR. (The blocksizes and the number-of-shifts are retrieved through calls to ILAENV.) RWORK (workspace) REAL array, dimension (8*N) RESULT (output) REAL array, dimension (7) The values computed by the tests described above. The values are currently limited to 1/ulp, to avoid overflow. INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value. > 0: A routine returned an error code. INFO is the absolute value of the INFO value returned. ===================================================================== Parameter adjustments */ --nn; --dotype; --iseed; t2_dim1 = *lda; t2_offset = 1 + t2_dim1 * 1; t2 -= t2_offset; s2_dim1 = *lda; s2_offset = 1 + s2_dim1 * 1; s2 -= s2_offset; t_dim1 = *lda; t_offset = 1 + t_dim1 * 1; t -= t_offset; s_dim1 = *lda; s_offset = 1 + s_dim1 * 1; s -= s_offset; b_dim1 = *lda; b_offset = 1 + b_dim1 * 1; b -= b_offset; a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; vr_dim1 = *ldq; vr_offset = 1 + vr_dim1 * 1; vr -= vr_offset; vl_dim1 = *ldq; vl_offset = 1 + vl_dim1 * 1; vl -= vl_offset; z_dim1 = *ldq; z_offset = 1 + z_dim1 * 1; z__ -= z_offset; q_dim1 = *ldq; q_offset = 1 + q_dim1 * 1; q -= q_offset; --alpha1; --beta1; --alpha2; --beta2; --work; --rwork; --result; /* Function Body Check for errors */ *info = 0; badnn = FALSE_; nmax = 1; i__1 = *nsizes; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ i__2 = nmax, i__3 = nn[j]; nmax = max(i__2,i__3); if (nn[j] < 0) { badnn = TRUE_; } /* L10: */ } /* Maximum blocksize and shift -- we assume that blocksize and number of shifts are monotone increasing functions of N. Computing MAX */ i__1 = 1, i__2 = ilaenv_(&c__1, "CGEQRF", " ", &nmax, &nmax, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1), i__1 = max(i__1,i__2), i__2 = ilaenv_(& c__1, "CUNMQR", "LC", &nmax, &nmax, &nmax, &c_n1, (ftnlen)6, ( ftnlen)2), i__1 = max(i__1,i__2), i__2 = ilaenv_(&c__1, "CUNGQR", " ", &nmax, &nmax, &nmax, &c_n1, (ftnlen)6, (ftnlen)1); nb = max(i__1,i__2); nbz = ilaenv_(&c__1, "CHGEQZ", "SII", &nmax, &c__1, &nmax, &c__0, (ftnlen) 6, (ftnlen)3); ns = ilaenv_(&c__4, "CHGEQZ", "SII", &nmax, &c__1, &nmax, &c__0, (ftnlen) 6, (ftnlen)3); i1 = nbz + ns; /* Computing MAX */ i__1 = nmax << 1, i__2 = nmax * (nb + 1), i__1 = max(i__1,i__2), i__2 = (( i1 << 1) + nmax + 1) * (i1 + 1); lwkopt = max(i__1,i__2); /* Check for errors */ if (*nsizes < 0) { *info = -1; } else if (badnn) { *info = -2; } else if (*ntypes < 0) { *info = -3; } else if (*thresh < 0.f) { *info = -6; } else if (*lda <= 1 || *lda < nmax) { *info = -10; } else if (*ldq <= 1 || *ldq < nmax) { *info = -19; } else if (lwkopt > *lwork) { *info = -30; } if (*info != 0) { i__1 = -(*info); xerbla_("CDRVGG", &i__1); return 0; } /* Quick return if possible */ if (*nsizes == 0 || *ntypes == 0) { return 0; } ulp = slamch_("Precision"); safmin = slamch_("Safe minimum"); safmin /= ulp; safmax = 1.f / safmin; slabad_(&safmin, &safmax); ulpinv = 1.f / ulp; /* The values RMAGN(2:3) depend on N, see below. */ rmagn[0] = 0.f; rmagn[1] = 1.f; /* Loop over sizes, types */ ntestt = 0; nerrs = 0; nmats = 0; i__1 = *nsizes; for (jsize = 1; jsize <= i__1; ++jsize) { n = nn[jsize]; n1 = max(1,n); rmagn[2] = safmax * ulp / (real) n1; rmagn[3] = safmin * ulpinv * n1; if (*nsizes != 1) { mtypes = min(26,*ntypes); } else { mtypes = min(27,*ntypes); } i__2 = mtypes; for (jtype = 1; jtype <= i__2; ++jtype) { if (! dotype[jtype]) { goto L150; } ++nmats; ntest = 0; /* Save ISEED in case of an error. */ for (j = 1; j <= 4; ++j) { ioldsd[j - 1] = iseed[j]; /* L20: */ } /* Initialize RESULT */ for (j = 1; j <= 7; ++j) { result[j] = 0.f; /* L30: */ } /* Compute A and B Description of control parameters: KCLASS: =1 means w/o rotation, =2 means w/ rotation, =3 means random. KATYPE: the "type" to be passed to CLATM4 for computing A. KAZERO: the pattern of zeros on the diagonal for A: =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of non-zero entries.) KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), =2: large, =3: small. LASIGN: .TRUE. if the diagonal elements of A are to be multiplied by a random magnitude 1 number. KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B. KTRIAN: =0: don't fill in the upper triangle, =1: do. KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. RMAGN: used to implement KAMAGN and KBMAGN. */ if (mtypes > 26) { goto L110; } iinfo = 0; if (kclass[jtype - 1] < 3) { /* Generate A (w/o rotation) */ if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) { in = ((n - 1) / 2 << 1) + 1; if (in != n) { claset_("Full", &n, &n, &c_b1, &c_b1, &a[a_offset], lda); } } else { in = n; } clatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1], &kz2[kazero[jtype - 1] - 1], &lasign[jtype - 1], & rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype - 1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[ a_offset], lda); iadd = kadd[kazero[jtype - 1] - 1]; if (iadd > 0 && iadd <= n) { i__3 = a_subscr(iadd, iadd); i__4 = kamagn[jtype - 1]; a[i__3].r = rmagn[i__4], a[i__3].i = 0.f; } /* Generate B (w/o rotation) */ if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) { in = ((n - 1) / 2 << 1) + 1; if (in != n) { claset_("Full", &n, &n, &c_b1, &c_b1, &b[b_offset], lda); } } else { in = n; } clatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1], &kz2[kbzero[jtype - 1] - 1], &lbsign[jtype - 1], & rmagn[kbmagn[jtype - 1]], &c_b39, &rmagn[ktrian[jtype - 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[ b_offset], lda); iadd = kadd[kbzero[jtype - 1] - 1]; if (iadd != 0 && iadd <= n) { i__3 = b_subscr(iadd, iadd); i__4 = kbmagn[jtype - 1]; b[i__3].r = rmagn[i__4], b[i__3].i = 0.f; } if (kclass[jtype - 1] == 2 && n > 0) { /* Include rotations Generate Q, Z as Householder transformations times a diagonal matrix. */ i__3 = n - 1; for (jc = 1; jc <= i__3; ++jc) { i__4 = n; for (jr = jc; jr <= i__4; ++jr) { i__5 = q_subscr(jr, jc); clarnd_(&q__1, &c__3, &iseed[1]); q[i__5].r = q__1.r, q[i__5].i = q__1.i; i__5 = z___subscr(jr, jc); clarnd_(&q__1, &c__3, &iseed[1]); z__[i__5].r = q__1.r, z__[i__5].i = q__1.i; /* L40: */ } i__4 = n + 1 - jc; clarfg_(&i__4, &q_ref(jc, jc), &q_ref(jc + 1, jc), & c__1, &work[jc]); i__4 = (n << 1) + jc; i__5 = q_subscr(jc, jc); r__2 = q[i__5].r; r__1 = r_sign(&c_b39, &r__2); work[i__4].r = r__1, work[i__4].i = 0.f; i__4 = q_subscr(jc, jc); q[i__4].r = 1.f, q[i__4].i = 0.f; i__4 = n + 1 - jc; clarfg_(&i__4, &z___ref(jc, jc), &z___ref(jc + 1, jc), &c__1, &work[n + jc]); i__4 = n * 3 + jc; i__5 = z___subscr(jc, jc); r__2 = z__[i__5].r; r__1 = r_sign(&c_b39, &r__2); work[i__4].r = r__1, work[i__4].i = 0.f; i__4 = z___subscr(jc, jc); z__[i__4].r = 1.f, z__[i__4].i = 0.f; /* L50: */ } clarnd_(&q__1, &c__3, &iseed[1]); ctemp.r = q__1.r, ctemp.i = q__1.i; i__3 = q_subscr(n, n); q[i__3].r = 1.f, q[i__3].i = 0.f; i__3 = n; work[i__3].r = 0.f, work[i__3].i = 0.f; i__3 = n * 3; r__1 = c_abs(&ctemp); q__1.r = ctemp.r / r__1, q__1.i = ctemp.i / r__1; work[i__3].r = q__1.r, work[i__3].i = q__1.i; clarnd_(&q__1, &c__3, &iseed[1]); ctemp.r = q__1.r, ctemp.i = q__1.i; i__3 = z___subscr(n, n); z__[i__3].r = 1.f, z__[i__3].i = 0.f; i__3 = n << 1; work[i__3].r = 0.f, work[i__3].i = 0.f; i__3 = n << 2; r__1 = c_abs(&ctemp); q__1.r = ctemp.r / r__1, q__1.i = ctemp.i / r__1; work[i__3].r = q__1.r, work[i__3].i = q__1.i; /* Apply the diagonal matrices */ i__3 = n; for (jc = 1; jc <= i__3; ++jc) { i__4 = n; for (jr = 1; jr <= i__4; ++jr) { i__5 = a_subscr(jr, jc); i__6 = (n << 1) + jr; r_cnjg(&q__3, &work[n * 3 + jc]); q__2.r = work[i__6].r * q__3.r - work[i__6].i * q__3.i, q__2.i = work[i__6].r * q__3.i + work[i__6].i * q__3.r; i__7 = a_subscr(jr, jc); q__1.r = q__2.r * a[i__7].r - q__2.i * a[i__7].i, q__1.i = q__2.r * a[i__7].i + q__2.i * a[ i__7].r; a[i__5].r = q__1.r, a[i__5].i = q__1.i; i__5 = b_subscr(jr, jc); i__6 = (n << 1) + jr; r_cnjg(&q__3, &work[n * 3 + jc]); q__2.r = work[i__6].r * q__3.r - work[i__6].i * q__3.i, q__2.i = work[i__6].r * q__3.i + work[i__6].i * q__3.r; i__7 = b_subscr(jr, jc); q__1.r = q__2.r * b[i__7].r - q__2.i * b[i__7].i, q__1.i = q__2.r * b[i__7].i + q__2.i * b[ i__7].r; b[i__5].r = q__1.r, b[i__5].i = q__1.i; /* L60: */ } /* L70: */ } i__3 = n - 1; cunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[ 1], &a[a_offset], lda, &work[(n << 1) + 1], & iinfo); if (iinfo != 0) { goto L100; } i__3 = n - 1; cunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, & work[n + 1], &a[a_offset], lda, &work[(n << 1) + 1], &iinfo); if (iinfo != 0) { goto L100; } i__3 = n - 1; cunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[ 1], &b[b_offset], lda, &work[(n << 1) + 1], & iinfo); if (iinfo != 0) { goto L100; } i__3 = n - 1; cunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, & work[n + 1], &b[b_offset], lda, &work[(n << 1) + 1], &iinfo); if (iinfo != 0) { goto L100; } } } else { /* Random matrices */ i__3 = n; for (jc = 1; jc <= i__3; ++jc) { i__4 = n; for (jr = 1; jr <= i__4; ++jr) { i__5 = a_subscr(jr, jc); i__6 = kamagn[jtype - 1]; clarnd_(&q__2, &c__4, &iseed[1]); q__1.r = rmagn[i__6] * q__2.r, q__1.i = rmagn[i__6] * q__2.i; a[i__5].r = q__1.r, a[i__5].i = q__1.i; i__5 = b_subscr(jr, jc); i__6 = kbmagn[jtype - 1]; clarnd_(&q__2, &c__4, &iseed[1]); q__1.r = rmagn[i__6] * q__2.r, q__1.i = rmagn[i__6] * q__2.i; b[i__5].r = q__1.r, b[i__5].i = q__1.i; /* L80: */ } /* L90: */ } } L100: if (iinfo != 0) { io___43.ciunit = *nounit; s_wsfe(&io___43); do_fio(&c__1, "Generator", (ftnlen)9); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); return 0; } L110: /* Call CGEGS to compute H, T, Q, Z, alpha, and beta. */ clacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda); clacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda); ntest = 1; result[1] = ulpinv; cgegs_("V", "V", &n, &s[s_offset], lda, &t[t_offset], lda, & alpha1[1], &beta1[1], &q[q_offset], ldq, &z__[z_offset], ldq, &work[1], lwork, &rwork[1], &iinfo); if (iinfo != 0) { io___44.ciunit = *nounit; s_wsfe(&io___44); do_fio(&c__1, "CGEGS", (ftnlen)5); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); goto L130; } ntest = 4; /* Do tests 1--4 */ cget51_(&c__1, &n, &a[a_offset], lda, &s[s_offset], lda, &q[ q_offset], ldq, &z__[z_offset], ldq, &work[1], &rwork[1], &result[1]); cget51_(&c__1, &n, &b[b_offset], lda, &t[t_offset], lda, &q[ q_offset], ldq, &z__[z_offset], ldq, &work[1], &rwork[1], &result[2]); cget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &q[ q_offset], ldq, &q[q_offset], ldq, &work[1], &rwork[1], & result[3]); cget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &z__[ z_offset], ldq, &z__[z_offset], ldq, &work[1], &rwork[1], &result[4]); /* Do test 5: compare eigenvalues with diagonals. */ temp1 = 0.f; i__3 = n; for (j = 1; j <= i__3; ++j) { i__4 = j; i__5 = s_subscr(j, j); q__2.r = alpha1[i__4].r - s[i__5].r, q__2.i = alpha1[i__4].i - s[i__5].i; q__1.r = q__2.r, q__1.i = q__2.i; i__6 = j; i__7 = t_subscr(j, j); q__4.r = beta1[i__6].r - t[i__7].r, q__4.i = beta1[i__6].i - t[i__7].i; q__3.r = q__4.r, q__3.i = q__4.i; /* Computing MAX */ i__8 = j; i__9 = s_subscr(j, j); r__13 = safmin, r__14 = (r__1 = alpha1[i__8].r, dabs(r__1)) + (r__2 = r_imag(&alpha1[j]), dabs(r__2)), r__13 = max( r__13,r__14), r__14 = (r__3 = s[i__9].r, dabs(r__3)) + (r__4 = r_imag(&s_ref(j, j)), dabs(r__4)); /* Computing MAX */ i__10 = j; i__11 = t_subscr(j, j); r__15 = safmin, r__16 = (r__5 = beta1[i__10].r, dabs(r__5)) + (r__6 = r_imag(&beta1[j]), dabs(r__6)), r__15 = max( r__15,r__16), r__16 = (r__7 = t[i__11].r, dabs(r__7)) + (r__8 = r_imag(&t_ref(j, j)), dabs(r__8)); temp2 = (((r__9 = q__1.r, dabs(r__9)) + (r__10 = r_imag(&q__1) , dabs(r__10))) / dmax(r__13,r__14) + ((r__11 = q__3.r, dabs(r__11)) + (r__12 = r_imag(&q__3), dabs( r__12))) / dmax(r__15,r__16)) / ulp; temp1 = dmax(temp1,temp2); /* L120: */ } result[5] = temp1; /* Call CGEGV to compute S2, T2, VL, and VR, do tests. Eigenvalues and Eigenvectors */ clacpy_(" ", &n, &n, &a[a_offset], lda, &s2[s2_offset], lda); clacpy_(" ", &n, &n, &b[b_offset], lda, &t2[t2_offset], lda); ntest = 6; result[6] = ulpinv; cgegv_("V", "V", &n, &s2[s2_offset], lda, &t2[t2_offset], lda, & alpha2[1], &beta2[1], &vl[vl_offset], ldq, &vr[vr_offset], ldq, &work[1], lwork, &rwork[1], &iinfo); if (iinfo != 0) { io___47.ciunit = *nounit; s_wsfe(&io___47); do_fio(&c__1, "CGEGV", (ftnlen)5); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); goto L130; } ntest = 7; /* Do Tests 6 and 7 */ cget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &vl[ vl_offset], ldq, &alpha2[1], &beta2[1], &work[1], &rwork[ 1], dumma); result[6] = dumma[0]; if (dumma[1] > *thrshn) { io___49.ciunit = *nounit; s_wsfe(&io___49); do_fio(&c__1, "Left", (ftnlen)4); do_fio(&c__1, "CGEGV", (ftnlen)5); do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); } cget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &vr[ vr_offset], ldq, &alpha2[1], &beta2[1], &work[1], &rwork[ 1], dumma); result[7] = dumma[0]; if (dumma[1] > *thresh) { io___50.ciunit = *nounit; s_wsfe(&io___50); do_fio(&c__1, "Right", (ftnlen)5); do_fio(&c__1, "CGEGV", (ftnlen)5); do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); } /* End of Loop -- Check for RESULT(j) > THRESH */ L130: ntestt += ntest; /* Print out tests which fail. */ i__3 = ntest; for (jr = 1; jr <= i__3; ++jr) { if (result[jr] >= *thresh) { /* If this is the first test to fail, print a header to the data file. */ if (nerrs == 0) { io___51.ciunit = *nounit; s_wsfe(&io___51); do_fio(&c__1, "CGG", (ftnlen)3); e_wsfe(); /* Matrix types */ io___52.ciunit = *nounit; s_wsfe(&io___52); e_wsfe(); io___53.ciunit = *nounit; s_wsfe(&io___53); e_wsfe(); io___54.ciunit = *nounit; s_wsfe(&io___54); do_fio(&c__1, "Unitary", (ftnlen)7); e_wsfe(); /* Tests performed */ io___55.ciunit = *nounit; s_wsfe(&io___55); do_fio(&c__1, "unitary", (ftnlen)7); do_fio(&c__1, "*", (ftnlen)1); do_fio(&c__1, "conjugate transpose", (ftnlen)19); for (j = 1; j <= 5; ++j) { do_fio(&c__1, "*", (ftnlen)1); } e_wsfe(); } ++nerrs; if (result[jr] < 1e4f) { io___56.ciunit = *nounit; s_wsfe(&io___56); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)) ; do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof( integer)); do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof( real)); e_wsfe(); } else { io___57.ciunit = *nounit; s_wsfe(&io___57); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)) ; do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof( integer)); do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof( real)); e_wsfe(); } } /* L140: */ } L150: ; } /* L160: */ } /* Summary */ alasvm_("CGG", nounit, &nerrs, &ntestt, &c__0); return 0; /* End of CDRVGG */ } /* cdrvgg_ */
/* Subroutine */ int zgghrd_(char *compq, char *compz, integer *n, integer * ilo, integer *ihi, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *q, integer *ldq, doublecomplex *z__, integer *ldz, integer *info) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, z_offset, i__1, i__2, i__3; doublecomplex z__1; /* Builtin functions */ void d_cnjg(doublecomplex *, doublecomplex *); /* Local variables */ static integer jcol; static doublereal temp; static integer jrow; extern /* Subroutine */ int zrot_(integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublereal *, doublecomplex *); static doublereal c__; static doublecomplex s; extern logical lsame_(char *, char *); static doublecomplex ctemp; extern /* Subroutine */ int xerbla_(char *, integer *); static integer icompq, icompz; extern /* Subroutine */ int zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlartg_(doublecomplex *, doublecomplex *, doublereal *, doublecomplex *, doublecomplex *); static logical ilq, ilz; #define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1 #define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)] #define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1 #define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)] #define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1 #define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)] #define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1 #define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)] /* -- LAPACK routine (instrumented to count operations, version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 ---------------------- Begin Timing Code ------------------------- Common block to return operation count and iteration count ITCNT is initialized to 0, OPS is only incremented OPST is used to accumulate small contributions to OPS to avoid roundoff error ----------------------- End Timing Code -------------------------- Purpose ======= ZGGHRD reduces a pair of complex matrices (A,B) to generalized upper Hessenberg form using unitary transformations, where A is a general matrix and B is upper triangular: Q' * A * Z = H and Q' * B * Z = T, where H is upper Hessenberg, T is upper triangular, and Q and Z are unitary, and ' means conjugate transpose. The unitary matrices Q and Z are determined as products of Givens rotations. They may either be formed explicitly, or they may be postmultiplied into input matrices Q1 and Z1, so that Q1 * A * Z1' = (Q1*Q) * H * (Z1*Z)' Q1 * B * Z1' = (Q1*Q) * T * (Z1*Z)' Arguments ========= COMPQ (input) CHARACTER*1 = 'N': do not compute Q; = 'I': Q is initialized to the unit matrix, and the unitary matrix Q is returned; = 'V': Q must contain a unitary matrix Q1 on entry, and the product Q1*Q is returned. COMPZ (input) CHARACTER*1 = 'N': do not compute Q; = 'I': Q is initialized to the unit matrix, and the unitary matrix Q is returned; = 'V': Q must contain a unitary matrix Q1 on entry, and the product Q1*Q is returned. N (input) INTEGER The order of the matrices A and B. N >= 0. ILO (input) INTEGER IHI (input) INTEGER It is assumed that A 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 ZGGBAL; otherwise they should be set to 1 and N respectively. 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. A (input/output) COMPLEX*16 array, dimension (LDA, N) On entry, the N-by-N general matrix to be reduced. On exit, the upper triangle and the first subdiagonal of A are overwritten with the upper Hessenberg matrix H, and the rest is set to zero. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,N). B (input/output) COMPLEX*16 array, dimension (LDB, N) On entry, the N-by-N upper triangular matrix B. On exit, the upper triangular matrix T = Q' B Z. The elements below the diagonal are set to zero. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,N). Q (input/output) COMPLEX*16 array, dimension (LDQ, N) If COMPQ='N': Q is not referenced. If COMPQ='I': on entry, Q need not be set, and on exit it contains the unitary matrix Q, where Q' is the product of the Givens transformations which are applied to A and B on the left. If COMPQ='V': on entry, Q must contain a unitary matrix Q1, and on exit this is overwritten by Q1*Q. LDQ (input) INTEGER The leading dimension of the array Q. LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. Z (input/output) COMPLEX*16 array, dimension (LDZ, N) If COMPZ='N': Z is not referenced. If COMPZ='I': on entry, Z need not be set, and on exit it contains the unitary matrix Z, which is the product of the Givens transformations which are applied to A and B on the right. If COMPZ='V': on entry, Z must contain a unitary matrix Z1, and on exit this is overwritten by Z1*Z. LDZ (input) INTEGER The leading dimension of the array Z. LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise. INFO (output) INTEGER = 0: successful exit. < 0: if INFO = -i, the i-th argument had an illegal value. Further Details =============== This routine reduces A to Hessenberg and B to triangular form by an unblocked reduction, as described in _Matrix_Computations_, by Golub and van Loan (Johns Hopkins Press). ===================================================================== Decode COMPQ Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; q_dim1 = *ldq; q_offset = 1 + q_dim1 * 1; q -= q_offset; z_dim1 = *ldz; z_offset = 1 + z_dim1 * 1; z__ -= z_offset; /* Function Body */ if (lsame_(compq, "N")) { ilq = FALSE_; icompq = 1; } else if (lsame_(compq, "V")) { ilq = TRUE_; icompq = 2; } else if (lsame_(compq, "I")) { ilq = TRUE_; icompq = 3; } else { icompq = 0; } /* Decode COMPZ */ if (lsame_(compz, "N")) { ilz = FALSE_; icompz = 1; } else if (lsame_(compz, "V")) { ilz = TRUE_; icompz = 2; } else if (lsame_(compz, "I")) { ilz = TRUE_; icompz = 3; } else { icompz = 0; } /* Test the input parameters. */ *info = 0; if (icompq <= 0) { *info = -1; } else if (icompz <= 0) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*ilo < 1) { *info = -4; } else if (*ihi > *n || *ihi < *ilo - 1) { *info = -5; } else if (*lda < max(1,*n)) { *info = -7; } else if (*ldb < max(1,*n)) { *info = -9; } else if (ilq && *ldq < *n || *ldq < 1) { *info = -11; } else if (ilz && *ldz < *n || *ldz < 1) { *info = -13; } if (*info != 0) { i__1 = -(*info); xerbla_("ZGGHRD", &i__1); return 0; } /* Initialize Q and Z if desired. */ if (icompq == 3) { zlaset_("Full", n, n, &c_b2, &c_b1, &q[q_offset], ldq); } if (icompz == 3) { zlaset_("Full", n, n, &c_b2, &c_b1, &z__[z_offset], ldz); } /* Quick return if possible */ if (*n <= 1) { return 0; } /* Zero out lower triangle of B */ i__1 = *n - 1; for (jcol = 1; jcol <= i__1; ++jcol) { i__2 = *n; for (jrow = jcol + 1; jrow <= i__2; ++jrow) { i__3 = b_subscr(jrow, jcol); b[i__3].r = 0., b[i__3].i = 0.; /* L10: */ } /* L20: */ } /* Reduce A and B */ i__1 = *ihi - 2; for (jcol = *ilo; jcol <= i__1; ++jcol) { i__2 = jcol + 2; for (jrow = *ihi; jrow >= i__2; --jrow) { /* Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL) */ i__3 = a_subscr(jrow - 1, jcol); ctemp.r = a[i__3].r, ctemp.i = a[i__3].i; zlartg_(&ctemp, &a_ref(jrow, jcol), &c__, &s, &a_ref(jrow - 1, jcol)); i__3 = a_subscr(jrow, jcol); a[i__3].r = 0., a[i__3].i = 0.; i__3 = *n - jcol; zrot_(&i__3, &a_ref(jrow - 1, jcol + 1), lda, &a_ref(jrow, jcol + 1), lda, &c__, &s); i__3 = *n + 2 - jrow; zrot_(&i__3, &b_ref(jrow - 1, jrow - 1), ldb, &b_ref(jrow, jrow - 1), ldb, &c__, &s); if (ilq) { d_cnjg(&z__1, &s); zrot_(n, &q_ref(1, jrow - 1), &c__1, &q_ref(1, jrow), &c__1, & c__, &z__1); } /* Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1) */ i__3 = b_subscr(jrow, jrow); ctemp.r = b[i__3].r, ctemp.i = b[i__3].i; zlartg_(&ctemp, &b_ref(jrow, jrow - 1), &c__, &s, &b_ref(jrow, jrow)); i__3 = b_subscr(jrow, jrow - 1); b[i__3].r = 0., b[i__3].i = 0.; zrot_(ihi, &a_ref(1, jrow), &c__1, &a_ref(1, jrow - 1), &c__1, & c__, &s); i__3 = jrow - 1; zrot_(&i__3, &b_ref(1, jrow), &c__1, &b_ref(1, jrow - 1), &c__1, & c__, &s); if (ilz) { zrot_(n, &z___ref(1, jrow), &c__1, &z___ref(1, jrow - 1), & c__1, &c__, &s); } /* L30: */ } /* L40: */ } /* ---------------------- Begin Timing Code ------------------------- Operation count: factor * number of calls to ZLARTG TEMP *32 * total number of rows/cols rotated in A and B TEMP*[6n + 2(ihi-ilo) + 5]/6 *20 * rows rotated in Q TEMP*n/2 *20 * rows rotated in Z TEMP*n/2 *20 */ temp = (doublereal) (*ihi - *ilo) * (doublereal) (*ihi - *ilo - 1); jrow = *n * 20 + (*ihi - *ilo) * 7 + 59; if (ilq) { jrow += *n * 10; } if (ilz) { jrow += *n * 10; } latime_1.ops += ((doublereal) jrow - (doublereal) (*ihi - *ilo + 1) / 3.) * temp; latime_1.itcnt = 0.; /* ----------------------- End Timing Code -------------------------- */ return 0; /* End of ZGGHRD */ } /* zgghrd_ */
/* Subroutine */ int slaed0_(integer *icompq, integer *qsiz, integer *n, real *d__, real *e, real *q, integer *ldq, real *qstore, integer *ldqs, real *work, integer *iwork, integer *info) { /* System generated locals */ integer q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2; real r__1; /* Builtin functions */ double log(doublereal); integer pow_ii(integer *, integer *); /* Local variables */ static real temp; static integer curr, i__, j, k; extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *); static integer iperm, indxq, iwrem; extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, integer *); static integer iqptr, tlvls; extern /* Subroutine */ int slaed1_(integer *, real *, real *, integer *, integer *, real *, integer *, real *, integer *, integer *), slaed7_(integer *, integer *, integer *, integer *, integer *, integer *, real *, real *, integer *, integer *, real *, integer * , real *, integer *, integer *, integer *, integer *, integer *, real *, real *, integer *, integer *); static integer iq, igivcl; extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *); static integer igivnm, submat; extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *); static integer curprb, subpbs, igivpt, curlvl, matsiz, iprmpt, smlsiz; extern /* Subroutine */ int ssteqr_(char *, integer *, real *, real *, real *, integer *, real *, integer *); static integer lgn, msd2, smm1, spm1, spm2; #define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1] #define qstore_ref(a_1,a_2) qstore[(a_2)*qstore_dim1 + a_1] /* -- LAPACK routine (instrumented to count operations, version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University June 30, 1999 Common block to return operation count and iteration count ITCNT is unchanged, OPS is only incremented Purpose ======= SLAED0 computes all eigenvalues and corresponding eigenvectors of a symmetric tridiagonal matrix using the divide and conquer method. Arguments ========= ICOMPQ (input) INTEGER = 0: Compute eigenvalues only. = 1: Compute eigenvectors of original dense symmetric matrix also. On entry, Q contains the orthogonal matrix used to reduce the original matrix to tridiagonal form. = 2: Compute eigenvalues and eigenvectors of tridiagonal matrix. QSIZ (input) INTEGER The dimension of the orthogonal matrix used to reduce the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. N (input) INTEGER The dimension of the symmetric tridiagonal matrix. N >= 0. D (input/output) REAL array, dimension (N) On entry, the main diagonal of the tridiagonal matrix. On exit, its eigenvalues. E (input) REAL array, dimension (N-1) The off-diagonal elements of the tridiagonal matrix. On exit, E has been destroyed. Q (input/output) REAL array, dimension (LDQ, N) On entry, Q must contain an N-by-N orthogonal matrix. If ICOMPQ = 0 Q is not referenced. If ICOMPQ = 1 On entry, Q is a subset of the columns of the orthogonal matrix used to reduce the full matrix to tridiagonal form corresponding to the subset of the full matrix which is being decomposed at this time. If ICOMPQ = 2 On entry, Q will be the identity matrix. On exit, Q contains the eigenvectors of the tridiagonal matrix. LDQ (input) INTEGER The leading dimension of the array Q. If eigenvectors are desired, then LDQ >= max(1,N). In any case, LDQ >= 1. QSTORE (workspace) REAL array, dimension (LDQS, N) Referenced only when ICOMPQ = 1. Used to store parts of the eigenvector matrix when the updating matrix multiplies take place. LDQS (input) INTEGER The leading dimension of the array QSTORE. If ICOMPQ = 1, then LDQS >= max(1,N). In any case, LDQS >= 1. WORK (workspace) REAL array, If ICOMPQ = 0 or 1, the dimension of WORK must be at least 1 + 3*N + 2*N*lg N + 2*N**2 ( lg( N ) = smallest integer k such that 2^k >= N ) If ICOMPQ = 2, the dimension of WORK must be at least 4*N + N**2. IWORK (workspace) INTEGER array, If ICOMPQ = 0 or 1, the dimension of IWORK must be at least 6 + 6*N + 5*N*lg N. ( lg( N ) = smallest integer k such that 2^k >= N ) If ICOMPQ = 2, the dimension of IWORK must be at least 3 + 5*N. INFO (output) INTEGER = 0: successful exit. < 0: if INFO = -i, the i-th argument had an illegal value. > 0: The algorithm failed to compute an eigenvalue while working on the submatrix lying in rows and columns INFO/(N+1) through mod(INFO,N+1). Further Details =============== Based on contributions by Jeff Rutter, Computer Science Division, University of California at Berkeley, USA ===================================================================== Test the input parameters. Parameter adjustments */ --d__; --e; q_dim1 = *ldq; q_offset = 1 + q_dim1 * 1; q -= q_offset; qstore_dim1 = *ldqs; qstore_offset = 1 + qstore_dim1 * 1; qstore -= qstore_offset; --work; --iwork; /* Function Body */ *info = 0; if (*icompq < 0 || *icompq > 2) { *info = -1; } else if (*icompq == 1 && *qsiz < max(0,*n)) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*ldq < max(1,*n)) { *info = -7; } else if (*ldqs < max(1,*n)) { *info = -9; } if (*info != 0) { i__1 = -(*info); xerbla_("SLAED0", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } smlsiz = ilaenv_(&c__9, "SLAED0", " ", &c__0, &c__0, &c__0, &c__0, ( ftnlen)6, (ftnlen)1); /* Determine the size and placement of the submatrices, and save in the leading elements of IWORK. */ iwork[1] = *n; subpbs = 1; tlvls = 0; L10: if (iwork[subpbs] > smlsiz) { for (j = subpbs; j >= 1; --j) { iwork[j * 2] = (iwork[j] + 1) / 2; iwork[(j << 1) - 1] = iwork[j] / 2; /* L20: */ } ++tlvls; subpbs <<= 1; goto L10; } i__1 = subpbs; for (j = 2; j <= i__1; ++j) { iwork[j] += iwork[j - 1]; /* L30: */ } /* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1 using rank-1 modifications (cuts). */ spm1 = subpbs - 1; latime_1.ops += spm1 << 1; i__1 = spm1; for (i__ = 1; i__ <= i__1; ++i__) { submat = iwork[i__] + 1; smm1 = submat - 1; d__[smm1] -= (r__1 = e[smm1], dabs(r__1)); d__[submat] -= (r__1 = e[smm1], dabs(r__1)); /* L40: */ } indxq = (*n << 2) + 3; if (*icompq != 2) { /* Set up workspaces for eigenvalues only/accumulate new vectors routine */ latime_1.ops += 3; temp = log((real) (*n)) / log(2.f); lgn = (integer) temp; if (pow_ii(&c__2, &lgn) < *n) { ++lgn; } if (pow_ii(&c__2, &lgn) < *n) { ++lgn; } iprmpt = indxq + *n + 1; iperm = iprmpt + *n * lgn; iqptr = iperm + *n * lgn; igivpt = iqptr + *n + 2; igivcl = igivpt + *n * lgn; igivnm = 1; iq = igivnm + (*n << 1) * lgn; /* Computing 2nd power */ i__1 = *n; iwrem = iq + i__1 * i__1 + 1; /* Initialize pointers */ i__1 = subpbs; for (i__ = 0; i__ <= i__1; ++i__) { iwork[iprmpt + i__] = 1; iwork[igivpt + i__] = 1; /* L50: */ } iwork[iqptr] = 1; } /* Solve each submatrix eigenproblem at the bottom of the divide and conquer tree. */ curr = 0; i__1 = spm1; for (i__ = 0; i__ <= i__1; ++i__) { if (i__ == 0) { submat = 1; matsiz = iwork[1]; } else { submat = iwork[i__] + 1; matsiz = iwork[i__ + 1] - iwork[i__]; } if (*icompq == 2) { ssteqr_("I", &matsiz, &d__[submat], &e[submat], &q_ref(submat, submat), ldq, &work[1], info); if (*info != 0) { goto L130; } } else { ssteqr_("I", &matsiz, &d__[submat], &e[submat], &work[iq - 1 + iwork[iqptr + curr]], &matsiz, &work[1], info); if (*info != 0) { goto L130; } if (*icompq == 1) { latime_1.ops += (real) (*qsiz) * 2 * matsiz * matsiz; sgemm_("N", "N", qsiz, &matsiz, &matsiz, &c_b23, &q_ref(1, submat), ldq, &work[iq - 1 + iwork[iqptr + curr]], & matsiz, &c_b24, &qstore_ref(1, submat), ldqs); } /* Computing 2nd power */ i__2 = matsiz; iwork[iqptr + curr + 1] = iwork[iqptr + curr] + i__2 * i__2; ++curr; } k = 1; i__2 = iwork[i__ + 1]; for (j = submat; j <= i__2; ++j) { iwork[indxq + j] = k; ++k; /* L60: */ } /* L70: */ } /* Successively merge eigensystems of adjacent submatrices into eigensystem for the corresponding larger matrix. while ( SUBPBS > 1 ) */ curlvl = 1; L80: if (subpbs > 1) { spm2 = subpbs - 2; i__1 = spm2; for (i__ = 0; i__ <= i__1; i__ += 2) { if (i__ == 0) { submat = 1; matsiz = iwork[2]; msd2 = iwork[1]; curprb = 0; } else { submat = iwork[i__] + 1; matsiz = iwork[i__ + 2] - iwork[i__]; msd2 = matsiz / 2; ++curprb; } /* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2) into an eigensystem of size MATSIZ. SLAED1 is used only for the full eigensystem of a tridiagonal matrix. SLAED7 handles the cases in which eigenvalues only or eigenvalues and eigenvectors of a full symmetric matrix (which was reduced to tridiagonal form) are desired. */ if (*icompq == 2) { slaed1_(&matsiz, &d__[submat], &q_ref(submat, submat), ldq, & iwork[indxq + submat], &e[submat + msd2 - 1], &msd2, & work[1], &iwork[subpbs + 1], info); } else { slaed7_(icompq, &matsiz, qsiz, &tlvls, &curlvl, &curprb, &d__[ submat], &qstore_ref(1, submat), ldqs, &iwork[indxq + submat], &e[submat + msd2 - 1], &msd2, &work[iq], & iwork[iqptr], &iwork[iprmpt], &iwork[iperm], &iwork[ igivpt], &iwork[igivcl], &work[igivnm], &work[iwrem], &iwork[subpbs + 1], info); } if (*info != 0) { goto L130; } iwork[i__ / 2 + 1] = iwork[i__ + 2]; /* L90: */ } subpbs /= 2; ++curlvl; goto L80; } /* end while Re-merge the eigenvalues/vectors which were deflated at the final merge step. */ if (*icompq == 1) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { j = iwork[indxq + i__]; work[i__] = d__[j]; scopy_(qsiz, &qstore_ref(1, j), &c__1, &q_ref(1, i__), &c__1); /* L100: */ } scopy_(n, &work[1], &c__1, &d__[1], &c__1); } else if (*icompq == 2) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { j = iwork[indxq + i__]; work[i__] = d__[j]; scopy_(n, &q_ref(1, j), &c__1, &work[*n * i__ + 1], &c__1); /* L110: */ } scopy_(n, &work[1], &c__1, &d__[1], &c__1); slacpy_("A", n, n, &work[*n + 1], n, &q[q_offset], ldq); } else { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { j = iwork[indxq + i__]; work[i__] = d__[j]; /* L120: */ } scopy_(n, &work[1], &c__1, &d__[1], &c__1); } goto L140; L130: *info = submat * (*n + 1) + submat + matsiz - 1; L140: return 0; /* End of SLAED0 */ } /* slaed0_ */
/* Subroutine */ int ctrexc_(char *compq, integer *n, complex *t, integer * ldt, complex *q, integer *ldq, integer *ifst, integer *ilst, integer * info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University March 31, 1993 Purpose ======= CTREXC reorders the Schur factorization of a complex matrix A = Q*T*Q**H, so that the diagonal element of T with row index IFST is moved to row ILST. The Schur form T is reordered by a unitary similarity transformation Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by postmultplying it with Z. Arguments ========= COMPQ (input) CHARACTER*1 = 'V': update the matrix Q of Schur vectors; = 'N': do not update Q. N (input) INTEGER The order of the matrix T. N >= 0. T (input/output) COMPLEX array, dimension (LDT,N) On entry, the upper triangular matrix T. On exit, the reordered upper triangular matrix. LDT (input) INTEGER The leading dimension of the array T. LDT >= max(1,N). Q (input/output) COMPLEX array, dimension (LDQ,N) On entry, if COMPQ = 'V', the matrix Q of Schur vectors. On exit, if COMPQ = 'V', Q has been postmultiplied by the unitary transformation matrix Z which reorders T. If COMPQ = 'N', Q is not referenced. LDQ (input) INTEGER The leading dimension of the array Q. LDQ >= max(1,N). IFST (input) INTEGER ILST (input) INTEGER Specify the reordering of the diagonal elements of T: The element with row index IFST is moved to row ILST by a sequence of transpositions between adjacent elements. 1 <= IFST <= N; 1 <= ILST <= N. INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value ===================================================================== Decode and test the input parameters. Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; /* System generated locals */ integer q_dim1, q_offset, t_dim1, t_offset, i__1, i__2, i__3; complex q__1; /* Builtin functions */ void r_cnjg(complex *, complex *); /* Local variables */ static complex temp; extern /* Subroutine */ int crot_(integer *, complex *, integer *, complex *, integer *, real *, complex *); static integer k; extern logical lsame_(char *, char *); static logical wantq; static integer m1, m2, m3; static real cs; static complex t11, t22, sn; extern /* Subroutine */ int clartg_(complex *, complex *, real *, complex *, complex *), xerbla_(char *, integer *); #define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1 #define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)] #define t_subscr(a_1,a_2) (a_2)*t_dim1 + a_1 #define t_ref(a_1,a_2) t[t_subscr(a_1,a_2)] t_dim1 = *ldt; t_offset = 1 + t_dim1 * 1; t -= t_offset; q_dim1 = *ldq; q_offset = 1 + q_dim1 * 1; q -= q_offset; /* Function Body */ *info = 0; wantq = lsame_(compq, "V"); if (! lsame_(compq, "N") && ! wantq) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*ldt < max(1,*n)) { *info = -4; } else if (*ldq < 1 || wantq && *ldq < max(1,*n)) { *info = -6; } else if (*ifst < 1 || *ifst > *n) { *info = -7; } else if (*ilst < 1 || *ilst > *n) { *info = -8; } if (*info != 0) { i__1 = -(*info); xerbla_("CTREXC", &i__1); return 0; } /* Quick return if possible */ if (*n == 1 || *ifst == *ilst) { return 0; } if (*ifst < *ilst) { /* Move the IFST-th diagonal element forward down the diagonal. */ m1 = 0; m2 = -1; m3 = 1; } else { /* Move the IFST-th diagonal element backward up the diagonal. */ m1 = -1; m2 = 0; m3 = -1; } i__1 = *ilst + m2; i__2 = m3; for (k = *ifst + m1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) { /* Interchange the k-th and (k+1)-th diagonal elements. */ i__3 = t_subscr(k, k); t11.r = t[i__3].r, t11.i = t[i__3].i; i__3 = t_subscr(k + 1, k + 1); t22.r = t[i__3].r, t22.i = t[i__3].i; /* Determine the transformation to perform the interchange. */ q__1.r = t22.r - t11.r, q__1.i = t22.i - t11.i; clartg_(&t_ref(k, k + 1), &q__1, &cs, &sn, &temp); /* Apply transformation to the matrix T. */ if (k + 2 <= *n) { i__3 = *n - k - 1; crot_(&i__3, &t_ref(k, k + 2), ldt, &t_ref(k + 1, k + 2), ldt, & cs, &sn); } i__3 = k - 1; r_cnjg(&q__1, &sn); crot_(&i__3, &t_ref(1, k), &c__1, &t_ref(1, k + 1), &c__1, &cs, &q__1) ; i__3 = t_subscr(k, k); t[i__3].r = t22.r, t[i__3].i = t22.i; i__3 = t_subscr(k + 1, k + 1); t[i__3].r = t11.r, t[i__3].i = t11.i; if (wantq) { /* Accumulate transformation in the matrix Q. */ r_cnjg(&q__1, &sn); crot_(n, &q_ref(1, k), &c__1, &q_ref(1, k + 1), &c__1, &cs, &q__1) ; } /* L10: */ } return 0; /* End of CTREXC */ } /* ctrexc_ */
/* Subroutine */ int zlaed8_(integer *k, integer *n, integer *qsiz, doublecomplex *q, integer *ldq, doublereal *d__, doublereal *rho, integer *cutpnt, doublereal *z__, doublereal *dlamda, doublecomplex * q2, integer *ldq2, doublereal *w, integer *indxp, integer *indx, integer *indxq, integer *perm, integer *givptr, integer *givcol, doublereal *givnum, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, Courant Institute, NAG Ltd., and Rice University September 30, 1994 Purpose ======= ZLAED8 merges the two sets of eigenvalues together into a single sorted set. Then it tries to deflate the size of the problem. There are two ways in which deflation can occur: when two or more eigenvalues are close together or if there is a tiny element in the Z vector. For each such occurrence the order of the related secular equation problem is reduced by one. Arguments ========= K (output) INTEGER Contains the number of non-deflated eigenvalues. This is the order of the related secular equation. N (input) INTEGER The dimension of the symmetric tridiagonal matrix. N >= 0. QSIZ (input) INTEGER The dimension of the unitary matrix used to reduce the dense or band matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. Q (input/output) COMPLEX*16 array, dimension (LDQ,N) On entry, Q contains the eigenvectors of the partially solved system which has been previously updated in matrix multiplies with other partially solved eigensystems. On exit, Q contains the trailing (N-K) updated eigenvectors (those which were deflated) in its last N-K columns. LDQ (input) INTEGER The leading dimension of the array Q. LDQ >= max( 1, N ). D (input/output) DOUBLE PRECISION array, dimension (N) On entry, D contains the eigenvalues of the two submatrices to be combined. On exit, D contains the trailing (N-K) updated eigenvalues (those which were deflated) sorted into increasing order. RHO (input/output) DOUBLE PRECISION Contains the off diagonal element associated with the rank-1 cut which originally split the two submatrices which are now being recombined. RHO is modified during the computation to the value required by DLAED3. CUTPNT (input) INTEGER Contains the location of the last eigenvalue in the leading sub-matrix. MIN(1,N) <= CUTPNT <= N. Z (input) DOUBLE PRECISION array, dimension (N) On input this vector contains the updating vector (the last row of the first sub-eigenvector matrix and the first row of the second sub-eigenvector matrix). The contents of Z are destroyed during the updating process. DLAMDA (output) DOUBLE PRECISION array, dimension (N) Contains a copy of the first K eigenvalues which will be used by DLAED3 to form the secular equation. Q2 (output) COMPLEX*16 array, dimension (LDQ2,N) If ICOMPQ = 0, Q2 is not referenced. Otherwise, Contains a copy of the first K eigenvectors which will be used by DLAED7 in a matrix multiply (DGEMM) to update the new eigenvectors. LDQ2 (input) INTEGER The leading dimension of the array Q2. LDQ2 >= max( 1, N ). W (output) DOUBLE PRECISION array, dimension (N) This will hold the first k values of the final deflation-altered z-vector and will be passed to DLAED3. INDXP (workspace) INTEGER array, dimension (N) This will contain the permutation used to place deflated values of D at the end of the array. On output INDXP(1:K) points to the nondeflated D-values and INDXP(K+1:N) points to the deflated eigenvalues. INDX (workspace) INTEGER array, dimension (N) This will contain the permutation used to sort the contents of D into ascending order. INDXQ (input) INTEGER array, dimension (N) This contains the permutation which separately sorts the two sub-problems in D into ascending order. Note that elements in the second half of this permutation must first have CUTPNT added to their values in order to be accurate. PERM (output) INTEGER array, dimension (N) Contains the permutations (from deflation and sorting) to be applied to each eigenblock. GIVPTR (output) INTEGER Contains the number of Givens rotations which took place in this subproblem. GIVCOL (output) INTEGER array, dimension (2, N) Each pair of numbers indicates a pair of columns to take place in a Givens rotation. GIVNUM (output) DOUBLE PRECISION array, dimension (2, N) Each number indicates the S value to be used in the corresponding Givens rotation. INFO (output) INTEGER = 0: successful exit. < 0: if INFO = -i, the i-th argument had an illegal value. ===================================================================== Test the input parameters. Parameter adjustments */ /* Table of constant values */ static doublereal c_b3 = -1.; static integer c__1 = 1; /* System generated locals */ integer q_dim1, q_offset, q2_dim1, q2_offset, i__1; doublereal d__1; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static integer jlam, imax, jmax; static doublereal c__; static integer i__, j; static doublereal s, t; extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, integer *), dcopy_(integer *, doublereal *, integer *, doublereal *, integer *); static integer k2, n1, n2; extern /* Subroutine */ int zdrot_(integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublereal *, doublereal *), zcopy_( integer *, doublecomplex *, integer *, doublecomplex *, integer *) ; extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *); static integer jp; extern integer idamax_(integer *, doublereal *, integer *); extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, integer *, integer *, integer *), xerbla_(char *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); static integer n1p1; static doublereal eps, tau, tol; #define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1 #define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)] #define q2_subscr(a_1,a_2) (a_2)*q2_dim1 + a_1 #define q2_ref(a_1,a_2) q2[q2_subscr(a_1,a_2)] #define givcol_ref(a_1,a_2) givcol[(a_2)*2 + a_1] #define givnum_ref(a_1,a_2) givnum[(a_2)*2 + a_1] q_dim1 = *ldq; q_offset = 1 + q_dim1 * 1; q -= q_offset; --d__; --z__; --dlamda; q2_dim1 = *ldq2; q2_offset = 1 + q2_dim1 * 1; q2 -= q2_offset; --w; --indxp; --indx; --indxq; --perm; givcol -= 3; givnum -= 3; /* Function Body */ *info = 0; if (*n < 0) { *info = -2; } else if (*qsiz < *n) { *info = -3; } else if (*ldq < max(1,*n)) { *info = -5; } else if (*cutpnt < min(1,*n) || *cutpnt > *n) { *info = -8; } else if (*ldq2 < max(1,*n)) { *info = -12; } if (*info != 0) { i__1 = -(*info); xerbla_("ZLAED8", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } n1 = *cutpnt; n2 = *n - n1; n1p1 = n1 + 1; if (*rho < 0.) { dscal_(&n2, &c_b3, &z__[n1p1], &c__1); } /* Normalize z so that norm(z) = 1 */ t = 1. / sqrt(2.); i__1 = *n; for (j = 1; j <= i__1; ++j) { indx[j] = j; /* L10: */ } dscal_(n, &t, &z__[1], &c__1); *rho = (d__1 = *rho * 2., abs(d__1)); /* Sort the eigenvalues into increasing order */ i__1 = *n; for (i__ = *cutpnt + 1; i__ <= i__1; ++i__) { indxq[i__] += *cutpnt; /* L20: */ } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { dlamda[i__] = d__[indxq[i__]]; w[i__] = z__[indxq[i__]]; /* L30: */ } i__ = 1; j = *cutpnt + 1; dlamrg_(&n1, &n2, &dlamda[1], &c__1, &c__1, &indx[1]); i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { d__[i__] = dlamda[indx[i__]]; z__[i__] = w[indx[i__]]; /* L40: */ } /* Calculate the allowable deflation tolerance */ imax = idamax_(n, &z__[1], &c__1); jmax = idamax_(n, &d__[1], &c__1); eps = dlamch_("Epsilon"); tol = eps * 8. * (d__1 = d__[jmax], abs(d__1)); /* If the rank-1 modifier is small enough, no more needs to be done -- except to reorganize Q so that its columns correspond with the elements in D. */ if (*rho * (d__1 = z__[imax], abs(d__1)) <= tol) { *k = 0; i__1 = *n; for (j = 1; j <= i__1; ++j) { perm[j] = indxq[indx[j]]; zcopy_(qsiz, &q_ref(1, perm[j]), &c__1, &q2_ref(1, j), &c__1); /* L50: */ } zlacpy_("A", qsiz, n, &q2_ref(1, 1), ldq2, &q_ref(1, 1), ldq); return 0; } /* If there are multiple eigenvalues then the problem deflates. Here the number of equal eigenvalues are found. As each equal eigenvalue is found, an elementary reflector is computed to rotate the corresponding eigensubspace so that the corresponding components of Z are zero in this new basis. */ *k = 0; *givptr = 0; k2 = *n + 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) { /* Deflate due to small z component. */ --k2; indxp[k2] = j; if (j == *n) { goto L100; } } else { jlam = j; goto L70; } /* L60: */ } L70: ++j; if (j > *n) { goto L90; } if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) { /* Deflate due to small z component. */ --k2; indxp[k2] = j; } else { /* Check if eigenvalues are close enough to allow deflation. */ s = z__[jlam]; c__ = z__[j]; /* Find sqrt(a**2+b**2) without overflow or destructive underflow. */ tau = dlapy2_(&c__, &s); t = d__[j] - d__[jlam]; c__ /= tau; s = -s / tau; if ((d__1 = t * c__ * s, abs(d__1)) <= tol) { /* Deflation is possible. */ z__[j] = tau; z__[jlam] = 0.; /* Record the appropriate Givens rotation */ ++(*givptr); givcol_ref(1, *givptr) = indxq[indx[jlam]]; givcol_ref(2, *givptr) = indxq[indx[j]]; givnum_ref(1, *givptr) = c__; givnum_ref(2, *givptr) = s; zdrot_(qsiz, &q_ref(1, indxq[indx[jlam]]), &c__1, &q_ref(1, indxq[ indx[j]]), &c__1, &c__, &s); t = d__[jlam] * c__ * c__ + d__[j] * s * s; d__[j] = d__[jlam] * s * s + d__[j] * c__ * c__; d__[jlam] = t; --k2; i__ = 1; L80: if (k2 + i__ <= *n) { if (d__[jlam] < d__[indxp[k2 + i__]]) { indxp[k2 + i__ - 1] = indxp[k2 + i__]; indxp[k2 + i__] = jlam; ++i__; goto L80; } else { indxp[k2 + i__ - 1] = jlam; } } else { indxp[k2 + i__ - 1] = jlam; } jlam = j; } else { ++(*k); w[*k] = z__[jlam]; dlamda[*k] = d__[jlam]; indxp[*k] = jlam; jlam = j; } } goto L70; L90: /* Record the last eigenvalue. */ ++(*k); w[*k] = z__[jlam]; dlamda[*k] = d__[jlam]; indxp[*k] = jlam; L100: /* Sort the eigenvalues and corresponding eigenvectors into DLAMDA and Q2 respectively. The eigenvalues/vectors which were not deflated go into the first K slots of DLAMDA and Q2 respectively, while those which were deflated go into the last N - K slots. */ i__1 = *n; for (j = 1; j <= i__1; ++j) { jp = indxp[j]; dlamda[j] = d__[jp]; perm[j] = indxq[indx[jp]]; zcopy_(qsiz, &q_ref(1, perm[j]), &c__1, &q2_ref(1, j), &c__1); /* L110: */ } /* The deflated eigenvalues and their corresponding vectors go back into the last N - K slots of D and Q respectively. */ if (*k < *n) { i__1 = *n - *k; dcopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1); i__1 = *n - *k; zlacpy_("A", qsiz, &i__1, &q2_ref(1, *k + 1), ldq2, &q_ref(1, *k + 1), ldq); } return 0; /* End of ZLAED8 */ } /* zlaed8_ */
/* Subroutine */ int dtgsja_(char *jobu, char *jobv, char *jobq, integer *m, integer *p, integer *n, integer *k, integer *l, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *tola, doublereal *tolb, doublereal *alpha, doublereal *beta, doublereal *u, integer *ldu, doublereal *v, integer *ldv, doublereal *q, integer * ldq, doublereal *work, integer *ncycle, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University June 30, 1999 Purpose ======= DTGSJA computes the generalized singular value decomposition (GSVD) of two real upper triangular (or trapezoidal) matrices A and B. On entry, it is assumed that matrices A and B have the following forms, which may be obtained by the preprocessing subroutine DGGSVP from a general M-by-N matrix A and P-by-N matrix B: N-K-L K L A = K ( 0 A12 A13 ) if M-K-L >= 0; L ( 0 0 A23 ) M-K-L ( 0 0 0 ) N-K-L K L A = K ( 0 A12 A13 ) if M-K-L < 0; M-K ( 0 0 A23 ) N-K-L K L B = L ( 0 0 B13 ) P-L ( 0 0 0 ) where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, otherwise A23 is (M-K)-by-L upper trapezoidal. On exit, U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ), where U, V and Q are orthogonal matrices, Z' denotes the transpose of Z, R is a nonsingular upper triangular matrix, and D1 and D2 are ``diagonal'' matrices, which are of the following structures: If M-K-L >= 0, K L D1 = K ( I 0 ) L ( 0 C ) M-K-L ( 0 0 ) K L D2 = L ( 0 S ) P-L ( 0 0 ) N-K-L K L ( 0 R ) = K ( 0 R11 R12 ) K L ( 0 0 R22 ) L where C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), S = diag( BETA(K+1), ... , BETA(K+L) ), C**2 + S**2 = I. R is stored in A(1:K+L,N-K-L+1:N) on exit. If M-K-L < 0, K M-K K+L-M D1 = K ( I 0 0 ) M-K ( 0 C 0 ) K M-K K+L-M D2 = M-K ( 0 S 0 ) K+L-M ( 0 0 I ) P-L ( 0 0 0 ) N-K-L K M-K K+L-M ( 0 R ) = K ( 0 R11 R12 R13 ) M-K ( 0 0 R22 R23 ) K+L-M ( 0 0 0 R33 ) where C = diag( ALPHA(K+1), ... , ALPHA(M) ), S = diag( BETA(K+1), ... , BETA(M) ), C**2 + S**2 = I. R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored ( 0 R22 R23 ) in B(M-K+1:L,N+M-K-L+1:N) on exit. The computation of the orthogonal transformation matrices U, V or Q is optional. These matrices may either be formed explicitly, or they may be postmultiplied into input matrices U1, V1, or Q1. Arguments ========= JOBU (input) CHARACTER*1 = 'U': U must contain an orthogonal matrix U1 on entry, and the product U1*U is returned; = 'I': U is initialized to the unit matrix, and the orthogonal matrix U is returned; = 'N': U is not computed. JOBV (input) CHARACTER*1 = 'V': V must contain an orthogonal matrix V1 on entry, and the product V1*V is returned; = 'I': V is initialized to the unit matrix, and the orthogonal matrix V is returned; = 'N': V is not computed. JOBQ (input) CHARACTER*1 = 'Q': Q must contain an orthogonal matrix Q1 on entry, and the product Q1*Q is returned; = 'I': Q is initialized to the unit matrix, and the orthogonal matrix Q is returned; = 'N': Q is not computed. M (input) INTEGER The number of rows of the matrix A. M >= 0. P (input) INTEGER The number of rows of the matrix B. P >= 0. N (input) INTEGER The number of columns of the matrices A and B. N >= 0. K (input) INTEGER L (input) INTEGER K and L specify the subblocks in the input matrices A and B: A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N) of A and B, whose GSVD is going to be computed by DTGSJA. See Further details. A (input/output) DOUBLE PRECISION array, dimension (LDA,N) On entry, the M-by-N matrix A. On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular matrix R or part of R. See Purpose for details. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,M). B (input/output) DOUBLE PRECISION array, dimension (LDB,N) On entry, the P-by-N matrix B. On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains a part of R. See Purpose for details. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,P). TOLA (input) DOUBLE PRECISION TOLB (input) DOUBLE PRECISION TOLA and TOLB are the convergence criteria for the Jacobi- Kogbetliantz iteration procedure. Generally, they are the same as used in the preprocessing step, say TOLA = max(M,N)*norm(A)*MAZHEPS, TOLB = max(P,N)*norm(B)*MAZHEPS. ALPHA (output) DOUBLE PRECISION array, dimension (N) BETA (output) DOUBLE PRECISION array, dimension (N) On exit, ALPHA and BETA contain the generalized singular value pairs of A and B; ALPHA(1:K) = 1, BETA(1:K) = 0, and if M-K-L >= 0, ALPHA(K+1:K+L) = diag(C), BETA(K+1:K+L) = diag(S), or if M-K-L < 0, ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0 BETA(K+1:M) = S, BETA(M+1:K+L) = 1. Furthermore, if K+L < N, ALPHA(K+L+1:N) = 0 and BETA(K+L+1:N) = 0. U (input/output) DOUBLE PRECISION array, dimension (LDU,M) On entry, if JOBU = 'U', U must contain a matrix U1 (usually the orthogonal matrix returned by DGGSVP). On exit, if JOBU = 'I', U contains the orthogonal matrix U; if JOBU = 'U', U contains the product U1*U. If JOBU = 'N', U is not referenced. LDU (input) INTEGER The leading dimension of the array U. LDU >= max(1,M) if JOBU = 'U'; LDU >= 1 otherwise. V (input/output) DOUBLE PRECISION array, dimension (LDV,P) On entry, if JOBV = 'V', V must contain a matrix V1 (usually the orthogonal matrix returned by DGGSVP). On exit, if JOBV = 'I', V contains the orthogonal matrix V; if JOBV = 'V', V contains the product V1*V. If JOBV = 'N', V is not referenced. LDV (input) INTEGER The leading dimension of the array V. LDV >= max(1,P) if JOBV = 'V'; LDV >= 1 otherwise. Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually the orthogonal matrix returned by DGGSVP). On exit, if JOBQ = 'I', Q contains the orthogonal matrix Q; if JOBQ = 'Q', Q contains the product Q1*Q. If JOBQ = 'N', Q is not referenced. LDQ (input) INTEGER The leading dimension of the array Q. LDQ >= max(1,N) if JOBQ = 'Q'; LDQ >= 1 otherwise. WORK (workspace) DOUBLE PRECISION array, dimension (2*N) NCYCLE (output) INTEGER The number of cycles required for convergence. INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value. = 1: the procedure does not converge after MAXIT cycles. Internal Parameters =================== MAXIT INTEGER MAXIT specifies the total loops that the iterative procedure may take. If after MAXIT cycles, the routine fails to converge, we return INFO = 1. Further Details =============== DTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L matrix B13 to the form: U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1, where U1, V1 and Q1 are orthogonal matrix, and Z' is the transpose of Z. C1 and S1 are diagonal matrices satisfying C1**2 + S1**2 = I, and R1 is an L-by-L nonsingular upper triangular matrix. ===================================================================== Decode and test the input parameters Parameter adjustments */ /* Table of constant values */ static doublereal c_b13 = 0.; static doublereal c_b14 = 1.; static integer c__1 = 1; static doublereal c_b43 = -1.; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4; doublereal d__1; /* Local variables */ extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *); static integer i__, j; static doublereal gamma; extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, integer *); extern logical lsame_(char *, char *); extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *); static doublereal a1; static logical initq; static doublereal a2, a3, b1; static logical initu, initv, wantq, upper; static doublereal b2, b3; static logical wantu, wantv; static doublereal error, ssmin; extern /* Subroutine */ int dlags2_(logical *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *), dlapll_(integer *, doublereal *, integer *, doublereal *, integer *, doublereal *); static integer kcycle; extern /* Subroutine */ int dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *), dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *); static doublereal csq, csu, csv, snq, rwk, snu, snv; #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] #define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1] #define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1] #define u_ref(a_1,a_2) u[(a_2)*u_dim1 + a_1] #define v_ref(a_1,a_2) v[(a_2)*v_dim1 + a_1] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; --alpha; --beta; u_dim1 = *ldu; u_offset = 1 + u_dim1 * 1; u -= u_offset; v_dim1 = *ldv; v_offset = 1 + v_dim1 * 1; v -= v_offset; q_dim1 = *ldq; q_offset = 1 + q_dim1 * 1; q -= q_offset; --work; /* Function Body */ initu = lsame_(jobu, "I"); wantu = initu || lsame_(jobu, "U"); initv = lsame_(jobv, "I"); wantv = initv || lsame_(jobv, "V"); initq = lsame_(jobq, "I"); wantq = initq || lsame_(jobq, "Q"); *info = 0; if (! (initu || wantu || lsame_(jobu, "N"))) { *info = -1; } else if (! (initv || wantv || lsame_(jobv, "N"))) { *info = -2; } else if (! (initq || wantq || lsame_(jobq, "N"))) { *info = -3; } else if (*m < 0) { *info = -4; } else if (*p < 0) { *info = -5; } else if (*n < 0) { *info = -6; } else if (*lda < max(1,*m)) { *info = -10; } else if (*ldb < max(1,*p)) { *info = -12; } else if (*ldu < 1 || wantu && *ldu < *m) { *info = -18; } else if (*ldv < 1 || wantv && *ldv < *p) { *info = -20; } else if (*ldq < 1 || wantq && *ldq < *n) { *info = -22; } if (*info != 0) { i__1 = -(*info); xerbla_("DTGSJA", &i__1); return 0; } /* Initialize U, V and Q, if necessary */ if (initu) { dlaset_("Full", m, m, &c_b13, &c_b14, &u[u_offset], ldu); } if (initv) { dlaset_("Full", p, p, &c_b13, &c_b14, &v[v_offset], ldv); } if (initq) { dlaset_("Full", n, n, &c_b13, &c_b14, &q[q_offset], ldq); } /* Loop until convergence */ upper = FALSE_; for (kcycle = 1; kcycle <= 40; ++kcycle) { upper = ! upper; i__1 = *l - 1; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *l; for (j = i__ + 1; j <= i__2; ++j) { a1 = 0.; a2 = 0.; a3 = 0.; if (*k + i__ <= *m) { a1 = a_ref(*k + i__, *n - *l + i__); } if (*k + j <= *m) { a3 = a_ref(*k + j, *n - *l + j); } b1 = b_ref(i__, *n - *l + i__); b3 = b_ref(j, *n - *l + j); if (upper) { if (*k + i__ <= *m) { a2 = a_ref(*k + i__, *n - *l + j); } b2 = b_ref(i__, *n - *l + j); } else { if (*k + j <= *m) { a2 = a_ref(*k + j, *n - *l + i__); } b2 = b_ref(j, *n - *l + i__); } dlags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, & csv, &snv, &csq, &snq); /* Update (K+I)-th and (K+J)-th rows of matrix A: U'*A */ if (*k + j <= *m) { drot_(l, &a_ref(*k + j, *n - *l + 1), lda, &a_ref(*k + i__, *n - *l + 1), lda, &csu, &snu); } /* Update I-th and J-th rows of matrix B: V'*B */ drot_(l, &b_ref(j, *n - *l + 1), ldb, &b_ref(i__, *n - *l + 1) , ldb, &csv, &snv); /* Update (N-L+I)-th and (N-L+J)-th columns of matrices A and B: A*Q and B*Q Computing MIN */ i__4 = *k + *l; i__3 = min(i__4,*m); drot_(&i__3, &a_ref(1, *n - *l + j), &c__1, &a_ref(1, *n - *l + i__), &c__1, &csq, &snq); drot_(l, &b_ref(1, *n - *l + j), &c__1, &b_ref(1, *n - *l + i__), &c__1, &csq, &snq); if (upper) { if (*k + i__ <= *m) { a_ref(*k + i__, *n - *l + j) = 0.; } b_ref(i__, *n - *l + j) = 0.; } else { if (*k + j <= *m) { a_ref(*k + j, *n - *l + i__) = 0.; } b_ref(j, *n - *l + i__) = 0.; } /* Update orthogonal matrices U, V, Q, if desired. */ if (wantu && *k + j <= *m) { drot_(m, &u_ref(1, *k + j), &c__1, &u_ref(1, *k + i__), & c__1, &csu, &snu); } if (wantv) { drot_(p, &v_ref(1, j), &c__1, &v_ref(1, i__), &c__1, &csv, &snv); } if (wantq) { drot_(n, &q_ref(1, *n - *l + j), &c__1, &q_ref(1, *n - *l + i__), &c__1, &csq, &snq); } /* L10: */ } /* L20: */ } if (! upper) { /* The matrices A13 and B13 were lower triangular at the start of the cycle, and are now upper triangular. Convergence test: test the parallelism of the corresponding rows of A and B. */ error = 0.; /* Computing MIN */ i__2 = *l, i__3 = *m - *k; i__1 = min(i__2,i__3); for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *l - i__ + 1; dcopy_(&i__2, &a_ref(*k + i__, *n - *l + i__), lda, &work[1], &c__1); i__2 = *l - i__ + 1; dcopy_(&i__2, &b_ref(i__, *n - *l + i__), ldb, &work[*l + 1], &c__1); i__2 = *l - i__ + 1; dlapll_(&i__2, &work[1], &c__1, &work[*l + 1], &c__1, &ssmin); error = max(error,ssmin); /* L30: */ } if (abs(error) <= min(*tola,*tolb)) { goto L50; } } /* End of cycle loop L40: */ } /* The algorithm has not converged after MAXIT cycles. */ *info = 1; goto L100; L50: /* If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged. Compute the generalized singular value pairs (ALPHA, BETA), and set the triangular matrix R to array A. */ i__1 = *k; for (i__ = 1; i__ <= i__1; ++i__) { alpha[i__] = 1.; beta[i__] = 0.; /* L60: */ } /* Computing MIN */ i__2 = *l, i__3 = *m - *k; i__1 = min(i__2,i__3); for (i__ = 1; i__ <= i__1; ++i__) { a1 = a_ref(*k + i__, *n - *l + i__); b1 = b_ref(i__, *n - *l + i__); if (a1 != 0.) { gamma = b1 / a1; /* change sign if necessary */ if (gamma < 0.) { i__2 = *l - i__ + 1; dscal_(&i__2, &c_b43, &b_ref(i__, *n - *l + i__), ldb); if (wantv) { dscal_(p, &c_b43, &v_ref(1, i__), &c__1); } } d__1 = abs(gamma); dlartg_(&d__1, &c_b14, &beta[*k + i__], &alpha[*k + i__], &rwk); if (alpha[*k + i__] >= beta[*k + i__]) { i__2 = *l - i__ + 1; d__1 = 1. / alpha[*k + i__]; dscal_(&i__2, &d__1, &a_ref(*k + i__, *n - *l + i__), lda); } else { i__2 = *l - i__ + 1; d__1 = 1. / beta[*k + i__]; dscal_(&i__2, &d__1, &b_ref(i__, *n - *l + i__), ldb); i__2 = *l - i__ + 1; dcopy_(&i__2, &b_ref(i__, *n - *l + i__), ldb, &a_ref(*k + i__, *n - *l + i__), lda); } } else { alpha[*k + i__] = 0.; beta[*k + i__] = 1.; i__2 = *l - i__ + 1; dcopy_(&i__2, &b_ref(i__, *n - *l + i__), ldb, &a_ref(*k + i__, * n - *l + i__), lda); } /* L70: */ } /* Post-assignment */ i__1 = *k + *l; for (i__ = *m + 1; i__ <= i__1; ++i__) { alpha[i__] = 0.; beta[i__] = 1.; /* L80: */ } if (*k + *l < *n) { i__1 = *n; for (i__ = *k + *l + 1; i__ <= i__1; ++i__) { alpha[i__] = 0.; beta[i__] = 0.; /* L90: */ } } L100: *ncycle = kcycle; return 0; /* End of DTGSJA */ } /* dtgsja_ */
/* Subroutine */ int sgbbrd_(char *vect, integer *m, integer *n, integer *ncc, integer *kl, integer *ku, real *ab, integer *ldab, real *d__, real * e, real *q, integer *ldq, real *pt, integer *ldpt, real *c__, integer *ldc, real *work, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= SGBBRD reduces a real general m-by-n band matrix A to upper bidiagonal form B by an orthogonal transformation: Q' * A * P = B. The routine computes B, and optionally forms Q or P', or computes Q'*C for a given matrix C. Arguments ========= VECT (input) CHARACTER*1 Specifies whether or not the matrices Q and P' are to be formed. = 'N': do not form Q or P'; = 'Q': form Q only; = 'P': form P' only; = 'B': form both. M (input) INTEGER The number of rows of the matrix A. M >= 0. N (input) INTEGER The number of columns of the matrix A. N >= 0. NCC (input) INTEGER The number of columns of the matrix C. NCC >= 0. KL (input) INTEGER The number of subdiagonals of the matrix A. KL >= 0. KU (input) INTEGER The number of superdiagonals of the matrix A. KU >= 0. AB (input/output) REAL array, dimension (LDAB,N) On entry, the m-by-n band matrix A, stored in rows 1 to KL+KU+1. The j-th column of A is stored in the j-th column of the array AB as follows: AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl). On exit, A is overwritten by values generated during the reduction. LDAB (input) INTEGER The leading dimension of the array A. LDAB >= KL+KU+1. D (output) REAL array, dimension (min(M,N)) The diagonal elements of the bidiagonal matrix B. E (output) REAL array, dimension (min(M,N)-1) The superdiagonal elements of the bidiagonal matrix B. Q (output) REAL array, dimension (LDQ,M) If VECT = 'Q' or 'B', the m-by-m orthogonal matrix Q. If VECT = 'N' or 'P', the array Q is not referenced. LDQ (input) INTEGER The leading dimension of the array Q. LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise. PT (output) REAL array, dimension (LDPT,N) If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'. If VECT = 'N' or 'Q', the array PT is not referenced. LDPT (input) INTEGER The leading dimension of the array PT. LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise. C (input/output) REAL array, dimension (LDC,NCC) On entry, an m-by-ncc matrix C. On exit, C is overwritten by Q'*C. C is not referenced if NCC = 0. LDC (input) INTEGER The leading dimension of the array C. LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0. WORK (workspace) REAL array, dimension (2*max(M,N)) INFO (output) INTEGER = 0: successful exit. < 0: if INFO = -i, the i-th argument had an illegal value. ===================================================================== Test the input parameters Parameter adjustments */ /* Table of constant values */ static real c_b8 = 0.f; static real c_b9 = 1.f; static integer c__1 = 1; /* System generated locals */ integer ab_dim1, ab_offset, c_dim1, c_offset, pt_dim1, pt_offset, q_dim1, q_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7; /* Local variables */ static integer inca; extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, integer *, real *, real *); static integer i__, j, l; extern logical lsame_(char *, char *); static logical wantb, wantc; static integer minmn; static logical wantq; static integer j1, j2, kb; static real ra, rb, rc; static integer kk, ml, mn, nr, mu; static real rs; extern /* Subroutine */ int xerbla_(char *, integer *), slaset_( char *, integer *, integer *, real *, real *, real *, integer *), slartg_(real *, real *, real *, real *, real *); static integer kb1; extern /* Subroutine */ int slargv_(integer *, real *, integer *, real *, integer *, real *, integer *); static integer ml0; extern /* Subroutine */ int slartv_(integer *, real *, integer *, real *, integer *, real *, real *, integer *); static logical wantpt; static integer mu0, klm, kun, nrt, klu1; #define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1] #define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1] #define ab_ref(a_1,a_2) ab[(a_2)*ab_dim1 + a_1] #define pt_ref(a_1,a_2) pt[(a_2)*pt_dim1 + a_1] ab_dim1 = *ldab; ab_offset = 1 + ab_dim1 * 1; ab -= ab_offset; --d__; --e; q_dim1 = *ldq; q_offset = 1 + q_dim1 * 1; q -= q_offset; pt_dim1 = *ldpt; pt_offset = 1 + pt_dim1 * 1; pt -= pt_offset; c_dim1 = *ldc; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; --work; /* Function Body */ wantb = lsame_(vect, "B"); wantq = lsame_(vect, "Q") || wantb; wantpt = lsame_(vect, "P") || wantb; wantc = *ncc > 0; klu1 = *kl + *ku + 1; *info = 0; if (! wantq && ! wantpt && ! lsame_(vect, "N")) { *info = -1; } else if (*m < 0) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*ncc < 0) { *info = -4; } else if (*kl < 0) { *info = -5; } else if (*ku < 0) { *info = -6; } else if (*ldab < klu1) { *info = -8; } else if (*ldq < 1 || wantq && *ldq < max(1,*m)) { *info = -12; } else if (*ldpt < 1 || wantpt && *ldpt < max(1,*n)) { *info = -14; } else if (*ldc < 1 || wantc && *ldc < max(1,*m)) { *info = -16; } if (*info != 0) { i__1 = -(*info); xerbla_("SGBBRD", &i__1); return 0; } /* Initialize Q and P' to the unit matrix, if needed */ if (wantq) { slaset_("Full", m, m, &c_b8, &c_b9, &q[q_offset], ldq); } if (wantpt) { slaset_("Full", n, n, &c_b8, &c_b9, &pt[pt_offset], ldpt); } /* Quick return if possible. */ if (*m == 0 || *n == 0) { return 0; } minmn = min(*m,*n); if (*kl + *ku > 1) { /* Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce first to lower bidiagonal form and then transform to upper bidiagonal */ if (*ku > 0) { ml0 = 1; mu0 = 2; } else { ml0 = 2; mu0 = 1; } /* Wherever possible, plane rotations are generated and applied in vector operations of length NR over the index set J1:J2:KLU1. The sines of the plane rotations are stored in WORK(1:max(m,n)) and the cosines in WORK(max(m,n)+1:2*max(m,n)). */ mn = max(*m,*n); /* Computing MIN */ i__1 = *m - 1; klm = min(i__1,*kl); /* Computing MIN */ i__1 = *n - 1; kun = min(i__1,*ku); kb = klm + kun; kb1 = kb + 1; inca = kb1 * *ldab; nr = 0; j1 = klm + 2; j2 = 1 - kun; i__1 = minmn; for (i__ = 1; i__ <= i__1; ++i__) { /* Reduce i-th column and i-th row of matrix to bidiagonal form */ ml = klm + 1; mu = kun + 1; i__2 = kb; for (kk = 1; kk <= i__2; ++kk) { j1 += kb; j2 += kb; /* generate plane rotations to annihilate nonzero elements which have been created below the band */ if (nr > 0) { slargv_(&nr, &ab_ref(klu1, j1 - klm - 1), &inca, &work[j1] , &kb1, &work[mn + j1], &kb1); } /* apply plane rotations from the left */ i__3 = kb; for (l = 1; l <= i__3; ++l) { if (j2 - klm + l - 1 > *n) { nrt = nr - 1; } else { nrt = nr; } if (nrt > 0) { slartv_(&nrt, &ab_ref(klu1 - l, j1 - klm + l - 1), & inca, &ab_ref(klu1 - l + 1, j1 - klm + l - 1), &inca, &work[mn + j1], &work[j1], &kb1); } /* L10: */ } if (ml > ml0) { if (ml <= *m - i__ + 1) { /* generate plane rotation to annihilate a(i+ml-1,i) within the band, and apply rotation from the left */ slartg_(&ab_ref(*ku + ml - 1, i__), &ab_ref(*ku + ml, i__), &work[mn + i__ + ml - 1], &work[i__ + ml - 1], &ra); ab_ref(*ku + ml - 1, i__) = ra; if (i__ < *n) { /* Computing MIN */ i__4 = *ku + ml - 2, i__5 = *n - i__; i__3 = min(i__4,i__5); i__6 = *ldab - 1; i__7 = *ldab - 1; srot_(&i__3, &ab_ref(*ku + ml - 2, i__ + 1), & i__6, &ab_ref(*ku + ml - 1, i__ + 1), & i__7, &work[mn + i__ + ml - 1], &work[i__ + ml - 1]); } } ++nr; j1 -= kb1; } if (wantq) { /* accumulate product of plane rotations in Q */ i__3 = j2; i__4 = kb1; for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) { srot_(m, &q_ref(1, j - 1), &c__1, &q_ref(1, j), &c__1, &work[mn + j], &work[j]); /* L20: */ } } if (wantc) { /* apply plane rotations to C */ i__4 = j2; i__3 = kb1; for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) { srot_(ncc, &c___ref(j - 1, 1), ldc, &c___ref(j, 1), ldc, &work[mn + j], &work[j]); /* L30: */ } } if (j2 + kun > *n) { /* adjust J2 to keep within the bounds of the matrix */ --nr; j2 -= kb1; } i__3 = j2; i__4 = kb1; for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) { /* create nonzero element a(j-1,j+ku) above the band and store it in WORK(n+1:2*n) */ work[j + kun] = work[j] * ab_ref(1, j + kun); ab_ref(1, j + kun) = work[mn + j] * ab_ref(1, j + kun); /* L40: */ } /* generate plane rotations to annihilate nonzero elements which have been generated above the band */ if (nr > 0) { slargv_(&nr, &ab_ref(1, j1 + kun - 1), &inca, &work[j1 + kun], &kb1, &work[mn + j1 + kun], &kb1); } /* apply plane rotations from the right */ i__4 = kb; for (l = 1; l <= i__4; ++l) { if (j2 + l - 1 > *m) { nrt = nr - 1; } else { nrt = nr; } if (nrt > 0) { slartv_(&nrt, &ab_ref(l + 1, j1 + kun - 1), &inca, & ab_ref(l, j1 + kun), &inca, &work[mn + j1 + kun], &work[j1 + kun], &kb1); } /* L50: */ } if (ml == ml0 && mu > mu0) { if (mu <= *n - i__ + 1) { /* generate plane rotation to annihilate a(i,i+mu-1) within the band, and apply rotation from the right */ slartg_(&ab_ref(*ku - mu + 3, i__ + mu - 2), &ab_ref(* ku - mu + 2, i__ + mu - 1), &work[mn + i__ + mu - 1], &work[i__ + mu - 1], &ra); ab_ref(*ku - mu + 3, i__ + mu - 2) = ra; /* Computing MIN */ i__3 = *kl + mu - 2, i__5 = *m - i__; i__4 = min(i__3,i__5); srot_(&i__4, &ab_ref(*ku - mu + 4, i__ + mu - 2), & c__1, &ab_ref(*ku - mu + 3, i__ + mu - 1), & c__1, &work[mn + i__ + mu - 1], &work[i__ + mu - 1]); } ++nr; j1 -= kb1; } if (wantpt) { /* accumulate product of plane rotations in P' */ i__4 = j2; i__3 = kb1; for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) { srot_(n, &pt_ref(j + kun - 1, 1), ldpt, &pt_ref(j + kun, 1), ldpt, &work[mn + j + kun], &work[j + kun]); /* L60: */ } } if (j2 + kb > *m) { /* adjust J2 to keep within the bounds of the matrix */ --nr; j2 -= kb1; } i__3 = j2; i__4 = kb1; for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) { /* create nonzero element a(j+kl+ku,j+ku-1) below the band and store it in WORK(1:n) */ work[j + kb] = work[j + kun] * ab_ref(klu1, j + kun); ab_ref(klu1, j + kun) = work[mn + j + kun] * ab_ref(klu1, j + kun); /* L70: */ } if (ml > ml0) { --ml; } else { --mu; } /* L80: */ } /* L90: */ } } if (*ku == 0 && *kl > 0) { /* A has been reduced to lower bidiagonal form Transform lower bidiagonal form to upper bidiagonal by applying plane rotations from the left, storing diagonal elements in D and off-diagonal elements in E Computing MIN */ i__2 = *m - 1; i__1 = min(i__2,*n); for (i__ = 1; i__ <= i__1; ++i__) { slartg_(&ab_ref(1, i__), &ab_ref(2, i__), &rc, &rs, &ra); d__[i__] = ra; if (i__ < *n) { e[i__] = rs * ab_ref(1, i__ + 1); ab_ref(1, i__ + 1) = rc * ab_ref(1, i__ + 1); } if (wantq) { srot_(m, &q_ref(1, i__), &c__1, &q_ref(1, i__ + 1), &c__1, & rc, &rs); } if (wantc) { srot_(ncc, &c___ref(i__, 1), ldc, &c___ref(i__ + 1, 1), ldc, & rc, &rs); } /* L100: */ } if (*m <= *n) { d__[*m] = ab_ref(1, *m); } } else if (*ku > 0) { /* A has been reduced to upper bidiagonal form */ if (*m < *n) { /* Annihilate a(m,m+1) by applying plane rotations from the right, storing diagonal elements in D and off-diagonal elements in E */ rb = ab_ref(*ku, *m + 1); for (i__ = *m; i__ >= 1; --i__) { slartg_(&ab_ref(*ku + 1, i__), &rb, &rc, &rs, &ra); d__[i__] = ra; if (i__ > 1) { rb = -rs * ab_ref(*ku, i__); e[i__ - 1] = rc * ab_ref(*ku, i__); } if (wantpt) { srot_(n, &pt_ref(i__, 1), ldpt, &pt_ref(*m + 1, 1), ldpt, &rc, &rs); } /* L110: */ } } else { /* Copy off-diagonal elements to E and diagonal elements to D */ i__1 = minmn - 1; for (i__ = 1; i__ <= i__1; ++i__) { e[i__] = ab_ref(*ku, i__ + 1); /* L120: */ } i__1 = minmn; for (i__ = 1; i__ <= i__1; ++i__) { d__[i__] = ab_ref(*ku + 1, i__); /* L130: */ } } } else { /* A is diagonal. Set elements of E to zero and copy diagonal elements to D. */ i__1 = minmn - 1; for (i__ = 1; i__ <= i__1; ++i__) { e[i__] = 0.f; /* L140: */ } i__1 = minmn; for (i__ = 1; i__ <= i__1; ++i__) { d__[i__] = ab_ref(1, i__); /* L150: */ } } return 0; /* End of SGBBRD */ } /* sgbbrd_ */
/* Subroutine */ int zrqt03_(integer *m, integer *n, integer *k, doublecomplex *af, doublecomplex *c__, doublecomplex *cc, doublecomplex *q, integer *lda, doublecomplex *tau, doublecomplex * work, integer *lwork, doublereal *rwork, doublereal *result) { /* Initialized data */ static integer iseed[4] = { 1988,1989,1990,1991 }; /* System generated locals */ integer af_dim1, af_offset, c_dim1, c_offset, cc_dim1, cc_offset, q_dim1, q_offset, i__1, i__2; /* Builtin functions Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); /* Local variables */ static char side[1]; static integer info, j, iside; extern logical lsame_(char *, char *); static doublereal resid; static integer minmn; static doublereal cnorm; extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *); static char trans[1]; static integer mc, nc; extern doublereal dlamch_(char *), zlange_(char *, integer *, integer *, doublecomplex *, integer *, doublereal *); static integer itrans; extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlarnv_( integer *, integer *, integer *, doublecomplex *), zungrq_( integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *), zunmrq_( char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer *); static doublereal eps; #define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1 #define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)] #define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1 #define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)] #define af_subscr(a_1,a_2) (a_2)*af_dim1 + a_1 #define af_ref(a_1,a_2) af[af_subscr(a_1,a_2)] /* -- LAPACK test routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= ZRQT03 tests ZUNMRQ, which computes Q*C, Q'*C, C*Q or C*Q'. ZRQT03 compares the results of a call to ZUNMRQ with the results of forming Q explicitly by a call to ZUNGRQ and then performing matrix multiplication by a call to ZGEMM. Arguments ========= M (input) INTEGER The number of rows or columns of the matrix C; C is n-by-m if Q is applied from the left, or m-by-n if Q is applied from the right. M >= 0. N (input) INTEGER The order of the orthogonal matrix Q. N >= 0. K (input) INTEGER The number of elementary reflectors whose product defines the orthogonal matrix Q. N >= K >= 0. AF (input) COMPLEX*16 array, dimension (LDA,N) Details of the RQ factorization of an m-by-n matrix, as returned by ZGERQF. See CGERQF for further details. C (workspace) COMPLEX*16 array, dimension (LDA,N) CC (workspace) COMPLEX*16 array, dimension (LDA,N) Q (workspace) COMPLEX*16 array, dimension (LDA,N) LDA (input) INTEGER The leading dimension of the arrays AF, C, CC, and Q. TAU (input) COMPLEX*16 array, dimension (min(M,N)) The scalar factors of the elementary reflectors corresponding to the RQ factorization in AF. WORK (workspace) COMPLEX*16 array, dimension (LWORK) LWORK (input) INTEGER The length of WORK. LWORK must be at least M, and should be M*NB, where NB is the blocksize for this environment. RWORK (workspace) DOUBLE PRECISION array, dimension (M) RESULT (output) DOUBLE PRECISION array, dimension (4) The test ratios compare two techniques for multiplying a random matrix C by an n-by-n orthogonal matrix Q. RESULT(1) = norm( Q*C - Q*C ) / ( N * norm(C) * EPS ) RESULT(2) = norm( C*Q - C*Q ) / ( N * norm(C) * EPS ) RESULT(3) = norm( Q'*C - Q'*C )/ ( N * norm(C) * EPS ) RESULT(4) = norm( C*Q' - C*Q' )/ ( N * norm(C) * EPS ) ===================================================================== Parameter adjustments */ q_dim1 = *lda; q_offset = 1 + q_dim1 * 1; q -= q_offset; cc_dim1 = *lda; cc_offset = 1 + cc_dim1 * 1; cc -= cc_offset; c_dim1 = *lda; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; af_dim1 = *lda; af_offset = 1 + af_dim1 * 1; af -= af_offset; --tau; --work; --rwork; --result; /* Function Body */ eps = dlamch_("Epsilon"); minmn = min(*m,*n); /* Quick return if possible */ if (minmn == 0) { result[1] = 0.; result[2] = 0.; result[3] = 0.; result[4] = 0.; return 0; } /* Copy the last k rows of the factorization to the array Q */ zlaset_("Full", n, n, &c_b1, &c_b1, &q[q_offset], lda); if (*k > 0 && *n > *k) { i__1 = *n - *k; zlacpy_("Full", k, &i__1, &af_ref(*m - *k + 1, 1), lda, &q_ref(*n - * k + 1, 1), lda); } if (*k > 1) { i__1 = *k - 1; i__2 = *k - 1; zlacpy_("Lower", &i__1, &i__2, &af_ref(*m - *k + 2, *n - *k + 1), lda, &q_ref(*n - *k + 2, *n - *k + 1), lda); } /* Generate the n-by-n matrix Q */ s_copy(srnamc_1.srnamt, "ZUNGRQ", (ftnlen)6, (ftnlen)6); zungrq_(n, n, k, &q[q_offset], lda, &tau[minmn - *k + 1], &work[1], lwork, &info); for (iside = 1; iside <= 2; ++iside) { if (iside == 1) { *(unsigned char *)side = 'L'; mc = *n; nc = *m; } else { *(unsigned char *)side = 'R'; mc = *m; nc = *n; } /* Generate MC by NC matrix C */ i__1 = nc; for (j = 1; j <= i__1; ++j) { zlarnv_(&c__2, iseed, &mc, &c___ref(1, j)); /* L10: */ } cnorm = zlange_("1", &mc, &nc, &c__[c_offset], lda, &rwork[1]); if (cnorm == 0.) { cnorm = 1.; } for (itrans = 1; itrans <= 2; ++itrans) { if (itrans == 1) { *(unsigned char *)trans = 'N'; } else { *(unsigned char *)trans = 'C'; } /* Copy C */ zlacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset], lda); /* Apply Q or Q' to C */ s_copy(srnamc_1.srnamt, "ZUNMRQ", (ftnlen)6, (ftnlen)6); if (*k > 0) { zunmrq_(side, trans, &mc, &nc, k, &af_ref(*m - *k + 1, 1), lda, &tau[minmn - *k + 1], &cc[cc_offset], lda, &work[ 1], lwork, &info); } /* Form explicit product and subtract */ if (lsame_(side, "L")) { zgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b21, &q[ q_offset], lda, &c__[c_offset], lda, &c_b22, &cc[ cc_offset], lda); } else { zgemm_("No transpose", trans, &mc, &nc, &nc, &c_b21, &c__[ c_offset], lda, &q[q_offset], lda, &c_b22, &cc[ cc_offset], lda); } /* Compute error in the difference */ resid = zlange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]); result[(iside - 1 << 1) + itrans] = resid / ((doublereal) max(1,* n) * cnorm * eps); /* L20: */ } /* L30: */ } return 0; /* End of ZRQT03 */ } /* zrqt03_ */
/* Subroutine */ int dlaed1_(integer *n, doublereal *d__, doublereal *q, integer *ldq, integer *indxq, doublereal *rho, integer *cutpnt, doublereal *work, integer *iwork, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University June 30, 1999 Purpose ======= DLAED1 computes the updated eigensystem of a diagonal matrix after modification by a rank-one symmetric matrix. This routine is used only for the eigenproblem which requires all eigenvalues and eigenvectors of a tridiagonal matrix. DLAED7 handles the case in which eigenvalues only or eigenvalues and eigenvectors of a full symmetric matrix (which was reduced to tridiagonal form) are desired. T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out) where Z = Q'u, u is a vector of length N with ones in the CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. The eigenvectors of the original matrix are stored in Q, and the eigenvalues are in D. The algorithm consists of three stages: The first stage consists of deflating the size of the problem when there are multiple eigenvalues or if there is a zero in the Z vector. For each such occurence the dimension of the secular equation problem is reduced by one. This stage is performed by the routine DLAED2. The second stage consists of calculating the updated eigenvalues. This is done by finding the roots of the secular equation via the routine DLAED4 (as called by DLAED3). This routine also calculates the eigenvectors of the current problem. The final stage consists of computing the updated eigenvectors directly using the updated eigenvalues. The eigenvectors for the current problem are multiplied with the eigenvectors from the overall problem. Arguments ========= N (input) INTEGER The dimension of the symmetric tridiagonal matrix. N >= 0. D (input/output) DOUBLE PRECISION array, dimension (N) On entry, the eigenvalues of the rank-1-perturbed matrix. On exit, the eigenvalues of the repaired matrix. Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) On entry, the eigenvectors of the rank-1-perturbed matrix. On exit, the eigenvectors of the repaired tridiagonal matrix. LDQ (input) INTEGER The leading dimension of the array Q. LDQ >= max(1,N). INDXQ (input/output) INTEGER array, dimension (N) On entry, the permutation which separately sorts the two subproblems in D into ascending order. On exit, the permutation which will reintegrate the subproblems back into sorted order, i.e. D( INDXQ( I = 1, N ) ) will be in ascending order. RHO (input) DOUBLE PRECISION The subdiagonal entry used to create the rank-1 modification. CUTPNT (input) INTEGER The location of the last eigenvalue in the leading sub-matrix. min(1,N) <= CUTPNT <= N/2. WORK (workspace) DOUBLE PRECISION array, dimension (4*N + N**2) IWORK (workspace) INTEGER array, dimension (4*N) INFO (output) INTEGER = 0: successful exit. < 0: if INFO = -i, the i-th argument had an illegal value. > 0: if INFO = 1, an eigenvalue did not converge Further Details =============== Based on contributions by Jeff Rutter, Computer Science Division, University of California at Berkeley, USA Modified by Francoise Tisseur, University of Tennessee. ===================================================================== Test the input parameters. Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; static integer c_n1 = -1; /* System generated locals */ integer q_dim1, q_offset, i__1, i__2; /* Local variables */ static integer indx, i__, k, indxc; extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *); static integer indxp; extern /* Subroutine */ int dlaed2_(integer *, integer *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, integer *, integer *, integer *, integer *), dlaed3_(integer *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *, doublereal *, integer *); static integer n1, n2, idlmda, is, iw, iz; extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, integer *, integer *, integer *), xerbla_(char *, integer *); static integer coltyp, iq2, zpp1; #define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1] --d__; q_dim1 = *ldq; q_offset = 1 + q_dim1 * 1; q -= q_offset; --indxq; --work; --iwork; /* Function Body */ *info = 0; if (*n < 0) { *info = -1; } else if (*ldq < max(1,*n)) { *info = -4; } else /* if(complicated condition) */ { /* Computing MIN */ i__1 = 1, i__2 = *n / 2; if (min(i__1,i__2) > *cutpnt || *n / 2 < *cutpnt) { *info = -7; } } if (*info != 0) { i__1 = -(*info); xerbla_("DLAED1", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* The following values are integer pointers which indicate the portion of the workspace used by a particular array in DLAED2 and DLAED3. */ iz = 1; idlmda = iz + *n; iw = idlmda + *n; iq2 = iw + *n; indx = 1; indxc = indx + *n; coltyp = indxc + *n; indxp = coltyp + *n; /* Form the z-vector which consists of the last row of Q_1 and the first row of Q_2. */ dcopy_(cutpnt, &q_ref(*cutpnt, 1), ldq, &work[iz], &c__1); zpp1 = *cutpnt + 1; i__1 = *n - *cutpnt; dcopy_(&i__1, &q_ref(zpp1, zpp1), ldq, &work[iz + *cutpnt], &c__1); /* Deflate eigenvalues. */ dlaed2_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, &indxq[1], rho, &work[ iz], &work[idlmda], &work[iw], &work[iq2], &iwork[indx], &iwork[ indxc], &iwork[indxp], &iwork[coltyp], info); if (*info != 0) { goto L20; } /* Solve Secular Equation. */ if (k != 0) { is = (iwork[coltyp] + iwork[coltyp + 1]) * *cutpnt + (iwork[coltyp + 1] + iwork[coltyp + 2]) * (*n - *cutpnt) + iq2; dlaed3_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, rho, &work[idlmda], &work[iq2], &iwork[indxc], &iwork[coltyp], &work[iw], &work[ is], info); if (*info != 0) { goto L20; } /* Prepare the INDXQ sorting permutation. */ n1 = k; n2 = *n - k; dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]); } else { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { indxq[i__] = i__; /* L10: */ } } L20: return 0; /* End of DLAED1 */ } /* dlaed1_ */
/* Subroutine */ int claed0_(integer *qsiz, integer *n, real *d__, real *e, complex *q, integer *ldq, complex *qstore, integer *ldqs, real *rwork, integer *iwork, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= Using the divide and conquer method, CLAED0 computes all eigenvalues of a symmetric tridiagonal matrix which is one diagonal block of those from reducing a dense or band Hermitian matrix and corresponding eigenvectors of the dense or band matrix. Arguments ========= QSIZ (input) INTEGER The dimension of the unitary matrix used to reduce the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. N (input) INTEGER The dimension of the symmetric tridiagonal matrix. N >= 0. D (input/output) REAL array, dimension (N) On entry, the diagonal elements of the tridiagonal matrix. On exit, the eigenvalues in ascending order. E (input/output) REAL array, dimension (N-1) On entry, the off-diagonal elements of the tridiagonal matrix. On exit, E has been destroyed. Q (input/output) COMPLEX array, dimension (LDQ,N) On entry, Q must contain an QSIZ x N matrix whose columns unitarily orthonormal. It is a part of the unitary matrix that reduces the full dense Hermitian matrix to a (reducible) symmetric tridiagonal matrix. LDQ (input) INTEGER The leading dimension of the array Q. LDQ >= max(1,N). IWORK (workspace) INTEGER array, the dimension of IWORK must be at least 6 + 6*N + 5*N*lg N ( lg( N ) = smallest integer k such that 2^k >= N ) RWORK (workspace) REAL array, dimension (1 + 3*N + 2*N*lg N + 3*N**2) ( lg( N ) = smallest integer k such that 2^k >= N ) QSTORE (workspace) COMPLEX array, dimension (LDQS, N) Used to store parts of the eigenvector matrix when the updating matrix multiplies take place. LDQS (input) INTEGER The leading dimension of the array QSTORE. LDQS >= max(1,N). INFO (output) INTEGER = 0: successful exit. < 0: if INFO = -i, the i-th argument had an illegal value. > 0: The algorithm failed to compute an eigenvalue while working on the submatrix lying in rows and columns INFO/(N+1) through mod(INFO,N+1). ===================================================================== Warning: N could be as big as QSIZ! Test the input parameters. Parameter adjustments */ /* Table of constant values */ static integer c__9 = 9; static integer c__0 = 0; static integer c__2 = 2; static integer c__1 = 1; /* System generated locals */ integer q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2; real r__1; /* Builtin functions */ double log(doublereal); integer pow_ii(integer *, integer *); /* Local variables */ static real temp; static integer curr, i__, j, k, iperm; extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, complex *, integer *); static integer indxq, iwrem; extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, integer *); static integer iqptr; extern /* Subroutine */ int claed7_(integer *, integer *, integer *, integer *, integer *, integer *, real *, complex *, integer *, real *, integer *, real *, integer *, integer *, integer *, integer *, integer *, real *, complex *, real *, integer *, integer *); static integer tlvls, ll, iq; extern /* Subroutine */ int clacrm_(integer *, integer *, complex *, integer *, real *, integer *, complex *, integer *, real *); static integer igivcl; extern /* Subroutine */ int xerbla_(char *, integer *); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); static integer igivnm, submat, curprb, subpbs, igivpt, curlvl, matsiz, iprmpt, smlsiz; extern /* Subroutine */ int ssteqr_(char *, integer *, real *, real *, real *, integer *, real *, integer *); static integer lgn, msd2, smm1, spm1, spm2; #define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1 #define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)] #define qstore_subscr(a_1,a_2) (a_2)*qstore_dim1 + a_1 #define qstore_ref(a_1,a_2) qstore[qstore_subscr(a_1,a_2)] --d__; --e; q_dim1 = *ldq; q_offset = 1 + q_dim1 * 1; q -= q_offset; qstore_dim1 = *ldqs; qstore_offset = 1 + qstore_dim1 * 1; qstore -= qstore_offset; --rwork; --iwork; /* Function Body */ *info = 0; /* IF( ICOMPQ .LT. 0 .OR. ICOMPQ .GT. 2 ) THEN INFO = -1 ELSE IF( ( ICOMPQ .EQ. 1 ) .AND. ( QSIZ .LT. MAX( 0, N ) ) ) $ THEN */ if (*qsiz < max(0,*n)) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*ldq < max(1,*n)) { *info = -6; } else if (*ldqs < max(1,*n)) { *info = -8; } if (*info != 0) { i__1 = -(*info); xerbla_("CLAED0", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } smlsiz = ilaenv_(&c__9, "CLAED0", " ", &c__0, &c__0, &c__0, &c__0, ( ftnlen)6, (ftnlen)1); /* Determine the size and placement of the submatrices, and save in the leading elements of IWORK. */ iwork[1] = *n; subpbs = 1; tlvls = 0; L10: if (iwork[subpbs] > smlsiz) { for (j = subpbs; j >= 1; --j) { iwork[j * 2] = (iwork[j] + 1) / 2; iwork[(j << 1) - 1] = iwork[j] / 2; /* L20: */ } ++tlvls; subpbs <<= 1; goto L10; } i__1 = subpbs; for (j = 2; j <= i__1; ++j) { iwork[j] += iwork[j - 1]; /* L30: */ } /* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1 using rank-1 modifications (cuts). */ spm1 = subpbs - 1; i__1 = spm1; for (i__ = 1; i__ <= i__1; ++i__) { submat = iwork[i__] + 1; smm1 = submat - 1; d__[smm1] -= (r__1 = e[smm1], dabs(r__1)); d__[submat] -= (r__1 = e[smm1], dabs(r__1)); /* L40: */ } indxq = (*n << 2) + 3; /* Set up workspaces for eigenvalues only/accumulate new vectors routine */ temp = log((real) (*n)) / log(2.f); lgn = (integer) temp; if (pow_ii(&c__2, &lgn) < *n) { ++lgn; } if (pow_ii(&c__2, &lgn) < *n) { ++lgn; } iprmpt = indxq + *n + 1; iperm = iprmpt + *n * lgn; iqptr = iperm + *n * lgn; igivpt = iqptr + *n + 2; igivcl = igivpt + *n * lgn; igivnm = 1; iq = igivnm + (*n << 1) * lgn; /* Computing 2nd power */ i__1 = *n; iwrem = iq + i__1 * i__1 + 1; /* Initialize pointers */ i__1 = subpbs; for (i__ = 0; i__ <= i__1; ++i__) { iwork[iprmpt + i__] = 1; iwork[igivpt + i__] = 1; /* L50: */ } iwork[iqptr] = 1; /* Solve each submatrix eigenproblem at the bottom of the divide and conquer tree. */ curr = 0; i__1 = spm1; for (i__ = 0; i__ <= i__1; ++i__) { if (i__ == 0) { submat = 1; matsiz = iwork[1]; } else { submat = iwork[i__] + 1; matsiz = iwork[i__ + 1] - iwork[i__]; } ll = iq - 1 + iwork[iqptr + curr]; ssteqr_("I", &matsiz, &d__[submat], &e[submat], &rwork[ll], &matsiz, & rwork[1], info); clacrm_(qsiz, &matsiz, &q_ref(1, submat), ldq, &rwork[ll], &matsiz, & qstore_ref(1, submat), ldqs, &rwork[iwrem]); /* Computing 2nd power */ i__2 = matsiz; iwork[iqptr + curr + 1] = iwork[iqptr + curr] + i__2 * i__2; ++curr; if (*info > 0) { *info = submat * (*n + 1) + submat + matsiz - 1; return 0; } k = 1; i__2 = iwork[i__ + 1]; for (j = submat; j <= i__2; ++j) { iwork[indxq + j] = k; ++k; /* L60: */ } /* L70: */ } /* Successively merge eigensystems of adjacent submatrices into eigensystem for the corresponding larger matrix. while ( SUBPBS > 1 ) */ curlvl = 1; L80: if (subpbs > 1) { spm2 = subpbs - 2; i__1 = spm2; for (i__ = 0; i__ <= i__1; i__ += 2) { if (i__ == 0) { submat = 1; matsiz = iwork[2]; msd2 = iwork[1]; curprb = 0; } else { submat = iwork[i__] + 1; matsiz = iwork[i__ + 2] - iwork[i__]; msd2 = matsiz / 2; ++curprb; } /* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2) into an eigensystem of size MATSIZ. CLAED7 handles the case when the eigenvectors of a full or band Hermitian matrix (which was reduced to tridiagonal form) are desired. I am free to use Q as a valuable working space until Loop 150. */ claed7_(&matsiz, &msd2, qsiz, &tlvls, &curlvl, &curprb, &d__[ submat], &qstore_ref(1, submat), ldqs, &e[submat + msd2 - 1], &iwork[indxq + submat], &rwork[iq], &iwork[iqptr], & iwork[iprmpt], &iwork[iperm], &iwork[igivpt], &iwork[ igivcl], &rwork[igivnm], &q_ref(1, submat), &rwork[iwrem], &iwork[subpbs + 1], info); if (*info > 0) { *info = submat * (*n + 1) + submat + matsiz - 1; return 0; } iwork[i__ / 2 + 1] = iwork[i__ + 2]; /* L90: */ } subpbs /= 2; ++curlvl; goto L80; } /* end while Re-merge the eigenvalues/vectors which were deflated at the final merge step. */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { j = iwork[indxq + i__]; rwork[i__] = d__[j]; ccopy_(qsiz, &qstore_ref(1, j), &c__1, &q_ref(1, i__), &c__1); /* L100: */ } scopy_(n, &rwork[1], &c__1, &d__[1], &c__1); return 0; /* End of CLAED0 */ } /* claed0_ */
/* Subroutine */ int sqrt03_(integer *m, integer *n, integer *k, real *af, real *c__, real *cc, real *q, integer *lda, real *tau, real *work, integer *lwork, real *rwork, real *result) { /* Initialized data */ static integer iseed[4] = { 1988,1989,1990,1991 }; /* System generated locals */ integer af_dim1, af_offset, c_dim1, c_offset, cc_dim1, cc_offset, q_dim1, q_offset, i__1; /* Builtin functions Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); /* Local variables */ static char side[1]; static integer info, j, iside; extern logical lsame_(char *, char *); static real resid; extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *); static real cnorm; static char trans[1]; static integer mc, nc; extern doublereal slamch_(char *), slange_(char *, integer *, integer *, real *, integer *, real *); extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *), slaset_(char *, integer *, integer *, real *, real *, real *, integer *); static integer itrans; extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real *), sorgqr_(integer *, integer *, integer *, real *, integer *, real *, real *, integer *, integer *), sormqr_(char *, char *, integer *, integer *, integer *, real *, integer *, real *, real * , integer *, real *, integer *, integer *); static real eps; #define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1] #define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1] #define af_ref(a_1,a_2) af[(a_2)*af_dim1 + a_1] /* -- LAPACK test routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= SQRT03 tests SORMQR, which computes Q*C, Q'*C, C*Q or C*Q'. SQRT03 compares the results of a call to SORMQR with the results of forming Q explicitly by a call to SORGQR and then performing matrix multiplication by a call to SGEMM. Arguments ========= M (input) INTEGER The order of the orthogonal matrix Q. M >= 0. N (input) INTEGER The number of rows or columns of the matrix C; C is m-by-n if Q is applied from the left, or n-by-m if Q is applied from the right. N >= 0. K (input) INTEGER The number of elementary reflectors whose product defines the orthogonal matrix Q. M >= K >= 0. AF (input) REAL array, dimension (LDA,N) Details of the QR factorization of an m-by-n matrix, as returnedby SGEQRF. See SGEQRF for further details. C (workspace) REAL array, dimension (LDA,N) CC (workspace) REAL array, dimension (LDA,N) Q (workspace) REAL array, dimension (LDA,M) LDA (input) INTEGER The leading dimension of the arrays AF, C, CC, and Q. TAU (input) REAL array, dimension (min(M,N)) The scalar factors of the elementary reflectors corresponding to the QR factorization in AF. WORK (workspace) REAL array, dimension (LWORK) LWORK (input) INTEGER The length of WORK. LWORK must be at least M, and should be M*NB, where NB is the blocksize for this environment. RWORK (workspace) REAL array, dimension (M) RESULT (output) REAL array, dimension (4) The test ratios compare two techniques for multiplying a random matrix C by an m-by-m orthogonal matrix Q. RESULT(1) = norm( Q*C - Q*C ) / ( M * norm(C) * EPS ) RESULT(2) = norm( C*Q - C*Q ) / ( M * norm(C) * EPS ) RESULT(3) = norm( Q'*C - Q'*C )/ ( M * norm(C) * EPS ) RESULT(4) = norm( C*Q' - C*Q' )/ ( M * norm(C) * EPS ) ===================================================================== Parameter adjustments */ q_dim1 = *lda; q_offset = 1 + q_dim1 * 1; q -= q_offset; cc_dim1 = *lda; cc_offset = 1 + cc_dim1 * 1; cc -= cc_offset; c_dim1 = *lda; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; af_dim1 = *lda; af_offset = 1 + af_dim1 * 1; af -= af_offset; --tau; --work; --rwork; --result; /* Function Body */ eps = slamch_("Epsilon"); /* Copy the first k columns of the factorization to the array Q */ slaset_("Full", m, m, &c_b4, &c_b4, &q[q_offset], lda); i__1 = *m - 1; slacpy_("Lower", &i__1, k, &af_ref(2, 1), lda, &q_ref(2, 1), lda); /* Generate the m-by-m matrix Q */ s_copy(srnamc_1.srnamt, "SORGQR", (ftnlen)6, (ftnlen)6); sorgqr_(m, m, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info); for (iside = 1; iside <= 2; ++iside) { if (iside == 1) { *(unsigned char *)side = 'L'; mc = *m; nc = *n; } else { *(unsigned char *)side = 'R'; mc = *n; nc = *m; } /* Generate MC by NC matrix C */ i__1 = nc; for (j = 1; j <= i__1; ++j) { slarnv_(&c__2, iseed, &mc, &c___ref(1, j)); /* L10: */ } cnorm = slange_("1", &mc, &nc, &c__[c_offset], lda, &rwork[1]); if (cnorm == 0.f) { cnorm = 1.f; } for (itrans = 1; itrans <= 2; ++itrans) { if (itrans == 1) { *(unsigned char *)trans = 'N'; } else { *(unsigned char *)trans = 'T'; } /* Copy C */ slacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset], lda); /* Apply Q or Q' to C */ s_copy(srnamc_1.srnamt, "SORMQR", (ftnlen)6, (ftnlen)6); sormqr_(side, trans, &mc, &nc, k, &af[af_offset], lda, &tau[1], & cc[cc_offset], lda, &work[1], lwork, &info); /* Form explicit product and subtract */ if (lsame_(side, "L")) { sgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b21, &q[ q_offset], lda, &c__[c_offset], lda, &c_b22, &cc[ cc_offset], lda); } else { sgemm_("No transpose", trans, &mc, &nc, &nc, &c_b21, &c__[ c_offset], lda, &q[q_offset], lda, &c_b22, &cc[ cc_offset], lda); } /* Compute error in the difference */ resid = slange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]); result[(iside - 1 << 1) + itrans] = resid / ((real) max(1,*m) * cnorm * eps); /* L20: */ } /* L30: */ } return 0; /* End of SQRT03 */ } /* sqrt03_ */
/* Subroutine */ int dgghrd_(char *compq, char *compz, integer *n, integer * ilo, integer *ihi, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *q, integer *ldq, doublereal *z__, integer * ldz, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= DGGHRD reduces a pair of real matrices (A,B) to generalized upper Hessenberg form using orthogonal transformations, where A is a general matrix and B is upper triangular: Q' * A * Z = H and Q' * B * Z = T, where H is upper Hessenberg, T is upper triangular, and Q and Z are orthogonal, and ' means transpose. The orthogonal matrices Q and Z are determined as products of Givens rotations. They may either be formed explicitly, or they may be postmultiplied into input matrices Q1 and Z1, so that Q1 * A * Z1' = (Q1*Q) * H * (Z1*Z)' Q1 * B * Z1' = (Q1*Q) * T * (Z1*Z)' Arguments ========= COMPQ (input) CHARACTER*1 = 'N': do not compute Q; = 'I': Q is initialized to the unit matrix, and the orthogonal matrix Q is returned; = 'V': Q must contain an orthogonal matrix Q1 on entry, and the product Q1*Q is returned. COMPZ (input) CHARACTER*1 = 'N': do not compute Z; = 'I': Z is initialized to the unit matrix, and the orthogonal matrix Z is returned; = 'V': Z must contain an orthogonal matrix Z1 on entry, and the product Z1*Z is returned. N (input) INTEGER The order of the matrices A and B. N >= 0. ILO (input) INTEGER IHI (input) INTEGER It is assumed that A 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 DGGBAL; otherwise they should be set to 1 and N respectively. 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. A (input/output) DOUBLE PRECISION array, dimension (LDA, N) On entry, the N-by-N general matrix to be reduced. On exit, the upper triangle and the first subdiagonal of A are overwritten with the upper Hessenberg matrix H, and the rest is set to zero. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,N). B (input/output) DOUBLE PRECISION array, dimension (LDB, N) On entry, the N-by-N upper triangular matrix B. On exit, the upper triangular matrix T = Q' B Z. The elements below the diagonal are set to zero. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,N). Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) If COMPQ='N': Q is not referenced. If COMPQ='I': on entry, Q need not be set, and on exit it contains the orthogonal matrix Q, where Q' is the product of the Givens transformations which are applied to A and B on the left. If COMPQ='V': on entry, Q must contain an orthogonal matrix Q1, and on exit this is overwritten by Q1*Q. LDQ (input) INTEGER The leading dimension of the array Q. LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. 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 it contains the orthogonal matrix Z, which is the product of the Givens transformations which are applied to A and B on the right. If COMPZ='V': on entry, Z must contain an orthogonal matrix Z1, and on exit this is overwritten by Z1*Z. LDZ (input) INTEGER The leading dimension of the array Z. LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise. INFO (output) INTEGER = 0: successful exit. < 0: if INFO = -i, the i-th argument had an illegal value. Further Details =============== This routine reduces A to Hessenberg and B to triangular form by an unblocked reduction, as described in _Matrix_Computations_, by Golub and Van Loan (Johns Hopkins Press.) ===================================================================== Decode COMPQ Parameter adjustments */ /* Table of constant values */ static doublereal c_b10 = 0.; static doublereal c_b11 = 1.; static integer c__1 = 1; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, z_offset, i__1, i__2, i__3; /* Local variables */ static integer jcol; static doublereal temp; extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *); static integer jrow; static doublereal c__, s; extern logical lsame_(char *, char *); extern /* Subroutine */ int dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *), dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *), xerbla_(char *, integer *); static integer icompq, icompz; static logical ilq, ilz; #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] #define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1] #define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1] #define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; q_dim1 = *ldq; q_offset = 1 + q_dim1 * 1; q -= q_offset; z_dim1 = *ldz; z_offset = 1 + z_dim1 * 1; z__ -= z_offset; /* Function Body */ if (lsame_(compq, "N")) { ilq = FALSE_; icompq = 1; } else if (lsame_(compq, "V")) { ilq = TRUE_; icompq = 2; } else if (lsame_(compq, "I")) { ilq = TRUE_; icompq = 3; } else { icompq = 0; } /* Decode COMPZ */ if (lsame_(compz, "N")) { ilz = FALSE_; icompz = 1; } else if (lsame_(compz, "V")) { ilz = TRUE_; icompz = 2; } else if (lsame_(compz, "I")) { ilz = TRUE_; icompz = 3; } else { icompz = 0; } /* Test the input parameters. */ *info = 0; if (icompq <= 0) { *info = -1; } else if (icompz <= 0) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*ilo < 1) { *info = -4; } else if (*ihi > *n || *ihi < *ilo - 1) { *info = -5; } else if (*lda < max(1,*n)) { *info = -7; } else if (*ldb < max(1,*n)) { *info = -9; } else if (ilq && *ldq < *n || *ldq < 1) { *info = -11; } else if (ilz && *ldz < *n || *ldz < 1) { *info = -13; } if (*info != 0) { i__1 = -(*info); xerbla_("DGGHRD", &i__1); return 0; } /* Initialize Q and Z if desired. */ if (icompq == 3) { dlaset_("Full", n, n, &c_b10, &c_b11, &q[q_offset], ldq); } if (icompz == 3) { dlaset_("Full", n, n, &c_b10, &c_b11, &z__[z_offset], ldz); } /* Quick return if possible */ if (*n <= 1) { return 0; } /* Zero out lower triangle of B */ i__1 = *n - 1; for (jcol = 1; jcol <= i__1; ++jcol) { i__2 = *n; for (jrow = jcol + 1; jrow <= i__2; ++jrow) { b_ref(jrow, jcol) = 0.; /* L10: */ } /* L20: */ } /* Reduce A and B */ i__1 = *ihi - 2; for (jcol = *ilo; jcol <= i__1; ++jcol) { i__2 = jcol + 2; for (jrow = *ihi; jrow >= i__2; --jrow) { /* Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL) */ temp = a_ref(jrow - 1, jcol); dlartg_(&temp, &a_ref(jrow, jcol), &c__, &s, &a_ref(jrow - 1, jcol)); a_ref(jrow, jcol) = 0.; i__3 = *n - jcol; drot_(&i__3, &a_ref(jrow - 1, jcol + 1), lda, &a_ref(jrow, jcol + 1), lda, &c__, &s); i__3 = *n + 2 - jrow; drot_(&i__3, &b_ref(jrow - 1, jrow - 1), ldb, &b_ref(jrow, jrow - 1), ldb, &c__, &s); if (ilq) { drot_(n, &q_ref(1, jrow - 1), &c__1, &q_ref(1, jrow), &c__1, & c__, &s); } /* Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1) */ temp = b_ref(jrow, jrow); dlartg_(&temp, &b_ref(jrow, jrow - 1), &c__, &s, &b_ref(jrow, jrow)); b_ref(jrow, jrow - 1) = 0.; drot_(ihi, &a_ref(1, jrow), &c__1, &a_ref(1, jrow - 1), &c__1, & c__, &s); i__3 = jrow - 1; drot_(&i__3, &b_ref(1, jrow), &c__1, &b_ref(1, jrow - 1), &c__1, & c__, &s); if (ilz) { drot_(n, &z___ref(1, jrow), &c__1, &z___ref(1, jrow - 1), & c__1, &c__, &s); } /* L30: */ } /* L40: */ } return 0; /* End of DGGHRD */ } /* dgghrd_ */
/* Subroutine */ int zhgeqz_(char *job, char *compq, char *compz, integer *n, integer *ilo, integer *ihi, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *alpha, doublecomplex * beta, doublecomplex *q, integer *ldq, doublecomplex *z__, integer * ldz, doublecomplex *work, integer *lwork, doublereal *rwork, integer * info) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6; doublereal d__1, d__2, d__3, d__4, d__5, d__6; doublecomplex z__1, z__2, z__3, z__4, z__5, z__6; /* Builtin functions */ double z_abs(doublecomplex *); void d_cnjg(doublecomplex *, doublecomplex *); double d_imag(doublecomplex *); void z_div(doublecomplex *, doublecomplex *, doublecomplex *), pow_zi( doublecomplex *, doublecomplex *, integer *), z_sqrt( doublecomplex *, doublecomplex *); /* Local variables */ static doublereal absb, atol, btol, temp, opst; extern /* Subroutine */ int zrot_(integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublereal *, doublecomplex *); static doublereal temp2, c__; static integer j; static doublecomplex s, t; extern logical lsame_(char *, char *); static doublecomplex ctemp; static integer iiter, ilast, jiter; static doublereal anorm; static integer maxit; static doublereal bnorm; static doublecomplex shift; extern /* Subroutine */ int zscal_(integer *, doublecomplex *, doublecomplex *, integer *); static doublereal tempr; static doublecomplex ctemp2, ctemp3; static logical ilazr2; static integer jc, in; static doublereal ascale, bscale; static doublecomplex u12; extern doublereal dlamch_(char *); static integer jr, nq; static doublecomplex signbc; static integer nz; static doublereal safmin; extern /* Subroutine */ int xerbla_(char *, integer *); static doublecomplex eshift; static logical ilschr; static integer icompq, ilastm; static doublecomplex rtdisc; static integer ischur; extern doublereal zlanhs_(char *, integer *, doublecomplex *, integer *, doublereal *); static logical ilazro; static integer icompz, ifirst; extern /* Subroutine */ int zlartg_(doublecomplex *, doublecomplex *, doublereal *, doublecomplex *, doublecomplex *); static integer ifrstm; extern /* Subroutine */ int zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *); static integer istart; static logical lquery; static doublecomplex ad11, ad12, ad21, ad22; static integer jch; static logical ilq, ilz; static doublereal ulp; static doublecomplex abi22; #define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1 #define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)] #define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1 #define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)] #define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1 #define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)] #define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1 #define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)] /* -- LAPACK routine (instrumented to count operations, version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University June 30, 1999 ----------------------- Begin Timing Code ------------------------ Common block to return operation count and iteration count ITCNT is initialized to 0, OPS is only incremented OPST is used to accumulate small contributions to OPS to avoid roundoff error ------------------------ End Timing Code ------------------------- Purpose ======= ZHGEQZ implements a single-shift version of the QZ method for finding the generalized eigenvalues w(i)=ALPHA(i)/BETA(i) of the equation det( A - w(i) B ) = 0 If JOB='S', then the pair (A,B) is simultaneously reduced to Schur form (i.e., A and B are both upper triangular) by applying one unitary tranformation (usually called Q) on the left and another (usually called Z) on the right. The diagonal elements of A are then ALPHA(1),...,ALPHA(N), and of B are BETA(1),...,BETA(N). If JOB='S' and COMPQ and COMPZ are 'V' or 'I', then the unitary transformations used to reduce (A,B) are accumulated into the arrays Q and Z s.t.: Q(in) A(in) Z(in)* = Q(out) A(out) Z(out)* Q(in) B(in) Z(in)* = Q(out) B(out) Z(out)* Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), pp. 241--256. Arguments ========= JOB (input) CHARACTER*1 = 'E': compute only ALPHA and BETA. A and B will not necessarily be put into generalized Schur form. = 'S': put A and B into generalized Schur form, as well as computing ALPHA and BETA. COMPQ (input) CHARACTER*1 = 'N': do not modify Q. = 'V': multiply the array Q on the right by the conjugate transpose of the unitary tranformation that is applied to the left side of A and B to reduce them to Schur form. = 'I': like COMPQ='V', except that Q will be initialized to the identity first. COMPZ (input) CHARACTER*1 = 'N': do not modify Z. = 'V': multiply the array Z on the right by the unitary tranformation that is applied to the right side of A and B to reduce them to Schur form. = 'I': like COMPZ='V', except that Z will be initialized to the identity first. N (input) INTEGER The order of the matrices A, B, Q, and Z. N >= 0. ILO (input) INTEGER IHI (input) INTEGER It is assumed that A is already upper triangular in rows and columns 1:ILO-1 and IHI+1:N. 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. A (input/output) COMPLEX*16 array, dimension (LDA, N) On entry, the N-by-N upper Hessenberg matrix A. Elements below the subdiagonal must be zero. If JOB='S', then on exit A and B will have been simultaneously reduced to upper triangular form. If JOB='E', then on exit A will have been destroyed. LDA (input) INTEGER The leading dimension of the array A. LDA >= max( 1, N ). B (input/output) COMPLEX*16 array, dimension (LDB, N) On entry, the N-by-N upper triangular matrix B. Elements below the diagonal must be zero. If JOB='S', then on exit A and B will have been simultaneously reduced to upper triangular form. If JOB='E', then on exit B will have been destroyed. LDB (input) INTEGER The leading dimension of the array B. LDB >= max( 1, N ). ALPHA (output) COMPLEX*16 array, dimension (N) The diagonal elements of A when the pair (A,B) has been reduced to Schur form. ALPHA(i)/BETA(i) i=1,...,N are the generalized eigenvalues. BETA (output) COMPLEX*16 array, dimension (N) The diagonal elements of B when the pair (A,B) has been reduced to Schur form. ALPHA(i)/BETA(i) i=1,...,N are the generalized eigenvalues. A and B are normalized so that BETA(1),...,BETA(N) are non-negative real numbers. Q (input/output) COMPLEX*16 array, dimension (LDQ, N) If COMPQ='N', then Q will not be referenced. If COMPQ='V' or 'I', then the conjugate transpose of the unitary transformations which are applied to A and B on the left will be applied to the array Q on the right. LDQ (input) INTEGER The leading dimension of the array Q. LDQ >= 1. If COMPQ='V' or 'I', then LDQ >= N. Z (input/output) COMPLEX*16 array, dimension (LDZ, N) If COMPZ='N', then Z will not be referenced. If COMPZ='V' or 'I', then the unitary transformations which are applied to A and B on the right will be applied to the array Z on the right. LDZ (input) INTEGER The leading dimension of the array Z. LDZ >= 1. If COMPZ='V' or 'I', then LDZ >= N. WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. LWORK (input) INTEGER The dimension of the array WORK. LWORK >= max(1,N). If LWORK = -1, then a workspace query is assumed; the routine only calculates the optimal size of the WORK array, returns this value as the first entry of the WORK array, and no error message related to LWORK is issued by XERBLA. RWORK (workspace) DOUBLE PRECISION array, dimension (N) INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value = 1,...,N: the QZ iteration did not converge. (A,B) is not in Schur form, but ALPHA(i) and BETA(i), i=INFO+1,...,N should be correct. = N+1,...,2*N: the shift calculation failed. (A,B) is not in Schur form, but ALPHA(i) and BETA(i), i=INFO-N+1,...,N should be correct. > 2*N: various "impossible" errors. Further Details =============== We assume that complex ABS works as long as its value is less than overflow. ===================================================================== ----------------------- Begin Timing Code ------------------------ Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; --alpha; --beta; q_dim1 = *ldq; q_offset = 1 + q_dim1 * 1; q -= q_offset; z_dim1 = *ldz; z_offset = 1 + z_dim1 * 1; z__ -= z_offset; --work; --rwork; /* Function Body */ latime_1.itcnt = 0.; /* ------------------------ End Timing Code ------------------------- Decode JOB, COMPQ, COMPZ */ if (lsame_(job, "E")) { ilschr = FALSE_; ischur = 1; } else if (lsame_(job, "S")) { ilschr = TRUE_; ischur = 2; } else { ischur = 0; } if (lsame_(compq, "N")) { ilq = FALSE_; icompq = 1; nq = 0; } else if (lsame_(compq, "V")) { ilq = TRUE_; icompq = 2; nq = *n; } else if (lsame_(compq, "I")) { ilq = TRUE_; icompq = 3; nq = *n; } else { icompq = 0; } if (lsame_(compz, "N")) { ilz = FALSE_; icompz = 1; nz = 0; } else if (lsame_(compz, "V")) { ilz = TRUE_; icompz = 2; nz = *n; } else if (lsame_(compz, "I")) { ilz = TRUE_; icompz = 3; nz = *n; } else { icompz = 0; } /* Check Argument Values */ *info = 0; i__1 = max(1,*n); work[1].r = (doublereal) i__1, work[1].i = 0.; lquery = *lwork == -1; if (ischur == 0) { *info = -1; } else if (icompq == 0) { *info = -2; } else if (icompz == 0) { *info = -3; } else if (*n < 0) { *info = -4; } else if (*ilo < 1) { *info = -5; } else if (*ihi > *n || *ihi < *ilo - 1) { *info = -6; } else if (*lda < *n) { *info = -8; } else if (*ldb < *n) { *info = -10; } else if (*ldq < 1 || ilq && *ldq < *n) { *info = -14; } else if (*ldz < 1 || ilz && *ldz < *n) { *info = -16; } else if (*lwork < max(1,*n) && ! lquery) { *info = -18; } if (*info != 0) { i__1 = -(*info); xerbla_("ZHGEQZ", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible WORK( 1 ) = CMPLX( 1 ) */ if (*n <= 0) { work[1].r = 1., work[1].i = 0.; return 0; } /* Initialize Q and Z */ if (icompq == 3) { zlaset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq); } if (icompz == 3) { zlaset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz); } /* Machine Constants */ in = *ihi + 1 - *ilo; safmin = dlamch_("S"); ulp = dlamch_("E") * dlamch_("B"); anorm = zlanhs_("F", &in, &a_ref(*ilo, *ilo), lda, &rwork[1]); bnorm = zlanhs_("F", &in, &b_ref(*ilo, *ilo), ldb, &rwork[1]); /* Computing MAX */ d__1 = safmin, d__2 = ulp * anorm; atol = max(d__1,d__2); /* Computing MAX */ d__1 = safmin, d__2 = ulp * bnorm; btol = max(d__1,d__2); ascale = 1. / max(safmin,anorm); bscale = 1. / max(safmin,bnorm); /* ---------------------- Begin Timing Code ------------------------- Count ops for norms, etc. */ opst = 0.; /* Computing 2nd power */ i__1 = *n; latime_1.ops += (doublereal) ((i__1 * i__1 << 2) + *n * 12 - 5); /* ----------------------- End Timing Code -------------------------- Set Eigenvalues IHI+1:N */ i__1 = *n; for (j = *ihi + 1; j <= i__1; ++j) { absb = z_abs(&b_ref(j, j)); if (absb > safmin) { i__2 = b_subscr(j, j); z__2.r = b[i__2].r / absb, z__2.i = b[i__2].i / absb; d_cnjg(&z__1, &z__2); signbc.r = z__1.r, signbc.i = z__1.i; i__2 = b_subscr(j, j); b[i__2].r = absb, b[i__2].i = 0.; if (ilschr) { i__2 = j - 1; zscal_(&i__2, &signbc, &b_ref(1, j), &c__1); zscal_(&j, &signbc, &a_ref(1, j), &c__1); /* ----------------- Begin Timing Code --------------------- */ opst += (doublereal) ((j - 1) * 12); /* ------------------ End Timing Code ---------------------- */ } else { i__2 = a_subscr(j, j); i__3 = a_subscr(j, j); z__1.r = a[i__3].r * signbc.r - a[i__3].i * signbc.i, z__1.i = a[i__3].r * signbc.i + a[i__3].i * signbc.r; a[i__2].r = z__1.r, a[i__2].i = z__1.i; } if (ilz) { zscal_(n, &signbc, &z___ref(1, j), &c__1); } /* ------------------- Begin Timing Code ---------------------- */ opst += (doublereal) (nz * 6 + 13); /* -------------------- End Timing Code ----------------------- */ } else { i__2 = b_subscr(j, j); b[i__2].r = 0., b[i__2].i = 0.; } i__2 = j; i__3 = a_subscr(j, j); alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i; i__2 = j; i__3 = b_subscr(j, j); beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i; /* L10: */ } /* If IHI < ILO, skip QZ steps */ if (*ihi < *ilo) { goto L190; } /* MAIN QZ ITERATION LOOP Initialize dynamic indices Eigenvalues ILAST+1:N have been found. Column operations modify rows IFRSTM:whatever Row operations modify columns whatever:ILASTM If only eigenvalues are being computed, then IFRSTM is the row of the last splitting row above row ILAST; this is always at least ILO. IITER counts iterations since the last eigenvalue was found, to tell when to use an extraordinary shift. MAXIT is the maximum number of QZ sweeps allowed. */ ilast = *ihi; if (ilschr) { ifrstm = 1; ilastm = *n; } else { ifrstm = *ilo; ilastm = *ihi; } iiter = 0; eshift.r = 0., eshift.i = 0.; maxit = (*ihi - *ilo + 1) * 30; i__1 = maxit; for (jiter = 1; jiter <= i__1; ++jiter) { /* Check for too many iterations. */ if (jiter > maxit) { goto L180; } /* Split the matrix if possible. Two tests: 1: A(j,j-1)=0 or j=ILO 2: B(j,j)=0 Special case: j=ILAST */ if (ilast == *ilo) { goto L60; } else { i__2 = a_subscr(ilast, ilast - 1); if ((d__1 = a[i__2].r, abs(d__1)) + (d__2 = d_imag(&a_ref(ilast, ilast - 1)), abs(d__2)) <= atol) { i__2 = a_subscr(ilast, ilast - 1); a[i__2].r = 0., a[i__2].i = 0.; goto L60; } } if (z_abs(&b_ref(ilast, ilast)) <= btol) { i__2 = b_subscr(ilast, ilast); b[i__2].r = 0., b[i__2].i = 0.; goto L50; } /* General case: j<ILAST */ i__2 = *ilo; for (j = ilast - 1; j >= i__2; --j) { /* Test 1: for A(j,j-1)=0 or j=ILO */ if (j == *ilo) { ilazro = TRUE_; } else { i__3 = a_subscr(j, j - 1); if ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a_ref(j, j - 1)), abs(d__2)) <= atol) { i__3 = a_subscr(j, j - 1); a[i__3].r = 0., a[i__3].i = 0.; ilazro = TRUE_; } else { ilazro = FALSE_; } } /* Test 2: for B(j,j)=0 */ if (z_abs(&b_ref(j, j)) < btol) { i__3 = b_subscr(j, j); b[i__3].r = 0., b[i__3].i = 0.; /* Test 1a: Check for 2 consecutive small subdiagonals in A */ ilazr2 = FALSE_; if (! ilazro) { i__3 = a_subscr(j, j - 1); i__4 = a_subscr(j + 1, j); i__5 = a_subscr(j, j); if (((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(& a_ref(j, j - 1)), abs(d__2))) * (ascale * ((d__3 = a[i__4].r, abs(d__3)) + (d__4 = d_imag(&a_ref(j + 1, j)), abs(d__4)))) <= ((d__5 = a[i__5].r, abs( d__5)) + (d__6 = d_imag(&a_ref(j, j)), abs(d__6))) * (ascale * atol)) { ilazr2 = TRUE_; } } /* If both tests pass (1 & 2), i.e., the leading diagonal element of B in the block is zero, split a 1x1 block off at the top. (I.e., at the J-th row/column) The leading diagonal element of the remainder can also be zero, so this may have to be done repeatedly. */ if (ilazro || ilazr2) { i__3 = ilast - 1; for (jch = j; jch <= i__3; ++jch) { i__4 = a_subscr(jch, jch); ctemp.r = a[i__4].r, ctemp.i = a[i__4].i; zlartg_(&ctemp, &a_ref(jch + 1, jch), &c__, &s, & a_ref(jch, jch)); i__4 = a_subscr(jch + 1, jch); a[i__4].r = 0., a[i__4].i = 0.; i__4 = ilastm - jch; zrot_(&i__4, &a_ref(jch, jch + 1), lda, &a_ref(jch + 1, jch + 1), lda, &c__, &s); i__4 = ilastm - jch; zrot_(&i__4, &b_ref(jch, jch + 1), ldb, &b_ref(jch + 1, jch + 1), ldb, &c__, &s); if (ilq) { d_cnjg(&z__1, &s); zrot_(n, &q_ref(1, jch), &c__1, &q_ref(1, jch + 1) , &c__1, &c__, &z__1); } if (ilazr2) { i__4 = a_subscr(jch, jch - 1); i__5 = a_subscr(jch, jch - 1); z__1.r = c__ * a[i__5].r, z__1.i = c__ * a[i__5] .i; a[i__4].r = z__1.r, a[i__4].i = z__1.i; } ilazr2 = FALSE_; /* --------------- Begin Timing Code ----------------- */ opst += (doublereal) ((ilastm - jch) * 40 + 32 + nq * 20); /* ---------------- End Timing Code ------------------ */ i__4 = b_subscr(jch + 1, jch + 1); if ((d__1 = b[i__4].r, abs(d__1)) + (d__2 = d_imag(& b_ref(jch + 1, jch + 1)), abs(d__2)) >= btol) { if (jch + 1 >= ilast) { goto L60; } else { ifirst = jch + 1; goto L70; } } i__4 = b_subscr(jch + 1, jch + 1); b[i__4].r = 0., b[i__4].i = 0.; /* L20: */ } goto L50; } else { /* Only test 2 passed -- chase the zero to B(ILAST,ILAST) Then process as in the case B(ILAST,ILAST)=0 */ i__3 = ilast - 1; for (jch = j; jch <= i__3; ++jch) { i__4 = b_subscr(jch, jch + 1); ctemp.r = b[i__4].r, ctemp.i = b[i__4].i; zlartg_(&ctemp, &b_ref(jch + 1, jch + 1), &c__, &s, & b_ref(jch, jch + 1)); i__4 = b_subscr(jch + 1, jch + 1); b[i__4].r = 0., b[i__4].i = 0.; if (jch < ilastm - 1) { i__4 = ilastm - jch - 1; zrot_(&i__4, &b_ref(jch, jch + 2), ldb, &b_ref( jch + 1, jch + 2), ldb, &c__, &s); } i__4 = ilastm - jch + 2; zrot_(&i__4, &a_ref(jch, jch - 1), lda, &a_ref(jch + 1, jch - 1), lda, &c__, &s); if (ilq) { d_cnjg(&z__1, &s); zrot_(n, &q_ref(1, jch), &c__1, &q_ref(1, jch + 1) , &c__1, &c__, &z__1); } i__4 = a_subscr(jch + 1, jch); ctemp.r = a[i__4].r, ctemp.i = a[i__4].i; zlartg_(&ctemp, &a_ref(jch + 1, jch - 1), &c__, &s, & a_ref(jch + 1, jch)); i__4 = a_subscr(jch + 1, jch - 1); a[i__4].r = 0., a[i__4].i = 0.; i__4 = jch + 1 - ifrstm; zrot_(&i__4, &a_ref(ifrstm, jch), &c__1, &a_ref( ifrstm, jch - 1), &c__1, &c__, &s); i__4 = jch - ifrstm; zrot_(&i__4, &b_ref(ifrstm, jch), &c__1, &b_ref( ifrstm, jch - 1), &c__1, &c__, &s); if (ilz) { zrot_(n, &z___ref(1, jch), &c__1, &z___ref(1, jch - 1), &c__1, &c__, &s); } /* L30: */ } /* ---------------- Begin Timing Code ------------------- */ opst += (doublereal) ((ilastm + 1 - ifrstm) * 40 + 64 + ( nq + nz) * 20) * (doublereal) (ilast - j); /* ----------------- End Timing Code -------------------- */ goto L50; } } else if (ilazro) { /* Only test 1 passed -- work on J:ILAST */ ifirst = j; goto L70; } /* Neither test passed -- try next J L40: */ } /* (Drop-through is "impossible") */ *info = (*n << 1) + 1; goto L210; /* B(ILAST,ILAST)=0 -- clear A(ILAST,ILAST-1) to split off a 1x1 block. */ L50: i__2 = a_subscr(ilast, ilast); ctemp.r = a[i__2].r, ctemp.i = a[i__2].i; zlartg_(&ctemp, &a_ref(ilast, ilast - 1), &c__, &s, &a_ref(ilast, ilast)); i__2 = a_subscr(ilast, ilast - 1); a[i__2].r = 0., a[i__2].i = 0.; i__2 = ilast - ifrstm; zrot_(&i__2, &a_ref(ifrstm, ilast), &c__1, &a_ref(ifrstm, ilast - 1), &c__1, &c__, &s); i__2 = ilast - ifrstm; zrot_(&i__2, &b_ref(ifrstm, ilast), &c__1, &b_ref(ifrstm, ilast - 1), &c__1, &c__, &s); if (ilz) { zrot_(n, &z___ref(1, ilast), &c__1, &z___ref(1, ilast - 1), &c__1, &c__, &s); } /* --------------------- Begin Timing Code ----------------------- */ opst += (doublereal) ((ilast - ifrstm) * 40 + 32 + nz * 20); /* ---------------------- End Timing Code ------------------------ A(ILAST,ILAST-1)=0 -- Standardize B, set ALPHA and BETA */ L60: absb = z_abs(&b_ref(ilast, ilast)); if (absb > safmin) { i__2 = b_subscr(ilast, ilast); z__2.r = b[i__2].r / absb, z__2.i = b[i__2].i / absb; d_cnjg(&z__1, &z__2); signbc.r = z__1.r, signbc.i = z__1.i; i__2 = b_subscr(ilast, ilast); b[i__2].r = absb, b[i__2].i = 0.; if (ilschr) { i__2 = ilast - ifrstm; zscal_(&i__2, &signbc, &b_ref(ifrstm, ilast), &c__1); i__2 = ilast + 1 - ifrstm; zscal_(&i__2, &signbc, &a_ref(ifrstm, ilast), &c__1); /* ----------------- Begin Timing Code --------------------- */ opst += (doublereal) ((ilast - ifrstm) * 12); /* ------------------ End Timing Code ---------------------- */ } else { i__2 = a_subscr(ilast, ilast); i__3 = a_subscr(ilast, ilast); z__1.r = a[i__3].r * signbc.r - a[i__3].i * signbc.i, z__1.i = a[i__3].r * signbc.i + a[i__3].i * signbc.r; a[i__2].r = z__1.r, a[i__2].i = z__1.i; } if (ilz) { zscal_(n, &signbc, &z___ref(1, ilast), &c__1); } /* ------------------- Begin Timing Code ---------------------- */ opst += (doublereal) (nz * 6 + 13); /* -------------------- End Timing Code ----------------------- */ } else { i__2 = b_subscr(ilast, ilast); b[i__2].r = 0., b[i__2].i = 0.; } i__2 = ilast; i__3 = a_subscr(ilast, ilast); alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i; i__2 = ilast; i__3 = b_subscr(ilast, ilast); beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i; /* Go to next block -- exit if finished. */ --ilast; if (ilast < *ilo) { goto L190; } /* Reset counters */ iiter = 0; eshift.r = 0., eshift.i = 0.; if (! ilschr) { ilastm = ilast; if (ifrstm > ilast) { ifrstm = *ilo; } } goto L160; /* QZ step This iteration only involves rows/columns IFIRST:ILAST. We assume IFIRST < ILAST, and that the diagonal of B is non-zero. */ L70: ++iiter; if (! ilschr) { ifrstm = ifirst; } /* Compute the Shift. At this point, IFIRST < ILAST, and the diagonal elements of B(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in magnitude) */ if (iiter / 10 * 10 != iiter) { /* The Wilkinson shift (AEP p.512), i.e., the eigenvalue of the bottom-right 2x2 block of A inv(B) which is nearest to the bottom-right element. We factor B as U*D, where U has unit diagonals, and compute (A*inv(D))*inv(U). */ i__2 = b_subscr(ilast - 1, ilast); z__2.r = bscale * b[i__2].r, z__2.i = bscale * b[i__2].i; i__3 = b_subscr(ilast, ilast); z__3.r = bscale * b[i__3].r, z__3.i = bscale * b[i__3].i; z_div(&z__1, &z__2, &z__3); u12.r = z__1.r, u12.i = z__1.i; i__2 = a_subscr(ilast - 1, ilast - 1); z__2.r = ascale * a[i__2].r, z__2.i = ascale * a[i__2].i; i__3 = b_subscr(ilast - 1, ilast - 1); z__3.r = bscale * b[i__3].r, z__3.i = bscale * b[i__3].i; z_div(&z__1, &z__2, &z__3); ad11.r = z__1.r, ad11.i = z__1.i; i__2 = a_subscr(ilast, ilast - 1); z__2.r = ascale * a[i__2].r, z__2.i = ascale * a[i__2].i; i__3 = b_subscr(ilast - 1, ilast - 1); z__3.r = bscale * b[i__3].r, z__3.i = bscale * b[i__3].i; z_div(&z__1, &z__2, &z__3); ad21.r = z__1.r, ad21.i = z__1.i; i__2 = a_subscr(ilast - 1, ilast); z__2.r = ascale * a[i__2].r, z__2.i = ascale * a[i__2].i; i__3 = b_subscr(ilast, ilast); z__3.r = bscale * b[i__3].r, z__3.i = bscale * b[i__3].i; z_div(&z__1, &z__2, &z__3); ad12.r = z__1.r, ad12.i = z__1.i; i__2 = a_subscr(ilast, ilast); z__2.r = ascale * a[i__2].r, z__2.i = ascale * a[i__2].i; i__3 = b_subscr(ilast, ilast); z__3.r = bscale * b[i__3].r, z__3.i = bscale * b[i__3].i; z_div(&z__1, &z__2, &z__3); ad22.r = z__1.r, ad22.i = z__1.i; z__2.r = u12.r * ad21.r - u12.i * ad21.i, z__2.i = u12.r * ad21.i + u12.i * ad21.r; z__1.r = ad22.r - z__2.r, z__1.i = ad22.i - z__2.i; abi22.r = z__1.r, abi22.i = z__1.i; z__2.r = ad11.r + abi22.r, z__2.i = ad11.i + abi22.i; z__1.r = z__2.r * .5, z__1.i = z__2.i * .5; t.r = z__1.r, t.i = z__1.i; pow_zi(&z__4, &t, &c__2); z__5.r = ad12.r * ad21.r - ad12.i * ad21.i, z__5.i = ad12.r * ad21.i + ad12.i * ad21.r; z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i; z__6.r = ad11.r * ad22.r - ad11.i * ad22.i, z__6.i = ad11.r * ad22.i + ad11.i * ad22.r; z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i; z_sqrt(&z__1, &z__2); rtdisc.r = z__1.r, rtdisc.i = z__1.i; z__1.r = t.r - abi22.r, z__1.i = t.i - abi22.i; z__2.r = t.r - abi22.r, z__2.i = t.i - abi22.i; temp = z__1.r * rtdisc.r + d_imag(&z__2) * d_imag(&rtdisc); if (temp <= 0.) { z__1.r = t.r + rtdisc.r, z__1.i = t.i + rtdisc.i; shift.r = z__1.r, shift.i = z__1.i; } else { z__1.r = t.r - rtdisc.r, z__1.i = t.i - rtdisc.i; shift.r = z__1.r, shift.i = z__1.i; } /* ------------------- Begin Timing Code ---------------------- */ opst += 116.; /* -------------------- End Timing Code ----------------------- */ } else { /* Exceptional shift. Chosen for no particularly good reason. */ i__2 = a_subscr(ilast - 1, ilast); z__4.r = ascale * a[i__2].r, z__4.i = ascale * a[i__2].i; i__3 = b_subscr(ilast - 1, ilast - 1); z__5.r = bscale * b[i__3].r, z__5.i = bscale * b[i__3].i; z_div(&z__3, &z__4, &z__5); d_cnjg(&z__2, &z__3); z__1.r = eshift.r + z__2.r, z__1.i = eshift.i + z__2.i; eshift.r = z__1.r, eshift.i = z__1.i; shift.r = eshift.r, shift.i = eshift.i; /* ------------------- Begin Timing Code ---------------------- */ opst += 15.; /* -------------------- End Timing Code ----------------------- */ } /* Now check for two consecutive small subdiagonals. */ i__2 = ifirst + 1; for (j = ilast - 1; j >= i__2; --j) { istart = j; i__3 = a_subscr(j, j); z__2.r = ascale * a[i__3].r, z__2.i = ascale * a[i__3].i; i__4 = b_subscr(j, j); z__4.r = bscale * b[i__4].r, z__4.i = bscale * b[i__4].i; z__3.r = shift.r * z__4.r - shift.i * z__4.i, z__3.i = shift.r * z__4.i + shift.i * z__4.r; z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; ctemp.r = z__1.r, ctemp.i = z__1.i; temp = (d__1 = ctemp.r, abs(d__1)) + (d__2 = d_imag(&ctemp), abs( d__2)); i__3 = a_subscr(j + 1, j); temp2 = ascale * ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(& a_ref(j + 1, j)), abs(d__2))); tempr = max(temp,temp2); if (tempr < 1. && tempr != 0.) { temp /= tempr; temp2 /= tempr; } i__3 = a_subscr(j, j - 1); if (((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a_ref(j, j - 1)), abs(d__2))) * temp2 <= temp * atol) { goto L90; } /* L80: */ } istart = ifirst; i__2 = a_subscr(ifirst, ifirst); z__2.r = ascale * a[i__2].r, z__2.i = ascale * a[i__2].i; i__3 = b_subscr(ifirst, ifirst); z__4.r = bscale * b[i__3].r, z__4.i = bscale * b[i__3].i; z__3.r = shift.r * z__4.r - shift.i * z__4.i, z__3.i = shift.r * z__4.i + shift.i * z__4.r; z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; ctemp.r = z__1.r, ctemp.i = z__1.i; /* --------------------- Begin Timing Code ----------------------- */ opst += -6.; /* ---------------------- End Timing Code ------------------------ */ L90: /* Do an implicit-shift QZ sweep. Initial Q */ i__2 = a_subscr(istart + 1, istart); z__1.r = ascale * a[i__2].r, z__1.i = ascale * a[i__2].i; ctemp2.r = z__1.r, ctemp2.i = z__1.i; /* --------------------- Begin Timing Code ----------------------- */ opst += (doublereal) ((ilast - istart) * 18 + 2); /* ---------------------- End Timing Code ------------------------ */ zlartg_(&ctemp, &ctemp2, &c__, &s, &ctemp3); /* Sweep */ i__2 = ilast - 1; for (j = istart; j <= i__2; ++j) { if (j > istart) { i__3 = a_subscr(j, j - 1); ctemp.r = a[i__3].r, ctemp.i = a[i__3].i; zlartg_(&ctemp, &a_ref(j + 1, j - 1), &c__, &s, &a_ref(j, j - 1)); i__3 = a_subscr(j + 1, j - 1); a[i__3].r = 0., a[i__3].i = 0.; } i__3 = ilastm; for (jc = j; jc <= i__3; ++jc) { i__4 = a_subscr(j, jc); z__2.r = c__ * a[i__4].r, z__2.i = c__ * a[i__4].i; i__5 = a_subscr(j + 1, jc); z__3.r = s.r * a[i__5].r - s.i * a[i__5].i, z__3.i = s.r * a[ i__5].i + s.i * a[i__5].r; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; ctemp.r = z__1.r, ctemp.i = z__1.i; i__4 = a_subscr(j + 1, jc); d_cnjg(&z__4, &s); z__3.r = -z__4.r, z__3.i = -z__4.i; i__5 = a_subscr(j, jc); z__2.r = z__3.r * a[i__5].r - z__3.i * a[i__5].i, z__2.i = z__3.r * a[i__5].i + z__3.i * a[i__5].r; i__6 = a_subscr(j + 1, jc); z__5.r = c__ * a[i__6].r, z__5.i = c__ * a[i__6].i; z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i; a[i__4].r = z__1.r, a[i__4].i = z__1.i; i__4 = a_subscr(j, jc); a[i__4].r = ctemp.r, a[i__4].i = ctemp.i; i__4 = b_subscr(j, jc); z__2.r = c__ * b[i__4].r, z__2.i = c__ * b[i__4].i; i__5 = b_subscr(j + 1, jc); z__3.r = s.r * b[i__5].r - s.i * b[i__5].i, z__3.i = s.r * b[ i__5].i + s.i * b[i__5].r; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; ctemp2.r = z__1.r, ctemp2.i = z__1.i; i__4 = b_subscr(j + 1, jc); d_cnjg(&z__4, &s); z__3.r = -z__4.r, z__3.i = -z__4.i; i__5 = b_subscr(j, jc); z__2.r = z__3.r * b[i__5].r - z__3.i * b[i__5].i, z__2.i = z__3.r * b[i__5].i + z__3.i * b[i__5].r; i__6 = b_subscr(j + 1, jc); z__5.r = c__ * b[i__6].r, z__5.i = c__ * b[i__6].i; z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i; b[i__4].r = z__1.r, b[i__4].i = z__1.i; i__4 = b_subscr(j, jc); b[i__4].r = ctemp2.r, b[i__4].i = ctemp2.i; /* L100: */ } if (ilq) { i__3 = *n; for (jr = 1; jr <= i__3; ++jr) { i__4 = q_subscr(jr, j); z__2.r = c__ * q[i__4].r, z__2.i = c__ * q[i__4].i; d_cnjg(&z__4, &s); i__5 = q_subscr(jr, j + 1); z__3.r = z__4.r * q[i__5].r - z__4.i * q[i__5].i, z__3.i = z__4.r * q[i__5].i + z__4.i * q[i__5].r; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; ctemp.r = z__1.r, ctemp.i = z__1.i; i__4 = q_subscr(jr, j + 1); z__3.r = -s.r, z__3.i = -s.i; i__5 = q_subscr(jr, j); z__2.r = z__3.r * q[i__5].r - z__3.i * q[i__5].i, z__2.i = z__3.r * q[i__5].i + z__3.i * q[i__5].r; i__6 = q_subscr(jr, j + 1); z__4.r = c__ * q[i__6].r, z__4.i = c__ * q[i__6].i; z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; q[i__4].r = z__1.r, q[i__4].i = z__1.i; i__4 = q_subscr(jr, j); q[i__4].r = ctemp.r, q[i__4].i = ctemp.i; /* L110: */ } } i__3 = b_subscr(j + 1, j + 1); ctemp.r = b[i__3].r, ctemp.i = b[i__3].i; zlartg_(&ctemp, &b_ref(j + 1, j), &c__, &s, &b_ref(j + 1, j + 1)); i__3 = b_subscr(j + 1, j); b[i__3].r = 0., b[i__3].i = 0.; /* Computing MIN */ i__4 = j + 2; i__3 = min(i__4,ilast); for (jr = ifrstm; jr <= i__3; ++jr) { i__4 = a_subscr(jr, j + 1); z__2.r = c__ * a[i__4].r, z__2.i = c__ * a[i__4].i; i__5 = a_subscr(jr, j); z__3.r = s.r * a[i__5].r - s.i * a[i__5].i, z__3.i = s.r * a[ i__5].i + s.i * a[i__5].r; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; ctemp.r = z__1.r, ctemp.i = z__1.i; i__4 = a_subscr(jr, j); d_cnjg(&z__4, &s); z__3.r = -z__4.r, z__3.i = -z__4.i; i__5 = a_subscr(jr, j + 1); z__2.r = z__3.r * a[i__5].r - z__3.i * a[i__5].i, z__2.i = z__3.r * a[i__5].i + z__3.i * a[i__5].r; i__6 = a_subscr(jr, j); z__5.r = c__ * a[i__6].r, z__5.i = c__ * a[i__6].i; z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i; a[i__4].r = z__1.r, a[i__4].i = z__1.i; i__4 = a_subscr(jr, j + 1); a[i__4].r = ctemp.r, a[i__4].i = ctemp.i; /* L120: */ } i__3 = j; for (jr = ifrstm; jr <= i__3; ++jr) { i__4 = b_subscr(jr, j + 1); z__2.r = c__ * b[i__4].r, z__2.i = c__ * b[i__4].i; i__5 = b_subscr(jr, j); z__3.r = s.r * b[i__5].r - s.i * b[i__5].i, z__3.i = s.r * b[ i__5].i + s.i * b[i__5].r; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; ctemp.r = z__1.r, ctemp.i = z__1.i; i__4 = b_subscr(jr, j); d_cnjg(&z__4, &s); z__3.r = -z__4.r, z__3.i = -z__4.i; i__5 = b_subscr(jr, j + 1); z__2.r = z__3.r * b[i__5].r - z__3.i * b[i__5].i, z__2.i = z__3.r * b[i__5].i + z__3.i * b[i__5].r; i__6 = b_subscr(jr, j); z__5.r = c__ * b[i__6].r, z__5.i = c__ * b[i__6].i; z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i; b[i__4].r = z__1.r, b[i__4].i = z__1.i; i__4 = b_subscr(jr, j + 1); b[i__4].r = ctemp.r, b[i__4].i = ctemp.i; /* L130: */ } if (ilz) { i__3 = *n; for (jr = 1; jr <= i__3; ++jr) { i__4 = z___subscr(jr, j + 1); z__2.r = c__ * z__[i__4].r, z__2.i = c__ * z__[i__4].i; i__5 = z___subscr(jr, j); z__3.r = s.r * z__[i__5].r - s.i * z__[i__5].i, z__3.i = s.r * z__[i__5].i + s.i * z__[i__5].r; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; ctemp.r = z__1.r, ctemp.i = z__1.i; i__4 = z___subscr(jr, j); d_cnjg(&z__4, &s); z__3.r = -z__4.r, z__3.i = -z__4.i; i__5 = z___subscr(jr, j + 1); z__2.r = z__3.r * z__[i__5].r - z__3.i * z__[i__5].i, z__2.i = z__3.r * z__[i__5].i + z__3.i * z__[i__5] .r; i__6 = z___subscr(jr, j); z__5.r = c__ * z__[i__6].r, z__5.i = c__ * z__[i__6].i; z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i; z__[i__4].r = z__1.r, z__[i__4].i = z__1.i; i__4 = z___subscr(jr, j + 1); z__[i__4].r = ctemp.r, z__[i__4].i = ctemp.i; /* L140: */ } } /* L150: */ } /* --------------------- Begin Timing Code ----------------------- */ opst += (doublereal) (ilast - istart) * (doublereal) ((ilastm - ifrstm) * 40 + 184 + (nq + nz) * 20) - 20; /* ---------------------- End Timing Code ------------------------ */ L160: /* --------------------- Begin Timing Code ----------------------- End of iteration -- add in "small" contributions. */ latime_1.ops += opst; opst = 0.; /* ---------------------- End Timing Code ------------------------ L170: */ } /* Drop-through = non-convergence */ L180: *info = ilast; /* ---------------------- Begin Timing Code ------------------------- */ latime_1.ops += opst; opst = 0.; /* ----------------------- End Timing Code -------------------------- */ goto L210; /* Successful completion of all QZ steps */ L190: /* Set Eigenvalues 1:ILO-1 */ i__1 = *ilo - 1; for (j = 1; j <= i__1; ++j) { absb = z_abs(&b_ref(j, j)); if (absb > safmin) { i__2 = b_subscr(j, j); z__2.r = b[i__2].r / absb, z__2.i = b[i__2].i / absb; d_cnjg(&z__1, &z__2); signbc.r = z__1.r, signbc.i = z__1.i; i__2 = b_subscr(j, j); b[i__2].r = absb, b[i__2].i = 0.; if (ilschr) { i__2 = j - 1; zscal_(&i__2, &signbc, &b_ref(1, j), &c__1); zscal_(&j, &signbc, &a_ref(1, j), &c__1); /* ----------------- Begin Timing Code --------------------- */ opst += (doublereal) ((j - 1) * 12); /* ------------------ End Timing Code ---------------------- */ } else { i__2 = a_subscr(j, j); i__3 = a_subscr(j, j); z__1.r = a[i__3].r * signbc.r - a[i__3].i * signbc.i, z__1.i = a[i__3].r * signbc.i + a[i__3].i * signbc.r; a[i__2].r = z__1.r, a[i__2].i = z__1.i; } if (ilz) { zscal_(n, &signbc, &z___ref(1, j), &c__1); } /* ------------------- Begin Timing Code ---------------------- */ opst += (doublereal) (nz * 6 + 13); /* -------------------- End Timing Code ----------------------- */ } else { i__2 = b_subscr(j, j); b[i__2].r = 0., b[i__2].i = 0.; } i__2 = j; i__3 = a_subscr(j, j); alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i; i__2 = j; i__3 = b_subscr(j, j); beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i; /* L200: */ } /* Normal Termination */ *info = 0; /* Exit (other than argument error) -- return optimal workspace size */ L210: /* ---------------------- Begin Timing Code ------------------------- */ latime_1.ops += opst; opst = 0.; latime_1.itcnt = (doublereal) jiter; /* ----------------------- End Timing Code -------------------------- */ z__1.r = (doublereal) (*n), z__1.i = 0.; work[1].r = z__1.r, work[1].i = z__1.i; return 0; /* End of ZHGEQZ */ } /* zhgeqz_ */
/* Subroutine */ int sopgtr_(char *uplo, integer *n, real *ap, real *tau, real *q, integer *ldq, real *work, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= SOPGTR generates a real orthogonal matrix Q which is defined as the product of n-1 elementary reflectors H(i) of order n, as returned by SSPTRD using packed storage: if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). Arguments ========= UPLO (input) CHARACTER*1 = 'U': Upper triangular packed storage used in previous call to SSPTRD; = 'L': Lower triangular packed storage used in previous call to SSPTRD. N (input) INTEGER The order of the matrix Q. N >= 0. AP (input) REAL array, dimension (N*(N+1)/2) The vectors which define the elementary reflectors, as returned by SSPTRD. TAU (input) REAL array, dimension (N-1) TAU(i) must contain the scalar factor of the elementary reflector H(i), as returned by SSPTRD. Q (output) REAL array, dimension (LDQ,N) The N-by-N orthogonal matrix Q. LDQ (input) INTEGER The leading dimension of the array Q. LDQ >= max(1,N). WORK (workspace) REAL array, dimension (N-1) INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value ===================================================================== Test the input arguments Parameter adjustments */ /* System generated locals */ integer q_dim1, q_offset, i__1, i__2, i__3; /* Local variables */ static integer i__, j; extern logical lsame_(char *, char *); static integer iinfo; static logical upper; extern /* Subroutine */ int sorg2l_(integer *, integer *, integer *, real *, integer *, real *, real *, integer *), sorg2r_(integer *, integer *, integer *, real *, integer *, real *, real *, integer * ); static integer ij; extern /* Subroutine */ int xerbla_(char *, integer *); #define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1] --ap; --tau; q_dim1 = *ldq; q_offset = 1 + q_dim1 * 1; q -= q_offset; --work; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*ldq < max(1,*n)) { *info = -6; } if (*info != 0) { i__1 = -(*info); xerbla_("SOPGTR", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } if (upper) { /* Q was determined by a call to SSPTRD with UPLO = 'U' Unpack the vectors which define the elementary reflectors and set the last row and column of Q equal to those of the unit matrix */ ij = 2; i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { q_ref(i__, j) = ap[ij]; ++ij; /* L10: */ } ij += 2; q_ref(*n, j) = 0.f; /* L20: */ } i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { q_ref(i__, *n) = 0.f; /* L30: */ } q_ref(*n, *n) = 1.f; /* Generate Q(1:n-1,1:n-1) */ i__1 = *n - 1; i__2 = *n - 1; i__3 = *n - 1; sorg2l_(&i__1, &i__2, &i__3, &q[q_offset], ldq, &tau[1], &work[1], & iinfo); } else { /* Q was determined by a call to SSPTRD with UPLO = 'L'. Unpack the vectors which define the elementary reflectors and set the first row and column of Q equal to those of the unit matrix */ q_ref(1, 1) = 1.f; i__1 = *n; for (i__ = 2; i__ <= i__1; ++i__) { q_ref(i__, 1) = 0.f; /* L40: */ } ij = 3; i__1 = *n; for (j = 2; j <= i__1; ++j) { q_ref(1, j) = 0.f; i__2 = *n; for (i__ = j + 1; i__ <= i__2; ++i__) { q_ref(i__, j) = ap[ij]; ++ij; /* L50: */ } ij += 2; /* L60: */ } if (*n > 1) { /* Generate Q(2:n,2:n) */ i__1 = *n - 1; i__2 = *n - 1; i__3 = *n - 1; sorg2r_(&i__1, &i__2, &i__3, &q_ref(2, 2), ldq, &tau[1], &work[1], &iinfo); } } return 0; /* End of SOPGTR */ } /* sopgtr_ */
/* Subroutine */ int ctgsen_(integer *ijob, logical *wantq, logical *wantz, logical *select, integer *n, complex *a, integer *lda, complex *b, integer *ldb, complex *alpha, complex *beta, complex *q, integer *ldq, complex *z__, integer *ldz, integer *m, real *pl, real *pr, real * dif, complex *work, integer *lwork, integer *iwork, integer *liwork, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University June 30, 1999 Purpose ======= CTGSEN reorders the generalized Schur decomposition of a complex matrix pair (A, B) (in terms of an unitary equivalence trans- formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues appears in the leading diagonal blocks of the pair (A,B). The leading columns of Q and Z form unitary bases of the corresponding left and right eigenspaces (deflating subspaces). (A, B) must be in generalized Schur canonical form, that is, A and B are both upper triangular. CTGSEN also computes the generalized eigenvalues w(j)= ALPHA(j) / BETA(j) of the reordered matrix pair (A, B). Optionally, the routine computes estimates of reciprocal condition numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11), (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s) between the matrix pairs (A11, B11) and (A22,B22) that correspond to the selected cluster and the eigenvalues outside the cluster, resp., and norms of "projections" onto left and right eigenspaces w.r.t. the selected cluster in the (1,1)-block. Arguments ========= IJOB (input) integer Specifies whether condition numbers are required for the cluster of eigenvalues (PL and PR) or the deflating subspaces (Difu and Difl): =0: Only reorder w.r.t. SELECT. No extras. =1: Reciprocal of norms of "projections" onto left and right eigenspaces w.r.t. the selected cluster (PL and PR). =2: Upper bounds on Difu and Difl. F-norm-based estimate (DIF(1:2)). =3: Estimate of Difu and Difl. 1-norm-based estimate (DIF(1:2)). About 5 times as expensive as IJOB = 2. =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic version to get it all. =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above) WANTQ (input) LOGICAL .TRUE. : update the left transformation matrix Q; .FALSE.: do not update Q. WANTZ (input) LOGICAL .TRUE. : update the right transformation matrix Z; .FALSE.: do not update Z. SELECT (input) LOGICAL array, dimension (N) SELECT specifies the eigenvalues in the selected cluster. To select an eigenvalue w(j), SELECT(j) must be set to .TRUE.. N (input) INTEGER The order of the matrices A and B. N >= 0. A (input/output) COMPLEX array, dimension(LDA,N) On entry, the upper triangular matrix A, in generalized Schur canonical form. On exit, A is overwritten by the reordered matrix A. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,N). B (input/output) COMPLEX array, dimension(LDB,N) On entry, the upper triangular matrix B, in generalized Schur canonical form. On exit, B is overwritten by the reordered matrix B. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,N). ALPHA (output) COMPLEX array, dimension (N) BETA (output) COMPLEX array, dimension (N) The diagonal elements of A and B, respectively, when the pair (A,B) has been reduced to generalized Schur form. ALPHA(i)/BETA(i) i=1,...,N are the generalized eigenvalues. Q (input/output) COMPLEX array, dimension (LDQ,N) On entry, if WANTQ = .TRUE., Q is an N-by-N matrix. On exit, Q has been postmultiplied by the left unitary transformation matrix which reorder (A, B); The leading M columns of Q form orthonormal bases for the specified pair of left eigenspaces (deflating subspaces). If WANTQ = .FALSE., Q is not referenced. LDQ (input) INTEGER The leading dimension of the array Q. LDQ >= 1. If WANTQ = .TRUE., LDQ >= N. Z (input/output) COMPLEX array, dimension (LDZ,N) On entry, if WANTZ = .TRUE., Z is an N-by-N matrix. On exit, Z has been postmultiplied by the left unitary transformation matrix which reorder (A, B); The leading M columns of Z form orthonormal bases for the specified pair of left eigenspaces (deflating subspaces). If WANTZ = .FALSE., Z is not referenced. LDZ (input) INTEGER The leading dimension of the array Z. LDZ >= 1. If WANTZ = .TRUE., LDZ >= N. M (output) INTEGER The dimension of the specified pair of left and right eigenspaces, (deflating subspaces) 0 <= M <= N. PL, PR (output) REAL If IJOB = 1, 4 or 5, PL, PR are lower bounds on the reciprocal of the norm of "projections" onto left and right eigenspace with respect to the selected cluster. 0 < PL, PR <= 1. If M = 0 or M = N, PL = PR = 1. If IJOB = 0, 2 or 3 PL, PR are not referenced. DIF (output) REAL array, dimension (2). If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl. If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based estimates of Difu and Difl, computed using reversed communication with CLACON. If M = 0 or N, DIF(1:2) = F-norm([A, B]). If IJOB = 0 or 1, DIF is not referenced. WORK (workspace/output) COMPLEX array, dimension (LWORK) IF IJOB = 0, WORK is not referenced. Otherwise, on exit, if INFO = 0, WORK(1) returns the optimal LWORK. LWORK (input) INTEGER The dimension of the array WORK. LWORK >= 1 If IJOB = 1, 2 or 4, LWORK >= 2*M*(N-M) If IJOB = 3 or 5, LWORK >= 4*M*(N-M) If LWORK = -1, then a workspace query is assumed; the routine only calculates the optimal size of the WORK array, returns this value as the first entry of the WORK array, and no error message related to LWORK is issued by XERBLA. IWORK (workspace/output) INTEGER, dimension (LIWORK) IF IJOB = 0, IWORK is not referenced. Otherwise, on exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. LIWORK (input) INTEGER The dimension of the array IWORK. LIWORK >= 1. If IJOB = 1, 2 or 4, LIWORK >= N+2; If IJOB = 3 or 5, LIWORK >= MAX(N+2, 2*M*(N-M)); If LIWORK = -1, then a workspace query is assumed; the routine only calculates the optimal size of the IWORK array, returns this value as the first entry of the IWORK array, and no error message related to LIWORK is issued by XERBLA. INFO (output) INTEGER =0: Successful exit. <0: If INFO = -i, the i-th argument had an illegal value. =1: Reordering of (A, B) failed because the transformed matrix pair (A, B) would be too far from generalized Schur form; the problem is very ill-conditioned. (A, B) may have been partially reordered. If requested, 0 is returned in DIF(*), PL and PR. Further Details =============== CTGSEN first collects the selected eigenvalues by computing unitary U and W that move them to the top left corner of (A, B). In other words, the selected eigenvalues are the eigenvalues of (A11, B11) in U'*(A, B)*W = (A11 A12) (B11 B12) n1 ( 0 A22),( 0 B22) n2 n1 n2 n1 n2 where N = n1+n2 and U' means the conjugate transpose of U. The first n1 columns of U and W span the specified pair of left and right eigenspaces (deflating subspaces) of (A, B). If (A, B) has been obtained from the generalized real Schur decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the reordered generalized Schur form of (C, D) is given by (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)', and the first n1 columns of Q*U and Z*W span the corresponding deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.). Note that if the selected eigenvalue is sufficiently ill-conditioned, then its value may differ significantly from its value before reordering. The reciprocal condition numbers of the left and right eigenspaces spanned by the first n1 columns of U and W (or Q*U and Z*W) may be returned in DIF(1:2), corresponding to Difu and Difl, resp. The Difu and Difl are defined as: Difu[(A11, B11), (A22, B22)] = sigma-min( Zu ) and Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)], where sigma-min(Zu) is the smallest singular value of the (2*n1*n2)-by-(2*n1*n2) matrix Zu = [ kron(In2, A11) -kron(A22', In1) ] [ kron(In2, B11) -kron(B22', In1) ]. Here, Inx is the identity matrix of size nx and A22' is the transpose of A22. kron(X, Y) is the Kronecker product between the matrices X and Y. When DIF(2) is small, small changes in (A, B) can cause large changes in the deflating subspace. An approximate (asymptotic) bound on the maximum angular error in the computed deflating subspaces is EPS * norm((A, B)) / DIF(2), where EPS is the machine precision. The reciprocal norm of the projectors on the left and right eigenspaces associated with (A11, B11) may be returned in PL and PR. They are computed as follows. First we compute L and R so that P*(A, B)*Q is block diagonal, where P = ( I -L ) n1 Q = ( I R ) n1 ( 0 I ) n2 and ( 0 I ) n2 n1 n2 n1 n2 and (L, R) is the solution to the generalized Sylvester equation A11*R - L*A22 = -A12 B11*R - L*B22 = -B12 Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2). An approximate (asymptotic) bound on the average absolute error of the selected eigenvalues is EPS * norm((A, B)) / PL. There are also global error bounds which valid for perturbations up to a certain restriction: A lower bound (x) on the smallest F-norm(E,F) for which an eigenvalue of (A11, B11) may move and coalesce with an eigenvalue of (A22, B22) under perturbation (E,F), (i.e. (A + E, B + F), is x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)). An approximate bound on x can be computed from DIF(1:2), PL and PR. If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed (L', R') and unperturbed (L, R) left and right deflating subspaces associated with the selected cluster in the (1,1)-blocks can be bounded as max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2)) max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2)) See LAPACK User's Guide section 4.11 or the following references for more information. Note that if the default method for computing the Frobenius-norm- based estimate DIF is not wanted (see CLATDF), then the parameter IDIFJB (see below) should be changed from 3 to 4 (routine CLATDF (IJOB = 2 will be used)). See CTGSYL for more details. Based on contributions by Bo Kagstrom and Peter Poromaa, Department of Computing Science, Umea University, S-901 87 Umea, Sweden. References ========== [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the Generalized Real Schur Form of a Regular Matrix Pair (A, B), in M.S. Moonen et al (eds), Linear Algebra for Large Scale and Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified Eigenvalues of a Regular Matrix Pair (A, B) and Condition Estimation: Theory, Algorithms and Software, Report UMINF - 94.04, Department of Computing Science, Umea University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87. To appear in Numerical Algorithms, 1996. [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software for Solving the Generalized Sylvester Equation and Estimating the Separation between Regular Matrix Pairs, Report UMINF - 93.23, Department of Computing Science, Umea University, S-901 87 Umea, Sweden, December 1993, Revised April 1994, Also as LAPACK working Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, 1996. ===================================================================== Decode and test the input parameters Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, z_offset, i__1, i__2, i__3; complex q__1, q__2; /* Builtin functions */ double sqrt(doublereal), c_abs(complex *); void r_cnjg(complex *, complex *); /* Local variables */ static integer kase, ierr; static real dsum; static logical swap; static integer i__, k; extern /* Subroutine */ int cscal_(integer *, complex *, complex *, integer *); static logical wantd; static integer lwmin; static logical wantp; static integer n1, n2; static logical wantd1, wantd2; static real dscale; static integer ks; extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real *, integer *); extern doublereal slamch_(char *); static real rdscal; extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex *, integer *, complex *, integer *); static real safmin; extern /* Subroutine */ int ctgexc_(logical *, logical *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, integer *, integer *, integer *), xerbla_( char *, integer *), classq_(integer *, complex *, integer *, real *, real *); static integer liwmin; extern /* Subroutine */ int ctgsyl_(char *, integer *, integer *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, real *, real *, complex *, integer *, integer *, integer *); static integer mn2; static logical lquery; static integer ijb; #define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1 #define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)] #define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1 #define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)] #define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1 #define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)] --select; a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; --alpha; --beta; q_dim1 = *ldq; q_offset = 1 + q_dim1 * 1; q -= q_offset; z_dim1 = *ldz; z_offset = 1 + z_dim1 * 1; z__ -= z_offset; --dif; --work; --iwork; /* Function Body */ *info = 0; lquery = *lwork == -1 || *liwork == -1; if (*ijob < 0 || *ijob > 5) { *info = -1; } else if (*n < 0) { *info = -5; } else if (*lda < max(1,*n)) { *info = -7; } else if (*ldb < max(1,*n)) { *info = -9; } else if (*ldq < 1 || *wantq && *ldq < *n) { *info = -13; } else if (*ldz < 1 || *wantz && *ldz < *n) { *info = -15; } if (*info != 0) { i__1 = -(*info); xerbla_("CTGSEN", &i__1); return 0; } ierr = 0; wantp = *ijob == 1 || *ijob >= 4; wantd1 = *ijob == 2 || *ijob == 4; wantd2 = *ijob == 3 || *ijob == 5; wantd = wantd1 || wantd2; /* Set M to the dimension of the specified pair of deflating subspaces. */ *m = 0; i__1 = *n; for (k = 1; k <= i__1; ++k) { i__2 = k; i__3 = a_subscr(k, k); alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i; i__2 = k; i__3 = b_subscr(k, k); beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i; if (k < *n) { if (select[k]) { ++(*m); } } else { if (select[*n]) { ++(*m); } } /* L10: */ } if (*ijob == 1 || *ijob == 2 || *ijob == 4) { /* Computing MAX */ i__1 = 1, i__2 = (*m << 1) * (*n - *m); lwmin = max(i__1,i__2); /* Computing MAX */ i__1 = 1, i__2 = *n + 2; liwmin = max(i__1,i__2); } else if (*ijob == 3 || *ijob == 5) { /* Computing MAX */ i__1 = 1, i__2 = (*m << 2) * (*n - *m); lwmin = max(i__1,i__2); /* Computing MAX */ i__1 = 1, i__2 = (*m << 1) * (*n - *m), i__1 = max(i__1,i__2), i__2 = *n + 2; liwmin = max(i__1,i__2); } else { lwmin = 1; liwmin = 1; } work[1].r = (real) lwmin, work[1].i = 0.f; iwork[1] = liwmin; if (*lwork < lwmin && ! lquery) { *info = -21; } else if (*liwork < liwmin && ! lquery) { *info = -23; } if (*info != 0) { i__1 = -(*info); xerbla_("CTGSEN", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible. */ if (*m == *n || *m == 0) { if (wantp) { *pl = 1.f; *pr = 1.f; } if (wantd) { dscale = 0.f; dsum = 1.f; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { classq_(n, &a_ref(1, i__), &c__1, &dscale, &dsum); classq_(n, &b_ref(1, i__), &c__1, &dscale, &dsum); /* L20: */ } dif[1] = dscale * sqrt(dsum); dif[2] = dif[1]; } goto L70; } /* Get machine constant */ safmin = slamch_("S"); /* Collect the selected blocks at the top-left corner of (A, B). */ ks = 0; i__1 = *n; for (k = 1; k <= i__1; ++k) { swap = select[k]; if (swap) { ++ks; /* Swap the K-th block to position KS. Compute unitary Q and Z that will swap adjacent diagonal blocks in (A, B). */ if (k != ks) { ctgexc_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &k, &ks, & ierr); } if (ierr > 0) { /* Swap is rejected: exit. */ *info = 1; if (wantp) { *pl = 0.f; *pr = 0.f; } if (wantd) { dif[1] = 0.f; dif[2] = 0.f; } goto L70; } } /* L30: */ } if (wantp) { /* Solve generalized Sylvester equation for R and L: A11 * R - L * A22 = A12 B11 * R - L * B22 = B12 */ n1 = *m; n2 = *n - *m; i__ = n1 + 1; clacpy_("Full", &n1, &n2, &a_ref(1, i__), lda, &work[1], &n1); clacpy_("Full", &n1, &n2, &b_ref(1, i__), ldb, &work[n1 * n2 + 1], & n1); ijb = 0; i__1 = *lwork - (n1 << 1) * n2; ctgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a_ref(i__, i__), lda, &work[1], &n1, &b[b_offset], ldb, &b_ref(i__, i__), ldb, & work[n1 * n2 + 1], &n1, &dscale, &dif[1], &work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &ierr); /* Estimate the reciprocal of norms of "projections" onto left and right eigenspaces */ rdscal = 0.f; dsum = 1.f; i__1 = n1 * n2; classq_(&i__1, &work[1], &c__1, &rdscal, &dsum); *pl = rdscal * sqrt(dsum); if (*pl == 0.f) { *pl = 1.f; } else { *pl = dscale / (sqrt(dscale * dscale / *pl + *pl) * sqrt(*pl)); } rdscal = 0.f; dsum = 1.f; i__1 = n1 * n2; classq_(&i__1, &work[n1 * n2 + 1], &c__1, &rdscal, &dsum); *pr = rdscal * sqrt(dsum); if (*pr == 0.f) { *pr = 1.f; } else { *pr = dscale / (sqrt(dscale * dscale / *pr + *pr) * sqrt(*pr)); } } if (wantd) { /* Compute estimates Difu and Difl. */ if (wantd1) { n1 = *m; n2 = *n - *m; i__ = n1 + 1; ijb = 3; /* Frobenius norm-based Difu estimate. */ i__1 = *lwork - (n1 << 1) * n2; ctgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a_ref(i__, i__), lda, &work[1], &n1, &b[b_offset], ldb, &b_ref(i__, i__), ldb, &work[n1 * n2 + 1], &n1, &dscale, &dif[1], &work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &ierr); /* Frobenius norm-based Difl estimate. */ i__1 = *lwork - (n1 << 1) * n2; ctgsyl_("N", &ijb, &n2, &n1, &a_ref(i__, i__), lda, &a[a_offset], lda, &work[1], &n2, &b_ref(i__, i__), ldb, &b[b_offset], ldb, &work[n1 * n2 + 1], &n2, &dscale, &dif[2], &work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &ierr); } else { /* Compute 1-norm-based estimates of Difu and Difl using reversed communication with CLACON. In each step a generalized Sylvester equation or a transposed variant is solved. */ kase = 0; n1 = *m; n2 = *n - *m; i__ = n1 + 1; ijb = 0; mn2 = (n1 << 1) * n2; /* 1-norm-based estimate of Difu. */ L40: clacon_(&mn2, &work[mn2 + 1], &work[1], &dif[1], &kase); if (kase != 0) { if (kase == 1) { /* Solve generalized Sylvester equation */ i__1 = *lwork - (n1 << 1) * n2; ctgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a_ref( i__, i__), lda, &work[1], &n1, &b[b_offset], ldb, &b_ref(i__, i__), ldb, &work[n1 * n2 + 1], &n1, & dscale, &dif[1], &work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &ierr); } else { /* Solve the transposed variant. */ i__1 = *lwork - (n1 << 1) * n2; ctgsyl_("C", &ijb, &n1, &n2, &a[a_offset], lda, &a_ref( i__, i__), lda, &work[1], &n1, &b[b_offset], ldb, &b_ref(i__, i__), ldb, &work[n1 * n2 + 1], &n1, & dscale, &dif[1], &work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &ierr); } goto L40; } dif[1] = dscale / dif[1]; /* 1-norm-based estimate of Difl. */ L50: clacon_(&mn2, &work[mn2 + 1], &work[1], &dif[2], &kase); if (kase != 0) { if (kase == 1) { /* Solve generalized Sylvester equation */ i__1 = *lwork - (n1 << 1) * n2; ctgsyl_("N", &ijb, &n2, &n1, &a_ref(i__, i__), lda, &a[ a_offset], lda, &work[1], &n2, &b_ref(i__, i__), ldb, &b[b_offset], ldb, &work[n1 * n2 + 1], &n2, & dscale, &dif[2], &work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &ierr); } else { /* Solve the transposed variant. */ i__1 = *lwork - (n1 << 1) * n2; ctgsyl_("C", &ijb, &n2, &n1, &a_ref(i__, i__), lda, &a[ a_offset], lda, &work[1], &n2, &b[b_offset], ldb, &b_ref(i__, i__), ldb, &work[n1 * n2 + 1], &n2, & dscale, &dif[2], &work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &ierr); } goto L50; } dif[2] = dscale / dif[2]; } } /* If B(K,K) is complex, make it real and positive (normalization of the generalized Schur form) and Store the generalized eigenvalues of reordered pair (A, B) */ i__1 = *n; for (k = 1; k <= i__1; ++k) { dscale = c_abs(&b_ref(k, k)); if (dscale > safmin) { i__2 = b_subscr(k, k); q__2.r = b[i__2].r / dscale, q__2.i = b[i__2].i / dscale; r_cnjg(&q__1, &q__2); work[1].r = q__1.r, work[1].i = q__1.i; i__2 = b_subscr(k, k); q__1.r = b[i__2].r / dscale, q__1.i = b[i__2].i / dscale; work[2].r = q__1.r, work[2].i = q__1.i; i__2 = b_subscr(k, k); b[i__2].r = dscale, b[i__2].i = 0.f; i__2 = *n - k; cscal_(&i__2, &work[1], &b_ref(k, k + 1), ldb); i__2 = *n - k + 1; cscal_(&i__2, &work[1], &a_ref(k, k), lda); if (*wantq) { cscal_(n, &work[2], &q_ref(1, k), &c__1); } } else { i__2 = b_subscr(k, k); b[i__2].r = 0.f, b[i__2].i = 0.f; } i__2 = k; i__3 = a_subscr(k, k); alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i; i__2 = k; i__3 = b_subscr(k, k); beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i; /* L60: */ } L70: work[1].r = (real) lwmin, work[1].i = 0.f; iwork[1] = liwmin; return 0; /* End of CTGSEN */ } /* ctgsen_ */
/* Subroutine */ int stgex2_(logical *wantq, logical *wantz, integer *n, real *a, integer *lda, real *b, integer *ldb, real *q, integer *ldq, real * z__, integer *ldz, integer *j1, integer *n1, integer *n2, real *work, integer *lwork, 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 June 30, 1999 Purpose ======= STGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22) of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair (A, B) by an orthogonal equivalence transformation. (A, B) must be in generalized real Schur canonical form (as returned by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper triangular. Optionally, the matrices Q and Z of generalized Schur vectors are updated. Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)' Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)' Arguments ========= WANTQ (input) LOGICAL .TRUE. : update the left transformation matrix Q; .FALSE.: do not update Q. WANTZ (input) LOGICAL .TRUE. : update the right transformation matrix Z; .FALSE.: do not update Z. N (input) INTEGER The order of the matrices A and B. N >= 0. A (input/output) REAL arrays, dimensions (LDA,N) On entry, the matrix A in the pair (A, B). On exit, the updated matrix A. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,N). B (input/output) REAL arrays, dimensions (LDB,N) On entry, the matrix B in the pair (A, B). On exit, the updated matrix B. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,N). Q (input/output) REAL array, dimension (LDZ,N) On entry, if WANTQ = .TRUE., the orthogonal matrix Q. On exit, the updated matrix Q. Not referenced if WANTQ = .FALSE.. LDQ (input) INTEGER The leading dimension of the array Q. LDQ >= 1. If WANTQ = .TRUE., LDQ >= N. Z (input/output) REAL array, dimension (LDZ,N) On entry, if WANTZ =.TRUE., the orthogonal matrix Z. On exit, the updated matrix Z. Not referenced if WANTZ = .FALSE.. LDZ (input) INTEGER The leading dimension of the array Z. LDZ >= 1. If WANTZ = .TRUE., LDZ >= N. J1 (input) INTEGER The index to the first block (A11, B11). 1 <= J1 <= N. N1 (input) INTEGER The order of the first block (A11, B11). N1 = 0, 1 or 2. N2 (input) INTEGER The order of the second block (A22, B22). N2 = 0, 1 or 2. WORK (workspace) REAL array, dimension (LWORK). LWORK (input) INTEGER The dimension of the array WORK. LWORK >= MAX( N*(N2+N1), (N2+N1)*(N2+N1)*2 ) INFO (output) INTEGER =0: Successful exit >0: If INFO = 1, the transformed matrix (A, B) would be too far from generalized Schur form; the blocks are not swapped and (A, B) and (Q, Z) are unchanged. The problem of swapping is too ill-conditioned. <0: If INFO = -16: LWORK is too small. Appropriate value for LWORK is returned in WORK(1). Further Details =============== Based on contributions by Bo Kagstrom and Peter Poromaa, Department of Computing Science, Umea University, S-901 87 Umea, Sweden. In the current code both weak and strong stability tests are performed. The user can omit the strong stability test by changing the internal logical parameter WANDS to .FALSE.. See ref. [2] for details. [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the Generalized Real Schur Form of a Regular Matrix Pair (A, B), in M.S. Moonen et al (eds), Linear Algebra for Large Scale and Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified Eigenvalues of a Regular Matrix Pair (A, B) and Condition Estimation: Theory, Algorithms and Software, Report UMINF - 94.04, Department of Computing Science, Umea University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87. To appear in Numerical Algorithms, 1996. ===================================================================== Parameter adjustments */ /* Table of constant values */ static integer c__16 = 16; static real c_b3 = 0.f; static integer c__0 = 0; static integer c__1 = 1; static integer c__4 = 4; static integer c__2 = 2; static real c_b38 = 1.f; static real c_b44 = -1.f; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, z_offset, i__1, i__2; real r__1, r__2; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static logical weak; static real ddum; static integer idum; static real taul[4], dsum, taur[4], scpy[16] /* was [4][4] */, tcpy[16] /* was [4][4] */; extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, integer *, real *, real *); static real f, g; static integer i__, m; static real s[16] /* was [4][4] */, t[16] /* was [4][4] */, scale, bqra21, brqa21; extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); static real licop[16] /* was [4][4] */; static integer linfo; extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *); static real ircop[16] /* was [4][4] */, dnorm; static integer iwork[4]; extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, integer *), slagv2_(real *, integer *, real *, integer *, real *, real *, real *, real *, real *, real *, real *), sgeqr2_(integer * , integer *, real *, integer *, real *, real *, integer *), sgerq2_(integer *, integer *, real *, integer *, real *, real *, integer *); static real be[2], ai[2]; extern /* Subroutine */ int sorg2r_(integer *, integer *, integer *, real *, integer *, real *, real *, integer *), sorgr2_(integer *, integer *, integer *, real *, integer *, real *, real *, integer * ); static real ar[2], sa, sb, li[16] /* was [4][4] */; extern /* Subroutine */ int sorm2r_(char *, char *, integer *, integer *, integer *, real *, integer *, real *, real *, integer *, real *, integer *), sormr2_(char *, char *, integer *, integer *, integer *, real *, integer *, real *, real *, integer * , real *, integer *); static real dscale, ir[16] /* was [4][4] */; extern /* Subroutine */ int stgsy2_(char *, integer *, integer *, integer *, real *, integer *, real *, integer *, real *, integer *, real * , integer *, real *, integer *, real *, integer *, real *, real *, real *, integer *, integer *, integer *); static real ss; extern doublereal slamch_(char *); static real ws; extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *), slartg_(real *, real *, real *, real *, real *); static real thresh; extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, real *); static real smlnum; static logical strong; static real eps; #define scpy_ref(a_1,a_2) scpy[(a_2)*4 + a_1 - 5] #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] #define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1] #define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1] #define s_ref(a_1,a_2) s[(a_2)*4 + a_1 - 5] #define t_ref(a_1,a_2) t[(a_2)*4 + a_1 - 5] #define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1] #define li_ref(a_1,a_2) li[(a_2)*4 + a_1 - 5] #define ir_ref(a_1,a_2) ir[(a_2)*4 + a_1 - 5] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; q_dim1 = *ldq; q_offset = 1 + q_dim1 * 1; q -= q_offset; z_dim1 = *ldz; z_offset = 1 + z_dim1 * 1; z__ -= z_offset; --work; /* Function Body */ *info = 0; /* Quick return if possible */ if (*n <= 1 || *n1 <= 0 || *n2 <= 0) { return 0; } if (*n1 > *n || *j1 + *n1 > *n) { return 0; } m = *n1 + *n2; /* Computing MAX */ i__1 = *n * m, i__2 = m * m << 1; if (*lwork < max(i__1,i__2)) { *info = -16; /* Computing MAX */ i__1 = *n * m, i__2 = m * m << 1; work[1] = (real) max(i__1,i__2); return 0; } weak = FALSE_; strong = FALSE_; /* Make a local copy of selected block */ scopy_(&c__16, &c_b3, &c__0, li, &c__1); scopy_(&c__16, &c_b3, &c__0, ir, &c__1); slacpy_("Full", &m, &m, &a_ref(*j1, *j1), lda, s, &c__4); slacpy_("Full", &m, &m, &b_ref(*j1, *j1), ldb, t, &c__4); /* Compute threshold for testing acceptance of swapping. */ eps = slamch_("P"); smlnum = slamch_("S") / eps; dscale = 0.f; dsum = 1.f; slacpy_("Full", &m, &m, s, &c__4, &work[1], &m); i__1 = m * m; slassq_(&i__1, &work[1], &c__1, &dscale, &dsum); slacpy_("Full", &m, &m, t, &c__4, &work[1], &m); i__1 = m * m; slassq_(&i__1, &work[1], &c__1, &dscale, &dsum); dnorm = dscale * sqrt(dsum); /* Computing MAX */ r__1 = eps * 10.f * dnorm; thresh = dmax(r__1,smlnum); if (m == 2) { /* CASE 1: Swap 1-by-1 and 1-by-1 blocks. Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks using Givens rotations and perform the swap tentatively. */ f = s_ref(2, 2) * t_ref(1, 1) - t_ref(2, 2) * s_ref(1, 1); g = s_ref(2, 2) * t_ref(1, 2) - t_ref(2, 2) * s_ref(1, 2); sb = (r__1 = t_ref(2, 2), dabs(r__1)); sa = (r__1 = s_ref(2, 2), dabs(r__1)); slartg_(&f, &g, &ir_ref(1, 2), &ir_ref(1, 1), &ddum); ir_ref(2, 1) = -ir_ref(1, 2); ir_ref(2, 2) = ir_ref(1, 1); srot_(&c__2, &s_ref(1, 1), &c__1, &s_ref(1, 2), &c__1, &ir_ref(1, 1), &ir_ref(2, 1)); srot_(&c__2, &t_ref(1, 1), &c__1, &t_ref(1, 2), &c__1, &ir_ref(1, 1), &ir_ref(2, 1)); if (sa >= sb) { slartg_(&s_ref(1, 1), &s_ref(2, 1), &li_ref(1, 1), &li_ref(2, 1), &ddum); } else { slartg_(&t_ref(1, 1), &t_ref(2, 1), &li_ref(1, 1), &li_ref(2, 1), &ddum); } srot_(&c__2, &s_ref(1, 1), &c__4, &s_ref(2, 1), &c__4, &li_ref(1, 1), &li_ref(2, 1)); srot_(&c__2, &t_ref(1, 1), &c__4, &t_ref(2, 1), &c__4, &li_ref(1, 1), &li_ref(2, 1)); li_ref(2, 2) = li_ref(1, 1); li_ref(1, 2) = -li_ref(2, 1); /* Weak stability test: |S21| + |T21| <= O(EPS * F-norm((S, T))) */ ws = (r__1 = s_ref(2, 1), dabs(r__1)) + (r__2 = t_ref(2, 1), dabs( r__2)); weak = ws <= thresh; if (! weak) { goto L70; } if (TRUE_) { /* Strong stability test: F-norm((A-QL'*S*QR, B-QL'*T*QR)) <= O(EPS*F-norm((A,B))) */ slacpy_("Full", &m, &m, &a_ref(*j1, *j1), lda, &work[m * m + 1], & m); sgemm_("N", "N", &m, &m, &m, &c_b38, li, &c__4, s, &c__4, &c_b3, & work[1], &m); sgemm_("N", "T", &m, &m, &m, &c_b44, &work[1], &m, ir, &c__4, & c_b38, &work[m * m + 1], &m); dscale = 0.f; dsum = 1.f; i__1 = m * m; slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum); slacpy_("Full", &m, &m, &b_ref(*j1, *j1), ldb, &work[m * m + 1], & m); sgemm_("N", "N", &m, &m, &m, &c_b38, li, &c__4, t, &c__4, &c_b3, & work[1], &m); sgemm_("N", "T", &m, &m, &m, &c_b44, &work[1], &m, ir, &c__4, & c_b38, &work[m * m + 1], &m); i__1 = m * m; slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum); ss = dscale * sqrt(dsum); strong = ss <= thresh; if (! strong) { goto L70; } } /* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */ i__1 = *j1 + 1; srot_(&i__1, &a_ref(1, *j1), &c__1, &a_ref(1, *j1 + 1), &c__1, & ir_ref(1, 1), &ir_ref(2, 1)); i__1 = *j1 + 1; srot_(&i__1, &b_ref(1, *j1), &c__1, &b_ref(1, *j1 + 1), &c__1, & ir_ref(1, 1), &ir_ref(2, 1)); i__1 = *n - *j1 + 1; srot_(&i__1, &a_ref(*j1, *j1), lda, &a_ref(*j1 + 1, *j1), lda, & li_ref(1, 1), &li_ref(2, 1)); i__1 = *n - *j1 + 1; srot_(&i__1, &b_ref(*j1, *j1), ldb, &b_ref(*j1 + 1, *j1), ldb, & li_ref(1, 1), &li_ref(2, 1)); /* Set N1-by-N2 (2,1) - blocks to ZERO. */ a_ref(*j1 + 1, *j1) = 0.f; b_ref(*j1 + 1, *j1) = 0.f; /* Accumulate transformations into Q and Z if requested. */ if (*wantz) { srot_(n, &z___ref(1, *j1), &c__1, &z___ref(1, *j1 + 1), &c__1, & ir_ref(1, 1), &ir_ref(2, 1)); } if (*wantq) { srot_(n, &q_ref(1, *j1), &c__1, &q_ref(1, *j1 + 1), &c__1, & li_ref(1, 1), &li_ref(2, 1)); } /* Exit with INFO = 0 if swap was successfully performed. */ return 0; } else { /* CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2 and 2-by-2 blocks. Solve the generalized Sylvester equation S11 * R - L * S22 = SCALE * S12 T11 * R - L * T22 = SCALE * T12 for R and L. Solutions in LI and IR. */ slacpy_("Full", n1, n2, &t_ref(1, *n1 + 1), &c__4, li, &c__4); slacpy_("Full", n1, n2, &s_ref(1, *n1 + 1), &c__4, &ir_ref(*n2 + 1, * n1 + 1), &c__4); stgsy2_("N", &c__0, n1, n2, s, &c__4, &s_ref(*n1 + 1, *n1 + 1), &c__4, &ir_ref(*n2 + 1, *n1 + 1), &c__4, t, &c__4, &t_ref(*n1 + 1, * n1 + 1), &c__4, li, &c__4, &scale, &dsum, &dscale, iwork, & idum, &linfo); /* Compute orthogonal matrix QL: QL' * LI = [ TL ] [ 0 ] where LI = [ -L ] [ SCALE * identity(N2) ] */ i__1 = *n2; for (i__ = 1; i__ <= i__1; ++i__) { sscal_(n1, &c_b44, &li_ref(1, i__), &c__1); li_ref(*n1 + i__, i__) = scale; /* L10: */ } sgeqr2_(&m, n2, li, &c__4, taul, &work[1], &linfo); if (linfo != 0) { goto L70; } sorg2r_(&m, &m, n2, li, &c__4, taul, &work[1], &linfo); if (linfo != 0) { goto L70; } /* Compute orthogonal matrix RQ: IR * RQ' = [ 0 TR], where IR = [ SCALE * identity(N1), R ] */ i__1 = *n1; for (i__ = 1; i__ <= i__1; ++i__) { ir_ref(*n2 + i__, i__) = scale; /* L20: */ } sgerq2_(n1, &m, &ir_ref(*n2 + 1, 1), &c__4, taur, &work[1], &linfo); if (linfo != 0) { goto L70; } sorgr2_(&m, &m, n1, ir, &c__4, taur, &work[1], &linfo); if (linfo != 0) { goto L70; } /* Perform the swapping tentatively: */ sgemm_("T", "N", &m, &m, &m, &c_b38, li, &c__4, s, &c__4, &c_b3, & work[1], &m); sgemm_("N", "T", &m, &m, &m, &c_b38, &work[1], &m, ir, &c__4, &c_b3, s, &c__4); sgemm_("T", "N", &m, &m, &m, &c_b38, li, &c__4, t, &c__4, &c_b3, & work[1], &m); sgemm_("N", "T", &m, &m, &m, &c_b38, &work[1], &m, ir, &c__4, &c_b3, t, &c__4); slacpy_("F", &m, &m, s, &c__4, scpy, &c__4); slacpy_("F", &m, &m, t, &c__4, tcpy, &c__4); slacpy_("F", &m, &m, ir, &c__4, ircop, &c__4); slacpy_("F", &m, &m, li, &c__4, licop, &c__4); /* Triangularize the B-part by an RQ factorization. Apply transformation (from left) to A-part, giving S. */ sgerq2_(&m, &m, t, &c__4, taur, &work[1], &linfo); if (linfo != 0) { goto L70; } sormr2_("R", "T", &m, &m, &m, t, &c__4, taur, s, &c__4, &work[1], & linfo); if (linfo != 0) { goto L70; } sormr2_("L", "N", &m, &m, &m, t, &c__4, taur, ir, &c__4, &work[1], & linfo); if (linfo != 0) { goto L70; } /* Compute F-norm(S21) in BRQA21. (T21 is 0.) */ dscale = 0.f; dsum = 1.f; i__1 = *n2; for (i__ = 1; i__ <= i__1; ++i__) { slassq_(n1, &s_ref(*n2 + 1, i__), &c__1, &dscale, &dsum); /* L30: */ } brqa21 = dscale * sqrt(dsum); /* Triangularize the B-part by a QR factorization. Apply transformation (from right) to A-part, giving S. */ sgeqr2_(&m, &m, tcpy, &c__4, taul, &work[1], &linfo); if (linfo != 0) { goto L70; } sorm2r_("L", "T", &m, &m, &m, tcpy, &c__4, taul, scpy, &c__4, &work[1] , info); sorm2r_("R", "N", &m, &m, &m, tcpy, &c__4, taul, licop, &c__4, &work[ 1], info); if (linfo != 0) { goto L70; } /* Compute F-norm(S21) in BQRA21. (T21 is 0.) */ dscale = 0.f; dsum = 1.f; i__1 = *n2; for (i__ = 1; i__ <= i__1; ++i__) { slassq_(n1, &scpy_ref(*n2 + 1, i__), &c__1, &dscale, &dsum); /* L40: */ } bqra21 = dscale * sqrt(dsum); /* Decide which method to use. Weak stability test: F-norm(S21) <= O(EPS * F-norm((S, T))) */ if (bqra21 <= brqa21 && bqra21 <= thresh) { slacpy_("F", &m, &m, scpy, &c__4, s, &c__4); slacpy_("F", &m, &m, tcpy, &c__4, t, &c__4); slacpy_("F", &m, &m, ircop, &c__4, ir, &c__4); slacpy_("F", &m, &m, licop, &c__4, li, &c__4); } else if (brqa21 >= thresh) { goto L70; } /* Set lower triangle of B-part to zero */ i__1 = m; for (i__ = 2; i__ <= i__1; ++i__) { i__2 = m - i__ + 1; scopy_(&i__2, &c_b3, &c__0, &t_ref(i__, i__ - 1), &c__1); /* L50: */ } if (TRUE_) { /* Strong stability test: F-norm((A-QL*S*QR', B-QL*T*QR')) <= O(EPS*F-norm((A,B))) */ slacpy_("Full", &m, &m, &a_ref(*j1, *j1), lda, &work[m * m + 1], & m); sgemm_("N", "N", &m, &m, &m, &c_b38, li, &c__4, s, &c__4, &c_b3, & work[1], &m); sgemm_("N", "N", &m, &m, &m, &c_b44, &work[1], &m, ir, &c__4, & c_b38, &work[m * m + 1], &m); dscale = 0.f; dsum = 1.f; i__1 = m * m; slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum); slacpy_("Full", &m, &m, &b_ref(*j1, *j1), ldb, &work[m * m + 1], & m); sgemm_("N", "N", &m, &m, &m, &c_b38, li, &c__4, t, &c__4, &c_b3, & work[1], &m); sgemm_("N", "N", &m, &m, &m, &c_b44, &work[1], &m, ir, &c__4, & c_b38, &work[m * m + 1], &m); i__1 = m * m; slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum); ss = dscale * sqrt(dsum); strong = ss <= thresh; if (! strong) { goto L70; } } /* If the swap is accepted ("weakly" and "strongly"), apply the transformations and set N1-by-N2 (2,1)-block to zero. */ i__1 = *n2; for (i__ = 1; i__ <= i__1; ++i__) { scopy_(n1, &c_b3, &c__0, &s_ref(*n2 + 1, i__), &c__1); /* L60: */ } /* copy back M-by-M diagonal block starting at index J1 of (A, B) */ slacpy_("F", &m, &m, s, &c__4, &a_ref(*j1, *j1), lda); slacpy_("F", &m, &m, t, &c__4, &b_ref(*j1, *j1), ldb); scopy_(&c__16, &c_b3, &c__0, t, &c__1); /* Standardize existing 2-by-2 blocks. */ i__1 = m * m; scopy_(&i__1, &c_b3, &c__0, &work[1], &c__1); work[1] = 1.f; t_ref(1, 1) = 1.f; idum = *lwork - m * m - 2; if (*n2 > 1) { slagv2_(&a_ref(*j1, *j1), lda, &b_ref(*j1, *j1), ldb, ar, ai, be, &work[1], &work[2], &t_ref(1, 1), &t_ref(2, 1)); work[m + 1] = -work[2]; work[m + 2] = work[1]; t_ref(*n2, *n2) = t_ref(1, 1); t_ref(1, 2) = -t_ref(2, 1); } work[m * m] = 1.f; t_ref(m, m) = 1.f; if (*n1 > 1) { slagv2_(&a_ref(*j1 + *n2, *j1 + *n2), lda, &b_ref(*j1 + *n2, *j1 + *n2), ldb, taur, taul, &work[m * m + 1], &work[*n2 * m + *n2 + 1], &work[*n2 * m + *n2 + 2], &t_ref(*n2 + 1, *n2 + 1), &t_ref(m, m - 1)); work[m * m] = work[*n2 * m + *n2 + 1]; work[m * m - 1] = -work[*n2 * m + *n2 + 2]; t_ref(m, m) = t_ref(*n2 + 1, *n2 + 1); t_ref(m - 1, m) = -t_ref(m, m - 1); } sgemm_("T", "N", n2, n1, n2, &c_b38, &work[1], &m, &a_ref(*j1, *j1 + * n2), lda, &c_b3, &work[m * m + 1], n2); slacpy_("Full", n2, n1, &work[m * m + 1], n2, &a_ref(*j1, *j1 + *n2), lda); sgemm_("T", "N", n2, n1, n2, &c_b38, &work[1], &m, &b_ref(*j1, *j1 + * n2), ldb, &c_b3, &work[m * m + 1], n2); slacpy_("Full", n2, n1, &work[m * m + 1], n2, &b_ref(*j1, *j1 + *n2), ldb); sgemm_("N", "N", &m, &m, &m, &c_b38, li, &c__4, &work[1], &m, &c_b3, & work[m * m + 1], &m); slacpy_("Full", &m, &m, &work[m * m + 1], &m, li, &c__4); sgemm_("N", "N", n2, n1, n1, &c_b38, &a_ref(*j1, *j1 + *n2), lda, & t_ref(*n2 + 1, *n2 + 1), &c__4, &c_b3, &work[1], n2); slacpy_("Full", n2, n1, &work[1], n2, &a_ref(*j1, *j1 + *n2), lda); sgemm_("N", "N", n2, n1, n1, &c_b38, &b_ref(*j1, *j1 + *n2), lda, & t_ref(*n2 + 1, *n2 + 1), &c__4, &c_b3, &work[1], n2); slacpy_("Full", n2, n1, &work[1], n2, &b_ref(*j1, *j1 + *n2), ldb); sgemm_("T", "N", &m, &m, &m, &c_b38, ir, &c__4, t, &c__4, &c_b3, & work[1], &m); slacpy_("Full", &m, &m, &work[1], &m, ir, &c__4); /* Accumulate transformations into Q and Z if requested. */ if (*wantq) { sgemm_("N", "N", n, &m, &m, &c_b38, &q_ref(1, *j1), ldq, li, & c__4, &c_b3, &work[1], n); slacpy_("Full", n, &m, &work[1], n, &q_ref(1, *j1), ldq); } if (*wantz) { sgemm_("N", "N", n, &m, &m, &c_b38, &z___ref(1, *j1), ldz, ir, & c__4, &c_b3, &work[1], n); slacpy_("Full", n, &m, &work[1], n, &z___ref(1, *j1), ldz); } /* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */ i__ = *j1 + m; if (i__ <= *n) { i__1 = *n - i__ + 1; sgemm_("T", "N", &m, &i__1, &m, &c_b38, li, &c__4, &a_ref(*j1, i__), lda, &c_b3, &work[1], &m); i__1 = *n - i__ + 1; slacpy_("Full", &m, &i__1, &work[1], &m, &a_ref(*j1, i__), lda); i__1 = *n - i__ + 1; sgemm_("T", "N", &m, &i__1, &m, &c_b38, li, &c__4, &b_ref(*j1, i__), lda, &c_b3, &work[1], &m); i__1 = *n - i__ + 1; slacpy_("Full", &m, &i__1, &work[1], &m, &b_ref(*j1, i__), lda); } i__ = *j1 - 1; if (i__ > 0) { sgemm_("N", "N", &i__, &m, &m, &c_b38, &a_ref(1, *j1), lda, ir, & c__4, &c_b3, &work[1], &i__); slacpy_("Full", &i__, &m, &work[1], &i__, &a_ref(1, *j1), lda); sgemm_("N", "N", &i__, &m, &m, &c_b38, &b_ref(1, *j1), ldb, ir, & c__4, &c_b3, &work[1], &i__); slacpy_("Full", &i__, &m, &work[1], &i__, &b_ref(1, *j1), ldb); } /* Exit with INFO = 0 if swap was successfully performed. */ return 0; } /* Exit with INFO = 1 if swap was rejected. */ L70: *info = 1; return 0; /* End of STGEX2 */ } /* stgex2_ */
/* Subroutine */ int dlaed3_(integer *k, integer *n, integer *n1, doublereal * d__, doublereal *q, integer *ldq, doublereal *rho, doublereal *dlamda, doublereal *q2, integer *indx, integer *ctot, doublereal *w, doublereal *s, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, Courant Institute, NAG Ltd., and Rice University June 30, 1999 Purpose ======= DLAED3 finds the roots of the secular equation, as defined by the values in D, W, and RHO, between 1 and K. It makes the appropriate calls to DLAED4 and then updates the eigenvectors by multiplying the matrix of eigenvectors of the pair of eigensystems being combined by the matrix of eigenvectors of the K-by-K system which is solved here. This code makes very mild assumptions about floating point arithmetic. It will work on machines with a guard digit in add/subtract, or on those binary machines without guard digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. It could conceivably fail on hexadecimal or decimal machines without guard digits, but we know of none. Arguments ========= K (input) INTEGER The number of terms in the rational function to be solved by DLAED4. K >= 0. N (input) INTEGER The number of rows and columns in the Q matrix. N >= K (deflation may result in N>K). N1 (input) INTEGER The location of the last eigenvalue in the leading submatrix. min(1,N) <= N1 <= N/2. D (output) DOUBLE PRECISION array, dimension (N) D(I) contains the updated eigenvalues for 1 <= I <= K. Q (output) DOUBLE PRECISION array, dimension (LDQ,N) Initially the first K columns are used as workspace. On output the columns 1 to K contain the updated eigenvectors. LDQ (input) INTEGER The leading dimension of the array Q. LDQ >= max(1,N). RHO (input) DOUBLE PRECISION The value of the parameter in the rank one update equation. RHO >= 0 required. DLAMDA (input/output) DOUBLE PRECISION array, dimension (K) The first K elements of this array contain the old roots of the deflated updating problem. These are the poles of the secular equation. May be changed on output by having lowest order bit set to zero on Cray X-MP, Cray Y-MP, Cray-2, or Cray C-90, as described above. Q2 (input) DOUBLE PRECISION array, dimension (LDQ2, N) The first K columns of this matrix contain the non-deflated eigenvectors for the split problem. INDX (input) INTEGER array, dimension (N) The permutation used to arrange the columns of the deflated Q matrix into three groups (see DLAED2). The rows of the eigenvectors found by DLAED4 must be likewise permuted before the matrix multiply can take place. CTOT (input) INTEGER array, dimension (4) A count of the total number of the various types of columns in Q, as described in INDX. The fourth column type is any column which has been deflated. W (input/output) DOUBLE PRECISION array, dimension (K) The first K elements of this array contain the components of the deflation-adjusted updating vector. Destroyed on output. S (workspace) DOUBLE PRECISION array, dimension (N1 + 1)*K Will contain the eigenvectors of the repaired matrix which will be multiplied by the previously accumulated eigenvectors to update the system. LDS (input) INTEGER The leading dimension of S. LDS >= max(1,K). INFO (output) INTEGER = 0: successful exit. < 0: if INFO = -i, the i-th argument had an illegal value. > 0: if INFO = 1, an eigenvalue did not converge Further Details =============== Based on contributions by Jeff Rutter, Computer Science Division, University of California at Berkeley, USA Modified by Francoise Tisseur, University of Tennessee. ===================================================================== Test the input parameters. Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; static doublereal c_b22 = 1.; static doublereal c_b23 = 0.; /* System generated locals */ integer q_dim1, q_offset, i__1, i__2; doublereal d__1; /* Builtin functions */ double sqrt(doublereal), d_sign(doublereal *, doublereal *); /* Local variables */ static doublereal temp; extern doublereal dnrm2_(integer *, doublereal *, integer *); static integer i__, j; extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *), dcopy_(integer *, doublereal *, integer *, doublereal *, integer *), dlaed4_(integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, integer *); static integer n2; extern doublereal dlamc3_(doublereal *, doublereal *); static integer n12, ii, n23; extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *), dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *); static integer iq2; #define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1] --d__; q_dim1 = *ldq; q_offset = 1 + q_dim1 * 1; q -= q_offset; --dlamda; --q2; --indx; --ctot; --w; --s; /* Function Body */ *info = 0; if (*k < 0) { *info = -1; } else if (*n < *k) { *info = -2; } else if (*ldq < max(1,*n)) { *info = -6; } if (*info != 0) { i__1 = -(*info); xerbla_("DLAED3", &i__1); return 0; } /* Quick return if possible */ if (*k == 0) { return 0; } /* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can be computed with high relative accuracy (barring over/underflow). This is a problem on machines without a guard digit in add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), which on any of these machines zeros out the bottommost bit of DLAMDA(I) if it is 1; this makes the subsequent subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation occurs. On binary machines with a guard digit (almost all machines) it does not change DLAMDA(I) at all. On hexadecimal and decimal machines with a guard digit, it slightly changes the bottommost bits of DLAMDA(I). It does not account for hexadecimal or decimal machines without guard digits (we know of none). We use a subroutine call to compute 2*DLAMBDA(I) to prevent optimizing compilers from eliminating this code. */ i__1 = *k; for (i__ = 1; i__ <= i__1; ++i__) { dlamda[i__] = dlamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__]; /* L10: */ } i__1 = *k; for (j = 1; j <= i__1; ++j) { dlaed4_(k, &j, &dlamda[1], &w[1], &q_ref(1, j), rho, &d__[j], info); /* If the zero finder fails, the computation is terminated. */ if (*info != 0) { goto L120; } /* L20: */ } if (*k == 1) { goto L110; } if (*k == 2) { i__1 = *k; for (j = 1; j <= i__1; ++j) { w[1] = q_ref(1, j); w[2] = q_ref(2, j); ii = indx[1]; q_ref(1, j) = w[ii]; ii = indx[2]; q_ref(2, j) = w[ii]; /* L30: */ } goto L110; } /* Compute updated W. */ dcopy_(k, &w[1], &c__1, &s[1], &c__1); /* Initialize W(I) = Q(I,I) */ i__1 = *ldq + 1; dcopy_(k, &q[q_offset], &i__1, &w[1], &c__1); i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { w[i__] *= q_ref(i__, j) / (dlamda[i__] - dlamda[j]); /* L40: */ } i__2 = *k; for (i__ = j + 1; i__ <= i__2; ++i__) { w[i__] *= q_ref(i__, j) / (dlamda[i__] - dlamda[j]); /* L50: */ } /* L60: */ } i__1 = *k; for (i__ = 1; i__ <= i__1; ++i__) { d__1 = sqrt(-w[i__]); w[i__] = d_sign(&d__1, &s[i__]); /* L70: */ } /* Compute eigenvectors of the modified rank-1 modification. */ i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *k; for (i__ = 1; i__ <= i__2; ++i__) { s[i__] = w[i__] / q_ref(i__, j); /* L80: */ } temp = dnrm2_(k, &s[1], &c__1); i__2 = *k; for (i__ = 1; i__ <= i__2; ++i__) { ii = indx[i__]; q_ref(i__, j) = s[ii] / temp; /* L90: */ } /* L100: */ } /* Compute the updated eigenvectors. */ L110: n2 = *n - *n1; n12 = ctot[1] + ctot[2]; n23 = ctot[2] + ctot[3]; dlacpy_("A", &n23, k, &q_ref(ctot[1] + 1, 1), ldq, &s[1], &n23) ; iq2 = *n1 * n12 + 1; if (n23 != 0) { dgemm_("N", "N", &n2, k, &n23, &c_b22, &q2[iq2], &n2, &s[1], &n23, & c_b23, &q_ref(*n1 + 1, 1), ldq); } else { dlaset_("A", &n2, k, &c_b23, &c_b23, &q_ref(*n1 + 1, 1), ldq); } dlacpy_("A", &n12, k, &q[q_offset], ldq, &s[1], &n12); if (n12 != 0) { dgemm_("N", "N", n1, k, &n12, &c_b22, &q2[1], n1, &s[1], &n12, &c_b23, &q[q_offset], ldq); } else { dlaset_("A", n1, k, &c_b23, &c_b23, &q_ref(1, 1), ldq); } L120: return 0; /* End of DLAED3 */ } /* dlaed3_ */
/* Subroutine */ int zlaqzh_(logical *ilq, logical *ilz, integer *n, integer * ilo, integer *ihi, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *q, integer *ldq, doublecomplex *z__, integer *ldz, doublecomplex *work, integer *info) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, z_offset, i__1, i__2; /* Local variables */ static integer iinfo, icols; static char compq[1], compz[1]; static integer irows; extern /* Subroutine */ int zgghrd_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer * ), zgeqrf_(integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *) , zlacpy_(char *, integer *, integer *, doublecomplex *, integer * , doublecomplex *, integer *), zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *), zungqr_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *), zunmqr_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer *); #define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1 #define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)] #define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1 #define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)] #define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1 #define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)] /* -- LAPACK timing routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= This calls the LAPACK routines to perform the function of QZHES. It is similar in function to ZGGHRD, except that B is not assumed to be upper-triangular. It reduces a pair of matrices (A,B) to a Hessenberg-triangular pair (H,T). More specifically, it computes unitary matrices Q and Z, an (upper) Hessenberg matrix H, and an upper triangular matrix T such that: A = Q H Z* and B = Q T Z* where * means conjugate transpose. Arguments ========= ILQ (input) LOGICAL = .FALSE. do not compute Q. = .TRUE. compute Q. ILZ (input) LOGICAL = .FALSE. do not compute Z. = .TRUE. compute Z. N (input) INTEGER The number of rows and columns in the matrices A, B, Q, and Z. N must be at least 0. ILO (input) INTEGER Columns 1 through ILO-1 of A and B are assumed to be in upper triangular form already, and will not be modified. ILO must be at least 1. IHI (input) INTEGER Rows IHI+1 through N of A and B are assumed to be in upper triangular form already, and will not be touched. IHI may not be greater than N. A (input/output) COMPLEX*16 array, dimension (LDA, N) On entry, the first of the pair of N x N general matrices to be reduced. On exit, the upper triangle and the first subdiagonal of A are overwritten with the Hessenberg matrix H, and the rest is set to zero. LDA (input) INTEGER The leading dimension of A as declared in the calling program. LDA must be at least max ( 1, N ) . B (input/output) COMPLEX*16 array, dimension (LDB, N) On entry, the second of the pair of N x N general matrices to be reduced. On exit, the transformed matrix T = Q* B Z, which is upper triangular. LDB (input) INTEGER The leading dimension of B as declared in the calling program. LDB must be at least max ( 1, N ) . Q (output) COMPLEX*16 array, dimension (LDQ,N) If ILQ = .TRUE., Q will contain the unitary matrix Q. (See "Purpose", above.) Will not be referenced if ILQ = .FALSE. LDQ (input) INTEGER The leading dimension of the matrix Q. LDQ must be at least 1 and at least N. Z (output) COMPLEX*16 array, dimension (LDZ,N) If ILZ = .TRUE., Z will contain the unitary matrix Z. (See "Purpose", above.) May be referenced even if ILZ = .FALSE. LDZ (input) INTEGER The leading dimension of the matrix Z. LDZ must be at least 1 and at least N. WORK (workspace) COMPLEX*16 array, dimension (N) Workspace. INFO (output) INTEGER = 0: successful exit. < 0: if INFO = -i, the i-th argument had an illegal value. > 0: errors that usually indicate LAPACK problems: = 2: error return from ZGEQRF; = 3: error return from ZUNMQR; = 4: error return from ZUNGQR; = 5: error return from ZGGHRD. ===================================================================== Quick return if possible Parameter adjustments */ --work; a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; q_dim1 = *ldq; q_offset = 1 + q_dim1 * 1; q -= q_offset; z_dim1 = *ldz; z_offset = 1 + z_dim1 * 1; z__ -= z_offset; /* Function Body */ if (*n == 0) { return 0; } /* Reduce B to triangular form, and initialize Q and/or Z */ irows = *ihi + 1 - *ilo; icols = *n + 1 - *ilo; i__1 = *n * *ldz; zgeqrf_(&irows, &icols, &b_ref(*ilo, *ilo), ldb, &work[1], &z__[z_offset], &i__1, &iinfo); if (iinfo != 0) { *info = 2; goto L10; } i__1 = *n * *ldz; zunmqr_("L", "C", &irows, &icols, &irows, &b_ref(*ilo, *ilo), ldb, &work[ 1], &a_ref(*ilo, *ilo), lda, &z__[z_offset], &i__1, &iinfo); if (iinfo != 0) { *info = 3; goto L10; } if (*ilq) { zlaset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq); i__1 = irows - 1; i__2 = irows - 1; zlacpy_("L", &i__1, &i__2, &b_ref(*ilo + 1, *ilo), ldb, &q_ref(*ilo + 1, *ilo), ldq); i__1 = *n * *ldz; zungqr_(&irows, &irows, &irows, &q_ref(*ilo, *ilo), ldq, &work[1], & z__[z_offset], &i__1, &iinfo); if (iinfo != 0) { *info = 4; goto L10; } } /* Reduce to generalized Hessenberg form */ if (*ilq) { *(unsigned char *)compq = 'V'; } else { *(unsigned char *)compq = 'N'; } if (*ilz) { *(unsigned char *)compz = 'I'; } else { *(unsigned char *)compz = 'N'; } zgghrd_(compq, compz, n, ilo, ihi, &a[a_offset], lda, &b[b_offset], ldb, & q[q_offset], ldq, &z__[z_offset], ldz, &iinfo); if (iinfo != 0) { *info = 5; goto L10; } /* End */ L10: return 0; /* End of ZLAQZH */ } /* zlaqzh_ */