/* Subroutine */ int ssycon_(char *uplo, integer *n, real *a, integer *lda, integer *ipiv, real *anorm, real *rcond, real *work, integer *iwork, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University March 31, 1993 Purpose ======= SSYCON estimates the reciprocal of the condition number (in the 1-norm) of a real symmetric matrix A using the factorization A = U*D*U**T or A = L*D*L**T computed by SSYTRF. An estimate is obtained for norm(inv(A)), and the reciprocal of the condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). 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. A (input) REAL array, dimension (LDA,N) The block diagonal matrix D and the multipliers used to obtain the factor U or L as computed by SSYTRF. 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 SSYTRF. ANORM (input) REAL The 1-norm of the original matrix A. RCOND (output) REAL The reciprocal of the condition number of the matrix A, computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an estimate of the 1-norm of inv(A) computed in this routine. WORK (workspace) REAL array, dimension (2*N) IWORK (workspace) INTEGER 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 a_dim1, a_offset, i__1; /* Local variables */ static integer kase, i__; extern logical lsame_(char *, char *); static logical upper; extern /* Subroutine */ int xerbla_(char *, integer *), slacon_( integer *, real *, real *, integer *, real *, integer *); static real ainvnm; extern /* Subroutine */ int ssytrs_(char *, integer *, integer *, real *, integer *, integer *, real *, integer *, integer *); #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; --ipiv; --work; --iwork; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < max(1,*n)) { *info = -4; } else if (*anorm < 0.f) { *info = -6; } if (*info != 0) { i__1 = -(*info); xerbla_("SSYCON", &i__1); return 0; } /* Quick return if possible */ *rcond = 0.f; if (*n == 0) { *rcond = 1.f; return 0; } else if (*anorm <= 0.f) { return 0; } /* Check that the diagonal matrix D is nonsingular. */ if (upper) { /* Upper triangular storage: examine D from bottom to top */ for (i__ = *n; i__ >= 1; --i__) { if (ipiv[i__] > 0 && a_ref(i__, i__) == 0.f) { return 0; } /* L10: */ } } else { /* Lower triangular storage: examine D from top to bottom. */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (ipiv[i__] > 0 && a_ref(i__, i__) == 0.f) { return 0; } /* L20: */ } } /* Estimate the 1-norm of the inverse. */ kase = 0; L30: slacon_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase); if (kase != 0) { /* Multiply by inv(L*D*L') or inv(U*D*U'). */ ssytrs_(uplo, n, &c__1, &a[a_offset], lda, &ipiv[1], &work[1], n, info); goto L30; } /* Compute the estimate of the reciprocal condition number. */ if (ainvnm != 0.f) { *rcond = 1.f / ainvnm / *anorm; } return 0; /* End of SSYCON */ } /* ssycon_ */
/* Subroutine */ int stpcon_(char *norm, char *uplo, char *diag, integer *n, real *ap, real *rcond, real *work, integer *iwork, integer *info, ftnlen norm_len, ftnlen uplo_len, ftnlen diag_len) { /* System generated locals */ integer i__1; real r__1; /* Local variables */ static integer ix, kase, kase1; static real scale; extern logical lsame_(char *, char *, ftnlen, ftnlen); static real anorm; extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *); static logical upper; static real xnorm; extern doublereal slamch_(char *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slacon_( integer *, real *, real *, integer *, real *, integer *); extern integer isamax_(integer *, real *, integer *); static real ainvnm; static logical onenrm; extern doublereal slantp_(char *, char *, char *, integer *, real *, real *, ftnlen, ftnlen, ftnlen); static char normin[1]; extern /* Subroutine */ int slatps_(char *, char *, char *, char *, integer *, real *, real *, real *, real *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); static real smlnum; static logical nounit; /* -- LAPACK routine (version 3.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* March 31, 1993 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* STPCON estimates the reciprocal of the condition number of a packed */ /* triangular matrix A, in either the 1-norm or the infinity-norm. */ /* The norm of A is computed and an estimate is obtained for */ /* norm(inv(A)), then the reciprocal of the condition number is */ /* computed as */ /* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ /* Arguments */ /* ========= */ /* NORM (input) CHARACTER*1 */ /* Specifies whether the 1-norm condition number or the */ /* infinity-norm condition number is required: */ /* = '1' or 'O': 1-norm; */ /* = 'I': Infinity-norm. */ /* UPLO (input) CHARACTER*1 */ /* = 'U': A is upper triangular; */ /* = 'L': A is lower triangular. */ /* 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. */ /* AP (input) REAL 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. */ /* RCOND (output) REAL */ /* The reciprocal of the condition number of the matrix A, */ /* computed as RCOND = 1/(norm(A) * norm(inv(A))). */ /* WORK (workspace) REAL array, dimension (3*N) */ /* IWORK (workspace) INTEGER array, dimension (N) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ --iwork; --work; --ap; /* Function Body */ *info = 0; upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1); onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O", (ftnlen)1, ( ftnlen)1); nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1); if (! onenrm && ! lsame_(norm, "I", (ftnlen)1, (ftnlen)1)) { *info = -1; } else if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) { *info = -2; } else if (! nounit && ! lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) { *info = -3; } else if (*n < 0) { *info = -4; } if (*info != 0) { i__1 = -(*info); xerbla_("STPCON", &i__1, (ftnlen)6); return 0; } /* Quick return if possible */ if (*n == 0) { *rcond = 1.f; return 0; } *rcond = 0.f; smlnum = slamch_("Safe minimum", (ftnlen)12) * (real) max(1,*n); /* Compute the norm of the triangular matrix A. */ anorm = slantp_(norm, uplo, diag, n, &ap[1], &work[1], (ftnlen)1, (ftnlen) 1, (ftnlen)1); /* Continue only if ANORM > 0. */ if (anorm > 0.f) { /* Estimate the norm of the inverse of A. */ ainvnm = 0.f; *(unsigned char *)normin = 'N'; if (onenrm) { kase1 = 1; } else { kase1 = 2; } kase = 0; L10: slacon_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase); if (kase != 0) { if (kase == kase1) { /* Multiply by inv(A). */ slatps_(uplo, "No transpose", diag, normin, n, &ap[1], &work[ 1], &scale, &work[(*n << 1) + 1], info, (ftnlen)1, ( ftnlen)12, (ftnlen)1, (ftnlen)1); } else { /* Multiply by inv(A'). */ slatps_(uplo, "Transpose", diag, normin, n, &ap[1], &work[1], &scale, &work[(*n << 1) + 1], info, (ftnlen)1, ( ftnlen)9, (ftnlen)1, (ftnlen)1); } *(unsigned char *)normin = 'Y'; /* Multiply by 1/SCALE if doing so will not cause overflow. */ if (scale != 1.f) { ix = isamax_(n, &work[1], &c__1); xnorm = (r__1 = work[ix], dabs(r__1)); if (scale < xnorm * smlnum || scale == 0.f) { goto L20; } srscl_(n, &scale, &work[1], &c__1); } goto L10; } /* Compute the estimate of the reciprocal condition number. */ if (ainvnm != 0.f) { *rcond = 1.f / anorm / ainvnm; } } L20: return 0; /* End of STPCON */ } /* stpcon_ */
/* Subroutine */ int sgerfs_(char *trans, integer *n, integer *nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv, real *b, integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real * work, integer *iwork, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= SGERFS 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 = 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) REAL 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) REAL array, dimension (LDAF,N) The factors L and U from the factorization A = P*L*U as computed by SGETRF. LDAF (input) INTEGER The leading dimension of the array AF. LDAF >= max(1,N). IPIV (input) INTEGER array, dimension (N) The pivot indices from SGETRF; for 1<=i<=N, row i of the matrix was interchanged with row IPIV(i). B (input) REAL 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) REAL array, dimension (LDX,NRHS) On entry, the solution matrix X, as computed by SGETRS. 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) REAL array, dimension (3*N) IWORK (workspace) INTEGER 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_b15 = -1.f; static real c_b17 = 1.f; /* 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; real r__1, r__2, r__3; /* 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 sgemv_(char *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *); static integer count; extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, integer *), saxpy_(integer *, real *, real *, integer *, real *, integer *); static real xk; extern doublereal slamch_(char *); static integer nz; static real safmin; extern /* Subroutine */ int xerbla_(char *, integer *), slacon_( integer *, real *, real *, integer *, real *, integer *); static logical notran; extern /* Subroutine */ int sgetrs_(char *, integer *, integer *, real *, integer *, integer *, real *, integer *, integer *); static char transt[1]; static real lstres, eps; #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] #define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1] #define x_ref(a_1,a_2) x[(a_2)*x_dim1 + a_1] 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; --iwork; /* 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_("SGERFS", &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 *)transt = 'T'; } else { *(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) { 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. */ scopy_(n, &b_ref(1, j), &c__1, &work[*n + 1], &c__1); sgemv_(trans, n, n, &c_b15, &a[a_offset], lda, &x_ref(1, j), &c__1, & c_b17, &work[*n + 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__) { work[i__] = (r__1 = b_ref(i__, j), dabs(r__1)); /* L30: */ } /* Compute abs(op(A))*abs(X) + abs(B). */ if (notran) { i__2 = *n; for (k = 1; k <= i__2; ++k) { xk = (r__1 = x_ref(k, j), dabs(r__1)); i__3 = *n; for (i__ = 1; i__ <= i__3; ++i__) { work[i__] += (r__1 = a_ref(i__, k), dabs(r__1)) * xk; /* L40: */ } /* L50: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { s = 0.f; i__3 = *n; for (i__ = 1; i__ <= i__3; ++i__) { s += (r__1 = a_ref(i__, k), dabs(r__1)) * (r__2 = x_ref( i__, j), dabs(r__2)); /* L60: */ } work[k] += s; /* L70: */ } } s = 0.f; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { if (work[i__] > safe2) { /* Computing MAX */ r__2 = s, r__3 = (r__1 = work[*n + i__], dabs(r__1)) / work[ i__]; s = dmax(r__2,r__3); } else { /* Computing MAX */ r__2 = s, r__3 = ((r__1 = work[*n + i__], dabs(r__1)) + safe1) / (work[i__] + safe1); s = dmax(r__2,r__3); } /* 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. */ sgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[*n + 1], n, info); saxpy_(n, &c_b17, &work[*n + 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 SLACON 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 (work[i__] > safe2) { work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps * work[i__]; } else { work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps * work[i__] + safe1; } /* L90: */ } kase = 0; L100: slacon_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & kase); if (kase != 0) { if (kase == 1) { /* Multiply by diag(W)*inv(op(A)**T). */ sgetrs_(transt, n, &c__1, &af[af_offset], ldaf, &ipiv[1], & work[*n + 1], n, info); i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { work[*n + i__] = work[i__] * work[*n + i__]; /* L110: */ } } else { /* Multiply by inv(op(A))*diag(W). */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { work[*n + i__] = work[i__] * work[*n + i__]; /* L120: */ } sgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], & work[*n + 1], n, info); } goto L100; } /* Normalize error. */ lstres = 0.f; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = lstres, r__3 = (r__1 = x_ref(i__, j), dabs(r__1)); lstres = dmax(r__2,r__3); /* L130: */ } if (lstres != 0.f) { ferr[j] /= lstres; } /* L140: */ } return 0; /* End of SGERFS */ } /* sgerfs_ */
/* Subroutine */ int spprfs_(char *uplo, integer *n, integer *nrhs, real *ap, real *afp, real *b, integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real *work, integer *iwork, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= SPPRFS improves the computed solution to a system of linear equations when the coefficient matrix is symmetric positive definite 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) REAL 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)*(2n-j)/2) = A(i,j) for j<=i<=n. AFP (input) REAL array, dimension (N*(N+1)/2) The triangular factor U or L from the Cholesky factorization A = U**T*U or A = L*L**T, as computed by SPPTRF/CPPTRF, packed columnwise in a linear array in the same format as A (see AP). B (input) REAL 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) REAL array, dimension (LDX,NRHS) On entry, the solution matrix X, as computed by SPPTRS. 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) REAL array, dimension (3*N) IWORK (workspace) INTEGER 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_b12 = -1.f; static real c_b14 = 1.f; /* System generated locals */ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3; real r__1, r__2, r__3; /* Local variables */ static integer kase; static real safe1, safe2; static integer i__, j, k; static real s; extern logical lsame_(char *, char *); static integer count; static logical upper; extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, integer *), saxpy_(integer *, real *, real *, integer *, real *, integer *), sspmv_(char *, integer *, real *, real *, real *, integer *, real *, real *, integer *); static integer ik, kk; static real xk; extern doublereal slamch_(char *); static integer nz; static real safmin; extern /* Subroutine */ int xerbla_(char *, integer *), slacon_( integer *, real *, real *, integer *, real *, integer *); static real lstres; extern /* Subroutine */ int spptrs_(char *, integer *, integer *, real *, real *, integer *, integer *); static real eps; #define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1] #define x_ref(a_1,a_2) x[(a_2)*x_dim1 + a_1] --ap; --afp; 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; --iwork; /* 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 = -7; } else if (*ldx < max(1,*n)) { *info = -9; } if (*info != 0) { i__1 = -(*info); xerbla_("SPPRFS", &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 */ scopy_(n, &b_ref(1, j), &c__1, &work[*n + 1], &c__1); sspmv_(uplo, n, &c_b12, &ap[1], &x_ref(1, j), &c__1, &c_b14, &work[*n + 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__) { work[i__] = (r__1 = b_ref(i__, j), dabs(r__1)); /* 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; xk = (r__1 = x_ref(k, j), dabs(r__1)); ik = kk; i__3 = k - 1; for (i__ = 1; i__ <= i__3; ++i__) { work[i__] += (r__1 = ap[ik], dabs(r__1)) * xk; s += (r__1 = ap[ik], dabs(r__1)) * (r__2 = x_ref(i__, j), dabs(r__2)); ++ik; /* L40: */ } work[k] = work[k] + (r__1 = ap[kk + k - 1], dabs(r__1)) * xk + s; kk += k; /* L50: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { s = 0.f; xk = (r__1 = x_ref(k, j), dabs(r__1)); work[k] += (r__1 = ap[kk], dabs(r__1)) * xk; ik = kk + 1; i__3 = *n; for (i__ = k + 1; i__ <= i__3; ++i__) { work[i__] += (r__1 = ap[ik], dabs(r__1)) * xk; s += (r__1 = ap[ik], dabs(r__1)) * (r__2 = x_ref(i__, j), dabs(r__2)); ++ik; /* L60: */ } work[k] += s; kk += *n - k + 1; /* L70: */ } } s = 0.f; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { if (work[i__] > safe2) { /* Computing MAX */ r__2 = s, r__3 = (r__1 = work[*n + i__], dabs(r__1)) / work[ i__]; s = dmax(r__2,r__3); } else { /* Computing MAX */ r__2 = s, r__3 = ((r__1 = work[*n + i__], dabs(r__1)) + safe1) / (work[i__] + safe1); s = dmax(r__2,r__3); } /* 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. */ spptrs_(uplo, n, &c__1, &afp[1], &work[*n + 1], n, info); saxpy_(n, &c_b14, &work[*n + 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 SLACON 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 (work[i__] > safe2) { work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps * work[i__]; } else { work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps * work[i__] + safe1; } /* L90: */ } kase = 0; L100: slacon_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & kase); if (kase != 0) { if (kase == 1) { /* Multiply by diag(W)*inv(A'). */ spptrs_(uplo, n, &c__1, &afp[1], &work[*n + 1], n, info); i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { work[*n + i__] = work[i__] * work[*n + i__]; /* L110: */ } } else if (kase == 2) { /* Multiply by inv(A)*diag(W). */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { work[*n + i__] = work[i__] * work[*n + i__]; /* L120: */ } spptrs_(uplo, n, &c__1, &afp[1], &work[*n + 1], n, info); } goto L100; } /* Normalize error. */ lstres = 0.f; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = lstres, r__3 = (r__1 = x_ref(i__, j), dabs(r__1)); lstres = dmax(r__2,r__3); /* L130: */ } if (lstres != 0.f) { ferr[j] /= lstres; } /* L140: */ } return 0; /* End of SPPRFS */ } /* spprfs_ */
/* Subroutine */ int sgecon_(char *norm, integer *n, real *a, integer *lda, real *anorm, real *rcond, real *work, integer *iwork, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University February 29, 1992 Purpose ======= SGECON estimates the reciprocal of the condition number of a general real matrix A, in either the 1-norm or the infinity-norm, using the LU factorization computed by SGETRF. An estimate is obtained for norm(inv(A)), and the reciprocal of the condition number is computed as RCOND = 1 / ( norm(A) * norm(inv(A)) ). Arguments ========= NORM (input) CHARACTER*1 Specifies whether the 1-norm condition number or the infinity-norm condition number is required: = '1' or 'O': 1-norm; = 'I': Infinity-norm. N (input) INTEGER The order of the matrix A. N >= 0. A (input) REAL array, dimension (LDA,N) The factors L and U from the factorization A = P*L*U as computed by SGETRF. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,N). ANORM (input) REAL If NORM = '1' or 'O', the 1-norm of the original matrix A. If NORM = 'I', the infinity-norm of the original matrix A. RCOND (output) REAL The reciprocal of the condition number of the matrix A, computed as RCOND = 1/(norm(A) * norm(inv(A))). WORK (workspace) REAL array, dimension (4*N) IWORK (workspace) INTEGER 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 a_dim1, a_offset, i__1; real r__1; /* Local variables */ static integer kase, kase1; static real scale; extern logical lsame_(char *, char *); extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *); static real sl; static integer ix; extern doublereal slamch_(char *); static real su; extern /* Subroutine */ int xerbla_(char *, integer *), slacon_( integer *, real *, real *, integer *, real *, integer *); extern integer isamax_(integer *, real *, integer *); static real ainvnm; static logical onenrm; static char normin[1]; extern /* Subroutine */ int slatrs_(char *, char *, char *, char *, integer *, real *, integer *, real *, real *, real *, integer *); static real smlnum; a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; --work; --iwork; /* Function Body */ *info = 0; onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); if (! onenrm && ! lsame_(norm, "I")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < max(1,*n)) { *info = -4; } else if (*anorm < 0.f) { *info = -5; } if (*info != 0) { i__1 = -(*info); xerbla_("SGECON", &i__1); return 0; } /* Quick return if possible */ *rcond = 0.f; if (*n == 0) { *rcond = 1.f; return 0; } else if (*anorm == 0.f) { return 0; } smlnum = slamch_("Safe minimum"); /* Estimate the norm of inv(A). */ ainvnm = 0.f; *(unsigned char *)normin = 'N'; if (onenrm) { kase1 = 1; } else { kase1 = 2; } kase = 0; L10: slacon_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase); if (kase != 0) { if (kase == kase1) { /* Multiply by inv(L). */ slatrs_("Lower", "No transpose", "Unit", normin, n, &a[a_offset], lda, &work[1], &sl, &work[(*n << 1) + 1], info); /* Multiply by inv(U). */ slatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[ a_offset], lda, &work[1], &su, &work[*n * 3 + 1], info); } else { /* Multiply by inv(U'). */ slatrs_("Upper", "Transpose", "Non-unit", normin, n, &a[a_offset], lda, &work[1], &su, &work[*n * 3 + 1], info); /* Multiply by inv(L'). */ slatrs_("Lower", "Transpose", "Unit", normin, n, &a[a_offset], lda, &work[1], &sl, &work[(*n << 1) + 1], info); } /* Divide X by 1/(SL*SU) if doing so will not cause overflow. */ scale = sl * su; *(unsigned char *)normin = 'Y'; if (scale != 1.f) { ix = isamax_(n, &work[1], &c__1); if (scale < (r__1 = work[ix], dabs(r__1)) * smlnum || scale == 0.f) { goto L20; } srscl_(n, &scale, &work[1], &c__1); } goto L10; } /* Compute the estimate of the reciprocal condition number. */ if (ainvnm != 0.f) { *rcond = 1.f / ainvnm / *anorm; } L20: return 0; /* End of SGECON */ } /* sgecon_ */
/* Subroutine */ int spocon_(char *uplo, integer *n, real *a, integer *lda, real *anorm, real *rcond, real *work, integer *iwork, integer *info) { /* -- LAPACK routine (version 2.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University March 31, 1993 Purpose ======= SPOCON estimates the reciprocal of the condition number (in the 1-norm) of a real symmetric positive definite matrix using the Cholesky factorization A = U**T*U or A = L*L**T computed by SPOTRF. An estimate is obtained for norm(inv(A)), and the reciprocal of the condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). 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. A (input) REAL array, dimension (LDA,N) The triangular factor U or L from the Cholesky factorization A = U**T*U or A = L*L**T, as computed by SPOTRF. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,N). ANORM (input) REAL The 1-norm (or infinity-norm) of the symmetric matrix A. RCOND (output) REAL The reciprocal of the condition number of the matrix A, computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an estimate of the 1-norm of inv(A) computed in this routine. WORK (workspace) REAL array, dimension (3*N) IWORK (workspace) INTEGER 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 Function Body */ /* Table of constant values */ static integer c__1 = 1; /* System generated locals */ integer a_dim1, a_offset, i__1; real r__1; /* Local variables */ static integer kase; static real scale; extern logical lsame_(char *, char *); extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *); static logical upper; static integer ix; static real scalel; extern doublereal slamch_(char *); static real scaleu; extern /* Subroutine */ int xerbla_(char *, integer *), slacon_( integer *, real *, real *, integer *, real *, integer *); extern integer isamax_(integer *, real *, integer *); static real ainvnm; static char normin[1]; extern /* Subroutine */ int slatrs_(char *, char *, char *, char *, integer *, real *, integer *, real *, real *, real *, integer *); static real smlnum; #define WORK(I) work[(I)-1] #define IWORK(I) iwork[(I)-1] #define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)] *info = 0; upper = lsame_(uplo, "U"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < max(1,*n)) { *info = -4; } else if (*anorm < 0.f) { *info = -5; } if (*info != 0) { i__1 = -(*info); xerbla_("SPOCON", &i__1); return 0; } /* Quick return if possible */ *rcond = 0.f; if (*n == 0) { *rcond = 1.f; return 0; } else if (*anorm == 0.f) { return 0; } smlnum = slamch_("Safe minimum"); /* Estimate the 1-norm of inv(A). */ kase = 0; *(unsigned char *)normin = 'N'; L10: slacon_(n, &WORK(*n + 1), &WORK(1), &IWORK(1), &ainvnm, &kase); if (kase != 0) { if (upper) { /* Multiply by inv(U'). */ slatrs_("Upper", "Transpose", "Non-unit", normin, n, &A(1,1), lda, &WORK(1), &scalel, &WORK((*n << 1) + 1), info); *(unsigned char *)normin = 'Y'; /* Multiply by inv(U). */ slatrs_("Upper", "No transpose", "Non-unit", normin, n, &A(1,1), lda, &WORK(1), &scaleu, &WORK((*n << 1) + 1), info); } else { /* Multiply by inv(L). */ slatrs_("Lower", "No transpose", "Non-unit", normin, n, &A(1,1), lda, &WORK(1), &scalel, &WORK((*n << 1) + 1), info); *(unsigned char *)normin = 'Y'; /* Multiply by inv(L'). */ slatrs_("Lower", "Transpose", "Non-unit", normin, n, &A(1,1), lda, &WORK(1), &scaleu, &WORK((*n << 1) + 1), info); } /* Multiply by 1/SCALE if doing so will not cause overflow. */ scale = scalel * scaleu; if (scale != 1.f) { ix = isamax_(n, &WORK(1), &c__1); if (scale < (r__1 = WORK(ix), dabs(r__1)) * smlnum || scale == 0.f) { goto L20; } srscl_(n, &scale, &WORK(1), &c__1); } goto L10; } /* Compute the estimate of the reciprocal condition number. */ if (ainvnm != 0.f) { *rcond = 1.f / ainvnm / *anorm; } L20: return 0; /* End of SPOCON */ } /* spocon_ */
/* Subroutine */ int strcon_(char *norm, char *uplo, char *diag, integer *n, real *a, integer *lda, real *rcond, real *work, integer *iwork, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University March 31, 1993 Purpose ======= STRCON estimates the reciprocal of the condition number of a triangular matrix A, in either the 1-norm or the infinity-norm. The norm of A is computed and an estimate is obtained for norm(inv(A)), then the reciprocal of the condition number is computed as RCOND = 1 / ( norm(A) * norm(inv(A)) ). Arguments ========= NORM (input) CHARACTER*1 Specifies whether the 1-norm condition number or the infinity-norm condition number is required: = '1' or 'O': 1-norm; = 'I': Infinity-norm. UPLO (input) CHARACTER*1 = 'U': A is upper triangular; = 'L': A is lower triangular. 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. A (input) REAL 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). RCOND (output) REAL The reciprocal of the condition number of the matrix A, computed as RCOND = 1/(norm(A) * norm(inv(A))). WORK (workspace) REAL array, dimension (3*N) IWORK (workspace) INTEGER 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 a_dim1, a_offset, i__1; real r__1; /* Local variables */ static integer kase, kase1; static real scale; extern logical lsame_(char *, char *); static real anorm; extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *); static logical upper; static real xnorm; static integer ix; extern doublereal slamch_(char *); extern /* Subroutine */ int xerbla_(char *, integer *), slacon_( integer *, real *, real *, integer *, real *, integer *); extern integer isamax_(integer *, real *, integer *); static real ainvnm; static logical onenrm; static char normin[1]; extern doublereal slantr_(char *, char *, char *, integer *, integer *, real *, integer *, real *); extern /* Subroutine */ int slatrs_(char *, char *, char *, char *, integer *, real *, integer *, real *, real *, real *, integer *); static real smlnum; static logical nounit; a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; --work; --iwork; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); nounit = lsame_(diag, "N"); if (! onenrm && ! lsame_(norm, "I")) { *info = -1; } else if (! upper && ! lsame_(uplo, "L")) { *info = -2; } else if (! nounit && ! lsame_(diag, "U")) { *info = -3; } else if (*n < 0) { *info = -4; } else if (*lda < max(1,*n)) { *info = -6; } if (*info != 0) { i__1 = -(*info); xerbla_("STRCON", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { *rcond = 1.f; return 0; } *rcond = 0.f; smlnum = slamch_("Safe minimum") * (real) max(1,*n); /* Compute the norm of the triangular matrix A. */ anorm = slantr_(norm, uplo, diag, n, n, &a[a_offset], lda, &work[1]); /* Continue only if ANORM > 0. */ if (anorm > 0.f) { /* Estimate the norm of the inverse of A. */ ainvnm = 0.f; *(unsigned char *)normin = 'N'; if (onenrm) { kase1 = 1; } else { kase1 = 2; } kase = 0; L10: slacon_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase); if (kase != 0) { if (kase == kase1) { /* Multiply by inv(A). */ slatrs_(uplo, "No transpose", diag, normin, n, &a[a_offset], lda, &work[1], &scale, &work[(*n << 1) + 1], info); } else { /* Multiply by inv(A'). */ slatrs_(uplo, "Transpose", diag, normin, n, &a[a_offset], lda, &work[1], &scale, &work[(*n << 1) + 1], info); } *(unsigned char *)normin = 'Y'; /* Multiply by 1/SCALE if doing so will not cause overflow. */ if (scale != 1.f) { ix = isamax_(n, &work[1], &c__1); xnorm = (r__1 = work[ix], dabs(r__1)); if (scale < xnorm * smlnum || scale == 0.f) { goto L20; } srscl_(n, &scale, &work[1], &c__1); } goto L10; } /* Compute the estimate of the reciprocal condition number. */ if (ainvnm != 0.f) { *rcond = 1.f / anorm / ainvnm; } } L20: return 0; /* End of STRCON */ } /* strcon_ */
/* Subroutine */ int ssyrfs_(char *uplo, integer *n, integer *nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv, real *b, integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real * work, integer *iwork, integer *info) { /* -- LAPACK routine (version 2.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= SSYRFS improves the computed solution to a system of linear equations when the coefficient matrix is symmetric indefinite, 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. A (input) REAL array, dimension (LDA,N) The symmetric 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. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,N). AF (input) REAL array, dimension (LDAF,N) The factored form of the matrix A. AF 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 SSYTRF. LDAF (input) INTEGER The leading dimension of the array AF. LDAF >= max(1,N). IPIV (input) INTEGER array, dimension (N) Details of the interchanges and the block structure of D as determined by SSYTRF. B (input) REAL 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) REAL array, dimension (LDX,NRHS) On entry, the solution matrix X, as computed by SSYTRS. 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) REAL array, dimension (3*N) IWORK (workspace) INTEGER 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 Function Body */ /* Table of constant values */ static integer c__1 = 1; static real c_b12 = -1.f; static real c_b14 = 1.f; /* 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; real r__1, r__2, r__3; /* Local variables */ static integer kase; static real safe1, safe2; static integer i, j, k; static real s; extern logical lsame_(char *, char *); static integer count; static logical upper; extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, integer *), saxpy_(integer *, real *, real *, integer *, real *, integer *), ssymv_(char *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *); static real xk; extern doublereal slamch_(char *); static integer nz; static real safmin; extern /* Subroutine */ int xerbla_(char *, integer *), slacon_( integer *, real *, real *, integer *, real *, integer *); static real lstres; extern /* Subroutine */ int ssytrs_(char *, integer *, integer *, real *, integer *, integer *, real *, integer *, integer *); static real eps; #define IPIV(I) ipiv[(I)-1] #define FERR(I) ferr[(I)-1] #define BERR(I) berr[(I)-1] #define WORK(I) work[(I)-1] #define IWORK(I) iwork[(I)-1] #define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)] #define AF(I,J) af[(I)-1 + ((J)-1)* ( *ldaf)] #define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)] #define X(I,J) x[(I)-1 + ((J)-1)* ( *ldx)] *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 (*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_("SSYRFS", &i__1); return 0; } /* Quick return if possible */ if (*n == 0 || *nrhs == 0) { i__1 = *nrhs; for (j = 1; j <= *nrhs; ++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 <= *nrhs; ++j) { count = 1; lstres = 3.f; L20: /* Loop until stopping criterion is satisfied. Compute residual R = B - A * X */ scopy_(n, &B(1,j), &c__1, &WORK(*n + 1), &c__1); ssymv_(uplo, n, &c_b12, &A(1,1), lda, &X(1,j), &c__1, &c_b14, &WORK(*n + 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 matr ix or vector Z. If the i-th component of the denominator is le ss than SAFE2, then SAFE1 is added to the i-th components of th e numerator and denominator before dividing. */ i__2 = *n; for (i = 1; i <= *n; ++i) { WORK(i) = (r__1 = B(i,j), dabs(r__1)); /* L30: */ } /* Compute abs(A)*abs(X) + abs(B). */ if (upper) { i__2 = *n; for (k = 1; k <= *n; ++k) { s = 0.f; xk = (r__1 = X(k,j), dabs(r__1)); i__3 = k - 1; for (i = 1; i <= k-1; ++i) { WORK(i) += (r__1 = A(i,k), dabs(r__1)) * xk; s += (r__1 = A(i,k), dabs(r__1)) * (r__2 = X(i,j), dabs(r__2)); /* L40: */ } WORK(k) = WORK(k) + (r__1 = A(k,k), dabs(r__1)) * xk + s; /* L50: */ } } else { i__2 = *n; for (k = 1; k <= *n; ++k) { s = 0.f; xk = (r__1 = X(k,j), dabs(r__1)); WORK(k) += (r__1 = A(k,k), dabs(r__1)) * xk; i__3 = *n; for (i = k + 1; i <= *n; ++i) { WORK(i) += (r__1 = A(i,k), dabs(r__1)) * xk; s += (r__1 = A(i,k), dabs(r__1)) * (r__2 = X(i,j), dabs(r__2)); /* L60: */ } WORK(k) += s; /* L70: */ } } s = 0.f; i__2 = *n; for (i = 1; i <= *n; ++i) { if (WORK(i) > safe2) { /* Computing MAX */ r__2 = s, r__3 = (r__1 = WORK(*n + i), dabs(r__1)) / WORK(i); s = dmax(r__2,r__3); } else { /* Computing MAX */ r__2 = s, r__3 = ((r__1 = WORK(*n + i), dabs(r__1)) + safe1) / (WORK(i) + safe1); s = dmax(r__2,r__3); } /* L80: */ } BERR(j) = s; /* Test stopping criterion. Continue iterating if 1) The residual BERR(J) is larger than machine epsilon, a nd 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. */ ssytrs_(uplo, n, &c__1, &AF(1,1), ldaf, &IPIV(1), &WORK(*n + 1), n, info); saxpy_(n, &c_b14, &WORK(*n + 1), &c__1, &X(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 o r 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 SLACON 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 <= *n; ++i) { if (WORK(i) > safe2) { WORK(i) = (r__1 = WORK(*n + i), dabs(r__1)) + nz * eps * WORK( i); } else { WORK(i) = (r__1 = WORK(*n + i), dabs(r__1)) + nz * eps * WORK( i) + safe1; } /* L90: */ } kase = 0; L100: slacon_(n, &WORK((*n << 1) + 1), &WORK(*n + 1), &IWORK(1), &FERR(j), & kase); if (kase != 0) { if (kase == 1) { /* Multiply by diag(W)*inv(A'). */ ssytrs_(uplo, n, &c__1, &AF(1,1), ldaf, &IPIV(1), &WORK( *n + 1), n, info); i__2 = *n; for (i = 1; i <= *n; ++i) { WORK(*n + i) = WORK(i) * WORK(*n + i); /* L110: */ } } else if (kase == 2) { /* Multiply by inv(A)*diag(W). */ i__2 = *n; for (i = 1; i <= *n; ++i) { WORK(*n + i) = WORK(i) * WORK(*n + i); /* L120: */ } ssytrs_(uplo, n, &c__1, &AF(1,1), ldaf, &IPIV(1), &WORK( *n + 1), n, info); } goto L100; } /* Normalize error. */ lstres = 0.f; i__2 = *n; for (i = 1; i <= *n; ++i) { /* Computing MAX */ r__2 = lstres, r__3 = (r__1 = X(i,j), dabs(r__1)); lstres = dmax(r__2,r__3); /* L130: */ } if (lstres != 0.f) { FERR(j) /= lstres; } /* L140: */ } return 0; /* End of SSYRFS */ } /* ssyrfs_ */
/* Subroutine */ int spbrfs_(char *uplo, integer *n, integer *kd, integer * nrhs, real *ab, integer *ldab, real *afb, integer *ldafb, real *b, integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real * work, integer *iwork, integer *info, ftnlen uplo_len) { /* System generated locals */ integer ab_dim1, ab_offset, afb_dim1, afb_offset, 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; /* Local variables */ static integer i__, j, k, l; static real s, xk; static integer nz; static real eps; static integer kase; static real safe1, safe2; extern logical lsame_(char *, char *, ftnlen, ftnlen); static integer count; extern /* Subroutine */ int ssbmv_(char *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *, ftnlen); static logical upper; extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, integer *), saxpy_(integer *, real *, real *, integer *, real *, integer *); extern doublereal slamch_(char *, ftnlen); static real safmin; extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slacon_( integer *, real *, real *, integer *, real *, integer *); static real lstres; extern /* Subroutine */ int spbtrs_(char *, integer *, integer *, integer *, real *, integer *, real *, integer *, integer *, ftnlen); /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* SPBRFS improves the computed solution to a system of linear */ /* equations when the coefficient matrix is symmetric positive definite */ /* and banded, 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. */ /* KD (input) INTEGER */ /* The number of superdiagonals of the matrix A if UPLO = 'U', */ /* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ /* NRHS (input) INTEGER */ /* The number of right hand sides, i.e., the number of columns */ /* of the matrices B and X. NRHS >= 0. */ /* AB (input) REAL array, dimension (LDAB,N) */ /* The upper or lower triangle of the symmetric band matrix A, */ /* stored in the first KD+1 rows of the array. The j-th column */ /* of A is stored in the j-th column of the array AB as follows: */ /* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ /* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ /* LDAB (input) INTEGER */ /* The leading dimension of the array AB. LDAB >= KD+1. */ /* AFB (input) REAL array, dimension (LDAFB,N) */ /* The triangular factor U or L from the Cholesky factorization */ /* A = U**T*U or A = L*L**T of the band matrix A as computed by */ /* SPBTRF, in the same storage format as A (see AB). */ /* LDAFB (input) INTEGER */ /* The leading dimension of the array AFB. LDAFB >= KD+1. */ /* B (input) REAL 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) REAL array, dimension (LDX,NRHS) */ /* On entry, the solution matrix X, as computed by SPBTRS. */ /* 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) REAL array, dimension (3*N) */ /* IWORK (workspace) INTEGER 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. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ ab_dim1 = *ldab; ab_offset = 1 + ab_dim1; ab -= ab_offset; afb_dim1 = *ldafb; afb_offset = 1 + afb_dim1; afb -= afb_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; x_dim1 = *ldx; x_offset = 1 + x_dim1; x -= x_offset; --ferr; --berr; --work; --iwork; /* Function Body */ *info = 0; upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1); if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*kd < 0) { *info = -3; } else if (*nrhs < 0) { *info = -4; } else if (*ldab < *kd + 1) { *info = -6; } else if (*ldafb < *kd + 1) { *info = -8; } else if (*ldb < max(1,*n)) { *info = -10; } else if (*ldx < max(1,*n)) { *info = -12; } if (*info != 0) { i__1 = -(*info); xerbla_("SPBRFS", &i__1, (ftnlen)6); 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 */ /* Computing MIN */ i__1 = *n + 1, i__2 = (*kd << 1) + 2; nz = min(i__1,i__2); eps = slamch_("Epsilon", (ftnlen)7); safmin = slamch_("Safe minimum", (ftnlen)12); 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 */ scopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); ssbmv_(uplo, n, kd, &c_b12, &ab[ab_offset], ldab, &x[j * x_dim1 + 1], &c__1, &c_b14, &work[*n + 1], &c__1, (ftnlen)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__) { work[i__] = (r__1 = b[i__ + j * b_dim1], dabs(r__1)); /* L30: */ } /* Compute abs(A)*abs(X) + abs(B). */ if (upper) { i__2 = *n; for (k = 1; k <= i__2; ++k) { s = 0.f; xk = (r__1 = x[k + j * x_dim1], dabs(r__1)); l = *kd + 1 - k; /* Computing MAX */ i__3 = 1, i__4 = k - *kd; i__5 = k - 1; for (i__ = max(i__3,i__4); i__ <= i__5; ++i__) { work[i__] += (r__1 = ab[l + i__ + k * ab_dim1], dabs(r__1) ) * xk; s += (r__1 = ab[l + i__ + k * ab_dim1], dabs(r__1)) * ( r__2 = x[i__ + j * x_dim1], dabs(r__2)); /* L40: */ } work[k] = work[k] + (r__1 = ab[*kd + 1 + k * ab_dim1], dabs( r__1)) * xk + s; /* L50: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { s = 0.f; xk = (r__1 = x[k + j * x_dim1], dabs(r__1)); work[k] += (r__1 = ab[k * ab_dim1 + 1], dabs(r__1)) * xk; l = 1 - k; /* Computing MIN */ i__3 = *n, i__4 = k + *kd; i__5 = min(i__3,i__4); for (i__ = k + 1; i__ <= i__5; ++i__) { work[i__] += (r__1 = ab[l + i__ + k * ab_dim1], dabs(r__1) ) * xk; s += (r__1 = ab[l + i__ + k * ab_dim1], dabs(r__1)) * ( r__2 = x[i__ + j * x_dim1], dabs(r__2)); /* L60: */ } work[k] += s; /* L70: */ } } s = 0.f; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { if (work[i__] > safe2) { /* Computing MAX */ r__2 = s, r__3 = (r__1 = work[*n + i__], dabs(r__1)) / work[ i__]; s = dmax(r__2,r__3); } else { /* Computing MAX */ r__2 = s, r__3 = ((r__1 = work[*n + i__], dabs(r__1)) + safe1) / (work[i__] + safe1); s = dmax(r__2,r__3); } /* 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. */ spbtrs_(uplo, n, kd, &c__1, &afb[afb_offset], ldafb, &work[*n + 1] , n, info, (ftnlen)1); saxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &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 SLACON 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 (work[i__] > safe2) { work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps * work[i__]; } else { work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps * work[i__] + safe1; } /* L90: */ } kase = 0; L100: slacon_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & kase); if (kase != 0) { if (kase == 1) { /* Multiply by diag(W)*inv(A'). */ spbtrs_(uplo, n, kd, &c__1, &afb[afb_offset], ldafb, &work[*n + 1], n, info, (ftnlen)1); i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { work[*n + i__] *= work[i__]; /* L110: */ } } else if (kase == 2) { /* Multiply by inv(A)*diag(W). */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { work[*n + i__] *= work[i__]; /* L120: */ } spbtrs_(uplo, n, kd, &c__1, &afb[afb_offset], ldafb, &work[*n + 1], n, info, (ftnlen)1); } goto L100; } /* Normalize error. */ lstres = 0.f; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = lstres, r__3 = (r__1 = x[i__ + j * x_dim1], dabs(r__1)); lstres = dmax(r__2,r__3); /* L130: */ } if (lstres != 0.f) { ferr[j] /= lstres; } /* L140: */ } return 0; /* End of SPBRFS */ } /* spbrfs_ */
void sgsrfs(trans_t trans, SuperMatrix *A, SuperMatrix *L, SuperMatrix *U, int *perm_c, int *perm_r, char *equed, float *R, float *C, SuperMatrix *B, SuperMatrix *X, float *ferr, float *berr, SuperLUStat_t *stat, int *info) { /* * Purpose * ======= * * SGSRFS improves the computed solution to a system of linear * equations and provides error bounds and backward error estimates for * the solution. * * If equilibration was performed, the system becomes: * (diag(R)*A_original*diag(C)) * X = diag(R)*B_original. * * See supermatrix.h for the definition of 'SuperMatrix' structure. * * Arguments * ========= * * trans (input) trans_t * Specifies the form of the system of equations: * = NOTRANS: A * X = B (No transpose) * = TRANS: A'* X = B (Transpose) * = CONJ: A**H * X = B (Conjugate transpose) * * A (input) SuperMatrix* * The original matrix A in the system, or the scaled A if * equilibration was done. The type of A can be: * Stype = SLU_NC, Dtype = SLU_S, Mtype = SLU_GE. * * L (input) SuperMatrix* * The factor L from the factorization Pr*A*Pc=L*U. Use * compressed row subscripts storage for supernodes, * i.e., L has types: Stype = SLU_SC, Dtype = SLU_S, Mtype = SLU_TRLU. * * U (input) SuperMatrix* * The factor U from the factorization Pr*A*Pc=L*U as computed by * sgstrf(). Use column-wise storage scheme, * i.e., U has types: Stype = SLU_NC, Dtype = SLU_S, Mtype = SLU_TRU. * * perm_c (input) int*, dimension (A->ncol) * Column permutation vector, which defines the * permutation matrix Pc; perm_c[i] = j means column i of A is * in position j in A*Pc. * * perm_r (input) int*, dimension (A->nrow) * Row permutation vector, which defines the permutation matrix Pr; * perm_r[i] = j means row i of A is in position j in Pr*A. * * equed (input) Specifies the form of equilibration that was done. * = 'N': No equilibration. * = 'R': Row equilibration, i.e., A was premultiplied by diag(R). * = 'C': Column equilibration, i.e., A was postmultiplied by * diag(C). * = 'B': Both row and column equilibration, i.e., A was replaced * by diag(R)*A*diag(C). * * R (input) float*, dimension (A->nrow) * The row scale factors for A. * If equed = 'R' or 'B', A is premultiplied by diag(R). * If equed = 'N' or 'C', R is not accessed. * * C (input) float*, dimension (A->ncol) * The column scale factors for A. * If equed = 'C' or 'B', A is postmultiplied by diag(C). * If equed = 'N' or 'R', C is not accessed. * * B (input) SuperMatrix* * B has types: Stype = SLU_DN, Dtype = SLU_S, Mtype = SLU_GE. * The right hand side matrix B. * if equed = 'R' or 'B', B is premultiplied by diag(R). * * X (input/output) SuperMatrix* * X has types: Stype = SLU_DN, Dtype = SLU_S, Mtype = SLU_GE. * On entry, the solution matrix X, as computed by sgstrs(). * On exit, the improved solution matrix X. * if *equed = 'C' or 'B', X should be premultiplied by diag(C) * in order to obtain the solution to the original system. * * FERR (output) float*, dimension (B->ncol) * 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) float*, dimension (B->ncol) * 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). * * stat (output) SuperLUStat_t* * Record the statistics on runtime and floating-point operation count. * See util.h for the definition of 'SuperLUStat_t'. * * info (output) int* * = 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. * */ #define ITMAX 5 /* Table of constant values */ int ione = 1; float ndone = -1.; float done = 1.; /* Local variables */ NCformat *Astore; float *Aval; SuperMatrix Bjcol; DNformat *Bstore, *Xstore, *Bjcol_store; float *Bmat, *Xmat, *Bptr, *Xptr; int kase; float safe1, safe2; int i, j, k, irow, nz, count, notran, rowequ, colequ; int ldb, ldx, nrhs; float s, xk, lstres, eps, safmin; char transc[1]; trans_t transt; float *work; float *rwork; int *iwork; extern double slamch_(char *); extern int slacon_(int *, float *, float *, int *, float *, int *); #ifdef _CRAY extern int SCOPY(int *, float *, int *, float *, int *); extern int SSAXPY(int *, float *, float *, int *, float *, int *); #else extern int scopy_(int *, float *, int *, float *, int *); extern int saxpy_(int *, float *, float *, int *, float *, int *); #endif Astore = A->Store; Aval = Astore->nzval; Bstore = B->Store; Xstore = X->Store; Bmat = Bstore->nzval; Xmat = Xstore->nzval; ldb = Bstore->lda; ldx = Xstore->lda; nrhs = B->ncol; /* Test the input parameters */ *info = 0; notran = (trans == NOTRANS); if ( !notran && trans != TRANS && trans != CONJ ) *info = -1; else if ( A->nrow != A->ncol || A->nrow < 0 || A->Stype != SLU_NC || A->Dtype != SLU_S || A->Mtype != SLU_GE ) *info = -2; else if ( L->nrow != L->ncol || L->nrow < 0 || L->Stype != SLU_SC || L->Dtype != SLU_S || L->Mtype != SLU_TRLU ) *info = -3; else if ( U->nrow != U->ncol || U->nrow < 0 || U->Stype != SLU_NC || U->Dtype != SLU_S || U->Mtype != SLU_TRU ) *info = -4; else if ( ldb < SUPERLU_MAX(0, A->nrow) || B->Stype != SLU_DN || B->Dtype != SLU_S || B->Mtype != SLU_GE ) *info = -10; else if ( ldx < SUPERLU_MAX(0, A->nrow) || X->Stype != SLU_DN || X->Dtype != SLU_S || X->Mtype != SLU_GE ) *info = -11; if (*info != 0) { i = -(*info); xerbla_("sgsrfs", &i); return; } /* Quick return if possible */ if ( A->nrow == 0 || nrhs == 0) { for (j = 0; j < nrhs; ++j) { ferr[j] = 0.; berr[j] = 0.; } return; } rowequ = lsame_(equed, "R") || lsame_(equed, "B"); colequ = lsame_(equed, "C") || lsame_(equed, "B"); /* Allocate working space */ work = floatMalloc(2*A->nrow); rwork = (float *) SUPERLU_MALLOC( A->nrow * sizeof(float) ); iwork = intMalloc(2*A->nrow); if ( !work || !rwork || !iwork ) ABORT("Malloc fails for work/rwork/iwork."); if ( notran ) { *(unsigned char *)transc = 'N'; transt = TRANS; } else { *(unsigned char *)transc = 'T'; transt = NOTRANS; } /* NZ = maximum number of nonzero elements in each row of A, plus 1 */ nz = A->ncol + 1; eps = slamch_("Epsilon"); safmin = slamch_("Safe minimum"); safe1 = nz * safmin; safe2 = safe1 / eps; /* Compute the number of nonzeros in each row (or column) of A */ for (i = 0; i < A->nrow; ++i) iwork[i] = 0; if ( notran ) { for (k = 0; k < A->ncol; ++k) for (i = Astore->colptr[k]; i < Astore->colptr[k+1]; ++i) ++iwork[Astore->rowind[i]]; } else { for (k = 0; k < A->ncol; ++k) iwork[k] = Astore->colptr[k+1] - Astore->colptr[k]; } /* Copy one column of RHS B into Bjcol. */ Bjcol.Stype = B->Stype; Bjcol.Dtype = B->Dtype; Bjcol.Mtype = B->Mtype; Bjcol.nrow = B->nrow; Bjcol.ncol = 1; Bjcol.Store = (void *) SUPERLU_MALLOC( sizeof(DNformat) ); if ( !Bjcol.Store ) ABORT("SUPERLU_MALLOC fails for Bjcol.Store"); Bjcol_store = Bjcol.Store; Bjcol_store->lda = ldb; Bjcol_store->nzval = work; /* address aliasing */ /* Do for each right hand side ... */ for (j = 0; j < nrhs; ++j) { count = 0; lstres = 3.; Bptr = &Bmat[j*ldb]; Xptr = &Xmat[j*ldx]; while (1) { /* 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. */ #ifdef _CRAY SCOPY(&A->nrow, Bptr, &ione, work, &ione); #else scopy_(&A->nrow, Bptr, &ione, work, &ione); #endif sp_sgemv(transc, ndone, A, Xptr, ione, done, work, ione); /* 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 component of the numerator and denominator before dividing. */ for (i = 0; i < A->nrow; ++i) rwork[i] = fabs( Bptr[i] ); /* Compute abs(op(A))*abs(X) + abs(B). */ if (notran) { for (k = 0; k < A->ncol; ++k) { xk = fabs( Xptr[k] ); for (i = Astore->colptr[k]; i < Astore->colptr[k+1]; ++i) rwork[Astore->rowind[i]] += fabs(Aval[i]) * xk; } } else { for (k = 0; k < A->ncol; ++k) { s = 0.; for (i = Astore->colptr[k]; i < Astore->colptr[k+1]; ++i) { irow = Astore->rowind[i]; s += fabs(Aval[i]) * fabs(Xptr[irow]); } rwork[k] += s; } } s = 0.; for (i = 0; i < A->nrow; ++i) { if (rwork[i] > safe2) s = SUPERLU_MAX( s, fabs(work[i]) / rwork[i] ); else s = SUPERLU_MAX( s, (fabs(work[i]) + safe1) / (rwork[i] + safe1) ); } 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 < ITMAX) { /* Update solution and try again. */ sgstrs (trans, L, U, perm_c, perm_r, &Bjcol, stat, info); #ifdef _CRAY SAXPY(&A->nrow, &done, work, &ione, &Xmat[j*ldx], &ione); #else saxpy_(&A->nrow, &done, work, &ione, &Xmat[j*ldx], &ione); #endif lstres = berr[j]; ++count; } else { break; } } /* end while */ stat->RefineSteps = count; /* 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 SLACON 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) ))) */ for (i = 0; i < A->nrow; ++i) rwork[i] = fabs( Bptr[i] ); /* Compute abs(op(A))*abs(X) + abs(B). */ if ( notran ) { for (k = 0; k < A->ncol; ++k) { xk = fabs( Xptr[k] ); for (i = Astore->colptr[k]; i < Astore->colptr[k+1]; ++i) rwork[Astore->rowind[i]] += fabs(Aval[i]) * xk; } } else { for (k = 0; k < A->ncol; ++k) { s = 0.; for (i = Astore->colptr[k]; i < Astore->colptr[k+1]; ++i) { irow = Astore->rowind[i]; xk = fabs( Xptr[irow] ); s += fabs(Aval[i]) * xk; } rwork[k] += s; } } for (i = 0; i < A->nrow; ++i) if (rwork[i] > safe2) rwork[i] = fabs(work[i]) + (iwork[i]+1)*eps*rwork[i]; else rwork[i] = fabs(work[i])+(iwork[i]+1)*eps*rwork[i]+safe1; kase = 0; do { slacon_(&A->nrow, &work[A->nrow], work, &iwork[A->nrow], &ferr[j], &kase); if (kase == 0) break; if (kase == 1) { /* Multiply by diag(W)*inv(op(A)**T)*(diag(C) or diag(R)). */ if ( notran && colequ ) for (i = 0; i < A->ncol; ++i) work[i] *= C[i]; else if ( !notran && rowequ ) for (i = 0; i < A->nrow; ++i) work[i] *= R[i]; sgstrs (transt, L, U, perm_c, perm_r, &Bjcol, stat, info); for (i = 0; i < A->nrow; ++i) work[i] *= rwork[i]; } else { /* Multiply by (diag(C) or diag(R))*inv(op(A))*diag(W). */ for (i = 0; i < A->nrow; ++i) work[i] *= rwork[i]; sgstrs (trans, L, U, perm_c, perm_r, &Bjcol, stat, info); if ( notran && colequ ) for (i = 0; i < A->ncol; ++i) work[i] *= C[i]; else if ( !notran && rowequ ) for (i = 0; i < A->ncol; ++i) work[i] *= R[i]; } } while ( kase != 0 ); /* Normalize error. */ lstres = 0.; if ( notran && colequ ) { for (i = 0; i < A->nrow; ++i) lstres = SUPERLU_MAX( lstres, C[i] * fabs( Xptr[i]) ); } else if ( !notran && rowequ ) { for (i = 0; i < A->nrow; ++i) lstres = SUPERLU_MAX( lstres, R[i] * fabs( Xptr[i]) ); } else { for (i = 0; i < A->nrow; ++i) lstres = SUPERLU_MAX( lstres, fabs( Xptr[i]) ); } if ( lstres != 0. ) ferr[j] /= lstres; } /* for each RHS j ... */ SUPERLU_FREE(work); SUPERLU_FREE(rwork); SUPERLU_FREE(iwork); SUPERLU_FREE(Bjcol.Store); return; } /* sgsrfs */
/* Subroutine */ int spbcon_(char *uplo, integer *n, integer *kd, real *ab, integer *ldab, real *anorm, real *rcond, real *work, integer *iwork, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= SPBCON estimates the reciprocal of the condition number (in the 1-norm) of a real symmetric positive definite band matrix using the Cholesky factorization A = U**T*U or A = L*L**T computed by SPBTRF. An estimate is obtained for norm(inv(A)), and the reciprocal of the condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). Arguments ========= UPLO (input) CHARACTER*1 = 'U': Upper triangular factor stored in AB; = 'L': Lower triangular factor stored in AB. N (input) INTEGER The order of the matrix A. N >= 0. KD (input) INTEGER The number of superdiagonals of the matrix A if UPLO = 'U', or the number of subdiagonals if UPLO = 'L'. KD >= 0. AB (input) REAL array, dimension (LDAB,N) The triangular factor U or L from the Cholesky factorization A = U**T*U or A = L*L**T of the band matrix A, stored in the first KD+1 rows of the array. The j-th column of U or L is stored in the j-th column of the array AB as follows: if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j; if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd). LDAB (input) INTEGER The leading dimension of the array AB. LDAB >= KD+1. ANORM (input) REAL The 1-norm (or infinity-norm) of the symmetric band matrix A. RCOND (output) REAL The reciprocal of the condition number of the matrix A, computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an estimate of the 1-norm of inv(A) computed in this routine. WORK (workspace) REAL array, dimension (3*N) IWORK (workspace) INTEGER 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 ab_dim1, ab_offset, i__1; real r__1; /* Local variables */ static integer kase; static real scale; extern logical lsame_(char *, char *); extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *); static logical upper; static integer ix; static real scalel; extern doublereal slamch_(char *); static real scaleu; extern /* Subroutine */ int xerbla_(char *, integer *), slacon_( integer *, real *, real *, integer *, real *, integer *); extern integer isamax_(integer *, real *, integer *); static real ainvnm; extern /* Subroutine */ int slatbs_(char *, char *, char *, char *, integer *, integer *, real *, integer *, real *, real *, real *, integer *); static char normin[1]; static real smlnum; ab_dim1 = *ldab; ab_offset = 1 + ab_dim1 * 1; ab -= ab_offset; --work; --iwork; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*kd < 0) { *info = -3; } else if (*ldab < *kd + 1) { *info = -5; } else if (*anorm < 0.f) { *info = -6; } if (*info != 0) { i__1 = -(*info); xerbla_("SPBCON", &i__1); return 0; } /* Quick return if possible */ *rcond = 0.f; if (*n == 0) { *rcond = 1.f; return 0; } else if (*anorm == 0.f) { return 0; } smlnum = slamch_("Safe minimum"); /* Estimate the 1-norm of the inverse. */ kase = 0; *(unsigned char *)normin = 'N'; L10: slacon_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase); if (kase != 0) { if (upper) { /* Multiply by inv(U'). */ slatbs_("Upper", "Transpose", "Non-unit", normin, n, kd, &ab[ ab_offset], ldab, &work[1], &scalel, &work[(*n << 1) + 1], info); *(unsigned char *)normin = 'Y'; /* Multiply by inv(U). */ slatbs_("Upper", "No transpose", "Non-unit", normin, n, kd, &ab[ ab_offset], ldab, &work[1], &scaleu, &work[(*n << 1) + 1], info); } else { /* Multiply by inv(L). */ slatbs_("Lower", "No transpose", "Non-unit", normin, n, kd, &ab[ ab_offset], ldab, &work[1], &scalel, &work[(*n << 1) + 1], info); *(unsigned char *)normin = 'Y'; /* Multiply by inv(L'). */ slatbs_("Lower", "Transpose", "Non-unit", normin, n, kd, &ab[ ab_offset], ldab, &work[1], &scaleu, &work[(*n << 1) + 1], info); } /* Multiply by 1/SCALE if doing so will not cause overflow. */ scale = scalel * scaleu; if (scale != 1.f) { ix = isamax_(n, &work[1], &c__1); if (scale < (r__1 = work[ix], dabs(r__1)) * smlnum || scale == 0.f) { goto L20; } srscl_(n, &scale, &work[1], &c__1); } goto L10; } /* Compute the estimate of the reciprocal condition number. */ if (ainvnm != 0.f) { *rcond = 1.f / ainvnm / *anorm; } L20: return 0; /* End of SPBCON */ } /* spbcon_ */
/* Subroutine */ int stpcon_(char *norm, char *uplo, char *diag, integer *n, real *ap, real *rcond, real *work, integer *iwork, integer *info) { /* -- LAPACK routine (version 2.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University March 31, 1993 Purpose ======= STPCON estimates the reciprocal of the condition number of a packed triangular matrix A, in either the 1-norm or the infinity-norm. The norm of A is computed and an estimate is obtained for norm(inv(A)), then the reciprocal of the condition number is computed as RCOND = 1 / ( norm(A) * norm(inv(A)) ). Arguments ========= NORM (input) CHARACTER*1 Specifies whether the 1-norm condition number or the infinity-norm condition number is required: = '1' or 'O': 1-norm; = 'I': Infinity-norm. UPLO (input) CHARACTER*1 = 'U': A is upper triangular; = 'L': A is lower triangular. 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. AP (input) REAL 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. RCOND (output) REAL The reciprocal of the condition number of the matrix A, computed as RCOND = 1/(norm(A) * norm(inv(A))). WORK (workspace) REAL array, dimension (3*N) IWORK (workspace) INTEGER 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 Function Body */ /* Table of constant values */ static integer c__1 = 1; /* System generated locals */ integer i__1; real r__1; /* Local variables */ static integer kase, kase1; static real scale; extern logical lsame_(char *, char *); static real anorm; extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *); static logical upper; static real xnorm; static integer ix; extern doublereal slamch_(char *); extern /* Subroutine */ int xerbla_(char *, integer *), slacon_( integer *, real *, real *, integer *, real *, integer *); extern integer isamax_(integer *, real *, integer *); static real ainvnm; static logical onenrm; extern doublereal slantp_(char *, char *, char *, integer *, real *, real *); static char normin[1]; extern /* Subroutine */ int slatps_(char *, char *, char *, char *, integer *, real *, real *, real *, real *, integer *); static real smlnum; static logical nounit; #define IWORK(I) iwork[(I)-1] #define WORK(I) work[(I)-1] #define AP(I) ap[(I)-1] *info = 0; upper = lsame_(uplo, "U"); onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); nounit = lsame_(diag, "N"); if (! onenrm && ! lsame_(norm, "I")) { *info = -1; } else if (! upper && ! lsame_(uplo, "L")) { *info = -2; } else if (! nounit && ! lsame_(diag, "U")) { *info = -3; } else if (*n < 0) { *info = -4; } if (*info != 0) { i__1 = -(*info); xerbla_("STPCON", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { *rcond = 1.f; return 0; } *rcond = 0.f; smlnum = slamch_("Safe minimum") * (real) max(1,*n); /* Compute the norm of the triangular matrix A. */ anorm = slantp_(norm, uplo, diag, n, &AP(1), &WORK(1)); /* Continue only if ANORM > 0. */ if (anorm > 0.f) { /* Estimate the norm of the inverse of A. */ ainvnm = 0.f; *(unsigned char *)normin = 'N'; if (onenrm) { kase1 = 1; } else { kase1 = 2; } kase = 0; L10: slacon_(n, &WORK(*n + 1), &WORK(1), &IWORK(1), &ainvnm, &kase); if (kase != 0) { if (kase == kase1) { /* Multiply by inv(A). */ slatps_(uplo, "No transpose", diag, normin, n, &AP(1), &WORK( 1), &scale, &WORK((*n << 1) + 1), info); } else { /* Multiply by inv(A'). */ slatps_(uplo, "Transpose", diag, normin, n, &AP(1), &WORK(1), &scale, &WORK((*n << 1) + 1), info); } *(unsigned char *)normin = 'Y'; /* Multiply by 1/SCALE if doing so will not cause overfl ow. */ if (scale != 1.f) { ix = isamax_(n, &WORK(1), &c__1); xnorm = (r__1 = WORK(ix), dabs(r__1)); if (scale < xnorm * smlnum || scale == 0.f) { goto L20; } srscl_(n, &scale, &WORK(1), &c__1); } goto L10; } /* Compute the estimate of the reciprocal condition number. */ if (ainvnm != 0.f) { *rcond = 1.f / anorm / ainvnm; } } L20: return 0; /* End of STPCON */ } /* stpcon_ */
/* Subroutine */ int stgsen_(integer *ijob, logical *wantq, logical *wantz, logical *select, integer *n, real *a, integer *lda, real *b, integer * ldb, real *alphar, real *alphai, real *beta, real *q, integer *ldq, real *z__, integer *ldz, integer *m, real *pl, real *pr, real *dif, real *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 ======= STGSEN reorders the generalized real Schur decomposition of a real matrix pair (A, B) (in terms of an orthonormal equivalence trans- formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues appears in the leading diagonal blocks of the upper quasi-triangular matrix A and the upper triangular B. The leading columns of Q and Z form orthonormal bases of the corresponding left and right eigen- spaces (deflating subspaces). (A, B) must be in generalized real Schur canonical form (as returned by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper triangular. STGSEN also computes the generalized eigenvalues w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j) of the reordered matrix pair (A, B). Optionally, STGSEN computes the 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 a real eigenvalue w(j), SELECT(j) must be set to .TRUE.. To select a complex conjugate pair of eigenvalues w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, either SELECT(j) or SELECT(j+1) or both must be set to .TRUE.; a complex conjugate pair of eigenvalues must be either both included in the cluster or both excluded. N (input) INTEGER The order of the matrices A and B. N >= 0. A (input/output) REAL array, dimension(LDA,N) On entry, the upper quasi-triangular matrix A, with (A, B) in generalized real 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) REAL array, dimension(LDB,N) On entry, the upper triangular matrix B, with (A, B) in generalized real 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). ALPHAR (output) REAL array, dimension (N) ALPHAI (output) REAL array, dimension (N) BETA (output) REAL array, dimension (N) On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i and BETA(j),j=1,...,N are the diagonals of the complex Schur form (S,T) that would result if the 2-by-2 diagonal blocks of the real generalized Schur form of (A,B) were further reduced to triangular form using complex unitary transformations. If ALPHAI(j) is zero, then the j-th eigenvalue is real; if positive, then the j-th and (j+1)-st eigenvalues are a complex conjugate pair, with ALPHAI(j+1) negative. Q (input/output) REAL 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 orthogonal 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; and if WANTQ = .TRUE., LDQ >= N. Z (input/output) REAL 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 orthogonal 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 eigen- spaces (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 eigenspaces 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 and 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. If M = 0 or N, DIF(1:2) = F-norm([A, B]). If IJOB = 0 or 1, DIF is not referenced. WORK (workspace/output) REAL 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 >= 4*N+16. If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)). If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 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 array, 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+6. If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6). 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 =============== STGSEN first collects the selected eigenvalues by computing orthogonal 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 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 real 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 SLATDF), then the parameter IDIFJB (see below) should be changed from 3 to 4 (routine SLATDF (IJOB = 2 will be used)). See STGSYL 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; static integer c__2 = 2; static real c_b28 = 1.f; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, z_offset, i__1, i__2; real r__1; /* Builtin functions */ double sqrt(doublereal), r_sign(real *, real *); /* Local variables */ static integer kase; static logical pair; static integer ierr; static real dsum; static logical swap; extern /* Subroutine */ int slag2_(real *, integer *, real *, integer *, real *, real *, real *, real *, real *, real *); static integer i__, k; static logical wantd; static integer lwmin; static logical wantp; static integer n1, n2; static logical wantd1, wantd2; static integer kk; static real dscale; static integer ks; static real rdscal; extern doublereal slamch_(char *); extern /* Subroutine */ int xerbla_(char *, integer *), slacon_( integer *, real *, real *, integer *, real *, integer *), slacpy_( char *, integer *, integer *, real *, integer *, real *, integer * ), stgexc_(logical *, logical *, integer *, real *, integer *, real *, integer *, real *, integer *, real *, integer * , integer *, integer *, real *, integer *, integer *); static integer liwmin; extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, real *); static real smlnum; static integer mn2; static logical lquery; extern /* Subroutine */ int stgsyl_(char *, integer *, integer *, integer *, real *, integer *, real *, integer *, real *, integer *, real * , integer *, real *, integer *, real *, integer *, real *, real *, real *, integer *, integer *, integer *); static integer ijb; static real eps; #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] #define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1] #define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1] --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; --alphar; --alphai; --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 = -14; } else if (*ldz < 1 || *wantz && *ldz < *n) { *info = -16; } if (*info != 0) { i__1 = -(*info); xerbla_("STGSEN", &i__1); return 0; } /* Get machine constants */ eps = slamch_("P"); smlnum = slamch_("S") / eps; 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; pair = FALSE_; i__1 = *n; for (k = 1; k <= i__1; ++k) { if (pair) { pair = FALSE_; } else { if (k < *n) { if (a_ref(k + 1, k) == 0.f) { if (select[k]) { ++(*m); } } else { pair = TRUE_; if (select[k] || select[k + 1]) { *m += 2; } } } else { if (select[*n]) { ++(*m); } } } /* L10: */ } if (*ijob == 1 || *ijob == 2 || *ijob == 4) { /* Computing MAX */ i__1 = 1, i__2 = (*n << 2) + 16, i__1 = max(i__1,i__2), i__2 = (*m << 1) * (*n - *m); lwmin = max(i__1,i__2); /* Computing MAX */ i__1 = 1, i__2 = *n + 6; liwmin = max(i__1,i__2); } else if (*ijob == 3 || *ijob == 5) { /* Computing MAX */ i__1 = 1, i__2 = (*n << 2) + 16, i__1 = max(i__1,i__2), 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 + 6; liwmin = max(i__1,i__2); } else { /* Computing MAX */ i__1 = 1, i__2 = (*n << 2) + 16; lwmin = max(i__1,i__2); liwmin = 1; } work[1] = (real) lwmin; iwork[1] = liwmin; if (*lwork < lwmin && ! lquery) { *info = -22; } else if (*liwork < liwmin && ! lquery) { *info = -24; } if (*info != 0) { i__1 = -(*info); xerbla_("STGSEN", &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__) { slassq_(n, &a_ref(1, i__), &c__1, &dscale, &dsum); slassq_(n, &b_ref(1, i__), &c__1, &dscale, &dsum); /* L20: */ } dif[1] = dscale * sqrt(dsum); dif[2] = dif[1]; } goto L60; } /* Collect the selected blocks at the top-left corner of (A, B). */ ks = 0; pair = FALSE_; i__1 = *n; for (k = 1; k <= i__1; ++k) { if (pair) { pair = FALSE_; } else { swap = select[k]; if (k < *n) { if (a_ref(k + 1, k) != 0.f) { pair = TRUE_; swap = swap || select[k + 1]; } } if (swap) { ++ks; /* Swap the K-th block to position KS. Perform the reordering of diagonal blocks in (A, B) by orthogonal transformation matrices and update Q and Z accordingly (if requested): */ kk = k; if (k != ks) { stgexc_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &kk, &ks, &work[1], lwork, &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 L60; } if (pair) { ++ks; } } } /* L30: */ } if (wantp) { /* Solve generalized Sylvester equation for R and L and compute PL and PR. */ n1 = *m; n2 = *n - *m; i__ = n1 + 1; ijb = 0; slacpy_("Full", &n1, &n2, &a_ref(1, i__), lda, &work[1], &n1); slacpy_("Full", &n1, &n2, &b_ref(1, i__), ldb, &work[n1 * n2 + 1], & n1); i__1 = *lwork - (n1 << 1) * n2; stgsyl_("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; slassq_(&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; slassq_(&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 of 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; stgsyl_("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 << 1) * n2 + 1], &i__1, &iwork[1], &ierr); /* Frobenius norm-based Difl-estimate. */ i__1 = *lwork - (n1 << 1) * n2; stgsyl_("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 << 1) * n2 + 1], &i__1, &iwork[1], &ierr); } else { /* Compute 1-norm-based estimates of Difu and Difl using reversed communication with SLACON. 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: slacon_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[1], &kase) ; if (kase != 0) { if (kase == 1) { /* Solve generalized Sylvester equation. */ i__1 = *lwork - (n1 << 1) * n2; stgsyl_("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 << 1) * n2 + 1], &i__1, &iwork[1], &ierr); } else { /* Solve the transposed variant. */ i__1 = *lwork - (n1 << 1) * n2; stgsyl_("T", &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 << 1) * n2 + 1], &i__1, &iwork[1], &ierr); } goto L40; } dif[1] = dscale / dif[1]; /* 1-norm-based estimate of Difl. */ L50: slacon_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[2], &kase) ; if (kase != 0) { if (kase == 1) { /* Solve generalized Sylvester equation. */ i__1 = *lwork - (n1 << 1) * n2; stgsyl_("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 << 1) * n2 + 1], &i__1, &iwork[1], &ierr); } else { /* Solve the transposed variant. */ i__1 = *lwork - (n1 << 1) * n2; stgsyl_("T", &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 << 1) * n2 + 1], &i__1, &iwork[1], &ierr); } goto L50; } dif[2] = dscale / dif[2]; } } L60: /* Compute generalized eigenvalues of reordered pair (A, B) and normalize the generalized Schur form. */ pair = FALSE_; i__1 = *n; for (k = 1; k <= i__1; ++k) { if (pair) { pair = FALSE_; } else { if (k < *n) { if (a_ref(k + 1, k) != 0.f) { pair = TRUE_; } } if (pair) { /* Compute the eigenvalue(s) at position K. */ work[1] = a_ref(k, k); work[2] = a_ref(k + 1, k); work[3] = a_ref(k, k + 1); work[4] = a_ref(k + 1, k + 1); work[5] = b_ref(k, k); work[6] = b_ref(k + 1, k); work[7] = b_ref(k, k + 1); work[8] = b_ref(k + 1, k + 1); r__1 = smlnum * eps; slag2_(&work[1], &c__2, &work[5], &c__2, &r__1, &beta[k], & beta[k + 1], &alphar[k], &alphar[k + 1], &alphai[k]); alphai[k + 1] = -alphai[k]; } else { if (r_sign(&c_b28, &b_ref(k, k)) < 0.f) { /* If B(K,K) is negative, make it positive */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { a_ref(k, i__) = -a_ref(k, i__); b_ref(k, i__) = -b_ref(k, i__); q_ref(i__, k) = -q_ref(i__, k); /* L80: */ } } alphar[k] = a_ref(k, k); alphai[k] = 0.f; beta[k] = b_ref(k, k); } } /* L70: */ } work[1] = (real) lwmin; iwork[1] = liwmin; return 0; /* End of STGSEN */ } /* stgsen_ */
/*! \brief * * <pre> * Purpose * ======= * * SGSRFS improves the computed solution to a system of linear * equations and provides error bounds and backward error estimates for * the solution. * * If equilibration was performed, the system becomes: * (diag(R)*A_original*diag(C)) * X = diag(R)*B_original. * * See supermatrix.h for the definition of 'SuperMatrix' structure. * * Arguments * ========= * * trans (input) trans_t * Specifies the form of the system of equations: * = NOTRANS: A * X = B (No transpose) * = TRANS: A'* X = B (Transpose) * = CONJ: A**H * X = B (Conjugate transpose) * * A (input) SuperMatrix* * The original matrix A in the system, or the scaled A if * equilibration was done. The type of A can be: * Stype = SLU_NC, Dtype = SLU_S, Mtype = SLU_GE. * * L (input) SuperMatrix* * The factor L from the factorization Pr*A*Pc=L*U. Use * compressed row subscripts storage for supernodes, * i.e., L has types: Stype = SLU_SC, Dtype = SLU_S, Mtype = SLU_TRLU. * * U (input) SuperMatrix* * The factor U from the factorization Pr*A*Pc=L*U as computed by * sgstrf(). Use column-wise storage scheme, * i.e., U has types: Stype = SLU_NC, Dtype = SLU_S, Mtype = SLU_TRU. * * perm_c (input) int*, dimension (A->ncol) * Column permutation vector, which defines the * permutation matrix Pc; perm_c[i] = j means column i of A is * in position j in A*Pc. * * perm_r (input) int*, dimension (A->nrow) * Row permutation vector, which defines the permutation matrix Pr; * perm_r[i] = j means row i of A is in position j in Pr*A. * * equed (input) Specifies the form of equilibration that was done. * = 'N': No equilibration. * = 'R': Row equilibration, i.e., A was premultiplied by diag(R). * = 'C': Column equilibration, i.e., A was postmultiplied by * diag(C). * = 'B': Both row and column equilibration, i.e., A was replaced * by diag(R)*A*diag(C). * * R (input) float*, dimension (A->nrow) * The row scale factors for A. * If equed = 'R' or 'B', A is premultiplied by diag(R). * If equed = 'N' or 'C', R is not accessed. * * C (input) float*, dimension (A->ncol) * The column scale factors for A. * If equed = 'C' or 'B', A is postmultiplied by diag(C). * If equed = 'N' or 'R', C is not accessed. * * B (input) SuperMatrix* * B has types: Stype = SLU_DN, Dtype = SLU_S, Mtype = SLU_GE. * The right hand side matrix B. * if equed = 'R' or 'B', B is premultiplied by diag(R). * * X (input/output) SuperMatrix* * X has types: Stype = SLU_DN, Dtype = SLU_S, Mtype = SLU_GE. * On entry, the solution matrix X, as computed by sgstrs(). * On exit, the improved solution matrix X. * if *equed = 'C' or 'B', X should be premultiplied by diag(C) * in order to obtain the solution to the original system. * * FERR (output) float*, dimension (B->ncol) * 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) float*, dimension (B->ncol) * 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). * * stat (output) SuperLUStat_t* * Record the statistics on runtime and floating-point operation count. * See util.h for the definition of 'SuperLUStat_t'. * * info (output) int* * = 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. * * </pre> */ void sgsrfs(trans_t trans, SuperMatrix *A, SuperMatrix *L, SuperMatrix *U, int *perm_c, int *perm_r, char *equed, float *R, float *C, SuperMatrix *B, SuperMatrix *X, float *ferr, float *berr, SuperLUStat_t *stat, int *info) { #define ITMAX 5 /* Table of constant values */ int ione = 1; float ndone = -1.; float done = 1.; /* Local variables */ NCformat *Astore; float *Aval; SuperMatrix Bjcol; DNformat *Bstore, *Xstore, *Bjcol_store; float *Bmat, *Xmat, *Bptr, *Xptr; int kase; float safe1, safe2; int i, j, k, irow, nz, count, notran, rowequ, colequ; int ldb, ldx, nrhs; float s, xk, lstres, eps, safmin; char transc[1]; trans_t transt; float *work; float *rwork; int *iwork; extern int slacon_(int *, float *, float *, int *, float *, int *); #ifdef _CRAY extern int SCOPY(int *, float *, int *, float *, int *); extern int SSAXPY(int *, float *, float *, int *, float *, int *); #else extern int scopy_(int *, float *, int *, float *, int *); extern int saxpy_(int *, float *, float *, int *, float *, int *); #endif Astore = A->Store; Aval = Astore->nzval; Bstore = B->Store; Xstore = X->Store; Bmat = Bstore->nzval; Xmat = Xstore->nzval; ldb = Bstore->lda; ldx = Xstore->lda; nrhs = B->ncol; /* Test the input parameters */ *info = 0; notran = (trans == NOTRANS); if ( !notran && trans != TRANS && trans != CONJ ) *info = -1; else if ( A->nrow != A->ncol || A->nrow < 0 || A->Stype != SLU_NC || A->Dtype != SLU_S || A->Mtype != SLU_GE ) *info = -2; else if ( L->nrow != L->ncol || L->nrow < 0 || L->Stype != SLU_SC || L->Dtype != SLU_S || L->Mtype != SLU_TRLU ) *info = -3; else if ( U->nrow != U->ncol || U->nrow < 0 || U->Stype != SLU_NC || U->Dtype != SLU_S || U->Mtype != SLU_TRU ) *info = -4; else if ( ldb < SUPERLU_MAX(0, A->nrow) || B->Stype != SLU_DN || B->Dtype != SLU_S || B->Mtype != SLU_GE ) *info = -10; else if ( ldx < SUPERLU_MAX(0, A->nrow) || X->Stype != SLU_DN || X->Dtype != SLU_S || X->Mtype != SLU_GE ) *info = -11; if (*info != 0) { i = -(*info); xerbla_("sgsrfs", &i); return; } /* Quick return if possible */ if ( A->nrow == 0 || nrhs == 0) { for (j = 0; j < nrhs; ++j) { ferr[j] = 0.; berr[j] = 0.; } return; } rowequ = lsame_(equed, "R") || lsame_(equed, "B"); colequ = lsame_(equed, "C") || lsame_(equed, "B"); /* Allocate working space */ work = floatMalloc(2*A->nrow); rwork = (float *) SUPERLU_MALLOC( A->nrow * sizeof(float) ); iwork = intMalloc(2*A->nrow); if ( !work || !rwork || !iwork ) ABORT("Malloc fails for work/rwork/iwork."); if ( notran ) { *(unsigned char *)transc = 'N'; transt = TRANS; } else { *(unsigned char *)transc = 'T'; transt = NOTRANS; } /* NZ = maximum number of nonzero elements in each row of A, plus 1 */ nz = A->ncol + 1; eps = slamch_("Epsilon"); safmin = slamch_("Safe minimum"); /* Set SAFE1 essentially to be the underflow threshold times the number of additions in each row. */ safe1 = nz * safmin; safe2 = safe1 / eps; /* Compute the number of nonzeros in each row (or column) of A */ for (i = 0; i < A->nrow; ++i) iwork[i] = 0; if ( notran ) { for (k = 0; k < A->ncol; ++k) for (i = Astore->colptr[k]; i < Astore->colptr[k+1]; ++i) ++iwork[Astore->rowind[i]]; } else { for (k = 0; k < A->ncol; ++k) iwork[k] = Astore->colptr[k+1] - Astore->colptr[k]; } /* Copy one column of RHS B into Bjcol. */ Bjcol.Stype = B->Stype; Bjcol.Dtype = B->Dtype; Bjcol.Mtype = B->Mtype; Bjcol.nrow = B->nrow; Bjcol.ncol = 1; Bjcol.Store = (void *) SUPERLU_MALLOC( sizeof(DNformat) ); if ( !Bjcol.Store ) ABORT("SUPERLU_MALLOC fails for Bjcol.Store"); Bjcol_store = Bjcol.Store; Bjcol_store->lda = ldb; Bjcol_store->nzval = work; /* address aliasing */ /* Do for each right hand side ... */ for (j = 0; j < nrhs; ++j) { count = 0; lstres = 3.; Bptr = &Bmat[j*ldb]; Xptr = &Xmat[j*ldx]; while (1) { /* 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. */ #ifdef _CRAY SCOPY(&A->nrow, Bptr, &ione, work, &ione); #else scopy_(&A->nrow, Bptr, &ione, work, &ione); #endif sp_sgemv(transc, ndone, A, Xptr, ione, done, work, ione); /* 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 component of the numerator before dividing. */ for (i = 0; i < A->nrow; ++i) rwork[i] = fabs( Bptr[i] ); /* Compute abs(op(A))*abs(X) + abs(B). */ if (notran) { for (k = 0; k < A->ncol; ++k) { xk = fabs( Xptr[k] ); for (i = Astore->colptr[k]; i < Astore->colptr[k+1]; ++i) rwork[Astore->rowind[i]] += fabs(Aval[i]) * xk; } } else { for (k = 0; k < A->ncol; ++k) { s = 0.; for (i = Astore->colptr[k]; i < Astore->colptr[k+1]; ++i) { irow = Astore->rowind[i]; s += fabs(Aval[i]) * fabs(Xptr[irow]); } rwork[k] += s; } } s = 0.; for (i = 0; i < A->nrow; ++i) { if (rwork[i] > safe2) { s = SUPERLU_MAX( s, fabs(work[i]) / rwork[i] ); } else if ( rwork[i] != 0.0 ) { /* Adding SAFE1 to the numerator guards against spuriously zero residuals (underflow). */ s = SUPERLU_MAX( s, (safe1 + fabs(work[i])) / rwork[i] ); } /* If rwork[i] is exactly 0.0, then we know the true residual also must be exactly 0.0. */ } 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 < ITMAX) { /* Update solution and try again. */ sgstrs (trans, L, U, perm_c, perm_r, &Bjcol, stat, info); #ifdef _CRAY SAXPY(&A->nrow, &done, work, &ione, &Xmat[j*ldx], &ione); #else saxpy_(&A->nrow, &done, work, &ione, &Xmat[j*ldx], &ione); #endif lstres = berr[j]; ++count; } else { break; } } /* end while */ stat->RefineSteps = count; /* 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 SLACON 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) ))) */ for (i = 0; i < A->nrow; ++i) rwork[i] = fabs( Bptr[i] ); /* Compute abs(op(A))*abs(X) + abs(B). */ if ( notran ) { for (k = 0; k < A->ncol; ++k) { xk = fabs( Xptr[k] ); for (i = Astore->colptr[k]; i < Astore->colptr[k+1]; ++i) rwork[Astore->rowind[i]] += fabs(Aval[i]) * xk; } } else { for (k = 0; k < A->ncol; ++k) { s = 0.; for (i = Astore->colptr[k]; i < Astore->colptr[k+1]; ++i) { irow = Astore->rowind[i]; xk = fabs( Xptr[irow] ); s += fabs(Aval[i]) * xk; } rwork[k] += s; } } for (i = 0; i < A->nrow; ++i) if (rwork[i] > safe2) rwork[i] = fabs(work[i]) + (iwork[i]+1)*eps*rwork[i]; else rwork[i] = fabs(work[i])+(iwork[i]+1)*eps*rwork[i]+safe1; kase = 0; do { slacon_(&A->nrow, &work[A->nrow], work, &iwork[A->nrow], &ferr[j], &kase); if (kase == 0) break; if (kase == 1) { /* Multiply by diag(W)*inv(op(A)**T)*(diag(C) or diag(R)). */ if ( notran && colequ ) for (i = 0; i < A->ncol; ++i) work[i] *= C[i]; else if ( !notran && rowequ ) for (i = 0; i < A->nrow; ++i) work[i] *= R[i]; sgstrs (transt, L, U, perm_c, perm_r, &Bjcol, stat, info); for (i = 0; i < A->nrow; ++i) work[i] *= rwork[i]; } else { /* Multiply by (diag(C) or diag(R))*inv(op(A))*diag(W). */ for (i = 0; i < A->nrow; ++i) work[i] *= rwork[i]; sgstrs (trans, L, U, perm_c, perm_r, &Bjcol, stat, info); if ( notran && colequ ) for (i = 0; i < A->ncol; ++i) work[i] *= C[i]; else if ( !notran && rowequ ) for (i = 0; i < A->ncol; ++i) work[i] *= R[i]; } } while ( kase != 0 ); /* Normalize error. */ lstres = 0.; if ( notran && colequ ) { for (i = 0; i < A->nrow; ++i) lstres = SUPERLU_MAX( lstres, C[i] * fabs( Xptr[i]) ); } else if ( !notran && rowequ ) { for (i = 0; i < A->nrow; ++i) lstres = SUPERLU_MAX( lstres, R[i] * fabs( Xptr[i]) ); } else { for (i = 0; i < A->nrow; ++i) lstres = SUPERLU_MAX( lstres, fabs( Xptr[i]) ); } if ( lstres != 0. ) ferr[j] /= lstres; } /* for each RHS j ... */ SUPERLU_FREE(work); SUPERLU_FREE(rwork); SUPERLU_FREE(iwork); SUPERLU_FREE(Bjcol.Store); return; } /* sgsrfs */
/* Subroutine */ int sppcon_(char *uplo, integer *n, real *ap, real *anorm, real *rcond, real *work, integer *iwork, integer *info, ftnlen uplo_len) { /* System generated locals */ integer i__1; real r__1; /* Local variables */ static integer ix, kase; static real scale; extern logical lsame_(char *, char *, ftnlen, ftnlen); extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *); static logical upper; static real scalel; extern doublereal slamch_(char *, ftnlen); static real scaleu; extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slacon_( integer *, real *, real *, integer *, real *, integer *); extern integer isamax_(integer *, real *, integer *); static real ainvnm; static char normin[1]; extern /* Subroutine */ int slatps_(char *, char *, char *, char *, integer *, real *, real *, real *, real *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); static real smlnum; /* -- LAPACK routine (version 3.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* March 31, 1993 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* SPPCON estimates the reciprocal of the condition number (in the */ /* 1-norm) of a real symmetric positive definite packed matrix using */ /* the Cholesky factorization A = U**T*U or A = L*L**T computed by */ /* SPPTRF. */ /* An estimate is obtained for norm(inv(A)), and the reciprocal of the */ /* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */ /* 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. */ /* AP (input) REAL array, dimension (N*(N+1)/2) */ /* The triangular factor U or L from the Cholesky factorization */ /* A = U**T*U or A = L*L**T, packed columnwise in a linear */ /* array. The j-th column of U or L is stored in the array AP */ /* as follows: */ /* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */ /* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */ /* ANORM (input) REAL */ /* The 1-norm (or infinity-norm) of the symmetric matrix A. */ /* RCOND (output) REAL */ /* The reciprocal of the condition number of the matrix A, */ /* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */ /* estimate of the 1-norm of inv(A) computed in this routine. */ /* WORK (workspace) REAL array, dimension (3*N) */ /* IWORK (workspace) INTEGER array, dimension (N) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ --iwork; --work; --ap; /* Function Body */ *info = 0; upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1); if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*anorm < 0.f) { *info = -4; } if (*info != 0) { i__1 = -(*info); xerbla_("SPPCON", &i__1, (ftnlen)6); return 0; } /* Quick return if possible */ *rcond = 0.f; if (*n == 0) { *rcond = 1.f; return 0; } else if (*anorm == 0.f) { return 0; } smlnum = slamch_("Safe minimum", (ftnlen)12); /* Estimate the 1-norm of the inverse. */ kase = 0; *(unsigned char *)normin = 'N'; L10: slacon_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase); if (kase != 0) { if (upper) { /* Multiply by inv(U'). */ slatps_("Upper", "Transpose", "Non-unit", normin, n, &ap[1], & work[1], &scalel, &work[(*n << 1) + 1], info, (ftnlen)5, ( ftnlen)9, (ftnlen)8, (ftnlen)1); *(unsigned char *)normin = 'Y'; /* Multiply by inv(U). */ slatps_("Upper", "No transpose", "Non-unit", normin, n, &ap[1], & work[1], &scaleu, &work[(*n << 1) + 1], info, (ftnlen)5, ( ftnlen)12, (ftnlen)8, (ftnlen)1); } else { /* Multiply by inv(L). */ slatps_("Lower", "No transpose", "Non-unit", normin, n, &ap[1], & work[1], &scalel, &work[(*n << 1) + 1], info, (ftnlen)5, ( ftnlen)12, (ftnlen)8, (ftnlen)1); *(unsigned char *)normin = 'Y'; /* Multiply by inv(L'). */ slatps_("Lower", "Transpose", "Non-unit", normin, n, &ap[1], & work[1], &scaleu, &work[(*n << 1) + 1], info, (ftnlen)5, ( ftnlen)9, (ftnlen)8, (ftnlen)1); } /* Multiply by 1/SCALE if doing so will not cause overflow. */ scale = scalel * scaleu; if (scale != 1.f) { ix = isamax_(n, &work[1], &c__1); if (scale < (r__1 = work[ix], dabs(r__1)) * smlnum || scale == 0.f) { goto L20; } srscl_(n, &scale, &work[1], &c__1); } goto L10; } /* Compute the estimate of the reciprocal condition number. */ if (ainvnm != 0.f) { *rcond = 1.f / ainvnm / *anorm; } L20: return 0; /* End of SPPCON */ } /* sppcon_ */
/* Subroutine */ int strrfs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, real *a, integer *lda, real *b, integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real *work, integer *iwork, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= STRRFS provides error bounds and backward error estimates for the solution to a system of linear equations with a triangular coefficient matrix. The solution matrix X must be computed by STRTRS or some other means before entering this routine. STRRFS 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 = 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. A (input) REAL 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) REAL 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) REAL 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) REAL array, dimension (3*N) IWORK (workspace) INTEGER 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; static real c_b19 = -1.f; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3; real r__1, r__2, r__3; /* Local variables */ static integer kase; static real safe1, safe2; static integer i__, j, k; static real s; extern logical lsame_(char *, char *); static logical upper; extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, integer *), saxpy_(integer *, real *, real *, integer *, real *, integer *), strmv_(char *, char *, char *, integer *, real *, integer *, real *, integer *), strsv_( char *, char *, char *, integer *, real *, integer *, real *, integer *); static real xk; extern doublereal slamch_(char *); static integer nz; static real safmin; extern /* Subroutine */ int xerbla_(char *, integer *), slacon_( integer *, real *, real *, integer *, real *, integer *); static logical notran; static char transt[1]; static logical nounit; static real lstres, eps; #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] #define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1] #define x_ref(a_1,a_2) x[(a_2)*x_dim1 + a_1] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; x_dim1 = *ldx; x_offset = 1 + x_dim1 * 1; x -= x_offset; --ferr; --berr; --work; --iwork; /* 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 (*lda < max(1,*n)) { *info = -7; } else if (*ldb < max(1,*n)) { *info = -9; } else if (*ldx < max(1,*n)) { *info = -11; } if (*info != 0) { i__1 = -(*info); xerbla_("STRRFS", &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 *)transt = 'T'; } else { *(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 or A', depending on TRANS. */ scopy_(n, &x_ref(1, j), &c__1, &work[*n + 1], &c__1); strmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[*n + 1], &c__1); saxpy_(n, &c_b19, &b_ref(1, j), &c__1, &work[*n + 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__) { work[i__] = (r__1 = b_ref(i__, j), dabs(r__1)); /* L20: */ } if (notran) { /* Compute abs(A)*abs(X) + abs(B). */ if (upper) { if (nounit) { i__2 = *n; for (k = 1; k <= i__2; ++k) { xk = (r__1 = x_ref(k, j), dabs(r__1)); i__3 = k; for (i__ = 1; i__ <= i__3; ++i__) { work[i__] += (r__1 = a_ref(i__, k), dabs(r__1)) * xk; /* L30: */ } /* L40: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { xk = (r__1 = x_ref(k, j), dabs(r__1)); i__3 = k - 1; for (i__ = 1; i__ <= i__3; ++i__) { work[i__] += (r__1 = a_ref(i__, k), dabs(r__1)) * xk; /* L50: */ } work[k] += xk; /* L60: */ } } } else { if (nounit) { i__2 = *n; for (k = 1; k <= i__2; ++k) { xk = (r__1 = x_ref(k, j), dabs(r__1)); i__3 = *n; for (i__ = k; i__ <= i__3; ++i__) { work[i__] += (r__1 = a_ref(i__, k), dabs(r__1)) * xk; /* L70: */ } /* L80: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { xk = (r__1 = x_ref(k, j), dabs(r__1)); i__3 = *n; for (i__ = k + 1; i__ <= i__3; ++i__) { work[i__] += (r__1 = a_ref(i__, k), dabs(r__1)) * xk; /* L90: */ } work[k] += xk; /* L100: */ } } } } else { /* Compute abs(A')*abs(X) + abs(B). */ if (upper) { 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__) { s += (r__1 = a_ref(i__, k), dabs(r__1)) * (r__2 = x_ref(i__, j), dabs(r__2)); /* L110: */ } work[k] += s; /* L120: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { s = (r__1 = x_ref(k, j), dabs(r__1)); i__3 = k - 1; for (i__ = 1; i__ <= i__3; ++i__) { s += (r__1 = a_ref(i__, k), dabs(r__1)) * (r__2 = x_ref(i__, j), dabs(r__2)); /* L130: */ } work[k] += s; /* L140: */ } } } else { 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__) { s += (r__1 = a_ref(i__, k), dabs(r__1)) * (r__2 = x_ref(i__, j), dabs(r__2)); /* L150: */ } work[k] += s; /* L160: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { s = (r__1 = x_ref(k, j), dabs(r__1)); i__3 = *n; for (i__ = k + 1; i__ <= i__3; ++i__) { s += (r__1 = a_ref(i__, k), dabs(r__1)) * (r__2 = x_ref(i__, j), dabs(r__2)); /* L170: */ } work[k] += s; /* L180: */ } } } } s = 0.f; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { if (work[i__] > safe2) { /* Computing MAX */ r__2 = s, r__3 = (r__1 = work[*n + i__], dabs(r__1)) / work[ i__]; s = dmax(r__2,r__3); } else { /* Computing MAX */ r__2 = s, r__3 = ((r__1 = work[*n + i__], dabs(r__1)) + safe1) / (work[i__] + safe1); s = dmax(r__2,r__3); } /* 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 SLACON 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 (work[i__] > safe2) { work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps * work[i__]; } else { work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps * work[i__] + safe1; } /* L200: */ } kase = 0; L210: slacon_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & kase); if (kase != 0) { if (kase == 1) { /* Multiply by diag(W)*inv(op(A)'). */ strsv_(uplo, transt, diag, n, &a[a_offset], lda, &work[*n + 1] , &c__1); i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { work[*n + i__] = work[i__] * work[*n + i__]; /* L220: */ } } else { /* Multiply by inv(op(A))*diag(W). */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { work[*n + i__] = work[i__] * work[*n + i__]; /* L230: */ } strsv_(uplo, trans, diag, n, &a[a_offset], lda, &work[*n + 1], &c__1); } goto L210; } /* Normalize error. */ lstres = 0.f; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = lstres, r__3 = (r__1 = x_ref(i__, j), dabs(r__1)); lstres = dmax(r__2,r__3); /* L240: */ } if (lstres != 0.f) { ferr[j] /= lstres; } /* L250: */ } return 0; /* End of STRRFS */ } /* strrfs_ */
/* Subroutine */ int strsen_(char *job, char *compq, logical *select, integer *n, real *t, integer *ldt, real *q, integer *ldq, real *wr, real *wi, integer *m, real *s, real *sep, real *work, integer *lwork, integer * iwork, integer *liwork, integer *info, ftnlen job_len, ftnlen compq_len) { /* System generated locals */ integer q_dim1, q_offset, t_dim1, t_offset, i__1, i__2; real r__1, r__2; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static integer k, n1, n2, kk, nn, ks; static real est; static integer kase; static logical pair; static integer ierr; static logical swap; static real scale; extern logical lsame_(char *, char *, ftnlen, ftnlen); static integer lwmin; static logical wantq, wants; static real rnorm; extern doublereal slange_(char *, integer *, integer *, real *, integer *, real *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slacon_( integer *, real *, real *, integer *, real *, integer *); static logical wantbh; extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *, ftnlen); static integer liwmin; extern /* Subroutine */ int strexc_(char *, integer *, real *, integer *, real *, integer *, integer *, integer *, real *, integer *, ftnlen); static logical wantsp, lquery; extern /* Subroutine */ int strsyl_(char *, char *, integer *, integer *, integer *, real *, integer *, real *, integer *, real *, integer * , real *, integer *, ftnlen, ftnlen); /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* STRSEN reorders the real Schur factorization of a real matrix */ /* A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in */ /* the leading diagonal blocks of the upper quasi-triangular matrix T, */ /* and the leading columns of Q form an orthonormal basis of the */ /* corresponding right invariant subspace. */ /* Optionally the routine computes the reciprocal condition numbers of */ /* the cluster of eigenvalues and/or the invariant subspace. */ /* T must be in Schur canonical form (as returned by SHSEQR), that is, */ /* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each */ /* 2-by-2 diagonal block has its diagonal elemnts equal and its */ /* off-diagonal elements of opposite sign. */ /* Arguments */ /* ========= */ /* JOB (input) CHARACTER*1 */ /* Specifies whether condition numbers are required for the */ /* cluster of eigenvalues (S) or the invariant subspace (SEP): */ /* = 'N': none; */ /* = 'E': for eigenvalues only (S); */ /* = 'V': for invariant subspace only (SEP); */ /* = 'B': for both eigenvalues and invariant subspace (S and */ /* SEP). */ /* COMPQ (input) CHARACTER*1 */ /* = 'V': update the matrix Q of Schur vectors; */ /* = 'N': do not update Q. */ /* SELECT (input) LOGICAL array, dimension (N) */ /* SELECT specifies the eigenvalues in the selected cluster. To */ /* select a real eigenvalue w(j), SELECT(j) must be set to */ /* .TRUE.. To select a complex conjugate pair of eigenvalues */ /* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, */ /* either SELECT(j) or SELECT(j+1) or both must be set to */ /* .TRUE.; a complex conjugate pair of eigenvalues must be */ /* either both included in the cluster or both excluded. */ /* N (input) INTEGER */ /* The order of the matrix T. N >= 0. */ /* T (input/output) REAL array, dimension (LDT,N) */ /* On entry, the upper quasi-triangular matrix T, in Schur */ /* canonical form. */ /* On exit, T is overwritten by the reordered matrix T, again in */ /* Schur canonical form, with the selected eigenvalues in the */ /* leading diagonal blocks. */ /* LDT (input) INTEGER */ /* The leading dimension of the array T. LDT >= max(1,N). */ /* Q (input/output) REAL array, dimension (LDQ,N) */ /* On entry, if COMPQ = 'V', the matrix Q of Schur vectors. */ /* On exit, if COMPQ = 'V', Q has been postmultiplied by the */ /* orthogonal transformation matrix which reorders T; the */ /* leading M columns of Q form an orthonormal basis for the */ /* specified invariant subspace. */ /* If COMPQ = 'N', Q is not referenced. */ /* LDQ (input) INTEGER */ /* The leading dimension of the array Q. */ /* LDQ >= 1; and if COMPQ = 'V', LDQ >= N. */ /* WR (output) REAL array, dimension (N) */ /* WI (output) REAL array, dimension (N) */ /* The real and imaginary parts, respectively, of the reordered */ /* eigenvalues of T. The eigenvalues are stored in the same */ /* order as on the diagonal of T, with WR(i) = T(i,i) and, if */ /* T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and */ /* WI(i+1) = -WI(i). Note that if a complex eigenvalue is */ /* sufficiently ill-conditioned, then its value may differ */ /* significantly from its value before reordering. */ /* M (output) INTEGER */ /* The dimension of the specified invariant subspace. */ /* 0 < = M <= N. */ /* S (output) REAL */ /* If JOB = 'E' or 'B', S is a lower bound on the reciprocal */ /* condition number for the selected cluster of eigenvalues. */ /* S cannot underestimate the true reciprocal condition number */ /* by more than a factor of sqrt(N). If M = 0 or N, S = 1. */ /* If JOB = 'N' or 'V', S is not referenced. */ /* SEP (output) REAL */ /* If JOB = 'V' or 'B', SEP is the estimated reciprocal */ /* condition number of the specified invariant subspace. If */ /* M = 0 or N, SEP = norm(T). */ /* If JOB = 'N' or 'E', SEP is not referenced. */ /* WORK (workspace/output) REAL array, dimension (LWORK) */ /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ /* LWORK (input) INTEGER */ /* The dimension of the array WORK. */ /* If JOB = 'N', LWORK >= max(1,N); */ /* if JOB = 'E', LWORK >= M*(N-M); */ /* if JOB = 'V' or 'B', LWORK >= 2*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) INTEGER array, dimension (LIWORK) */ /* IF JOB = 'N' or 'E', IWORK is not referenced. */ /* LIWORK (input) INTEGER */ /* The dimension of the array IWORK. */ /* If JOB = 'N' or 'E', LIWORK >= 1; */ /* if JOB = 'V' or 'B', LIWORK >= 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 T failed because some eigenvalues are too */ /* close to separate (the problem is very ill-conditioned); */ /* T may have been partially reordered, and WR and WI */ /* contain the eigenvalues in the same order as in T; S and */ /* SEP (if requested) are set to zero. */ /* Further Details */ /* =============== */ /* STRSEN first collects the selected eigenvalues by computing an */ /* orthogonal transformation Z to move them to the top left corner of T. */ /* In other words, the selected eigenvalues are the eigenvalues of T11 */ /* in: */ /* Z'*T*Z = ( T11 T12 ) n1 */ /* ( 0 T22 ) n2 */ /* n1 n2 */ /* where N = n1+n2 and Z' means the transpose of Z. The first n1 columns */ /* of Z span the specified invariant subspace of T. */ /* If T has been obtained from the real Schur factorization of a matrix */ /* A = Q*T*Q', then the reordered real Schur factorization of A is given */ /* by A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span */ /* the corresponding invariant subspace of A. */ /* The reciprocal condition number of the average of the eigenvalues of */ /* T11 may be returned in S. S lies between 0 (very badly conditioned) */ /* and 1 (very well conditioned). It is computed as follows. First we */ /* compute R so that */ /* P = ( I R ) n1 */ /* ( 0 0 ) n2 */ /* n1 n2 */ /* is the projector on the invariant subspace associated with T11. */ /* R is the solution of the Sylvester equation: */ /* T11*R - R*T22 = T12. */ /* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote */ /* the two-norm of M. Then S is computed as the lower bound */ /* (1 + F-norm(R)**2)**(-1/2) */ /* on the reciprocal of 2-norm(P), the true reciprocal condition number. */ /* S cannot underestimate 1 / 2-norm(P) by more than a factor of */ /* sqrt(N). */ /* An approximate error bound for the computed average of the */ /* eigenvalues of T11 is */ /* EPS * norm(T) / S */ /* where EPS is the machine precision. */ /* The reciprocal condition number of the right invariant subspace */ /* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP. */ /* SEP is defined as the separation of T11 and T22: */ /* sep( T11, T22 ) = sigma-min( C ) */ /* where sigma-min(C) is the smallest singular value of the */ /* n1*n2-by-n1*n2 matrix */ /* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) ) */ /* I(m) is an m by m identity matrix, and kprod denotes the Kronecker */ /* product. We estimate sigma-min(C) by the reciprocal of an estimate of */ /* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C) */ /* cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2). */ /* When SEP is small, small changes in T can cause large changes in */ /* the invariant subspace. An approximate bound on the maximum angular */ /* error in the computed right invariant subspace is */ /* EPS * norm(T) / SEP */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Decode and test the input parameters */ /* Parameter adjustments */ --select; t_dim1 = *ldt; t_offset = 1 + t_dim1; t -= t_offset; q_dim1 = *ldq; q_offset = 1 + q_dim1; q -= q_offset; --wr; --wi; --work; --iwork; /* Function Body */ wantbh = lsame_(job, "B", (ftnlen)1, (ftnlen)1); wants = lsame_(job, "E", (ftnlen)1, (ftnlen)1) || wantbh; wantsp = lsame_(job, "V", (ftnlen)1, (ftnlen)1) || wantbh; wantq = lsame_(compq, "V", (ftnlen)1, (ftnlen)1); *info = 0; lquery = *lwork == -1; if (! lsame_(job, "N", (ftnlen)1, (ftnlen)1) && ! wants && ! wantsp) { *info = -1; } else if (! lsame_(compq, "N", (ftnlen)1, (ftnlen)1) && ! wantq) { *info = -2; } else if (*n < 0) { *info = -4; } else if (*ldt < max(1,*n)) { *info = -6; } else if (*ldq < 1 || wantq && *ldq < *n) { *info = -8; } else { /* Set M to the dimension of the specified invariant subspace, */ /* and test LWORK and LIWORK. */ *m = 0; pair = FALSE_; i__1 = *n; for (k = 1; k <= i__1; ++k) { if (pair) { pair = FALSE_; } else { if (k < *n) { if (t[k + 1 + k * t_dim1] == 0.f) { if (select[k]) { ++(*m); } } else { pair = TRUE_; if (select[k] || select[k + 1]) { *m += 2; } } } else { if (select[*n]) { ++(*m); } } } /* L10: */ } n1 = *m; n2 = *n - *m; nn = n1 * n2; if (wantsp) { /* Computing MAX */ i__1 = 1, i__2 = nn << 1; lwmin = max(i__1,i__2); liwmin = max(1,nn); } else if (lsame_(job, "N", (ftnlen)1, (ftnlen)1)) { lwmin = max(1,*n); liwmin = 1; } else if (lsame_(job, "E", (ftnlen)1, (ftnlen)1)) { lwmin = max(1,nn); liwmin = 1; } if (*lwork < lwmin && ! lquery) { *info = -15; } else if (*liwork < liwmin && ! lquery) { *info = -17; } } if (*info == 0) { work[1] = (real) lwmin; iwork[1] = liwmin; } if (*info != 0) { i__1 = -(*info); xerbla_("STRSEN", &i__1, (ftnlen)6); return 0; } else if (lquery) { return 0; } /* Quick return if possible. */ if (*m == *n || *m == 0) { if (wants) { *s = 1.f; } if (wantsp) { *sep = slange_("1", n, n, &t[t_offset], ldt, &work[1], (ftnlen)1); } goto L40; } /* Collect the selected blocks at the top-left corner of T. */ ks = 0; pair = FALSE_; i__1 = *n; for (k = 1; k <= i__1; ++k) { if (pair) { pair = FALSE_; } else { swap = select[k]; if (k < *n) { if (t[k + 1 + k * t_dim1] != 0.f) { pair = TRUE_; swap = swap || select[k + 1]; } } if (swap) { ++ks; /* Swap the K-th block to position KS. */ ierr = 0; kk = k; if (k != ks) { strexc_(compq, n, &t[t_offset], ldt, &q[q_offset], ldq, & kk, &ks, &work[1], &ierr, (ftnlen)1); } if (ierr == 1 || ierr == 2) { /* Blocks too close to swap: exit. */ *info = 1; if (wants) { *s = 0.f; } if (wantsp) { *sep = 0.f; } goto L40; } if (pair) { ++ks; } } } /* L20: */ } if (wants) { /* Solve Sylvester equation for R: */ /* T11*R - R*T22 = scale*T12 */ slacpy_("F", &n1, &n2, &t[(n1 + 1) * t_dim1 + 1], ldt, &work[1], &n1, (ftnlen)1); strsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, &ierr, (ftnlen)1, (ftnlen)1); /* Estimate the reciprocal of the condition number of the cluster */ /* of eigenvalues. */ rnorm = slange_("F", &n1, &n2, &work[1], &n1, &work[1], (ftnlen)1); if (rnorm == 0.f) { *s = 1.f; } else { *s = scale / (sqrt(scale * scale / rnorm + rnorm) * sqrt(rnorm)); } } if (wantsp) { /* Estimate sep(T11,T22). */ est = 0.f; kase = 0; L30: slacon_(&nn, &work[nn + 1], &work[1], &iwork[1], &est, &kase); if (kase != 0) { if (kase == 1) { /* Solve T11*R - R*T22 = scale*X. */ strsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, & ierr, (ftnlen)1, (ftnlen)1); } else { /* Solve T11'*R - R*T22' = scale*X. */ strsyl_("T", "T", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, & ierr, (ftnlen)1, (ftnlen)1); } goto L30; } *sep = scale / est; } L40: /* Store the output eigenvalues in WR and WI. */ i__1 = *n; for (k = 1; k <= i__1; ++k) { wr[k] = t[k + k * t_dim1]; wi[k] = 0.f; /* L50: */ } i__1 = *n - 1; for (k = 1; k <= i__1; ++k) { if (t[k + 1 + k * t_dim1] != 0.f) { wi[k] = sqrt((r__1 = t[k + (k + 1) * t_dim1], dabs(r__1))) * sqrt( (r__2 = t[k + 1 + k * t_dim1], dabs(r__2))); wi[k + 1] = -wi[k]; } /* L60: */ } work[1] = (real) lwmin; iwork[1] = liwmin; return 0; /* End of STRSEN */ } /* strsen_ */
/* Subroutine */ int stprfs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, real *ap, real *b, integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real *work, integer *iwork, integer *info, ftnlen uplo_len, ftnlen trans_len, ftnlen diag_len) { /* System generated locals */ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3; real r__1, r__2, r__3; /* Local variables */ static integer i__, j, k; static real s; static integer kc; static real xk; static integer nz; static real eps; static integer kase; static real safe1, safe2; extern logical lsame_(char *, char *, ftnlen, ftnlen); static logical upper; extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, integer *), saxpy_(integer *, real *, real *, integer *, real *, integer *), stpmv_(char *, char *, char *, integer *, real *, real *, integer *, ftnlen, ftnlen, ftnlen), stpsv_(char *, char *, char *, integer *, real *, real *, integer *, ftnlen, ftnlen, ftnlen); extern doublereal slamch_(char *, ftnlen); static real safmin; extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slacon_( integer *, real *, real *, integer *, real *, integer *); static logical notran; static char transt[1]; static logical nounit; static real lstres; /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* STPRFS 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 STPTRS or some other */ /* means before entering this routine. STPRFS 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 = 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) REAL 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)*(2*n-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) REAL 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) REAL 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) REAL array, dimension (3*N) */ /* IWORK (workspace) INTEGER array, dimension (N) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ --ap; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; x_dim1 = *ldx; x_offset = 1 + x_dim1; x -= x_offset; --ferr; --berr; --work; --iwork; /* Function Body */ *info = 0; upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1); notran = lsame_(trans, "N", (ftnlen)1, (ftnlen)1); nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1); if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) { *info = -1; } else if (! notran && ! lsame_(trans, "T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (ftnlen)1)) { *info = -2; } else if (! nounit && ! lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) { *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_("STPRFS", &i__1, (ftnlen)6); 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 *)transt = 'T'; } else { *(unsigned char *)transt = 'N'; } /* NZ = maximum number of nonzero elements in each row of A, plus 1 */ nz = *n + 1; eps = slamch_("Epsilon", (ftnlen)7); safmin = slamch_("Safe minimum", (ftnlen)12); 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 or A', depending on TRANS. */ scopy_(n, &x[j * x_dim1 + 1], &c__1, &work[*n + 1], &c__1); stpmv_(uplo, trans, diag, n, &ap[1], &work[*n + 1], &c__1, (ftnlen)1, (ftnlen)1, (ftnlen)1); saxpy_(n, &c_b19, &b[j * b_dim1 + 1], &c__1, &work[*n + 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__) { work[i__] = (r__1 = b[i__ + j * b_dim1], dabs(r__1)); /* 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) { xk = (r__1 = x[k + j * x_dim1], dabs(r__1)); i__3 = k; for (i__ = 1; i__ <= i__3; ++i__) { work[i__] += (r__1 = ap[kc + i__ - 1], dabs(r__1)) * xk; /* L30: */ } kc += k; /* L40: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { xk = (r__1 = x[k + j * x_dim1], dabs(r__1)); i__3 = k - 1; for (i__ = 1; i__ <= i__3; ++i__) { work[i__] += (r__1 = ap[kc + i__ - 1], dabs(r__1)) * xk; /* L50: */ } work[k] += xk; kc += k; /* L60: */ } } } else { kc = 1; if (nounit) { i__2 = *n; for (k = 1; k <= i__2; ++k) { xk = (r__1 = x[k + j * x_dim1], dabs(r__1)); i__3 = *n; for (i__ = k; i__ <= i__3; ++i__) { work[i__] += (r__1 = ap[kc + i__ - k], dabs(r__1)) * xk; /* L70: */ } kc = kc + *n - k + 1; /* L80: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { xk = (r__1 = x[k + j * x_dim1], dabs(r__1)); i__3 = *n; for (i__ = k + 1; i__ <= i__3; ++i__) { work[i__] += (r__1 = ap[kc + i__ - k], dabs(r__1)) * xk; /* L90: */ } work[k] += xk; kc = kc + *n - k + 1; /* L100: */ } } } } else { /* Compute abs(A')*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__) { s += (r__1 = ap[kc + i__ - 1], dabs(r__1)) * ( r__2 = x[i__ + j * x_dim1], dabs(r__2)); /* L110: */ } work[k] += s; kc += k; /* L120: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { s = (r__1 = x[k + j * x_dim1], dabs(r__1)); i__3 = k - 1; for (i__ = 1; i__ <= i__3; ++i__) { s += (r__1 = ap[kc + i__ - 1], dabs(r__1)) * ( r__2 = x[i__ + j * x_dim1], dabs(r__2)); /* L130: */ } work[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__) { s += (r__1 = ap[kc + i__ - k], dabs(r__1)) * ( r__2 = x[i__ + j * x_dim1], dabs(r__2)); /* L150: */ } work[k] += s; kc = kc + *n - k + 1; /* L160: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { s = (r__1 = x[k + j * x_dim1], dabs(r__1)); i__3 = *n; for (i__ = k + 1; i__ <= i__3; ++i__) { s += (r__1 = ap[kc + i__ - k], dabs(r__1)) * ( r__2 = x[i__ + j * x_dim1], dabs(r__2)); /* L170: */ } work[k] += s; kc = kc + *n - k + 1; /* L180: */ } } } } s = 0.f; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { if (work[i__] > safe2) { /* Computing MAX */ r__2 = s, r__3 = (r__1 = work[*n + i__], dabs(r__1)) / work[ i__]; s = dmax(r__2,r__3); } else { /* Computing MAX */ r__2 = s, r__3 = ((r__1 = work[*n + i__], dabs(r__1)) + safe1) / (work[i__] + safe1); s = dmax(r__2,r__3); } /* 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 SLACON 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 (work[i__] > safe2) { work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps * work[i__]; } else { work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps * work[i__] + safe1; } /* L200: */ } kase = 0; L210: slacon_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & kase); if (kase != 0) { if (kase == 1) { /* Multiply by diag(W)*inv(op(A)'). */ stpsv_(uplo, transt, diag, n, &ap[1], &work[*n + 1], &c__1, ( ftnlen)1, (ftnlen)1, (ftnlen)1); i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { work[*n + i__] = work[i__] * work[*n + i__]; /* L220: */ } } else { /* Multiply by inv(op(A))*diag(W). */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { work[*n + i__] = work[i__] * work[*n + i__]; /* L230: */ } stpsv_(uplo, trans, diag, n, &ap[1], &work[*n + 1], &c__1, ( ftnlen)1, (ftnlen)1, (ftnlen)1); } goto L210; } /* Normalize error. */ lstres = 0.f; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = lstres, r__3 = (r__1 = x[i__ + j * x_dim1], dabs(r__1)); lstres = dmax(r__2,r__3); /* L240: */ } if (lstres != 0.f) { ferr[j] /= lstres; } /* L250: */ } return 0; /* End of STPRFS */ } /* stprfs_ */