/* Subroutine */ int zchkgl_(integer *nin, integer *nout) { /* Format strings */ static char fmt_9999[] = "(\002 .. test output of ZGGBAL .. \002)"; static char fmt_9998[] = "(\002 ratio of largest test error " " = \002,d12.3)"; static char fmt_9997[] = "(\002 example number where info is not zero " " = \002,i4)"; static char fmt_9996[] = "(\002 example number where ILO or IHI is wrong" " = \002,i4)"; static char fmt_9995[] = "(\002 example number having largest error " " = \002,i4)"; static char fmt_9994[] = "(\002 number of examples where info is not 0 " " = \002,i4)"; static char fmt_9993[] = "(\002 total 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; doublecomplex z__1; /* Builtin functions */ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), e_rsle(void); double z_abs(doublecomplex *); integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen); /* Local variables */ static integer info, lmax[3]; static doublereal rmax, vmax, work[120]; static doublecomplex a[400] /* was [20][20] */, b[400] /* was [20][ 20] */; static integer i__, j, n, ihiin, ninfo, iloin; static doublereal anorm, bnorm; extern doublereal dlamch_(char *); static doublereal lscale[20]; extern /* Subroutine */ int zggbal_(char *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *); static doublereal rscale[20]; extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, integer *, doublereal *); static doublereal lsclin[20], rsclin[20]; static doublecomplex ain[400] /* was [20][20] */, bin[400] /* was [20][20] */; static integer ihi, ilo; static doublereal eps; static integer knt; /* Fortran I/O blocks */ static cilist io___6 = { 0, 0, 0, 0, 0 }; static cilist io___9 = { 0, 0, 0, 0, 0 }; static cilist io___12 = { 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___19 = { 0, 0, 0, 0, 0 }; static cilist io___21 = { 0, 0, 0, 0, 0 }; static cilist io___23 = { 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 }; #define a_subscr(a_1,a_2) (a_2)*20 + a_1 - 21 #define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)] #define b_subscr(a_1,a_2) (a_2)*20 + a_1 - 21 #define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)] #define ain_subscr(a_1,a_2) (a_2)*20 + a_1 - 21 #define ain_ref(a_1,a_2) ain[ain_subscr(a_1,a_2)] #define bin_subscr(a_1,a_2) (a_2)*20 + a_1 - 21 #define bin_ref(a_1,a_2) bin[bin_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 ======= ZCHKGL tests ZGGBAL, a routine for balancing 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. ===================================================================== */ lmax[0] = 0; lmax[1] = 0; lmax[2] = 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)); e_rsle(); if (n == 0) { goto L90; } i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { io___9.ciunit = *nin; s_rsle(&io___9); i__2 = n; for (j = 1; j <= i__2; ++j) { do_lio(&c__7, &c__1, (char *)&a_ref(i__, j), (ftnlen)sizeof( doublecomplex)); } e_rsle(); /* L20: */ } i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { io___12.ciunit = *nin; s_rsle(&io___12); i__2 = n; for (j = 1; j <= i__2; ++j) { do_lio(&c__7, &c__1, (char *)&b_ref(i__, j), (ftnlen)sizeof( doublecomplex)); } e_rsle(); /* L30: */ } io___14.ciunit = *nin; s_rsle(&io___14); do_lio(&c__3, &c__1, (char *)&iloin, (ftnlen)sizeof(integer)); do_lio(&c__3, &c__1, (char *)&ihiin, (ftnlen)sizeof(integer)); e_rsle(); 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 *)&ain_ref(i__, j), (ftnlen)sizeof( doublecomplex)); } e_rsle(); /* L40: */ } i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { io___19.ciunit = *nin; s_rsle(&io___19); i__2 = n; for (j = 1; j <= i__2; ++j) { do_lio(&c__7, &c__1, (char *)&bin_ref(i__, j), (ftnlen)sizeof( doublecomplex)); } e_rsle(); /* L50: */ } io___21.ciunit = *nin; s_rsle(&io___21); i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { do_lio(&c__5, &c__1, (char *)&lsclin[i__ - 1], (ftnlen)sizeof( doublereal)); } e_rsle(); io___23.ciunit = *nin; s_rsle(&io___23); i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { do_lio(&c__5, &c__1, (char *)&rsclin[i__ - 1], (ftnlen)sizeof( doublereal)); } e_rsle(); anorm = zlange_("M", &n, &n, a, &c__20, work); bnorm = zlange_("M", &n, &n, b, &c__20, work); ++knt; zggbal_("B", &n, a, &c__20, b, &c__20, &ilo, &ihi, lscale, rscale, work, & info); if (info != 0) { ++ninfo; lmax[0] = knt; } if (ilo != iloin || ihi != ihiin) { ++ninfo; lmax[1] = knt; } vmax = 0.; i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = n; for (j = 1; j <= i__2; ++j) { /* Computing MAX */ i__3 = a_subscr(i__, j); i__4 = ain_subscr(i__, j); z__1.r = a[i__3].r - ain[i__4].r, z__1.i = a[i__3].i - ain[i__4] .i; d__1 = vmax, d__2 = z_abs(&z__1); vmax = max(d__1,d__2); /* Computing MAX */ i__3 = b_subscr(i__, j); i__4 = bin_subscr(i__, j); z__1.r = b[i__3].r - bin[i__4].r, z__1.i = b[i__3].i - bin[i__4] .i; d__1 = vmax, d__2 = z_abs(&z__1); vmax = max(d__1,d__2); /* L60: */ } /* L70: */ } i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { /* Computing MAX */ d__2 = vmax, d__3 = (d__1 = lscale[i__ - 1] - lsclin[i__ - 1], abs( d__1)); vmax = max(d__2,d__3); /* Computing MAX */ d__2 = vmax, d__3 = (d__1 = rscale[i__ - 1] - rsclin[i__ - 1], abs( d__1)); vmax = max(d__2,d__3); /* L80: */ } vmax /= eps * max(anorm,bnorm); if (vmax > rmax) { lmax[2] = knt; rmax = vmax; } goto L10; L90: 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 *)&ninfo, (ftnlen)sizeof(integer)); e_wsfe(); io___40.ciunit = *nout; s_wsfe(&io___40); do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer)); e_wsfe(); return 0; /* End of ZCHKGL */ } /* zchkgl_ */
/* Subroutine */ int zgerfs_(char *trans, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *rwork, 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 ======= ZGERFS improves the computed solution to a system of linear equations and provides error bounds and backward error estimates for the solution. Arguments ========= TRANS (input) CHARACTER*1 Specifies the form of the system of equations: = 'N': A * X = B (No transpose) = 'T': A**T * X = B (Transpose) = 'C': A**H * X = B (Conjugate transpose) N (input) INTEGER The order of the matrix A. N >= 0. NRHS (input) INTEGER The number of right hand sides, i.e., the number of columns of the matrices B and X. NRHS >= 0. A (input) COMPLEX*16 array, dimension (LDA,N) The original N-by-N matrix A. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,N). AF (input) COMPLEX*16 array, dimension (LDAF,N) The factors L and U from the factorization A = P*L*U as computed by ZGETRF. LDAF (input) INTEGER The leading dimension of the array AF. LDAF >= max(1,N). IPIV (input) INTEGER array, dimension (N) The pivot indices from ZGETRF; for 1<=i<=N, row i of the matrix was interchanged with row IPIV(i). B (input) COMPLEX*16 array, dimension (LDB,NRHS) The right hand side matrix B. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,N). X (input/output) COMPLEX*16 array, dimension (LDX,NRHS) On entry, the solution matrix X, as computed by ZGETRS. On exit, the improved solution matrix X. LDX (input) INTEGER The leading dimension of the array X. LDX >= max(1,N). FERR (output) DOUBLE PRECISION array, dimension (NRHS) The estimated forward error bound for each solution vector X(j) (the j-th column of the solution matrix X). If XTRUE is the true solution corresponding to X(j), FERR(j) is an estimated upper bound for the magnitude of the largest element in (X(j) - XTRUE) divided by the magnitude of the largest element in X(j). The estimate is as reliable as the estimate for RCOND, and is almost always a slight overestimate of the true error. BERR (output) DOUBLE PRECISION array, dimension (NRHS) The componentwise relative backward error of each solution vector X(j) (i.e., the smallest relative change in any element of A or B that makes X(j) an exact solution). WORK (workspace) COMPLEX*16 array, dimension (2*N) 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 Internal Parameters =================== ITMAX is the maximum number of steps of iterative refinement. ===================================================================== Test the input parameters. Parameter adjustments */ /* Table of constant values */ static doublecomplex c_b1 = {1.,0.}; static integer c__1 = 1; /* System generated locals */ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5; doublereal d__1, d__2, d__3, d__4; doublecomplex z__1; /* Builtin functions */ double d_imag(doublecomplex *); /* Local variables */ static integer kase; static doublereal safe1, safe2; static integer i__, j, k; static doublereal s; extern logical lsame_(char *, char *); static integer count; extern /* Subroutine */ int zgemv_(char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *); extern doublereal dlamch_(char *); static doublereal xk; static integer nz; static doublereal safmin; extern /* Subroutine */ int xerbla_(char *, integer *), zlacon_( integer *, doublecomplex *, doublecomplex *, doublereal *, integer *); static logical notran; static char transn[1], transt[1]; static doublereal lstres; extern /* Subroutine */ int zgetrs_(char *, integer *, integer *, doublecomplex *, integer *, integer *, 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 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 x_subscr(a_1,a_2) (a_2)*x_dim1 + a_1 #define x_ref(a_1,a_2) x[x_subscr(a_1,a_2)] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; af_dim1 = *ldaf; af_offset = 1 + af_dim1 * 1; af -= af_offset; --ipiv; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; x_dim1 = *ldx; x_offset = 1 + x_dim1 * 1; x -= x_offset; --ferr; --berr; --work; --rwork; /* Function Body */ *info = 0; notran = lsame_(trans, "N"); if (! notran && ! lsame_(trans, "T") && ! lsame_( trans, "C")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*nrhs < 0) { *info = -3; } else if (*lda < max(1,*n)) { *info = -5; } else if (*ldaf < max(1,*n)) { *info = -7; } else if (*ldb < max(1,*n)) { *info = -10; } else if (*ldx < max(1,*n)) { *info = -12; } if (*info != 0) { i__1 = -(*info); xerbla_("ZGERFS", &i__1); return 0; } /* Quick return if possible */ if (*n == 0 || *nrhs == 0) { i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { ferr[j] = 0.; berr[j] = 0.; /* L10: */ } return 0; } if (notran) { *(unsigned char *)transn = 'N'; *(unsigned char *)transt = 'C'; } else { *(unsigned char *)transn = 'C'; *(unsigned char *)transt = 'N'; } /* NZ = maximum number of nonzero elements in each row of A, plus 1 */ nz = *n + 1; eps = dlamch_("Epsilon"); safmin = dlamch_("Safe minimum"); safe1 = nz * safmin; safe2 = safe1 / eps; /* Do for each right hand side */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { count = 1; lstres = 3.; L20: /* Loop until stopping criterion is satisfied. Compute residual R = B - op(A) * X, where op(A) = A, A**T, or A**H, depending on TRANS. */ zcopy_(n, &b_ref(1, j), &c__1, &work[1], &c__1); z__1.r = -1., z__1.i = 0.; zgemv_(trans, n, n, &z__1, &a[a_offset], lda, &x_ref(1, j), &c__1, & c_b1, &work[1], &c__1); /* Compute componentwise relative backward error from formula max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) where abs(Z) is the componentwise absolute value of the matrix or vector Z. If the i-th component of the denominator is less than SAFE2, then SAFE1 is added to the i-th components of the numerator and denominator before dividing. */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(& b_ref(i__, j)), abs(d__2)); /* L30: */ } /* Compute abs(op(A))*abs(X) + abs(B). */ if (notran) { i__2 = *n; for (k = 1; k <= i__2; ++k) { i__3 = x_subscr(k, j); xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x_ref(k, j)), abs(d__2)); i__3 = *n; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = a_subscr(i__, k); rwork[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a_ref(i__, k)), abs(d__2))) * xk; /* L40: */ } /* L50: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { s = 0.; i__3 = *n; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = a_subscr(i__, k); i__5 = x_subscr(i__, j); s += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(& a_ref(i__, k)), abs(d__2))) * ((d__3 = x[i__5].r, abs(d__3)) + (d__4 = d_imag(&x_ref(i__, j)), abs( d__4))); /* L60: */ } rwork[k] += s; /* L70: */ } } s = 0.; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { if (rwork[i__] > safe2) { /* Computing MAX */ i__3 = i__; d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 = d_imag(&work[i__]), abs(d__2))) / rwork[i__]; s = max(d__3,d__4); } else { /* Computing MAX */ i__3 = i__; d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 = d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__] + safe1); s = max(d__3,d__4); } /* L80: */ } berr[j] = s; /* Test stopping criterion. Continue iterating if 1) The residual BERR(J) is larger than machine epsilon, and 2) BERR(J) decreased by at least a factor of 2 during the last iteration, and 3) At most ITMAX iterations tried. */ if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) { /* Update solution and try again. */ zgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[1], n, info); zaxpy_(n, &c_b1, &work[1], &c__1, &x_ref(1, j), &c__1); lstres = berr[j]; ++count; goto L20; } /* Bound error from formula norm(X - XTRUE) / norm(X) .le. FERR = norm( abs(inv(op(A)))* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) where norm(Z) is the magnitude of the largest component of Z inv(op(A)) is the inverse of op(A) abs(Z) is the componentwise absolute value of the matrix or vector Z NZ is the maximum number of nonzeros in any row of A, plus 1 EPS is machine epsilon The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) is incremented by SAFE1 if the i-th component of abs(op(A))*abs(X) + abs(B) is less than SAFE2. Use ZLACON to estimate the infinity-norm of the matrix inv(op(A)) * diag(W), where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { if (rwork[i__] > safe2) { i__3 = i__; rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 = d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__] ; } else { i__3 = i__; rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 = d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__] + safe1; } /* L90: */ } kase = 0; L100: zlacon_(n, &work[*n + 1], &work[1], &ferr[j], &kase); if (kase != 0) { if (kase == 1) { /* Multiply by diag(W)*inv(op(A)**H). */ zgetrs_(transt, n, &c__1, &af[af_offset], ldaf, &ipiv[1], & work[1], n, info); i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__; i__4 = i__; i__5 = i__; z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4] * work[i__5].i; work[i__3].r = z__1.r, work[i__3].i = z__1.i; /* L110: */ } } else { /* Multiply by inv(op(A))*diag(W). */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__; i__4 = i__; i__5 = i__; z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4] * work[i__5].i; work[i__3].r = z__1.r, work[i__3].i = z__1.i; /* L120: */ } zgetrs_(transn, n, &c__1, &af[af_offset], ldaf, &ipiv[1], & work[1], n, info); } goto L100; } /* Normalize error. */ lstres = 0.; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { /* Computing MAX */ i__3 = x_subscr(i__, j); d__3 = lstres, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x_ref(i__, j)), abs(d__2)); lstres = max(d__3,d__4); /* L130: */ } if (lstres != 0.) { ferr[j] /= lstres; } /* L140: */ } return 0; /* End of ZGERFS */ } /* zgerfs_ */
/* Subroutine */ int csprfs_(char *uplo, integer *n, integer *nrhs, complex * ap, complex *afp, integer *ipiv, complex *b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork, 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 ======= CSPRFS improves the computed solution to a system of linear equations when the coefficient matrix is symmetric indefinite and packed, and provides error bounds and backward error estimates for the solution. Arguments ========= UPLO (input) CHARACTER*1 = 'U': Upper triangle of A is stored; = 'L': Lower triangle of A is stored. N (input) INTEGER The order of the matrix A. N >= 0. NRHS (input) INTEGER The number of right hand sides, i.e., the number of columns of the matrices B and X. NRHS >= 0. AP (input) COMPLEX array, dimension (N*(N+1)/2) The upper or lower triangle of the symmetric matrix A, packed columnwise in a linear array. The j-th column of A is stored in the array AP as follows: if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. AFP (input) COMPLEX array, dimension (N*(N+1)/2) The factored form of the matrix A. AFP contains the block diagonal matrix D and the multipliers used to obtain the factor U or L from the factorization A = U*D*U**T or A = L*D*L**T as computed by CSPTRF, stored as a packed triangular matrix. IPIV (input) INTEGER array, dimension (N) Details of the interchanges and the block structure of D as determined by CSPTRF. B (input) COMPLEX array, dimension (LDB,NRHS) The right hand side matrix B. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,N). X (input/output) COMPLEX array, dimension (LDX,NRHS) On entry, the solution matrix X, as computed by CSPTRS. On exit, the improved solution matrix X. LDX (input) INTEGER The leading dimension of the array X. LDX >= max(1,N). FERR (output) REAL array, dimension (NRHS) The estimated forward error bound for each solution vector X(j) (the j-th column of the solution matrix X). If XTRUE is the true solution corresponding to X(j), FERR(j) is an estimated upper bound for the magnitude of the largest element in (X(j) - XTRUE) divided by the magnitude of the largest element in X(j). The estimate is as reliable as the estimate for RCOND, and is almost always a slight overestimate of the true error. BERR (output) REAL array, dimension (NRHS) The componentwise relative backward error of each solution vector X(j) (i.e., the smallest relative change in any element of A or B that makes X(j) an exact solution). WORK (workspace) COMPLEX array, dimension (2*N) RWORK (workspace) REAL array, dimension (N) INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value Internal Parameters =================== ITMAX is the maximum number of steps of iterative refinement. ===================================================================== Test the input parameters. Parameter adjustments */ /* Table of constant values */ static complex c_b1 = {1.f,0.f}; static integer c__1 = 1; /* System generated locals */ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5; real r__1, r__2, r__3, r__4; complex q__1; /* Builtin functions */ double r_imag(complex *); /* Local variables */ static integer kase; static real safe1, safe2; static integer i__, j, k; static real s; extern logical lsame_(char *, char *); extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer *, complex *, integer *); static integer count; extern /* Subroutine */ int cspmv_(char *, integer *, complex *, complex * , complex *, integer *, complex *, complex *, integer *); static logical upper; static integer ik, kk; extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real *, integer *); static real xk; extern doublereal slamch_(char *); static integer nz; static real safmin; extern /* Subroutine */ int xerbla_(char *, integer *); static real lstres; extern /* Subroutine */ int csptrs_(char *, integer *, integer *, complex *, integer *, complex *, integer *, integer *); static real eps; #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 x_subscr(a_1,a_2) (a_2)*x_dim1 + a_1 #define x_ref(a_1,a_2) x[x_subscr(a_1,a_2)] --ap; --afp; --ipiv; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; x_dim1 = *ldx; x_offset = 1 + x_dim1 * 1; x -= x_offset; --ferr; --berr; --work; --rwork; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*nrhs < 0) { *info = -3; } else if (*ldb < max(1,*n)) { *info = -8; } else if (*ldx < max(1,*n)) { *info = -10; } if (*info != 0) { i__1 = -(*info); xerbla_("CSPRFS", &i__1); return 0; } /* Quick return if possible */ if (*n == 0 || *nrhs == 0) { i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { ferr[j] = 0.f; berr[j] = 0.f; /* L10: */ } return 0; } /* NZ = maximum number of nonzero elements in each row of A, plus 1 */ nz = *n + 1; eps = slamch_("Epsilon"); safmin = slamch_("Safe minimum"); safe1 = nz * safmin; safe2 = safe1 / eps; /* Do for each right hand side */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { count = 1; lstres = 3.f; L20: /* Loop until stopping criterion is satisfied. Compute residual R = B - A * X */ ccopy_(n, &b_ref(1, j), &c__1, &work[1], &c__1); q__1.r = -1.f, q__1.i = 0.f; cspmv_(uplo, n, &q__1, &ap[1], &x_ref(1, j), &c__1, &c_b1, &work[1], & c__1); /* Compute componentwise relative backward error from formula max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) where abs(Z) is the componentwise absolute value of the matrix or vector Z. If the i-th component of the denominator is less than SAFE2, then SAFE1 is added to the i-th components of the numerator and denominator before dividing. */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(& b_ref(i__, j)), dabs(r__2)); /* L30: */ } /* Compute abs(A)*abs(X) + abs(B). */ kk = 1; if (upper) { i__2 = *n; for (k = 1; k <= i__2; ++k) { s = 0.f; i__3 = x_subscr(k, j); xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x_ref(k, j)), dabs(r__2)); ik = kk; i__3 = k - 1; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = ik; rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&ap[ik]), dabs(r__2))) * xk; i__4 = ik; i__5 = x_subscr(i__, j); s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(& ap[ik]), dabs(r__2))) * ((r__3 = x[i__5].r, dabs( r__3)) + (r__4 = r_imag(&x_ref(i__, j)), dabs( r__4))); ++ik; /* L40: */ } i__3 = kk + k - 1; rwork[k] = rwork[k] + ((r__1 = ap[i__3].r, dabs(r__1)) + ( r__2 = r_imag(&ap[kk + k - 1]), dabs(r__2))) * xk + s; kk += k; /* L50: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { s = 0.f; i__3 = x_subscr(k, j); xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x_ref(k, j)), dabs(r__2)); i__3 = kk; rwork[k] += ((r__1 = ap[i__3].r, dabs(r__1)) + (r__2 = r_imag( &ap[kk]), dabs(r__2))) * xk; ik = kk + 1; i__3 = *n; for (i__ = k + 1; i__ <= i__3; ++i__) { i__4 = ik; rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&ap[ik]), dabs(r__2))) * xk; i__4 = ik; i__5 = x_subscr(i__, j); s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(& ap[ik]), dabs(r__2))) * ((r__3 = x[i__5].r, dabs( r__3)) + (r__4 = r_imag(&x_ref(i__, j)), dabs( r__4))); ++ik; /* L60: */ } rwork[k] += s; kk += *n - k + 1; /* L70: */ } } s = 0.f; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { if (rwork[i__] > safe2) { /* Computing MAX */ i__3 = i__; r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 = r_imag(&work[i__]), dabs(r__2))) / rwork[i__]; s = dmax(r__3,r__4); } else { /* Computing MAX */ i__3 = i__; r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 = r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__] + safe1); s = dmax(r__3,r__4); } /* L80: */ } berr[j] = s; /* Test stopping criterion. Continue iterating if 1) The residual BERR(J) is larger than machine epsilon, and 2) BERR(J) decreased by at least a factor of 2 during the last iteration, and 3) At most ITMAX iterations tried. */ if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) { /* Update solution and try again. */ csptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info); caxpy_(n, &c_b1, &work[1], &c__1, &x_ref(1, j), &c__1); lstres = berr[j]; ++count; goto L20; } /* Bound error from formula norm(X - XTRUE) / norm(X) .le. FERR = norm( abs(inv(A))* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) where norm(Z) is the magnitude of the largest component of Z inv(A) is the inverse of A abs(Z) is the componentwise absolute value of the matrix or vector Z NZ is the maximum number of nonzeros in any row of A, plus 1 EPS is machine epsilon The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) is incremented by SAFE1 if the i-th component of abs(A)*abs(X) + abs(B) is less than SAFE2. Use CLACON to estimate the infinity-norm of the matrix inv(A) * diag(W), where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { if (rwork[i__] > safe2) { i__3 = i__; rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 = r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[ i__]; } else { i__3 = i__; rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 = r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[ i__] + safe1; } /* L90: */ } kase = 0; L100: clacon_(n, &work[*n + 1], &work[1], &ferr[j], &kase); if (kase != 0) { if (kase == 1) { /* Multiply by diag(W)*inv(A'). */ csptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info); i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__; i__4 = i__; i__5 = i__; q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4] * work[i__5].i; work[i__3].r = q__1.r, work[i__3].i = q__1.i; /* L110: */ } } else if (kase == 2) { /* Multiply by inv(A)*diag(W). */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__; i__4 = i__; i__5 = i__; q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4] * work[i__5].i; work[i__3].r = q__1.r, work[i__3].i = q__1.i; /* L120: */ } csptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info); } goto L100; } /* Normalize error. */ lstres = 0.f; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { /* Computing MAX */ i__3 = x_subscr(i__, j); r__3 = lstres, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x_ref(i__, j)), dabs(r__2)); lstres = dmax(r__3,r__4); /* L130: */ } if (lstres != 0.f) { ferr[j] /= lstres; } /* L140: */ } return 0; /* End of CSPRFS */ } /* csprfs_ */
/* Subroutine */ int zggsvp_(char *jobu, char *jobv, char *jobq, integer *m, integer *p, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublereal *tola, doublereal *tolb, integer *k, integer *l, doublecomplex *u, integer *ldu, doublecomplex *v, integer *ldv, doublecomplex *q, integer *ldq, integer *iwork, doublereal * rwork, doublecomplex *tau, doublecomplex *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 ======= ZGGSVP computes unitary matrices U, V and Q such that N-K-L K L U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0; L ( 0 0 A23 ) M-K-L ( 0 0 0 ) N-K-L K L = K ( 0 A12 A13 ) if M-K-L < 0; M-K ( 0 0 A23 ) N-K-L K L V'*B*Q = 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. K+L = the effective numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the conjugate transpose of Z. This decomposition is the preprocessing step for computing the Generalized Singular Value Decomposition (GSVD), see subroutine ZGGSVD. Arguments ========= JOBU (input) CHARACTER*1 = 'U': Unitary matrix U is computed; = 'N': U is not computed. JOBV (input) CHARACTER*1 = 'V': Unitary matrix V is computed; = 'N': V is not computed. JOBQ (input) CHARACTER*1 = 'Q': Unitary matrix Q is computed; = '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. A (input/output) COMPLEX*16 array, dimension (LDA,N) On entry, the M-by-N matrix A. On exit, A contains the triangular (or trapezoidal) matrix described in the Purpose section. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,M). B (input/output) COMPLEX*16 array, dimension (LDB,N) On entry, the P-by-N matrix B. On exit, B contains the triangular matrix described in the Purpose section. 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 thresholds to determine the effective numerical rank of matrix B and a subblock of A. Generally, they are set to TOLA = MAX(M,N)*norm(A)*MAZHEPS, TOLB = MAX(P,N)*norm(B)*MAZHEPS. The size of TOLA and TOLB may affect the size of backward errors of the decomposition. K (output) INTEGER L (output) INTEGER On exit, K and L specify the dimension of the subblocks described in Purpose section. K + L = effective numerical rank of (A',B')'. U (output) COMPLEX*16 array, dimension (LDU,M) If JOBU = 'U', U contains the unitary matrix 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 (output) COMPLEX*16 array, dimension (LDV,M) If JOBV = 'V', V contains the unitary matrix 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 (output) COMPLEX*16 array, dimension (LDQ,N) If JOBQ = 'Q', Q contains the unitary matrix 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. IWORK (workspace) INTEGER array, dimension (N) RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) TAU (workspace) COMPLEX*16 array, dimension (N) WORK (workspace) COMPLEX*16 array, dimension (max(3*N,M,P)) INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value. Further Details =============== The subroutine uses LAPACK subroutine ZGEQPF for the QR factorization with column pivoting to detect the effective numerical rank of the a matrix. It may be replaced by a better rank determination strategy. ===================================================================== Test the input parameters Parameter adjustments */ /* Table of constant values */ static doublecomplex c_b1 = {0.,0.}; static doublecomplex c_b2 = {1.,0.}; /* 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; doublereal d__1, d__2; /* Builtin functions */ double d_imag(doublecomplex *); /* Local variables */ static integer i__, j; extern logical lsame_(char *, char *); static logical wantq, wantu, wantv; extern /* Subroutine */ int zgeqr2_(integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zgerq2_( integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zung2r_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zunm2r_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), zunmr2_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), xerbla_( char *, integer *), zgeqpf_(integer *, integer *, doublecomplex *, integer *, integer *, doublecomplex *, doublecomplex *, doublereal *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); static logical forwrd; extern /* Subroutine */ int zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlapmt_(logical *, integer *, 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 u_subscr(a_1,a_2) (a_2)*u_dim1 + a_1 #define u_ref(a_1,a_2) u[u_subscr(a_1,a_2)] #define v_subscr(a_1,a_2) (a_2)*v_dim1 + a_1 #define v_ref(a_1,a_2) v[v_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; 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; --iwork; --rwork; --tau; --work; /* Function Body */ wantu = lsame_(jobu, "U"); wantv = lsame_(jobv, "V"); wantq = lsame_(jobq, "Q"); forwrd = TRUE_; *info = 0; if (! (wantu || lsame_(jobu, "N"))) { *info = -1; } else if (! (wantv || lsame_(jobv, "N"))) { *info = -2; } else if (! (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 = -8; } else if (*ldb < max(1,*p)) { *info = -10; } else if (*ldu < 1 || wantu && *ldu < *m) { *info = -16; } else if (*ldv < 1 || wantv && *ldv < *p) { *info = -18; } else if (*ldq < 1 || wantq && *ldq < *n) { *info = -20; } if (*info != 0) { i__1 = -(*info); xerbla_("ZGGSVP", &i__1); return 0; } /* QR with column pivoting of B: B*P = V*( S11 S12 ) ( 0 0 ) */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { iwork[i__] = 0; /* L10: */ } zgeqpf_(p, n, &b[b_offset], ldb, &iwork[1], &tau[1], &work[1], &rwork[1], info); /* Update A := A*P */ zlapmt_(&forwrd, m, n, &a[a_offset], lda, &iwork[1]); /* Determine the effective rank of matrix B. */ *l = 0; i__1 = min(*p,*n); for (i__ = 1; i__ <= i__1; ++i__) { i__2 = b_subscr(i__, i__); if ((d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b_ref(i__, i__)), abs(d__2)) > *tolb) { ++(*l); } /* L20: */ } if (wantv) { /* Copy the details of V, and form V. */ zlaset_("Full", p, p, &c_b1, &c_b1, &v[v_offset], ldv); if (*p > 1) { i__1 = *p - 1; zlacpy_("Lower", &i__1, n, &b_ref(2, 1), ldb, &v_ref(2, 1), ldv); } i__1 = min(*p,*n); zung2r_(p, p, &i__1, &v[v_offset], ldv, &tau[1], &work[1], info); } /* Clean up B */ i__1 = *l - 1; for (j = 1; j <= i__1; ++j) { i__2 = *l; for (i__ = j + 1; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); b[i__3].r = 0., b[i__3].i = 0.; /* L30: */ } /* L40: */ } if (*p > *l) { i__1 = *p - *l; zlaset_("Full", &i__1, n, &c_b1, &c_b1, &b_ref(*l + 1, 1), ldb); } if (wantq) { /* Set Q = I and Update Q := Q*P */ zlaset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq); zlapmt_(&forwrd, n, n, &q[q_offset], ldq, &iwork[1]); } if (*p >= *l && *n != *l) { /* RQ factorization of ( S11 S12 ) = ( 0 S12 )*Z */ zgerq2_(l, n, &b[b_offset], ldb, &tau[1], &work[1], info); /* Update A := A*Z' */ zunmr2_("Right", "Conjugate transpose", m, n, l, &b[b_offset], ldb, & tau[1], &a[a_offset], lda, &work[1], info); if (wantq) { /* Update Q := Q*Z' */ zunmr2_("Right", "Conjugate transpose", n, n, l, &b[b_offset], ldb, &tau[1], &q[q_offset], ldq, &work[1], info); } /* Clean up B */ i__1 = *n - *l; zlaset_("Full", l, &i__1, &c_b1, &c_b1, &b[b_offset], ldb); i__1 = *n; for (j = *n - *l + 1; j <= i__1; ++j) { i__2 = *l; for (i__ = j - *n + *l + 1; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); b[i__3].r = 0., b[i__3].i = 0.; /* L50: */ } /* L60: */ } } /* Let N-L L A = ( A11 A12 ) M, then the following does the complete QR decomposition of A11: A11 = U*( 0 T12 )*P1' ( 0 0 ) */ i__1 = *n - *l; for (i__ = 1; i__ <= i__1; ++i__) { iwork[i__] = 0; /* L70: */ } i__1 = *n - *l; zgeqpf_(m, &i__1, &a[a_offset], lda, &iwork[1], &tau[1], &work[1], &rwork[ 1], info); /* Determine the effective rank of A11 */ *k = 0; /* Computing MIN */ i__2 = *m, i__3 = *n - *l; i__1 = min(i__2,i__3); for (i__ = 1; i__ <= i__1; ++i__) { i__2 = a_subscr(i__, i__); if ((d__1 = a[i__2].r, abs(d__1)) + (d__2 = d_imag(&a_ref(i__, i__)), abs(d__2)) > *tola) { ++(*k); } /* L80: */ } /* Update A12 := U'*A12, where A12 = A( 1:M, N-L+1:N ) Computing MIN */ i__2 = *m, i__3 = *n - *l; i__1 = min(i__2,i__3); zunm2r_("Left", "Conjugate transpose", m, l, &i__1, &a[a_offset], lda, & tau[1], &a_ref(1, *n - *l + 1), lda, &work[1], info); if (wantu) { /* Copy the details of U, and form U */ zlaset_("Full", m, m, &c_b1, &c_b1, &u[u_offset], ldu); if (*m > 1) { i__1 = *m - 1; i__2 = *n - *l; zlacpy_("Lower", &i__1, &i__2, &a_ref(2, 1), lda, &u_ref(2, 1), ldu); } /* Computing MIN */ i__2 = *m, i__3 = *n - *l; i__1 = min(i__2,i__3); zung2r_(m, m, &i__1, &u[u_offset], ldu, &tau[1], &work[1], info); } if (wantq) { /* Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1 */ i__1 = *n - *l; zlapmt_(&forwrd, n, &i__1, &q[q_offset], ldq, &iwork[1]); } /* Clean up A: set the strictly lower triangular part of A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0. */ i__1 = *k - 1; for (j = 1; j <= i__1; ++j) { i__2 = *k; for (i__ = j + 1; i__ <= i__2; ++i__) { i__3 = a_subscr(i__, j); a[i__3].r = 0., a[i__3].i = 0.; /* L90: */ } /* L100: */ } if (*m > *k) { i__1 = *m - *k; i__2 = *n - *l; zlaset_("Full", &i__1, &i__2, &c_b1, &c_b1, &a_ref(*k + 1, 1), lda); } if (*n - *l > *k) { /* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 */ i__1 = *n - *l; zgerq2_(k, &i__1, &a[a_offset], lda, &tau[1], &work[1], info); if (wantq) { /* Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1' */ i__1 = *n - *l; zunmr2_("Right", "Conjugate transpose", n, &i__1, k, &a[a_offset], lda, &tau[1], &q[q_offset], ldq, &work[1], info); } /* Clean up A */ i__1 = *n - *l - *k; zlaset_("Full", k, &i__1, &c_b1, &c_b1, &a[a_offset], lda); i__1 = *n - *l; for (j = *n - *l - *k + 1; j <= i__1; ++j) { i__2 = *k; for (i__ = j - *n + *l + *k + 1; i__ <= i__2; ++i__) { i__3 = a_subscr(i__, j); a[i__3].r = 0., a[i__3].i = 0.; /* L110: */ } /* L120: */ } } if (*m > *k) { /* QR factorization of A( K+1:M,N-L+1:N ) */ i__1 = *m - *k; zgeqr2_(&i__1, l, &a_ref(*k + 1, *n - *l + 1), lda, &tau[1], &work[1], info); if (wantu) { /* Update U(:,K+1:M) := U(:,K+1:M)*U1 */ i__1 = *m - *k; /* Computing MIN */ i__3 = *m - *k; i__2 = min(i__3,*l); zunm2r_("Right", "No transpose", m, &i__1, &i__2, &a_ref(*k + 1, * n - *l + 1), lda, &tau[1], &u_ref(1, *k + 1), ldu, &work[ 1], info); } /* Clean up */ i__1 = *n; for (j = *n - *l + 1; j <= i__1; ++j) { i__2 = *m; for (i__ = j - *n + *k + *l + 1; i__ <= i__2; ++i__) { i__3 = a_subscr(i__, j); a[i__3].r = 0., a[i__3].i = 0.; /* L130: */ } /* L140: */ } } return 0; /* End of ZGGSVP */ } /* zggsvp_ */
/* Subroutine */ int cgtts2_(integer *itrans, integer *n, integer *nrhs, complex *dl, complex *d__, complex *du, complex *du2, integer *ipiv, complex *b, integer *ldb) { /* -- 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 ======= CGTTS2 solves one of the systems of equations A * X = B, A**T * X = B, or A**H * X = B, with a tridiagonal matrix A using the LU factorization computed by CGTTRF. Arguments ========= ITRANS (input) INTEGER Specifies the form of the system of equations. = 0: A * X = B (No transpose) = 1: A**T * X = B (Transpose) = 2: A**H * X = B (Conjugate transpose) N (input) INTEGER The order of the matrix A. NRHS (input) INTEGER The number of right hand sides, i.e., the number of columns of the matrix B. NRHS >= 0. DL (input) COMPLEX array, dimension (N-1) The (n-1) multipliers that define the matrix L from the LU factorization of A. D (input) COMPLEX array, dimension (N) The n diagonal elements of the upper triangular matrix U from the LU factorization of A. DU (input) COMPLEX array, dimension (N-1) The (n-1) elements of the first super-diagonal of U. DU2 (input) COMPLEX array, dimension (N-2) The (n-2) elements of the second super-diagonal of U. IPIV (input) INTEGER array, dimension (N) The pivot indices; for 1 <= i <= n, row i of the matrix was interchanged with row IPIV(i). IPIV(i) will always be either i or i+1; IPIV(i) = i indicates a row interchange was not required. B (input/output) COMPLEX array, dimension (LDB,NRHS) On entry, the matrix of right hand side vectors B. On exit, B is overwritten by the solution vectors X. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,N). ===================================================================== Quick return if possible Parameter adjustments */ /* System generated locals */ integer b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8; complex q__1, q__2, q__3, q__4, q__5, q__6, q__7, q__8; /* Builtin functions */ void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *); /* Local variables */ static complex temp; static integer i__, j; #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)] --dl; --d__; --du; --du2; --ipiv; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; /* Function Body */ if (*n == 0 || *nrhs == 0) { return 0; } if (*itrans == 0) { /* Solve A*X = B using the LU factorization of A, overwriting each right hand side vector with its solution. */ if (*nrhs <= 1) { j = 1; L10: /* Solve L*x = b. */ i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { if (ipiv[i__] == i__) { i__2 = b_subscr(i__ + 1, j); i__3 = b_subscr(i__ + 1, j); i__4 = i__; i__5 = b_subscr(i__, j); q__2.r = dl[i__4].r * b[i__5].r - dl[i__4].i * b[i__5].i, q__2.i = dl[i__4].r * b[i__5].i + dl[i__4].i * b[ i__5].r; q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; } else { i__2 = b_subscr(i__, j); temp.r = b[i__2].r, temp.i = b[i__2].i; i__2 = b_subscr(i__, j); i__3 = b_subscr(i__ + 1, j); b[i__2].r = b[i__3].r, b[i__2].i = b[i__3].i; i__2 = b_subscr(i__ + 1, j); i__3 = i__; i__4 = b_subscr(i__, j); q__2.r = dl[i__3].r * b[i__4].r - dl[i__3].i * b[i__4].i, q__2.i = dl[i__3].r * b[i__4].i + dl[i__3].i * b[ i__4].r; q__1.r = temp.r - q__2.r, q__1.i = temp.i - q__2.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; } /* L20: */ } /* Solve U*x = b. */ i__1 = b_subscr(*n, j); c_div(&q__1, &b_ref(*n, j), &d__[*n]); b[i__1].r = q__1.r, b[i__1].i = q__1.i; if (*n > 1) { i__1 = b_subscr(*n - 1, j); i__2 = b_subscr(*n - 1, j); i__3 = *n - 1; i__4 = b_subscr(*n, j); q__3.r = du[i__3].r * b[i__4].r - du[i__3].i * b[i__4].i, q__3.i = du[i__3].r * b[i__4].i + du[i__3].i * b[i__4] .r; q__2.r = b[i__2].r - q__3.r, q__2.i = b[i__2].i - q__3.i; c_div(&q__1, &q__2, &d__[*n - 1]); b[i__1].r = q__1.r, b[i__1].i = q__1.i; } for (i__ = *n - 2; i__ >= 1; --i__) { i__1 = b_subscr(i__, j); i__2 = b_subscr(i__, j); i__3 = i__; i__4 = b_subscr(i__ + 1, j); q__4.r = du[i__3].r * b[i__4].r - du[i__3].i * b[i__4].i, q__4.i = du[i__3].r * b[i__4].i + du[i__3].i * b[i__4] .r; q__3.r = b[i__2].r - q__4.r, q__3.i = b[i__2].i - q__4.i; i__5 = i__; i__6 = b_subscr(i__ + 2, j); q__5.r = du2[i__5].r * b[i__6].r - du2[i__5].i * b[i__6].i, q__5.i = du2[i__5].r * b[i__6].i + du2[i__5].i * b[ i__6].r; q__2.r = q__3.r - q__5.r, q__2.i = q__3.i - q__5.i; c_div(&q__1, &q__2, &d__[i__]); b[i__1].r = q__1.r, b[i__1].i = q__1.i; /* L30: */ } if (j < *nrhs) { ++j; goto L10; } } else { i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { /* Solve L*x = b. */ i__2 = *n - 1; for (i__ = 1; i__ <= i__2; ++i__) { if (ipiv[i__] == i__) { i__3 = b_subscr(i__ + 1, j); i__4 = b_subscr(i__ + 1, j); i__5 = i__; i__6 = b_subscr(i__, j); q__2.r = dl[i__5].r * b[i__6].r - dl[i__5].i * b[i__6] .i, q__2.i = dl[i__5].r * b[i__6].i + dl[i__5] .i * b[i__6].r; q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i - q__2.i; b[i__3].r = q__1.r, b[i__3].i = q__1.i; } else { i__3 = b_subscr(i__, j); temp.r = b[i__3].r, temp.i = b[i__3].i; i__3 = b_subscr(i__, j); i__4 = b_subscr(i__ + 1, j); b[i__3].r = b[i__4].r, b[i__3].i = b[i__4].i; i__3 = b_subscr(i__ + 1, j); i__4 = i__; i__5 = b_subscr(i__, j); q__2.r = dl[i__4].r * b[i__5].r - dl[i__4].i * b[i__5] .i, q__2.i = dl[i__4].r * b[i__5].i + dl[i__4] .i * b[i__5].r; q__1.r = temp.r - q__2.r, q__1.i = temp.i - q__2.i; b[i__3].r = q__1.r, b[i__3].i = q__1.i; } /* L40: */ } /* Solve U*x = b. */ i__2 = b_subscr(*n, j); c_div(&q__1, &b_ref(*n, j), &d__[*n]); b[i__2].r = q__1.r, b[i__2].i = q__1.i; if (*n > 1) { i__2 = b_subscr(*n - 1, j); i__3 = b_subscr(*n - 1, j); i__4 = *n - 1; i__5 = b_subscr(*n, j); q__3.r = du[i__4].r * b[i__5].r - du[i__4].i * b[i__5].i, q__3.i = du[i__4].r * b[i__5].i + du[i__4].i * b[ i__5].r; q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i; c_div(&q__1, &q__2, &d__[*n - 1]); b[i__2].r = q__1.r, b[i__2].i = q__1.i; } for (i__ = *n - 2; i__ >= 1; --i__) { i__2 = b_subscr(i__, j); i__3 = b_subscr(i__, j); i__4 = i__; i__5 = b_subscr(i__ + 1, j); q__4.r = du[i__4].r * b[i__5].r - du[i__4].i * b[i__5].i, q__4.i = du[i__4].r * b[i__5].i + du[i__4].i * b[ i__5].r; q__3.r = b[i__3].r - q__4.r, q__3.i = b[i__3].i - q__4.i; i__6 = i__; i__7 = b_subscr(i__ + 2, j); q__5.r = du2[i__6].r * b[i__7].r - du2[i__6].i * b[i__7] .i, q__5.i = du2[i__6].r * b[i__7].i + du2[i__6] .i * b[i__7].r; q__2.r = q__3.r - q__5.r, q__2.i = q__3.i - q__5.i; c_div(&q__1, &q__2, &d__[i__]); b[i__2].r = q__1.r, b[i__2].i = q__1.i; /* L50: */ } /* L60: */ } } } else if (*itrans == 1) { /* Solve A**T * X = B. */ if (*nrhs <= 1) { j = 1; L70: /* Solve U**T * x = b. */ i__1 = b_subscr(1, j); c_div(&q__1, &b_ref(1, j), &d__[1]); b[i__1].r = q__1.r, b[i__1].i = q__1.i; if (*n > 1) { i__1 = b_subscr(2, j); i__2 = b_subscr(2, j); i__3 = b_subscr(1, j); q__3.r = du[1].r * b[i__3].r - du[1].i * b[i__3].i, q__3.i = du[1].r * b[i__3].i + du[1].i * b[i__3].r; q__2.r = b[i__2].r - q__3.r, q__2.i = b[i__2].i - q__3.i; c_div(&q__1, &q__2, &d__[2]); b[i__1].r = q__1.r, b[i__1].i = q__1.i; } i__1 = *n; for (i__ = 3; i__ <= i__1; ++i__) { i__2 = b_subscr(i__, j); i__3 = b_subscr(i__, j); i__4 = i__ - 1; i__5 = b_subscr(i__ - 1, j); q__4.r = du[i__4].r * b[i__5].r - du[i__4].i * b[i__5].i, q__4.i = du[i__4].r * b[i__5].i + du[i__4].i * b[i__5] .r; q__3.r = b[i__3].r - q__4.r, q__3.i = b[i__3].i - q__4.i; i__6 = i__ - 2; i__7 = b_subscr(i__ - 2, j); q__5.r = du2[i__6].r * b[i__7].r - du2[i__6].i * b[i__7].i, q__5.i = du2[i__6].r * b[i__7].i + du2[i__6].i * b[ i__7].r; q__2.r = q__3.r - q__5.r, q__2.i = q__3.i - q__5.i; c_div(&q__1, &q__2, &d__[i__]); b[i__2].r = q__1.r, b[i__2].i = q__1.i; /* L80: */ } /* Solve L**T * x = b. */ for (i__ = *n - 1; i__ >= 1; --i__) { if (ipiv[i__] == i__) { i__1 = b_subscr(i__, j); i__2 = b_subscr(i__, j); i__3 = i__; i__4 = b_subscr(i__ + 1, j); q__2.r = dl[i__3].r * b[i__4].r - dl[i__3].i * b[i__4].i, q__2.i = dl[i__3].r * b[i__4].i + dl[i__3].i * b[ i__4].r; q__1.r = b[i__2].r - q__2.r, q__1.i = b[i__2].i - q__2.i; b[i__1].r = q__1.r, b[i__1].i = q__1.i; } else { i__1 = b_subscr(i__ + 1, j); temp.r = b[i__1].r, temp.i = b[i__1].i; i__1 = b_subscr(i__ + 1, j); i__2 = b_subscr(i__, j); i__3 = i__; q__2.r = dl[i__3].r * temp.r - dl[i__3].i * temp.i, q__2.i = dl[i__3].r * temp.i + dl[i__3].i * temp.r; q__1.r = b[i__2].r - q__2.r, q__1.i = b[i__2].i - q__2.i; b[i__1].r = q__1.r, b[i__1].i = q__1.i; i__1 = b_subscr(i__, j); b[i__1].r = temp.r, b[i__1].i = temp.i; } /* L90: */ } if (j < *nrhs) { ++j; goto L70; } } else { i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { /* Solve U**T * x = b. */ i__2 = b_subscr(1, j); c_div(&q__1, &b_ref(1, j), &d__[1]); b[i__2].r = q__1.r, b[i__2].i = q__1.i; if (*n > 1) { i__2 = b_subscr(2, j); i__3 = b_subscr(2, j); i__4 = b_subscr(1, j); q__3.r = du[1].r * b[i__4].r - du[1].i * b[i__4].i, q__3.i = du[1].r * b[i__4].i + du[1].i * b[i__4] .r; q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i; c_div(&q__1, &q__2, &d__[2]); b[i__2].r = q__1.r, b[i__2].i = q__1.i; } i__2 = *n; for (i__ = 3; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); i__4 = b_subscr(i__, j); i__5 = i__ - 1; i__6 = b_subscr(i__ - 1, j); q__4.r = du[i__5].r * b[i__6].r - du[i__5].i * b[i__6].i, q__4.i = du[i__5].r * b[i__6].i + du[i__5].i * b[ i__6].r; q__3.r = b[i__4].r - q__4.r, q__3.i = b[i__4].i - q__4.i; i__7 = i__ - 2; i__8 = b_subscr(i__ - 2, j); q__5.r = du2[i__7].r * b[i__8].r - du2[i__7].i * b[i__8] .i, q__5.i = du2[i__7].r * b[i__8].i + du2[i__7] .i * b[i__8].r; q__2.r = q__3.r - q__5.r, q__2.i = q__3.i - q__5.i; c_div(&q__1, &q__2, &d__[i__]); b[i__3].r = q__1.r, b[i__3].i = q__1.i; /* L100: */ } /* Solve L**T * x = b. */ for (i__ = *n - 1; i__ >= 1; --i__) { if (ipiv[i__] == i__) { i__2 = b_subscr(i__, j); i__3 = b_subscr(i__, j); i__4 = i__; i__5 = b_subscr(i__ + 1, j); q__2.r = dl[i__4].r * b[i__5].r - dl[i__4].i * b[i__5] .i, q__2.i = dl[i__4].r * b[i__5].i + dl[i__4] .i * b[i__5].r; q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; } else { i__2 = b_subscr(i__ + 1, j); temp.r = b[i__2].r, temp.i = b[i__2].i; i__2 = b_subscr(i__ + 1, j); i__3 = b_subscr(i__, j); i__4 = i__; q__2.r = dl[i__4].r * temp.r - dl[i__4].i * temp.i, q__2.i = dl[i__4].r * temp.i + dl[i__4].i * temp.r; q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; i__2 = b_subscr(i__, j); b[i__2].r = temp.r, b[i__2].i = temp.i; } /* L110: */ } /* L120: */ } } } else { /* Solve A**H * X = B. */ if (*nrhs <= 1) { j = 1; L130: /* Solve U**H * x = b. */ i__1 = b_subscr(1, j); r_cnjg(&q__2, &d__[1]); c_div(&q__1, &b_ref(1, j), &q__2); b[i__1].r = q__1.r, b[i__1].i = q__1.i; if (*n > 1) { i__1 = b_subscr(2, j); i__2 = b_subscr(2, j); r_cnjg(&q__4, &du[1]); i__3 = b_subscr(1, j); q__3.r = q__4.r * b[i__3].r - q__4.i * b[i__3].i, q__3.i = q__4.r * b[i__3].i + q__4.i * b[i__3].r; q__2.r = b[i__2].r - q__3.r, q__2.i = b[i__2].i - q__3.i; r_cnjg(&q__5, &d__[2]); c_div(&q__1, &q__2, &q__5); b[i__1].r = q__1.r, b[i__1].i = q__1.i; } i__1 = *n; for (i__ = 3; i__ <= i__1; ++i__) { i__2 = b_subscr(i__, j); i__3 = b_subscr(i__, j); r_cnjg(&q__5, &du[i__ - 1]); i__4 = b_subscr(i__ - 1, j); q__4.r = q__5.r * b[i__4].r - q__5.i * b[i__4].i, q__4.i = q__5.r * b[i__4].i + q__5.i * b[i__4].r; q__3.r = b[i__3].r - q__4.r, q__3.i = b[i__3].i - q__4.i; r_cnjg(&q__7, &du2[i__ - 2]); i__5 = b_subscr(i__ - 2, j); q__6.r = q__7.r * b[i__5].r - q__7.i * b[i__5].i, q__6.i = q__7.r * b[i__5].i + q__7.i * b[i__5].r; q__2.r = q__3.r - q__6.r, q__2.i = q__3.i - q__6.i; r_cnjg(&q__8, &d__[i__]); c_div(&q__1, &q__2, &q__8); b[i__2].r = q__1.r, b[i__2].i = q__1.i; /* L140: */ } /* Solve L**H * x = b. */ for (i__ = *n - 1; i__ >= 1; --i__) { if (ipiv[i__] == i__) { i__1 = b_subscr(i__, j); i__2 = b_subscr(i__, j); r_cnjg(&q__3, &dl[i__]); i__3 = b_subscr(i__ + 1, j); q__2.r = q__3.r * b[i__3].r - q__3.i * b[i__3].i, q__2.i = q__3.r * b[i__3].i + q__3.i * b[i__3].r; q__1.r = b[i__2].r - q__2.r, q__1.i = b[i__2].i - q__2.i; b[i__1].r = q__1.r, b[i__1].i = q__1.i; } else { i__1 = b_subscr(i__ + 1, j); temp.r = b[i__1].r, temp.i = b[i__1].i; i__1 = b_subscr(i__ + 1, j); i__2 = b_subscr(i__, j); r_cnjg(&q__3, &dl[i__]); q__2.r = q__3.r * temp.r - q__3.i * temp.i, q__2.i = q__3.r * temp.i + q__3.i * temp.r; q__1.r = b[i__2].r - q__2.r, q__1.i = b[i__2].i - q__2.i; b[i__1].r = q__1.r, b[i__1].i = q__1.i; i__1 = b_subscr(i__, j); b[i__1].r = temp.r, b[i__1].i = temp.i; } /* L150: */ } if (j < *nrhs) { ++j; goto L130; } } else { i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { /* Solve U**H * x = b. */ i__2 = b_subscr(1, j); r_cnjg(&q__2, &d__[1]); c_div(&q__1, &b_ref(1, j), &q__2); b[i__2].r = q__1.r, b[i__2].i = q__1.i; if (*n > 1) { i__2 = b_subscr(2, j); i__3 = b_subscr(2, j); r_cnjg(&q__4, &du[1]); i__4 = b_subscr(1, j); q__3.r = q__4.r * b[i__4].r - q__4.i * b[i__4].i, q__3.i = q__4.r * b[i__4].i + q__4.i * b[i__4].r; q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i; r_cnjg(&q__5, &d__[2]); c_div(&q__1, &q__2, &q__5); b[i__2].r = q__1.r, b[i__2].i = q__1.i; } i__2 = *n; for (i__ = 3; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); i__4 = b_subscr(i__, j); r_cnjg(&q__5, &du[i__ - 1]); i__5 = b_subscr(i__ - 1, j); q__4.r = q__5.r * b[i__5].r - q__5.i * b[i__5].i, q__4.i = q__5.r * b[i__5].i + q__5.i * b[i__5].r; q__3.r = b[i__4].r - q__4.r, q__3.i = b[i__4].i - q__4.i; r_cnjg(&q__7, &du2[i__ - 2]); i__6 = b_subscr(i__ - 2, j); q__6.r = q__7.r * b[i__6].r - q__7.i * b[i__6].i, q__6.i = q__7.r * b[i__6].i + q__7.i * b[i__6].r; q__2.r = q__3.r - q__6.r, q__2.i = q__3.i - q__6.i; r_cnjg(&q__8, &d__[i__]); c_div(&q__1, &q__2, &q__8); b[i__3].r = q__1.r, b[i__3].i = q__1.i; /* L160: */ } /* Solve L**H * x = b. */ for (i__ = *n - 1; i__ >= 1; --i__) { if (ipiv[i__] == i__) { i__2 = b_subscr(i__, j); i__3 = b_subscr(i__, j); r_cnjg(&q__3, &dl[i__]); i__4 = b_subscr(i__ + 1, j); q__2.r = q__3.r * b[i__4].r - q__3.i * b[i__4].i, q__2.i = q__3.r * b[i__4].i + q__3.i * b[i__4] .r; q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; } else { i__2 = b_subscr(i__ + 1, j); temp.r = b[i__2].r, temp.i = b[i__2].i; i__2 = b_subscr(i__ + 1, j); i__3 = b_subscr(i__, j); r_cnjg(&q__3, &dl[i__]); q__2.r = q__3.r * temp.r - q__3.i * temp.i, q__2.i = q__3.r * temp.i + q__3.i * temp.r; q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; i__2 = b_subscr(i__, j); b[i__2].r = temp.r, b[i__2].i = temp.i; } /* L170: */ } /* L180: */ } } } /* End of CGTTS2 */ return 0; } /* cgtts2_ */
/* Subroutine */ int ctprfs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, complex *ap, complex *b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork, 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 ======= CTPRFS provides error bounds and backward error estimates for the solution to a system of linear equations with a triangular packed coefficient matrix. The solution matrix X must be computed by CTPTRS or some other means before entering this routine. CTPRFS does not do iterative refinement because doing so cannot improve the backward error. Arguments ========= UPLO (input) CHARACTER*1 = 'U': A is upper triangular; = 'L': A is lower triangular. TRANS (input) CHARACTER*1 Specifies the form of the system of equations: = 'N': A * X = B (No transpose) = 'T': A**T * X = B (Transpose) = 'C': A**H * X = B (Conjugate transpose) DIAG (input) CHARACTER*1 = 'N': A is non-unit triangular; = 'U': A is unit triangular. N (input) INTEGER The order of the matrix A. N >= 0. NRHS (input) INTEGER The number of right hand sides, i.e., the number of columns of the matrices B and X. NRHS >= 0. AP (input) COMPLEX array, dimension (N*(N+1)/2) The upper or lower triangular matrix A, packed columnwise in a linear array. The j-th column of A is stored in the array AP as follows: if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. If DIAG = 'U', the diagonal elements of A are not referenced and are assumed to be 1. B (input) COMPLEX array, dimension (LDB,NRHS) The right hand side matrix B. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,N). X (input) COMPLEX array, dimension (LDX,NRHS) The solution matrix X. LDX (input) INTEGER The leading dimension of the array X. LDX >= max(1,N). FERR (output) REAL array, dimension (NRHS) The estimated forward error bound for each solution vector X(j) (the j-th column of the solution matrix X). If XTRUE is the true solution corresponding to X(j), FERR(j) is an estimated upper bound for the magnitude of the largest element in (X(j) - XTRUE) divided by the magnitude of the largest element in X(j). The estimate is as reliable as the estimate for RCOND, and is almost always a slight overestimate of the true error. BERR (output) REAL array, dimension (NRHS) The componentwise relative backward error of each solution vector X(j) (i.e., the smallest relative change in any element of A or B that makes X(j) an exact solution). WORK (workspace) COMPLEX array, dimension (2*N) RWORK (workspace) REAL array, dimension (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 integer c__1 = 1; /* System generated locals */ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5; real r__1, r__2, r__3, r__4; complex q__1; /* Builtin functions */ double r_imag(complex *); /* Local variables */ static integer kase; static real safe1, safe2; static integer i__, j, k; static real s; extern logical lsame_(char *, char *); extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer *, complex *, integer *), ctpmv_(char *, char *, char *, integer *, complex *, complex *, integer *); static logical upper; extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *, complex *, complex *, integer *); static integer kc; extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real *, integer *); static real xk; extern doublereal slamch_(char *); static integer nz; static real safmin; extern /* Subroutine */ int xerbla_(char *, integer *); static logical notran; static char transn[1], transt[1]; static logical nounit; static real lstres, eps; #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 x_subscr(a_1,a_2) (a_2)*x_dim1 + a_1 #define x_ref(a_1,a_2) x[x_subscr(a_1,a_2)] --ap; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; x_dim1 = *ldx; x_offset = 1 + x_dim1 * 1; x -= x_offset; --ferr; --berr; --work; --rwork; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); notran = lsame_(trans, "N"); nounit = lsame_(diag, "N"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (! notran && ! lsame_(trans, "T") && ! lsame_(trans, "C")) { *info = -2; } else if (! nounit && ! lsame_(diag, "U")) { *info = -3; } else if (*n < 0) { *info = -4; } else if (*nrhs < 0) { *info = -5; } else if (*ldb < max(1,*n)) { *info = -8; } else if (*ldx < max(1,*n)) { *info = -10; } if (*info != 0) { i__1 = -(*info); xerbla_("CTPRFS", &i__1); return 0; } /* Quick return if possible */ if (*n == 0 || *nrhs == 0) { i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { ferr[j] = 0.f; berr[j] = 0.f; /* L10: */ } return 0; } if (notran) { *(unsigned char *)transn = 'N'; *(unsigned char *)transt = 'C'; } else { *(unsigned char *)transn = 'C'; *(unsigned char *)transt = 'N'; } /* NZ = maximum number of nonzero elements in each row of A, plus 1 */ nz = *n + 1; eps = slamch_("Epsilon"); safmin = slamch_("Safe minimum"); safe1 = nz * safmin; safe2 = safe1 / eps; /* Do for each right hand side */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { /* Compute residual R = B - op(A) * X, where op(A) = A, A**T, or A**H, depending on TRANS. */ ccopy_(n, &x_ref(1, j), &c__1, &work[1], &c__1); ctpmv_(uplo, trans, diag, n, &ap[1], &work[1], &c__1); q__1.r = -1.f, q__1.i = 0.f; caxpy_(n, &q__1, &b_ref(1, j), &c__1, &work[1], &c__1); /* Compute componentwise relative backward error from formula max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) where abs(Z) is the componentwise absolute value of the matrix or vector Z. If the i-th component of the denominator is less than SAFE2, then SAFE1 is added to the i-th components of the numerator and denominator before dividing. */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(& b_ref(i__, j)), dabs(r__2)); /* L20: */ } if (notran) { /* Compute abs(A)*abs(X) + abs(B). */ if (upper) { kc = 1; if (nounit) { i__2 = *n; for (k = 1; k <= i__2; ++k) { i__3 = x_subscr(k, j); xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(& x_ref(k, j)), dabs(r__2)); i__3 = k; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = kc + i__ - 1; rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + ( r__2 = r_imag(&ap[kc + i__ - 1]), dabs( r__2))) * xk; /* L30: */ } kc += k; /* L40: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { i__3 = x_subscr(k, j); xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(& x_ref(k, j)), dabs(r__2)); i__3 = k - 1; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = kc + i__ - 1; rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + ( r__2 = r_imag(&ap[kc + i__ - 1]), dabs( r__2))) * xk; /* L50: */ } rwork[k] += xk; kc += k; /* L60: */ } } } else { kc = 1; if (nounit) { i__2 = *n; for (k = 1; k <= i__2; ++k) { i__3 = x_subscr(k, j); xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(& x_ref(k, j)), dabs(r__2)); i__3 = *n; for (i__ = k; i__ <= i__3; ++i__) { i__4 = kc + i__ - k; rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + ( r__2 = r_imag(&ap[kc + i__ - k]), dabs( r__2))) * xk; /* L70: */ } kc = kc + *n - k + 1; /* L80: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { i__3 = x_subscr(k, j); xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(& x_ref(k, j)), dabs(r__2)); i__3 = *n; for (i__ = k + 1; i__ <= i__3; ++i__) { i__4 = kc + i__ - k; rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + ( r__2 = r_imag(&ap[kc + i__ - k]), dabs( r__2))) * xk; /* L90: */ } rwork[k] += xk; kc = kc + *n - k + 1; /* L100: */ } } } } else { /* Compute abs(A**H)*abs(X) + abs(B). */ if (upper) { kc = 1; if (nounit) { i__2 = *n; for (k = 1; k <= i__2; ++k) { s = 0.f; i__3 = k; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = kc + i__ - 1; i__5 = x_subscr(i__, j); s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&ap[kc + i__ - 1]), dabs(r__2))) * ((r__3 = x[i__5].r, dabs(r__3)) + (r__4 = r_imag(&x_ref(i__, j)), dabs(r__4))); /* L110: */ } rwork[k] += s; kc += k; /* L120: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { i__3 = x_subscr(k, j); s = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(& x_ref(k, j)), dabs(r__2)); i__3 = k - 1; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = kc + i__ - 1; i__5 = x_subscr(i__, j); s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&ap[kc + i__ - 1]), dabs(r__2))) * ((r__3 = x[i__5].r, dabs(r__3)) + (r__4 = r_imag(&x_ref(i__, j)), dabs(r__4))); /* L130: */ } rwork[k] += s; kc += k; /* L140: */ } } } else { kc = 1; if (nounit) { i__2 = *n; for (k = 1; k <= i__2; ++k) { s = 0.f; i__3 = *n; for (i__ = k; i__ <= i__3; ++i__) { i__4 = kc + i__ - k; i__5 = x_subscr(i__, j); s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&ap[kc + i__ - k]), dabs(r__2))) * ((r__3 = x[i__5].r, dabs(r__3)) + (r__4 = r_imag(&x_ref(i__, j)), dabs(r__4))); /* L150: */ } rwork[k] += s; kc = kc + *n - k + 1; /* L160: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { i__3 = x_subscr(k, j); s = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(& x_ref(k, j)), dabs(r__2)); i__3 = *n; for (i__ = k + 1; i__ <= i__3; ++i__) { i__4 = kc + i__ - k; i__5 = x_subscr(i__, j); s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&ap[kc + i__ - k]), dabs(r__2))) * ((r__3 = x[i__5].r, dabs(r__3)) + (r__4 = r_imag(&x_ref(i__, j)), dabs(r__4))); /* L170: */ } rwork[k] += s; kc = kc + *n - k + 1; /* L180: */ } } } } s = 0.f; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { if (rwork[i__] > safe2) { /* Computing MAX */ i__3 = i__; r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 = r_imag(&work[i__]), dabs(r__2))) / rwork[i__]; s = dmax(r__3,r__4); } else { /* Computing MAX */ i__3 = i__; r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 = r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__] + safe1); s = dmax(r__3,r__4); } /* L190: */ } berr[j] = s; /* Bound error from formula norm(X - XTRUE) / norm(X) .le. FERR = norm( abs(inv(op(A)))* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) where norm(Z) is the magnitude of the largest component of Z inv(op(A)) is the inverse of op(A) abs(Z) is the componentwise absolute value of the matrix or vector Z NZ is the maximum number of nonzeros in any row of A, plus 1 EPS is machine epsilon The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) is incremented by SAFE1 if the i-th component of abs(op(A))*abs(X) + abs(B) is less than SAFE2. Use CLACON to estimate the infinity-norm of the matrix inv(op(A)) * diag(W), where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { if (rwork[i__] > safe2) { i__3 = i__; rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 = r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[ i__]; } else { i__3 = i__; rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 = r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[ i__] + safe1; } /* L200: */ } kase = 0; L210: clacon_(n, &work[*n + 1], &work[1], &ferr[j], &kase); if (kase != 0) { if (kase == 1) { /* Multiply by diag(W)*inv(op(A)**H). */ ctpsv_(uplo, transt, diag, n, &ap[1], &work[1], &c__1); i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__; i__4 = i__; i__5 = i__; q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4] * work[i__5].i; work[i__3].r = q__1.r, work[i__3].i = q__1.i; /* L220: */ } } else { /* Multiply by inv(op(A))*diag(W). */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__; i__4 = i__; i__5 = i__; q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4] * work[i__5].i; work[i__3].r = q__1.r, work[i__3].i = q__1.i; /* L230: */ } ctpsv_(uplo, transn, diag, n, &ap[1], &work[1], &c__1); } goto L210; } /* Normalize error. */ lstres = 0.f; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { /* Computing MAX */ i__3 = x_subscr(i__, j); r__3 = lstres, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x_ref(i__, j)), dabs(r__2)); lstres = dmax(r__3,r__4); /* L240: */ } if (lstres != 0.f) { ferr[j] /= lstres; } /* L250: */ } return 0; /* End of CTPRFS */ } /* ctprfs_ */
/* Subroutine */ int claein_(logical *rightv, logical *noinit, integer *n, complex *h__, integer *ldh, complex *w, complex *v, complex *b, integer *ldb, real *rwork, real *eps3, real *smlnum, 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 September 30, 1994 Purpose ======= CLAEIN uses inverse iteration to find a right or left eigenvector corresponding to the eigenvalue W of a complex upper Hessenberg matrix H. Arguments ========= RIGHTV (input) LOGICAL = .TRUE. : compute right eigenvector; = .FALSE.: compute left eigenvector. NOINIT (input) LOGICAL = .TRUE. : no initial vector supplied in V = .FALSE.: initial vector supplied in V. N (input) INTEGER The order of the matrix H. N >= 0. H (input) COMPLEX array, dimension (LDH,N) The upper Hessenberg matrix H. LDH (input) INTEGER The leading dimension of the array H. LDH >= max(1,N). W (input) COMPLEX The eigenvalue of H whose corresponding right or left eigenvector is to be computed. V (input/output) COMPLEX array, dimension (N) On entry, if NOINIT = .FALSE., V must contain a starting vector for inverse iteration; otherwise V need not be set. On exit, V contains the computed eigenvector, normalized so that the component of largest magnitude has magnitude 1; here the magnitude of a complex number (x,y) is taken to be |x| + |y|. B (workspace) COMPLEX array, dimension (LDB,N) LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,N). RWORK (workspace) REAL array, dimension (N) EPS3 (input) REAL A small machine-dependent value which is used to perturb close eigenvalues, and to replace zero pivots. SMLNUM (input) REAL A machine-dependent value close to the underflow threshold. INFO (output) INTEGER = 0: successful exit = 1: inverse iteration did not converge; V is set to the last iterate. ===================================================================== Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; /* System generated locals */ integer b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4, i__5; real r__1, r__2, r__3, r__4; complex q__1, q__2; /* Builtin functions */ double sqrt(doublereal), r_imag(complex *); /* Local variables */ static integer ierr; static complex temp; static integer i__, j; static real scale; static complex x; static char trans[1]; static real rtemp, rootn, vnorm; extern doublereal scnrm2_(integer *, complex *, integer *); static complex ei, ej; extern integer icamax_(integer *, complex *, integer *); extern /* Complex */ VOID cladiv_(complex *, complex *, complex *); extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer *), clatrs_(char *, char *, char *, char *, integer *, complex *, integer *, complex *, real *, real *, integer *); extern doublereal scasum_(integer *, complex *, integer *); static char normin[1]; static real nrmsml, growto; static integer its; #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 h___subscr(a_1,a_2) (a_2)*h_dim1 + a_1 #define h___ref(a_1,a_2) h__[h___subscr(a_1,a_2)] h_dim1 = *ldh; h_offset = 1 + h_dim1 * 1; h__ -= h_offset; --v; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; --rwork; /* Function Body */ *info = 0; /* GROWTO is the threshold used in the acceptance test for an eigenvector. */ rootn = sqrt((real) (*n)); growto = .1f / rootn; /* Computing MAX */ r__1 = 1.f, r__2 = *eps3 * rootn; nrmsml = dmax(r__1,r__2) * *smlnum; /* Form B = H - W*I (except that the subdiagonal elements are not stored). */ i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); i__4 = h___subscr(i__, j); b[i__3].r = h__[i__4].r, b[i__3].i = h__[i__4].i; /* L10: */ } i__2 = b_subscr(j, j); i__3 = h___subscr(j, j); q__1.r = h__[i__3].r - w->r, q__1.i = h__[i__3].i - w->i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; /* L20: */ } if (*noinit) { /* Initialize V. */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__; v[i__2].r = *eps3, v[i__2].i = 0.f; /* L30: */ } } else { /* Scale supplied initial vector. */ vnorm = scnrm2_(n, &v[1], &c__1); r__1 = *eps3 * rootn / dmax(vnorm,nrmsml); csscal_(n, &r__1, &v[1], &c__1); } if (*rightv) { /* LU decomposition with partial pivoting of B, replacing zero pivots by EPS3. */ i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = h___subscr(i__ + 1, i__); ei.r = h__[i__2].r, ei.i = h__[i__2].i; i__2 = b_subscr(i__, i__); if ((r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(i__, i__)), dabs(r__2)) < (r__3 = ei.r, dabs(r__3)) + (r__4 = r_imag(&ei), dabs(r__4))) { /* Interchange rows and eliminate. */ cladiv_(&q__1, &b_ref(i__, i__), &ei); x.r = q__1.r, x.i = q__1.i; i__2 = b_subscr(i__, i__); b[i__2].r = ei.r, b[i__2].i = ei.i; i__2 = *n; for (j = i__ + 1; j <= i__2; ++j) { i__3 = b_subscr(i__ + 1, j); temp.r = b[i__3].r, temp.i = b[i__3].i; i__3 = b_subscr(i__ + 1, j); i__4 = b_subscr(i__, j); q__2.r = x.r * temp.r - x.i * temp.i, q__2.i = x.r * temp.i + x.i * temp.r; q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i - q__2.i; b[i__3].r = q__1.r, b[i__3].i = q__1.i; i__3 = b_subscr(i__, j); b[i__3].r = temp.r, b[i__3].i = temp.i; /* L40: */ } } else { /* Eliminate without interchange. */ i__2 = b_subscr(i__, i__); if (b[i__2].r == 0.f && b[i__2].i == 0.f) { i__3 = b_subscr(i__, i__); b[i__3].r = *eps3, b[i__3].i = 0.f; } cladiv_(&q__1, &ei, &b_ref(i__, i__)); x.r = q__1.r, x.i = q__1.i; if (x.r != 0.f || x.i != 0.f) { i__2 = *n; for (j = i__ + 1; j <= i__2; ++j) { i__3 = b_subscr(i__ + 1, j); i__4 = b_subscr(i__ + 1, j); i__5 = b_subscr(i__, j); q__2.r = x.r * b[i__5].r - x.i * b[i__5].i, q__2.i = x.r * b[i__5].i + x.i * b[i__5].r; q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i - q__2.i; b[i__3].r = q__1.r, b[i__3].i = q__1.i; /* L50: */ } } } /* L60: */ } i__1 = b_subscr(*n, *n); if (b[i__1].r == 0.f && b[i__1].i == 0.f) { i__2 = b_subscr(*n, *n); b[i__2].r = *eps3, b[i__2].i = 0.f; } *(unsigned char *)trans = 'N'; } else { /* UL decomposition with partial pivoting of B, replacing zero pivots by EPS3. */ for (j = *n; j >= 2; --j) { i__1 = h___subscr(j, j - 1); ej.r = h__[i__1].r, ej.i = h__[i__1].i; i__1 = b_subscr(j, j); if ((r__1 = b[i__1].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(j, j)), dabs(r__2)) < (r__3 = ej.r, dabs(r__3)) + (r__4 = r_imag( &ej), dabs(r__4))) { /* Interchange columns and eliminate. */ cladiv_(&q__1, &b_ref(j, j), &ej); x.r = q__1.r, x.i = q__1.i; i__1 = b_subscr(j, j); b[i__1].r = ej.r, b[i__1].i = ej.i; i__1 = j - 1; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = b_subscr(i__, j - 1); temp.r = b[i__2].r, temp.i = b[i__2].i; i__2 = b_subscr(i__, j - 1); i__3 = b_subscr(i__, j); q__2.r = x.r * temp.r - x.i * temp.i, q__2.i = x.r * temp.i + x.i * temp.r; q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; i__2 = b_subscr(i__, j); b[i__2].r = temp.r, b[i__2].i = temp.i; /* L70: */ } } else { /* Eliminate without interchange. */ i__1 = b_subscr(j, j); if (b[i__1].r == 0.f && b[i__1].i == 0.f) { i__2 = b_subscr(j, j); b[i__2].r = *eps3, b[i__2].i = 0.f; } cladiv_(&q__1, &ej, &b_ref(j, j)); x.r = q__1.r, x.i = q__1.i; if (x.r != 0.f || x.i != 0.f) { i__1 = j - 1; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = b_subscr(i__, j - 1); i__3 = b_subscr(i__, j - 1); i__4 = b_subscr(i__, j); q__2.r = x.r * b[i__4].r - x.i * b[i__4].i, q__2.i = x.r * b[i__4].i + x.i * b[i__4].r; q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; /* L80: */ } } } /* L90: */ } i__1 = b_subscr(1, 1); if (b[i__1].r == 0.f && b[i__1].i == 0.f) { i__2 = b_subscr(1, 1); b[i__2].r = *eps3, b[i__2].i = 0.f; } *(unsigned char *)trans = 'C'; } *(unsigned char *)normin = 'N'; i__1 = *n; for (its = 1; its <= i__1; ++its) { /* Solve U*x = scale*v for a right eigenvector or U'*x = scale*v for a left eigenvector, overwriting x on v. */ clatrs_("Upper", trans, "Nonunit", normin, n, &b[b_offset], ldb, &v[1] , &scale, &rwork[1], &ierr); *(unsigned char *)normin = 'Y'; /* Test for sufficient growth in the norm of v. */ vnorm = scasum_(n, &v[1], &c__1); if (vnorm >= growto * scale) { goto L120; } /* Choose new orthogonal starting vector and try again. */ rtemp = *eps3 / (rootn + 1.f); v[1].r = *eps3, v[1].i = 0.f; i__2 = *n; for (i__ = 2; i__ <= i__2; ++i__) { i__3 = i__; v[i__3].r = rtemp, v[i__3].i = 0.f; /* L100: */ } i__2 = *n - its + 1; i__3 = *n - its + 1; r__1 = *eps3 * rootn; q__1.r = v[i__3].r - r__1, q__1.i = v[i__3].i; v[i__2].r = q__1.r, v[i__2].i = q__1.i; /* L110: */ } /* Failure to find eigenvector in N iterations. */ *info = 1; L120: /* Normalize eigenvector. */ i__ = icamax_(n, &v[1], &c__1); i__1 = i__; r__3 = 1.f / ((r__1 = v[i__1].r, dabs(r__1)) + (r__2 = r_imag(&v[i__]), dabs(r__2))); csscal_(n, &r__3, &v[1], &c__1); return 0; /* End of CLAEIN */ } /* claein_ */
/* Subroutine */ int ctrmm_(char *side, char *uplo, char *transa, char *diag, integer *m, integer *n, complex *alpha, complex *a, integer *lda, complex *b, integer *ldb) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, i__6; complex q__1, q__2, q__3; /* Builtin functions */ void r_cnjg(complex *, complex *); /* Local variables */ static integer info; static complex temp; static integer i__, j, k; extern logical lsame_(char *, char *); static logical lside; static integer nrowa; static logical upper; extern /* Subroutine */ int xerbla_(char *, integer *); static logical noconj, nounit; #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)] /* Purpose ======= CTRMM performs one of the matrix-matrix operations B := alpha*op( A )*B, or B := alpha*B*op( A ) where alpha is a scalar, B is an m by n matrix, A is a unit, or non-unit, upper or lower triangular matrix and op( A ) is one of op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). Parameters ========== SIDE - CHARACTER*1. On entry, SIDE specifies whether op( A ) multiplies B from the left or right as follows: SIDE = 'L' or 'l' B := alpha*op( A )*B. SIDE = 'R' or 'r' B := alpha*B*op( A ). Unchanged on exit. UPLO - CHARACTER*1. On entry, UPLO specifies whether the matrix A is an upper or lower triangular matrix as follows: UPLO = 'U' or 'u' A is an upper triangular matrix. UPLO = 'L' or 'l' A is a lower triangular matrix. Unchanged on exit. TRANSA - CHARACTER*1. On entry, TRANSA specifies the form of op( A ) to be used in the matrix multiplication as follows: TRANSA = 'N' or 'n' op( A ) = A. TRANSA = 'T' or 't' op( A ) = A'. TRANSA = 'C' or 'c' op( A ) = conjg( A' ). Unchanged on exit. DIAG - CHARACTER*1. On entry, DIAG specifies whether or not A is unit triangular as follows: DIAG = 'U' or 'u' A is assumed to be unit triangular. DIAG = 'N' or 'n' A is not assumed to be unit triangular. Unchanged on exit. M - INTEGER. On entry, M specifies the number of rows of B. M must be at least zero. Unchanged on exit. N - INTEGER. On entry, N specifies the number of columns of B. N must be at least zero. Unchanged on exit. ALPHA - COMPLEX . On entry, ALPHA specifies the scalar alpha. When alpha is zero then A is not referenced and B need not be set before entry. Unchanged on exit. A - COMPLEX array of DIMENSION ( LDA, k ), where k is m when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. Before entry with UPLO = 'U' or 'u', the leading k by k upper triangular part of the array A must contain the upper triangular matrix and the strictly lower triangular part of A is not referenced. Before entry with UPLO = 'L' or 'l', the leading k by k lower triangular part of the array A must contain the lower triangular matrix and the strictly upper triangular part of A is not referenced. Note that when DIAG = 'U' or 'u', the diagonal elements of A are not referenced either, but are assumed to be unity. Unchanged on exit. LDA - INTEGER. On entry, LDA specifies the first dimension of A as declared in the calling (sub) program. When SIDE = 'L' or 'l' then LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' then LDA must be at least max( 1, n ). Unchanged on exit. B - COMPLEX array of DIMENSION ( LDB, n ). Before entry, the leading m by n part of the array B must contain the matrix B, and on exit is overwritten by the transformed matrix. LDB - INTEGER. On entry, LDB specifies the first dimension of B as declared in the calling (sub) program. LDB must be at least max( 1, m ). Unchanged on exit. Level 3 Blas routine. -- Written on 8-February-1989. Jack Dongarra, Argonne National Laboratory. Iain Duff, AERE Harwell. Jeremy Du Croz, Numerical Algorithms Group Ltd. Sven Hammarling, Numerical Algorithms Group Ltd. Test the input parameters. 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; /* Function Body */ lside = lsame_(side, "L"); if (lside) { nrowa = *m; } else { nrowa = *n; } noconj = lsame_(transa, "T"); nounit = lsame_(diag, "N"); upper = lsame_(uplo, "U"); info = 0; if (! lside && ! lsame_(side, "R")) { info = 1; } else if (! upper && ! lsame_(uplo, "L")) { info = 2; } else if (! lsame_(transa, "N") && ! lsame_(transa, "T") && ! lsame_(transa, "C")) { info = 3; } else if (! lsame_(diag, "U") && ! lsame_(diag, "N")) { info = 4; } else if (*m < 0) { info = 5; } else if (*n < 0) { info = 6; } else if (*lda < max(1,nrowa)) { info = 9; } else if (*ldb < max(1,*m)) { info = 11; } if (info != 0) { xerbla_("CTRMM ", &info); return 0; } /* Quick return if possible. */ if (*n == 0) { return 0; } /* And when alpha.eq.zero. */ if (alpha->r == 0.f && alpha->i == 0.f) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); b[i__3].r = 0.f, b[i__3].i = 0.f; /* L10: */ } /* L20: */ } return 0; } /* Start the operations. */ if (lside) { if (lsame_(transa, "N")) { /* Form B := alpha*A*B. */ if (upper) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (k = 1; k <= i__2; ++k) { i__3 = b_subscr(k, j); if (b[i__3].r != 0.f || b[i__3].i != 0.f) { i__3 = b_subscr(k, j); q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3] .i, q__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3].r; temp.r = q__1.r, temp.i = q__1.i; i__3 = k - 1; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = b_subscr(i__, j); i__5 = b_subscr(i__, j); i__6 = a_subscr(i__, k); q__2.r = temp.r * a[i__6].r - temp.i * a[i__6] .i, q__2.i = temp.r * a[i__6].i + temp.i * a[i__6].r; q__1.r = b[i__5].r + q__2.r, q__1.i = b[i__5] .i + q__2.i; b[i__4].r = q__1.r, b[i__4].i = q__1.i; /* L30: */ } if (nounit) { i__3 = a_subscr(k, k); q__1.r = temp.r * a[i__3].r - temp.i * a[i__3] .i, q__1.i = temp.r * a[i__3].i + temp.i * a[i__3].r; temp.r = q__1.r, temp.i = q__1.i; } i__3 = b_subscr(k, j); b[i__3].r = temp.r, b[i__3].i = temp.i; } /* L40: */ } /* L50: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { for (k = *m; k >= 1; --k) { i__2 = b_subscr(k, j); if (b[i__2].r != 0.f || b[i__2].i != 0.f) { i__2 = b_subscr(k, j); q__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2] .i, q__1.i = alpha->r * b[i__2].i + alpha->i * b[i__2].r; temp.r = q__1.r, temp.i = q__1.i; i__2 = b_subscr(k, j); b[i__2].r = temp.r, b[i__2].i = temp.i; if (nounit) { i__2 = b_subscr(k, j); i__3 = b_subscr(k, j); i__4 = a_subscr(k, k); q__1.r = b[i__3].r * a[i__4].r - b[i__3].i * a[i__4].i, q__1.i = b[i__3].r * a[ i__4].i + b[i__3].i * a[i__4].r; b[i__2].r = q__1.r, b[i__2].i = q__1.i; } i__2 = *m; for (i__ = k + 1; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); i__4 = b_subscr(i__, j); i__5 = a_subscr(i__, k); q__2.r = temp.r * a[i__5].r - temp.i * a[i__5] .i, q__2.i = temp.r * a[i__5].i + temp.i * a[i__5].r; q__1.r = b[i__4].r + q__2.r, q__1.i = b[i__4] .i + q__2.i; b[i__3].r = q__1.r, b[i__3].i = q__1.i; /* L60: */ } } /* L70: */ } /* L80: */ } } } else { /* Form B := alpha*A'*B or B := alpha*conjg( A' )*B. */ if (upper) { i__1 = *n; for (j = 1; j <= i__1; ++j) { for (i__ = *m; i__ >= 1; --i__) { i__2 = b_subscr(i__, j); temp.r = b[i__2].r, temp.i = b[i__2].i; if (noconj) { if (nounit) { i__2 = a_subscr(i__, i__); q__1.r = temp.r * a[i__2].r - temp.i * a[i__2] .i, q__1.i = temp.r * a[i__2].i + temp.i * a[i__2].r; temp.r = q__1.r, temp.i = q__1.i; } i__2 = i__ - 1; for (k = 1; k <= i__2; ++k) { i__3 = a_subscr(k, i__); i__4 = b_subscr(k, j); q__2.r = a[i__3].r * b[i__4].r - a[i__3].i * b[i__4].i, q__2.i = a[i__3].r * b[ i__4].i + a[i__3].i * b[i__4].r; q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i; temp.r = q__1.r, temp.i = q__1.i; /* L90: */ } } else { if (nounit) { r_cnjg(&q__2, &a_ref(i__, i__)); q__1.r = temp.r * q__2.r - temp.i * q__2.i, q__1.i = temp.r * q__2.i + temp.i * q__2.r; temp.r = q__1.r, temp.i = q__1.i; } i__2 = i__ - 1; for (k = 1; k <= i__2; ++k) { r_cnjg(&q__3, &a_ref(k, i__)); i__3 = b_subscr(k, j); q__2.r = q__3.r * b[i__3].r - q__3.i * b[i__3] .i, q__2.i = q__3.r * b[i__3].i + q__3.i * b[i__3].r; q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i; temp.r = q__1.r, temp.i = q__1.i; /* L100: */ } } i__2 = b_subscr(i__, j); q__1.r = alpha->r * temp.r - alpha->i * temp.i, q__1.i = alpha->r * temp.i + alpha->i * temp.r; b[i__2].r = q__1.r, b[i__2].i = q__1.i; /* L110: */ } /* L120: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); temp.r = b[i__3].r, temp.i = b[i__3].i; if (noconj) { if (nounit) { i__3 = a_subscr(i__, i__); q__1.r = temp.r * a[i__3].r - temp.i * a[i__3] .i, q__1.i = temp.r * a[i__3].i + temp.i * a[i__3].r; temp.r = q__1.r, temp.i = q__1.i; } i__3 = *m; for (k = i__ + 1; k <= i__3; ++k) { i__4 = a_subscr(k, i__); i__5 = b_subscr(k, j); q__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5].i, q__2.i = a[i__4].r * b[ i__5].i + a[i__4].i * b[i__5].r; q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i; temp.r = q__1.r, temp.i = q__1.i; /* L130: */ } } else { if (nounit) { r_cnjg(&q__2, &a_ref(i__, i__)); q__1.r = temp.r * q__2.r - temp.i * q__2.i, q__1.i = temp.r * q__2.i + temp.i * q__2.r; temp.r = q__1.r, temp.i = q__1.i; } i__3 = *m; for (k = i__ + 1; k <= i__3; ++k) { r_cnjg(&q__3, &a_ref(k, i__)); i__4 = b_subscr(k, j); q__2.r = q__3.r * b[i__4].r - q__3.i * b[i__4] .i, q__2.i = q__3.r * b[i__4].i + q__3.i * b[i__4].r; q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i; temp.r = q__1.r, temp.i = q__1.i; /* L140: */ } } i__3 = b_subscr(i__, j); q__1.r = alpha->r * temp.r - alpha->i * temp.i, q__1.i = alpha->r * temp.i + alpha->i * temp.r; b[i__3].r = q__1.r, b[i__3].i = q__1.i; /* L150: */ } /* L160: */ } } } } else { if (lsame_(transa, "N")) { /* Form B := alpha*B*A. */ if (upper) { for (j = *n; j >= 1; --j) { temp.r = alpha->r, temp.i = alpha->i; if (nounit) { i__1 = a_subscr(j, j); q__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i, q__1.i = temp.r * a[i__1].i + temp.i * a[i__1] .r; temp.r = q__1.r, temp.i = q__1.i; } i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = b_subscr(i__, j); i__3 = b_subscr(i__, j); q__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i, q__1.i = temp.r * b[i__3].i + temp.i * b[i__3] .r; b[i__2].r = q__1.r, b[i__2].i = q__1.i; /* L170: */ } i__1 = j - 1; for (k = 1; k <= i__1; ++k) { i__2 = a_subscr(k, j); if (a[i__2].r != 0.f || a[i__2].i != 0.f) { i__2 = a_subscr(k, j); q__1.r = alpha->r * a[i__2].r - alpha->i * a[i__2] .i, q__1.i = alpha->r * a[i__2].i + alpha->i * a[i__2].r; temp.r = q__1.r, temp.i = q__1.i; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); i__4 = b_subscr(i__, j); i__5 = b_subscr(i__, k); q__2.r = temp.r * b[i__5].r - temp.i * b[i__5] .i, q__2.i = temp.r * b[i__5].i + temp.i * b[i__5].r; q__1.r = b[i__4].r + q__2.r, q__1.i = b[i__4] .i + q__2.i; b[i__3].r = q__1.r, b[i__3].i = q__1.i; /* L180: */ } } /* L190: */ } /* L200: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { temp.r = alpha->r, temp.i = alpha->i; if (nounit) { i__2 = a_subscr(j, j); q__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i, q__1.i = temp.r * a[i__2].i + temp.i * a[i__2] .r; temp.r = q__1.r, temp.i = q__1.i; } i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); i__4 = b_subscr(i__, j); q__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i, q__1.i = temp.r * b[i__4].i + temp.i * b[i__4] .r; b[i__3].r = q__1.r, b[i__3].i = q__1.i; /* L210: */ } i__2 = *n; for (k = j + 1; k <= i__2; ++k) { i__3 = a_subscr(k, j); if (a[i__3].r != 0.f || a[i__3].i != 0.f) { i__3 = a_subscr(k, j); q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3] .i, q__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3].r; temp.r = q__1.r, temp.i = q__1.i; i__3 = *m; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = b_subscr(i__, j); i__5 = b_subscr(i__, j); i__6 = b_subscr(i__, k); q__2.r = temp.r * b[i__6].r - temp.i * b[i__6] .i, q__2.i = temp.r * b[i__6].i + temp.i * b[i__6].r; q__1.r = b[i__5].r + q__2.r, q__1.i = b[i__5] .i + q__2.i; b[i__4].r = q__1.r, b[i__4].i = q__1.i; /* L220: */ } } /* L230: */ } /* L240: */ } } } else { /* Form B := alpha*B*A' or B := alpha*B*conjg( A' ). */ if (upper) { i__1 = *n; for (k = 1; k <= i__1; ++k) { i__2 = k - 1; for (j = 1; j <= i__2; ++j) { i__3 = a_subscr(j, k); if (a[i__3].r != 0.f || a[i__3].i != 0.f) { if (noconj) { i__3 = a_subscr(j, k); q__1.r = alpha->r * a[i__3].r - alpha->i * a[ i__3].i, q__1.i = alpha->r * a[i__3] .i + alpha->i * a[i__3].r; temp.r = q__1.r, temp.i = q__1.i; } else { r_cnjg(&q__2, &a_ref(j, k)); q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i = alpha->r * q__2.i + alpha->i * q__2.r; temp.r = q__1.r, temp.i = q__1.i; } i__3 = *m; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = b_subscr(i__, j); i__5 = b_subscr(i__, j); i__6 = b_subscr(i__, k); q__2.r = temp.r * b[i__6].r - temp.i * b[i__6] .i, q__2.i = temp.r * b[i__6].i + temp.i * b[i__6].r; q__1.r = b[i__5].r + q__2.r, q__1.i = b[i__5] .i + q__2.i; b[i__4].r = q__1.r, b[i__4].i = q__1.i; /* L250: */ } } /* L260: */ } temp.r = alpha->r, temp.i = alpha->i; if (nounit) { if (noconj) { i__2 = a_subscr(k, k); q__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i, q__1.i = temp.r * a[i__2].i + temp.i * a[ i__2].r; temp.r = q__1.r, temp.i = q__1.i; } else { r_cnjg(&q__2, &a_ref(k, k)); q__1.r = temp.r * q__2.r - temp.i * q__2.i, q__1.i = temp.r * q__2.i + temp.i * q__2.r; temp.r = q__1.r, temp.i = q__1.i; } } if (temp.r != 1.f || temp.i != 0.f) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, k); i__4 = b_subscr(i__, k); q__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i, q__1.i = temp.r * b[i__4].i + temp.i * b[ i__4].r; b[i__3].r = q__1.r, b[i__3].i = q__1.i; /* L270: */ } } /* L280: */ } } else { for (k = *n; k >= 1; --k) { i__1 = *n; for (j = k + 1; j <= i__1; ++j) { i__2 = a_subscr(j, k); if (a[i__2].r != 0.f || a[i__2].i != 0.f) { if (noconj) { i__2 = a_subscr(j, k); q__1.r = alpha->r * a[i__2].r - alpha->i * a[ i__2].i, q__1.i = alpha->r * a[i__2] .i + alpha->i * a[i__2].r; temp.r = q__1.r, temp.i = q__1.i; } else { r_cnjg(&q__2, &a_ref(j, k)); q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i = alpha->r * q__2.i + alpha->i * q__2.r; temp.r = q__1.r, temp.i = q__1.i; } i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); i__4 = b_subscr(i__, j); i__5 = b_subscr(i__, k); q__2.r = temp.r * b[i__5].r - temp.i * b[i__5] .i, q__2.i = temp.r * b[i__5].i + temp.i * b[i__5].r; q__1.r = b[i__4].r + q__2.r, q__1.i = b[i__4] .i + q__2.i; b[i__3].r = q__1.r, b[i__3].i = q__1.i; /* L290: */ } } /* L300: */ } temp.r = alpha->r, temp.i = alpha->i; if (nounit) { if (noconj) { i__1 = a_subscr(k, k); q__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i, q__1.i = temp.r * a[i__1].i + temp.i * a[ i__1].r; temp.r = q__1.r, temp.i = q__1.i; } else { r_cnjg(&q__2, &a_ref(k, k)); q__1.r = temp.r * q__2.r - temp.i * q__2.i, q__1.i = temp.r * q__2.i + temp.i * q__2.r; temp.r = q__1.r, temp.i = q__1.i; } } if (temp.r != 1.f || temp.i != 0.f) { i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = b_subscr(i__, k); i__3 = b_subscr(i__, k); q__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i, q__1.i = temp.r * b[i__3].i + temp.i * b[ i__3].r; b[i__2].r = q__1.r, b[i__2].i = q__1.i; /* L310: */ } } /* L320: */ } } } } return 0; /* End of CTRMM . */ } /* ctrmm_ */
/* Subroutine */ int zerrec_(char *path, integer *nunit) { /* Format strings */ static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e" "rror exits (\002,i3,\002 tests done)\002)"; static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes" "ts of the error \002,\002exits ***\002)"; /* System generated locals */ integer i__1; /* Builtin functions Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); /* Local variables */ static integer info, ifst, ilst; static doublecomplex work[24], a[16] /* was [4][4] */, b[16] /* was [4][4] */, c__[16] /* was [4][4] */; static integer i__, j, m; static doublereal s[4], scale; static doublecomplex x[4]; static integer nt; static doublereal rw[24]; extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical *, logical *), ztrexc_(char *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, integer *, integer *), ztrsna_(char *, char *, logical *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublereal *, doublereal *, integer *, integer *, doublecomplex *, integer *, doublereal *, integer *), ztrsen_(char *, char *, logical *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublereal *, doublereal *, doublecomplex *, integer *, integer *), ztrsyl_( char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublereal *, integer *); static logical sel[4]; static doublereal sep[4]; /* Fortran I/O blocks */ static cilist io___18 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___19 = { 0, 0, 0, fmt_9998, 0 }; #define a_subscr(a_1,a_2) (a_2)*4 + a_1 - 5 #define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)] #define b_subscr(a_1,a_2) (a_2)*4 + a_1 - 5 #define b_ref(a_1,a_2) b[b_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 ======= ZERREC tests the error exits for the routines for eigen- condition estimation for DOUBLE PRECISION matrices: ZTRSYL, CTREXC, CTRSNA and CTRSEN. Arguments ========= PATH (input) CHARACTER*3 The LAPACK path name for the routines to be tested. NUNIT (input) INTEGER The unit number for output. ===================================================================== */ infoc_1.nout = *nunit; infoc_1.ok = TRUE_; nt = 0; /* Initialize A, B and SEL */ for (j = 1; j <= 4; ++j) { for (i__ = 1; i__ <= 4; ++i__) { i__1 = a_subscr(i__, j); a[i__1].r = 0., a[i__1].i = 0.; i__1 = b_subscr(i__, j); b[i__1].r = 0., b[i__1].i = 0.; /* L10: */ } /* L20: */ } for (i__ = 1; i__ <= 4; ++i__) { i__1 = a_subscr(i__, i__); a[i__1].r = 1., a[i__1].i = 0.; sel[i__ - 1] = TRUE_; /* L30: */ } /* Test ZTRSYL */ s_copy(srnamc_1.srnamt, "ZTRSYL", (ftnlen)6, (ftnlen)6); infoc_1.infot = 1; ztrsyl_("X", "N", &c__1, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, & scale, &info); chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; ztrsyl_("N", "X", &c__1, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, & scale, &info); chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; ztrsyl_("N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, & scale, &info); chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; ztrsyl_("N", "N", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, c__, &c__1, & scale, &info); chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; ztrsyl_("N", "N", &c__1, &c__0, &c_n1, a, &c__1, b, &c__1, c__, &c__1, & scale, &info); chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 7; ztrsyl_("N", "N", &c__1, &c__2, &c__0, a, &c__1, b, &c__1, c__, &c__2, & scale, &info); chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 9; ztrsyl_("N", "N", &c__1, &c__0, &c__2, a, &c__1, b, &c__1, c__, &c__1, & scale, &info); chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 11; ztrsyl_("N", "N", &c__1, &c__2, &c__0, a, &c__2, b, &c__1, c__, &c__1, & scale, &info); chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); nt += 8; /* Test ZTREXC */ s_copy(srnamc_1.srnamt, "ZTREXC", (ftnlen)6, (ftnlen)6); ifst = 1; ilst = 1; infoc_1.infot = 1; ztrexc_("X", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info); chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 7; ztrexc_("N", &c__0, a, &c__1, b, &c__1, &ifst, &ilst, &info); chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; ilst = 2; ztrexc_("N", &c__2, a, &c__1, b, &c__1, &ifst, &ilst, &info); chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 6; ztrexc_("V", &c__2, a, &c__2, b, &c__1, &ifst, &ilst, &info); chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 7; ifst = 0; ilst = 1; ztrexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info); chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 7; ifst = 2; ztrexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info); chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 8; ifst = 1; ilst = 0; ztrexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info); chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 8; ilst = 2; ztrexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info); chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); nt += 8; /* Test ZTRSNA */ s_copy(srnamc_1.srnamt, "ZTRSNA", (ftnlen)6, (ftnlen)6); infoc_1.infot = 1; ztrsna_("X", "A", sel, &c__0, a, &c__1, b, &c__1, c__, &c__1, s, sep, & c__1, &m, work, &c__1, rw, &info); chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; ztrsna_("B", "X", sel, &c__0, a, &c__1, b, &c__1, c__, &c__1, s, sep, & c__1, &m, work, &c__1, rw, &info); chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; ztrsna_("B", "A", sel, &c_n1, a, &c__1, b, &c__1, c__, &c__1, s, sep, & c__1, &m, work, &c__1, rw, &info); chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 6; ztrsna_("V", "A", sel, &c__2, a, &c__1, b, &c__1, c__, &c__1, s, sep, & c__2, &m, work, &c__2, rw, &info); chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 8; ztrsna_("B", "A", sel, &c__2, a, &c__2, b, &c__1, c__, &c__2, s, sep, & c__2, &m, work, &c__2, rw, &info); chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 10; ztrsna_("B", "A", sel, &c__2, a, &c__2, b, &c__2, c__, &c__1, s, sep, & c__2, &m, work, &c__2, rw, &info); chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 13; ztrsna_("B", "A", sel, &c__1, a, &c__1, b, &c__1, c__, &c__1, s, sep, & c__0, &m, work, &c__1, rw, &info); chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 13; ztrsna_("B", "S", sel, &c__2, a, &c__2, b, &c__2, c__, &c__2, s, sep, & c__1, &m, work, &c__1, rw, &info); chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 16; ztrsna_("B", "A", sel, &c__2, a, &c__2, b, &c__2, c__, &c__2, s, sep, & c__2, &m, work, &c__1, rw, &info); chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); nt += 9; /* Test ZTRSEN */ sel[0] = FALSE_; s_copy(srnamc_1.srnamt, "ZTRSEN", (ftnlen)6, (ftnlen)6); infoc_1.infot = 1; ztrsen_("X", "N", sel, &c__0, a, &c__1, b, &c__1, x, &m, s, sep, work, & c__1, &info); chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; ztrsen_("N", "X", sel, &c__0, a, &c__1, b, &c__1, x, &m, s, sep, work, & c__1, &info); chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; ztrsen_("N", "N", sel, &c_n1, a, &c__1, b, &c__1, x, &m, s, sep, work, & c__1, &info); chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 6; ztrsen_("N", "N", sel, &c__2, a, &c__1, b, &c__1, x, &m, s, sep, work, & c__2, &info); chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 8; ztrsen_("N", "V", sel, &c__2, a, &c__2, b, &c__1, x, &m, s, sep, work, & c__1, &info); chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 14; ztrsen_("N", "V", sel, &c__2, a, &c__2, b, &c__2, x, &m, s, sep, work, & c__0, &info); chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 14; ztrsen_("E", "V", sel, &c__3, a, &c__3, b, &c__3, x, &m, s, sep, work, & c__1, &info); chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 14; ztrsen_("V", "V", sel, &c__3, a, &c__3, b, &c__3, x, &m, s, sep, work, & c__3, &info); chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); nt += 8; /* Print a summary line. */ if (infoc_1.ok) { io___18.ciunit = infoc_1.nout; s_wsfe(&io___18); do_fio(&c__1, path, (ftnlen)3); do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer)); e_wsfe(); } else { io___19.ciunit = infoc_1.nout; s_wsfe(&io___19); do_fio(&c__1, path, (ftnlen)3); e_wsfe(); } return 0; /* End of ZERREC */ } /* zerrec_ */
/* Subroutine */ int clagtm_(char *trans, integer *n, integer *nrhs, real * alpha, complex *dl, complex *d__, complex *du, complex *x, integer * ldx, real *beta, complex *b, integer *ldb) { /* -- LAPACK auxiliary routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University October 31, 1992 Purpose ======= CLAGTM performs a matrix-vector product of the form B := alpha * A * X + beta * B where A is a tridiagonal matrix of order N, B and X are N by NRHS matrices, and alpha and beta are real scalars, each of which may be 0., 1., or -1. Arguments ========= TRANS (input) CHARACTER Specifies the operation applied to A. = 'N': No transpose, B := alpha * A * X + beta * B = 'T': Transpose, B := alpha * A**T * X + beta * B = 'C': Conjugate transpose, B := alpha * A**H * X + beta * B N (input) INTEGER The order of the matrix A. N >= 0. NRHS (input) INTEGER The number of right hand sides, i.e., the number of columns of the matrices X and B. ALPHA (input) REAL The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise, it is assumed to be 0. DL (input) COMPLEX array, dimension (N-1) The (n-1) sub-diagonal elements of T. D (input) COMPLEX array, dimension (N) The diagonal elements of T. DU (input) COMPLEX array, dimension (N-1) The (n-1) super-diagonal elements of T. X (input) COMPLEX array, dimension (LDX,NRHS) The N by NRHS matrix X. LDX (input) INTEGER The leading dimension of the array X. LDX >= max(N,1). BETA (input) REAL The scalar beta. BETA must be 0., 1., or -1.; otherwise, it is assumed to be 1. B (input/output) COMPLEX array, dimension (LDB,NRHS) On entry, the N by NRHS matrix B. On exit, B is overwritten by the matrix expression B := alpha * A * X + beta * B. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(N,1). ===================================================================== Parameter adjustments */ /* System generated locals */ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10; complex q__1, q__2, q__3, q__4, q__5, q__6, q__7, q__8, q__9; /* Builtin functions */ void r_cnjg(complex *, complex *); /* Local variables */ static integer i__, j; extern logical lsame_(char *, char *); #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 x_subscr(a_1,a_2) (a_2)*x_dim1 + a_1 #define x_ref(a_1,a_2) x[x_subscr(a_1,a_2)] --dl; --d__; --du; x_dim1 = *ldx; x_offset = 1 + x_dim1 * 1; x -= x_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; /* Function Body */ if (*n == 0) { return 0; } /* Multiply B by BETA if BETA.NE.1. */ if (*beta == 0.f) { i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); b[i__3].r = 0.f, b[i__3].i = 0.f; /* L10: */ } /* L20: */ } } else if (*beta == -1.f) { i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); i__4 = b_subscr(i__, j); q__1.r = -b[i__4].r, q__1.i = -b[i__4].i; b[i__3].r = q__1.r, b[i__3].i = q__1.i; /* L30: */ } /* L40: */ } } if (*alpha == 1.f) { if (lsame_(trans, "N")) { /* Compute B := B + A*X */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { if (*n == 1) { i__2 = b_subscr(1, j); i__3 = b_subscr(1, j); i__4 = x_subscr(1, j); q__2.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i, q__2.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4] .r; q__1.r = b[i__3].r + q__2.r, q__1.i = b[i__3].i + q__2.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; } else { i__2 = b_subscr(1, j); i__3 = b_subscr(1, j); i__4 = x_subscr(1, j); q__3.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i, q__3.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4] .r; q__2.r = b[i__3].r + q__3.r, q__2.i = b[i__3].i + q__3.i; i__5 = x_subscr(2, j); q__4.r = du[1].r * x[i__5].r - du[1].i * x[i__5].i, q__4.i = du[1].r * x[i__5].i + du[1].i * x[i__5] .r; q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; i__2 = b_subscr(*n, j); i__3 = b_subscr(*n, j); i__4 = *n - 1; i__5 = x_subscr(*n - 1, j); q__3.r = dl[i__4].r * x[i__5].r - dl[i__4].i * x[i__5].i, q__3.i = dl[i__4].r * x[i__5].i + dl[i__4].i * x[ i__5].r; q__2.r = b[i__3].r + q__3.r, q__2.i = b[i__3].i + q__3.i; i__6 = *n; i__7 = x_subscr(*n, j); q__4.r = d__[i__6].r * x[i__7].r - d__[i__6].i * x[i__7] .i, q__4.i = d__[i__6].r * x[i__7].i + d__[i__6] .i * x[i__7].r; q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; i__2 = *n - 1; for (i__ = 2; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); i__4 = b_subscr(i__, j); i__5 = i__ - 1; i__6 = x_subscr(i__ - 1, j); q__4.r = dl[i__5].r * x[i__6].r - dl[i__5].i * x[i__6] .i, q__4.i = dl[i__5].r * x[i__6].i + dl[i__5] .i * x[i__6].r; q__3.r = b[i__4].r + q__4.r, q__3.i = b[i__4].i + q__4.i; i__7 = i__; i__8 = x_subscr(i__, j); q__5.r = d__[i__7].r * x[i__8].r - d__[i__7].i * x[ i__8].i, q__5.i = d__[i__7].r * x[i__8].i + d__[i__7].i * x[i__8].r; q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i; i__9 = i__; i__10 = x_subscr(i__ + 1, j); q__6.r = du[i__9].r * x[i__10].r - du[i__9].i * x[ i__10].i, q__6.i = du[i__9].r * x[i__10].i + du[i__9].i * x[i__10].r; q__1.r = q__2.r + q__6.r, q__1.i = q__2.i + q__6.i; b[i__3].r = q__1.r, b[i__3].i = q__1.i; /* L50: */ } } /* L60: */ } } else if (lsame_(trans, "T")) { /* Compute B := B + A**T * X */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { if (*n == 1) { i__2 = b_subscr(1, j); i__3 = b_subscr(1, j); i__4 = x_subscr(1, j); q__2.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i, q__2.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4] .r; q__1.r = b[i__3].r + q__2.r, q__1.i = b[i__3].i + q__2.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; } else { i__2 = b_subscr(1, j); i__3 = b_subscr(1, j); i__4 = x_subscr(1, j); q__3.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i, q__3.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4] .r; q__2.r = b[i__3].r + q__3.r, q__2.i = b[i__3].i + q__3.i; i__5 = x_subscr(2, j); q__4.r = dl[1].r * x[i__5].r - dl[1].i * x[i__5].i, q__4.i = dl[1].r * x[i__5].i + dl[1].i * x[i__5] .r; q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; i__2 = b_subscr(*n, j); i__3 = b_subscr(*n, j); i__4 = *n - 1; i__5 = x_subscr(*n - 1, j); q__3.r = du[i__4].r * x[i__5].r - du[i__4].i * x[i__5].i, q__3.i = du[i__4].r * x[i__5].i + du[i__4].i * x[ i__5].r; q__2.r = b[i__3].r + q__3.r, q__2.i = b[i__3].i + q__3.i; i__6 = *n; i__7 = x_subscr(*n, j); q__4.r = d__[i__6].r * x[i__7].r - d__[i__6].i * x[i__7] .i, q__4.i = d__[i__6].r * x[i__7].i + d__[i__6] .i * x[i__7].r; q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; i__2 = *n - 1; for (i__ = 2; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); i__4 = b_subscr(i__, j); i__5 = i__ - 1; i__6 = x_subscr(i__ - 1, j); q__4.r = du[i__5].r * x[i__6].r - du[i__5].i * x[i__6] .i, q__4.i = du[i__5].r * x[i__6].i + du[i__5] .i * x[i__6].r; q__3.r = b[i__4].r + q__4.r, q__3.i = b[i__4].i + q__4.i; i__7 = i__; i__8 = x_subscr(i__, j); q__5.r = d__[i__7].r * x[i__8].r - d__[i__7].i * x[ i__8].i, q__5.i = d__[i__7].r * x[i__8].i + d__[i__7].i * x[i__8].r; q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i; i__9 = i__; i__10 = x_subscr(i__ + 1, j); q__6.r = dl[i__9].r * x[i__10].r - dl[i__9].i * x[ i__10].i, q__6.i = dl[i__9].r * x[i__10].i + dl[i__9].i * x[i__10].r; q__1.r = q__2.r + q__6.r, q__1.i = q__2.i + q__6.i; b[i__3].r = q__1.r, b[i__3].i = q__1.i; /* L70: */ } } /* L80: */ } } else if (lsame_(trans, "C")) { /* Compute B := B + A**H * X */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { if (*n == 1) { i__2 = b_subscr(1, j); i__3 = b_subscr(1, j); r_cnjg(&q__3, &d__[1]); i__4 = x_subscr(1, j); q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i = q__3.r * x[i__4].i + q__3.i * x[i__4].r; q__1.r = b[i__3].r + q__2.r, q__1.i = b[i__3].i + q__2.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; } else { i__2 = b_subscr(1, j); i__3 = b_subscr(1, j); r_cnjg(&q__4, &d__[1]); i__4 = x_subscr(1, j); q__3.r = q__4.r * x[i__4].r - q__4.i * x[i__4].i, q__3.i = q__4.r * x[i__4].i + q__4.i * x[i__4].r; q__2.r = b[i__3].r + q__3.r, q__2.i = b[i__3].i + q__3.i; r_cnjg(&q__6, &dl[1]); i__5 = x_subscr(2, j); q__5.r = q__6.r * x[i__5].r - q__6.i * x[i__5].i, q__5.i = q__6.r * x[i__5].i + q__6.i * x[i__5].r; q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; i__2 = b_subscr(*n, j); i__3 = b_subscr(*n, j); r_cnjg(&q__4, &du[*n - 1]); i__4 = x_subscr(*n - 1, j); q__3.r = q__4.r * x[i__4].r - q__4.i * x[i__4].i, q__3.i = q__4.r * x[i__4].i + q__4.i * x[i__4].r; q__2.r = b[i__3].r + q__3.r, q__2.i = b[i__3].i + q__3.i; r_cnjg(&q__6, &d__[*n]); i__5 = x_subscr(*n, j); q__5.r = q__6.r * x[i__5].r - q__6.i * x[i__5].i, q__5.i = q__6.r * x[i__5].i + q__6.i * x[i__5].r; q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; i__2 = *n - 1; for (i__ = 2; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); i__4 = b_subscr(i__, j); r_cnjg(&q__5, &du[i__ - 1]); i__5 = x_subscr(i__ - 1, j); q__4.r = q__5.r * x[i__5].r - q__5.i * x[i__5].i, q__4.i = q__5.r * x[i__5].i + q__5.i * x[i__5] .r; q__3.r = b[i__4].r + q__4.r, q__3.i = b[i__4].i + q__4.i; r_cnjg(&q__7, &d__[i__]); i__6 = x_subscr(i__, j); q__6.r = q__7.r * x[i__6].r - q__7.i * x[i__6].i, q__6.i = q__7.r * x[i__6].i + q__7.i * x[i__6] .r; q__2.r = q__3.r + q__6.r, q__2.i = q__3.i + q__6.i; r_cnjg(&q__9, &dl[i__]); i__7 = x_subscr(i__ + 1, j); q__8.r = q__9.r * x[i__7].r - q__9.i * x[i__7].i, q__8.i = q__9.r * x[i__7].i + q__9.i * x[i__7] .r; q__1.r = q__2.r + q__8.r, q__1.i = q__2.i + q__8.i; b[i__3].r = q__1.r, b[i__3].i = q__1.i; /* L90: */ } } /* L100: */ } } } else if (*alpha == -1.f) { if (lsame_(trans, "N")) { /* Compute B := B - A*X */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { if (*n == 1) { i__2 = b_subscr(1, j); i__3 = b_subscr(1, j); i__4 = x_subscr(1, j); q__2.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i, q__2.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4] .r; q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; } else { i__2 = b_subscr(1, j); i__3 = b_subscr(1, j); i__4 = x_subscr(1, j); q__3.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i, q__3.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4] .r; q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i; i__5 = x_subscr(2, j); q__4.r = du[1].r * x[i__5].r - du[1].i * x[i__5].i, q__4.i = du[1].r * x[i__5].i + du[1].i * x[i__5] .r; q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; i__2 = b_subscr(*n, j); i__3 = b_subscr(*n, j); i__4 = *n - 1; i__5 = x_subscr(*n - 1, j); q__3.r = dl[i__4].r * x[i__5].r - dl[i__4].i * x[i__5].i, q__3.i = dl[i__4].r * x[i__5].i + dl[i__4].i * x[ i__5].r; q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i; i__6 = *n; i__7 = x_subscr(*n, j); q__4.r = d__[i__6].r * x[i__7].r - d__[i__6].i * x[i__7] .i, q__4.i = d__[i__6].r * x[i__7].i + d__[i__6] .i * x[i__7].r; q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; i__2 = *n - 1; for (i__ = 2; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); i__4 = b_subscr(i__, j); i__5 = i__ - 1; i__6 = x_subscr(i__ - 1, j); q__4.r = dl[i__5].r * x[i__6].r - dl[i__5].i * x[i__6] .i, q__4.i = dl[i__5].r * x[i__6].i + dl[i__5] .i * x[i__6].r; q__3.r = b[i__4].r - q__4.r, q__3.i = b[i__4].i - q__4.i; i__7 = i__; i__8 = x_subscr(i__, j); q__5.r = d__[i__7].r * x[i__8].r - d__[i__7].i * x[ i__8].i, q__5.i = d__[i__7].r * x[i__8].i + d__[i__7].i * x[i__8].r; q__2.r = q__3.r - q__5.r, q__2.i = q__3.i - q__5.i; i__9 = i__; i__10 = x_subscr(i__ + 1, j); q__6.r = du[i__9].r * x[i__10].r - du[i__9].i * x[ i__10].i, q__6.i = du[i__9].r * x[i__10].i + du[i__9].i * x[i__10].r; q__1.r = q__2.r - q__6.r, q__1.i = q__2.i - q__6.i; b[i__3].r = q__1.r, b[i__3].i = q__1.i; /* L110: */ } } /* L120: */ } } else if (lsame_(trans, "T")) { /* Compute B := B - A'*X */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { if (*n == 1) { i__2 = b_subscr(1, j); i__3 = b_subscr(1, j); i__4 = x_subscr(1, j); q__2.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i, q__2.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4] .r; q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; } else { i__2 = b_subscr(1, j); i__3 = b_subscr(1, j); i__4 = x_subscr(1, j); q__3.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i, q__3.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4] .r; q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i; i__5 = x_subscr(2, j); q__4.r = dl[1].r * x[i__5].r - dl[1].i * x[i__5].i, q__4.i = dl[1].r * x[i__5].i + dl[1].i * x[i__5] .r; q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; i__2 = b_subscr(*n, j); i__3 = b_subscr(*n, j); i__4 = *n - 1; i__5 = x_subscr(*n - 1, j); q__3.r = du[i__4].r * x[i__5].r - du[i__4].i * x[i__5].i, q__3.i = du[i__4].r * x[i__5].i + du[i__4].i * x[ i__5].r; q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i; i__6 = *n; i__7 = x_subscr(*n, j); q__4.r = d__[i__6].r * x[i__7].r - d__[i__6].i * x[i__7] .i, q__4.i = d__[i__6].r * x[i__7].i + d__[i__6] .i * x[i__7].r; q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; i__2 = *n - 1; for (i__ = 2; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); i__4 = b_subscr(i__, j); i__5 = i__ - 1; i__6 = x_subscr(i__ - 1, j); q__4.r = du[i__5].r * x[i__6].r - du[i__5].i * x[i__6] .i, q__4.i = du[i__5].r * x[i__6].i + du[i__5] .i * x[i__6].r; q__3.r = b[i__4].r - q__4.r, q__3.i = b[i__4].i - q__4.i; i__7 = i__; i__8 = x_subscr(i__, j); q__5.r = d__[i__7].r * x[i__8].r - d__[i__7].i * x[ i__8].i, q__5.i = d__[i__7].r * x[i__8].i + d__[i__7].i * x[i__8].r; q__2.r = q__3.r - q__5.r, q__2.i = q__3.i - q__5.i; i__9 = i__; i__10 = x_subscr(i__ + 1, j); q__6.r = dl[i__9].r * x[i__10].r - dl[i__9].i * x[ i__10].i, q__6.i = dl[i__9].r * x[i__10].i + dl[i__9].i * x[i__10].r; q__1.r = q__2.r - q__6.r, q__1.i = q__2.i - q__6.i; b[i__3].r = q__1.r, b[i__3].i = q__1.i; /* L130: */ } } /* L140: */ } } else if (lsame_(trans, "C")) { /* Compute B := B - A'*X */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { if (*n == 1) { i__2 = b_subscr(1, j); i__3 = b_subscr(1, j); r_cnjg(&q__3, &d__[1]); i__4 = x_subscr(1, j); q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i = q__3.r * x[i__4].i + q__3.i * x[i__4].r; q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; } else { i__2 = b_subscr(1, j); i__3 = b_subscr(1, j); r_cnjg(&q__4, &d__[1]); i__4 = x_subscr(1, j); q__3.r = q__4.r * x[i__4].r - q__4.i * x[i__4].i, q__3.i = q__4.r * x[i__4].i + q__4.i * x[i__4].r; q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i; r_cnjg(&q__6, &dl[1]); i__5 = x_subscr(2, j); q__5.r = q__6.r * x[i__5].r - q__6.i * x[i__5].i, q__5.i = q__6.r * x[i__5].i + q__6.i * x[i__5].r; q__1.r = q__2.r - q__5.r, q__1.i = q__2.i - q__5.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; i__2 = b_subscr(*n, j); i__3 = b_subscr(*n, j); r_cnjg(&q__4, &du[*n - 1]); i__4 = x_subscr(*n - 1, j); q__3.r = q__4.r * x[i__4].r - q__4.i * x[i__4].i, q__3.i = q__4.r * x[i__4].i + q__4.i * x[i__4].r; q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i; r_cnjg(&q__6, &d__[*n]); i__5 = x_subscr(*n, j); q__5.r = q__6.r * x[i__5].r - q__6.i * x[i__5].i, q__5.i = q__6.r * x[i__5].i + q__6.i * x[i__5].r; q__1.r = q__2.r - q__5.r, q__1.i = q__2.i - q__5.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; i__2 = *n - 1; for (i__ = 2; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); i__4 = b_subscr(i__, j); r_cnjg(&q__5, &du[i__ - 1]); i__5 = x_subscr(i__ - 1, j); q__4.r = q__5.r * x[i__5].r - q__5.i * x[i__5].i, q__4.i = q__5.r * x[i__5].i + q__5.i * x[i__5] .r; q__3.r = b[i__4].r - q__4.r, q__3.i = b[i__4].i - q__4.i; r_cnjg(&q__7, &d__[i__]); i__6 = x_subscr(i__, j); q__6.r = q__7.r * x[i__6].r - q__7.i * x[i__6].i, q__6.i = q__7.r * x[i__6].i + q__7.i * x[i__6] .r; q__2.r = q__3.r - q__6.r, q__2.i = q__3.i - q__6.i; r_cnjg(&q__9, &dl[i__]); i__7 = x_subscr(i__ + 1, j); q__8.r = q__9.r * x[i__7].r - q__9.i * x[i__7].i, q__8.i = q__9.r * x[i__7].i + q__9.i * x[i__7] .r; q__1.r = q__2.r - q__8.r, q__1.i = q__2.i - q__8.i; b[i__3].r = q__1.r, b[i__3].i = q__1.i; /* L150: */ } } /* L160: */ } } } return 0; /* End of CLAGTM */ } /* clagtm_ */
/* Subroutine */ int ctgevc_(char *side, char *howmny, logical *select, integer *n, complex *a, integer *lda, complex *b, integer *ldb, complex *vl, integer *ldvl, complex *vr, integer *ldvr, integer *mm, integer *m, complex *work, real *rwork, 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 ======= CTGEVC computes some or all of the right and/or left generalized eigenvectors of a pair of complex upper triangular matrices (A,B). The right generalized eigenvector x and the left generalized eigenvector y of (A,B) corresponding to a generalized eigenvalue w are defined by: (A - wB) * x = 0 and y**H * (A - wB) = 0 where y**H denotes the conjugate tranpose of y. If an eigenvalue w is determined by zero diagonal elements of both A and B, a unit vector is returned as the corresponding eigenvector. If all eigenvectors are requested, the routine may either return the matrices X and/or Y of right or left eigenvectors of (A,B), or the products Z*X and/or Q*Y, where Z and Q are input unitary matrices. If (A,B) was obtained from the generalized Schur factorization of an original pair of matrices (A0,B0) = (Q*A*Z**H,Q*B*Z**H), then Z*X and Q*Y are the matrices of right or left eigenvectors of A. Arguments ========= SIDE (input) CHARACTER*1 = 'R': compute right eigenvectors only; = 'L': compute left eigenvectors only; = 'B': compute both right and left eigenvectors. HOWMNY (input) CHARACTER*1 = 'A': compute all right and/or left eigenvectors; = 'B': compute all right and/or left eigenvectors, and backtransform them using the input matrices supplied in VR and/or VL; = 'S': compute selected right and/or left eigenvectors, specified by the logical array SELECT. SELECT (input) LOGICAL array, dimension (N) If HOWMNY='S', SELECT specifies the eigenvectors to be computed. If HOWMNY='A' or 'B', SELECT is not referenced. To select the eigenvector corresponding to the j-th eigenvalue, SELECT(j) must be set to .TRUE.. N (input) INTEGER The order of the matrices A and B. N >= 0. A (input) COMPLEX array, dimension (LDA,N) The upper triangular matrix A. LDA (input) INTEGER The leading dimension of array A. LDA >= max(1,N). B (input) COMPLEX array, dimension (LDB,N) The upper triangular matrix B. B must have real diagonal elements. LDB (input) INTEGER The leading dimension of array B. LDB >= max(1,N). VL (input/output) COMPLEX array, dimension (LDVL,MM) On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must contain an N-by-N matrix Q (usually the unitary matrix Q of left Schur vectors returned by CHGEQZ). On exit, if SIDE = 'L' or 'B', VL contains: if HOWMNY = 'A', the matrix Y of left eigenvectors of (A,B); if HOWMNY = 'B', the matrix Q*Y; if HOWMNY = 'S', the left eigenvectors of (A,B) specified by SELECT, stored consecutively in the columns of VL, in the same order as their eigenvalues. If SIDE = 'R', VL is not referenced. LDVL (input) INTEGER The leading dimension of array VL. LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. VR (input/output) COMPLEX array, dimension (LDVR,MM) On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must contain an N-by-N matrix Q (usually the unitary matrix Z of right Schur vectors returned by CHGEQZ). On exit, if SIDE = 'R' or 'B', VR contains: if HOWMNY = 'A', the matrix X of right eigenvectors of (A,B); if HOWMNY = 'B', the matrix Z*X; if HOWMNY = 'S', the right eigenvectors of (A,B) specified by SELECT, stored consecutively in the columns of VR, in the same order as their eigenvalues. If SIDE = 'L', VR is not referenced. LDVR (input) INTEGER The leading dimension of the array VR. LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. MM (input) INTEGER The number of columns in the arrays VL and/or VR. MM >= M. M (output) INTEGER The number of columns in the arrays VL and/or VR actually used to store the eigenvectors. If HOWMNY = 'A' or 'B', M is set to N. Each selected eigenvector occupies one column. WORK (workspace) COMPLEX array, dimension (2*N) RWORK (workspace) REAL array, dimension (2*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 complex c_b1 = {0.f,0.f}; static complex c_b2 = {1.f,0.f}; static integer c__1 = 1; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4, i__5; real r__1, r__2, r__3, r__4, r__5, r__6; complex q__1, q__2, q__3, q__4; /* Builtin functions */ double r_imag(complex *); void r_cnjg(complex *, complex *); /* Local variables */ static integer ibeg, ieig, iend; static real dmin__; static integer isrc; static real temp; static complex suma, sumb; static real xmax; static complex d__; static integer i__, j; static real scale; static logical ilall; static integer iside; static real sbeta; extern logical lsame_(char *, char *); extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * , complex *, integer *, complex *, integer *, complex *, complex * , integer *); static real small; static logical compl; static real anorm, bnorm; static logical compr; static complex ca, cb; static logical ilbbad; static real acoefa; static integer je; static real bcoefa, acoeff; static complex bcoeff; static logical ilback; static integer im; extern /* Subroutine */ int slabad_(real *, real *); static real ascale, bscale; static integer jr; extern /* Complex */ VOID cladiv_(complex *, complex *, complex *); extern doublereal slamch_(char *); static complex salpha; static real safmin; extern /* Subroutine */ int xerbla_(char *, integer *); static real bignum; static logical ilcomp; static integer ihwmny; static real big; static logical lsa, lsb; static real ulp; static complex sum; #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 vl_subscr(a_1,a_2) (a_2)*vl_dim1 + a_1 #define vl_ref(a_1,a_2) vl[vl_subscr(a_1,a_2)] #define vr_subscr(a_1,a_2) (a_2)*vr_dim1 + a_1 #define vr_ref(a_1,a_2) vr[vr_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; vl_dim1 = *ldvl; vl_offset = 1 + vl_dim1 * 1; vl -= vl_offset; vr_dim1 = *ldvr; vr_offset = 1 + vr_dim1 * 1; vr -= vr_offset; --work; --rwork; /* Function Body */ if (lsame_(howmny, "A")) { ihwmny = 1; ilall = TRUE_; ilback = FALSE_; } else if (lsame_(howmny, "S")) { ihwmny = 2; ilall = FALSE_; ilback = FALSE_; } else if (lsame_(howmny, "B") || lsame_(howmny, "T")) { ihwmny = 3; ilall = TRUE_; ilback = TRUE_; } else { ihwmny = -1; } if (lsame_(side, "R")) { iside = 1; compl = FALSE_; compr = TRUE_; } else if (lsame_(side, "L")) { iside = 2; compl = TRUE_; compr = FALSE_; } else if (lsame_(side, "B")) { iside = 3; compl = TRUE_; compr = TRUE_; } else { iside = -1; } *info = 0; if (iside < 0) { *info = -1; } else if (ihwmny < 0) { *info = -2; } else if (*n < 0) { *info = -4; } else if (*lda < max(1,*n)) { *info = -6; } else if (*ldb < max(1,*n)) { *info = -8; } if (*info != 0) { i__1 = -(*info); xerbla_("CTGEVC", &i__1); return 0; } /* Count the number of eigenvectors */ if (! ilall) { im = 0; i__1 = *n; for (j = 1; j <= i__1; ++j) { if (select[j]) { ++im; } /* L10: */ } } else { im = *n; } /* Check diagonal of B */ ilbbad = FALSE_; i__1 = *n; for (j = 1; j <= i__1; ++j) { if (r_imag(&b_ref(j, j)) != 0.f) { ilbbad = TRUE_; } /* L20: */ } if (ilbbad) { *info = -7; } else if (compl && *ldvl < *n || *ldvl < 1) { *info = -10; } else if (compr && *ldvr < *n || *ldvr < 1) { *info = -12; } else if (*mm < im) { *info = -13; } if (*info != 0) { i__1 = -(*info); xerbla_("CTGEVC", &i__1); return 0; } /* Quick return if possible */ *m = im; if (*n == 0) { return 0; } /* Machine Constants */ safmin = slamch_("Safe minimum"); big = 1.f / safmin; slabad_(&safmin, &big); ulp = slamch_("Epsilon") * slamch_("Base"); small = safmin * *n / ulp; big = 1.f / small; bignum = 1.f / (safmin * *n); /* Compute the 1-norm of each column of the strictly upper triangular part of A and B to check for possible overflow in the triangular solver. */ i__1 = a_subscr(1, 1); anorm = (r__1 = a[i__1].r, dabs(r__1)) + (r__2 = r_imag(&a_ref(1, 1)), dabs(r__2)); i__1 = b_subscr(1, 1); bnorm = (r__1 = b[i__1].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(1, 1)), dabs(r__2)); rwork[1] = 0.f; rwork[*n + 1] = 0.f; i__1 = *n; for (j = 2; j <= i__1; ++j) { rwork[j] = 0.f; rwork[*n + j] = 0.f; i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = a_subscr(i__, j); rwork[j] += (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(& a_ref(i__, j)), dabs(r__2)); i__3 = b_subscr(i__, j); rwork[*n + j] += (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(& b_ref(i__, j)), dabs(r__2)); /* L30: */ } /* Computing MAX */ i__2 = a_subscr(j, j); r__3 = anorm, r__4 = rwork[j] + ((r__1 = a[i__2].r, dabs(r__1)) + ( r__2 = r_imag(&a_ref(j, j)), dabs(r__2))); anorm = dmax(r__3,r__4); /* Computing MAX */ i__2 = b_subscr(j, j); r__3 = bnorm, r__4 = rwork[*n + j] + ((r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(j, j)), dabs(r__2))); bnorm = dmax(r__3,r__4); /* L40: */ } ascale = 1.f / dmax(anorm,safmin); bscale = 1.f / dmax(bnorm,safmin); /* Left eigenvectors */ if (compl) { ieig = 0; /* Main loop over eigenvalues */ i__1 = *n; for (je = 1; je <= i__1; ++je) { if (ilall) { ilcomp = TRUE_; } else { ilcomp = select[je]; } if (ilcomp) { ++ieig; i__2 = a_subscr(je, je); i__3 = b_subscr(je, je); if ((r__2 = a[i__2].r, dabs(r__2)) + (r__3 = r_imag(&a_ref(je, je)), dabs(r__3)) <= safmin && (r__1 = b[i__3].r, dabs(r__1)) <= safmin) { /* Singular matrix pencil -- return unit eigenvector */ i__2 = *n; for (jr = 1; jr <= i__2; ++jr) { i__3 = vl_subscr(jr, ieig); vl[i__3].r = 0.f, vl[i__3].i = 0.f; /* L50: */ } i__2 = vl_subscr(ieig, ieig); vl[i__2].r = 1.f, vl[i__2].i = 0.f; goto L140; } /* Non-singular eigenvalue: Compute coefficients a and b in H y ( a A - b B ) = 0 Computing MAX */ i__2 = a_subscr(je, je); i__3 = b_subscr(je, je); r__4 = ((r__2 = a[i__2].r, dabs(r__2)) + (r__3 = r_imag(& a_ref(je, je)), dabs(r__3))) * ascale, r__5 = (r__1 = b[i__3].r, dabs(r__1)) * bscale, r__4 = max(r__4,r__5) ; temp = 1.f / dmax(r__4,safmin); i__2 = a_subscr(je, je); q__2.r = temp * a[i__2].r, q__2.i = temp * a[i__2].i; q__1.r = ascale * q__2.r, q__1.i = ascale * q__2.i; salpha.r = q__1.r, salpha.i = q__1.i; i__2 = b_subscr(je, je); sbeta = temp * b[i__2].r * bscale; acoeff = sbeta * ascale; q__1.r = bscale * salpha.r, q__1.i = bscale * salpha.i; bcoeff.r = q__1.r, bcoeff.i = q__1.i; /* Scale to avoid underflow */ lsa = dabs(sbeta) >= safmin && dabs(acoeff) < small; lsb = (r__1 = salpha.r, dabs(r__1)) + (r__2 = r_imag(&salpha), dabs(r__2)) >= safmin && (r__3 = bcoeff.r, dabs(r__3) ) + (r__4 = r_imag(&bcoeff), dabs(r__4)) < small; scale = 1.f; if (lsa) { scale = small / dabs(sbeta) * dmin(anorm,big); } if (lsb) { /* Computing MAX */ r__3 = scale, r__4 = small / ((r__1 = salpha.r, dabs(r__1) ) + (r__2 = r_imag(&salpha), dabs(r__2))) * dmin( bnorm,big); scale = dmax(r__3,r__4); } if (lsa || lsb) { /* Computing MIN Computing MAX */ r__5 = 1.f, r__6 = dabs(acoeff), r__5 = max(r__5,r__6), r__6 = (r__1 = bcoeff.r, dabs(r__1)) + (r__2 = r_imag(&bcoeff), dabs(r__2)); r__3 = scale, r__4 = 1.f / (safmin * dmax(r__5,r__6)); scale = dmin(r__3,r__4); if (lsa) { acoeff = ascale * (scale * sbeta); } else { acoeff = scale * acoeff; } if (lsb) { q__2.r = scale * salpha.r, q__2.i = scale * salpha.i; q__1.r = bscale * q__2.r, q__1.i = bscale * q__2.i; bcoeff.r = q__1.r, bcoeff.i = q__1.i; } else { q__1.r = scale * bcoeff.r, q__1.i = scale * bcoeff.i; bcoeff.r = q__1.r, bcoeff.i = q__1.i; } } acoefa = dabs(acoeff); bcoefa = (r__1 = bcoeff.r, dabs(r__1)) + (r__2 = r_imag(& bcoeff), dabs(r__2)); xmax = 1.f; i__2 = *n; for (jr = 1; jr <= i__2; ++jr) { i__3 = jr; work[i__3].r = 0.f, work[i__3].i = 0.f; /* L60: */ } i__2 = je; work[i__2].r = 1.f, work[i__2].i = 0.f; /* Computing MAX */ r__1 = ulp * acoefa * anorm, r__2 = ulp * bcoefa * bnorm, r__1 = max(r__1,r__2); dmin__ = dmax(r__1,safmin); /* H Triangular solve of (a A - b B) y = 0 H (rowwise in (a A - b B) , or columnwise in a A - b B) */ i__2 = *n; for (j = je + 1; j <= i__2; ++j) { /* Compute j-1 SUM = sum conjg( a*A(k,j) - b*B(k,j) )*x(k) k=je (Scale if necessary) */ temp = 1.f / xmax; if (acoefa * rwork[j] + bcoefa * rwork[*n + j] > bignum * temp) { i__3 = j - 1; for (jr = je; jr <= i__3; ++jr) { i__4 = jr; i__5 = jr; q__1.r = temp * work[i__5].r, q__1.i = temp * work[i__5].i; work[i__4].r = q__1.r, work[i__4].i = q__1.i; /* L70: */ } xmax = 1.f; } suma.r = 0.f, suma.i = 0.f; sumb.r = 0.f, sumb.i = 0.f; i__3 = j - 1; for (jr = je; jr <= i__3; ++jr) { r_cnjg(&q__3, &a_ref(jr, j)); i__4 = jr; q__2.r = q__3.r * work[i__4].r - q__3.i * work[i__4] .i, q__2.i = q__3.r * work[i__4].i + q__3.i * work[i__4].r; q__1.r = suma.r + q__2.r, q__1.i = suma.i + q__2.i; suma.r = q__1.r, suma.i = q__1.i; r_cnjg(&q__3, &b_ref(jr, j)); i__4 = jr; q__2.r = q__3.r * work[i__4].r - q__3.i * work[i__4] .i, q__2.i = q__3.r * work[i__4].i + q__3.i * work[i__4].r; q__1.r = sumb.r + q__2.r, q__1.i = sumb.i + q__2.i; sumb.r = q__1.r, sumb.i = q__1.i; /* L80: */ } q__2.r = acoeff * suma.r, q__2.i = acoeff * suma.i; r_cnjg(&q__4, &bcoeff); q__3.r = q__4.r * sumb.r - q__4.i * sumb.i, q__3.i = q__4.r * sumb.i + q__4.i * sumb.r; q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i; sum.r = q__1.r, sum.i = q__1.i; /* Form x(j) = - SUM / conjg( a*A(j,j) - b*B(j,j) ) with scaling and perturbation of the denominator */ i__3 = a_subscr(j, j); q__3.r = acoeff * a[i__3].r, q__3.i = acoeff * a[i__3].i; i__4 = b_subscr(j, j); q__4.r = bcoeff.r * b[i__4].r - bcoeff.i * b[i__4].i, q__4.i = bcoeff.r * b[i__4].i + bcoeff.i * b[i__4] .r; q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i; r_cnjg(&q__1, &q__2); d__.r = q__1.r, d__.i = q__1.i; if ((r__1 = d__.r, dabs(r__1)) + (r__2 = r_imag(&d__), dabs(r__2)) <= dmin__) { q__1.r = dmin__, q__1.i = 0.f; d__.r = q__1.r, d__.i = q__1.i; } if ((r__1 = d__.r, dabs(r__1)) + (r__2 = r_imag(&d__), dabs(r__2)) < 1.f) { if ((r__1 = sum.r, dabs(r__1)) + (r__2 = r_imag(&sum), dabs(r__2)) >= bignum * ((r__3 = d__.r, dabs( r__3)) + (r__4 = r_imag(&d__), dabs(r__4)))) { temp = 1.f / ((r__1 = sum.r, dabs(r__1)) + (r__2 = r_imag(&sum), dabs(r__2))); i__3 = j - 1; for (jr = je; jr <= i__3; ++jr) { i__4 = jr; i__5 = jr; q__1.r = temp * work[i__5].r, q__1.i = temp * work[i__5].i; work[i__4].r = q__1.r, work[i__4].i = q__1.i; /* L90: */ } xmax = temp * xmax; q__1.r = temp * sum.r, q__1.i = temp * sum.i; sum.r = q__1.r, sum.i = q__1.i; } } i__3 = j; q__2.r = -sum.r, q__2.i = -sum.i; cladiv_(&q__1, &q__2, &d__); work[i__3].r = q__1.r, work[i__3].i = q__1.i; /* Computing MAX */ i__3 = j; r__3 = xmax, r__4 = (r__1 = work[i__3].r, dabs(r__1)) + ( r__2 = r_imag(&work[j]), dabs(r__2)); xmax = dmax(r__3,r__4); /* L100: */ } /* Back transform eigenvector if HOWMNY='B'. */ if (ilback) { i__2 = *n + 1 - je; cgemv_("N", n, &i__2, &c_b2, &vl_ref(1, je), ldvl, &work[ je], &c__1, &c_b1, &work[*n + 1], &c__1); isrc = 2; ibeg = 1; } else { isrc = 1; ibeg = je; } /* Copy and scale eigenvector into column of VL */ xmax = 0.f; i__2 = *n; for (jr = ibeg; jr <= i__2; ++jr) { /* Computing MAX */ i__3 = (isrc - 1) * *n + jr; r__3 = xmax, r__4 = (r__1 = work[i__3].r, dabs(r__1)) + ( r__2 = r_imag(&work[(isrc - 1) * *n + jr]), dabs( r__2)); xmax = dmax(r__3,r__4); /* L110: */ } if (xmax > safmin) { temp = 1.f / xmax; i__2 = *n; for (jr = ibeg; jr <= i__2; ++jr) { i__3 = vl_subscr(jr, ieig); i__4 = (isrc - 1) * *n + jr; q__1.r = temp * work[i__4].r, q__1.i = temp * work[ i__4].i; vl[i__3].r = q__1.r, vl[i__3].i = q__1.i; /* L120: */ } } else { ibeg = *n + 1; } i__2 = ibeg - 1; for (jr = 1; jr <= i__2; ++jr) { i__3 = vl_subscr(jr, ieig); vl[i__3].r = 0.f, vl[i__3].i = 0.f; /* L130: */ } } L140: ; } } /* Right eigenvectors */ if (compr) { ieig = im + 1; /* Main loop over eigenvalues */ for (je = *n; je >= 1; --je) { if (ilall) { ilcomp = TRUE_; } else { ilcomp = select[je]; } if (ilcomp) { --ieig; i__1 = a_subscr(je, je); i__2 = b_subscr(je, je); if ((r__2 = a[i__1].r, dabs(r__2)) + (r__3 = r_imag(&a_ref(je, je)), dabs(r__3)) <= safmin && (r__1 = b[i__2].r, dabs(r__1)) <= safmin) { /* Singular matrix pencil -- return unit eigenvector */ i__1 = *n; for (jr = 1; jr <= i__1; ++jr) { i__2 = vr_subscr(jr, ieig); vr[i__2].r = 0.f, vr[i__2].i = 0.f; /* L150: */ } i__1 = vr_subscr(ieig, ieig); vr[i__1].r = 1.f, vr[i__1].i = 0.f; goto L250; } /* Non-singular eigenvalue: Compute coefficients a and b in ( a A - b B ) x = 0 Computing MAX */ i__1 = a_subscr(je, je); i__2 = b_subscr(je, je); r__4 = ((r__2 = a[i__1].r, dabs(r__2)) + (r__3 = r_imag(& a_ref(je, je)), dabs(r__3))) * ascale, r__5 = (r__1 = b[i__2].r, dabs(r__1)) * bscale, r__4 = max(r__4,r__5) ; temp = 1.f / dmax(r__4,safmin); i__1 = a_subscr(je, je); q__2.r = temp * a[i__1].r, q__2.i = temp * a[i__1].i; q__1.r = ascale * q__2.r, q__1.i = ascale * q__2.i; salpha.r = q__1.r, salpha.i = q__1.i; i__1 = b_subscr(je, je); sbeta = temp * b[i__1].r * bscale; acoeff = sbeta * ascale; q__1.r = bscale * salpha.r, q__1.i = bscale * salpha.i; bcoeff.r = q__1.r, bcoeff.i = q__1.i; /* Scale to avoid underflow */ lsa = dabs(sbeta) >= safmin && dabs(acoeff) < small; lsb = (r__1 = salpha.r, dabs(r__1)) + (r__2 = r_imag(&salpha), dabs(r__2)) >= safmin && (r__3 = bcoeff.r, dabs(r__3) ) + (r__4 = r_imag(&bcoeff), dabs(r__4)) < small; scale = 1.f; if (lsa) { scale = small / dabs(sbeta) * dmin(anorm,big); } if (lsb) { /* Computing MAX */ r__3 = scale, r__4 = small / ((r__1 = salpha.r, dabs(r__1) ) + (r__2 = r_imag(&salpha), dabs(r__2))) * dmin( bnorm,big); scale = dmax(r__3,r__4); } if (lsa || lsb) { /* Computing MIN Computing MAX */ r__5 = 1.f, r__6 = dabs(acoeff), r__5 = max(r__5,r__6), r__6 = (r__1 = bcoeff.r, dabs(r__1)) + (r__2 = r_imag(&bcoeff), dabs(r__2)); r__3 = scale, r__4 = 1.f / (safmin * dmax(r__5,r__6)); scale = dmin(r__3,r__4); if (lsa) { acoeff = ascale * (scale * sbeta); } else { acoeff = scale * acoeff; } if (lsb) { q__2.r = scale * salpha.r, q__2.i = scale * salpha.i; q__1.r = bscale * q__2.r, q__1.i = bscale * q__2.i; bcoeff.r = q__1.r, bcoeff.i = q__1.i; } else { q__1.r = scale * bcoeff.r, q__1.i = scale * bcoeff.i; bcoeff.r = q__1.r, bcoeff.i = q__1.i; } } acoefa = dabs(acoeff); bcoefa = (r__1 = bcoeff.r, dabs(r__1)) + (r__2 = r_imag(& bcoeff), dabs(r__2)); xmax = 1.f; i__1 = *n; for (jr = 1; jr <= i__1; ++jr) { i__2 = jr; work[i__2].r = 0.f, work[i__2].i = 0.f; /* L160: */ } i__1 = je; work[i__1].r = 1.f, work[i__1].i = 0.f; /* Computing MAX */ r__1 = ulp * acoefa * anorm, r__2 = ulp * bcoefa * bnorm, r__1 = max(r__1,r__2); dmin__ = dmax(r__1,safmin); /* Triangular solve of (a A - b B) x = 0 (columnwise) WORK(1:j-1) contains sums w, WORK(j+1:JE) contains x */ i__1 = je - 1; for (jr = 1; jr <= i__1; ++jr) { i__2 = jr; i__3 = a_subscr(jr, je); q__2.r = acoeff * a[i__3].r, q__2.i = acoeff * a[i__3].i; i__4 = b_subscr(jr, je); q__3.r = bcoeff.r * b[i__4].r - bcoeff.i * b[i__4].i, q__3.i = bcoeff.r * b[i__4].i + bcoeff.i * b[i__4] .r; q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i; work[i__2].r = q__1.r, work[i__2].i = q__1.i; /* L170: */ } i__1 = je; work[i__1].r = 1.f, work[i__1].i = 0.f; for (j = je - 1; j >= 1; --j) { /* Form x(j) := - w(j) / d with scaling and perturbation of the denominator */ i__1 = a_subscr(j, j); q__2.r = acoeff * a[i__1].r, q__2.i = acoeff * a[i__1].i; i__2 = b_subscr(j, j); q__3.r = bcoeff.r * b[i__2].r - bcoeff.i * b[i__2].i, q__3.i = bcoeff.r * b[i__2].i + bcoeff.i * b[i__2] .r; q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i; d__.r = q__1.r, d__.i = q__1.i; if ((r__1 = d__.r, dabs(r__1)) + (r__2 = r_imag(&d__), dabs(r__2)) <= dmin__) { q__1.r = dmin__, q__1.i = 0.f; d__.r = q__1.r, d__.i = q__1.i; } if ((r__1 = d__.r, dabs(r__1)) + (r__2 = r_imag(&d__), dabs(r__2)) < 1.f) { i__1 = j; if ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&work[j]), dabs(r__2)) >= bignum * (( r__3 = d__.r, dabs(r__3)) + (r__4 = r_imag(& d__), dabs(r__4)))) { i__1 = j; temp = 1.f / ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&work[j]), dabs(r__2))); i__1 = je; for (jr = 1; jr <= i__1; ++jr) { i__2 = jr; i__3 = jr; q__1.r = temp * work[i__3].r, q__1.i = temp * work[i__3].i; work[i__2].r = q__1.r, work[i__2].i = q__1.i; /* L180: */ } } } i__1 = j; i__2 = j; q__2.r = -work[i__2].r, q__2.i = -work[i__2].i; cladiv_(&q__1, &q__2, &d__); work[i__1].r = q__1.r, work[i__1].i = q__1.i; if (j > 1) { /* w = w + x(j)*(a A(*,j) - b B(*,j) ) with scaling */ i__1 = j; if ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&work[j]), dabs(r__2)) > 1.f) { i__1 = j; temp = 1.f / ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&work[j]), dabs(r__2))); if (acoefa * rwork[j] + bcoefa * rwork[*n + j] >= bignum * temp) { i__1 = je; for (jr = 1; jr <= i__1; ++jr) { i__2 = jr; i__3 = jr; q__1.r = temp * work[i__3].r, q__1.i = temp * work[i__3].i; work[i__2].r = q__1.r, work[i__2].i = q__1.i; /* L190: */ } } } i__1 = j; q__1.r = acoeff * work[i__1].r, q__1.i = acoeff * work[i__1].i; ca.r = q__1.r, ca.i = q__1.i; i__1 = j; q__1.r = bcoeff.r * work[i__1].r - bcoeff.i * work[ i__1].i, q__1.i = bcoeff.r * work[i__1].i + bcoeff.i * work[i__1].r; cb.r = q__1.r, cb.i = q__1.i; i__1 = j - 1; for (jr = 1; jr <= i__1; ++jr) { i__2 = jr; i__3 = jr; i__4 = a_subscr(jr, j); q__3.r = ca.r * a[i__4].r - ca.i * a[i__4].i, q__3.i = ca.r * a[i__4].i + ca.i * a[i__4] .r; q__2.r = work[i__3].r + q__3.r, q__2.i = work[ i__3].i + q__3.i; i__5 = b_subscr(jr, j); q__4.r = cb.r * b[i__5].r - cb.i * b[i__5].i, q__4.i = cb.r * b[i__5].i + cb.i * b[i__5] .r; q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i; work[i__2].r = q__1.r, work[i__2].i = q__1.i; /* L200: */ } } /* L210: */ } /* Back transform eigenvector if HOWMNY='B'. */ if (ilback) { cgemv_("N", n, &je, &c_b2, &vr[vr_offset], ldvr, &work[1], &c__1, &c_b1, &work[*n + 1], &c__1); isrc = 2; iend = *n; } else { isrc = 1; iend = je; } /* Copy and scale eigenvector into column of VR */ xmax = 0.f; i__1 = iend; for (jr = 1; jr <= i__1; ++jr) { /* Computing MAX */ i__2 = (isrc - 1) * *n + jr; r__3 = xmax, r__4 = (r__1 = work[i__2].r, dabs(r__1)) + ( r__2 = r_imag(&work[(isrc - 1) * *n + jr]), dabs( r__2)); xmax = dmax(r__3,r__4); /* L220: */ } if (xmax > safmin) { temp = 1.f / xmax; i__1 = iend; for (jr = 1; jr <= i__1; ++jr) { i__2 = vr_subscr(jr, ieig); i__3 = (isrc - 1) * *n + jr; q__1.r = temp * work[i__3].r, q__1.i = temp * work[ i__3].i; vr[i__2].r = q__1.r, vr[i__2].i = q__1.i; /* L230: */ } } else { iend = 0; } i__1 = *n; for (jr = iend + 1; jr <= i__1; ++jr) { i__2 = vr_subscr(jr, ieig); vr[i__2].r = 0.f, vr[i__2].i = 0.f; /* L240: */ } } L250: ; } } return 0; /* End of CTGEVC */ } /* ctgevc_ */
/* Subroutine */ int cgtrfs_(char *trans, integer *n, integer *nrhs, complex * dl, complex *d__, complex *du, complex *dlf, complex *df, complex * duf, complex *du2, integer *ipiv, complex *b, integer *ldb, complex * x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork, 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 ======= CGTRFS improves the computed solution to a system of linear equations when the coefficient matrix is tridiagonal, and provides error bounds and backward error estimates for the solution. Arguments ========= TRANS (input) CHARACTER*1 Specifies the form of the system of equations: = 'N': A * X = B (No transpose) = 'T': A**T * X = B (Transpose) = 'C': A**H * X = B (Conjugate transpose) N (input) INTEGER The order of the matrix A. N >= 0. NRHS (input) INTEGER The number of right hand sides, i.e., the number of columns of the matrix B. NRHS >= 0. DL (input) COMPLEX array, dimension (N-1) The (n-1) subdiagonal elements of A. D (input) COMPLEX array, dimension (N) The diagonal elements of A. DU (input) COMPLEX array, dimension (N-1) The (n-1) superdiagonal elements of A. DLF (input) COMPLEX array, dimension (N-1) The (n-1) multipliers that define the matrix L from the LU factorization of A as computed by CGTTRF. DF (input) COMPLEX array, dimension (N) The n diagonal elements of the upper triangular matrix U from the LU factorization of A. DUF (input) COMPLEX array, dimension (N-1) The (n-1) elements of the first superdiagonal of U. DU2 (input) COMPLEX array, dimension (N-2) The (n-2) elements of the second superdiagonal of U. IPIV (input) INTEGER array, dimension (N) The pivot indices; for 1 <= i <= n, row i of the matrix was interchanged with row IPIV(i). IPIV(i) will always be either i or i+1; IPIV(i) = i indicates a row interchange was not required. B (input) COMPLEX array, dimension (LDB,NRHS) The right hand side matrix B. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,N). X (input/output) COMPLEX array, dimension (LDX,NRHS) On entry, the solution matrix X, as computed by CGTTRS. On exit, the improved solution matrix X. LDX (input) INTEGER The leading dimension of the array X. LDX >= max(1,N). FERR (output) REAL array, dimension (NRHS) The estimated forward error bound for each solution vector X(j) (the j-th column of the solution matrix X). If XTRUE is the true solution corresponding to X(j), FERR(j) is an estimated upper bound for the magnitude of the largest element in (X(j) - XTRUE) divided by the magnitude of the largest element in X(j). The estimate is as reliable as the estimate for RCOND, and is almost always a slight overestimate of the true error. BERR (output) REAL array, dimension (NRHS) The componentwise relative backward error of each solution vector X(j) (i.e., the smallest relative change in any element of A or B that makes X(j) an exact solution). WORK (workspace) COMPLEX array, dimension (2*N) RWORK (workspace) REAL array, dimension (N) INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value Internal Parameters =================== ITMAX is the maximum number of steps of iterative refinement. ===================================================================== Test the input parameters. Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; static real c_b18 = -1.f; static real c_b19 = 1.f; static complex c_b26 = {1.f,0.f}; /* System generated locals */ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9; 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; complex q__1; /* Builtin functions */ double r_imag(complex *); /* Local variables */ static integer kase; static real safe1, safe2; static integer i__, j; static real s; extern logical lsame_(char *, char *); extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer *, complex *, integer *); static integer count; extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real *, integer *), clagtm_(char *, integer *, integer *, real *, complex *, complex *, complex *, complex *, integer *, real *, complex *, integer *); static integer nz; extern doublereal slamch_(char *); static real safmin; extern /* Subroutine */ int xerbla_(char *, integer *); static logical notran; static char transn[1]; extern /* Subroutine */ int cgttrs_(char *, integer *, integer *, complex *, complex *, complex *, complex *, integer *, complex *, integer *, integer *); static char transt[1]; static real lstres, eps; #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 x_subscr(a_1,a_2) (a_2)*x_dim1 + a_1 #define x_ref(a_1,a_2) x[x_subscr(a_1,a_2)] --dl; --d__; --du; --dlf; --df; --duf; --du2; --ipiv; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; x_dim1 = *ldx; x_offset = 1 + x_dim1 * 1; x -= x_offset; --ferr; --berr; --work; --rwork; /* Function Body */ *info = 0; notran = lsame_(trans, "N"); if (! notran && ! lsame_(trans, "T") && ! lsame_( trans, "C")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*nrhs < 0) { *info = -3; } else if (*ldb < max(1,*n)) { *info = -13; } else if (*ldx < max(1,*n)) { *info = -15; } if (*info != 0) { i__1 = -(*info); xerbla_("CGTRFS", &i__1); return 0; } /* Quick return if possible */ if (*n == 0 || *nrhs == 0) { i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { ferr[j] = 0.f; berr[j] = 0.f; /* L10: */ } return 0; } if (notran) { *(unsigned char *)transn = 'N'; *(unsigned char *)transt = 'C'; } else { *(unsigned char *)transn = 'C'; *(unsigned char *)transt = 'N'; } /* NZ = maximum number of nonzero elements in each row of A, plus 1 */ nz = 4; eps = slamch_("Epsilon"); safmin = slamch_("Safe minimum"); safe1 = nz * safmin; safe2 = safe1 / eps; /* Do for each right hand side */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { count = 1; lstres = 3.f; L20: /* Loop until stopping criterion is satisfied. Compute residual R = B - op(A) * X, where op(A) = A, A**T, or A**H, depending on TRANS. */ ccopy_(n, &b_ref(1, j), &c__1, &work[1], &c__1); clagtm_(trans, n, &c__1, &c_b18, &dl[1], &d__[1], &du[1], &x_ref(1, j) , ldx, &c_b19, &work[1], n); /* Compute abs(op(A))*abs(x) + abs(b) for use in the backward error bound. */ if (notran) { if (*n == 1) { i__2 = b_subscr(1, j); i__3 = x_subscr(1, j); rwork[1] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(& b_ref(1, j)), dabs(r__2)) + ((r__3 = d__[1].r, dabs( r__3)) + (r__4 = r_imag(&d__[1]), dabs(r__4))) * (( r__5 = x[i__3].r, dabs(r__5)) + (r__6 = r_imag(&x_ref( 1, j)), dabs(r__6))); } else { i__2 = b_subscr(1, j); i__3 = x_subscr(1, j); i__4 = x_subscr(2, j); rwork[1] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(& b_ref(1, j)), dabs(r__2)) + ((r__3 = d__[1].r, dabs( r__3)) + (r__4 = r_imag(&d__[1]), dabs(r__4))) * (( r__5 = x[i__3].r, dabs(r__5)) + (r__6 = r_imag(&x_ref( 1, j)), dabs(r__6))) + ((r__7 = du[1].r, dabs(r__7)) + (r__8 = r_imag(&du[1]), dabs(r__8))) * ((r__9 = x[ i__4].r, dabs(r__9)) + (r__10 = r_imag(&x_ref(2, j)), dabs(r__10))); i__2 = *n - 1; for (i__ = 2; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); i__4 = i__ - 1; i__5 = x_subscr(i__ - 1, j); i__6 = i__; i__7 = x_subscr(i__, j); i__8 = i__; i__9 = x_subscr(i__ + 1, j); rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(i__, j)), dabs(r__2)) + ((r__3 = dl[ i__4].r, dabs(r__3)) + (r__4 = r_imag(&dl[i__ - 1] ), dabs(r__4))) * ((r__5 = x[i__5].r, dabs(r__5)) + (r__6 = r_imag(&x_ref(i__ - 1, j)), dabs(r__6))) + ((r__7 = d__[i__6].r, dabs(r__7)) + (r__8 = r_imag(&d__[i__]), dabs(r__8))) * ((r__9 = x[i__7] .r, dabs(r__9)) + (r__10 = r_imag(&x_ref(i__, j)), dabs(r__10))) + ((r__11 = du[i__8].r, dabs(r__11) ) + (r__12 = r_imag(&du[i__]), dabs(r__12))) * (( r__13 = x[i__9].r, dabs(r__13)) + (r__14 = r_imag( &x_ref(i__ + 1, j)), dabs(r__14))); /* L30: */ } i__2 = b_subscr(*n, j); i__3 = *n - 1; i__4 = x_subscr(*n - 1, j); i__5 = *n; i__6 = x_subscr(*n, j); rwork[*n] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(& b_ref(*n, j)), dabs(r__2)) + ((r__3 = dl[i__3].r, dabs(r__3)) + (r__4 = r_imag(&dl[*n - 1]), dabs(r__4)) ) * ((r__5 = x[i__4].r, dabs(r__5)) + (r__6 = r_imag(& x_ref(*n - 1, j)), dabs(r__6))) + ((r__7 = d__[i__5] .r, dabs(r__7)) + (r__8 = r_imag(&d__[*n]), dabs(r__8) )) * ((r__9 = x[i__6].r, dabs(r__9)) + (r__10 = r_imag(&x_ref(*n, j)), dabs(r__10))); } } else { if (*n == 1) { i__2 = b_subscr(1, j); i__3 = x_subscr(1, j); rwork[1] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(& b_ref(1, j)), dabs(r__2)) + ((r__3 = d__[1].r, dabs( r__3)) + (r__4 = r_imag(&d__[1]), dabs(r__4))) * (( r__5 = x[i__3].r, dabs(r__5)) + (r__6 = r_imag(&x_ref( 1, j)), dabs(r__6))); } else { i__2 = b_subscr(1, j); i__3 = x_subscr(1, j); i__4 = x_subscr(2, j); rwork[1] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(& b_ref(1, j)), dabs(r__2)) + ((r__3 = d__[1].r, dabs( r__3)) + (r__4 = r_imag(&d__[1]), dabs(r__4))) * (( r__5 = x[i__3].r, dabs(r__5)) + (r__6 = r_imag(&x_ref( 1, j)), dabs(r__6))) + ((r__7 = dl[1].r, dabs(r__7)) + (r__8 = r_imag(&dl[1]), dabs(r__8))) * ((r__9 = x[ i__4].r, dabs(r__9)) + (r__10 = r_imag(&x_ref(2, j)), dabs(r__10))); i__2 = *n - 1; for (i__ = 2; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); i__4 = i__ - 1; i__5 = x_subscr(i__ - 1, j); i__6 = i__; i__7 = x_subscr(i__, j); i__8 = i__; i__9 = x_subscr(i__ + 1, j); rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(i__, j)), dabs(r__2)) + ((r__3 = du[ i__4].r, dabs(r__3)) + (r__4 = r_imag(&du[i__ - 1] ), dabs(r__4))) * ((r__5 = x[i__5].r, dabs(r__5)) + (r__6 = r_imag(&x_ref(i__ - 1, j)), dabs(r__6))) + ((r__7 = d__[i__6].r, dabs(r__7)) + (r__8 = r_imag(&d__[i__]), dabs(r__8))) * ((r__9 = x[i__7] .r, dabs(r__9)) + (r__10 = r_imag(&x_ref(i__, j)), dabs(r__10))) + ((r__11 = dl[i__8].r, dabs(r__11) ) + (r__12 = r_imag(&dl[i__]), dabs(r__12))) * (( r__13 = x[i__9].r, dabs(r__13)) + (r__14 = r_imag( &x_ref(i__ + 1, j)), dabs(r__14))); /* L40: */ } i__2 = b_subscr(*n, j); i__3 = *n - 1; i__4 = x_subscr(*n - 1, j); i__5 = *n; i__6 = x_subscr(*n, j); rwork[*n] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(& b_ref(*n, j)), dabs(r__2)) + ((r__3 = du[i__3].r, dabs(r__3)) + (r__4 = r_imag(&du[*n - 1]), dabs(r__4)) ) * ((r__5 = x[i__4].r, dabs(r__5)) + (r__6 = r_imag(& x_ref(*n - 1, j)), dabs(r__6))) + ((r__7 = d__[i__5] .r, dabs(r__7)) + (r__8 = r_imag(&d__[*n]), dabs(r__8) )) * ((r__9 = x[i__6].r, dabs(r__9)) + (r__10 = r_imag(&x_ref(*n, j)), dabs(r__10))); } } /* Compute componentwise relative backward error from formula max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) where abs(Z) is the componentwise absolute value of the matrix or vector Z. If the i-th component of the denominator is less than SAFE2, then SAFE1 is added to the i-th components of the numerator and denominator before dividing. */ s = 0.f; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { if (rwork[i__] > safe2) { /* Computing MAX */ i__3 = i__; r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 = r_imag(&work[i__]), dabs(r__2))) / rwork[i__]; s = dmax(r__3,r__4); } else { /* Computing MAX */ i__3 = i__; r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 = r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__] + safe1); s = dmax(r__3,r__4); } /* L50: */ } berr[j] = s; /* Test stopping criterion. Continue iterating if 1) The residual BERR(J) is larger than machine epsilon, and 2) BERR(J) decreased by at least a factor of 2 during the last iteration, and 3) At most ITMAX iterations tried. */ if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) { /* Update solution and try again. */ cgttrs_(trans, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[ 1], &work[1], n, info); caxpy_(n, &c_b26, &work[1], &c__1, &x_ref(1, j), &c__1); lstres = berr[j]; ++count; goto L20; } /* Bound error from formula norm(X - XTRUE) / norm(X) .le. FERR = norm( abs(inv(op(A)))* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) where norm(Z) is the magnitude of the largest component of Z inv(op(A)) is the inverse of op(A) abs(Z) is the componentwise absolute value of the matrix or vector Z NZ is the maximum number of nonzeros in any row of A, plus 1 EPS is machine epsilon The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) is incremented by SAFE1 if the i-th component of abs(op(A))*abs(X) + abs(B) is less than SAFE2. Use CLACON to estimate the infinity-norm of the matrix inv(op(A)) * diag(W), where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { if (rwork[i__] > safe2) { i__3 = i__; rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 = r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[ i__]; } else { i__3 = i__; rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 = r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[ i__] + safe1; } /* L60: */ } kase = 0; L70: clacon_(n, &work[*n + 1], &work[1], &ferr[j], &kase); if (kase != 0) { if (kase == 1) { /* Multiply by diag(W)*inv(op(A)**H). */ cgttrs_(transt, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], & ipiv[1], &work[1], n, info); i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__; i__4 = i__; i__5 = i__; q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4] * work[i__5].i; work[i__3].r = q__1.r, work[i__3].i = q__1.i; /* L80: */ } } else { /* Multiply by inv(op(A))*diag(W). */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__; i__4 = i__; i__5 = i__; q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4] * work[i__5].i; work[i__3].r = q__1.r, work[i__3].i = q__1.i; /* L90: */ } cgttrs_(transn, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], & ipiv[1], &work[1], n, info); } goto L70; } /* Normalize error. */ lstres = 0.f; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { /* Computing MAX */ i__3 = x_subscr(i__, j); r__3 = lstres, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x_ref(i__, j)), dabs(r__2)); lstres = dmax(r__3,r__4); /* L100: */ } if (lstres != 0.f) { ferr[j] /= lstres; } /* L110: */ } return 0; /* End of CGTRFS */ } /* cgtrfs_ */
/* Subroutine */ int clals0_(integer *icompq, integer *nl, integer *nr, integer *sqre, integer *nrhs, complex *b, integer *ldb, complex *bx, integer *ldbx, integer *perm, integer *givptr, integer *givcol, integer *ldgcol, real *givnum, integer *ldgnum, real *poles, real * difl, real *difr, real *z__, integer *k, real *c__, real *s, real * rwork, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University December 1, 1999 Purpose ======= CLALS0 applies back the multiplying factors of either the left or the right singular vector matrix of a diagonal matrix appended by a row to the right hand side matrix B in solving the least squares problem using the divide-and-conquer SVD approach. For the left singular vector matrix, three types of orthogonal matrices are involved: (1L) Givens rotations: the number of such rotations is GIVPTR; the pairs of columns/rows they were applied to are stored in GIVCOL; and the C- and S-values of these rotations are stored in GIVNUM. (2L) Permutation. The (NL+1)-st row of B is to be moved to the first row, and for J=2:N, PERM(J)-th row of B is to be moved to the J-th row. (3L) The left singular vector matrix of the remaining matrix. For the right singular vector matrix, four types of orthogonal matrices are involved: (1R) The right singular vector matrix of the remaining matrix. (2R) If SQRE = 1, one extra Givens rotation to generate the right null space. (3R) The inverse transformation of (2L). (4R) The inverse transformation of (1L). Arguments ========= ICOMPQ (input) INTEGER Specifies whether singular vectors are to be computed in factored form: = 0: Left singular vector matrix. = 1: Right singular vector matrix. NL (input) INTEGER The row dimension of the upper block. NL >= 1. NR (input) INTEGER The row dimension of the lower block. NR >= 1. SQRE (input) INTEGER = 0: the lower block is an NR-by-NR square matrix. = 1: the lower block is an NR-by-(NR+1) rectangular matrix. The bidiagonal matrix has row dimension N = NL + NR + 1, and column dimension M = N + SQRE. NRHS (input) INTEGER The number of columns of B and BX. NRHS must be at least 1. B (input/output) COMPLEX array, dimension ( LDB, NRHS ) On input, B contains the right hand sides of the least squares problem in rows 1 through M. On output, B contains the solution X in rows 1 through N. LDB (input) INTEGER The leading dimension of B. LDB must be at least max(1,MAX( M, N ) ). BX (workspace) COMPLEX array, dimension ( LDBX, NRHS ) LDBX (input) INTEGER The leading dimension of BX. PERM (input) INTEGER array, dimension ( N ) The permutations (from deflation and sorting) applied to the two blocks. GIVPTR (input) INTEGER The number of Givens rotations which took place in this subproblem. GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 ) Each pair of numbers indicates a pair of rows/columns involved in a Givens rotation. LDGCOL (input) INTEGER The leading dimension of GIVCOL, must be at least N. GIVNUM (input) REAL array, dimension ( LDGNUM, 2 ) Each number indicates the C or S value used in the corresponding Givens rotation. LDGNUM (input) INTEGER The leading dimension of arrays DIFR, POLES and GIVNUM, must be at least K. POLES (input) REAL array, dimension ( LDGNUM, 2 ) On entry, POLES(1:K, 1) contains the new singular values obtained from solving the secular equation, and POLES(1:K, 2) is an array containing the poles in the secular equation. DIFL (input) REAL array, dimension ( K ). On entry, DIFL(I) is the distance between I-th updated (undeflated) singular value and the I-th (undeflated) old singular value. DIFR (input) REAL array, dimension ( LDGNUM, 2 ). On entry, DIFR(I, 1) contains the distances between I-th updated (undeflated) singular value and the I+1-th (undeflated) old singular value. And DIFR(I, 2) is the normalizing factor for the I-th right singular vector. Z (input) REAL array, dimension ( K ) Contain the components of the deflation-adjusted updating row vector. K (input) INTEGER Contains the dimension of the non-deflated matrix, This is the order of the related secular equation. 1 <= K <=N. C (input) REAL C contains garbage if SQRE =0 and the C-value of a Givens rotation related to the right null space if SQRE = 1. S (input) REAL S contains garbage if SQRE =0 and the S-value of a Givens rotation related to the right null space if SQRE = 1. RWORK (workspace) REAL array, dimension ( K*(1+NRHS) + 2*NRHS ) INFO (output) INTEGER = 0: successful exit. < 0: if INFO = -i, the i-th argument had an illegal value. Further Details =============== Based on contributions by Ming Gu and Ren-Cang Li, Computer Science Division, University of California at Berkeley, USA Osni Marques, LBNL/NERSC, USA ===================================================================== Test the input parameters. Parameter adjustments */ /* Table of constant values */ static real c_b5 = -1.f; static integer c__1 = 1; static real c_b13 = 1.f; static real c_b15 = 0.f; static integer c__0 = 0; /* System generated locals */ integer givcol_dim1, givcol_offset, difr_dim1, difr_offset, givnum_dim1, givnum_offset, poles_dim1, poles_offset, b_dim1, b_offset, bx_dim1, bx_offset, i__1, i__2, i__3, i__4, i__5; real r__1; complex q__1; /* Builtin functions */ double r_imag(complex *); /* Local variables */ static integer jcol; static real temp; static integer jrow; extern doublereal snrm2_(integer *, real *, integer *); static integer i__, j, m, n; static real diflj, difrj, dsigj; extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, complex *, integer *), sgemv_(char *, integer *, integer *, real * , real *, integer *, real *, integer *, real *, real *, integer *), csrot_(integer *, complex *, integer *, complex *, integer *, real *, real *); extern doublereal slamc3_(real *, real *); static real dj; extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *, real *, integer *, integer *, complex *, integer *, integer *), csscal_(integer *, real *, complex *, integer *), clacpy_(char *, integer *, integer *, complex *, integer *, complex *, integer *), xerbla_(char *, integer *); static real dsigjp; static integer nlp1; #define difr_ref(a_1,a_2) difr[(a_2)*difr_dim1 + a_1] #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 poles_ref(a_1,a_2) poles[(a_2)*poles_dim1 + a_1] #define bx_subscr(a_1,a_2) (a_2)*bx_dim1 + a_1 #define bx_ref(a_1,a_2) bx[bx_subscr(a_1,a_2)] #define givcol_ref(a_1,a_2) givcol[(a_2)*givcol_dim1 + a_1] #define givnum_ref(a_1,a_2) givnum[(a_2)*givnum_dim1 + a_1] b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; bx_dim1 = *ldbx; bx_offset = 1 + bx_dim1 * 1; bx -= bx_offset; --perm; givcol_dim1 = *ldgcol; givcol_offset = 1 + givcol_dim1 * 1; givcol -= givcol_offset; difr_dim1 = *ldgnum; difr_offset = 1 + difr_dim1 * 1; difr -= difr_offset; poles_dim1 = *ldgnum; poles_offset = 1 + poles_dim1 * 1; poles -= poles_offset; givnum_dim1 = *ldgnum; givnum_offset = 1 + givnum_dim1 * 1; givnum -= givnum_offset; --difl; --z__; --rwork; /* Function Body */ *info = 0; if (*icompq < 0 || *icompq > 1) { *info = -1; } else if (*nl < 1) { *info = -2; } else if (*nr < 1) { *info = -3; } else if (*sqre < 0 || *sqre > 1) { *info = -4; } n = *nl + *nr + 1; if (*nrhs < 1) { *info = -5; } else if (*ldb < n) { *info = -7; } else if (*ldbx < n) { *info = -9; } else if (*givptr < 0) { *info = -11; } else if (*ldgcol < n) { *info = -13; } else if (*ldgnum < n) { *info = -15; } else if (*k < 1) { *info = -20; } if (*info != 0) { i__1 = -(*info); xerbla_("CLALS0", &i__1); return 0; } m = n + *sqre; nlp1 = *nl + 1; if (*icompq == 0) { /* Apply back orthogonal transformations from the left. Step (1L): apply back the Givens rotations performed. */ i__1 = *givptr; for (i__ = 1; i__ <= i__1; ++i__) { csrot_(nrhs, &b_ref(givcol_ref(i__, 2), 1), ldb, &b_ref( givcol_ref(i__, 1), 1), ldb, &givnum_ref(i__, 2), & givnum_ref(i__, 1)); /* L10: */ } /* Step (2L): permute rows of B. */ ccopy_(nrhs, &b_ref(nlp1, 1), ldb, &bx_ref(1, 1), ldbx); i__1 = n; for (i__ = 2; i__ <= i__1; ++i__) { ccopy_(nrhs, &b_ref(perm[i__], 1), ldb, &bx_ref(i__, 1), ldbx); /* L20: */ } /* Step (3L): apply the inverse of the left singular vector matrix to BX. */ if (*k == 1) { ccopy_(nrhs, &bx[bx_offset], ldbx, &b[b_offset], ldb); if (z__[1] < 0.f) { csscal_(nrhs, &c_b5, &b[b_offset], ldb); } } else { i__1 = *k; for (j = 1; j <= i__1; ++j) { diflj = difl[j]; dj = poles_ref(j, 1); dsigj = -poles_ref(j, 2); if (j < *k) { difrj = -difr_ref(j, 1); dsigjp = -poles_ref(j + 1, 2); } if (z__[j] == 0.f || poles_ref(j, 2) == 0.f) { rwork[j] = 0.f; } else { rwork[j] = -poles_ref(j, 2) * z__[j] / diflj / (poles_ref( j, 2) + dj); } i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { if (z__[i__] == 0.f || poles_ref(i__, 2) == 0.f) { rwork[i__] = 0.f; } else { rwork[i__] = poles_ref(i__, 2) * z__[i__] / (slamc3_(& poles_ref(i__, 2), &dsigj) - diflj) / ( poles_ref(i__, 2) + dj); } /* L30: */ } i__2 = *k; for (i__ = j + 1; i__ <= i__2; ++i__) { if (z__[i__] == 0.f || poles_ref(i__, 2) == 0.f) { rwork[i__] = 0.f; } else { rwork[i__] = poles_ref(i__, 2) * z__[i__] / (slamc3_(& poles_ref(i__, 2), &dsigjp) + difrj) / ( poles_ref(i__, 2) + dj); } /* L40: */ } rwork[1] = -1.f; temp = snrm2_(k, &rwork[1], &c__1); /* Since B and BX are complex, the following call to SGEMV is performed in two steps (real and imaginary parts). CALL SGEMV( 'T', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO, $ B( J, 1 ), LDB ) */ i__ = *k + (*nrhs << 1); i__2 = *nrhs; for (jcol = 1; jcol <= i__2; ++jcol) { i__3 = *k; for (jrow = 1; jrow <= i__3; ++jrow) { ++i__; i__4 = bx_subscr(jrow, jcol); rwork[i__] = bx[i__4].r; /* L50: */ } /* L60: */ } sgemv_("T", k, nrhs, &c_b13, &rwork[*k + 1 + (*nrhs << 1)], k, &rwork[1], &c__1, &c_b15, &rwork[*k + 1], &c__1); i__ = *k + (*nrhs << 1); i__2 = *nrhs; for (jcol = 1; jcol <= i__2; ++jcol) { i__3 = *k; for (jrow = 1; jrow <= i__3; ++jrow) { ++i__; rwork[i__] = r_imag(&bx_ref(jrow, jcol)); /* L70: */ } /* L80: */ } sgemv_("T", k, nrhs, &c_b13, &rwork[*k + 1 + (*nrhs << 1)], k, &rwork[1], &c__1, &c_b15, &rwork[*k + 1 + *nrhs], & c__1); i__2 = *nrhs; for (jcol = 1; jcol <= i__2; ++jcol) { i__3 = b_subscr(j, jcol); i__4 = jcol + *k; i__5 = jcol + *k + *nrhs; q__1.r = rwork[i__4], q__1.i = rwork[i__5]; b[i__3].r = q__1.r, b[i__3].i = q__1.i; /* L90: */ } clascl_("G", &c__0, &c__0, &temp, &c_b13, &c__1, nrhs, &b_ref( j, 1), ldb, info); /* L100: */ } } /* Move the deflated rows of BX to B also. */ if (*k < max(m,n)) { i__1 = n - *k; clacpy_("A", &i__1, nrhs, &bx_ref(*k + 1, 1), ldbx, &b_ref(*k + 1, 1), ldb); } } else { /* Apply back the right orthogonal transformations. Step (1R): apply back the new right singular vector matrix to B. */ if (*k == 1) { ccopy_(nrhs, &b[b_offset], ldb, &bx[bx_offset], ldbx); } else { i__1 = *k; for (j = 1; j <= i__1; ++j) { dsigj = poles_ref(j, 2); if (z__[j] == 0.f) { rwork[j] = 0.f; } else { rwork[j] = -z__[j] / difl[j] / (dsigj + poles_ref(j, 1)) / difr_ref(j, 2); } i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { if (z__[j] == 0.f) { rwork[i__] = 0.f; } else { r__1 = -poles_ref(i__ + 1, 2); rwork[i__] = z__[j] / (slamc3_(&dsigj, &r__1) - difr_ref(i__, 1)) / (dsigj + poles_ref(i__, 1) ) / difr_ref(i__, 2); } /* L110: */ } i__2 = *k; for (i__ = j + 1; i__ <= i__2; ++i__) { if (z__[j] == 0.f) { rwork[i__] = 0.f; } else { r__1 = -poles_ref(i__, 2); rwork[i__] = z__[j] / (slamc3_(&dsigj, &r__1) - difl[ i__]) / (dsigj + poles_ref(i__, 1)) / difr_ref(i__, 2); } /* L120: */ } /* Since B and BX are complex, the following call to SGEMV is performed in two steps (real and imaginary parts). CALL SGEMV( 'T', K, NRHS, ONE, B, LDB, WORK, 1, ZERO, $ BX( J, 1 ), LDBX ) */ i__ = *k + (*nrhs << 1); i__2 = *nrhs; for (jcol = 1; jcol <= i__2; ++jcol) { i__3 = *k; for (jrow = 1; jrow <= i__3; ++jrow) { ++i__; i__4 = b_subscr(jrow, jcol); rwork[i__] = b[i__4].r; /* L130: */ } /* L140: */ } sgemv_("T", k, nrhs, &c_b13, &rwork[*k + 1 + (*nrhs << 1)], k, &rwork[1], &c__1, &c_b15, &rwork[*k + 1], &c__1); i__ = *k + (*nrhs << 1); i__2 = *nrhs; for (jcol = 1; jcol <= i__2; ++jcol) { i__3 = *k; for (jrow = 1; jrow <= i__3; ++jrow) { ++i__; rwork[i__] = r_imag(&b_ref(jrow, jcol)); /* L150: */ } /* L160: */ } sgemv_("T", k, nrhs, &c_b13, &rwork[*k + 1 + (*nrhs << 1)], k, &rwork[1], &c__1, &c_b15, &rwork[*k + 1 + *nrhs], & c__1); i__2 = *nrhs; for (jcol = 1; jcol <= i__2; ++jcol) { i__3 = bx_subscr(j, jcol); i__4 = jcol + *k; i__5 = jcol + *k + *nrhs; q__1.r = rwork[i__4], q__1.i = rwork[i__5]; bx[i__3].r = q__1.r, bx[i__3].i = q__1.i; /* L170: */ } /* L180: */ } } /* Step (2R): if SQRE = 1, apply back the rotation that is related to the right null space of the subproblem. */ if (*sqre == 1) { ccopy_(nrhs, &b_ref(m, 1), ldb, &bx_ref(m, 1), ldbx); csrot_(nrhs, &bx_ref(1, 1), ldbx, &bx_ref(m, 1), ldbx, c__, s); } if (*k < max(m,n)) { i__1 = n - *k; clacpy_("A", &i__1, nrhs, &b_ref(*k + 1, 1), ldb, &bx_ref(*k + 1, 1), ldbx); } /* Step (3R): permute rows of B. */ ccopy_(nrhs, &bx_ref(1, 1), ldbx, &b_ref(nlp1, 1), ldb); if (*sqre == 1) { ccopy_(nrhs, &bx_ref(m, 1), ldbx, &b_ref(m, 1), ldb); } i__1 = n; for (i__ = 2; i__ <= i__1; ++i__) { ccopy_(nrhs, &bx_ref(i__, 1), ldbx, &b_ref(perm[i__], 1), ldb); /* L190: */ } /* Step (4R): apply back the Givens rotations performed. */ for (i__ = *givptr; i__ >= 1; --i__) { r__1 = -givnum_ref(i__, 1); csrot_(nrhs, &b_ref(givcol_ref(i__, 2), 1), ldb, &b_ref( givcol_ref(i__, 1), 1), ldb, &givnum_ref(i__, 2), &r__1); /* L200: */ } } return 0; /* End of CLALS0 */ } /* clals0_ */
/* Subroutine */ int ctrsyl_(char *trana, char *tranb, integer *isgn, integer *m, integer *n, complex *a, integer *lda, complex *b, integer *ldb, complex *c__, integer *ldc, real *scale, 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 ======= CTRSYL solves the complex Sylvester matrix equation: op(A)*X + X*op(B) = scale*C or op(A)*X - X*op(B) = scale*C, where op(A) = A or A**H, and A and B are both upper triangular. A is M-by-M and B is N-by-N; the right hand side C and the solution X are M-by-N; and scale is an output scale factor, set <= 1 to avoid overflow in X. Arguments ========= TRANA (input) CHARACTER*1 Specifies the option op(A): = 'N': op(A) = A (No transpose) = 'C': op(A) = A**H (Conjugate transpose) TRANB (input) CHARACTER*1 Specifies the option op(B): = 'N': op(B) = B (No transpose) = 'C': op(B) = B**H (Conjugate transpose) ISGN (input) INTEGER Specifies the sign in the equation: = +1: solve op(A)*X + X*op(B) = scale*C = -1: solve op(A)*X - X*op(B) = scale*C M (input) INTEGER The order of the matrix A, and the number of rows in the matrices X and C. M >= 0. N (input) INTEGER The order of the matrix B, and the number of columns in the matrices X and C. N >= 0. 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, the M-by-N right hand side matrix C. On exit, C is overwritten by the solution matrix X. LDC (input) INTEGER The leading dimension of the array C. LDC >= max(1,M) SCALE (output) REAL The scale factor, scale, set <= 1 to avoid overflow in X. INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value = 1: A and B have common or very close eigenvalues; perturbed values were used to solve the equation (but the matrices A and B are unchanged). ===================================================================== Decode and Test 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, c_dim1, c_offset, i__1, i__2, i__3, i__4; real r__1, r__2; complex q__1, q__2, q__3, q__4; /* Builtin functions */ double r_imag(complex *); void r_cnjg(complex *, complex *); /* Local variables */ static real smin; static complex suml, sumr; static integer j, k, l; extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer *, complex *, integer *); extern logical lsame_(char *, char *); extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer *, complex *, integer *); static complex a11; static real db; extern /* Subroutine */ int slabad_(real *, real *); extern doublereal clange_(char *, integer *, integer *, complex *, integer *, real *); static complex x11; extern /* Complex */ VOID cladiv_(complex *, complex *, complex *); static real scaloc; extern doublereal slamch_(char *); extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer *), xerbla_(char *, integer *); static real bignum; static logical notrna, notrnb; static real smlnum, da11; static complex vec; static real dum[1], eps, sgn; #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)] 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; /* Function Body */ notrna = lsame_(trana, "N"); notrnb = lsame_(tranb, "N"); *info = 0; if (! notrna && ! lsame_(trana, "T") && ! lsame_( trana, "C")) { *info = -1; } else if (! notrnb && ! lsame_(tranb, "T") && ! lsame_(tranb, "C")) { *info = -2; } else if (*isgn != 1 && *isgn != -1) { *info = -3; } else if (*m < 0) { *info = -4; } else if (*n < 0) { *info = -5; } else if (*lda < max(1,*m)) { *info = -7; } else if (*ldb < max(1,*n)) { *info = -9; } else if (*ldc < max(1,*m)) { *info = -11; } if (*info != 0) { i__1 = -(*info); xerbla_("CTRSYL", &i__1); return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0) { return 0; } /* Set constants to control overflow */ eps = slamch_("P"); smlnum = slamch_("S"); bignum = 1.f / smlnum; slabad_(&smlnum, &bignum); smlnum = smlnum * (real) (*m * *n) / eps; bignum = 1.f / smlnum; /* Computing MAX */ r__1 = smlnum, r__2 = eps * clange_("M", m, m, &a[a_offset], lda, dum), r__1 = max(r__1,r__2), r__2 = eps * clange_("M", n, n, &b[b_offset], ldb, dum); smin = dmax(r__1,r__2); *scale = 1.f; sgn = (real) (*isgn); if (notrna && notrnb) { /* Solve A*X + ISGN*X*B = scale*C. The (K,L)th block of X is determined starting from bottom-left corner column by column by A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) Where M L-1 R(K,L) = SUM [A(K,I)*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)]. I=K+1 J=1 */ i__1 = *n; for (l = 1; l <= i__1; ++l) { for (k = *m; k >= 1; --k) { /* Computing MIN */ i__2 = k + 1; /* Computing MIN */ i__3 = k + 1; i__4 = *m - k; cdotu_(&q__1, &i__4, &a_ref(k, min(i__2,*m)), lda, &c___ref( min(i__3,*m), l), &c__1); suml.r = q__1.r, suml.i = q__1.i; i__2 = l - 1; cdotu_(&q__1, &i__2, &c___ref(k, 1), ldc, &b_ref(1, l), &c__1) ; sumr.r = q__1.r, sumr.i = q__1.i; i__2 = c___subscr(k, l); q__3.r = sgn * sumr.r, q__3.i = sgn * sumr.i; q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i; q__1.r = c__[i__2].r - q__2.r, q__1.i = c__[i__2].i - q__2.i; vec.r = q__1.r, vec.i = q__1.i; scaloc = 1.f; i__2 = a_subscr(k, k); i__3 = b_subscr(l, l); q__2.r = sgn * b[i__3].r, q__2.i = sgn * b[i__3].i; q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i; a11.r = q__1.r, a11.i = q__1.i; da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11), dabs(r__2)); if (da11 <= smin) { a11.r = smin, a11.i = 0.f; da11 = smin; *info = 1; } db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs( r__2)); if (da11 < 1.f && db > 1.f) { if (db > bignum * da11) { scaloc = 1.f / db; } } q__3.r = scaloc, q__3.i = 0.f; q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r * q__3.i + vec.i * q__3.r; cladiv_(&q__1, &q__2, &a11); x11.r = q__1.r, x11.i = q__1.i; if (scaloc != 1.f) { i__2 = *n; for (j = 1; j <= i__2; ++j) { csscal_(m, &scaloc, &c___ref(1, j), &c__1); /* L10: */ } *scale *= scaloc; } i__2 = c___subscr(k, l); c__[i__2].r = x11.r, c__[i__2].i = x11.i; /* L20: */ } /* L30: */ } } else if (! notrna && notrnb) { /* Solve A' *X + ISGN*X*B = scale*C. The (K,L)th block of X is determined starting from upper-left corner column by column by A'(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) Where K-1 L-1 R(K,L) = SUM [A'(I,K)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)] I=1 J=1 */ i__1 = *n; for (l = 1; l <= i__1; ++l) { i__2 = *m; for (k = 1; k <= i__2; ++k) { i__3 = k - 1; cdotc_(&q__1, &i__3, &a_ref(1, k), &c__1, &c___ref(1, l), & c__1); suml.r = q__1.r, suml.i = q__1.i; i__3 = l - 1; cdotu_(&q__1, &i__3, &c___ref(k, 1), ldc, &b_ref(1, l), &c__1) ; sumr.r = q__1.r, sumr.i = q__1.i; i__3 = c___subscr(k, l); q__3.r = sgn * sumr.r, q__3.i = sgn * sumr.i; q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i; q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i; vec.r = q__1.r, vec.i = q__1.i; scaloc = 1.f; r_cnjg(&q__2, &a_ref(k, k)); i__3 = b_subscr(l, l); q__3.r = sgn * b[i__3].r, q__3.i = sgn * b[i__3].i; q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; a11.r = q__1.r, a11.i = q__1.i; da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11), dabs(r__2)); if (da11 <= smin) { a11.r = smin, a11.i = 0.f; da11 = smin; *info = 1; } db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs( r__2)); if (da11 < 1.f && db > 1.f) { if (db > bignum * da11) { scaloc = 1.f / db; } } q__3.r = scaloc, q__3.i = 0.f; q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r * q__3.i + vec.i * q__3.r; cladiv_(&q__1, &q__2, &a11); x11.r = q__1.r, x11.i = q__1.i; if (scaloc != 1.f) { i__3 = *n; for (j = 1; j <= i__3; ++j) { csscal_(m, &scaloc, &c___ref(1, j), &c__1); /* L40: */ } *scale *= scaloc; } i__3 = c___subscr(k, l); c__[i__3].r = x11.r, c__[i__3].i = x11.i; /* L50: */ } /* L60: */ } } else if (! notrna && ! notrnb) { /* Solve A'*X + ISGN*X*B' = C. The (K,L)th block of X is determined starting from upper-right corner column by column by A'(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L) Where K-1 R(K,L) = SUM [A'(I,K)*X(I,L)] + I=1 N ISGN*SUM [X(K,J)*B'(L,J)]. J=L+1 */ for (l = *n; l >= 1; --l) { i__1 = *m; for (k = 1; k <= i__1; ++k) { i__2 = k - 1; cdotc_(&q__1, &i__2, &a_ref(1, k), &c__1, &c___ref(1, l), & c__1); suml.r = q__1.r, suml.i = q__1.i; /* Computing MIN */ i__2 = l + 1; /* Computing MIN */ i__3 = l + 1; i__4 = *n - l; cdotc_(&q__1, &i__4, &c___ref(k, min(i__2,*n)), ldc, &b_ref(l, min(i__3,*n)), ldb); sumr.r = q__1.r, sumr.i = q__1.i; i__2 = c___subscr(k, l); r_cnjg(&q__4, &sumr); q__3.r = sgn * q__4.r, q__3.i = sgn * q__4.i; q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i; q__1.r = c__[i__2].r - q__2.r, q__1.i = c__[i__2].i - q__2.i; vec.r = q__1.r, vec.i = q__1.i; scaloc = 1.f; i__2 = a_subscr(k, k); i__3 = b_subscr(l, l); q__3.r = sgn * b[i__3].r, q__3.i = sgn * b[i__3].i; q__2.r = a[i__2].r + q__3.r, q__2.i = a[i__2].i + q__3.i; r_cnjg(&q__1, &q__2); a11.r = q__1.r, a11.i = q__1.i; da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11), dabs(r__2)); if (da11 <= smin) { a11.r = smin, a11.i = 0.f; da11 = smin; *info = 1; } db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs( r__2)); if (da11 < 1.f && db > 1.f) { if (db > bignum * da11) { scaloc = 1.f / db; } } q__3.r = scaloc, q__3.i = 0.f; q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r * q__3.i + vec.i * q__3.r; cladiv_(&q__1, &q__2, &a11); x11.r = q__1.r, x11.i = q__1.i; if (scaloc != 1.f) { i__2 = *n; for (j = 1; j <= i__2; ++j) { csscal_(m, &scaloc, &c___ref(1, j), &c__1); /* L70: */ } *scale *= scaloc; } i__2 = c___subscr(k, l); c__[i__2].r = x11.r, c__[i__2].i = x11.i; /* L80: */ } /* L90: */ } } else if (notrna && ! notrnb) { /* Solve A*X + ISGN*X*B' = C. The (K,L)th block of X is determined starting from bottom-left corner column by column by A(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L) Where M N R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B'(L,J)] I=K+1 J=L+1 */ for (l = *n; l >= 1; --l) { for (k = *m; k >= 1; --k) { /* Computing MIN */ i__1 = k + 1; /* Computing MIN */ i__2 = k + 1; i__3 = *m - k; cdotu_(&q__1, &i__3, &a_ref(k, min(i__1,*m)), lda, &c___ref( min(i__2,*m), l), &c__1); suml.r = q__1.r, suml.i = q__1.i; /* Computing MIN */ i__1 = l + 1; /* Computing MIN */ i__2 = l + 1; i__3 = *n - l; cdotc_(&q__1, &i__3, &c___ref(k, min(i__1,*n)), ldc, &b_ref(l, min(i__2,*n)), ldb); sumr.r = q__1.r, sumr.i = q__1.i; i__1 = c___subscr(k, l); r_cnjg(&q__4, &sumr); q__3.r = sgn * q__4.r, q__3.i = sgn * q__4.i; q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i; q__1.r = c__[i__1].r - q__2.r, q__1.i = c__[i__1].i - q__2.i; vec.r = q__1.r, vec.i = q__1.i; scaloc = 1.f; i__1 = a_subscr(k, k); r_cnjg(&q__3, &b_ref(l, l)); q__2.r = sgn * q__3.r, q__2.i = sgn * q__3.i; q__1.r = a[i__1].r + q__2.r, q__1.i = a[i__1].i + q__2.i; a11.r = q__1.r, a11.i = q__1.i; da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11), dabs(r__2)); if (da11 <= smin) { a11.r = smin, a11.i = 0.f; da11 = smin; *info = 1; } db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs( r__2)); if (da11 < 1.f && db > 1.f) { if (db > bignum * da11) { scaloc = 1.f / db; } } q__3.r = scaloc, q__3.i = 0.f; q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r * q__3.i + vec.i * q__3.r; cladiv_(&q__1, &q__2, &a11); x11.r = q__1.r, x11.i = q__1.i; if (scaloc != 1.f) { i__1 = *n; for (j = 1; j <= i__1; ++j) { csscal_(m, &scaloc, &c___ref(1, j), &c__1); /* L100: */ } *scale *= scaloc; } i__1 = c___subscr(k, l); c__[i__1].r = x11.r, c__[i__1].i = x11.i; /* L110: */ } /* L120: */ } } return 0; /* End of CTRSYL */ } /* ctrsyl_ */
/* Subroutine */ int zgels_(char *trans, integer *m, integer *n, integer * nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *work, integer *lwork, integer *info) { /* -- LAPACK driver 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 ======= ZGELS solves overdetermined or underdetermined complex linear systems involving an M-by-N matrix A, or its conjugate-transpose, using a QR or LQ factorization of A. It is assumed that A has full rank. The following options are provided: 1. If TRANS = 'N' and m >= n: find the least squares solution of an overdetermined system, i.e., solve the least squares problem minimize || B - A*X ||. 2. If TRANS = 'N' and m < n: find the minimum norm solution of an underdetermined system A * X = B. 3. If TRANS = 'C' and m >= n: find the minimum norm solution of an undetermined system A**H * X = B. 4. If TRANS = 'C' and m < n: find the least squares solution of an overdetermined system, i.e., solve the least squares problem minimize || B - A**H * X ||. Several right hand side vectors b and solution vectors x can be handled in a single call; they are stored as the columns of the M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix X. Arguments ========= TRANS (input) CHARACTER = 'N': the linear system involves A; = 'C': the linear system involves A**H. 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. NRHS (input) INTEGER The number of right hand sides, i.e., the number of columns of the matrices B and X. NRHS >= 0. A (input/output) COMPLEX*16 array, dimension (LDA,N) On entry, the M-by-N matrix A. if M >= N, A is overwritten by details of its QR factorization as returned by ZGEQRF; if M < N, A is overwritten by details of its LQ factorization as returned by ZGELQF. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,M). B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) On entry, the matrix B of right hand side vectors, stored columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS if TRANS = 'C'. On exit, B is overwritten by the solution vectors, stored columnwise: if TRANS = 'N' and m >= n, rows 1 to n of B contain the least squares solution vectors; the residual sum of squares for the solution in each column is given by the sum of squares of elements N+1 to M in that column; if TRANS = 'N' and m < n, rows 1 to N of B contain the minimum norm solution vectors; if TRANS = 'C' and m >= n, rows 1 to M of B contain the minimum norm solution vectors; if TRANS = 'C' and m < n, rows 1 to M of B contain the least squares solution vectors; the residual sum of squares for the solution in each column is given by the sum of squares of elements M+1 to N in that column. LDB (input) INTEGER The leading dimension of the array B. LDB >= MAX(1,M,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, MN + max( MN, NRHS ) ). For optimal performance, LWORK >= max( 1, MN + max( MN, NRHS )*NB ). where MN = min(M,N) and NB is the optimum block size. 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. INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value ===================================================================== Test the input arguments. Parameter adjustments */ /* Table of constant values */ static doublecomplex c_b1 = {0.,0.}; static doublecomplex c_b2 = {1.,0.}; static integer c__1 = 1; static integer c_n1 = -1; static integer c__0 = 0; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; doublereal d__1; /* Local variables */ static doublereal anrm, bnrm; static integer brow; static logical tpsd; static integer i__, j, iascl, ibscl; extern logical lsame_(char *, char *); static integer wsize; static doublereal rwork[1]; extern /* Subroutine */ int ztrsm_(char *, char *, char *, char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), dlabad_(doublereal *, doublereal *); static integer nb; extern doublereal dlamch_(char *); static integer mn; extern /* Subroutine */ int xerbla_(char *, integer *); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); static integer scllen; static doublereal bignum; extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, integer *, doublereal *); extern /* Subroutine */ int zgelqf_(integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer * ), zlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *, doublecomplex *, integer *, integer *), zgeqrf_(integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *), zlaset_( char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *); static doublereal smlnum; static logical lquery; extern /* Subroutine */ int zunmlq_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer *), zunmqr_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer *); #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)] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; --work; /* Function Body */ *info = 0; mn = min(*m,*n); lquery = *lwork == -1; if (! (lsame_(trans, "N") || lsame_(trans, "C"))) { *info = -1; } else if (*m < 0) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*nrhs < 0) { *info = -4; } else if (*lda < max(1,*m)) { *info = -6; } else /* if(complicated condition) */ { /* Computing MAX */ i__1 = max(1,*m); if (*ldb < max(i__1,*n)) { *info = -8; } else /* if(complicated condition) */ { /* Computing MAX */ i__1 = 1, i__2 = mn + max(mn,*nrhs); if (*lwork < max(i__1,i__2) && ! lquery) { *info = -10; } } } /* Figure out optimal block size */ if (*info == 0 || *info == -10) { tpsd = TRUE_; if (lsame_(trans, "N")) { tpsd = FALSE_; } if (*m >= *n) { nb = ilaenv_(&c__1, "ZGEQRF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); if (tpsd) { /* Computing MAX */ i__1 = nb, i__2 = ilaenv_(&c__1, "ZUNMQR", "LN", m, nrhs, n, & c_n1, (ftnlen)6, (ftnlen)2); nb = max(i__1,i__2); } else { /* Computing MAX */ i__1 = nb, i__2 = ilaenv_(&c__1, "ZUNMQR", "LC", m, nrhs, n, & c_n1, (ftnlen)6, (ftnlen)2); nb = max(i__1,i__2); } } else { nb = ilaenv_(&c__1, "ZGELQF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); if (tpsd) { /* Computing MAX */ i__1 = nb, i__2 = ilaenv_(&c__1, "ZUNMLQ", "LC", n, nrhs, m, & c_n1, (ftnlen)6, (ftnlen)2); nb = max(i__1,i__2); } else { /* Computing MAX */ i__1 = nb, i__2 = ilaenv_(&c__1, "ZUNMLQ", "LN", n, nrhs, m, & c_n1, (ftnlen)6, (ftnlen)2); nb = max(i__1,i__2); } } /* Computing MAX */ i__1 = 1, i__2 = mn + max(mn,*nrhs) * nb; wsize = max(i__1,i__2); d__1 = (doublereal) wsize; work[1].r = d__1, work[1].i = 0.; } if (*info != 0) { i__1 = -(*info); xerbla_("ZGELS ", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible Computing MIN */ i__1 = min(*m,*n); if (min(i__1,*nrhs) == 0) { i__1 = max(*m,*n); zlaset_("Full", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb); return 0; } /* Get machine parameters */ smlnum = dlamch_("S") / dlamch_("P"); bignum = 1. / smlnum; dlabad_(&smlnum, &bignum); /* Scale A, B if max element outside range [SMLNUM,BIGNUM] */ anrm = zlange_("M", m, n, &a[a_offset], lda, rwork); iascl = 0; if (anrm > 0. && anrm < smlnum) { /* Scale matrix norm up to SMLNUM */ zlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, info); iascl = 1; } else if (anrm > bignum) { /* Scale matrix norm down to BIGNUM */ zlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, info); iascl = 2; } else if (anrm == 0.) { /* Matrix all zero. Return zero solution. */ i__1 = max(*m,*n); zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb); goto L50; } brow = *m; if (tpsd) { brow = *n; } bnrm = zlange_("M", &brow, nrhs, &b[b_offset], ldb, rwork); ibscl = 0; if (bnrm > 0. && bnrm < smlnum) { /* Scale matrix norm up to SMLNUM */ zlascl_("G", &c__0, &c__0, &bnrm, &smlnum, &brow, nrhs, &b[b_offset], ldb, info); ibscl = 1; } else if (bnrm > bignum) { /* Scale matrix norm down to BIGNUM */ zlascl_("G", &c__0, &c__0, &bnrm, &bignum, &brow, nrhs, &b[b_offset], ldb, info); ibscl = 2; } if (*m >= *n) { /* compute QR factorization of A */ i__1 = *lwork - mn; zgeqrf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info) ; /* workspace at least N, optimally N*NB */ if (! tpsd) { /* Least-Squares Problem min || A * X - B || B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */ i__1 = *lwork - mn; zunmqr_("Left", "Conjugate transpose", m, nrhs, n, &a[a_offset], lda, &work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info); /* workspace at least NRHS, optimally NRHS*NB B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS) */ ztrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, & c_b2, &a[a_offset], lda, &b[b_offset], ldb); scllen = *n; } else { /* Overdetermined system of equations A' * X = B B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS) */ ztrsm_("Left", "Upper", "Conjugate transpose", "Non-unit", n, nrhs, &c_b2, &a[a_offset], lda, &b[b_offset], ldb); /* B(N+1:M,1:NRHS) = ZERO */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = *n + 1; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); b[i__3].r = 0., b[i__3].i = 0.; /* L10: */ } /* L20: */ } /* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS) */ i__1 = *lwork - mn; zunmqr_("Left", "No transpose", m, nrhs, n, &a[a_offset], lda, & work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info); /* workspace at least NRHS, optimally NRHS*NB */ scllen = *m; } } else { /* Compute LQ factorization of A */ i__1 = *lwork - mn; zgelqf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info) ; /* workspace at least M, optimally M*NB. */ if (! tpsd) { /* underdetermined system of equations A * X = B B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS) */ ztrsm_("Left", "Lower", "No transpose", "Non-unit", m, nrhs, & c_b2, &a[a_offset], lda, &b[b_offset], ldb); /* B(M+1:N,1:NRHS) = 0 */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = *m + 1; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); b[i__3].r = 0., b[i__3].i = 0.; /* L30: */ } /* L40: */ } /* B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS) */ i__1 = *lwork - mn; zunmlq_("Left", "Conjugate transpose", n, nrhs, m, &a[a_offset], lda, &work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info); /* workspace at least NRHS, optimally NRHS*NB */ scllen = *n; } else { /* overdetermined system min || A' * X - B || B(1:N,1:NRHS) := Q * B(1:N,1:NRHS) */ i__1 = *lwork - mn; zunmlq_("Left", "No transpose", n, nrhs, m, &a[a_offset], lda, & work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info); /* workspace at least NRHS, optimally NRHS*NB B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS) */ ztrsm_("Left", "Lower", "Conjugate transpose", "Non-unit", m, nrhs, &c_b2, &a[a_offset], lda, &b[b_offset], ldb); scllen = *m; } } /* Undo scaling */ if (iascl == 1) { zlascl_("G", &c__0, &c__0, &anrm, &smlnum, &scllen, nrhs, &b[b_offset] , ldb, info); } else if (iascl == 2) { zlascl_("G", &c__0, &c__0, &anrm, &bignum, &scllen, nrhs, &b[b_offset] , ldb, info); } if (ibscl == 1) { zlascl_("G", &c__0, &c__0, &smlnum, &bnrm, &scllen, nrhs, &b[b_offset] , ldb, info); } else if (ibscl == 2) { zlascl_("G", &c__0, &c__0, &bignum, &bnrm, &scllen, nrhs, &b[b_offset] , ldb, info); } L50: d__1 = (doublereal) wsize; work[1].r = d__1, work[1].i = 0.; return 0; /* End of ZGELS */ } /* zgels_ */
/* Subroutine */ int ztrt05_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublecomplex *xact, integer *ldxact, doublereal *ferr, doublereal *berr, doublereal * reslts) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1, xact_offset, i__1, i__2, i__3, i__4, i__5; doublereal d__1, d__2, d__3, d__4; doublecomplex z__1, z__2; /* Builtin functions */ double d_imag(doublecomplex *); /* Local variables */ static doublereal diff, axbi; static integer imax; static doublereal unfl, ovfl; static logical unit; static integer i__, j, k; extern logical lsame_(char *, char *); static logical upper; static doublereal xnorm; extern doublereal dlamch_(char *); static doublereal errbnd; extern integer izamax_(integer *, doublecomplex *, integer *); static logical notran; static integer ifu; static doublereal eps, tmp; #define xact_subscr(a_1,a_2) (a_2)*xact_dim1 + a_1 #define xact_ref(a_1,a_2) xact[xact_subscr(a_1,a_2)] #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 x_subscr(a_1,a_2) (a_2)*x_dim1 + a_1 #define x_ref(a_1,a_2) x[x_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 February 29, 1992 Purpose ======= ZTRT05 tests the error bounds from iterative refinement for the computed solution to a system of equations A*X = B, where A is a triangular n by n matrix. RESLTS(1) = test of the error bound = norm(X - XACT) / ( norm(X) * FERR ) A large value is returned if this ratio is not less than one. RESLTS(2) = residual from the iterative refinement routine = the maximum of BERR / ( (n+1)*EPS + (*) ), where (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) Arguments ========= UPLO (input) CHARACTER*1 Specifies whether the matrix A is upper or lower triangular. = 'U': Upper triangular = 'L': Lower triangular TRANS (input) CHARACTER*1 Specifies the form of the system of equations. = 'N': A * X = B (No transpose) = 'T': A'* X = B (Transpose) = 'C': A'* X = B (Conjugate transpose = Transpose) DIAG (input) CHARACTER*1 Specifies whether or not the matrix A is unit triangular. = 'N': Non-unit triangular = 'U': Unit triangular N (input) INTEGER The number of rows of the matrices X, B, and XACT, and the order of the matrix A. N >= 0. NRHS (input) INTEGER The number of columns of the matrices X, B, and XACT. NRHS >= 0. A (input) COMPLEX*16 array, dimension (LDA,N) The triangular matrix A. If UPLO = 'U', the leading n by n upper triangular part of the array A contains the upper triangular matrix, and the strictly lower triangular part of A is not referenced. If UPLO = 'L', the leading n by n lower triangular part of the array A contains the lower triangular matrix, and the strictly upper triangular part of A is not referenced. If DIAG = 'U', the diagonal elements of A are also not referenced and are assumed to be 1. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,N). B (input) COMPLEX*16 array, dimension (LDB,NRHS) The right hand side vectors for the system of linear equations. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,N). X (input) COMPLEX*16 array, dimension (LDX,NRHS) The computed solution vectors. Each vector is stored as a column of the matrix X. LDX (input) INTEGER The leading dimension of the array X. LDX >= max(1,N). XACT (input) COMPLEX*16 array, dimension (LDX,NRHS) The exact solution vectors. Each vector is stored as a column of the matrix XACT. LDXACT (input) INTEGER The leading dimension of the array XACT. LDXACT >= max(1,N). FERR (input) DOUBLE PRECISION array, dimension (NRHS) The estimated forward error bounds for each solution vector X. If XTRUE is the true solution, FERR bounds the magnitude of the largest entry in (X - XTRUE) divided by the magnitude of the largest entry in X. BERR (input) DOUBLE PRECISION array, dimension (NRHS) The componentwise relative backward error of each solution vector (i.e., the smallest relative change in any entry of A or B that makes X an exact solution). RESLTS (output) DOUBLE PRECISION array, dimension (2) The maximum over the NRHS solution vectors of the ratios: RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) ===================================================================== Quick exit if N = 0 or NRHS = 0. 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; x_dim1 = *ldx; x_offset = 1 + x_dim1 * 1; x -= x_offset; xact_dim1 = *ldxact; xact_offset = 1 + xact_dim1 * 1; xact -= xact_offset; --ferr; --berr; --reslts; /* Function Body */ if (*n <= 0 || *nrhs <= 0) { reslts[1] = 0.; reslts[2] = 0.; return 0; } eps = dlamch_("Epsilon"); unfl = dlamch_("Safe minimum"); ovfl = 1. / unfl; upper = lsame_(uplo, "U"); notran = lsame_(trans, "N"); unit = lsame_(diag, "U"); /* Test 1: Compute the maximum of norm(X - XACT) / ( norm(X) * FERR ) over all the vectors X and XACT using the infinity-norm. */ errbnd = 0.; i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { imax = izamax_(n, &x_ref(1, j), &c__1); /* Computing MAX */ i__2 = x_subscr(imax, j); d__3 = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x_ref(imax, j)) , abs(d__2)); xnorm = max(d__3,unfl); diff = 0.; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = x_subscr(i__, j); i__4 = xact_subscr(i__, j); z__2.r = x[i__3].r - xact[i__4].r, z__2.i = x[i__3].i - xact[i__4] .i; z__1.r = z__2.r, z__1.i = z__2.i; /* Computing MAX */ d__3 = diff, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(& z__1), abs(d__2)); diff = max(d__3,d__4); /* L10: */ } if (xnorm > 1.) { goto L20; } else if (diff <= ovfl * xnorm) { goto L20; } else { errbnd = 1. / eps; goto L30; } L20: if (diff / xnorm <= ferr[j]) { /* Computing MAX */ d__1 = errbnd, d__2 = diff / xnorm / ferr[j]; errbnd = max(d__1,d__2); } else { errbnd = 1. / eps; } L30: ; } reslts[1] = errbnd; /* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */ ifu = 0; if (unit) { ifu = 1; } i__1 = *nrhs; for (k = 1; k <= i__1; ++k) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, k); tmp = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b_ref(i__, k)), abs(d__2)); if (upper) { if (! notran) { i__3 = i__ - ifu; for (j = 1; j <= i__3; ++j) { i__4 = a_subscr(j, i__); i__5 = x_subscr(j, k); tmp += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a_ref(j, i__)), abs(d__2))) * ((d__3 = x[i__5].r, abs(d__3)) + (d__4 = d_imag(& x_ref(j, k)), abs(d__4))); /* L40: */ } if (unit) { i__3 = x_subscr(i__, k); tmp += (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag( &x_ref(i__, k)), abs(d__2)); } } else { if (unit) { i__3 = x_subscr(i__, k); tmp += (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag( &x_ref(i__, k)), abs(d__2)); } i__3 = *n; for (j = i__ + ifu; j <= i__3; ++j) { i__4 = a_subscr(i__, j); i__5 = x_subscr(j, k); tmp += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a_ref(i__, j)), abs(d__2))) * ((d__3 = x[i__5].r, abs(d__3)) + (d__4 = d_imag(& x_ref(j, k)), abs(d__4))); /* L50: */ } } } else { if (notran) { i__3 = i__ - ifu; for (j = 1; j <= i__3; ++j) { i__4 = a_subscr(i__, j); i__5 = x_subscr(j, k); tmp += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a_ref(i__, j)), abs(d__2))) * ((d__3 = x[i__5].r, abs(d__3)) + (d__4 = d_imag(& x_ref(j, k)), abs(d__4))); /* L60: */ } if (unit) { i__3 = x_subscr(i__, k); tmp += (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag( &x_ref(i__, k)), abs(d__2)); } } else { if (unit) { i__3 = x_subscr(i__, k); tmp += (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag( &x_ref(i__, k)), abs(d__2)); } i__3 = *n; for (j = i__ + ifu; j <= i__3; ++j) { i__4 = a_subscr(j, i__); i__5 = x_subscr(j, k); tmp += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a_ref(j, i__)), abs(d__2))) * ((d__3 = x[i__5].r, abs(d__3)) + (d__4 = d_imag(& x_ref(j, k)), abs(d__4))); /* L70: */ } } } if (i__ == 1) { axbi = tmp; } else { axbi = min(axbi,tmp); } /* L80: */ } /* Computing MAX */ d__1 = axbi, d__2 = (*n + 1) * unfl; tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / max(d__1,d__2)); if (k == 1) { reslts[2] = tmp; } else { reslts[2] = max(reslts[2],tmp); } /* L90: */ } return 0; /* End of ZTRT05 */ } /* ztrt05_ */
/* Subroutine */ int cgtt05_(char *trans, integer *n, integer *nrhs, complex * dl, complex *d__, complex *du, complex *b, integer *ldb, complex *x, integer *ldx, complex *xact, integer *ldxact, real *ferr, real *berr, real *reslts) { /* System generated locals */ integer b_dim1, b_offset, x_dim1, x_offset, xact_dim1, xact_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9; 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; complex q__1, q__2; /* Builtin functions */ double r_imag(complex *); /* Local variables */ static real diff, axbi; static integer imax; static real unfl, ovfl; static integer i__, j, k; extern logical lsame_(char *, char *); static real xnorm; extern integer icamax_(integer *, complex *, integer *); extern doublereal slamch_(char *); static integer nz; static real errbnd; static logical notran; static real eps, tmp; #define xact_subscr(a_1,a_2) (a_2)*xact_dim1 + a_1 #define xact_ref(a_1,a_2) xact[xact_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 x_subscr(a_1,a_2) (a_2)*x_dim1 + a_1 #define x_ref(a_1,a_2) x[x_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 February 29, 1992 Purpose ======= CGTT05 tests the error bounds from iterative refinement for the computed solution to a system of equations A*X = B, where A is a general tridiagonal matrix of order n and op(A) = A or A**T, depending on TRANS. RESLTS(1) = test of the error bound = norm(X - XACT) / ( norm(X) * FERR ) A large value is returned if this ratio is not less than one. RESLTS(2) = residual from the iterative refinement routine = the maximum of BERR / ( NZ*EPS + (*) ), where (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) and NZ = max. number of nonzeros in any row of A, plus 1 Arguments ========= TRANS (input) CHARACTER*1 Specifies the form of the system of equations. = 'N': A * X = B (No transpose) = 'T': A**T * X = B (Transpose) = 'C': A**H * X = B (Conjugate transpose = Transpose) N (input) INTEGER The number of rows of the matrices X and XACT. N >= 0. NRHS (input) INTEGER The number of columns of the matrices X and XACT. NRHS >= 0. DL (input) COMPLEX array, dimension (N-1) The (n-1) sub-diagonal elements of A. D (input) COMPLEX array, dimension (N) The diagonal elements of A. DU (input) COMPLEX array, dimension (N-1) The (n-1) super-diagonal elements of A. B (input) COMPLEX array, dimension (LDB,NRHS) The right hand side vectors for the system of linear equations. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,N). X (input) COMPLEX array, dimension (LDX,NRHS) The computed solution vectors. Each vector is stored as a column of the matrix X. LDX (input) INTEGER The leading dimension of the array X. LDX >= max(1,N). XACT (input) COMPLEX array, dimension (LDX,NRHS) The exact solution vectors. Each vector is stored as a column of the matrix XACT. LDXACT (input) INTEGER The leading dimension of the array XACT. LDXACT >= max(1,N). FERR (input) REAL array, dimension (NRHS) The estimated forward error bounds for each solution vector X. If XTRUE is the true solution, FERR bounds the magnitude of the largest entry in (X - XTRUE) divided by the magnitude of the largest entry in X. BERR (input) REAL array, dimension (NRHS) The componentwise relative backward error of each solution vector (i.e., the smallest relative change in any entry of A or B that makes X an exact solution). RESLTS (output) REAL array, dimension (2) The maximum over the NRHS solution vectors of the ratios: RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) RESLTS(2) = BERR / ( NZ*EPS + (*) ) ===================================================================== Quick exit if N = 0 or NRHS = 0. Parameter adjustments */ --dl; --d__; --du; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; x_dim1 = *ldx; x_offset = 1 + x_dim1 * 1; x -= x_offset; xact_dim1 = *ldxact; xact_offset = 1 + xact_dim1 * 1; xact -= xact_offset; --ferr; --berr; --reslts; /* Function Body */ if (*n <= 0 || *nrhs <= 0) { reslts[1] = 0.f; reslts[2] = 0.f; return 0; } eps = slamch_("Epsilon"); unfl = slamch_("Safe minimum"); ovfl = 1.f / unfl; notran = lsame_(trans, "N"); nz = 4; /* Test 1: Compute the maximum of norm(X - XACT) / ( norm(X) * FERR ) over all the vectors X and XACT using the infinity-norm. */ errbnd = 0.f; i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { imax = icamax_(n, &x_ref(1, j), &c__1); /* Computing MAX */ i__2 = x_subscr(imax, j); r__3 = (r__1 = x[i__2].r, dabs(r__1)) + (r__2 = r_imag(&x_ref(imax, j) ), dabs(r__2)); xnorm = dmax(r__3,unfl); diff = 0.f; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = x_subscr(i__, j); i__4 = xact_subscr(i__, j); q__2.r = x[i__3].r - xact[i__4].r, q__2.i = x[i__3].i - xact[i__4] .i; q__1.r = q__2.r, q__1.i = q__2.i; /* Computing MAX */ r__3 = diff, r__4 = (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(& q__1), dabs(r__2)); diff = dmax(r__3,r__4); /* L10: */ } if (xnorm > 1.f) { goto L20; } else if (diff <= ovfl * xnorm) { goto L20; } else { errbnd = 1.f / eps; goto L30; } L20: if (diff / xnorm <= ferr[j]) { /* Computing MAX */ r__1 = errbnd, r__2 = diff / xnorm / ferr[j]; errbnd = dmax(r__1,r__2); } else { errbnd = 1.f / eps; } L30: ; } reslts[1] = errbnd; /* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */ i__1 = *nrhs; for (k = 1; k <= i__1; ++k) { if (notran) { if (*n == 1) { i__2 = b_subscr(1, k); i__3 = x_subscr(1, k); axbi = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b_ref( 1, k)), dabs(r__2)) + ((r__3 = d__[1].r, dabs(r__3)) + (r__4 = r_imag(&d__[1]), dabs(r__4))) * ((r__5 = x[ i__3].r, dabs(r__5)) + (r__6 = r_imag(&x_ref(1, k)), dabs(r__6))); } else { i__2 = b_subscr(1, k); i__3 = x_subscr(1, k); i__4 = x_subscr(2, k); axbi = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b_ref( 1, k)), dabs(r__2)) + ((r__3 = d__[1].r, dabs(r__3)) + (r__4 = r_imag(&d__[1]), dabs(r__4))) * ((r__5 = x[ i__3].r, dabs(r__5)) + (r__6 = r_imag(&x_ref(1, k)), dabs(r__6))) + ((r__7 = du[1].r, dabs(r__7)) + (r__8 = r_imag(&du[1]), dabs(r__8))) * ((r__9 = x[i__4].r, dabs(r__9)) + (r__10 = r_imag(&x_ref(2, k)), dabs( r__10))); i__2 = *n - 1; for (i__ = 2; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, k); i__4 = i__ - 1; i__5 = x_subscr(i__ - 1, k); i__6 = i__; i__7 = x_subscr(i__, k); i__8 = i__; i__9 = x_subscr(i__ + 1, k); tmp = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(& b_ref(i__, k)), dabs(r__2)) + ((r__3 = dl[i__4].r, dabs(r__3)) + (r__4 = r_imag(&dl[i__ - 1]), dabs( r__4))) * ((r__5 = x[i__5].r, dabs(r__5)) + (r__6 = r_imag(&x_ref(i__ - 1, k)), dabs(r__6))) + (( r__7 = d__[i__6].r, dabs(r__7)) + (r__8 = r_imag(& d__[i__]), dabs(r__8))) * ((r__9 = x[i__7].r, dabs(r__9)) + (r__10 = r_imag(&x_ref(i__, k)), dabs(r__10))) + ((r__11 = du[i__8].r, dabs(r__11)) + (r__12 = r_imag(&du[i__]), dabs(r__12))) * (( r__13 = x[i__9].r, dabs(r__13)) + (r__14 = r_imag( &x_ref(i__ + 1, k)), dabs(r__14))); axbi = dmin(axbi,tmp); /* L40: */ } i__2 = b_subscr(*n, k); i__3 = *n - 1; i__4 = x_subscr(*n - 1, k); i__5 = *n; i__6 = x_subscr(*n, k); tmp = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(* n, k)), dabs(r__2)) + ((r__3 = dl[i__3].r, dabs(r__3)) + (r__4 = r_imag(&dl[*n - 1]), dabs(r__4))) * ((r__5 = x[i__4].r, dabs(r__5)) + (r__6 = r_imag(&x_ref(*n - 1, k)), dabs(r__6))) + ((r__7 = d__[i__5].r, dabs( r__7)) + (r__8 = r_imag(&d__[*n]), dabs(r__8))) * (( r__9 = x[i__6].r, dabs(r__9)) + (r__10 = r_imag(& x_ref(*n, k)), dabs(r__10))); axbi = dmin(axbi,tmp); } } else { if (*n == 1) { i__2 = b_subscr(1, k); i__3 = x_subscr(1, k); axbi = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b_ref( 1, k)), dabs(r__2)) + ((r__3 = d__[1].r, dabs(r__3)) + (r__4 = r_imag(&d__[1]), dabs(r__4))) * ((r__5 = x[ i__3].r, dabs(r__5)) + (r__6 = r_imag(&x_ref(1, k)), dabs(r__6))); } else { i__2 = b_subscr(1, k); i__3 = x_subscr(1, k); i__4 = x_subscr(2, k); axbi = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b_ref( 1, k)), dabs(r__2)) + ((r__3 = d__[1].r, dabs(r__3)) + (r__4 = r_imag(&d__[1]), dabs(r__4))) * ((r__5 = x[ i__3].r, dabs(r__5)) + (r__6 = r_imag(&x_ref(1, k)), dabs(r__6))) + ((r__7 = dl[1].r, dabs(r__7)) + (r__8 = r_imag(&dl[1]), dabs(r__8))) * ((r__9 = x[i__4].r, dabs(r__9)) + (r__10 = r_imag(&x_ref(2, k)), dabs( r__10))); i__2 = *n - 1; for (i__ = 2; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, k); i__4 = i__ - 1; i__5 = x_subscr(i__ - 1, k); i__6 = i__; i__7 = x_subscr(i__, k); i__8 = i__; i__9 = x_subscr(i__ + 1, k); tmp = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(& b_ref(i__, k)), dabs(r__2)) + ((r__3 = du[i__4].r, dabs(r__3)) + (r__4 = r_imag(&du[i__ - 1]), dabs( r__4))) * ((r__5 = x[i__5].r, dabs(r__5)) + (r__6 = r_imag(&x_ref(i__ - 1, k)), dabs(r__6))) + (( r__7 = d__[i__6].r, dabs(r__7)) + (r__8 = r_imag(& d__[i__]), dabs(r__8))) * ((r__9 = x[i__7].r, dabs(r__9)) + (r__10 = r_imag(&x_ref(i__, k)), dabs(r__10))) + ((r__11 = dl[i__8].r, dabs(r__11)) + (r__12 = r_imag(&dl[i__]), dabs(r__12))) * (( r__13 = x[i__9].r, dabs(r__13)) + (r__14 = r_imag( &x_ref(i__ + 1, k)), dabs(r__14))); axbi = dmin(axbi,tmp); /* L50: */ } i__2 = b_subscr(*n, k); i__3 = *n - 1; i__4 = x_subscr(*n - 1, k); i__5 = *n; i__6 = x_subscr(*n, k); tmp = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(* n, k)), dabs(r__2)) + ((r__3 = du[i__3].r, dabs(r__3)) + (r__4 = r_imag(&du[*n - 1]), dabs(r__4))) * ((r__5 = x[i__4].r, dabs(r__5)) + (r__6 = r_imag(&x_ref(*n - 1, k)), dabs(r__6))) + ((r__7 = d__[i__5].r, dabs( r__7)) + (r__8 = r_imag(&d__[*n]), dabs(r__8))) * (( r__9 = x[i__6].r, dabs(r__9)) + (r__10 = r_imag(& x_ref(*n, k)), dabs(r__10))); axbi = dmin(axbi,tmp); } } /* Computing MAX */ r__1 = axbi, r__2 = nz * unfl; tmp = berr[k] / (nz * eps + nz * unfl / dmax(r__1,r__2)); if (k == 1) { reslts[2] = tmp; } else { reslts[2] = dmax(reslts[2],tmp); } /* L60: */ } return 0; /* End of CGTT05 */ } /* cgtt05_ */
/* Subroutine */ int cgtsv_(integer *n, integer *nrhs, complex *dl, complex * d__, complex *du, complex *b, integer *ldb, 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 ======= CGTSV solves the equation A*X = B, where A is an N-by-N tridiagonal matrix, by Gaussian elimination with partial pivoting. Note that the equation A'*X = B may be solved by interchanging the order of the arguments DU and DL. Arguments ========= N (input) INTEGER The order of the matrix A. N >= 0. NRHS (input) INTEGER The number of right hand sides, i.e., the number of columns of the matrix B. NRHS >= 0. DL (input/output) COMPLEX array, dimension (N-1) On entry, DL must contain the (n-1) subdiagonal elements of A. On exit, DL is overwritten by the (n-2) elements of the second superdiagonal of the upper triangular matrix U from the LU factorization of A, in DL(1), ..., DL(n-2). D (input/output) COMPLEX array, dimension (N) On entry, D must contain the diagonal elements of A. On exit, D is overwritten by the n diagonal elements of U. DU (input/output) COMPLEX array, dimension (N-1) On entry, DU must contain the (n-1) superdiagonal elements of A. On exit, DU is overwritten by the (n-1) elements of the first superdiagonal of U. B (input/output) COMPLEX array, dimension (LDB,NRHS) On entry, the N-by-NRHS right hand side matrix B. On exit, if INFO = 0, the N-by-NRHS solution matrix X. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,N). INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value > 0: if INFO = i, U(i,i) is exactly zero, and the solution has not been computed. The factorization has not been completed unless i = N. ===================================================================== Parameter adjustments */ /* System generated locals */ integer b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7; real r__1, r__2, r__3, r__4; complex q__1, q__2, q__3, q__4, q__5; /* Builtin functions */ double r_imag(complex *); void c_div(complex *, complex *, complex *); /* Local variables */ static complex temp, mult; static integer j, k; extern /* Subroutine */ int xerbla_(char *, integer *); #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)] --dl; --d__; --du; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; /* Function Body */ *info = 0; if (*n < 0) { *info = -1; } else if (*nrhs < 0) { *info = -2; } else if (*ldb < max(1,*n)) { *info = -7; } if (*info != 0) { i__1 = -(*info); xerbla_("CGTSV ", &i__1); return 0; } if (*n == 0) { return 0; } i__1 = *n - 1; for (k = 1; k <= i__1; ++k) { i__2 = k; if (dl[i__2].r == 0.f && dl[i__2].i == 0.f) { /* Subdiagonal is zero, no elimination is required. */ i__2 = k; if (d__[i__2].r == 0.f && d__[i__2].i == 0.f) { /* Diagonal is zero: set INFO = K and return; a unique solution can not be found. */ *info = k; return 0; } } else /* if(complicated condition) */ { i__2 = k; i__3 = k; if ((r__1 = d__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&d__[k]), dabs(r__2)) >= (r__3 = dl[i__3].r, dabs(r__3)) + (r__4 = r_imag(&dl[k]), dabs(r__4))) { /* No row interchange required */ c_div(&q__1, &dl[k], &d__[k]); mult.r = q__1.r, mult.i = q__1.i; i__2 = k + 1; i__3 = k + 1; i__4 = k; q__2.r = mult.r * du[i__4].r - mult.i * du[i__4].i, q__2.i = mult.r * du[i__4].i + mult.i * du[i__4].r; q__1.r = d__[i__3].r - q__2.r, q__1.i = d__[i__3].i - q__2.i; d__[i__2].r = q__1.r, d__[i__2].i = q__1.i; i__2 = *nrhs; for (j = 1; j <= i__2; ++j) { i__3 = b_subscr(k + 1, j); i__4 = b_subscr(k + 1, j); i__5 = b_subscr(k, j); q__2.r = mult.r * b[i__5].r - mult.i * b[i__5].i, q__2.i = mult.r * b[i__5].i + mult.i * b[i__5].r; q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i - q__2.i; b[i__3].r = q__1.r, b[i__3].i = q__1.i; /* L10: */ } if (k < *n - 1) { i__2 = k; dl[i__2].r = 0.f, dl[i__2].i = 0.f; } } else { /* Interchange rows K and K+1 */ c_div(&q__1, &d__[k], &dl[k]); mult.r = q__1.r, mult.i = q__1.i; i__2 = k; i__3 = k; d__[i__2].r = dl[i__3].r, d__[i__2].i = dl[i__3].i; i__2 = k + 1; temp.r = d__[i__2].r, temp.i = d__[i__2].i; i__2 = k + 1; i__3 = k; q__2.r = mult.r * temp.r - mult.i * temp.i, q__2.i = mult.r * temp.i + mult.i * temp.r; q__1.r = du[i__3].r - q__2.r, q__1.i = du[i__3].i - q__2.i; d__[i__2].r = q__1.r, d__[i__2].i = q__1.i; if (k < *n - 1) { i__2 = k; i__3 = k + 1; dl[i__2].r = du[i__3].r, dl[i__2].i = du[i__3].i; i__2 = k + 1; q__2.r = -mult.r, q__2.i = -mult.i; i__3 = k; q__1.r = q__2.r * dl[i__3].r - q__2.i * dl[i__3].i, q__1.i = q__2.r * dl[i__3].i + q__2.i * dl[i__3] .r; du[i__2].r = q__1.r, du[i__2].i = q__1.i; } i__2 = k; du[i__2].r = temp.r, du[i__2].i = temp.i; i__2 = *nrhs; for (j = 1; j <= i__2; ++j) { i__3 = b_subscr(k, j); temp.r = b[i__3].r, temp.i = b[i__3].i; i__3 = b_subscr(k, j); i__4 = b_subscr(k + 1, j); b[i__3].r = b[i__4].r, b[i__3].i = b[i__4].i; i__3 = b_subscr(k + 1, j); i__4 = b_subscr(k + 1, j); q__2.r = mult.r * b[i__4].r - mult.i * b[i__4].i, q__2.i = mult.r * b[i__4].i + mult.i * b[i__4].r; q__1.r = temp.r - q__2.r, q__1.i = temp.i - q__2.i; b[i__3].r = q__1.r, b[i__3].i = q__1.i; /* L20: */ } } } /* L30: */ } i__1 = *n; if (d__[i__1].r == 0.f && d__[i__1].i == 0.f) { *info = *n; return 0; } /* Back solve with the matrix U from the factorization. */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { i__2 = b_subscr(*n, j); c_div(&q__1, &b_ref(*n, j), &d__[*n]); b[i__2].r = q__1.r, b[i__2].i = q__1.i; if (*n > 1) { i__2 = b_subscr(*n - 1, j); i__3 = b_subscr(*n - 1, j); i__4 = *n - 1; i__5 = b_subscr(*n, j); q__3.r = du[i__4].r * b[i__5].r - du[i__4].i * b[i__5].i, q__3.i = du[i__4].r * b[i__5].i + du[i__4].i * b[i__5].r; q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i; c_div(&q__1, &q__2, &d__[*n - 1]); b[i__2].r = q__1.r, b[i__2].i = q__1.i; } for (k = *n - 2; k >= 1; --k) { i__2 = b_subscr(k, j); i__3 = b_subscr(k, j); i__4 = k; i__5 = b_subscr(k + 1, j); q__4.r = du[i__4].r * b[i__5].r - du[i__4].i * b[i__5].i, q__4.i = du[i__4].r * b[i__5].i + du[i__4].i * b[i__5].r; q__3.r = b[i__3].r - q__4.r, q__3.i = b[i__3].i - q__4.i; i__6 = k; i__7 = b_subscr(k + 2, j); q__5.r = dl[i__6].r * b[i__7].r - dl[i__6].i * b[i__7].i, q__5.i = dl[i__6].r * b[i__7].i + dl[i__6].i * b[i__7].r; q__2.r = q__3.r - q__5.r, q__2.i = q__3.i - q__5.i; c_div(&q__1, &q__2, &d__[k]); b[i__2].r = q__1.r, b[i__2].i = q__1.i; /* L40: */ } /* L50: */ } return 0; /* End of CGTSV */ } /* cgtsv_ */
/* 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 zsymm_(char *side, char *uplo, integer *m, integer *n, doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex * b, integer *ldb, doublecomplex *beta, doublecomplex *c__, integer * ldc) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6; doublecomplex z__1, z__2, z__3, z__4, z__5; /* Local variables */ static integer info; static doublecomplex temp1, temp2; static integer i__, j, k; extern logical lsame_(char *, char *); static integer nrowa; static logical upper; extern /* Subroutine */ int xerbla_(char *, 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 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)] /* Purpose ======= ZSYMM performs one of the matrix-matrix operations C := alpha*A*B + beta*C, or C := alpha*B*A + beta*C, where alpha and beta are scalars, A is a symmetric matrix and B and C are m by n matrices. Parameters ========== SIDE - CHARACTER*1. On entry, SIDE specifies whether the symmetric matrix A appears on the left or right in the operation as follows: SIDE = 'L' or 'l' C := alpha*A*B + beta*C, SIDE = 'R' or 'r' C := alpha*B*A + beta*C, Unchanged on exit. UPLO - CHARACTER*1. On entry, UPLO specifies whether the upper or lower triangular part of the symmetric matrix A is to be referenced as follows: UPLO = 'U' or 'u' Only the upper triangular part of the symmetric matrix is to be referenced. UPLO = 'L' or 'l' Only the lower triangular part of the symmetric matrix is to be referenced. Unchanged on exit. M - INTEGER. On entry, M specifies the number of rows of the matrix C. M must be at least zero. Unchanged on exit. N - INTEGER. On entry, N specifies the number of columns of the matrix C. N must be at least zero. Unchanged on exit. ALPHA - COMPLEX*16 . On entry, ALPHA specifies the scalar alpha. Unchanged on exit. A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is m when SIDE = 'L' or 'l' and is n otherwise. Before entry with SIDE = 'L' or 'l', the m by m part of the array A must contain the symmetric matrix, such that when UPLO = 'U' or 'u', the leading m by m upper triangular part of the array A must contain the upper triangular part of the symmetric matrix and the strictly lower triangular part of A is not referenced, and when UPLO = 'L' or 'l', the leading m by m lower triangular part of the array A must contain the lower triangular part of the symmetric matrix and the strictly upper triangular part of A is not referenced. Before entry with SIDE = 'R' or 'r', the n by n part of the array A must contain the symmetric matrix, such that when UPLO = 'U' or 'u', the leading n by n upper triangular part of the array A must contain the upper triangular part of the symmetric matrix and the strictly lower triangular part of A is not referenced, and when UPLO = 'L' or 'l', the leading n by n lower triangular part of the array A must contain the lower triangular part of the symmetric matrix and the strictly upper triangular part of A is not referenced. Unchanged on exit. LDA - INTEGER. On entry, LDA specifies the first dimension of A as declared in the calling (sub) program. When SIDE = 'L' or 'l' then LDA must be at least max( 1, m ), otherwise LDA must be at least max( 1, n ). Unchanged on exit. B - COMPLEX*16 array of DIMENSION ( LDB, n ). Before entry, the leading m by n part of the array B must contain the matrix B. Unchanged on exit. LDB - INTEGER. On entry, LDB specifies the first dimension of B as declared in the calling (sub) program. LDB must be at least max( 1, m ). Unchanged on exit. BETA - COMPLEX*16 . On entry, BETA specifies the scalar beta. When BETA is supplied as zero then C need not be set on input. Unchanged on exit. C - COMPLEX*16 array of DIMENSION ( LDC, n ). Before entry, the leading m by n part of the array C must contain the matrix C, except when beta is zero, in which case C need not be set on entry. On exit, the array C is overwritten by the m by n updated matrix. LDC - INTEGER. On entry, LDC specifies the first dimension of C as declared in the calling (sub) program. LDC must be at least max( 1, m ). Unchanged on exit. Level 3 Blas routine. -- Written on 8-February-1989. Jack Dongarra, Argonne National Laboratory. Iain Duff, AERE Harwell. Jeremy Du Croz, Numerical Algorithms Group Ltd. Sven Hammarling, Numerical Algorithms Group Ltd. Set NROWA as the number of rows of A. 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; /* Function Body */ if (lsame_(side, "L")) { nrowa = *m; } else { nrowa = *n; } upper = lsame_(uplo, "U"); /* Test the input parameters. */ info = 0; if (! lsame_(side, "L") && ! lsame_(side, "R")) { info = 1; } else if (! upper && ! lsame_(uplo, "L")) { info = 2; } else if (*m < 0) { info = 3; } else if (*n < 0) { info = 4; } else if (*lda < max(1,nrowa)) { info = 7; } else if (*ldb < max(1,*m)) { info = 9; } else if (*ldc < max(1,*m)) { info = 12; } if (info != 0) { xerbla_("ZSYMM ", &info); return 0; } /* Quick return if possible. */ if (*m == 0 || *n == 0 || alpha->r == 0. && alpha->i == 0. && (beta->r == 1. && beta->i == 0.)) { return 0; } /* And when alpha.eq.zero. */ if (alpha->r == 0. && alpha->i == 0.) { if (beta->r == 0. && beta->i == 0.) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = c___subscr(i__, j); c__[i__3].r = 0., c__[i__3].i = 0.; /* L10: */ } /* L20: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = c___subscr(i__, j); i__4 = c___subscr(i__, j); z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i, z__1.i = beta->r * c__[i__4].i + beta->i * c__[ i__4].r; c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L30: */ } /* L40: */ } } return 0; } /* Start the operations. */ if (lsame_(side, "L")) { /* Form C := alpha*A*B + beta*C. */ if (upper) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i, z__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3] .r; temp1.r = z__1.r, temp1.i = z__1.i; temp2.r = 0., temp2.i = 0.; i__3 = i__ - 1; for (k = 1; k <= i__3; ++k) { i__4 = c___subscr(k, j); i__5 = c___subscr(k, j); i__6 = a_subscr(k, i__); z__2.r = temp1.r * a[i__6].r - temp1.i * a[i__6].i, z__2.i = temp1.r * a[i__6].i + temp1.i * a[ i__6].r; z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i + z__2.i; c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; i__4 = b_subscr(k, j); i__5 = a_subscr(k, i__); z__2.r = b[i__4].r * a[i__5].r - b[i__4].i * a[i__5] .i, z__2.i = b[i__4].r * a[i__5].i + b[i__4] .i * a[i__5].r; z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; temp2.r = z__1.r, temp2.i = z__1.i; /* L50: */ } if (beta->r == 0. && beta->i == 0.) { i__3 = c___subscr(i__, j); i__4 = a_subscr(i__, i__); z__2.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i, z__2.i = temp1.r * a[i__4].i + temp1.i * a[ i__4].r; z__3.r = alpha->r * temp2.r - alpha->i * temp2.i, z__3.i = alpha->r * temp2.i + alpha->i * temp2.r; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; } else { i__3 = c___subscr(i__, j); i__4 = c___subscr(i__, j); z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] .i, z__3.i = beta->r * c__[i__4].i + beta->i * c__[i__4].r; i__5 = a_subscr(i__, i__); z__4.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, z__4.i = temp1.r * a[i__5].i + temp1.i * a[ i__5].r; z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i; z__5.r = alpha->r * temp2.r - alpha->i * temp2.i, z__5.i = alpha->r * temp2.i + alpha->i * temp2.r; z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i; c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; } /* L60: */ } /* L70: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { for (i__ = *m; i__ >= 1; --i__) { i__2 = b_subscr(i__, j); z__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2].i, z__1.i = alpha->r * b[i__2].i + alpha->i * b[i__2] .r; temp1.r = z__1.r, temp1.i = z__1.i; temp2.r = 0., temp2.i = 0.; i__2 = *m; for (k = i__ + 1; k <= i__2; ++k) { i__3 = c___subscr(k, j); i__4 = c___subscr(k, j); i__5 = a_subscr(k, i__); z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, z__2.i = temp1.r * a[i__5].i + temp1.i * a[ i__5].r; z__1.r = c__[i__4].r + z__2.r, z__1.i = c__[i__4].i + z__2.i; c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; i__3 = b_subscr(k, j); i__4 = a_subscr(k, i__); z__2.r = b[i__3].r * a[i__4].r - b[i__3].i * a[i__4] .i, z__2.i = b[i__3].r * a[i__4].i + b[i__3] .i * a[i__4].r; z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; temp2.r = z__1.r, temp2.i = z__1.i; /* L80: */ } if (beta->r == 0. && beta->i == 0.) { i__2 = c___subscr(i__, j); i__3 = a_subscr(i__, i__); z__2.r = temp1.r * a[i__3].r - temp1.i * a[i__3].i, z__2.i = temp1.r * a[i__3].i + temp1.i * a[ i__3].r; z__3.r = alpha->r * temp2.r - alpha->i * temp2.i, z__3.i = alpha->r * temp2.i + alpha->i * temp2.r; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; } else { i__2 = c___subscr(i__, j); i__3 = c___subscr(i__, j); z__3.r = beta->r * c__[i__3].r - beta->i * c__[i__3] .i, z__3.i = beta->r * c__[i__3].i + beta->i * c__[i__3].r; i__4 = a_subscr(i__, i__); z__4.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i, z__4.i = temp1.r * a[i__4].i + temp1.i * a[ i__4].r; z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i; z__5.r = alpha->r * temp2.r - alpha->i * temp2.i, z__5.i = alpha->r * temp2.i + alpha->i * temp2.r; z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i; c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; } /* L90: */ } /* L100: */ } } } else { /* Form C := alpha*B*A + beta*C. */ i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = a_subscr(j, j); z__1.r = alpha->r * a[i__2].r - alpha->i * a[i__2].i, z__1.i = alpha->r * a[i__2].i + alpha->i * a[i__2].r; temp1.r = z__1.r, temp1.i = z__1.i; if (beta->r == 0. && beta->i == 0.) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = c___subscr(i__, j); i__4 = b_subscr(i__, j); z__1.r = temp1.r * b[i__4].r - temp1.i * b[i__4].i, z__1.i = temp1.r * b[i__4].i + temp1.i * b[i__4] .r; c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L110: */ } } else { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = c___subscr(i__, j); i__4 = c___subscr(i__, j); z__2.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i, z__2.i = beta->r * c__[i__4].i + beta->i * c__[ i__4].r; i__5 = b_subscr(i__, j); z__3.r = temp1.r * b[i__5].r - temp1.i * b[i__5].i, z__3.i = temp1.r * b[i__5].i + temp1.i * b[i__5] .r; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L120: */ } } i__2 = j - 1; for (k = 1; k <= i__2; ++k) { if (upper) { i__3 = a_subscr(k, j); z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, z__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3] .r; temp1.r = z__1.r, temp1.i = z__1.i; } else { i__3 = a_subscr(j, k); z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, z__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3] .r; temp1.r = z__1.r, temp1.i = z__1.i; } i__3 = *m; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = c___subscr(i__, j); i__5 = c___subscr(i__, j); i__6 = b_subscr(i__, k); z__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i, z__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6] .r; z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i + z__2.i; c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; /* L130: */ } /* L140: */ } i__2 = *n; for (k = j + 1; k <= i__2; ++k) { if (upper) { i__3 = a_subscr(j, k); z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, z__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3] .r; temp1.r = z__1.r, temp1.i = z__1.i; } else { i__3 = a_subscr(k, j); z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, z__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3] .r; temp1.r = z__1.r, temp1.i = z__1.i; } i__3 = *m; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = c___subscr(i__, j); i__5 = c___subscr(i__, j); i__6 = b_subscr(i__, k); z__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i, z__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6] .r; z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i + z__2.i; c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; /* L150: */ } /* L160: */ } /* L170: */ } } return 0; /* End of ZSYMM . */ } /* zsymm_ */
/* Subroutine */ int zlacpy_(char *uplo, integer *m, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb) { /* -- 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 ======= ZLACPY copies all or part of a two-dimensional matrix A to another matrix B. Arguments ========= UPLO (input) CHARACTER*1 Specifies the part of the matrix A to be copied to B. = 'U': Upper triangular part = 'L': Lower triangular part Otherwise: All of the matrix A 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*16 array, dimension (LDA,N) The m by n matrix A. If UPLO = 'U', only the upper trapezium is accessed; if UPLO = 'L', only the lower trapezium is accessed. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,M). B (output) COMPLEX*16 array, dimension (LDB,N) On exit, B = A in the locations specified by UPLO. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,M). ===================================================================== Parameter adjustments */ /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4; /* Local variables */ static integer i__, j; extern logical lsame_(char *, char *); #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)] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; /* Function Body */ if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = min(j,*m); for (i__ = 1; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); i__4 = a_subscr(i__, j); b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i; /* L10: */ } /* L20: */ } } else if (lsame_(uplo, "L")) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = j; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); i__4 = a_subscr(i__, j); b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i; /* L30: */ } /* L40: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); i__4 = a_subscr(i__, j); b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i; /* L50: */ } /* L60: */ } } return 0; /* End of ZLACPY */ } /* zlacpy_ */
/* Subroutine */ int zptt05_(integer *n, integer *nrhs, doublereal *d__, doublecomplex *e, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublecomplex *xact, integer *ldxact, doublereal *ferr, doublereal *berr, doublereal *reslts) { /* System generated locals */ integer b_dim1, b_offset, x_dim1, x_offset, xact_dim1, xact_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9; doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10, d__11, d__12; doublecomplex z__1, z__2; /* Builtin functions */ double d_imag(doublecomplex *); /* Local variables */ static doublereal diff, axbi; static integer imax; static doublereal unfl, ovfl; static integer i__, j, k; static doublereal xnorm; extern doublereal dlamch_(char *); static integer nz; static doublereal errbnd; extern integer izamax_(integer *, doublecomplex *, integer *); static doublereal eps, tmp; #define xact_subscr(a_1,a_2) (a_2)*xact_dim1 + a_1 #define xact_ref(a_1,a_2) xact[xact_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 x_subscr(a_1,a_2) (a_2)*x_dim1 + a_1 #define x_ref(a_1,a_2) x[x_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 February 29, 1992 Purpose ======= ZPTT05 tests the error bounds from iterative refinement for the computed solution to a system of equations A*X = B, where A is a Hermitian tridiagonal matrix of order n. RESLTS(1) = test of the error bound = norm(X - XACT) / ( norm(X) * FERR ) A large value is returned if this ratio is not less than one. RESLTS(2) = residual from the iterative refinement routine = the maximum of BERR / ( NZ*EPS + (*) ), where (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) and NZ = max. number of nonzeros in any row of A, plus 1 Arguments ========= N (input) INTEGER The number of rows of the matrices X, B, and XACT, and the order of the matrix A. N >= 0. NRHS (input) INTEGER The number of columns of the matrices X, B, and XACT. NRHS >= 0. D (input) DOUBLE PRECISION array, dimension (N) The n diagonal elements of the tridiagonal matrix A. E (input) COMPLEX*16 array, dimension (N-1) The (n-1) subdiagonal elements of the tridiagonal matrix A. B (input) COMPLEX*16 array, dimension (LDB,NRHS) The right hand side vectors for the system of linear equations. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,N). X (input) COMPLEX*16 array, dimension (LDX,NRHS) The computed solution vectors. Each vector is stored as a column of the matrix X. LDX (input) INTEGER The leading dimension of the array X. LDX >= max(1,N). XACT (input) COMPLEX*16 array, dimension (LDX,NRHS) The exact solution vectors. Each vector is stored as a column of the matrix XACT. LDXACT (input) INTEGER The leading dimension of the array XACT. LDXACT >= max(1,N). FERR (input) DOUBLE PRECISION array, dimension (NRHS) The estimated forward error bounds for each solution vector X. If XTRUE is the true solution, FERR bounds the magnitude of the largest entry in (X - XTRUE) divided by the magnitude of the largest entry in X. BERR (input) DOUBLE PRECISION array, dimension (NRHS) The componentwise relative backward error of each solution vector (i.e., the smallest relative change in any entry of A or B that makes X an exact solution). RESLTS (output) DOUBLE PRECISION array, dimension (2) The maximum over the NRHS solution vectors of the ratios: RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) RESLTS(2) = BERR / ( NZ*EPS + (*) ) ===================================================================== Quick exit if N = 0 or NRHS = 0. Parameter adjustments */ --d__; --e; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; x_dim1 = *ldx; x_offset = 1 + x_dim1 * 1; x -= x_offset; xact_dim1 = *ldxact; xact_offset = 1 + xact_dim1 * 1; xact -= xact_offset; --ferr; --berr; --reslts; /* Function Body */ if (*n <= 0 || *nrhs <= 0) { reslts[1] = 0.; reslts[2] = 0.; return 0; } eps = dlamch_("Epsilon"); unfl = dlamch_("Safe minimum"); ovfl = 1. / unfl; nz = 4; /* Test 1: Compute the maximum of norm(X - XACT) / ( norm(X) * FERR ) over all the vectors X and XACT using the infinity-norm. */ errbnd = 0.; i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { imax = izamax_(n, &x_ref(1, j), &c__1); /* Computing MAX */ i__2 = x_subscr(imax, j); d__3 = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x_ref(imax, j)) , abs(d__2)); xnorm = max(d__3,unfl); diff = 0.; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = x_subscr(i__, j); i__4 = xact_subscr(i__, j); z__2.r = x[i__3].r - xact[i__4].r, z__2.i = x[i__3].i - xact[i__4] .i; z__1.r = z__2.r, z__1.i = z__2.i; /* Computing MAX */ d__3 = diff, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(& z__1), abs(d__2)); diff = max(d__3,d__4); /* L10: */ } if (xnorm > 1.) { goto L20; } else if (diff <= ovfl * xnorm) { goto L20; } else { errbnd = 1. / eps; goto L30; } L20: if (diff / xnorm <= ferr[j]) { /* Computing MAX */ d__1 = errbnd, d__2 = diff / xnorm / ferr[j]; errbnd = max(d__1,d__2); } else { errbnd = 1. / eps; } L30: ; } reslts[1] = errbnd; /* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */ i__1 = *nrhs; for (k = 1; k <= i__1; ++k) { if (*n == 1) { i__2 = x_subscr(1, k); z__2.r = d__[1] * x[i__2].r, z__2.i = d__[1] * x[i__2].i; z__1.r = z__2.r, z__1.i = z__2.i; i__3 = b_subscr(1, k); axbi = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b_ref(1, k) ), abs(d__2)) + ((d__3 = z__1.r, abs(d__3)) + (d__4 = d_imag(&z__1), abs(d__4))); } else { i__2 = x_subscr(1, k); z__2.r = d__[1] * x[i__2].r, z__2.i = d__[1] * x[i__2].i; z__1.r = z__2.r, z__1.i = z__2.i; i__3 = b_subscr(1, k); i__4 = x_subscr(2, k); axbi = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b_ref(1, k) ), abs(d__2)) + ((d__3 = z__1.r, abs(d__3)) + (d__4 = d_imag(&z__1), abs(d__4))) + ((d__5 = e[1].r, abs(d__5)) + (d__6 = d_imag(&e[1]), abs(d__6))) * ((d__7 = x[i__4].r, abs(d__7)) + (d__8 = d_imag(&x_ref(2, k)), abs(d__8))); i__2 = *n - 1; for (i__ = 2; i__ <= i__2; ++i__) { i__3 = i__; i__4 = x_subscr(i__, k); z__2.r = d__[i__3] * x[i__4].r, z__2.i = d__[i__3] * x[i__4] .i; z__1.r = z__2.r, z__1.i = z__2.i; i__5 = b_subscr(i__, k); i__6 = i__ - 1; i__7 = x_subscr(i__ - 1, k); i__8 = i__; i__9 = x_subscr(i__ + 1, k); tmp = (d__1 = b[i__5].r, abs(d__1)) + (d__2 = d_imag(&b_ref( i__, k)), abs(d__2)) + ((d__3 = e[i__6].r, abs(d__3)) + (d__4 = d_imag(&e[i__ - 1]), abs(d__4))) * ((d__5 = x[i__7].r, abs(d__5)) + (d__6 = d_imag(&x_ref(i__ - 1, k)), abs(d__6))) + ((d__7 = z__1.r, abs(d__7)) + ( d__8 = d_imag(&z__1), abs(d__8))) + ((d__9 = e[i__8] .r, abs(d__9)) + (d__10 = d_imag(&e[i__]), abs(d__10)) ) * ((d__11 = x[i__9].r, abs(d__11)) + (d__12 = d_imag(&x_ref(i__ + 1, k)), abs(d__12))); axbi = min(axbi,tmp); /* L40: */ } i__2 = *n; i__3 = x_subscr(*n, k); z__2.r = d__[i__2] * x[i__3].r, z__2.i = d__[i__2] * x[i__3].i; z__1.r = z__2.r, z__1.i = z__2.i; i__4 = b_subscr(*n, k); i__5 = *n - 1; i__6 = x_subscr(*n - 1, k); tmp = (d__1 = b[i__4].r, abs(d__1)) + (d__2 = d_imag(&b_ref(*n, k) ), abs(d__2)) + ((d__3 = e[i__5].r, abs(d__3)) + (d__4 = d_imag(&e[*n - 1]), abs(d__4))) * ((d__5 = x[i__6].r, abs( d__5)) + (d__6 = d_imag(&x_ref(*n - 1, k)), abs(d__6))) + ((d__7 = z__1.r, abs(d__7)) + (d__8 = d_imag(&z__1), abs( d__8))); axbi = min(axbi,tmp); } /* Computing MAX */ d__1 = axbi, d__2 = nz * unfl; tmp = berr[k] / (nz * eps + nz * unfl / max(d__1,d__2)); if (k == 1) { reslts[2] = tmp; } else { reslts[2] = max(reslts[2],tmp); } /* L50: */ } return 0; /* End of ZPTT05 */ } /* zptt05_ */
/* Subroutine */ int clatm5_(integer *prtype, 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, complex *r__, integer *ldr, complex *l, integer *ldl, real *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, i__3, i__4; doublereal d__1; complex q__1, q__2, q__3, q__4, q__5; /* Builtin functions */ void c_sin(complex *, complex *), c_div(complex *, complex *, complex *); /* Local variables */ static integer i__, j, k; extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *); static complex imeps, reeps; #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 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 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 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)] /* -- 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 ======= CLATM5 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) COMPLEX 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) COMPLEX 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) COMPLEX 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) COMPLEX 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) COMPLEX 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) COMPLEX 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) COMPLEX 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) COMPLEX 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) REAL 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) { i__3 = a_subscr(i__, j); a[i__3].r = 1.f, a[i__3].i = 0.f; i__3 = d___subscr(i__, j); d__[i__3].r = 1.f, d__[i__3].i = 0.f; } else if (i__ == j - 1) { i__3 = a_subscr(i__, j); q__1.r = -1.f, q__1.i = 0.f; a[i__3].r = q__1.r, a[i__3].i = q__1.i; i__3 = d___subscr(i__, j); d__[i__3].r = 0.f, d__[i__3].i = 0.f; } else { i__3 = a_subscr(i__, j); a[i__3].r = 0.f, a[i__3].i = 0.f; i__3 = d___subscr(i__, j); d__[i__3].r = 0.f, d__[i__3].i = 0.f; } /* 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) { i__3 = b_subscr(i__, j); q__1.r = 1.f - *alpha, q__1.i = 0.f; b[i__3].r = q__1.r, b[i__3].i = q__1.i; i__3 = e_subscr(i__, j); e[i__3].r = 1.f, e[i__3].i = 0.f; } else if (i__ == j - 1) { i__3 = b_subscr(i__, j); b[i__3].r = 1.f, b[i__3].i = 0.f; i__3 = e_subscr(i__, j); e[i__3].r = 0.f, e[i__3].i = 0.f; } else { i__3 = b_subscr(i__, j); b[i__3].r = 0.f, b[i__3].i = 0.f; i__3 = e_subscr(i__, j); e[i__3].r = 0.f, e[i__3].i = 0.f; } /* L30: */ } /* L40: */ } i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *n; for (j = 1; j <= i__2; ++j) { i__3 = r___subscr(i__, j); i__4 = i__ / j; q__4.r = (real) i__4, q__4.i = 0.f; c_sin(&q__3, &q__4); q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i; q__1.r = q__2.r * 20.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + q__2.i * 20.f; r__[i__3].r = q__1.r, r__[i__3].i = q__1.i; i__3 = l_subscr(i__, j); i__4 = r___subscr(i__, j); l[i__3].r = r__[i__4].r, l[i__3].i = r__[i__4].i; /* 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) { i__3 = a_subscr(i__, j); q__4.r = (real) i__, q__4.i = 0.f; c_sin(&q__3, &q__4); q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i; q__1.r = q__2.r * 2.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + q__2.i * 2.f; a[i__3].r = q__1.r, a[i__3].i = q__1.i; i__3 = d___subscr(i__, j); i__4 = i__ * j; q__4.r = (real) i__4, q__4.i = 0.f; c_sin(&q__3, &q__4); q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i; q__1.r = q__2.r * 2.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + q__2.i * 2.f; d__[i__3].r = q__1.r, d__[i__3].i = q__1.i; } else { i__3 = a_subscr(i__, j); a[i__3].r = 0.f, a[i__3].i = 0.f; i__3 = d___subscr(i__, j); d__[i__3].r = 0.f, d__[i__3].i = 0.f; } /* 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) { i__3 = b_subscr(i__, j); i__4 = i__ + j; q__4.r = (real) i__4, q__4.i = 0.f; c_sin(&q__3, &q__4); q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i; q__1.r = q__2.r * 2.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + q__2.i * 2.f; b[i__3].r = q__1.r, b[i__3].i = q__1.i; i__3 = e_subscr(i__, j); q__4.r = (real) j, q__4.i = 0.f; c_sin(&q__3, &q__4); q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i; q__1.r = q__2.r * 2.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + q__2.i * 2.f; e[i__3].r = q__1.r, e[i__3].i = q__1.i; } else { i__3 = b_subscr(i__, j); b[i__3].r = 0.f, b[i__3].i = 0.f; i__3 = e_subscr(i__, j); e[i__3].r = 0.f, e[i__3].i = 0.f; } /* L90: */ } /* L100: */ } i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *n; for (j = 1; j <= i__2; ++j) { i__3 = r___subscr(i__, j); i__4 = i__ * j; q__4.r = (real) i__4, q__4.i = 0.f; c_sin(&q__3, &q__4); q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i; q__1.r = q__2.r * 20.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + q__2.i * 20.f; r__[i__3].r = q__1.r, r__[i__3].i = q__1.i; i__3 = l_subscr(i__, j); i__4 = i__ + j; q__4.r = (real) i__4, q__4.i = 0.f; c_sin(&q__3, &q__4); q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i; q__1.r = q__2.r * 20.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + q__2.i * 20.f; l[i__3].r = q__1.r, l[i__3].i = q__1.i; /* 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) { i__3 = a_subscr(k + 1, k + 1); i__4 = a_subscr(k, k); a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i; i__3 = a_subscr(k + 1, k); c_sin(&q__2, &a_ref(k, k + 1)); q__1.r = -q__2.r, q__1.i = -q__2.i; a[i__3].r = q__1.r, a[i__3].i = q__1.i; /* 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) { i__3 = b_subscr(k + 1, k + 1); i__4 = b_subscr(k, k); b[i__3].r = b[i__4].r, b[i__3].i = b[i__4].i; i__3 = b_subscr(k + 1, k); c_sin(&q__2, &b_ref(k, k + 1)); q__1.r = -q__2.r, q__1.i = -q__2.i; b[i__3].r = q__1.r, b[i__3].i = q__1.i; /* 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) { i__3 = a_subscr(i__, j); i__4 = i__ * j; q__4.r = (real) i__4, q__4.i = 0.f; c_sin(&q__3, &q__4); q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i; q__1.r = q__2.r * 20.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + q__2.i * 20.f; a[i__3].r = q__1.r, a[i__3].i = q__1.i; i__3 = d___subscr(i__, j); i__4 = i__ + j; q__4.r = (real) i__4, q__4.i = 0.f; c_sin(&q__3, &q__4); q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i; q__1.r = q__2.r * 2.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + q__2.i * 2.f; d__[i__3].r = q__1.r, d__[i__3].i = q__1.i; /* L150: */ } /* L160: */ } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *n; for (j = 1; j <= i__2; ++j) { i__3 = b_subscr(i__, j); i__4 = i__ + j; q__4.r = (real) i__4, q__4.i = 0.f; c_sin(&q__3, &q__4); q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i; q__1.r = q__2.r * 20.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + q__2.i * 20.f; b[i__3].r = q__1.r, b[i__3].i = q__1.i; i__3 = e_subscr(i__, j); i__4 = i__ * j; q__4.r = (real) i__4, q__4.i = 0.f; c_sin(&q__3, &q__4); q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i; q__1.r = q__2.r * 2.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + q__2.i * 2.f; e[i__3].r = q__1.r, e[i__3].i = q__1.i; /* L170: */ } /* L180: */ } i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *n; for (j = 1; j <= i__2; ++j) { i__3 = r___subscr(i__, j); i__4 = j / i__; q__4.r = (real) i__4, q__4.i = 0.f; c_sin(&q__3, &q__4); q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i; q__1.r = q__2.r * 20.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + q__2.i * 20.f; r__[i__3].r = q__1.r, r__[i__3].i = q__1.i; i__3 = l_subscr(i__, j); i__4 = i__ * j; q__4.r = (real) i__4, q__4.i = 0.f; c_sin(&q__3, &q__4); q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i; q__1.r = q__2.r * 2.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + q__2.i * 2.f; l[i__3].r = q__1.r, l[i__3].i = q__1.i; /* L190: */ } /* L200: */ } } else if (*prtype >= 5) { q__3.r = 1.f, q__3.i = 0.f; q__2.r = q__3.r * 20.f - q__3.i * 0.f, q__2.i = q__3.r * 0.f + q__3.i * 20.f; q__1.r = q__2.r / *alpha, q__1.i = q__2.i / *alpha; reeps.r = q__1.r, reeps.i = q__1.i; q__2.r = -1.5f, q__2.i = 0.f; q__1.r = q__2.r / *alpha, q__1.i = q__2.i / *alpha; imeps.r = q__1.r, imeps.i = q__1.i; i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *n; for (j = 1; j <= i__2; ++j) { i__3 = r___subscr(i__, j); i__4 = i__ * j; q__5.r = (real) i__4, q__5.i = 0.f; c_sin(&q__4, &q__5); q__3.r = .5f - q__4.r, q__3.i = 0.f - q__4.i; q__2.r = *alpha * q__3.r, q__2.i = *alpha * q__3.i; c_div(&q__1, &q__2, &c_b5); r__[i__3].r = q__1.r, r__[i__3].i = q__1.i; i__3 = l_subscr(i__, j); i__4 = i__ + j; q__5.r = (real) i__4, q__5.i = 0.f; c_sin(&q__4, &q__5); q__3.r = .5f - q__4.r, q__3.i = 0.f - q__4.i; q__2.r = *alpha * q__3.r, q__2.i = *alpha * q__3.i; c_div(&q__1, &q__2, &c_b5); l[i__3].r = q__1.r, l[i__3].i = q__1.i; /* L210: */ } /* L220: */ } i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = d___subscr(i__, i__); d__[i__2].r = 1.f, d__[i__2].i = 0.f; /* L230: */ } i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { if (i__ <= 4) { i__2 = a_subscr(i__, i__); a[i__2].r = 1.f, a[i__2].i = 0.f; if (i__ > 2) { i__2 = a_subscr(i__, i__); q__1.r = reeps.r + 1.f, q__1.i = reeps.i + 0.f; a[i__2].r = q__1.r, a[i__2].i = q__1.i; } if (i__ % 2 != 0 && i__ < *m) { i__2 = a_subscr(i__, i__ + 1); a[i__2].r = imeps.r, a[i__2].i = imeps.i; } else if (i__ > 1) { i__2 = a_subscr(i__, i__ - 1); q__1.r = -imeps.r, q__1.i = -imeps.i; a[i__2].r = q__1.r, a[i__2].i = q__1.i; } } else if (i__ <= 8) { if (i__ <= 6) { i__2 = a_subscr(i__, i__); a[i__2].r = reeps.r, a[i__2].i = reeps.i; } else { i__2 = a_subscr(i__, i__); q__1.r = -reeps.r, q__1.i = -reeps.i; a[i__2].r = q__1.r, a[i__2].i = q__1.i; } if (i__ % 2 != 0 && i__ < *m) { i__2 = a_subscr(i__, i__ + 1); a[i__2].r = 1.f, a[i__2].i = 0.f; } else if (i__ > 1) { i__2 = a_subscr(i__, i__ - 1); q__1.r = -1.f, q__1.i = 0.f; a[i__2].r = q__1.r, a[i__2].i = q__1.i; } } else { i__2 = a_subscr(i__, i__); a[i__2].r = 1.f, a[i__2].i = 0.f; if (i__ % 2 != 0 && i__ < *m) { i__2 = a_subscr(i__, i__ + 1); d__1 = 2.; q__1.r = d__1 * imeps.r, q__1.i = d__1 * imeps.i; a[i__2].r = q__1.r, a[i__2].i = q__1.i; } else if (i__ > 1) { i__2 = a_subscr(i__, i__ - 1); q__2.r = -imeps.r, q__2.i = -imeps.i; d__1 = 2.; q__1.r = d__1 * q__2.r, q__1.i = d__1 * q__2.i; a[i__2].r = q__1.r, a[i__2].i = q__1.i; } } /* L240: */ } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = e_subscr(i__, i__); e[i__2].r = 1.f, e[i__2].i = 0.f; if (i__ <= 4) { i__2 = b_subscr(i__, i__); q__1.r = -1.f, q__1.i = 0.f; b[i__2].r = q__1.r, b[i__2].i = q__1.i; if (i__ > 2) { i__2 = b_subscr(i__, i__); q__1.r = 1.f - reeps.r, q__1.i = 0.f - reeps.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; } if (i__ % 2 != 0 && i__ < *n) { i__2 = b_subscr(i__, i__ + 1); b[i__2].r = imeps.r, b[i__2].i = imeps.i; } else if (i__ > 1) { i__2 = b_subscr(i__, i__ - 1); q__1.r = -imeps.r, q__1.i = -imeps.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; } } else if (i__ <= 8) { if (i__ <= 6) { i__2 = b_subscr(i__, i__); b[i__2].r = reeps.r, b[i__2].i = reeps.i; } else { i__2 = b_subscr(i__, i__); q__1.r = -reeps.r, q__1.i = -reeps.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; } if (i__ % 2 != 0 && i__ < *n) { i__2 = b_subscr(i__, i__ + 1); q__1.r = imeps.r + 1.f, q__1.i = imeps.i + 0.f; b[i__2].r = q__1.r, b[i__2].i = q__1.i; } else if (i__ > 1) { i__2 = b_subscr(i__, i__ - 1); q__2.r = -1.f, q__2.i = 0.f; q__1.r = q__2.r - imeps.r, q__1.i = q__2.i - imeps.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; } } else { i__2 = b_subscr(i__, i__); q__1.r = 1.f - reeps.r, q__1.i = 0.f - reeps.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; if (i__ % 2 != 0 && i__ < *n) { i__2 = b_subscr(i__, i__ + 1); d__1 = 2.; q__1.r = d__1 * imeps.r, q__1.i = d__1 * imeps.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; } else if (i__ > 1) { i__2 = b_subscr(i__, i__ - 1); q__2.r = -imeps.r, q__2.i = -imeps.i; d__1 = 2.; q__1.r = d__1 * q__2.r, q__1.i = d__1 * q__2.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; } } /* L250: */ } } /* Compute rhs (C, F) */ cgemm_("N", "N", m, n, m, &c_b1, &a[a_offset], lda, &r__[r_offset], ldr, & c_b3, &c__[c_offset], ldc); q__1.r = -1.f, q__1.i = 0.f; cgemm_("N", "N", m, n, n, &q__1, &l[l_offset], ldl, &b[b_offset], ldb, & c_b1, &c__[c_offset], ldc); cgemm_("N", "N", m, n, m, &c_b1, &d__[d_offset], ldd, &r__[r_offset], ldr, &c_b3, &f[f_offset], ldf); q__1.r = -1.f, q__1.i = 0.f; cgemm_("N", "N", m, n, n, &q__1, &l[l_offset], ldl, &e[e_offset], lde, & c_b1, &f[f_offset], ldf); /* End of CLATM5 */ return 0; } /* clatm5_ */
/* Subroutine */ int zdrgev_(integer *nsizes, integer *nn, integer *ntypes, logical *dotype, integer *iseed, doublereal *thresh, integer *nounit, doublecomplex *a, integer *lda, doublecomplex *b, doublecomplex *s, doublecomplex *t, doublecomplex *q, integer *ldq, doublecomplex *z__, doublecomplex *qe, integer *ldqe, doublecomplex *alpha, doublecomplex *beta, doublecomplex *alpha1, doublecomplex *beta1, doublecomplex * work, integer *lwork, doublereal *rwork, doublereal *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 ZDRGEV: \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 ZDRGEV: \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 ZDRGEV 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,d10.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; doublereal d__1, d__2; doublecomplex z__1, z__2, z__3; /* Builtin functions */ double d_sign(doublereal *, doublereal *), z_abs(doublecomplex *); void d_cnjg(doublecomplex *, doublecomplex *); 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; static doublereal rmagn[4]; static doublecomplex ctemp; extern /* Subroutine */ int zget52_(logical *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer * , doublecomplex *, doublecomplex *, doublecomplex *, doublereal *, doublereal *); static integer nmats, jsize; extern /* Subroutine */ int zggev_(char *, char *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublereal *, integer *); static integer nerrs, jtype, n1; extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), zlatm4_( integer *, integer *, integer *, integer *, logical *, doublereal *, doublereal *, doublereal *, integer *, integer *, doublecomplex *, integer *); static integer jc, nb, in; extern doublereal dlamch_(char *); static integer jr; extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *); static doublereal 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 *), zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *); extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *, integer *); extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, 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___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 ======= ZDRGEV checks the nonsymmetric generalized eigenvalue problem driver routine ZGGEV. ZGGEV 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 ZDRGEV 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 ZGGEV: (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, ZDRGES 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, ZDRGEV 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 ZDRGES 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. 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*16 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*16 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*16 array, dimension (LDA, max(NN)) The Schur form matrix computed from A by ZGGEV. On exit, S contains the Schur form matrix corresponding to the matrix in A. T (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) The upper triangular matrix computed from B by ZGGEV. Q (workspace) COMPLEX*16 array, dimension (LDQ, max(NN)) The (left) eigenvectors matrix computed by ZGGEV. LDQ (input) INTEGER The leading dimension of Q and Z. It must be at least 1 and at least max( NN ). Z (workspace) COMPLEX*16 array, dimension( LDQ, max(NN) ) The (right) orthogonal matrix computed by ZGGEV. QE (workspace) COMPLEX*16 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*16 array, dimension (max(NN)) BETA (workspace) COMPLEX*16 array, dimension (max(NN)) The generalized eigenvalues of (A,B) computed by ZGGEV. ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th generalized eigenvalue of A and B. ALPHA1 (workspace) COMPLEX*16 array, dimension (max(NN)) BETA1 (workspace) COMPLEX*16 array, dimension (max(NN)) Like ALPHAR, ALPHAI, BETA, these arrays contain the eigenvalues of A and B, but those computed when ZGGEV only computes a partial eigendecomposition, i.e. not the eigenvalues and left and right eigenvectors. WORK (workspace) COMPLEX*16 array, dimension (LWORK) LWORK (input) INTEGER The number of entries in WORK. LWORK >= N*(N+1) RWORK (workspace) DOUBLE PRECISION array, dimension (8*N) Real workspace. RESULT (output) DOUBLE PRECISION 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.) { *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, "ZGEQRF", " ", &nmax, &nmax, &c_n1, & c_n1, (ftnlen)6, (ftnlen)1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&c__1, "ZUNMQR", "LC", &nmax, &nmax, &nmax, &c_n1, ( ftnlen)6, (ftnlen)2), i__1 = max(i__1,i__2), i__2 = ilaenv_(& c__1, "ZUNGQR", " ", &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 = (doublereal) maxwrk, work[1].i = 0.; } if (*lwork < minwrk) { *info = -23; } if (*info != 0) { i__1 = -(*info); xerbla_("ZDRGEV", &i__1); return 0; } /* Quick return if possible */ if (*nsizes == 0 || *ntypes == 0) { return 0; } ulp = dlamch_("Precision"); safmin = dlamch_("Safe minimum"); 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 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 / (doublereal) 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: KZLASS: =1 means w/o rotation, =2 means w/ rotation, =3 means random. KATYPE: the "type" to be passed to ZLATM4 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) { zlaset_("Full", &n, &n, &c_b1, &c_b1, &a[a_offset], lda); } } else { in = n; } zlatm4_(&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.; } /* Generate B (w/o rotation) */ if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) { in = ((n - 1) / 2 << 1) + 1; if (in != n) { zlaset_("Full", &n, &n, &c_b1, &c_b1, &b[b_offset], lda); } } else { in = n; } zlatm4_(&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.; } 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); zlarnd_(&z__1, &c__3, &iseed[1]); q[i__5].r = z__1.r, q[i__5].i = z__1.i; i__5 = z___subscr(jr, jc); zlarnd_(&z__1, &c__3, &iseed[1]); z__[i__5].r = z__1.r, z__[i__5].i = z__1.i; /* L30: */ } i__4 = n + 1 - jc; zlarfg_(&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); d__2 = q[i__5].r; d__1 = d_sign(&c_b28, &d__2); work[i__4].r = d__1, work[i__4].i = 0.; i__4 = q_subscr(jc, jc); q[i__4].r = 1., q[i__4].i = 0.; i__4 = n + 1 - jc; zlarfg_(&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); d__2 = z__[i__5].r; d__1 = d_sign(&c_b28, &d__2); work[i__4].r = d__1, work[i__4].i = 0.; i__4 = z___subscr(jc, jc); z__[i__4].r = 1., z__[i__4].i = 0.; /* L40: */ } zlarnd_(&z__1, &c__3, &iseed[1]); ctemp.r = z__1.r, ctemp.i = z__1.i; i__3 = q_subscr(n, n); q[i__3].r = 1., q[i__3].i = 0.; i__3 = n; work[i__3].r = 0., work[i__3].i = 0.; i__3 = n * 3; d__1 = z_abs(&ctemp); z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1; work[i__3].r = z__1.r, work[i__3].i = z__1.i; zlarnd_(&z__1, &c__3, &iseed[1]); ctemp.r = z__1.r, ctemp.i = z__1.i; i__3 = z___subscr(n, n); z__[i__3].r = 1., z__[i__3].i = 0.; i__3 = n << 1; work[i__3].r = 0., work[i__3].i = 0.; i__3 = n << 2; d__1 = z_abs(&ctemp); z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1; work[i__3].r = z__1.r, work[i__3].i = z__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; d_cnjg(&z__3, &work[n * 3 + jc]); z__2.r = work[i__6].r * z__3.r - work[i__6].i * z__3.i, z__2.i = work[i__6].r * z__3.i + work[i__6].i * z__3.r; i__7 = a_subscr(jr, jc); z__1.r = z__2.r * a[i__7].r - z__2.i * a[i__7].i, z__1.i = z__2.r * a[i__7].i + z__2.i * a[ i__7].r; a[i__5].r = z__1.r, a[i__5].i = z__1.i; i__5 = b_subscr(jr, jc); i__6 = (n << 1) + jr; d_cnjg(&z__3, &work[n * 3 + jc]); z__2.r = work[i__6].r * z__3.r - work[i__6].i * z__3.i, z__2.i = work[i__6].r * z__3.i + work[i__6].i * z__3.r; i__7 = b_subscr(jr, jc); z__1.r = z__2.r * b[i__7].r - z__2.i * b[i__7].i, z__1.i = z__2.r * b[i__7].i + z__2.i * b[ i__7].r; b[i__5].r = z__1.r, b[i__5].i = z__1.i; /* L50: */ } /* L60: */ } i__3 = n - 1; zunm2r_("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; zunm2r_("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; zunm2r_("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; zunm2r_("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]; zlarnd_(&z__2, &c__4, &iseed[1]); z__1.r = rmagn[i__6] * z__2.r, z__1.i = rmagn[i__6] * z__2.i; a[i__5].r = z__1.r, a[i__5].i = z__1.i; i__5 = b_subscr(jr, jc); i__6 = kbmagn[jtype - 1]; zlarnd_(&z__2, &c__4, &iseed[1]); z__1.r = rmagn[i__6] * z__2.r, z__1.i = rmagn[i__6] * z__2.i; b[i__5].r = z__1.r, b[i__5].i = z__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.; /* L110: */ } /* Call ZGGEV to compute eigenvalues and eigenvectors. */ zlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda); zlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda); zggev_("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, "ZGGEV1", (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) */ zget52_(&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, "ZGGEV1", (ftnlen)6); do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(doublereal)); 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) */ zget52_(&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, "ZGGEV1", (ftnlen)6); do_fio(&c__1, (char *)&result[4], (ftnlen)sizeof(doublereal)); 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) */ zlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda); zlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda); zggev_("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, "ZGGEV2", (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 */ zlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda); zlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda); zggev_("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, "ZGGEV3", (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 */ zlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda); zlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda); zggev_("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, "ZGGEV4", (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, "ZGV", (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] < 1e4) { 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( doublereal)); 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( doublereal)); e_wsfe(); } } /* L200: */ } L210: ; } /* L220: */ } /* Summary */ alasvm_("ZGV", nounit, &nerrs, &ntestt, &c__0); work[1].r = (doublereal) maxwrk, work[1].i = 0.; return 0; /* End of ZDRGEV */ } /* zdrgev_ */
/* Subroutine */ int csytrs_(char *uplo, integer *n, integer *nrhs, complex * a, integer *lda, integer *ipiv, complex *b, integer *ldb, 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 ======= CSYTRS solves a system of linear equations A*X = B with a complex symmetric matrix A using the factorization A = U*D*U**T or A = L*D*L**T computed by CSYTRF. Arguments ========= UPLO (input) CHARACTER*1 Specifies whether the details of the factorization are stored as an upper or lower triangular matrix. = 'U': Upper triangular, form is A = U*D*U**T; = 'L': Lower triangular, form is A = L*D*L**T. N (input) INTEGER The order of the matrix A. N >= 0. NRHS (input) INTEGER The number of right hand sides, i.e., the number of columns of the matrix B. NRHS >= 0. A (input) COMPLEX array, dimension (LDA,N) The block diagonal matrix D and the multipliers used to obtain the factor U or L as computed by CSYTRF. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,N). IPIV (input) INTEGER array, dimension (N) Details of the interchanges and the block structure of D as determined by CSYTRF. B (input/output) COMPLEX array, dimension (LDB,NRHS) On entry, the right hand side matrix B. On exit, the solution matrix X. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,N). INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value ===================================================================== Parameter adjustments */ /* Table of constant values */ static complex c_b1 = {1.f,0.f}; static integer c__1 = 1; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; complex q__1, q__2, q__3; /* Builtin functions */ void c_div(complex *, complex *, complex *); /* Local variables */ static complex akm1k; static integer j, k; extern /* Subroutine */ int cscal_(integer *, complex *, complex *, integer *); extern logical lsame_(char *, char *); static complex denom; extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * , complex *, integer *, complex *, integer *, complex *, complex * , integer *), cgeru_(integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, integer *), cswap_(integer *, complex *, integer *, complex *, integer *); static logical upper; static complex ak, bk; static integer kp; extern /* Subroutine */ int xerbla_(char *, integer *); static complex akm1, bkm1; #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)] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; --ipiv; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*nrhs < 0) { *info = -3; } else if (*lda < max(1,*n)) { *info = -5; } else if (*ldb < max(1,*n)) { *info = -8; } if (*info != 0) { i__1 = -(*info); xerbla_("CSYTRS", &i__1); return 0; } /* Quick return if possible */ if (*n == 0 || *nrhs == 0) { return 0; } if (upper) { /* Solve A*X = B, where A = U*D*U'. First solve U*D*X = B, overwriting B with X. K is the main loop index, decreasing from N to 1 in steps of 1 or 2, depending on the size of the diagonal blocks. */ k = *n; L10: /* If K < 1, exit from loop. */ if (k < 1) { goto L30; } if (ipiv[k] > 0) { /* 1 x 1 diagonal block Interchange rows K and IPIV(K). */ kp = ipiv[k]; if (kp != k) { cswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb); } /* Multiply by inv(U(K)), where U(K) is the transformation stored in column K of A. */ i__1 = k - 1; q__1.r = -1.f, q__1.i = 0.f; cgeru_(&i__1, nrhs, &q__1, &a_ref(1, k), &c__1, &b_ref(k, 1), ldb, &b_ref(1, 1), ldb); /* Multiply by the inverse of the diagonal block. */ c_div(&q__1, &c_b1, &a_ref(k, k)); cscal_(nrhs, &q__1, &b_ref(k, 1), ldb); --k; } else { /* 2 x 2 diagonal block Interchange rows K-1 and -IPIV(K). */ kp = -ipiv[k]; if (kp != k - 1) { cswap_(nrhs, &b_ref(k - 1, 1), ldb, &b_ref(kp, 1), ldb); } /* Multiply by inv(U(K)), where U(K) is the transformation stored in columns K-1 and K of A. */ i__1 = k - 2; q__1.r = -1.f, q__1.i = 0.f; cgeru_(&i__1, nrhs, &q__1, &a_ref(1, k), &c__1, &b_ref(k, 1), ldb, &b_ref(1, 1), ldb); i__1 = k - 2; q__1.r = -1.f, q__1.i = 0.f; cgeru_(&i__1, nrhs, &q__1, &a_ref(1, k - 1), &c__1, &b_ref(k - 1, 1), ldb, &b_ref(1, 1), ldb); /* Multiply by the inverse of the diagonal block. */ i__1 = a_subscr(k - 1, k); akm1k.r = a[i__1].r, akm1k.i = a[i__1].i; c_div(&q__1, &a_ref(k - 1, k - 1), &akm1k); akm1.r = q__1.r, akm1.i = q__1.i; c_div(&q__1, &a_ref(k, k), &akm1k); ak.r = q__1.r, ak.i = q__1.i; q__2.r = akm1.r * ak.r - akm1.i * ak.i, q__2.i = akm1.r * ak.i + akm1.i * ak.r; q__1.r = q__2.r - 1.f, q__1.i = q__2.i + 0.f; denom.r = q__1.r, denom.i = q__1.i; i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { c_div(&q__1, &b_ref(k - 1, j), &akm1k); bkm1.r = q__1.r, bkm1.i = q__1.i; c_div(&q__1, &b_ref(k, j), &akm1k); bk.r = q__1.r, bk.i = q__1.i; i__2 = b_subscr(k - 1, j); q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r * bkm1.i + ak.i * bkm1.r; q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i; c_div(&q__1, &q__2, &denom); b[i__2].r = q__1.r, b[i__2].i = q__1.i; i__2 = b_subscr(k, j); q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r * bk.i + akm1.i * bk.r; q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i; c_div(&q__1, &q__2, &denom); b[i__2].r = q__1.r, b[i__2].i = q__1.i; /* L20: */ } k += -2; } goto L10; L30: /* Next solve U'*X = B, overwriting B with X. K is the main loop index, increasing from 1 to N in steps of 1 or 2, depending on the size of the diagonal blocks. */ k = 1; L40: /* If K > N, exit from loop. */ if (k > *n) { goto L50; } if (ipiv[k] > 0) { /* 1 x 1 diagonal block Multiply by inv(U'(K)), where U(K) is the transformation stored in column K of A. */ i__1 = k - 1; q__1.r = -1.f, q__1.i = 0.f; cgemv_("Transpose", &i__1, nrhs, &q__1, &b[b_offset], ldb, &a_ref( 1, k), &c__1, &c_b1, &b_ref(k, 1), ldb); /* Interchange rows K and IPIV(K). */ kp = ipiv[k]; if (kp != k) { cswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb); } ++k; } else { /* 2 x 2 diagonal block Multiply by inv(U'(K+1)), where U(K+1) is the transformation stored in columns K and K+1 of A. */ i__1 = k - 1; q__1.r = -1.f, q__1.i = 0.f; cgemv_("Transpose", &i__1, nrhs, &q__1, &b[b_offset], ldb, &a_ref( 1, k), &c__1, &c_b1, &b_ref(k, 1), ldb); i__1 = k - 1; q__1.r = -1.f, q__1.i = 0.f; cgemv_("Transpose", &i__1, nrhs, &q__1, &b[b_offset], ldb, &a_ref( 1, k + 1), &c__1, &c_b1, &b_ref(k + 1, 1), ldb) ; /* Interchange rows K and -IPIV(K). */ kp = -ipiv[k]; if (kp != k) { cswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb); } k += 2; } goto L40; L50: ; } else { /* Solve A*X = B, where A = L*D*L'. First solve L*D*X = B, overwriting B with X. K is the main loop index, increasing from 1 to N in steps of 1 or 2, depending on the size of the diagonal blocks. */ k = 1; L60: /* If K > N, exit from loop. */ if (k > *n) { goto L80; } if (ipiv[k] > 0) { /* 1 x 1 diagonal block Interchange rows K and IPIV(K). */ kp = ipiv[k]; if (kp != k) { cswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb); } /* Multiply by inv(L(K)), where L(K) is the transformation stored in column K of A. */ if (k < *n) { i__1 = *n - k; q__1.r = -1.f, q__1.i = 0.f; cgeru_(&i__1, nrhs, &q__1, &a_ref(k + 1, k), &c__1, &b_ref(k, 1), ldb, &b_ref(k + 1, 1), ldb); } /* Multiply by the inverse of the diagonal block. */ c_div(&q__1, &c_b1, &a_ref(k, k)); cscal_(nrhs, &q__1, &b_ref(k, 1), ldb); ++k; } else { /* 2 x 2 diagonal block Interchange rows K+1 and -IPIV(K). */ kp = -ipiv[k]; if (kp != k + 1) { cswap_(nrhs, &b_ref(k + 1, 1), ldb, &b_ref(kp, 1), ldb); } /* Multiply by inv(L(K)), where L(K) is the transformation stored in columns K and K+1 of A. */ if (k < *n - 1) { i__1 = *n - k - 1; q__1.r = -1.f, q__1.i = 0.f; cgeru_(&i__1, nrhs, &q__1, &a_ref(k + 2, k), &c__1, &b_ref(k, 1), ldb, &b_ref(k + 2, 1), ldb); i__1 = *n - k - 1; q__1.r = -1.f, q__1.i = 0.f; cgeru_(&i__1, nrhs, &q__1, &a_ref(k + 2, k + 1), &c__1, & b_ref(k + 1, 1), ldb, &b_ref(k + 2, 1), ldb); } /* Multiply by the inverse of the diagonal block. */ i__1 = a_subscr(k + 1, k); akm1k.r = a[i__1].r, akm1k.i = a[i__1].i; c_div(&q__1, &a_ref(k, k), &akm1k); akm1.r = q__1.r, akm1.i = q__1.i; c_div(&q__1, &a_ref(k + 1, k + 1), &akm1k); ak.r = q__1.r, ak.i = q__1.i; q__2.r = akm1.r * ak.r - akm1.i * ak.i, q__2.i = akm1.r * ak.i + akm1.i * ak.r; q__1.r = q__2.r - 1.f, q__1.i = q__2.i + 0.f; denom.r = q__1.r, denom.i = q__1.i; i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { c_div(&q__1, &b_ref(k, j), &akm1k); bkm1.r = q__1.r, bkm1.i = q__1.i; c_div(&q__1, &b_ref(k + 1, j), &akm1k); bk.r = q__1.r, bk.i = q__1.i; i__2 = b_subscr(k, j); q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r * bkm1.i + ak.i * bkm1.r; q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i; c_div(&q__1, &q__2, &denom); b[i__2].r = q__1.r, b[i__2].i = q__1.i; i__2 = b_subscr(k + 1, j); q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r * bk.i + akm1.i * bk.r; q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i; c_div(&q__1, &q__2, &denom); b[i__2].r = q__1.r, b[i__2].i = q__1.i; /* L70: */ } k += 2; } goto L60; L80: /* Next solve L'*X = B, overwriting B with X. K is the main loop index, decreasing from N to 1 in steps of 1 or 2, depending on the size of the diagonal blocks. */ k = *n; L90: /* If K < 1, exit from loop. */ if (k < 1) { goto L100; } if (ipiv[k] > 0) { /* 1 x 1 diagonal block Multiply by inv(L'(K)), where L(K) is the transformation stored in column K of A. */ if (k < *n) { i__1 = *n - k; q__1.r = -1.f, q__1.i = 0.f; cgemv_("Transpose", &i__1, nrhs, &q__1, &b_ref(k + 1, 1), ldb, &a_ref(k + 1, k), &c__1, &c_b1, &b_ref(k, 1), ldb); } /* Interchange rows K and IPIV(K). */ kp = ipiv[k]; if (kp != k) { cswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb); } --k; } else { /* 2 x 2 diagonal block Multiply by inv(L'(K-1)), where L(K-1) is the transformation stored in columns K-1 and K of A. */ if (k < *n) { i__1 = *n - k; q__1.r = -1.f, q__1.i = 0.f; cgemv_("Transpose", &i__1, nrhs, &q__1, &b_ref(k + 1, 1), ldb, &a_ref(k + 1, k), &c__1, &c_b1, &b_ref(k, 1), ldb); i__1 = *n - k; q__1.r = -1.f, q__1.i = 0.f; cgemv_("Transpose", &i__1, nrhs, &q__1, &b_ref(k + 1, 1), ldb, &a_ref(k + 1, k - 1), &c__1, &c_b1, &b_ref(k - 1, 1), ldb); } /* Interchange rows K and -IPIV(K). */ kp = -ipiv[k]; if (kp != k) { cswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb); } k += -2; } goto L90; L100: ; } return 0; /* End of CSYTRS */ } /* csytrs_ */
/* 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 chegs2_(integer *itype, char *uplo, integer *n, complex * a, integer *lda, complex *b, integer *ldb, 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 ======= CHEGS2 reduces a complex Hermitian-definite generalized eigenproblem to standard form. If ITYPE = 1, the problem is A*x = lambda*B*x, and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L') If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L. B must have been previously factorized as U'*U or L*L' by CPOTRF. Arguments ========= ITYPE (input) INTEGER = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L'); = 2 or 3: compute U*A*U' or L'*A*L. UPLO (input) CHARACTER Specifies whether the upper or lower triangular part of the Hermitian matrix A is stored, and how B has been factorized. = 'U': Upper triangular = 'L': Lower triangular N (input) INTEGER The order of the matrices A and B. N >= 0. A (input/output) COMPLEX array, dimension (LDA,N) On entry, the Hermitian matrix A. If UPLO = 'U', the leading n by n upper triangular part of A contains the upper triangular part of the matrix A, and the strictly lower triangular part of A is not referenced. If UPLO = 'L', the leading n by n lower triangular part of A contains the lower triangular part of the matrix A, and the strictly upper triangular part of A is not referenced. On exit, if INFO = 0, the transformed matrix, stored in the same format as A. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,N). B (input) COMPLEX array, dimension (LDB,N) The triangular factor from the Cholesky factorization of B, as returned by CPOTRF. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,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 complex c_b1 = {1.f,0.f}; static integer c__1 = 1; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; real r__1, r__2; complex q__1; /* Local variables */ extern /* Subroutine */ int cher2_(char *, integer *, complex *, complex * , integer *, complex *, integer *, complex *, integer *); static integer k; extern logical lsame_(char *, char *); extern /* Subroutine */ int caxpy_(integer *, complex *, complex *, integer *, complex *, integer *); static logical upper; extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *, complex *, integer *, complex *, integer *), ctrsv_(char *, char *, char *, integer *, complex *, integer *, complex *, integer *); static complex ct; extern /* Subroutine */ int clacgv_(integer *, complex *, integer *), csscal_(integer *, real *, complex *, integer *), xerbla_(char *, integer *); static real akk, bkk; #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)] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (*itype < 1 || *itype > 3) { *info = -1; } else if (! upper && ! lsame_(uplo, "L")) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*lda < max(1,*n)) { *info = -5; } else if (*ldb < max(1,*n)) { *info = -7; } if (*info != 0) { i__1 = -(*info); xerbla_("CHEGS2", &i__1); return 0; } if (*itype == 1) { if (upper) { /* Compute inv(U')*A*inv(U) */ i__1 = *n; for (k = 1; k <= i__1; ++k) { /* Update the upper triangle of A(k:n,k:n) */ i__2 = a_subscr(k, k); akk = a[i__2].r; i__2 = b_subscr(k, k); bkk = b[i__2].r; /* Computing 2nd power */ r__1 = bkk; akk /= r__1 * r__1; i__2 = a_subscr(k, k); a[i__2].r = akk, a[i__2].i = 0.f; if (k < *n) { i__2 = *n - k; r__1 = 1.f / bkk; csscal_(&i__2, &r__1, &a_ref(k, k + 1), lda); r__1 = akk * -.5f; ct.r = r__1, ct.i = 0.f; i__2 = *n - k; clacgv_(&i__2, &a_ref(k, k + 1), lda); i__2 = *n - k; clacgv_(&i__2, &b_ref(k, k + 1), ldb); i__2 = *n - k; caxpy_(&i__2, &ct, &b_ref(k, k + 1), ldb, &a_ref(k, k + 1) , lda); i__2 = *n - k; q__1.r = -1.f, q__1.i = 0.f; cher2_(uplo, &i__2, &q__1, &a_ref(k, k + 1), lda, &b_ref( k, k + 1), ldb, &a_ref(k + 1, k + 1), lda); i__2 = *n - k; caxpy_(&i__2, &ct, &b_ref(k, k + 1), ldb, &a_ref(k, k + 1) , lda); i__2 = *n - k; clacgv_(&i__2, &b_ref(k, k + 1), ldb); i__2 = *n - k; ctrsv_(uplo, "Conjugate transpose", "Non-unit", &i__2, & b_ref(k + 1, k + 1), ldb, &a_ref(k, k + 1), lda); i__2 = *n - k; clacgv_(&i__2, &a_ref(k, k + 1), lda); } /* L10: */ } } else { /* Compute inv(L)*A*inv(L') */ i__1 = *n; for (k = 1; k <= i__1; ++k) { /* Update the lower triangle of A(k:n,k:n) */ i__2 = a_subscr(k, k); akk = a[i__2].r; i__2 = b_subscr(k, k); bkk = b[i__2].r; /* Computing 2nd power */ r__1 = bkk; akk /= r__1 * r__1; i__2 = a_subscr(k, k); a[i__2].r = akk, a[i__2].i = 0.f; if (k < *n) { i__2 = *n - k; r__1 = 1.f / bkk; csscal_(&i__2, &r__1, &a_ref(k + 1, k), &c__1); r__1 = akk * -.5f; ct.r = r__1, ct.i = 0.f; i__2 = *n - k; caxpy_(&i__2, &ct, &b_ref(k + 1, k), &c__1, &a_ref(k + 1, k), &c__1); i__2 = *n - k; q__1.r = -1.f, q__1.i = 0.f; cher2_(uplo, &i__2, &q__1, &a_ref(k + 1, k), &c__1, & b_ref(k + 1, k), &c__1, &a_ref(k + 1, k + 1), lda); i__2 = *n - k; caxpy_(&i__2, &ct, &b_ref(k + 1, k), &c__1, &a_ref(k + 1, k), &c__1); i__2 = *n - k; ctrsv_(uplo, "No transpose", "Non-unit", &i__2, &b_ref(k + 1, k + 1), ldb, &a_ref(k + 1, k), &c__1); } /* L20: */ } } } else { if (upper) { /* Compute U*A*U' */ i__1 = *n; for (k = 1; k <= i__1; ++k) { /* Update the upper triangle of A(1:k,1:k) */ i__2 = a_subscr(k, k); akk = a[i__2].r; i__2 = b_subscr(k, k); bkk = b[i__2].r; i__2 = k - 1; ctrmv_(uplo, "No transpose", "Non-unit", &i__2, &b[b_offset], ldb, &a_ref(1, k), &c__1); r__1 = akk * .5f; ct.r = r__1, ct.i = 0.f; i__2 = k - 1; caxpy_(&i__2, &ct, &b_ref(1, k), &c__1, &a_ref(1, k), &c__1); i__2 = k - 1; cher2_(uplo, &i__2, &c_b1, &a_ref(1, k), &c__1, &b_ref(1, k), &c__1, &a[a_offset], lda); i__2 = k - 1; caxpy_(&i__2, &ct, &b_ref(1, k), &c__1, &a_ref(1, k), &c__1); i__2 = k - 1; csscal_(&i__2, &bkk, &a_ref(1, k), &c__1); i__2 = a_subscr(k, k); /* Computing 2nd power */ r__2 = bkk; r__1 = akk * (r__2 * r__2); a[i__2].r = r__1, a[i__2].i = 0.f; /* L30: */ } } else { /* Compute L'*A*L */ i__1 = *n; for (k = 1; k <= i__1; ++k) { /* Update the lower triangle of A(1:k,1:k) */ i__2 = a_subscr(k, k); akk = a[i__2].r; i__2 = b_subscr(k, k); bkk = b[i__2].r; i__2 = k - 1; clacgv_(&i__2, &a_ref(k, 1), lda); i__2 = k - 1; ctrmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &b[ b_offset], ldb, &a_ref(k, 1), lda); r__1 = akk * .5f; ct.r = r__1, ct.i = 0.f; i__2 = k - 1; clacgv_(&i__2, &b_ref(k, 1), ldb); i__2 = k - 1; caxpy_(&i__2, &ct, &b_ref(k, 1), ldb, &a_ref(k, 1), lda); i__2 = k - 1; cher2_(uplo, &i__2, &c_b1, &a_ref(k, 1), lda, &b_ref(k, 1), ldb, &a[a_offset], lda); i__2 = k - 1; caxpy_(&i__2, &ct, &b_ref(k, 1), ldb, &a_ref(k, 1), lda); i__2 = k - 1; clacgv_(&i__2, &b_ref(k, 1), ldb); i__2 = k - 1; csscal_(&i__2, &bkk, &a_ref(k, 1), lda); i__2 = k - 1; clacgv_(&i__2, &a_ref(k, 1), lda); i__2 = a_subscr(k, k); /* Computing 2nd power */ r__2 = bkk; r__1 = akk * (r__2 * r__2); a[i__2].r = r__1, a[i__2].i = 0.f; /* L40: */ } } } return 0; /* End of CHEGS2 */ } /* chegs2_ */
/* Subroutine */ int cgghrd_(char *compq, char *compz, integer *n, integer * ilo, integer *ihi, complex *a, integer *lda, complex *b, integer *ldb, complex *q, integer *ldq, complex *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 ======= CGGHRD 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 CGGBAL; 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 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 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 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 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 */ /* Table of constant values */ static complex c_b1 = {1.f,0.f}; static complex c_b2 = {0.f,0.f}; 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; /* Builtin functions */ void r_cnjg(complex *, complex *); /* Local variables */ static integer jcol; extern /* Subroutine */ int crot_(integer *, complex *, integer *, complex *, integer *, real *, complex *); static integer jrow; static real c__; static complex s; extern logical lsame_(char *, char *); static complex ctemp; extern /* Subroutine */ int claset_(char *, integer *, integer *, complex *, complex *, complex *, integer *), clartg_(complex *, complex *, real *, complex *, complex *), xerbla_(char *, integer *); static integer icompq, icompz; 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)] 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_("CGGHRD", &i__1); return 0; } /* Initialize Q and Z if desired. */ if (icompq == 3) { claset_("Full", n, n, &c_b2, &c_b1, &q[q_offset], ldq); } if (icompz == 3) { claset_("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.f, b[i__3].i = 0.f; /* 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; clartg_(&ctemp, &a_ref(jrow, jcol), &c__, &s, &a_ref(jrow - 1, jcol)); i__3 = a_subscr(jrow, jcol); a[i__3].r = 0.f, a[i__3].i = 0.f; i__3 = *n - jcol; crot_(&i__3, &a_ref(jrow - 1, jcol + 1), lda, &a_ref(jrow, jcol + 1), lda, &c__, &s); i__3 = *n + 2 - jrow; crot_(&i__3, &b_ref(jrow - 1, jrow - 1), ldb, &b_ref(jrow, jrow - 1), ldb, &c__, &s); if (ilq) { r_cnjg(&q__1, &s); crot_(n, &q_ref(1, jrow - 1), &c__1, &q_ref(1, jrow), &c__1, & c__, &q__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; clartg_(&ctemp, &b_ref(jrow, jrow - 1), &c__, &s, &b_ref(jrow, jrow)); i__3 = b_subscr(jrow, jrow - 1); b[i__3].r = 0.f, b[i__3].i = 0.f; crot_(ihi, &a_ref(1, jrow), &c__1, &a_ref(1, jrow - 1), &c__1, & c__, &s); i__3 = jrow - 1; crot_(&i__3, &b_ref(1, jrow), &c__1, &b_ref(1, jrow - 1), &c__1, & c__, &s); if (ilz) { crot_(n, &z___ref(1, jrow), &c__1, &z___ref(1, jrow - 1), & c__1, &c__, &s); } /* L30: */ } /* L40: */ } return 0; /* End of CGGHRD */ } /* cgghrd_ */
/* Subroutine */ int cgsvts_(integer *m, integer *p, integer *n, complex *a, complex *af, integer *lda, complex *b, complex *bf, integer *ldb, complex *u, integer *ldu, complex *v, integer *ldv, complex *q, integer *ldq, real *alpha, real *beta, complex *r__, integer *ldr, integer *iwork, complex *work, integer *lwork, real *rwork, real * result) { /* System generated locals */ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, bf_dim1, bf_offset, q_dim1, q_offset, r_dim1, r_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4, i__5, i__6; real r__1; complex q__1, q__2; /* Local variables */ static integer info; static real unfl, temp; static integer i__, j, k, l; 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 /* Subroutine */ int scopy_(integer *, real *, integer *, real *, integer *); extern doublereal clange_(char *, integer *, integer *, complex *, integer *, real *), clanhe_(char *, char *, 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 *), cggsvd_(char *, char *, char *, integer *, integer *, integer *, integer *, integer *, complex *, integer *, complex *, integer *, real *, real *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, real *, integer *, integer *); static real ulpinv, ulp; #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 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 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 June 30, 1999 Purpose ======= CGSVTS tests CGGSVD, which computes the GSVD of an M-by-N matrix A and a P-by-N matrix B: U'*A*Q = D1*R and V'*B*Q = D2*R. 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,M) The M-by-N matrix A. AF (output) COMPLEX array, dimension (LDA,N) Details of the GSVD of A and B, as returned by CGGSVD, see CGGSVD for further details. LDA (input) INTEGER The leading dimension of the arrays A and AF. LDA >= max( 1,M ). B (input) COMPLEX array, dimension (LDB,P) On entry, the P-by-N matrix B. BF (output) COMPLEX array, dimension (LDB,N) Details of the GSVD of A and B, as returned by CGGSVD, see CGGSVD for further details. LDB (input) INTEGER The leading dimension of the arrays B and BF. LDB >= max(1,P). U (output) COMPLEX array, dimension(LDU,M) The M by M unitary matrix U. LDU (input) INTEGER The leading dimension of the array U. LDU >= max(1,M). V (output) COMPLEX array, dimension(LDV,M) The P by P unitary matrix V. LDV (input) INTEGER The leading dimension of the array V. LDV >= max(1,P). Q (output) COMPLEX array, dimension(LDQ,N) The N by N unitary matrix Q. LDQ (input) INTEGER The leading dimension of the array Q. LDQ >= max(1,N). ALPHA (output) REAL array, dimension (N) BETA (output) REAL array, dimension (N) The generalized singular value pairs of A and B, the ``diagonal'' matrices D1 and D2 are constructed from ALPHA and BETA, see subroutine CGGSVD for details. R (output) COMPLEX array, dimension(LDQ,N) The upper triangular matrix R. LDR (input) INTEGER The leading dimension of the array R. LDR >= max(1,N). IWORK (workspace) INTEGER array, dimension (N) WORK (workspace) COMPLEX array, dimension (LWORK) LWORK (input) INTEGER The dimension of the array WORK, LWORK >= max(M,P,N)*max(M,P,N). RWORK (workspace) REAL array, dimension (max(M,P,N)) RESULT (output) REAL array, dimension (5) The test ratios: RESULT(1) = norm( U'*A*Q - D1*R ) / ( MAX(M,N)*norm(A)*ULP) RESULT(2) = norm( V'*B*Q - D2*R ) / ( MAX(P,N)*norm(B)*ULP) RESULT(3) = norm( I - U'*U ) / ( M*ULP ) RESULT(4) = norm( I - V'*V ) / ( P*ULP ) RESULT(5) = norm( I - Q'*Q ) / ( N*ULP ) RESULT(6) = 0 if ALPHA is in decreasing order; = ULPINV otherwise. ===================================================================== Parameter adjustments */ af_dim1 = *lda; af_offset = 1 + af_dim1 * 1; af -= af_offset; a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_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; 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; --alpha; --beta; r_dim1 = *ldr; r_offset = 1 + r_dim1 * 1; r__ -= r_offset; --iwork; --work; --rwork; --result; /* Function Body */ ulp = slamch_("Precision"); ulpinv = 1.f / ulp; 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. */ cggsvd_("U", "V", "Q", m, n, p, &k, &l, &af[af_offset], lda, &bf[ bf_offset], ldb, &alpha[1], &beta[1], &u[u_offset], ldu, &v[ v_offset], ldv, &q[q_offset], ldq, &work[1], &rwork[1], &iwork[1], &info); /* Copy R Computing MIN */ i__2 = k + l; i__1 = min(i__2,*m); for (i__ = 1; i__ <= i__1; ++i__) { i__2 = k + l; for (j = i__; j <= i__2; ++j) { i__3 = r___subscr(i__, j); i__4 = af_subscr(i__, *n - k - l + j); r__[i__3].r = af[i__4].r, r__[i__3].i = af[i__4].i; /* L10: */ } /* L20: */ } if (*m - k - l < 0) { i__1 = k + l; for (i__ = *m + 1; i__ <= i__1; ++i__) { i__2 = k + l; for (j = i__; j <= i__2; ++j) { i__3 = r___subscr(i__, j); i__4 = bf_subscr(i__ - k, *n - k - l + j); r__[i__3].r = bf[i__4].r, r__[i__3].i = bf[i__4].i; /* L30: */ } /* L40: */ } } /* Compute A:= U'*A*Q - D1*R */ cgemm_("No transpose", "No transpose", m, n, n, &c_b2, &a[a_offset], lda, &q[q_offset], ldq, &c_b1, &work[1], lda); cgemm_("Conjugate transpose", "No transpose", m, n, m, &c_b2, &u[u_offset] , ldu, &work[1], lda, &c_b1, &a[a_offset], lda); i__1 = k; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = k + l; for (j = i__; j <= i__2; ++j) { i__3 = a_subscr(i__, *n - k - l + j); i__4 = a_subscr(i__, *n - k - l + j); i__5 = r___subscr(i__, j); q__1.r = a[i__4].r - r__[i__5].r, q__1.i = a[i__4].i - r__[i__5] .i; a[i__3].r = q__1.r, a[i__3].i = q__1.i; /* L50: */ } /* L60: */ } /* Computing MIN */ i__2 = k + l; i__1 = min(i__2,*m); for (i__ = k + 1; i__ <= i__1; ++i__) { i__2 = k + l; for (j = i__; j <= i__2; ++j) { i__3 = a_subscr(i__, *n - k - l + j); i__4 = a_subscr(i__, *n - k - l + j); i__5 = i__; i__6 = r___subscr(i__, j); q__2.r = alpha[i__5] * r__[i__6].r, q__2.i = alpha[i__5] * r__[ i__6].i; q__1.r = a[i__4].r - q__2.r, q__1.i = a[i__4].i - q__2.i; a[i__3].r = q__1.r, a[i__3].i = q__1.i; /* L70: */ } /* L80: */ } /* Compute norm( U'*A*Q - D1*R ) / ( MAX(1,M,N)*norm(A)*ULP ) . */ resid = clange_("1", m, n, &a[a_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 B := V'*B*Q - D2*R */ cgemm_("No transpose", "No transpose", p, n, n, &c_b2, &b[b_offset], ldb, &q[q_offset], ldq, &c_b1, &work[1], ldb); cgemm_("Conjugate transpose", "No transpose", p, n, p, &c_b2, &v[v_offset] , ldv, &work[1], ldb, &c_b1, &b[b_offset], ldb); i__1 = l; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = l; for (j = i__; j <= i__2; ++j) { i__3 = b_subscr(i__, *n - l + j); i__4 = b_subscr(i__, *n - l + j); i__5 = k + i__; i__6 = r___subscr(k + i__, k + j); q__2.r = beta[i__5] * r__[i__6].r, q__2.i = beta[i__5] * r__[i__6] .i; q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i - q__2.i; b[i__3].r = q__1.r, b[i__3].i = q__1.i; /* L90: */ } /* L100: */ } /* Compute norm( V'*B*Q - D2*R ) / ( MAX(P,N)*norm(B)*ULP ) . */ resid = clange_("1", p, n, &b[b_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 - U'*U */ claset_("Full", m, m, &c_b1, &c_b2, &work[1], ldq); cherk_("Upper", "Conjugate transpose", m, m, &c_b36, &u[u_offset], ldu, & c_b37, &work[1], ldu); /* Compute norm( I - U'*U ) / ( M * ULP ) . */ resid = clanhe_("1", "Upper", m, &work[1], ldu, &rwork[1]); result[3] = resid / (real) max(1,*m) / ulp; /* Compute I - V'*V */ claset_("Full", p, p, &c_b1, &c_b2, &work[1], ldv); cherk_("Upper", "Conjugate transpose", p, p, &c_b36, &v[v_offset], ldv, & c_b37, &work[1], ldv); /* Compute norm( I - V'*V ) / ( P * ULP ) . */ resid = clanhe_("1", "Upper", p, &work[1], ldv, &rwork[1]); result[4] = resid / (real) max(1,*p) / ulp; /* Compute I - Q'*Q */ claset_("Full", n, n, &c_b1, &c_b2, &work[1], ldq); cherk_("Upper", "Conjugate transpose", n, n, &c_b36, &q[q_offset], ldq, & c_b37, &work[1], ldq); /* Compute norm( I - Q'*Q ) / ( N * ULP ) . */ resid = clanhe_("1", "Upper", n, &work[1], ldq, &rwork[1]); result[5] = resid / (real) max(1,*n) / ulp; /* Check sorting */ scopy_(n, &alpha[1], &c__1, &rwork[1], &c__1); /* Computing MIN */ i__2 = k + l; i__1 = min(i__2,*m); for (i__ = k + 1; i__ <= i__1; ++i__) { j = iwork[i__]; if (i__ != j) { temp = rwork[i__]; rwork[i__] = rwork[j]; rwork[j] = temp; } /* L110: */ } result[6] = 0.f; /* Computing MIN */ i__2 = k + l; i__1 = min(i__2,*m) - 1; for (i__ = k + 1; i__ <= i__1; ++i__) { if (rwork[i__] < rwork[i__ + 1]) { result[6] = ulpinv; } /* L120: */ } return 0; /* End of CGSVTS */ } /* cgsvts_ */
/* Subroutine */ int zptts2_(integer *iuplo, integer *n, integer *nrhs, doublereal *d__, doublecomplex *e, doublecomplex *b, integer *ldb) { /* -- 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 ======= ZPTTS2 solves a tridiagonal system of the form A * X = B using the factorization A = U'*D*U or A = L*D*L' computed by ZPTTRF. D is a diagonal matrix specified in the vector D, U (or L) is a unit bidiagonal matrix whose superdiagonal (subdiagonal) is specified in the vector E, and X and B are N by NRHS matrices. Arguments ========= IUPLO (input) INTEGER Specifies the form of the factorization and whether the vector E is the superdiagonal of the upper bidiagonal factor U or the subdiagonal of the lower bidiagonal factor L. = 1: A = U'*D*U, E is the superdiagonal of U = 0: A = L*D*L', E is the subdiagonal of L N (input) INTEGER The order of the tridiagonal matrix A. N >= 0. NRHS (input) INTEGER The number of right hand sides, i.e., the number of columns of the matrix B. NRHS >= 0. D (input) DOUBLE PRECISION array, dimension (N) The n diagonal elements of the diagonal matrix D from the factorization A = U'*D*U or A = L*D*L'. E (input) COMPLEX*16 array, dimension (N-1) If IUPLO = 1, the (n-1) superdiagonal elements of the unit bidiagonal factor U from the factorization A = U'*D*U. If IUPLO = 0, the (n-1) subdiagonal elements of the unit bidiagonal factor L from the factorization A = L*D*L'. B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) On entry, the right hand side vectors B for the system of linear equations. On exit, the solution vectors, X. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,N). ===================================================================== Quick return if possible Parameter adjustments */ /* System generated locals */ integer b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, i__6; doublereal d__1; doublecomplex z__1, z__2, z__3, z__4; /* Builtin functions */ void d_cnjg(doublecomplex *, doublecomplex *); /* Local variables */ static integer i__, j; extern /* Subroutine */ int zdscal_(integer *, doublereal *, doublecomplex *, integer *); #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)] --d__; --e; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; /* Function Body */ if (*n <= 1) { if (*n == 1) { d__1 = 1. / d__[1]; zdscal_(nrhs, &d__1, &b[b_offset], ldb); } return 0; } if (*iuplo == 1) { /* Solve A * X = B using the factorization A = U'*D*U, overwriting each right hand side vector with its solution. */ if (*nrhs <= 2) { j = 1; L10: /* Solve U' * x = b. */ i__1 = *n; for (i__ = 2; i__ <= i__1; ++i__) { i__2 = b_subscr(i__, j); i__3 = b_subscr(i__, j); i__4 = b_subscr(i__ - 1, j); d_cnjg(&z__3, &e[i__ - 1]); z__2.r = b[i__4].r * z__3.r - b[i__4].i * z__3.i, z__2.i = b[ i__4].r * z__3.i + b[i__4].i * z__3.r; z__1.r = b[i__3].r - z__2.r, z__1.i = b[i__3].i - z__2.i; b[i__2].r = z__1.r, b[i__2].i = z__1.i; /* L20: */ } /* Solve D * U * x = b. */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = b_subscr(i__, j); i__3 = b_subscr(i__, j); i__4 = i__; z__1.r = b[i__3].r / d__[i__4], z__1.i = b[i__3].i / d__[i__4] ; b[i__2].r = z__1.r, b[i__2].i = z__1.i; /* L30: */ } for (i__ = *n - 1; i__ >= 1; --i__) { i__1 = b_subscr(i__, j); i__2 = b_subscr(i__, j); i__3 = b_subscr(i__ + 1, j); i__4 = i__; z__2.r = b[i__3].r * e[i__4].r - b[i__3].i * e[i__4].i, z__2.i = b[i__3].r * e[i__4].i + b[i__3].i * e[i__4] .r; z__1.r = b[i__2].r - z__2.r, z__1.i = b[i__2].i - z__2.i; b[i__1].r = z__1.r, b[i__1].i = z__1.i; /* L40: */ } if (j < *nrhs) { ++j; goto L10; } } else { i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { /* Solve U' * x = b. */ i__2 = *n; for (i__ = 2; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); i__4 = b_subscr(i__, j); i__5 = b_subscr(i__ - 1, j); d_cnjg(&z__3, &e[i__ - 1]); z__2.r = b[i__5].r * z__3.r - b[i__5].i * z__3.i, z__2.i = b[i__5].r * z__3.i + b[i__5].i * z__3.r; z__1.r = b[i__4].r - z__2.r, z__1.i = b[i__4].i - z__2.i; b[i__3].r = z__1.r, b[i__3].i = z__1.i; /* L50: */ } /* Solve D * U * x = b. */ i__2 = b_subscr(*n, j); i__3 = b_subscr(*n, j); i__4 = *n; z__1.r = b[i__3].r / d__[i__4], z__1.i = b[i__3].i / d__[i__4] ; b[i__2].r = z__1.r, b[i__2].i = z__1.i; for (i__ = *n - 1; i__ >= 1; --i__) { i__2 = b_subscr(i__, j); i__3 = b_subscr(i__, j); i__4 = i__; z__2.r = b[i__3].r / d__[i__4], z__2.i = b[i__3].i / d__[ i__4]; i__5 = b_subscr(i__ + 1, j); i__6 = i__; z__3.r = b[i__5].r * e[i__6].r - b[i__5].i * e[i__6].i, z__3.i = b[i__5].r * e[i__6].i + b[i__5].i * e[ i__6].r; z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; b[i__2].r = z__1.r, b[i__2].i = z__1.i; /* L60: */ } /* L70: */ } } } else { /* Solve A * X = B using the factorization A = L*D*L', overwriting each right hand side vector with its solution. */ if (*nrhs <= 2) { j = 1; L80: /* Solve L * x = b. */ i__1 = *n; for (i__ = 2; i__ <= i__1; ++i__) { i__2 = b_subscr(i__, j); i__3 = b_subscr(i__, j); i__4 = b_subscr(i__ - 1, j); i__5 = i__ - 1; z__2.r = b[i__4].r * e[i__5].r - b[i__4].i * e[i__5].i, z__2.i = b[i__4].r * e[i__5].i + b[i__4].i * e[i__5] .r; z__1.r = b[i__3].r - z__2.r, z__1.i = b[i__3].i - z__2.i; b[i__2].r = z__1.r, b[i__2].i = z__1.i; /* L90: */ } /* Solve D * L' * x = b. */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = b_subscr(i__, j); i__3 = b_subscr(i__, j); i__4 = i__; z__1.r = b[i__3].r / d__[i__4], z__1.i = b[i__3].i / d__[i__4] ; b[i__2].r = z__1.r, b[i__2].i = z__1.i; /* L100: */ } for (i__ = *n - 1; i__ >= 1; --i__) { i__1 = b_subscr(i__, j); i__2 = b_subscr(i__, j); i__3 = b_subscr(i__ + 1, j); d_cnjg(&z__3, &e[i__]); z__2.r = b[i__3].r * z__3.r - b[i__3].i * z__3.i, z__2.i = b[ i__3].r * z__3.i + b[i__3].i * z__3.r; z__1.r = b[i__2].r - z__2.r, z__1.i = b[i__2].i - z__2.i; b[i__1].r = z__1.r, b[i__1].i = z__1.i; /* L110: */ } if (j < *nrhs) { ++j; goto L80; } } else { i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { /* Solve L * x = b. */ i__2 = *n; for (i__ = 2; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); i__4 = b_subscr(i__, j); i__5 = b_subscr(i__ - 1, j); i__6 = i__ - 1; z__2.r = b[i__5].r * e[i__6].r - b[i__5].i * e[i__6].i, z__2.i = b[i__5].r * e[i__6].i + b[i__5].i * e[ i__6].r; z__1.r = b[i__4].r - z__2.r, z__1.i = b[i__4].i - z__2.i; b[i__3].r = z__1.r, b[i__3].i = z__1.i; /* L120: */ } /* Solve D * L' * x = b. */ i__2 = b_subscr(*n, j); i__3 = b_subscr(*n, j); i__4 = *n; z__1.r = b[i__3].r / d__[i__4], z__1.i = b[i__3].i / d__[i__4] ; b[i__2].r = z__1.r, b[i__2].i = z__1.i; for (i__ = *n - 1; i__ >= 1; --i__) { i__2 = b_subscr(i__, j); i__3 = b_subscr(i__, j); i__4 = i__; z__2.r = b[i__3].r / d__[i__4], z__2.i = b[i__3].i / d__[ i__4]; i__5 = b_subscr(i__ + 1, j); d_cnjg(&z__4, &e[i__]); z__3.r = b[i__5].r * z__4.r - b[i__5].i * z__4.i, z__3.i = b[i__5].r * z__4.i + b[i__5].i * z__4.r; z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; b[i__2].r = z__1.r, b[i__2].i = z__1.i; /* L130: */ } /* L140: */ } } } return 0; /* End of ZPTTS2 */ } /* zptts2_ */