void test_qr_method_sym() { std::size_t sz = 220; viennacl::matrix<ScalarType, MatrixLayout> Q = viennacl::identity_matrix<ScalarType>(sz); std::vector<ScalarType> d(sz), e(sz), d_ref(sz), e_ref(sz); std::cout << "Testing matrix of size " << sz << "-by-" << sz << std::endl << std::endl; // Initialize diagonal and superdiagonal elements for(unsigned int i = 0; i < sz; ++i) { d[i] = ((float)(i % 9)) - 4.5f; e[i] = ((float)(i % 5)) - 4.5f; } e[0] = 0.0f; d_ref = d; e_ref = e; //---Run the tql2 algorithm----------------------------------- viennacl::linalg::tql2(Q, d, e); // ---Test the computed eigenvalues and eigenvectors if(!test_eigen_val_vec<MatrixLayout>(Q, d, d_ref, e_ref)) exit(EXIT_FAILURE); /* for( unsigned int i = 0; i < sz; ++i) std::cout << "Eigenvalue " << i << "= " << d[i] << std::endl; */ }
/* Subroutine */ int sget52_(logical *left, integer *n, real *a, integer *lda, real *b, integer *ldb, real *e, integer *lde, real *alphar, real * alphai, real *beta, real *work, real *result) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, e_dim1, e_offset, i__1, i__2; real r__1, r__2, r__3, r__4; /* Local variables */ static integer jvec; static real temp1; static integer j; static real acoef, scale, abmax, salfi, sbeta, salfr, anorm, bnorm, enorm; extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *); static char trans[1]; static real bcoefi, bcoefr, alfmax; extern doublereal slamch_(char *), slange_(char *, integer *, integer *, real *, integer *, real *); static real safmin; static char normab[1]; static real safmax, betmax, enrmer; static logical ilcplx; static real errnrm, ulp; #define e_ref(a_1,a_2) e[(a_2)*e_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 ======= SGET52 does an eigenvector check for the generalized eigenvalue problem. The basic test for right eigenvectors is: | b(j) A E(j) - a(j) B E(j) | RESULT(1) = max ------------------------------- j n ulp max( |b(j) A|, |a(j) B| ) using the 1-norm. Here, a(j)/b(j) = w is the j-th generalized eigenvalue of A - w B, or, equivalently, b(j)/a(j) = m is the j-th generalized eigenvalue of m A - B. For real eigenvalues, the test is straightforward. For complex eigenvalues, E(j) and a(j) are complex, represented by Er(j) + i*Ei(j) and ar(j) + i*ai(j), resp., so the test for that eigenvector becomes max( |Wr|, |Wi| ) -------------------------------------------- n ulp max( |b(j) A|, (|ar(j)|+|ai(j)|) |B| ) where Wr = b(j) A Er(j) - ar(j) B Er(j) + ai(j) B Ei(j) Wi = b(j) A Ei(j) - ai(j) B Er(j) - ar(j) B Ei(j) T T _ For left eigenvectors, A , B , a, and b are used. SGET52 also tests the normalization of E. Each eigenvector is supposed to be normalized so that the maximum "absolute value" of its elements is 1, where in this case, "absolute value" of a complex value x is |Re(x)| + |Im(x)| ; let us call this maximum "absolute value" norm of a vector v M(v). if a(j)=b(j)=0, then the eigenvector is set to be the jth coordinate vector. The normalization test is: RESULT(2) = max | M(v(j)) - 1 | / ( n ulp ) eigenvectors v(j) Arguments ========= LEFT (input) LOGICAL =.TRUE.: The eigenvectors in the columns of E are assumed to be *left* eigenvectors. =.FALSE.: The eigenvectors in the columns of E are assumed to be *right* eigenvectors. N (input) INTEGER The size of the matrices. If it is zero, SGET52 does nothing. It must be at least zero. A (input) REAL array, dimension (LDA, N) The matrix A. LDA (input) INTEGER The leading dimension of A. It must be at least 1 and at least N. B (input) REAL array, dimension (LDB, N) The matrix B. LDB (input) INTEGER The leading dimension of B. It must be at least 1 and at least N. E (input) REAL array, dimension (LDE, N) The matrix of eigenvectors. It must be O( 1 ). Complex eigenvalues and eigenvectors always come in pairs, the eigenvalue and its conjugate being stored in adjacent elements of ALPHAR, ALPHAI, and BETA. Thus, if a(j)/b(j) and a(j+1)/b(j+1) are a complex conjugate pair of generalized eigenvalues, then E(,j) contains the real part of the eigenvector and E(,j+1) contains the imaginary part. Note that whether E(,j) is a real eigenvector or part of a complex one is specified by whether ALPHAI(j) is zero or not. LDE (input) INTEGER The leading dimension of E. It must be at least 1 and at least N. ALPHAR (input) REAL array, dimension (N) The real parts of the values a(j) as described above, which, along with b(j), define the generalized eigenvalues. Complex eigenvalues always come in complex conjugate pairs a(j)/b(j) and a(j+1)/b(j+1), which are stored in adjacent elements in ALPHAR, ALPHAI, and BETA. Thus, if the j-th and (j+1)-st eigenvalues form a pair, ALPHAR(j+1)/BETA(j+1) is assumed to be equal to ALPHAR(j)/BETA(j). ALPHAI (input) REAL array, dimension (N) The imaginary parts of the values a(j) as described above, which, along with b(j), define the generalized eigenvalues. If ALPHAI(j)=0, then the eigenvalue is real, otherwise it is part of a complex conjugate pair. Complex eigenvalues always come in complex conjugate pairs a(j)/b(j) and a(j+1)/b(j+1), which are stored in adjacent elements in ALPHAR, ALPHAI, and BETA. Thus, if the j-th and (j+1)-st eigenvalues form a pair, ALPHAI(j+1)/BETA(j+1) is assumed to be equal to -ALPHAI(j)/BETA(j). Also, nonzero values in ALPHAI are assumed to always come in adjacent pairs. BETA (input) REAL array, dimension (N) The values b(j) as described above, which, along with a(j), define the generalized eigenvalues. WORK (workspace) REAL array, dimension (N**2+N) RESULT (output) REAL array, dimension (2) The values computed by the test described above. If A E or B E is likely to overflow, then RESULT(1:2) is set to 10 / ulp. ===================================================================== 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; e_dim1 = *lde; e_offset = 1 + e_dim1 * 1; e -= e_offset; --alphar; --alphai; --beta; --work; --result; /* Function Body */ result[1] = 0.f; result[2] = 0.f; if (*n <= 0) { return 0; } safmin = slamch_("Safe minimum"); safmax = 1.f / safmin; ulp = slamch_("Epsilon") * slamch_("Base"); if (*left) { *(unsigned char *)trans = 'T'; *(unsigned char *)normab = 'I'; } else { *(unsigned char *)trans = 'N'; *(unsigned char *)normab = 'O'; } /* Norm of A, B, and E: Computing MAX */ r__1 = slange_(normab, n, n, &a[a_offset], lda, &work[1]); anorm = dmax(r__1,safmin); /* Computing MAX */ r__1 = slange_(normab, n, n, &b[b_offset], ldb, &work[1]); bnorm = dmax(r__1,safmin); /* Computing MAX */ r__1 = slange_("O", n, n, &e[e_offset], lde, &work[1]); enorm = dmax(r__1,ulp); alfmax = safmax / dmax(1.f,bnorm); betmax = safmax / dmax(1.f,anorm); /* Compute error matrix. Column i = ( b(i) A - a(i) B ) E(i) / max( |a(i) B| |b(i) A| ) */ ilcplx = FALSE_; i__1 = *n; for (jvec = 1; jvec <= i__1; ++jvec) { if (ilcplx) { /* 2nd Eigenvalue/-vector of pair -- do nothing */ ilcplx = FALSE_; } else { salfr = alphar[jvec]; salfi = alphai[jvec]; sbeta = beta[jvec]; if (salfi == 0.f) { /* Real eigenvalue and -vector Computing MAX */ r__1 = dabs(salfr), r__2 = dabs(sbeta); abmax = dmax(r__1,r__2); if (dabs(salfr) > alfmax || dabs(sbeta) > betmax || abmax < 1.f) { scale = 1.f / dmax(abmax,safmin); salfr = scale * salfr; sbeta = scale * sbeta; } /* Computing MAX */ r__1 = dabs(salfr) * bnorm, r__2 = dabs(sbeta) * anorm, r__1 = max(r__1,r__2); scale = 1.f / dmax(r__1,safmin); acoef = scale * sbeta; bcoefr = scale * salfr; sgemv_(trans, n, n, &acoef, &a[a_offset], lda, &e_ref(1, jvec) , &c__1, &c_b12, &work[*n * (jvec - 1) + 1], &c__1); r__1 = -bcoefr; sgemv_(trans, n, n, &r__1, &b[b_offset], lda, &e_ref(1, jvec), &c__1, &c_b15, &work[*n * (jvec - 1) + 1], &c__1); } else { /* Complex conjugate pair */ ilcplx = TRUE_; if (jvec == *n) { result[1] = 10.f / ulp; return 0; } /* Computing MAX */ r__1 = dabs(salfr) + dabs(salfi), r__2 = dabs(sbeta); abmax = dmax(r__1,r__2); if (dabs(salfr) + dabs(salfi) > alfmax || dabs(sbeta) > betmax || abmax < 1.f) { scale = 1.f / dmax(abmax,safmin); salfr = scale * salfr; salfi = scale * salfi; sbeta = scale * sbeta; } /* Computing MAX */ r__1 = (dabs(salfr) + dabs(salfi)) * bnorm, r__2 = dabs(sbeta) * anorm, r__1 = max(r__1,r__2); scale = 1.f / dmax(r__1,safmin); acoef = scale * sbeta; bcoefr = scale * salfr; bcoefi = scale * salfi; if (*left) { bcoefi = -bcoefi; } sgemv_(trans, n, n, &acoef, &a[a_offset], lda, &e_ref(1, jvec) , &c__1, &c_b12, &work[*n * (jvec - 1) + 1], &c__1); r__1 = -bcoefr; sgemv_(trans, n, n, &r__1, &b[b_offset], lda, &e_ref(1, jvec), &c__1, &c_b15, &work[*n * (jvec - 1) + 1], &c__1); sgemv_(trans, n, n, &bcoefi, &b[b_offset], lda, &e_ref(1, jvec + 1), &c__1, &c_b15, &work[*n * (jvec - 1) + 1], &c__1); sgemv_(trans, n, n, &acoef, &a[a_offset], lda, &e_ref(1, jvec + 1), &c__1, &c_b12, &work[*n * jvec + 1], &c__1); r__1 = -bcoefi; sgemv_(trans, n, n, &r__1, &b[b_offset], lda, &e_ref(1, jvec), &c__1, &c_b15, &work[*n * jvec + 1], &c__1); r__1 = -bcoefr; sgemv_(trans, n, n, &r__1, &b[b_offset], lda, &e_ref(1, jvec + 1), &c__1, &c_b15, &work[*n * jvec + 1], &c__1); } } /* L10: */ } /* Computing 2nd power */ i__1 = *n; errnrm = slange_("One", n, n, &work[1], n, &work[i__1 * i__1 + 1]) / enorm; /* Compute RESULT(1) */ result[1] = errnrm / ulp; /* Normalization of E: */ enrmer = 0.f; ilcplx = FALSE_; i__1 = *n; for (jvec = 1; jvec <= i__1; ++jvec) { if (ilcplx) { ilcplx = FALSE_; } else { temp1 = 0.f; if (alphai[jvec] == 0.f) { i__2 = *n; for (j = 1; j <= i__2; ++j) { /* Computing MAX */ r__2 = temp1, r__3 = (r__1 = e_ref(j, jvec), dabs(r__1)); temp1 = dmax(r__2,r__3); /* L20: */ } /* Computing MAX */ r__1 = enrmer, r__2 = temp1 - 1.f; enrmer = dmax(r__1,r__2); } else { ilcplx = TRUE_; i__2 = *n; for (j = 1; j <= i__2; ++j) { /* Computing MAX */ r__3 = temp1, r__4 = (r__1 = e_ref(j, jvec), dabs(r__1)) + (r__2 = e_ref(j, jvec + 1), dabs(r__2)); temp1 = dmax(r__3,r__4); /* L30: */ } /* Computing MAX */ r__1 = enrmer, r__2 = temp1 - 1.f; enrmer = dmax(r__1,r__2); } } /* L40: */ } /* Compute RESULT(2) : the normalization error in E. */ result[2] = enrmer / ((real) (*n) * ulp); return 0; /* End of SGET52 */ } /* sget52_ */
/* Subroutine */ int zchkbk_(integer *nin, integer *nout) { /* Format strings */ static char fmt_9999[] = "(1x,\002.. test output of ZGEBAK .. \002)"; static char fmt_9998[] = "(1x,\002value of largest test error " " = \002,d12.3)"; static char fmt_9997[] = "(1x,\002example number where info is not zero " " = \002,i4)"; static char fmt_9996[] = "(1x,\002example number having largest error " " = \002,i4)"; static char fmt_9995[] = "(1x,\002number of examples where info is not 0" " = \002,i4)"; static char fmt_9994[] = "(1x,\002total number of examples tested " " = \002,i4)"; /* System generated locals */ integer i__1, i__2, i__3, i__4; doublereal d__1, d__2, d__3, d__4; doublecomplex z__1, z__2; /* Builtin functions */ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), e_rsle(void); double d_imag(doublecomplex *); integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen); /* Local variables */ static integer info, lmax[2]; static doublereal rmax, vmax; static doublecomplex e[400] /* was [20][20] */; static integer i__, j, n; static doublereal scale[20], x; static integer ninfo; extern doublereal dlamch_(char *); extern /* Subroutine */ int zgebak_(char *, char *, integer *, integer *, integer *, doublereal *, integer *, doublecomplex *, integer *, integer *); static doublereal safmin; static integer ihi; static doublecomplex ein[400] /* was [20][20] */; static integer ilo; static doublereal eps; static integer knt; /* Fortran I/O blocks */ static cilist io___7 = { 0, 0, 0, 0, 0 }; static cilist io___11 = { 0, 0, 0, 0, 0 }; static cilist io___14 = { 0, 0, 0, 0, 0 }; static cilist io___17 = { 0, 0, 0, 0, 0 }; static cilist io___22 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___23 = { 0, 0, 0, fmt_9998, 0 }; static cilist io___24 = { 0, 0, 0, fmt_9997, 0 }; static cilist io___25 = { 0, 0, 0, fmt_9996, 0 }; static cilist io___26 = { 0, 0, 0, fmt_9995, 0 }; static cilist io___27 = { 0, 0, 0, fmt_9994, 0 }; #define e_subscr(a_1,a_2) (a_2)*20 + a_1 - 21 #define e_ref(a_1,a_2) e[e_subscr(a_1,a_2)] #define ein_subscr(a_1,a_2) (a_2)*20 + a_1 - 21 #define ein_ref(a_1,a_2) ein[ein_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 ======= ZCHKBK tests ZGEBAK, a routine for backward transformation of the computed right or left eigenvectors if the orginal matrix was preprocessed by balance subroutine ZGEBAL. Arguments ========= NIN (input) INTEGER The logical unit number for input. NIN > 0. NOUT (input) INTEGER The logical unit number for output. NOUT > 0. ====================================================================== */ lmax[0] = 0; lmax[1] = 0; ninfo = 0; knt = 0; rmax = 0.; eps = dlamch_("E"); safmin = dlamch_("S"); L10: io___7.ciunit = *nin; s_rsle(&io___7); do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer)); do_lio(&c__3, &c__1, (char *)&ilo, (ftnlen)sizeof(integer)); do_lio(&c__3, &c__1, (char *)&ihi, (ftnlen)sizeof(integer)); e_rsle(); if (n == 0) { goto L60; } io___11.ciunit = *nin; s_rsle(&io___11); i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { do_lio(&c__5, &c__1, (char *)&scale[i__ - 1], (ftnlen)sizeof( doublereal)); } e_rsle(); i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { io___14.ciunit = *nin; s_rsle(&io___14); i__2 = n; for (j = 1; j <= i__2; ++j) { do_lio(&c__7, &c__1, (char *)&e_ref(i__, j), (ftnlen)sizeof( doublecomplex)); } e_rsle(); /* L20: */ } i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { io___17.ciunit = *nin; s_rsle(&io___17); i__2 = n; for (j = 1; j <= i__2; ++j) { do_lio(&c__7, &c__1, (char *)&ein_ref(i__, j), (ftnlen)sizeof( doublecomplex)); } e_rsle(); /* L30: */ } ++knt; zgebak_("B", "R", &n, &ilo, &ihi, scale, &n, e, &c__20, &info); if (info != 0) { ++ninfo; lmax[0] = knt; } vmax = 0.; i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = n; for (j = 1; j <= i__2; ++j) { i__3 = e_subscr(i__, j); i__4 = ein_subscr(i__, j); z__2.r = e[i__3].r - ein[i__4].r, z__2.i = e[i__3].i - ein[i__4] .i; z__1.r = z__2.r, z__1.i = z__2.i; x = ((d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), abs(d__2) )) / eps; i__3 = e_subscr(i__, j); if ((d__1 = e[i__3].r, abs(d__1)) + (d__2 = d_imag(&e_ref(i__, j)) , abs(d__2)) > safmin) { i__4 = e_subscr(i__, j); x /= (d__3 = e[i__4].r, abs(d__3)) + (d__4 = d_imag(&e_ref( i__, j)), abs(d__4)); } vmax = max(vmax,x); /* L40: */ } /* L50: */ } if (vmax > rmax) { lmax[1] = knt; rmax = vmax; } goto L10; L60: io___22.ciunit = *nout; s_wsfe(&io___22); e_wsfe(); io___23.ciunit = *nout; s_wsfe(&io___23); do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal)); e_wsfe(); io___24.ciunit = *nout; s_wsfe(&io___24); do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer)); e_wsfe(); io___25.ciunit = *nout; s_wsfe(&io___25); do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer)); e_wsfe(); io___26.ciunit = *nout; s_wsfe(&io___26); do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer)); e_wsfe(); io___27.ciunit = *nout; s_wsfe(&io___27); do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer)); e_wsfe(); return 0; /* End of ZCHKBK */ } /* zchkbk_ */
/* Subroutine */ int dlatm5_(integer *prtype, integer *m, integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal * c__, integer *ldc, doublereal *d__, integer *ldd, doublereal *e, integer *lde, doublereal *f, integer *ldf, doublereal *r__, integer * ldr, doublereal *l, integer *ldl, doublereal *alpha, integer *qblcka, integer *qblckb) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1, d_offset, e_dim1, e_offset, f_dim1, f_offset, l_dim1, l_offset, r_dim1, r_offset, i__1, i__2; /* Builtin functions */ double sin(doublereal); /* Local variables */ static integer i__, j, k; extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *); static doublereal imeps, reeps; #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 d___ref(a_1,a_2) d__[(a_2)*d_dim1 + a_1] #define e_ref(a_1,a_2) e[(a_2)*e_dim1 + a_1] #define l_ref(a_1,a_2) l[(a_2)*l_dim1 + a_1] #define r___ref(a_1,a_2) r__[(a_2)*r_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 ======= DLATM5 generates matrices involved in the Generalized Sylvester equation: A * R - L * B = C D * R - L * E = F They also satisfy (the diagonalization condition) [ I -L ] ( [ A -C ], [ D -F ] ) [ I R ] = ( [ A ], [ D ] ) [ I ] ( [ B ] [ E ] ) [ I ] ( [ B ] [ E ] ) Arguments ========= PRTYPE (input) INTEGER "Points" to a certian type of the matrices to generate (see futher details). M (input) INTEGER Specifies the order of A and D and the number of rows in C, F, R and L. N (input) INTEGER Specifies the order of B and E and the number of columns in C, F, R and L. A (output) DOUBLE PRECISION array, dimension (LDA, M). On exit A M-by-M is initialized according to PRTYPE. LDA (input) INTEGER The leading dimension of A. B (output) DOUBLE PRECISION array, dimension (LDB, N). On exit B N-by-N is initialized according to PRTYPE. LDB (input) INTEGER The leading dimension of B. C (output) DOUBLE PRECISION array, dimension (LDC, N). On exit C M-by-N is initialized according to PRTYPE. LDC (input) INTEGER The leading dimension of C. D (output) DOUBLE PRECISION array, dimension (LDD, M). On exit D M-by-M is initialized according to PRTYPE. LDD (input) INTEGER The leading dimension of D. E (output) DOUBLE PRECISION array, dimension (LDE, N). On exit E N-by-N is initialized according to PRTYPE. LDE (input) INTEGER The leading dimension of E. F (output) DOUBLE PRECISION array, dimension (LDF, N). On exit F M-by-N is initialized according to PRTYPE. LDF (input) INTEGER The leading dimension of F. R (output) DOUBLE PRECISION array, dimension (LDR, N). On exit R M-by-N is initialized according to PRTYPE. LDR (input) INTEGER The leading dimension of R. L (output) DOUBLE PRECISION array, dimension (LDL, N). On exit L M-by-N is initialized according to PRTYPE. LDL (input) INTEGER The leading dimension of L. ALPHA (input) DOUBLE PRECISION Parameter used in generating PRTYPE = 1 and 5 matrices. QBLCKA (input) INTEGER When PRTYPE = 3, specifies the distance between 2-by-2 blocks on the diagonal in A. Otherwise, QBLCKA is not referenced. QBLCKA > 1. QBLCKB (input) INTEGER When PRTYPE = 3, specifies the distance between 2-by-2 blocks on the diagonal in B. Otherwise, QBLCKB is not referenced. QBLCKB > 1. Further Details =============== PRTYPE = 1: A and B are Jordan blocks, D and E are identity matrices A : if (i == j) then A(i, j) = 1.0 if (j == i + 1) then A(i, j) = -1.0 else A(i, j) = 0.0, i, j = 1...M B : if (i == j) then B(i, j) = 1.0 - ALPHA if (j == i + 1) then B(i, j) = 1.0 else B(i, j) = 0.0, i, j = 1...N D : if (i == j) then D(i, j) = 1.0 else D(i, j) = 0.0, i, j = 1...M E : if (i == j) then E(i, j) = 1.0 else E(i, j) = 0.0, i, j = 1...N L = R are chosen from [-10...10], which specifies the right hand sides (C, F). PRTYPE = 2 or 3: Triangular and/or quasi- triangular. A : if (i <= j) then A(i, j) = [-1...1] else A(i, j) = 0.0, i, j = 1...M if (PRTYPE = 3) then A(k + 1, k + 1) = A(k, k) A(k + 1, k) = [-1...1] sign(A(k, k + 1) = -(sin(A(k + 1, k)) k = 1, M - 1, QBLCKA B : if (i <= j) then B(i, j) = [-1...1] else B(i, j) = 0.0, i, j = 1...N if (PRTYPE = 3) then B(k + 1, k + 1) = B(k, k) B(k + 1, k) = [-1...1] sign(B(k, k + 1) = -(sign(B(k + 1, k)) k = 1, N - 1, QBLCKB D : if (i <= j) then D(i, j) = [-1...1]. else D(i, j) = 0.0, i, j = 1...M E : if (i <= j) then D(i, j) = [-1...1] else E(i, j) = 0.0, i, j = 1...N L, R are chosen from [-10...10], which specifies the right hand sides (C, F). PRTYPE = 4 Full A(i, j) = [-10...10] D(i, j) = [-1...1] i,j = 1...M B(i, j) = [-10...10] E(i, j) = [-1...1] i,j = 1...N R(i, j) = [-10...10] L(i, j) = [-1...1] i = 1..M ,j = 1...N L, R specifies the right hand sides (C, F). PRTYPE = 5 special case common and/or close eigs. ===================================================================== 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; c_dim1 = *ldc; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; d_dim1 = *ldd; d_offset = 1 + d_dim1 * 1; d__ -= d_offset; e_dim1 = *lde; e_offset = 1 + e_dim1 * 1; e -= e_offset; f_dim1 = *ldf; f_offset = 1 + f_dim1 * 1; f -= f_offset; r_dim1 = *ldr; r_offset = 1 + r_dim1 * 1; r__ -= r_offset; l_dim1 = *ldl; l_offset = 1 + l_dim1 * 1; l -= l_offset; /* Function Body */ if (*prtype == 1) { i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *m; for (j = 1; j <= i__2; ++j) { if (i__ == j) { a_ref(i__, j) = 1.; d___ref(i__, j) = 1.; } else if (i__ == j - 1) { a_ref(i__, j) = -1.; d___ref(i__, j) = 0.; } else { a_ref(i__, j) = 0.; d___ref(i__, j) = 0.; } /* L10: */ } /* L20: */ } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *n; for (j = 1; j <= i__2; ++j) { if (i__ == j) { b_ref(i__, j) = 1. - *alpha; e_ref(i__, j) = 1.; } else if (i__ == j - 1) { b_ref(i__, j) = 1.; e_ref(i__, j) = 0.; } else { b_ref(i__, j) = 0.; e_ref(i__, j) = 0.; } /* L30: */ } /* L40: */ } i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *n; for (j = 1; j <= i__2; ++j) { r___ref(i__, j) = (.5 - sin((doublereal) (i__ / j))) * 20.; l_ref(i__, j) = r___ref(i__, j); /* L50: */ } /* L60: */ } } else if (*prtype == 2 || *prtype == 3) { i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *m; for (j = 1; j <= i__2; ++j) { if (i__ <= j) { a_ref(i__, j) = (.5 - sin((doublereal) i__)) * 2.; d___ref(i__, j) = (.5 - sin((doublereal) (i__ * j))) * 2.; } else { a_ref(i__, j) = 0.; d___ref(i__, j) = 0.; } /* L70: */ } /* L80: */ } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *n; for (j = 1; j <= i__2; ++j) { if (i__ <= j) { b_ref(i__, j) = (.5 - sin((doublereal) (i__ + j))) * 2.; e_ref(i__, j) = (.5 - sin((doublereal) j)) * 2.; } else { b_ref(i__, j) = 0.; e_ref(i__, j) = 0.; } /* L90: */ } /* L100: */ } i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *n; for (j = 1; j <= i__2; ++j) { r___ref(i__, j) = (.5 - sin((doublereal) (i__ * j))) * 20.; l_ref(i__, j) = (.5 - sin((doublereal) (i__ + j))) * 20.; /* L110: */ } /* L120: */ } if (*prtype == 3) { if (*qblcka <= 1) { *qblcka = 2; } i__1 = *m - 1; i__2 = *qblcka; for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) { a_ref(k + 1, k + 1) = a_ref(k, k); a_ref(k + 1, k) = -sin(a_ref(k, k + 1)); /* L130: */ } if (*qblckb <= 1) { *qblckb = 2; } i__2 = *n - 1; i__1 = *qblckb; for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) { b_ref(k + 1, k + 1) = b_ref(k, k); b_ref(k + 1, k) = -sin(b_ref(k, k + 1)); /* L140: */ } } } else if (*prtype == 4) { i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *m; for (j = 1; j <= i__2; ++j) { a_ref(i__, j) = (.5 - sin((doublereal) (i__ * j))) * 20.; d___ref(i__, j) = (.5 - sin((doublereal) (i__ + j))) * 2.; /* L150: */ } /* L160: */ } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *n; for (j = 1; j <= i__2; ++j) { b_ref(i__, j) = (.5 - sin((doublereal) (i__ + j))) * 20.; e_ref(i__, j) = (.5 - sin((doublereal) (i__ * j))) * 2.; /* L170: */ } /* L180: */ } i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *n; for (j = 1; j <= i__2; ++j) { r___ref(i__, j) = (.5 - sin((doublereal) (j / i__))) * 20.; l_ref(i__, j) = (.5 - sin((doublereal) (i__ * j))) * 2.; /* L190: */ } /* L200: */ } } else if (*prtype >= 5) { reeps = 20. / *alpha; imeps = -1.5 / *alpha; i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *n; for (j = 1; j <= i__2; ++j) { r___ref(i__, j) = (.5 - sin((doublereal) (i__ * j))) * *alpha / 20.; l_ref(i__, j) = (.5 - sin((doublereal) (i__ + j))) * *alpha / 20.; /* L210: */ } /* L220: */ } i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { d___ref(i__, i__) = 1.; /* L230: */ } i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { if (i__ <= 4) { a_ref(i__, i__) = 1.; if (i__ > 2) { a_ref(i__, i__) = reeps + 1.; } if (i__ % 2 != 0 && i__ < *m) { a_ref(i__, i__ + 1) = imeps; } else if (i__ > 1) { a_ref(i__, i__ - 1) = -imeps; } } else if (i__ <= 8) { if (i__ <= 6) { a_ref(i__, i__) = reeps; } else { a_ref(i__, i__) = -reeps; } if (i__ % 2 != 0 && i__ < *m) { a_ref(i__, i__ + 1) = 1.; } else if (i__ > 1) { a_ref(i__, i__ - 1) = -1.; } } else { a_ref(i__, i__) = 1.; if (i__ % 2 != 0 && i__ < *m) { a_ref(i__, i__ + 1) = imeps * 2; } else if (i__ > 1) { a_ref(i__, i__ - 1) = -imeps * 2; } } /* L240: */ } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { e_ref(i__, i__) = 1.; if (i__ <= 4) { b_ref(i__, i__) = -1.; if (i__ > 2) { b_ref(i__, i__) = 1. - reeps; } if (i__ % 2 != 0 && i__ < *n) { b_ref(i__, i__ + 1) = imeps; } else if (i__ > 1) { b_ref(i__, i__ - 1) = -imeps; } } else if (i__ <= 8) { if (i__ <= 6) { b_ref(i__, i__) = reeps; } else { b_ref(i__, i__) = -reeps; } if (i__ % 2 != 0 && i__ < *n) { b_ref(i__, i__ + 1) = imeps + 1.; } else if (i__ > 1) { b_ref(i__, i__ - 1) = -1. - imeps; } } else { b_ref(i__, i__) = 1. - reeps; if (i__ % 2 != 0 && i__ < *n) { b_ref(i__, i__ + 1) = imeps * 2; } else if (i__ > 1) { b_ref(i__, i__ - 1) = -imeps * 2; } } /* L250: */ } } /* Compute rhs (C, F) */ dgemm_("N", "N", m, n, m, &c_b29, &a[a_offset], lda, &r__[r_offset], ldr, &c_b30, &c__[c_offset], ldc); dgemm_("N", "N", m, n, n, &c_b33, &l[l_offset], ldl, &b[b_offset], ldb, & c_b29, &c__[c_offset], ldc); dgemm_("N", "N", m, n, m, &c_b29, &d__[d_offset], ldd, &r__[r_offset], ldr, &c_b30, &f[f_offset], ldf); dgemm_("N", "N", m, n, n, &c_b33, &l[l_offset], ldl, &e[e_offset], lde, & c_b29, &f[f_offset], ldf); /* End of DLATM5 */ return 0; } /* dlatm5_ */
/* Subroutine */ int ctgsyl_(char *trans, integer *ijob, integer *m, integer * n, complex *a, integer *lda, complex *b, integer *ldb, complex *c__, integer *ldc, complex *d__, integer *ldd, complex *e, integer *lde, complex *f, integer *ldf, real *scale, real *dif, complex *work, integer *lwork, 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 ======= CTGSYL solves the generalized Sylvester equation: A * R - L * B = scale * C (1) D * R - L * E = scale * F where R and L are unknown m-by-n matrices, (A, D), (B, E) and (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n, respectively, with complex entries. A, B, D and E are upper triangular (i.e., (A,D) and (B,E) in generalized Schur form). The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor chosen to avoid overflow. In matrix notation (1) is equivalent to solve Zx = scale*b, where Z is defined as Z = [ kron(In, A) -kron(B', Im) ] (2) [ kron(In, D) -kron(E', Im) ], Here Ix is the identity matrix of size x and X' is the conjugate transpose of X. Kron(X, Y) is the Kronecker product between the matrices X and Y. If TRANS = 'C', y in the conjugate transposed system Z'*y = scale*b is solved for, which is equivalent to solve for R and L in A' * R + D' * L = scale * C (3) R * B' + L * E' = scale * -F This case (TRANS = 'C') is used to compute an one-norm-based estimate of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D) and (B,E), using CLACON. If IJOB >= 1, CTGSYL computes a Frobenius norm-based estimate of Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the reciprocal of the smallest singular value of Z. This is a level-3 BLAS algorithm. Arguments ========= TRANS (input) CHARACTER*1 = 'N': solve the generalized sylvester equation (1). = 'C': solve the "conjugate transposed" system (3). IJOB (input) INTEGER Specifies what kind of functionality to be performed. =0: solve (1) only. =1: The functionality of 0 and 3. =2: The functionality of 0 and 4. =3: Only an estimate of Dif[(A,D), (B,E)] is computed. (look ahead strategy is used). =4: Only an estimate of Dif[(A,D), (B,E)] is computed. (CGECON on sub-systems is used). Not referenced if TRANS = 'C'. M (input) INTEGER The order of the matrices A and D, and the row dimension of the matrices C, F, R and L. N (input) INTEGER The order of the matrices B and E, and the column dimension of the matrices C, F, R and L. A (input) COMPLEX array, dimension (LDA, M) The upper triangular matrix A. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1, M). B (input) COMPLEX array, dimension (LDB, N) The upper triangular matrix B. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1, N). C (input/output) COMPLEX array, dimension (LDC, N) On entry, C contains the right-hand-side of the first matrix equation in (1) or (3). On exit, if IJOB = 0, 1 or 2, C has been overwritten by the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R, the solution achieved during the computation of the Dif-estimate. LDC (input) INTEGER The leading dimension of the array C. LDC >= max(1, M). D (input) COMPLEX array, dimension (LDD, M) The upper triangular matrix D. LDD (input) INTEGER The leading dimension of the array D. LDD >= max(1, M). E (input) COMPLEX array, dimension (LDE, N) The upper triangular matrix E. LDE (input) INTEGER The leading dimension of the array E. LDE >= max(1, N). F (input/output) COMPLEX array, dimension (LDF, N) On entry, F contains the right-hand-side of the second matrix equation in (1) or (3). On exit, if IJOB = 0, 1 or 2, F has been overwritten by the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L, the solution achieved during the computation of the Dif-estimate. LDF (input) INTEGER The leading dimension of the array F. LDF >= max(1, M). DIF (output) REAL On exit DIF is the reciprocal of a lower bound of the reciprocal of the Dif-function, i.e. DIF is an upper bound of Dif[(A,D), (B,E)] = sigma-min(Z), where Z as in (2). IF IJOB = 0 or TRANS = 'C', DIF is not referenced. SCALE (output) REAL On exit SCALE is the scaling factor in (1) or (3). If 0 < SCALE < 1, C and F hold the solutions R and L, resp., to a slightly perturbed system but the input matrices A, B, D and E have not been changed. If SCALE = 0, R and L will hold the solutions to the homogenious system with C = F = 0. WORK (workspace/output) COMPLEX array, dimension (LWORK) IF IJOB = 0, WORK is not referenced. Otherwise, LWORK (input) INTEGER The dimension of the array WORK. LWORK > = 1. If IJOB = 1 or 2 and TRANS = 'N', LWORK >= 2*M*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. IWORK (workspace) INTEGER array, dimension (M+N+2) If IJOB = 0, IWORK is not referenced. INFO (output) INTEGER =0: successful exit <0: If INFO = -i, the i-th argument had an illegal value. >0: (A, D) and (B, E) have common or very close eigenvalues. Further Details =============== Based on contributions by Bo Kagstrom and Peter Poromaa, Department of Computing Science, Umea University, S-901 87 Umea, Sweden. [1] 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. [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal. Appl., 15(4):1045-1060, 1994. [3] B. Kagstrom and L. Westin, Generalized Schur Methods with Condition Estimators for Solving the Generalized Sylvester Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751. ===================================================================== Decode and test input parameters Parameter adjustments */ /* Table of constant values */ static integer c__2 = 2; static integer c_n1 = -1; static integer c__5 = 5; static integer c__0 = 0; static integer c__1 = 1; static complex c_b16 = {0.f,0.f}; static complex c_b53 = {-1.f,0.f}; static complex c_b54 = {1.f,0.f}; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1, d_offset, e_dim1, e_offset, f_dim1, f_offset, i__1, i__2, i__3, i__4; complex q__1; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static real dsum; static integer i__, j, k, p, q; extern /* Subroutine */ int cscal_(integer *, complex *, complex *, integer *), cgemm_(char *, char *, integer *, integer *, integer * , complex *, complex *, integer *, complex *, integer *, complex * , complex *, integer *); extern logical lsame_(char *, char *); static integer ifunc, linfo; extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, complex *, integer *); static integer lwmin; static real scale2; extern /* Subroutine */ int ctgsy2_(char *, integer *, integer *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, real *, real *, real *, integer *); static integer ie, je, mb, nb; static real dscale; static integer is, js, pq; static real scaloc; extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex *, integer *, complex *, integer *), xerbla_(char *, integer *); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); static integer iround; static logical notran; static integer isolve; static logical lquery; #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 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 d___subscr(a_1,a_2) (a_2)*d_dim1 + a_1 #define d___ref(a_1,a_2) d__[d___subscr(a_1,a_2)] #define e_subscr(a_1,a_2) (a_2)*e_dim1 + a_1 #define e_ref(a_1,a_2) e[e_subscr(a_1,a_2)] #define f_subscr(a_1,a_2) (a_2)*f_dim1 + a_1 #define f_ref(a_1,a_2) f[f_subscr(a_1,a_2)] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; c_dim1 = *ldc; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; d_dim1 = *ldd; d_offset = 1 + d_dim1 * 1; d__ -= d_offset; e_dim1 = *lde; e_offset = 1 + e_dim1 * 1; e -= e_offset; f_dim1 = *ldf; f_offset = 1 + f_dim1 * 1; f -= f_offset; --work; --iwork; /* Function Body */ *info = 0; notran = lsame_(trans, "N"); lquery = *lwork == -1; if ((*ijob == 1 || *ijob == 2) && notran) { /* Computing MAX */ i__1 = 1, i__2 = (*m << 1) * *n; lwmin = max(i__1,i__2); } else { lwmin = 1; } if (! notran && ! lsame_(trans, "C")) { *info = -1; } else if (*ijob < 0 || *ijob > 4) { *info = -2; } else if (*m <= 0) { *info = -3; } else if (*n <= 0) { *info = -4; } else if (*lda < max(1,*m)) { *info = -6; } else if (*ldb < max(1,*n)) { *info = -8; } else if (*ldc < max(1,*m)) { *info = -10; } else if (*ldd < max(1,*m)) { *info = -12; } else if (*lde < max(1,*n)) { *info = -14; } else if (*ldf < max(1,*m)) { *info = -16; } else if (*lwork < lwmin && ! lquery) { *info = -20; } if (*info == 0) { work[1].r = (real) lwmin, work[1].i = 0.f; } if (*info != 0) { i__1 = -(*info); xerbla_("CTGSYL", &i__1); return 0; } else if (lquery) { return 0; } /* Determine optimal block sizes MB and NB */ mb = ilaenv_(&c__2, "CTGSYL", trans, m, n, &c_n1, &c_n1, (ftnlen)6, ( ftnlen)1); nb = ilaenv_(&c__5, "CTGSYL", trans, m, n, &c_n1, &c_n1, (ftnlen)6, ( ftnlen)1); isolve = 1; ifunc = 0; if (*ijob >= 3 && notran) { ifunc = *ijob - 2; i__1 = *n; for (j = 1; j <= i__1; ++j) { ccopy_(m, &c_b16, &c__0, &c___ref(1, j), &c__1); ccopy_(m, &c_b16, &c__0, &f_ref(1, j), &c__1); /* L10: */ } } else if (*ijob >= 1 && notran) { isolve = 2; } if (mb <= 1 && nb <= 1 || mb >= *m && nb >= *n) { /* Use unblocked Level 2 solver */ i__1 = isolve; for (iround = 1; iround <= i__1; ++iround) { *scale = 1.f; dscale = 0.f; dsum = 1.f; pq = *m * *n; ctgsy2_(trans, &ifunc, m, n, &a[a_offset], lda, &b[b_offset], ldb, &c__[c_offset], ldc, &d__[d_offset], ldd, &e[e_offset], lde, &f[f_offset], ldf, scale, &dsum, &dscale, info); if (dscale != 0.f) { if (*ijob == 1 || *ijob == 3) { *dif = sqrt((real) ((*m << 1) * *n)) / (dscale * sqrt( dsum)); } else { *dif = sqrt((real) pq) / (dscale * sqrt(dsum)); } } if (isolve == 2 && iround == 1) { ifunc = *ijob; scale2 = *scale; clacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m); clacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m); i__2 = *n; for (j = 1; j <= i__2; ++j) { ccopy_(m, &c_b16, &c__0, &c___ref(1, j), &c__1); ccopy_(m, &c_b16, &c__0, &f_ref(1, j), &c__1); /* L20: */ } } else if (isolve == 2 && iround == 2) { clacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc); clacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf); *scale = scale2; } /* L30: */ } return 0; } /* Determine block structure of A */ p = 0; i__ = 1; L40: if (i__ > *m) { goto L50; } ++p; iwork[p] = i__; i__ += mb; if (i__ >= *m) { goto L50; } goto L40; L50: iwork[p + 1] = *m + 1; if (iwork[p] == iwork[p + 1]) { --p; } /* Determine block structure of B */ q = p + 1; j = 1; L60: if (j > *n) { goto L70; } ++q; iwork[q] = j; j += nb; if (j >= *n) { goto L70; } goto L60; L70: iwork[q + 1] = *n + 1; if (iwork[q] == iwork[q + 1]) { --q; } if (notran) { i__1 = isolve; for (iround = 1; iround <= i__1; ++iround) { /* Solve (I, J) - subsystem A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) for I = P, P - 1, ..., 1; J = 1, 2, ..., Q */ pq = 0; *scale = 1.f; dscale = 0.f; dsum = 1.f; i__2 = q; for (j = p + 2; j <= i__2; ++j) { js = iwork[j]; je = iwork[j + 1] - 1; nb = je - js + 1; for (i__ = p; i__ >= 1; --i__) { is = iwork[i__]; ie = iwork[i__ + 1] - 1; mb = ie - is + 1; ctgsy2_(trans, &ifunc, &mb, &nb, &a_ref(is, is), lda, & b_ref(js, js), ldb, &c___ref(is, js), ldc, & d___ref(is, is), ldd, &e_ref(js, js), lde, &f_ref( is, js), ldf, &scaloc, &dsum, &dscale, &linfo); if (linfo > 0) { *info = linfo; } pq += mb * nb; if (scaloc != 1.f) { i__3 = js - 1; for (k = 1; k <= i__3; ++k) { q__1.r = scaloc, q__1.i = 0.f; cscal_(m, &q__1, &c___ref(1, k), &c__1); q__1.r = scaloc, q__1.i = 0.f; cscal_(m, &q__1, &f_ref(1, k), &c__1); /* L80: */ } i__3 = je; for (k = js; k <= i__3; ++k) { i__4 = is - 1; q__1.r = scaloc, q__1.i = 0.f; cscal_(&i__4, &q__1, &c___ref(1, k), &c__1); i__4 = is - 1; q__1.r = scaloc, q__1.i = 0.f; cscal_(&i__4, &q__1, &f_ref(1, k), &c__1); /* L90: */ } i__3 = je; for (k = js; k <= i__3; ++k) { i__4 = *m - ie; q__1.r = scaloc, q__1.i = 0.f; cscal_(&i__4, &q__1, &c___ref(ie + 1, k), &c__1); i__4 = *m - ie; q__1.r = scaloc, q__1.i = 0.f; cscal_(&i__4, &q__1, &f_ref(ie + 1, k), &c__1); /* L100: */ } i__3 = *n; for (k = je + 1; k <= i__3; ++k) { q__1.r = scaloc, q__1.i = 0.f; cscal_(m, &q__1, &c___ref(1, k), &c__1); q__1.r = scaloc, q__1.i = 0.f; cscal_(m, &q__1, &f_ref(1, k), &c__1); /* L110: */ } *scale *= scaloc; } /* Substitute R(I,J) and L(I,J) into remaining equation. */ if (i__ > 1) { i__3 = is - 1; cgemm_("N", "N", &i__3, &nb, &mb, &c_b53, &a_ref(1, is), lda, &c___ref(is, js), ldc, &c_b54, & c___ref(1, js), ldc); i__3 = is - 1; cgemm_("N", "N", &i__3, &nb, &mb, &c_b53, &d___ref(1, is), ldd, &c___ref(is, js), ldc, &c_b54, & f_ref(1, js), ldf); } if (j < q) { i__3 = *n - je; cgemm_("N", "N", &mb, &i__3, &nb, &c_b54, &f_ref(is, js), ldf, &b_ref(js, je + 1), ldb, &c_b54, & c___ref(is, je + 1), ldc); i__3 = *n - je; cgemm_("N", "N", &mb, &i__3, &nb, &c_b54, &f_ref(is, js), ldf, &e_ref(js, je + 1), lde, &c_b54, & f_ref(is, je + 1), ldf); } /* L120: */ } /* L130: */ } if (dscale != 0.f) { if (*ijob == 1 || *ijob == 3) { *dif = sqrt((real) ((*m << 1) * *n)) / (dscale * sqrt( dsum)); } else { *dif = sqrt((real) pq) / (dscale * sqrt(dsum)); } } if (isolve == 2 && iround == 1) { ifunc = *ijob; scale2 = *scale; clacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m); clacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m); i__2 = *n; for (j = 1; j <= i__2; ++j) { ccopy_(m, &c_b16, &c__0, &c___ref(1, j), &c__1); ccopy_(m, &c_b16, &c__0, &f_ref(1, j), &c__1); /* L140: */ } } else if (isolve == 2 && iround == 2) { clacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc); clacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf); *scale = scale2; } /* L150: */ } } else { /* Solve transposed (I, J)-subsystem A(I, I)' * R(I, J) + D(I, I)' * L(I, J) = C(I, J) R(I, J) * B(J, J) + L(I, J) * E(J, J) = -F(I, J) for I = 1,2,..., P; J = Q, Q-1,..., 1 */ *scale = 1.f; i__1 = p; for (i__ = 1; i__ <= i__1; ++i__) { is = iwork[i__]; ie = iwork[i__ + 1] - 1; mb = ie - is + 1; i__2 = p + 2; for (j = q; j >= i__2; --j) { js = iwork[j]; je = iwork[j + 1] - 1; nb = je - js + 1; ctgsy2_(trans, &ifunc, &mb, &nb, &a_ref(is, is), lda, &b_ref( js, js), ldb, &c___ref(is, js), ldc, &d___ref(is, is), ldd, &e_ref(js, js), lde, &f_ref(is, js), ldf, & scaloc, &dsum, &dscale, &linfo); if (linfo > 0) { *info = linfo; } if (scaloc != 1.f) { i__3 = js - 1; for (k = 1; k <= i__3; ++k) { q__1.r = scaloc, q__1.i = 0.f; cscal_(m, &q__1, &c___ref(1, k), &c__1); q__1.r = scaloc, q__1.i = 0.f; cscal_(m, &q__1, &f_ref(1, k), &c__1); /* L160: */ } i__3 = je; for (k = js; k <= i__3; ++k) { i__4 = is - 1; q__1.r = scaloc, q__1.i = 0.f; cscal_(&i__4, &q__1, &c___ref(1, k), &c__1); i__4 = is - 1; q__1.r = scaloc, q__1.i = 0.f; cscal_(&i__4, &q__1, &f_ref(1, k), &c__1); /* L170: */ } i__3 = je; for (k = js; k <= i__3; ++k) { i__4 = *m - ie; q__1.r = scaloc, q__1.i = 0.f; cscal_(&i__4, &q__1, &c___ref(ie + 1, k), &c__1); i__4 = *m - ie; q__1.r = scaloc, q__1.i = 0.f; cscal_(&i__4, &q__1, &f_ref(ie + 1, k), &c__1); /* L180: */ } i__3 = *n; for (k = je + 1; k <= i__3; ++k) { q__1.r = scaloc, q__1.i = 0.f; cscal_(m, &q__1, &c___ref(1, k), &c__1); q__1.r = scaloc, q__1.i = 0.f; cscal_(m, &q__1, &f_ref(1, k), &c__1); /* L190: */ } *scale *= scaloc; } /* Substitute R(I,J) and L(I,J) into remaining equation. */ if (j > p + 2) { i__3 = js - 1; cgemm_("N", "C", &mb, &i__3, &nb, &c_b54, &c___ref(is, js) , ldc, &b_ref(1, js), ldb, &c_b54, &f_ref(is, 1), ldf); i__3 = js - 1; cgemm_("N", "C", &mb, &i__3, &nb, &c_b54, &f_ref(is, js), ldf, &e_ref(1, js), lde, &c_b54, &f_ref(is, 1), ldf); } if (i__ < p) { i__3 = *m - ie; cgemm_("C", "N", &i__3, &nb, &mb, &c_b53, &a_ref(is, ie + 1), lda, &c___ref(is, js), ldc, &c_b54, &c___ref( ie + 1, js), ldc); i__3 = *m - ie; cgemm_("C", "N", &i__3, &nb, &mb, &c_b53, &d___ref(is, ie + 1), ldd, &f_ref(is, js), ldf, &c_b54, &c___ref( ie + 1, js), ldc); } /* L200: */ } /* L210: */ } } work[1].r = (real) lwmin, work[1].i = 0.f; return 0; /* End of CTGSYL */ } /* ctgsyl_ */
/* Subroutine */ int cget52_(logical *left, integer *n, complex *a, integer * lda, complex *b, integer *ldb, complex *e, integer *lde, complex * alpha, complex *beta, complex *work, real *rwork, real *result) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, e_dim1, e_offset, i__1, i__2, i__3; real r__1, r__2, r__3, r__4, r__5, r__6; complex q__1; /* Builtin functions */ double r_imag(complex *); void r_cnjg(complex *, complex *); /* Local variables */ static integer jvec; static real temp1; static integer j; static complex betai; static real scale, abmax; extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * , complex *, integer *, complex *, integer *, complex *, complex * , integer *); static real anorm, bnorm, enorm; static char trans[1]; static complex acoeff, bcoeff; extern doublereal clange_(char *, integer *, integer *, complex *, integer *, real *); static complex alphai; extern doublereal slamch_(char *); static real alfmax, safmin; static char normab[1]; static real safmax, betmax, enrmer, errnrm, ulp; #define e_subscr(a_1,a_2) (a_2)*e_dim1 + a_1 #define e_ref(a_1,a_2) e[e_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 ======= CGET52 does an eigenvector check for the generalized eigenvalue problem. The basic test for right eigenvectors is: | b(i) A E(i) - a(i) B E(i) | RESULT(1) = max ------------------------------- i n ulp max( |b(i) A|, |a(i) B| ) using the 1-norm. Here, a(i)/b(i) = w is the i-th generalized eigenvalue of A - w B, or, equivalently, b(i)/a(i) = m is the i-th generalized eigenvalue of m A - B. H H _ _ For left eigenvectors, A , B , a, and b are used. CGET52 also tests the normalization of E. Each eigenvector is supposed to be normalized so that the maximum "absolute value" of its elements is 1, where in this case, "absolute value" of a complex value x is |Re(x)| + |Im(x)| ; let us call this maximum "absolute value" norm of a vector v M(v). if a(i)=b(i)=0, then the eigenvector is set to be the jth coordinate vector. The normalization test is: RESULT(2) = max | M(v(i)) - 1 | / ( n ulp ) eigenvectors v(i) Arguments ========= LEFT (input) LOGICAL =.TRUE.: The eigenvectors in the columns of E are assumed to be *left* eigenvectors. =.FALSE.: The eigenvectors in the columns of E are assumed to be *right* eigenvectors. N (input) INTEGER The size of the matrices. If it is zero, CGET52 does nothing. It must be at least zero. A (input) COMPLEX array, dimension (LDA, N) The matrix A. LDA (input) INTEGER The leading dimension of A. It must be at least 1 and at least N. B (input) COMPLEX array, dimension (LDB, N) The matrix B. LDB (input) INTEGER The leading dimension of B. It must be at least 1 and at least N. E (input) COMPLEX array, dimension (LDE, N) The matrix of eigenvectors. It must be O( 1 ). LDE (input) INTEGER The leading dimension of E. It must be at least 1 and at least N. ALPHA (input) COMPLEX array, dimension (N) The values a(i) as described above, which, along with b(i), define the generalized eigenvalues. BETA (input) COMPLEX array, dimension (N) The values b(i) as described above, which, along with a(i), define the generalized eigenvalues. WORK (workspace) COMPLEX array, dimension (N**2) RWORK (workspace) REAL array, dimension (N) RESULT (output) REAL array, dimension (2) The values computed by the test described above. If A E or B E is likely to overflow, then RESULT(1:2) is set to 10 / ulp. ===================================================================== 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; e_dim1 = *lde; e_offset = 1 + e_dim1 * 1; e -= e_offset; --alpha; --beta; --work; --rwork; --result; /* Function Body */ result[1] = 0.f; result[2] = 0.f; if (*n <= 0) { return 0; } safmin = slamch_("Safe minimum"); safmax = 1.f / safmin; ulp = slamch_("Epsilon") * slamch_("Base"); if (*left) { *(unsigned char *)trans = 'C'; *(unsigned char *)normab = 'I'; } else { *(unsigned char *)trans = 'N'; *(unsigned char *)normab = 'O'; } /* Norm of A, B, and E: Computing MAX */ r__1 = clange_(normab, n, n, &a[a_offset], lda, &rwork[1]); anorm = dmax(r__1,safmin); /* Computing MAX */ r__1 = clange_(normab, n, n, &b[b_offset], ldb, &rwork[1]); bnorm = dmax(r__1,safmin); /* Computing MAX */ r__1 = clange_("O", n, n, &e[e_offset], lde, &rwork[1]); enorm = dmax(r__1,ulp); alfmax = safmax / dmax(1.f,bnorm); betmax = safmax / dmax(1.f,anorm); /* Compute error matrix. Column i = ( b(i) A - a(i) B ) E(i) / max( |a(i) B| |b(i) A| ) */ i__1 = *n; for (jvec = 1; jvec <= i__1; ++jvec) { i__2 = jvec; alphai.r = alpha[i__2].r, alphai.i = alpha[i__2].i; i__2 = jvec; betai.r = beta[i__2].r, betai.i = beta[i__2].i; /* Computing MAX */ r__5 = (r__1 = alphai.r, dabs(r__1)) + (r__2 = r_imag(&alphai), dabs( r__2)), r__6 = (r__3 = betai.r, dabs(r__3)) + (r__4 = r_imag(& betai), dabs(r__4)); abmax = dmax(r__5,r__6); if ((r__1 = alphai.r, dabs(r__1)) + (r__2 = r_imag(&alphai), dabs( r__2)) > alfmax || (r__3 = betai.r, dabs(r__3)) + (r__4 = r_imag(&betai), dabs(r__4)) > betmax || abmax < 1.f) { scale = 1.f / dmax(abmax,safmin); q__1.r = scale * alphai.r, q__1.i = scale * alphai.i; alphai.r = q__1.r, alphai.i = q__1.i; q__1.r = scale * betai.r, q__1.i = scale * betai.i; betai.r = q__1.r, betai.i = q__1.i; } /* Computing MAX */ r__5 = ((r__1 = alphai.r, dabs(r__1)) + (r__2 = r_imag(&alphai), dabs( r__2))) * bnorm, r__6 = ((r__3 = betai.r, dabs(r__3)) + (r__4 = r_imag(&betai), dabs(r__4))) * anorm, r__5 = max(r__5,r__6); scale = 1.f / dmax(r__5,safmin); q__1.r = scale * betai.r, q__1.i = scale * betai.i; acoeff.r = q__1.r, acoeff.i = q__1.i; q__1.r = scale * alphai.r, q__1.i = scale * alphai.i; bcoeff.r = q__1.r, bcoeff.i = q__1.i; if (*left) { r_cnjg(&q__1, &acoeff); acoeff.r = q__1.r, acoeff.i = q__1.i; r_cnjg(&q__1, &bcoeff); bcoeff.r = q__1.r, bcoeff.i = q__1.i; } cgemv_(trans, n, n, &acoeff, &a[a_offset], lda, &e_ref(1, jvec), & c__1, &c_b1, &work[*n * (jvec - 1) + 1], &c__1); q__1.r = -bcoeff.r, q__1.i = -bcoeff.i; cgemv_(trans, n, n, &q__1, &b[b_offset], lda, &e_ref(1, jvec), &c__1, &c_b2, &work[*n * (jvec - 1) + 1], &c__1); /* L10: */ } errnrm = clange_("One", n, n, &work[1], n, &rwork[1]) / enorm; /* Compute RESULT(1) */ result[1] = errnrm / ulp; /* Normalization of E: */ enrmer = 0.f; i__1 = *n; for (jvec = 1; jvec <= i__1; ++jvec) { temp1 = 0.f; i__2 = *n; for (j = 1; j <= i__2; ++j) { /* Computing MAX */ i__3 = e_subscr(j, jvec); r__3 = temp1, r__4 = (r__1 = e[i__3].r, dabs(r__1)) + (r__2 = r_imag(&e_ref(j, jvec)), dabs(r__2)); temp1 = dmax(r__3,r__4); /* L20: */ } /* Computing MAX */ r__1 = enrmer, r__2 = temp1 - 1.f; enrmer = dmax(r__1,r__2); /* L30: */ } /* Compute RESULT(2) : the normalization error in E. */ result[2] = enrmer / ((real) (*n) * ulp); return 0; /* End of CGET52 */ } /* cget52_ */
/* Subroutine */ int dlakf2_(integer *m, integer *n, doublereal *a, integer * lda, doublereal *b, doublereal *d__, doublereal *e, doublereal *z__, integer *ldz) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, d_dim1, d_offset, e_dim1, e_offset, z_dim1, z_offset, i__1, i__2, i__3; /* Local variables */ static integer i__, j, l, ik, jk, mn; extern /* Subroutine */ int dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *); static integer mn2; #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 d___ref(a_1,a_2) d__[(a_2)*d_dim1 + a_1] #define e_ref(a_1,a_2) e[(a_2)*e_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 ======= Form the 2*M*N by 2*M*N matrix Z = [ kron(In, A) -kron(B', Im) ] [ kron(In, D) -kron(E', Im) ], where In is the identity matrix of size n and X' is the transpose of X. kron(X, Y) is the Kronecker product between the matrices X and Y. Arguments ========= M (input) INTEGER Size of matrix, must be >= 1. N (input) INTEGER Size of matrix, must be >= 1. A (input) DOUBLE PRECISION, dimension ( LDA, M ) The matrix A in the output matrix Z. LDA (input) INTEGER The leading dimension of A, B, D, and E. ( LDA >= M+N ) B (input) DOUBLE PRECISION, dimension ( LDA, N ) D (input) DOUBLE PRECISION, dimension ( LDA, M ) E (input) DOUBLE PRECISION, dimension ( LDA, N ) The matrices used in forming the output matrix Z. Z (output) DOUBLE PRECISION, dimension ( LDZ, 2*M*N ) The resultant Kronecker M*N*2 by M*N*2 matrix (see above.) LDZ (input) INTEGER The leading dimension of Z. ( LDZ >= 2*M*N ) ==================================================================== Initialize Z Parameter adjustments */ e_dim1 = *lda; e_offset = 1 + e_dim1 * 1; e -= e_offset; d_dim1 = *lda; d_offset = 1 + d_dim1 * 1; d__ -= d_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 = *ldz; z_offset = 1 + z_dim1 * 1; z__ -= z_offset; /* Function Body */ mn = *m * *n; mn2 = mn << 1; dlaset_("Full", &mn2, &mn2, &c_b3, &c_b3, &z__[z_offset], ldz); ik = 1; i__1 = *n; for (l = 1; l <= i__1; ++l) { /* form kron(In, A) */ i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = *m; for (j = 1; j <= i__3; ++j) { z___ref(ik + i__ - 1, ik + j - 1) = a_ref(i__, j); /* L10: */ } /* L20: */ } /* form kron(In, D) */ i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = *m; for (j = 1; j <= i__3; ++j) { z___ref(ik + mn + i__ - 1, ik + j - 1) = d___ref(i__, j); /* L30: */ } /* L40: */ } ik += *m; /* L50: */ } ik = 1; i__1 = *n; for (l = 1; l <= i__1; ++l) { jk = mn + 1; i__2 = *n; for (j = 1; j <= i__2; ++j) { /* form -kron(B', Im) */ i__3 = *m; for (i__ = 1; i__ <= i__3; ++i__) { z___ref(ik + i__ - 1, jk + i__ - 1) = -b_ref(j, l); /* L60: */ } /* form -kron(E', Im) */ i__3 = *m; for (i__ = 1; i__ <= i__3; ++i__) { z___ref(ik + mn + i__ - 1, jk + i__ - 1) = -e_ref(j, l); /* L70: */ } jk += *m; /* L80: */ } ik += *m; /* L90: */ } return 0; /* End of DLAKF2 */ } /* dlakf2_ */
/* Subroutine */ int dchkgk_(integer *nin, integer *nout) { /* Format strings */ static char fmt_9999[] = "(1x,\002.. test output of DGGBAK .. \002)"; static char fmt_9998[] = "(\002 value of largest test error " " =\002,d12.3)"; static char fmt_9997[] = "(\002 example number where DGGBAL info is not " "0 =\002,i4)"; static char fmt_9996[] = "(\002 example number where DGGBAK(L) info is n" "ot 0 =\002,i4)"; static char fmt_9995[] = "(\002 example number where DGGBAK(R) info is n" "ot 0 =\002,i4)"; static char fmt_9994[] = "(\002 example number having largest error " " =\002,i4)"; static char fmt_9993[] = "(\002 number of examples where info is not 0 " " =\002,i4)"; static char fmt_9992[] = "(\002 total number of examples tested " " =\002,i4)"; /* System generated locals */ integer i__1, i__2; doublereal d__1, d__2, d__3; /* Builtin functions */ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), e_rsle(void), s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen); /* Local variables */ static integer info, lmax[4]; static doublereal rmax, vmax, work[2500] /* was [50][50] */, a[2500] /* was [50][50] */, b[2500] /* was [50][50] */, e[2500] /* was [50][50] */, f[2500] /* was [50][50] */; static integer i__, j, m, n; extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *); static integer ninfo; static doublereal anorm, bnorm, af[2500] /* was [50][50] */, bf[2500] /* was [50][50] */; extern /* Subroutine */ int dggbak_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, integer *), dggbal_(char *, integer *, doublereal *, integer *, doublereal *, integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *); extern doublereal dlamch_(char *), dlange_(char *, integer *, integer *, doublereal *, integer *, doublereal *); static doublereal vl[2500] /* was [50][50] */, lscale[50], vr[2500] /* was [50][50] */, rscale[50]; extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *); static integer ihi, ilo; static doublereal eps, vlf[2500] /* was [50][50] */; static integer knt; static doublereal vrf[2500] /* was [50][50] */; /* Fortran I/O blocks */ static cilist io___6 = { 0, 0, 0, 0, 0 }; static cilist io___10 = { 0, 0, 0, 0, 0 }; static cilist io___13 = { 0, 0, 0, 0, 0 }; static cilist io___15 = { 0, 0, 0, 0, 0 }; static cilist io___17 = { 0, 0, 0, 0, 0 }; static cilist io___34 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___35 = { 0, 0, 0, fmt_9998, 0 }; static cilist io___36 = { 0, 0, 0, fmt_9997, 0 }; static cilist io___37 = { 0, 0, 0, fmt_9996, 0 }; static cilist io___38 = { 0, 0, 0, fmt_9995, 0 }; static cilist io___39 = { 0, 0, 0, fmt_9994, 0 }; static cilist io___40 = { 0, 0, 0, fmt_9993, 0 }; static cilist io___41 = { 0, 0, 0, fmt_9992, 0 }; #define a_ref(a_1,a_2) a[(a_2)*50 + a_1 - 51] #define b_ref(a_1,a_2) b[(a_2)*50 + a_1 - 51] #define e_ref(a_1,a_2) e[(a_2)*50 + a_1 - 51] #define f_ref(a_1,a_2) f[(a_2)*50 + a_1 - 51] #define vl_ref(a_1,a_2) vl[(a_2)*50 + a_1 - 51] #define vr_ref(a_1,a_2) vr[(a_2)*50 + a_1 - 51] /* -- 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 ======= DCHKGK tests DGGBAK, a routine for backward balancing of a matrix pair (A, B). Arguments ========= NIN (input) INTEGER The logical unit number for input. NIN > 0. NOUT (input) INTEGER The logical unit number for output. NOUT > 0. ===================================================================== Initialization */ lmax[0] = 0; lmax[1] = 0; lmax[2] = 0; lmax[3] = 0; ninfo = 0; knt = 0; rmax = 0.; eps = dlamch_("Precision"); L10: io___6.ciunit = *nin; s_rsle(&io___6); do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer)); do_lio(&c__3, &c__1, (char *)&m, (ftnlen)sizeof(integer)); e_rsle(); if (n == 0) { goto L100; } i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { io___10.ciunit = *nin; s_rsle(&io___10); i__2 = n; for (j = 1; j <= i__2; ++j) { do_lio(&c__5, &c__1, (char *)&a_ref(i__, j), (ftnlen)sizeof( doublereal)); } e_rsle(); /* L20: */ } i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { io___13.ciunit = *nin; s_rsle(&io___13); i__2 = n; for (j = 1; j <= i__2; ++j) { do_lio(&c__5, &c__1, (char *)&b_ref(i__, j), (ftnlen)sizeof( doublereal)); } e_rsle(); /* L30: */ } i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { io___15.ciunit = *nin; s_rsle(&io___15); i__2 = m; for (j = 1; j <= i__2; ++j) { do_lio(&c__5, &c__1, (char *)&vl_ref(i__, j), (ftnlen)sizeof( doublereal)); } e_rsle(); /* L40: */ } i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { io___17.ciunit = *nin; s_rsle(&io___17); i__2 = m; for (j = 1; j <= i__2; ++j) { do_lio(&c__5, &c__1, (char *)&vr_ref(i__, j), (ftnlen)sizeof( doublereal)); } e_rsle(); /* L50: */ } ++knt; anorm = dlange_("M", &n, &n, a, &c__50, work); bnorm = dlange_("M", &n, &n, b, &c__50, work); dlacpy_("FULL", &n, &n, a, &c__50, af, &c__50); dlacpy_("FULL", &n, &n, b, &c__50, bf, &c__50); dggbal_("B", &n, a, &c__50, b, &c__50, &ilo, &ihi, lscale, rscale, work, & info); if (info != 0) { ++ninfo; lmax[0] = knt; } dlacpy_("FULL", &n, &m, vl, &c__50, vlf, &c__50); dlacpy_("FULL", &n, &m, vr, &c__50, vrf, &c__50); dggbak_("B", "L", &n, &ilo, &ihi, lscale, rscale, &m, vl, &c__50, &info); if (info != 0) { ++ninfo; lmax[1] = knt; } dggbak_("B", "R", &n, &ilo, &ihi, lscale, rscale, &m, vr, &c__50, &info); if (info != 0) { ++ninfo; lmax[2] = knt; } /* Test of DGGBAK Check tilde(VL)'*A*tilde(VR) - VL'*tilde(A)*VR where tilde(A) denotes the transformed matrix. */ dgemm_("N", "N", &n, &m, &n, &c_b52, af, &c__50, vr, &c__50, &c_b55, work, &c__50); dgemm_("T", "N", &m, &m, &n, &c_b52, vl, &c__50, work, &c__50, &c_b55, e, &c__50); dgemm_("N", "N", &n, &m, &n, &c_b52, a, &c__50, vrf, &c__50, &c_b55, work, &c__50); dgemm_("T", "N", &m, &m, &n, &c_b52, vlf, &c__50, work, &c__50, &c_b55, f, &c__50); vmax = 0.; i__1 = m; for (j = 1; j <= i__1; ++j) { i__2 = m; for (i__ = 1; i__ <= i__2; ++i__) { /* Computing MAX */ d__2 = vmax, d__3 = (d__1 = e_ref(i__, j) - f_ref(i__, j), abs( d__1)); vmax = max(d__2,d__3); /* L60: */ } /* L70: */ } vmax /= eps * max(anorm,bnorm); if (vmax > rmax) { lmax[3] = knt; rmax = vmax; } /* Check tilde(VL)'*B*tilde(VR) - VL'*tilde(B)*VR */ dgemm_("N", "N", &n, &m, &n, &c_b52, bf, &c__50, vr, &c__50, &c_b55, work, &c__50); dgemm_("T", "N", &m, &m, &n, &c_b52, vl, &c__50, work, &c__50, &c_b55, e, &c__50); dgemm_("N", "N", &n, &m, &n, &c_b52, b, &c__50, vrf, &c__50, &c_b55, work, &c__50); dgemm_("T", "N", &m, &m, &n, &c_b52, vlf, &c__50, work, &c__50, &c_b55, f, &c__50); vmax = 0.; i__1 = m; for (j = 1; j <= i__1; ++j) { i__2 = m; for (i__ = 1; i__ <= i__2; ++i__) { /* Computing MAX */ d__2 = vmax, d__3 = (d__1 = e_ref(i__, j) - f_ref(i__, j), abs( d__1)); vmax = max(d__2,d__3); /* L80: */ } /* L90: */ } vmax /= eps * max(anorm,bnorm); if (vmax > rmax) { lmax[3] = knt; rmax = vmax; } goto L10; L100: io___34.ciunit = *nout; s_wsfe(&io___34); e_wsfe(); io___35.ciunit = *nout; s_wsfe(&io___35); do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal)); e_wsfe(); io___36.ciunit = *nout; s_wsfe(&io___36); do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer)); e_wsfe(); io___37.ciunit = *nout; s_wsfe(&io___37); do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer)); e_wsfe(); io___38.ciunit = *nout; s_wsfe(&io___38); do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer)); e_wsfe(); io___39.ciunit = *nout; s_wsfe(&io___39); do_fio(&c__1, (char *)&lmax[3], (ftnlen)sizeof(integer)); e_wsfe(); io___40.ciunit = *nout; s_wsfe(&io___40); do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer)); e_wsfe(); io___41.ciunit = *nout; s_wsfe(&io___41); do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer)); e_wsfe(); return 0; /* End of DCHKGK */ } /* dchkgk_ */