/* ===================================================================== */ real slangb_(char *norm, integer *n, integer *kl, integer *ku, real *ab, integer *ldab, real *work) { /* System generated locals */ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6; real ret_val, r__1; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ integer i__, j, k, l; real sum, temp, scale; extern logical lsame_(char *, char *); real value; extern logical sisnan_(real *); extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, real *); /* -- LAPACK auxiliary routine (version 3.4.2) -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ /* September 2012 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ ab_dim1 = *ldab; ab_offset = 1 + ab_dim1; ab -= ab_offset; --work; /* Function Body */ if (*n == 0) { value = 0.f; } else if (lsame_(norm, "M")) { /* Find max(abs(A(i,j))). */ value = 0.f; i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ i__2 = *ku + 2 - j; /* Computing MIN */ i__4 = *n + *ku + 1 - j; i__5 = *kl + *ku + 1; // , expr subst i__3 = min(i__4,i__5); for (i__ = max(i__2,1); i__ <= i__3; ++i__) { temp = (r__1 = ab[i__ + j * ab_dim1], abs(r__1)); if (value < temp || sisnan_(&temp)) { value = temp; } /* L10: */ } /* L20: */ } } else if (lsame_(norm, "O") || *(unsigned char *) norm == '1') { /* Find norm1(A). */ value = 0.f; i__1 = *n; for (j = 1; j <= i__1; ++j) { sum = 0.f; /* Computing MAX */ i__3 = *ku + 2 - j; /* Computing MIN */ i__4 = *n + *ku + 1 - j; i__5 = *kl + *ku + 1; // , expr subst i__2 = min(i__4,i__5); for (i__ = max(i__3,1); i__ <= i__2; ++i__) { sum += (r__1 = ab[i__ + j * ab_dim1], abs(r__1)); /* L30: */ } if (value < sum || sisnan_(&sum)) { value = sum; } /* L40: */ } } else if (lsame_(norm, "I")) { /* Find normI(A). */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.f; /* L50: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { k = *ku + 1 - j; /* Computing MAX */ i__2 = 1; i__3 = j - *ku; // , expr subst /* Computing MIN */ i__5 = *n; i__6 = j + *kl; // , expr subst i__4 = min(i__5,i__6); for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { work[i__] += (r__1 = ab[k + i__ + j * ab_dim1], abs(r__1)); /* L60: */ } /* L70: */ } value = 0.f; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { temp = work[i__]; if (value < temp || sisnan_(&temp)) { value = temp; } /* L80: */ } } else if (lsame_(norm, "F") || lsame_(norm, "E")) { /* Find normF(A). */ scale = 0.f; sum = 1.f; i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ i__4 = 1; i__2 = j - *ku; // , expr subst l = max(i__4,i__2); k = *ku + 1 - j + l; /* Computing MIN */ i__2 = *n; i__3 = j + *kl; // , expr subst i__4 = min(i__2,i__3) - l + 1; slassq_(&i__4, &ab[k + j * ab_dim1], &c__1, &scale, &sum); /* L90: */ } value = scale * sqrt(sum); } ret_val = value; return ret_val; /* End of SLANGB */ }
doublereal slansy_(char *norm, char *uplo, int *n, real *a, int *lda, real *work) { /* -- LAPACK auxiliary routine (version 2.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University October 31, 1992 Purpose ======= SLANSY returns the value of the one norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric matrix A. Description =========== SLANSY returns the value SLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm' ( ( norm1(A), NORM = '1', 'O' or 'o' ( ( normI(A), NORM = 'I' or 'i' ( ( normF(A), NORM = 'F', 'f', 'E' or 'e' where norm1 denotes the one norm of a matrix (maximum column sum), normI denotes the infinity norm of a matrix (maximum row sum) and normF denotes the Frobenius norm of a matrix (square root of sum of squares). Note that max(abs(A(i,j))) is not a matrix norm. Arguments ========= NORM (input) CHARACTER*1 Specifies the value to be returned in SLANSY as described above. UPLO (input) CHARACTER*1 Specifies whether the upper or lower triangular part of the symmetric matrix A is to be referenced. = 'U': Upper triangular part of A is referenced = 'L': Lower triangular part of A is referenced N (input) INTEGER The order of the matrix A. N >= 0. When N = 0, SLANSY is set to zero. 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(N,1). WORK (workspace) REAL array, dimension (LWORK), where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, WORK is not referenced. ===================================================================== Parameter adjustments Function Body */ /* Table of constant values */ static int c__1 = 1; /* System generated locals */ /* Unused variables commented out by MDG on 03-09-05 int a_dim1, a_offset; */ int i__1, i__2; real ret_val, r__1, r__2, r__3; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static real absa; static int i, j; static real scale; extern logical lsame_(char *, char *); static real value; extern /* Subroutine */ int slassq_(int *, real *, int *, real *, real *); static real sum; #define WORK(I) work[(I)-1] #define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)] if (*n == 0) { value = 0.f; } else if (lsame_(norm, "M")) { /* Find max(abs(A(i,j))). */ value = 0.f; if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= *n; ++j) { i__2 = j; for (i = 1; i <= j; ++i) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = A(i,j), dabs(r__1) ); value = dmax(r__2,r__3); /* L10: */ } /* L20: */ } } else { i__1 = *n; for (j = 1; j <= *n; ++j) { i__2 = *n; for (i = j; i <= *n; ++i) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = A(i,j), dabs(r__1) ); value = dmax(r__2,r__3); /* L30: */ } /* L40: */ } } } else if (lsame_(norm, "I") || lsame_(norm, "O") || *( unsigned char *)norm == '1') { /* Find normI(A) ( = norm1(A), since A is symmetric). */ value = 0.f; if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= *n; ++j) { sum = 0.f; i__2 = j - 1; for (i = 1; i <= j-1; ++i) { absa = (r__1 = A(i,j), dabs(r__1)); sum += absa; WORK(i) += absa; /* L50: */ } WORK(j) = sum + (r__1 = A(j,j), dabs(r__1)); /* L60: */ } i__1 = *n; for (i = 1; i <= *n; ++i) { /* Computing MAX */ r__1 = value, r__2 = WORK(i); value = dmax(r__1,r__2); /* L70: */ } } else { i__1 = *n; for (i = 1; i <= *n; ++i) { WORK(i) = 0.f; /* L80: */ } i__1 = *n; for (j = 1; j <= *n; ++j) { sum = WORK(j) + (r__1 = A(j,j), dabs(r__1)); i__2 = *n; for (i = j + 1; i <= *n; ++i) { absa = (r__1 = A(i,j), dabs(r__1)); sum += absa; WORK(i) += absa; /* L90: */ } value = dmax(value,sum); /* L100: */ } } } else if (lsame_(norm, "F") || lsame_(norm, "E")) { /* Find normF(A). */ scale = 0.f; sum = 1.f; if (lsame_(uplo, "U")) { i__1 = *n; for (j = 2; j <= *n; ++j) { i__2 = j - 1; slassq_(&i__2, &A(1,j), &c__1, &scale, &sum); /* L110: */ } } else { i__1 = *n - 1; for (j = 1; j <= *n-1; ++j) { i__2 = *n - j; slassq_(&i__2, &A(j+1,j), &c__1, &scale, &sum); /* L120: */ } } sum *= 2; i__1 = *lda + 1; slassq_(n, &A(1,1), &i__1, &scale, &sum); value = scale * sqrt(sum); } ret_val = value; return ret_val; /* End of SLANSY */ } /* slansy_ */
double slanst_(char *norm, int *n, float *d__, float *e) { /* System generated locals */ int i__1; float ret_val, r__1, r__2, r__3, r__4, r__5; /* Builtin functions */ double sqrt(double); /* Local variables */ int i__; float sum, scale; extern int lsame_(char *, char *); float anorm; extern int slassq_(int *, float *, int *, float *, float *); /* -- LAPACK auxiliary routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* SLANST returns the value of the one norm, or the Frobenius norm, or */ /* the infinity norm, or the element of largest absolute value of a */ /* float symmetric tridiagonal matrix A. */ /* Description */ /* =========== */ /* SLANST returns the value */ /* SLANST = ( MAX(ABS(A(i,j))), NORM = 'M' or 'm' */ /* ( */ /* ( norm1(A), NORM = '1', 'O' or 'o' */ /* ( */ /* ( normI(A), NORM = 'I' or 'i' */ /* ( */ /* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ /* where norm1 denotes the one norm of a matrix (maximum column sum), */ /* normI denotes the infinity norm of a matrix (maximum row sum) and */ /* normF denotes the Frobenius norm of a matrix (square root of sum of */ /* squares). Note that MAX(ABS(A(i,j))) is not a consistent matrix norm. */ /* Arguments */ /* ========= */ /* NORM (input) CHARACTER*1 */ /* Specifies the value to be returned in SLANST as described */ /* above. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. When N = 0, SLANST is */ /* set to zero. */ /* D (input) REAL array, dimension (N) */ /* The diagonal elements of A. */ /* E (input) REAL array, dimension (N-1) */ /* The (n-1) sub-diagonal or super-diagonal elements of A. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ --e; --d__; /* Function Body */ if (*n <= 0) { anorm = 0.f; } else if (lsame_(norm, "M")) { /* Find MAX(ABS(A(i,j))). */ anorm = (r__1 = d__[*n], ABS(r__1)); i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { /* Computing MAX */ r__2 = anorm, r__3 = (r__1 = d__[i__], ABS(r__1)); anorm = MAX(r__2,r__3); /* Computing MAX */ r__2 = anorm, r__3 = (r__1 = e[i__], ABS(r__1)); anorm = MAX(r__2,r__3); /* L10: */ } } else if (lsame_(norm, "O") || *(unsigned char *) norm == '1' || lsame_(norm, "I")) { /* Find norm1(A). */ if (*n == 1) { anorm = ABS(d__[1]); } else { /* Computing MAX */ r__3 = ABS(d__[1]) + ABS(e[1]), r__4 = (r__1 = e[*n - 1], ABS( r__1)) + (r__2 = d__[*n], ABS(r__2)); anorm = MAX(r__3,r__4); i__1 = *n - 1; for (i__ = 2; i__ <= i__1; ++i__) { /* Computing MAX */ r__4 = anorm, r__5 = (r__1 = d__[i__], ABS(r__1)) + (r__2 = e[i__], ABS(r__2)) + (r__3 = e[i__ - 1], ABS(r__3)); anorm = MAX(r__4,r__5); /* L20: */ } } } else if (lsame_(norm, "F") || lsame_(norm, "E")) { /* Find normF(A). */ scale = 0.f; sum = 1.f; if (*n > 1) { i__1 = *n - 1; slassq_(&i__1, &e[1], &c__1, &scale, &sum); sum *= 2; } slassq_(n, &d__[1], &c__1, &scale, &sum); anorm = scale * sqrt(sum); } ret_val = anorm; return ret_val; /* End of SLANST */ } /* slanst_ */
/* Subroutine */ int slatdf_(integer *ijob, integer *n, real *z__, integer * ldz, real *rhs, real *rdsum, real *rdscal, integer *ipiv, integer * jpiv) { /* -- LAPACK auxiliary routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University June 30, 1999 Purpose ======= SLATDF uses the LU factorization of the n-by-n matrix Z computed by SGETC2 and computes a contribution to the reciprocal Dif-estimate by solving Z * x = b for x, and choosing the r.h.s. b such that the norm of x is as large as possible. On entry RHS = b holds the contribution from earlier solved sub-systems, and on return RHS = x. The factorization of Z returned by SGETC2 has the form Z = P*L*U*Q, where P and Q are permutation matrices. L is lower triangular with unit diagonal elements and U is upper triangular. Arguments ========= IJOB (input) INTEGER IJOB = 2: First compute an approximative null-vector e of Z using SGECON, e is normalized and solve for Zx = +-e - f with the sign giving the greater value of 2-norm(x). About 5 times as expensive as Default. IJOB .ne. 2: Local look ahead strategy where all entries of the r.h.s. b is choosen as either +1 or -1 (Default). N (input) INTEGER The number of columns of the matrix Z. Z (input) REAL array, dimension (LDZ, N) On entry, the LU part of the factorization of the n-by-n matrix Z computed by SGETC2: Z = P * L * U * Q LDZ (input) INTEGER The leading dimension of the array Z. LDA >= max(1, N). RHS (input/output) REAL array, dimension N. On entry, RHS contains contributions from other subsystems. On exit, RHS contains the solution of the subsystem with entries acoording to the value of IJOB (see above). RDSUM (input/output) REAL On entry, the sum of squares of computed contributions to the Dif-estimate under computation by STGSYL, where the scaling factor RDSCAL (see below) has been factored out. On exit, the corresponding sum of squares updated with the contributions from the current sub-system. If TRANS = 'T' RDSUM is not touched. NOTE: RDSUM only makes sense when STGSY2 is called by STGSYL. RDSCAL (input/output) REAL On entry, scaling factor used to prevent overflow in RDSUM. On exit, RDSCAL is updated w.r.t. the current contributions in RDSUM. If TRANS = 'T', RDSCAL is not touched. NOTE: RDSCAL only makes sense when STGSY2 is called by STGSYL. IPIV (input) INTEGER array, dimension (N). The pivot indices; for 1 <= i <= N, row i of the matrix has been interchanged with row IPIV(i). JPIV (input) INTEGER array, dimension (N). The pivot indices; for 1 <= j <= N, column j of the matrix has been interchanged with column JPIV(j). Further Details =============== Based on contributions by Bo Kagstrom and Peter Poromaa, Department of Computing Science, Umea University, S-901 87 Umea, Sweden. This routine is a further developed implementation of algorithm BSOLVE in [1] using complete pivoting in the LU factorization. [1] Bo Kagstrom and Lars Westin, Generalized Schur Methods with Condition Estimators for Solving the Generalized Sylvester Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751. [2] Peter Poromaa, On Efficient and Robust Estimators for the Separation between two Regular Matrix Pairs with Applications in Condition Estimation. Report IMINF-95.05, Departement of Computing Science, Umea University, S-901 87 Umea, Sweden, 1995. ===================================================================== Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; static integer c_n1 = -1; static real c_b23 = 1.f; static real c_b37 = -1.f; /* System generated locals */ integer z_dim1, z_offset, i__1, i__2; real r__1; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static integer info; static real temp; extern doublereal sdot_(integer *, real *, integer *, real *, integer *); static real work[32]; static integer i__, j, k; extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); static real pmone; extern doublereal sasum_(integer *, real *, integer *); static real sminu; static integer iwork[8]; extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, integer *), saxpy_(integer *, real *, real *, integer *, real *, integer *); static real splus; extern /* Subroutine */ int sgesc2_(integer *, real *, integer *, real *, integer *, integer *, real *); static real bm, bp, xm[8], xp[8]; extern /* Subroutine */ int sgecon_(char *, integer *, real *, integer *, real *, real *, real *, integer *, integer *), slassq_( integer *, real *, integer *, real *, real *), slaswp_(integer *, real *, integer *, integer *, integer *, integer *, integer *); #define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1] z_dim1 = *ldz; z_offset = 1 + z_dim1 * 1; z__ -= z_offset; --rhs; --ipiv; --jpiv; /* Function Body */ if (*ijob != 2) { /* Apply permutations IPIV to RHS */ i__1 = *n - 1; slaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &ipiv[1], &c__1); /* Solve for L-part choosing RHS either to +1 or -1. */ pmone = -1.f; i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { bp = rhs[j] + 1.f; bm = rhs[j] - 1.f; splus = 1.f; /* Look-ahead for L-part RHS(1:N-1) = + or -1, SPLUS and SMIN computed more efficiently than in BSOLVE [1]. */ i__2 = *n - j; splus += sdot_(&i__2, &z___ref(j + 1, j), &c__1, &z___ref(j + 1, j), &c__1); i__2 = *n - j; sminu = sdot_(&i__2, &z___ref(j + 1, j), &c__1, &rhs[j + 1], & c__1); splus *= rhs[j]; if (splus > sminu) { rhs[j] = bp; } else if (sminu > splus) { rhs[j] = bm; } else { /* In this case the updating sums are equal and we can choose RHS(J) +1 or -1. The first time this happens we choose -1, thereafter +1. This is a simple way to get good estimates of matrices like Byers well-known example (see [1]). (Not done in BSOLVE.) */ rhs[j] += pmone; pmone = 1.f; } /* Compute the remaining r.h.s. */ temp = -rhs[j]; i__2 = *n - j; saxpy_(&i__2, &temp, &z___ref(j + 1, j), &c__1, &rhs[j + 1], & c__1); /* L10: */ } /* Solve for U-part, look-ahead for RHS(N) = +-1. This is not done in BSOLVE and will hopefully give us a better estimate because any ill-conditioning of the original matrix is transfered to U and not to L. U(N, N) is an approximation to sigma_min(LU). */ i__1 = *n - 1; scopy_(&i__1, &rhs[1], &c__1, xp, &c__1); xp[*n - 1] = rhs[*n] + 1.f; rhs[*n] += -1.f; splus = 0.f; sminu = 0.f; for (i__ = *n; i__ >= 1; --i__) { temp = 1.f / z___ref(i__, i__); xp[i__ - 1] *= temp; rhs[i__] *= temp; i__1 = *n; for (k = i__ + 1; k <= i__1; ++k) { xp[i__ - 1] -= xp[k - 1] * (z___ref(i__, k) * temp); rhs[i__] -= rhs[k] * (z___ref(i__, k) * temp); /* L20: */ } splus += (r__1 = xp[i__ - 1], dabs(r__1)); sminu += (r__1 = rhs[i__], dabs(r__1)); /* L30: */ } if (splus > sminu) { scopy_(n, xp, &c__1, &rhs[1], &c__1); } /* Apply the permutations JPIV to the computed solution (RHS) */ i__1 = *n - 1; slaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &jpiv[1], &c_n1); /* Compute the sum of squares */ slassq_(n, &rhs[1], &c__1, rdscal, rdsum); } else { /* IJOB = 2, Compute approximate nullvector XM of Z */ sgecon_("I", n, &z__[z_offset], ldz, &c_b23, &temp, work, iwork, & info); scopy_(n, &work[*n], &c__1, xm, &c__1); /* Compute RHS */ i__1 = *n - 1; slaswp_(&c__1, xm, ldz, &c__1, &i__1, &ipiv[1], &c_n1); temp = 1.f / sqrt(sdot_(n, xm, &c__1, xm, &c__1)); sscal_(n, &temp, xm, &c__1); scopy_(n, xm, &c__1, xp, &c__1); saxpy_(n, &c_b23, &rhs[1], &c__1, xp, &c__1); saxpy_(n, &c_b37, xm, &c__1, &rhs[1], &c__1); sgesc2_(n, &z__[z_offset], ldz, &rhs[1], &ipiv[1], &jpiv[1], &temp); sgesc2_(n, &z__[z_offset], ldz, xp, &ipiv[1], &jpiv[1], &temp); if (sasum_(n, xp, &c__1) > sasum_(n, &rhs[1], &c__1)) { scopy_(n, xp, &c__1, &rhs[1], &c__1); } /* Compute the sum of squares */ slassq_(n, &rhs[1], &c__1, rdscal, rdsum); } return 0; /* End of SLATDF */ } /* slatdf_ */
doublereal slantr_(char *norm, char *uplo, char *diag, integer *m, integer *n, real *a, integer *lda, real *work) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4; real ret_val, r__1, r__2, r__3; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ integer i__, j; real sum, scale; logical udiag; extern logical lsame_(char *, char *); real value; extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, real *); /* -- LAPACK auxiliary routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* SLANTR returns the value of the one norm, or the Frobenius norm, or */ /* the infinity norm, or the element of largest absolute value of a */ /* trapezoidal or triangular matrix A. */ /* Description */ /* =========== */ /* SLANTR returns the value */ /* SLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ /* ( */ /* ( norm1(A), NORM = '1', 'O' or 'o' */ /* ( */ /* ( normI(A), NORM = 'I' or 'i' */ /* ( */ /* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ /* where norm1 denotes the one norm of a matrix (maximum column sum), */ /* normI denotes the infinity norm of a matrix (maximum row sum) and */ /* normF denotes the Frobenius norm of a matrix (square root of sum of */ /* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ /* Arguments */ /* ========= */ /* NORM (input) CHARACTER*1 */ /* Specifies the value to be returned in SLANTR as described */ /* above. */ /* UPLO (input) CHARACTER*1 */ /* Specifies whether the matrix A is upper or lower trapezoidal. */ /* = 'U': Upper trapezoidal */ /* = 'L': Lower trapezoidal */ /* Note that A is triangular instead of trapezoidal if M = N. */ /* DIAG (input) CHARACTER*1 */ /* Specifies whether or not the matrix A has unit diagonal. */ /* = 'N': Non-unit diagonal */ /* = 'U': Unit diagonal */ /* M (input) INTEGER */ /* The number of rows of the matrix A. M >= 0, and if */ /* UPLO = 'U', M <= N. When M = 0, SLANTR is set to zero. */ /* N (input) INTEGER */ /* The number of columns of the matrix A. N >= 0, and if */ /* UPLO = 'L', N <= M. When N = 0, SLANTR is set to zero. */ /* A (input) REAL array, dimension (LDA,N) */ /* The trapezoidal matrix A (A is triangular if M = N). */ /* If UPLO = 'U', the leading m by n upper trapezoidal part of */ /* the array A contains the upper trapezoidal matrix, and the */ /* strictly lower triangular part of A is not referenced. */ /* If UPLO = 'L', the leading m by n lower trapezoidal part of */ /* the array A contains the lower trapezoidal matrix, and the */ /* strictly upper triangular part of A is not referenced. Note */ /* that when DIAG = 'U', the diagonal elements of A are not */ /* referenced and are assumed to be one. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(M,1). */ /* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */ /* where LWORK >= M when NORM = 'I'; otherwise, WORK is not */ /* referenced. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --work; /* Function Body */ if (min(*m,*n) == 0) { value = 0.f; } else if (lsame_(norm, "M")) { /* Find max(abs(A(i,j))). */ if (lsame_(diag, "U")) { value = 1.f; if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ i__3 = *m, i__4 = j - 1; i__2 = min(i__3,i__4); for (i__ = 1; i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1)); value = dmax(r__2,r__3); /* L10: */ } /* L20: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = j + 1; i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1)); value = dmax(r__2,r__3); /* L30: */ } /* L40: */ } } } else { value = 0.f; if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = min(*m,j); for (i__ = 1; i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1)); value = dmax(r__2,r__3); /* L50: */ } /* L60: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = j; i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1)); value = dmax(r__2,r__3); /* L70: */ } /* L80: */ } } } } else if (lsame_(norm, "O") || *(unsigned char *) norm == '1') { /* Find norm1(A). */ value = 0.f; udiag = lsame_(diag, "U"); if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (udiag && j <= *m) { sum = 1.f; i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { sum += (r__1 = a[i__ + j * a_dim1], dabs(r__1)); /* L90: */ } } else { sum = 0.f; i__2 = min(*m,j); for (i__ = 1; i__ <= i__2; ++i__) { sum += (r__1 = a[i__ + j * a_dim1], dabs(r__1)); /* L100: */ } } value = dmax(value,sum); /* L110: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (udiag) { sum = 1.f; i__2 = *m; for (i__ = j + 1; i__ <= i__2; ++i__) { sum += (r__1 = a[i__ + j * a_dim1], dabs(r__1)); /* L120: */ } } else { sum = 0.f; i__2 = *m; for (i__ = j; i__ <= i__2; ++i__) { sum += (r__1 = a[i__ + j * a_dim1], dabs(r__1)); /* L130: */ } } value = dmax(value,sum); /* L140: */ } } } else if (lsame_(norm, "I")) { /* Find normI(A). */ if (lsame_(uplo, "U")) { if (lsame_(diag, "U")) { i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 1.f; /* L150: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ i__3 = *m, i__4 = j - 1; i__2 = min(i__3,i__4); for (i__ = 1; i__ <= i__2; ++i__) { work[i__] += (r__1 = a[i__ + j * a_dim1], dabs(r__1)); /* L160: */ } /* L170: */ } } else { i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.f; /* L180: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = min(*m,j); for (i__ = 1; i__ <= i__2; ++i__) { work[i__] += (r__1 = a[i__ + j * a_dim1], dabs(r__1)); /* L190: */ } /* L200: */ } } } else { if (lsame_(diag, "U")) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 1.f; /* L210: */ } i__1 = *m; for (i__ = *n + 1; i__ <= i__1; ++i__) { work[i__] = 0.f; /* L220: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = j + 1; i__ <= i__2; ++i__) { work[i__] += (r__1 = a[i__ + j * a_dim1], dabs(r__1)); /* L230: */ } /* L240: */ } } else { i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.f; /* L250: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = j; i__ <= i__2; ++i__) { work[i__] += (r__1 = a[i__ + j * a_dim1], dabs(r__1)); /* L260: */ } /* L270: */ } } } value = 0.f; i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { /* Computing MAX */ r__1 = value, r__2 = work[i__]; value = dmax(r__1,r__2); /* L280: */ } } else if (lsame_(norm, "F") || lsame_(norm, "E")) { /* Find normF(A). */ if (lsame_(uplo, "U")) { if (lsame_(diag, "U")) { scale = 1.f; sum = (real) min(*m,*n); i__1 = *n; for (j = 2; j <= i__1; ++j) { /* Computing MIN */ i__3 = *m, i__4 = j - 1; i__2 = min(i__3,i__4); slassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum); /* L290: */ } } else { scale = 0.f; sum = 1.f; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = min(*m,j); slassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum); /* L300: */ } } } else { if (lsame_(diag, "U")) { scale = 1.f; sum = (real) min(*m,*n); i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m - j; /* Computing MIN */ i__3 = *m, i__4 = j + 1; slassq_(&i__2, &a[min(i__3, i__4)+ j * a_dim1], &c__1, & scale, &sum); /* L310: */ } } else { scale = 0.f; sum = 1.f; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m - j + 1; slassq_(&i__2, &a[j + j * a_dim1], &c__1, &scale, &sum); /* L320: */ } } } value = scale * sqrt(sum); } ret_val = value; return ret_val; /* End of SLANTR */ } /* slantr_ */
/* ===================================================================== */ real slantp_(char *norm, char *uplo, char *diag, integer *n, real *ap, real * work) { /* System generated locals */ integer i__1, i__2; real ret_val, r__1; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ integer i__, j, k; real sum, scale; logical udiag; extern logical lsame_(char *, char *); real value; extern logical sisnan_(real *); extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, real *); /* -- LAPACK auxiliary routine (version 3.4.2) -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ /* September 2012 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ --work; --ap; /* Function Body */ if (*n == 0) { value = 0.f; } else if (lsame_(norm, "M")) { /* Find max(f2c_abs(A(i,j))). */ k = 1; if (lsame_(diag, "U")) { value = 1.f; if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = k + j - 2; for (i__ = k; i__ <= i__2; ++i__) { sum = (r__1 = ap[i__], f2c_abs(r__1)); if (value < sum || sisnan_(&sum)) { value = sum; } /* L10: */ } k += j; /* L20: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = k + *n - j; for (i__ = k + 1; i__ <= i__2; ++i__) { sum = (r__1 = ap[i__], f2c_abs(r__1)); if (value < sum || sisnan_(&sum)) { value = sum; } /* L30: */ } k = k + *n - j + 1; /* L40: */ } } } else { value = 0.f; if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = k + j - 1; for (i__ = k; i__ <= i__2; ++i__) { sum = (r__1 = ap[i__], f2c_abs(r__1)); if (value < sum || sisnan_(&sum)) { value = sum; } /* L50: */ } k += j; /* L60: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = k + *n - j; for (i__ = k; i__ <= i__2; ++i__) { sum = (r__1 = ap[i__], f2c_abs(r__1)); if (value < sum || sisnan_(&sum)) { value = sum; } /* L70: */ } k = k + *n - j + 1; /* L80: */ } } } } else if (lsame_(norm, "O") || *(unsigned char *) norm == '1') { /* Find norm1(A). */ value = 0.f; k = 1; udiag = lsame_(diag, "U"); if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (udiag) { sum = 1.f; i__2 = k + j - 2; for (i__ = k; i__ <= i__2; ++i__) { sum += (r__1 = ap[i__], f2c_abs(r__1)); /* L90: */ } } else { sum = 0.f; i__2 = k + j - 1; for (i__ = k; i__ <= i__2; ++i__) { sum += (r__1 = ap[i__], f2c_abs(r__1)); /* L100: */ } } k += j; if (value < sum || sisnan_(&sum)) { value = sum; } /* L110: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (udiag) { sum = 1.f; i__2 = k + *n - j; for (i__ = k + 1; i__ <= i__2; ++i__) { sum += (r__1 = ap[i__], f2c_abs(r__1)); /* L120: */ } } else { sum = 0.f; i__2 = k + *n - j; for (i__ = k; i__ <= i__2; ++i__) { sum += (r__1 = ap[i__], f2c_abs(r__1)); /* L130: */ } } k = k + *n - j + 1; if (value < sum || sisnan_(&sum)) { value = sum; } /* L140: */ } } } else if (lsame_(norm, "I")) { /* Find normI(A). */ k = 1; if (lsame_(uplo, "U")) { if (lsame_(diag, "U")) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 1.f; /* L150: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { work[i__] += (r__1 = ap[k], f2c_abs(r__1)); ++k; /* L160: */ } ++k; /* L170: */ } } else { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.f; /* L180: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j; for (i__ = 1; i__ <= i__2; ++i__) { work[i__] += (r__1 = ap[k], f2c_abs(r__1)); ++k; /* L190: */ } /* L200: */ } } } else { if (lsame_(diag, "U")) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 1.f; /* L210: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { ++k; i__2 = *n; for (i__ = j + 1; i__ <= i__2; ++i__) { work[i__] += (r__1 = ap[k], f2c_abs(r__1)); ++k; /* L220: */ } /* L230: */ } } else { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.f; /* L240: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { work[i__] += (r__1 = ap[k], f2c_abs(r__1)); ++k; /* L250: */ } /* L260: */ } } } value = 0.f; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { sum = work[i__]; if (value < sum || sisnan_(&sum)) { value = sum; } /* L270: */ } } else if (lsame_(norm, "F") || lsame_(norm, "E")) { /* Find normF(A). */ if (lsame_(uplo, "U")) { if (lsame_(diag, "U")) { scale = 1.f; sum = (real) (*n); k = 2; i__1 = *n; for (j = 2; j <= i__1; ++j) { i__2 = j - 1; slassq_(&i__2, &ap[k], &c__1, &scale, &sum); k += j; /* L280: */ } } else { scale = 0.f; sum = 1.f; k = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { slassq_(&j, &ap[k], &c__1, &scale, &sum); k += j; /* L290: */ } } } else { if (lsame_(diag, "U")) { scale = 1.f; sum = (real) (*n); k = 2; i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { i__2 = *n - j; slassq_(&i__2, &ap[k], &c__1, &scale, &sum); k = k + *n - j + 1; /* L300: */ } } else { scale = 0.f; sum = 1.f; k = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *n - j + 1; slassq_(&i__2, &ap[k], &c__1, &scale, &sum); k = k + *n - j + 1; /* L310: */ } } } value = scale * sqrt(sum); } ret_val = value; return ret_val; /* End of SLANTP */ }
doublereal slangb_(char *norm, integer *n, integer *kl, integer *ku, real *ab, integer *ldab, real *work) { /* System generated locals */ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6; real ret_val, r__1, r__2, r__3; /* Local variables */ integer i__, j, k, l; real sum, scale; real value; /* -- LAPACK auxiliary routine (version 3.2) -- */ /* November 2006 */ /* Purpose */ /* ======= */ /* SLANGB returns the value of the one norm, or the Frobenius norm, or */ /* the infinity norm, or the element of largest absolute value of an */ /* n by n band matrix A, with kl sub-diagonals and ku super-diagonals. */ /* Description */ /* =========== */ /* SLANGB returns the value */ /* SLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ /* ( */ /* ( norm1(A), NORM = '1', 'O' or 'o' */ /* ( */ /* ( normI(A), NORM = 'I' or 'i' */ /* ( */ /* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ /* where norm1 denotes the one norm of a matrix (maximum column sum), */ /* normI denotes the infinity norm of a matrix (maximum row sum) and */ /* normF denotes the Frobenius norm of a matrix (square root of sum of */ /* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ /* Arguments */ /* ========= */ /* NORM (input) CHARACTER*1 */ /* Specifies the value to be returned in SLANGB as described */ /* above. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. When N = 0, SLANGB is */ /* set to zero. */ /* KL (input) INTEGER */ /* The number of sub-diagonals of the matrix A. KL >= 0. */ /* KU (input) INTEGER */ /* The number of super-diagonals of the matrix A. KU >= 0. */ /* AB (input) REAL array, dimension (LDAB,N) */ /* The band matrix A, stored in rows 1 to KL+KU+1. The j-th */ /* column of A is stored in the j-th column of the array AB as */ /* follows: */ /* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */ /* LDAB (input) INTEGER */ /* The leading dimension of the array AB. LDAB >= KL+KU+1. */ /* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */ /* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */ /* referenced. */ /* ===================================================================== */ /* Parameter adjustments */ ab_dim1 = *ldab; ab_offset = 1 + ab_dim1; ab -= ab_offset; --work; /* Function Body */ if (*n == 0) { value = 0.f; } else if (lsame_(norm, "M")) { /* Find max(abs(A(i,j))). */ value = 0.f; i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ i__2 = *ku + 2 - j; /* Computing MIN */ i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1; i__3 = min(i__4,i__5); for (i__ = max(i__2,1); i__ <= i__3; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = ab[i__ + j * ab_dim1], dabs(r__1) ); value = dmax(r__2,r__3); } } } else if (lsame_(norm, "O") || *(unsigned char *) norm == '1') { /* Find norm1(A). */ value = 0.f; i__1 = *n; for (j = 1; j <= i__1; ++j) { sum = 0.f; /* Computing MAX */ i__3 = *ku + 2 - j; /* Computing MIN */ i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1; i__2 = min(i__4,i__5); for (i__ = max(i__3,1); i__ <= i__2; ++i__) { sum += (r__1 = ab[i__ + j * ab_dim1], dabs(r__1)); } value = dmax(value,sum); } } else if (lsame_(norm, "I")) { /* Find normI(A). */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.f; } i__1 = *n; for (j = 1; j <= i__1; ++j) { k = *ku + 1 - j; /* Computing MAX */ i__2 = 1, i__3 = j - *ku; /* Computing MIN */ i__5 = *n, i__6 = j + *kl; i__4 = min(i__5,i__6); for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { work[i__] += (r__1 = ab[k + i__ + j * ab_dim1], dabs(r__1)); } } value = 0.f; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { /* Computing MAX */ r__1 = value, r__2 = work[i__]; value = dmax(r__1,r__2); } } else if (lsame_(norm, "F") || lsame_(norm, "E")) { /* Find normF(A). */ scale = 0.f; sum = 1.f; i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ i__4 = 1, i__2 = j - *ku; l = max(i__4,i__2); k = *ku + 1 - j + l; /* Computing MIN */ i__2 = *n, i__3 = j + *kl; i__4 = min(i__2,i__3) - l + 1; slassq_(&i__4, &ab[k + j * ab_dim1], &c__1, &scale, &sum); } value = scale * sqrt(sum); } ret_val = value; return ret_val; /* End of SLANGB */ } /* slangb_ */
/* Subroutine */ int stgex2_(logical *wantq, logical *wantz, integer *n, real *a, integer *lda, real *b, integer *ldb, real *q, integer *ldq, real * z__, integer *ldz, integer *j1, integer *n1, integer *n2, real *work, integer *lwork, integer *info) { /* -- LAPACK auxiliary routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University June 30, 1999 Purpose ======= STGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22) of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair (A, B) by an orthogonal equivalence transformation. (A, B) must be in generalized real Schur canonical form (as returned by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper triangular. Optionally, the matrices Q and Z of generalized Schur vectors are updated. Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)' Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)' Arguments ========= WANTQ (input) LOGICAL .TRUE. : update the left transformation matrix Q; .FALSE.: do not update Q. WANTZ (input) LOGICAL .TRUE. : update the right transformation matrix Z; .FALSE.: do not update Z. N (input) INTEGER The order of the matrices A and B. N >= 0. A (input/output) REAL arrays, dimensions (LDA,N) On entry, the matrix A in the pair (A, B). On exit, the updated matrix A. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,N). B (input/output) REAL arrays, dimensions (LDB,N) On entry, the matrix B in the pair (A, B). On exit, the updated matrix B. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,N). Q (input/output) REAL array, dimension (LDZ,N) On entry, if WANTQ = .TRUE., the orthogonal matrix Q. On exit, the updated matrix Q. Not referenced if WANTQ = .FALSE.. LDQ (input) INTEGER The leading dimension of the array Q. LDQ >= 1. If WANTQ = .TRUE., LDQ >= N. Z (input/output) REAL array, dimension (LDZ,N) On entry, if WANTZ =.TRUE., the orthogonal matrix Z. On exit, the updated matrix Z. Not referenced if WANTZ = .FALSE.. LDZ (input) INTEGER The leading dimension of the array Z. LDZ >= 1. If WANTZ = .TRUE., LDZ >= N. J1 (input) INTEGER The index to the first block (A11, B11). 1 <= J1 <= N. N1 (input) INTEGER The order of the first block (A11, B11). N1 = 0, 1 or 2. N2 (input) INTEGER The order of the second block (A22, B22). N2 = 0, 1 or 2. WORK (workspace) REAL array, dimension (LWORK). LWORK (input) INTEGER The dimension of the array WORK. LWORK >= MAX( N*(N2+N1), (N2+N1)*(N2+N1)*2 ) INFO (output) INTEGER =0: Successful exit >0: If INFO = 1, the transformed matrix (A, B) would be too far from generalized Schur form; the blocks are not swapped and (A, B) and (Q, Z) are unchanged. The problem of swapping is too ill-conditioned. <0: If INFO = -16: LWORK is too small. Appropriate value for LWORK is returned in WORK(1). Further Details =============== Based on contributions by Bo Kagstrom and Peter Poromaa, Department of Computing Science, Umea University, S-901 87 Umea, Sweden. In the current code both weak and strong stability tests are performed. The user can omit the strong stability test by changing the internal logical parameter WANDS to .FALSE.. See ref. [2] for details. [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the Generalized Real Schur Form of a Regular Matrix Pair (A, B), in M.S. Moonen et al (eds), Linear Algebra for Large Scale and Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified Eigenvalues of a Regular Matrix Pair (A, B) and Condition Estimation: Theory, Algorithms and Software, Report UMINF - 94.04, Department of Computing Science, Umea University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87. To appear in Numerical Algorithms, 1996. ===================================================================== Parameter adjustments */ /* Table of constant values */ static integer c__16 = 16; static real c_b3 = 0.f; static integer c__0 = 0; static integer c__1 = 1; static integer c__4 = 4; static integer c__2 = 2; static real c_b38 = 1.f; static real c_b44 = -1.f; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, z_offset, i__1, i__2; real r__1, r__2; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static logical weak; static real ddum; static integer idum; static real taul[4], dsum, taur[4], scpy[16] /* was [4][4] */, tcpy[16] /* was [4][4] */; extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, integer *, real *, real *); static real f, g; static integer i__, m; static real s[16] /* was [4][4] */, t[16] /* was [4][4] */, scale, bqra21, brqa21; extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); static real licop[16] /* was [4][4] */; static integer linfo; extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *); static real ircop[16] /* was [4][4] */, dnorm; static integer iwork[4]; extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, integer *), slagv2_(real *, integer *, real *, integer *, real *, real *, real *, real *, real *, real *, real *), sgeqr2_(integer * , integer *, real *, integer *, real *, real *, integer *), sgerq2_(integer *, integer *, real *, integer *, real *, real *, integer *); static real be[2], ai[2]; extern /* Subroutine */ int sorg2r_(integer *, integer *, integer *, real *, integer *, real *, real *, integer *), sorgr2_(integer *, integer *, integer *, real *, integer *, real *, real *, integer * ); static real ar[2], sa, sb, li[16] /* was [4][4] */; extern /* Subroutine */ int sorm2r_(char *, char *, integer *, integer *, integer *, real *, integer *, real *, real *, integer *, real *, integer *), sormr2_(char *, char *, integer *, integer *, integer *, real *, integer *, real *, real *, integer * , real *, integer *); static real dscale, ir[16] /* was [4][4] */; extern /* Subroutine */ int stgsy2_(char *, integer *, integer *, integer *, real *, integer *, real *, integer *, real *, integer *, real * , integer *, real *, integer *, real *, integer *, real *, real *, real *, integer *, integer *, integer *); static real ss; extern doublereal slamch_(char *); static real ws; extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *), slartg_(real *, real *, real *, real *, real *); static real thresh; extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, real *); static real smlnum; static logical strong; static real eps; #define scpy_ref(a_1,a_2) scpy[(a_2)*4 + a_1 - 5] #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] #define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1] #define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1] #define s_ref(a_1,a_2) s[(a_2)*4 + a_1 - 5] #define t_ref(a_1,a_2) t[(a_2)*4 + a_1 - 5] #define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1] #define li_ref(a_1,a_2) li[(a_2)*4 + a_1 - 5] #define ir_ref(a_1,a_2) ir[(a_2)*4 + a_1 - 5] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; q_dim1 = *ldq; q_offset = 1 + q_dim1 * 1; q -= q_offset; z_dim1 = *ldz; z_offset = 1 + z_dim1 * 1; z__ -= z_offset; --work; /* Function Body */ *info = 0; /* Quick return if possible */ if (*n <= 1 || *n1 <= 0 || *n2 <= 0) { return 0; } if (*n1 > *n || *j1 + *n1 > *n) { return 0; } m = *n1 + *n2; /* Computing MAX */ i__1 = *n * m, i__2 = m * m << 1; if (*lwork < max(i__1,i__2)) { *info = -16; /* Computing MAX */ i__1 = *n * m, i__2 = m * m << 1; work[1] = (real) max(i__1,i__2); return 0; } weak = FALSE_; strong = FALSE_; /* Make a local copy of selected block */ scopy_(&c__16, &c_b3, &c__0, li, &c__1); scopy_(&c__16, &c_b3, &c__0, ir, &c__1); slacpy_("Full", &m, &m, &a_ref(*j1, *j1), lda, s, &c__4); slacpy_("Full", &m, &m, &b_ref(*j1, *j1), ldb, t, &c__4); /* Compute threshold for testing acceptance of swapping. */ eps = slamch_("P"); smlnum = slamch_("S") / eps; dscale = 0.f; dsum = 1.f; slacpy_("Full", &m, &m, s, &c__4, &work[1], &m); i__1 = m * m; slassq_(&i__1, &work[1], &c__1, &dscale, &dsum); slacpy_("Full", &m, &m, t, &c__4, &work[1], &m); i__1 = m * m; slassq_(&i__1, &work[1], &c__1, &dscale, &dsum); dnorm = dscale * sqrt(dsum); /* Computing MAX */ r__1 = eps * 10.f * dnorm; thresh = dmax(r__1,smlnum); if (m == 2) { /* CASE 1: Swap 1-by-1 and 1-by-1 blocks. Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks using Givens rotations and perform the swap tentatively. */ f = s_ref(2, 2) * t_ref(1, 1) - t_ref(2, 2) * s_ref(1, 1); g = s_ref(2, 2) * t_ref(1, 2) - t_ref(2, 2) * s_ref(1, 2); sb = (r__1 = t_ref(2, 2), dabs(r__1)); sa = (r__1 = s_ref(2, 2), dabs(r__1)); slartg_(&f, &g, &ir_ref(1, 2), &ir_ref(1, 1), &ddum); ir_ref(2, 1) = -ir_ref(1, 2); ir_ref(2, 2) = ir_ref(1, 1); srot_(&c__2, &s_ref(1, 1), &c__1, &s_ref(1, 2), &c__1, &ir_ref(1, 1), &ir_ref(2, 1)); srot_(&c__2, &t_ref(1, 1), &c__1, &t_ref(1, 2), &c__1, &ir_ref(1, 1), &ir_ref(2, 1)); if (sa >= sb) { slartg_(&s_ref(1, 1), &s_ref(2, 1), &li_ref(1, 1), &li_ref(2, 1), &ddum); } else { slartg_(&t_ref(1, 1), &t_ref(2, 1), &li_ref(1, 1), &li_ref(2, 1), &ddum); } srot_(&c__2, &s_ref(1, 1), &c__4, &s_ref(2, 1), &c__4, &li_ref(1, 1), &li_ref(2, 1)); srot_(&c__2, &t_ref(1, 1), &c__4, &t_ref(2, 1), &c__4, &li_ref(1, 1), &li_ref(2, 1)); li_ref(2, 2) = li_ref(1, 1); li_ref(1, 2) = -li_ref(2, 1); /* Weak stability test: |S21| + |T21| <= O(EPS * F-norm((S, T))) */ ws = (r__1 = s_ref(2, 1), dabs(r__1)) + (r__2 = t_ref(2, 1), dabs( r__2)); weak = ws <= thresh; if (! weak) { goto L70; } if (TRUE_) { /* Strong stability test: F-norm((A-QL'*S*QR, B-QL'*T*QR)) <= O(EPS*F-norm((A,B))) */ slacpy_("Full", &m, &m, &a_ref(*j1, *j1), lda, &work[m * m + 1], & m); sgemm_("N", "N", &m, &m, &m, &c_b38, li, &c__4, s, &c__4, &c_b3, & work[1], &m); sgemm_("N", "T", &m, &m, &m, &c_b44, &work[1], &m, ir, &c__4, & c_b38, &work[m * m + 1], &m); dscale = 0.f; dsum = 1.f; i__1 = m * m; slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum); slacpy_("Full", &m, &m, &b_ref(*j1, *j1), ldb, &work[m * m + 1], & m); sgemm_("N", "N", &m, &m, &m, &c_b38, li, &c__4, t, &c__4, &c_b3, & work[1], &m); sgemm_("N", "T", &m, &m, &m, &c_b44, &work[1], &m, ir, &c__4, & c_b38, &work[m * m + 1], &m); i__1 = m * m; slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum); ss = dscale * sqrt(dsum); strong = ss <= thresh; if (! strong) { goto L70; } } /* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */ i__1 = *j1 + 1; srot_(&i__1, &a_ref(1, *j1), &c__1, &a_ref(1, *j1 + 1), &c__1, & ir_ref(1, 1), &ir_ref(2, 1)); i__1 = *j1 + 1; srot_(&i__1, &b_ref(1, *j1), &c__1, &b_ref(1, *j1 + 1), &c__1, & ir_ref(1, 1), &ir_ref(2, 1)); i__1 = *n - *j1 + 1; srot_(&i__1, &a_ref(*j1, *j1), lda, &a_ref(*j1 + 1, *j1), lda, & li_ref(1, 1), &li_ref(2, 1)); i__1 = *n - *j1 + 1; srot_(&i__1, &b_ref(*j1, *j1), ldb, &b_ref(*j1 + 1, *j1), ldb, & li_ref(1, 1), &li_ref(2, 1)); /* Set N1-by-N2 (2,1) - blocks to ZERO. */ a_ref(*j1 + 1, *j1) = 0.f; b_ref(*j1 + 1, *j1) = 0.f; /* Accumulate transformations into Q and Z if requested. */ if (*wantz) { srot_(n, &z___ref(1, *j1), &c__1, &z___ref(1, *j1 + 1), &c__1, & ir_ref(1, 1), &ir_ref(2, 1)); } if (*wantq) { srot_(n, &q_ref(1, *j1), &c__1, &q_ref(1, *j1 + 1), &c__1, & li_ref(1, 1), &li_ref(2, 1)); } /* Exit with INFO = 0 if swap was successfully performed. */ return 0; } else { /* CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2 and 2-by-2 blocks. Solve the generalized Sylvester equation S11 * R - L * S22 = SCALE * S12 T11 * R - L * T22 = SCALE * T12 for R and L. Solutions in LI and IR. */ slacpy_("Full", n1, n2, &t_ref(1, *n1 + 1), &c__4, li, &c__4); slacpy_("Full", n1, n2, &s_ref(1, *n1 + 1), &c__4, &ir_ref(*n2 + 1, * n1 + 1), &c__4); stgsy2_("N", &c__0, n1, n2, s, &c__4, &s_ref(*n1 + 1, *n1 + 1), &c__4, &ir_ref(*n2 + 1, *n1 + 1), &c__4, t, &c__4, &t_ref(*n1 + 1, * n1 + 1), &c__4, li, &c__4, &scale, &dsum, &dscale, iwork, & idum, &linfo); /* Compute orthogonal matrix QL: QL' * LI = [ TL ] [ 0 ] where LI = [ -L ] [ SCALE * identity(N2) ] */ i__1 = *n2; for (i__ = 1; i__ <= i__1; ++i__) { sscal_(n1, &c_b44, &li_ref(1, i__), &c__1); li_ref(*n1 + i__, i__) = scale; /* L10: */ } sgeqr2_(&m, n2, li, &c__4, taul, &work[1], &linfo); if (linfo != 0) { goto L70; } sorg2r_(&m, &m, n2, li, &c__4, taul, &work[1], &linfo); if (linfo != 0) { goto L70; } /* Compute orthogonal matrix RQ: IR * RQ' = [ 0 TR], where IR = [ SCALE * identity(N1), R ] */ i__1 = *n1; for (i__ = 1; i__ <= i__1; ++i__) { ir_ref(*n2 + i__, i__) = scale; /* L20: */ } sgerq2_(n1, &m, &ir_ref(*n2 + 1, 1), &c__4, taur, &work[1], &linfo); if (linfo != 0) { goto L70; } sorgr2_(&m, &m, n1, ir, &c__4, taur, &work[1], &linfo); if (linfo != 0) { goto L70; } /* Perform the swapping tentatively: */ sgemm_("T", "N", &m, &m, &m, &c_b38, li, &c__4, s, &c__4, &c_b3, & work[1], &m); sgemm_("N", "T", &m, &m, &m, &c_b38, &work[1], &m, ir, &c__4, &c_b3, s, &c__4); sgemm_("T", "N", &m, &m, &m, &c_b38, li, &c__4, t, &c__4, &c_b3, & work[1], &m); sgemm_("N", "T", &m, &m, &m, &c_b38, &work[1], &m, ir, &c__4, &c_b3, t, &c__4); slacpy_("F", &m, &m, s, &c__4, scpy, &c__4); slacpy_("F", &m, &m, t, &c__4, tcpy, &c__4); slacpy_("F", &m, &m, ir, &c__4, ircop, &c__4); slacpy_("F", &m, &m, li, &c__4, licop, &c__4); /* Triangularize the B-part by an RQ factorization. Apply transformation (from left) to A-part, giving S. */ sgerq2_(&m, &m, t, &c__4, taur, &work[1], &linfo); if (linfo != 0) { goto L70; } sormr2_("R", "T", &m, &m, &m, t, &c__4, taur, s, &c__4, &work[1], & linfo); if (linfo != 0) { goto L70; } sormr2_("L", "N", &m, &m, &m, t, &c__4, taur, ir, &c__4, &work[1], & linfo); if (linfo != 0) { goto L70; } /* Compute F-norm(S21) in BRQA21. (T21 is 0.) */ dscale = 0.f; dsum = 1.f; i__1 = *n2; for (i__ = 1; i__ <= i__1; ++i__) { slassq_(n1, &s_ref(*n2 + 1, i__), &c__1, &dscale, &dsum); /* L30: */ } brqa21 = dscale * sqrt(dsum); /* Triangularize the B-part by a QR factorization. Apply transformation (from right) to A-part, giving S. */ sgeqr2_(&m, &m, tcpy, &c__4, taul, &work[1], &linfo); if (linfo != 0) { goto L70; } sorm2r_("L", "T", &m, &m, &m, tcpy, &c__4, taul, scpy, &c__4, &work[1] , info); sorm2r_("R", "N", &m, &m, &m, tcpy, &c__4, taul, licop, &c__4, &work[ 1], info); if (linfo != 0) { goto L70; } /* Compute F-norm(S21) in BQRA21. (T21 is 0.) */ dscale = 0.f; dsum = 1.f; i__1 = *n2; for (i__ = 1; i__ <= i__1; ++i__) { slassq_(n1, &scpy_ref(*n2 + 1, i__), &c__1, &dscale, &dsum); /* L40: */ } bqra21 = dscale * sqrt(dsum); /* Decide which method to use. Weak stability test: F-norm(S21) <= O(EPS * F-norm((S, T))) */ if (bqra21 <= brqa21 && bqra21 <= thresh) { slacpy_("F", &m, &m, scpy, &c__4, s, &c__4); slacpy_("F", &m, &m, tcpy, &c__4, t, &c__4); slacpy_("F", &m, &m, ircop, &c__4, ir, &c__4); slacpy_("F", &m, &m, licop, &c__4, li, &c__4); } else if (brqa21 >= thresh) { goto L70; } /* Set lower triangle of B-part to zero */ i__1 = m; for (i__ = 2; i__ <= i__1; ++i__) { i__2 = m - i__ + 1; scopy_(&i__2, &c_b3, &c__0, &t_ref(i__, i__ - 1), &c__1); /* L50: */ } if (TRUE_) { /* Strong stability test: F-norm((A-QL*S*QR', B-QL*T*QR')) <= O(EPS*F-norm((A,B))) */ slacpy_("Full", &m, &m, &a_ref(*j1, *j1), lda, &work[m * m + 1], & m); sgemm_("N", "N", &m, &m, &m, &c_b38, li, &c__4, s, &c__4, &c_b3, & work[1], &m); sgemm_("N", "N", &m, &m, &m, &c_b44, &work[1], &m, ir, &c__4, & c_b38, &work[m * m + 1], &m); dscale = 0.f; dsum = 1.f; i__1 = m * m; slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum); slacpy_("Full", &m, &m, &b_ref(*j1, *j1), ldb, &work[m * m + 1], & m); sgemm_("N", "N", &m, &m, &m, &c_b38, li, &c__4, t, &c__4, &c_b3, & work[1], &m); sgemm_("N", "N", &m, &m, &m, &c_b44, &work[1], &m, ir, &c__4, & c_b38, &work[m * m + 1], &m); i__1 = m * m; slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum); ss = dscale * sqrt(dsum); strong = ss <= thresh; if (! strong) { goto L70; } } /* If the swap is accepted ("weakly" and "strongly"), apply the transformations and set N1-by-N2 (2,1)-block to zero. */ i__1 = *n2; for (i__ = 1; i__ <= i__1; ++i__) { scopy_(n1, &c_b3, &c__0, &s_ref(*n2 + 1, i__), &c__1); /* L60: */ } /* copy back M-by-M diagonal block starting at index J1 of (A, B) */ slacpy_("F", &m, &m, s, &c__4, &a_ref(*j1, *j1), lda); slacpy_("F", &m, &m, t, &c__4, &b_ref(*j1, *j1), ldb); scopy_(&c__16, &c_b3, &c__0, t, &c__1); /* Standardize existing 2-by-2 blocks. */ i__1 = m * m; scopy_(&i__1, &c_b3, &c__0, &work[1], &c__1); work[1] = 1.f; t_ref(1, 1) = 1.f; idum = *lwork - m * m - 2; if (*n2 > 1) { slagv2_(&a_ref(*j1, *j1), lda, &b_ref(*j1, *j1), ldb, ar, ai, be, &work[1], &work[2], &t_ref(1, 1), &t_ref(2, 1)); work[m + 1] = -work[2]; work[m + 2] = work[1]; t_ref(*n2, *n2) = t_ref(1, 1); t_ref(1, 2) = -t_ref(2, 1); } work[m * m] = 1.f; t_ref(m, m) = 1.f; if (*n1 > 1) { slagv2_(&a_ref(*j1 + *n2, *j1 + *n2), lda, &b_ref(*j1 + *n2, *j1 + *n2), ldb, taur, taul, &work[m * m + 1], &work[*n2 * m + *n2 + 1], &work[*n2 * m + *n2 + 2], &t_ref(*n2 + 1, *n2 + 1), &t_ref(m, m - 1)); work[m * m] = work[*n2 * m + *n2 + 1]; work[m * m - 1] = -work[*n2 * m + *n2 + 2]; t_ref(m, m) = t_ref(*n2 + 1, *n2 + 1); t_ref(m - 1, m) = -t_ref(m, m - 1); } sgemm_("T", "N", n2, n1, n2, &c_b38, &work[1], &m, &a_ref(*j1, *j1 + * n2), lda, &c_b3, &work[m * m + 1], n2); slacpy_("Full", n2, n1, &work[m * m + 1], n2, &a_ref(*j1, *j1 + *n2), lda); sgemm_("T", "N", n2, n1, n2, &c_b38, &work[1], &m, &b_ref(*j1, *j1 + * n2), ldb, &c_b3, &work[m * m + 1], n2); slacpy_("Full", n2, n1, &work[m * m + 1], n2, &b_ref(*j1, *j1 + *n2), ldb); sgemm_("N", "N", &m, &m, &m, &c_b38, li, &c__4, &work[1], &m, &c_b3, & work[m * m + 1], &m); slacpy_("Full", &m, &m, &work[m * m + 1], &m, li, &c__4); sgemm_("N", "N", n2, n1, n1, &c_b38, &a_ref(*j1, *j1 + *n2), lda, & t_ref(*n2 + 1, *n2 + 1), &c__4, &c_b3, &work[1], n2); slacpy_("Full", n2, n1, &work[1], n2, &a_ref(*j1, *j1 + *n2), lda); sgemm_("N", "N", n2, n1, n1, &c_b38, &b_ref(*j1, *j1 + *n2), lda, & t_ref(*n2 + 1, *n2 + 1), &c__4, &c_b3, &work[1], n2); slacpy_("Full", n2, n1, &work[1], n2, &b_ref(*j1, *j1 + *n2), ldb); sgemm_("T", "N", &m, &m, &m, &c_b38, ir, &c__4, t, &c__4, &c_b3, & work[1], &m); slacpy_("Full", &m, &m, &work[1], &m, ir, &c__4); /* Accumulate transformations into Q and Z if requested. */ if (*wantq) { sgemm_("N", "N", n, &m, &m, &c_b38, &q_ref(1, *j1), ldq, li, & c__4, &c_b3, &work[1], n); slacpy_("Full", n, &m, &work[1], n, &q_ref(1, *j1), ldq); } if (*wantz) { sgemm_("N", "N", n, &m, &m, &c_b38, &z___ref(1, *j1), ldz, ir, & c__4, &c_b3, &work[1], n); slacpy_("Full", n, &m, &work[1], n, &z___ref(1, *j1), ldz); } /* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */ i__ = *j1 + m; if (i__ <= *n) { i__1 = *n - i__ + 1; sgemm_("T", "N", &m, &i__1, &m, &c_b38, li, &c__4, &a_ref(*j1, i__), lda, &c_b3, &work[1], &m); i__1 = *n - i__ + 1; slacpy_("Full", &m, &i__1, &work[1], &m, &a_ref(*j1, i__), lda); i__1 = *n - i__ + 1; sgemm_("T", "N", &m, &i__1, &m, &c_b38, li, &c__4, &b_ref(*j1, i__), lda, &c_b3, &work[1], &m); i__1 = *n - i__ + 1; slacpy_("Full", &m, &i__1, &work[1], &m, &b_ref(*j1, i__), lda); } i__ = *j1 - 1; if (i__ > 0) { sgemm_("N", "N", &i__, &m, &m, &c_b38, &a_ref(1, *j1), lda, ir, & c__4, &c_b3, &work[1], &i__); slacpy_("Full", &i__, &m, &work[1], &i__, &a_ref(1, *j1), lda); sgemm_("N", "N", &i__, &m, &m, &c_b38, &b_ref(1, *j1), ldb, ir, & c__4, &c_b3, &work[1], &i__); slacpy_("Full", &i__, &m, &work[1], &i__, &b_ref(1, *j1), ldb); } /* Exit with INFO = 0 if swap was successfully performed. */ return 0; } /* Exit with INFO = 1 if swap was rejected. */ L70: *info = 1; return 0; /* End of STGEX2 */ } /* stgex2_ */
doublereal slangb_(char *norm, integer *n, integer *kl, integer *ku, real *ab, integer *ldab, real *work) { /* -- LAPACK auxiliary routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University October 31, 1992 Purpose ======= SLANGB returns the value of the one norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of an n by n band matrix A, with kl sub-diagonals and ku super-diagonals. Description =========== SLANGB returns the value SLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm' ( ( norm1(A), NORM = '1', 'O' or 'o' ( ( normI(A), NORM = 'I' or 'i' ( ( normF(A), NORM = 'F', 'f', 'E' or 'e' where norm1 denotes the one norm of a matrix (maximum column sum), normI denotes the infinity norm of a matrix (maximum row sum) and normF denotes the Frobenius norm of a matrix (square root of sum of squares). Note that max(abs(A(i,j))) is not a matrix norm. Arguments ========= NORM (input) CHARACTER*1 Specifies the value to be returned in SLANGB as described above. N (input) INTEGER The order of the matrix A. N >= 0. When N = 0, SLANGB is set to zero. KL (input) INTEGER The number of sub-diagonals of the matrix A. KL >= 0. KU (input) INTEGER The number of super-diagonals of the matrix A. KU >= 0. AB (input) REAL array, dimension (LDAB,N) The band matrix A, stored in rows 1 to KL+KU+1. The j-th column of A is stored in the j-th column of the array AB as follows: AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). LDAB (input) INTEGER The leading dimension of the array AB. LDAB >= KL+KU+1. WORK (workspace) REAL array, dimension (LWORK), where LWORK >= N when NORM = 'I'; otherwise, WORK is not referenced. ===================================================================== Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; /* System generated locals */ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6; real ret_val, r__1, r__2, r__3; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static integer i__, j, k, l; static real scale; extern logical lsame_(char *, char *); static real value; extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, real *); static real sum; #define ab_ref(a_1,a_2) ab[(a_2)*ab_dim1 + a_1] ab_dim1 = *ldab; ab_offset = 1 + ab_dim1 * 1; ab -= ab_offset; --work; /* Function Body */ if (*n == 0) { value = 0.f; } else if (lsame_(norm, "M")) { /* Find max(abs(A(i,j))). */ value = 0.f; i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ i__2 = *ku + 2 - j; /* Computing MIN */ i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1; i__3 = min(i__4,i__5); for (i__ = max(i__2,1); i__ <= i__3; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = ab_ref(i__, j), dabs(r__1)); value = dmax(r__2,r__3); /* L10: */ } /* L20: */ } } else if (lsame_(norm, "O") || *(unsigned char *) norm == '1') { /* Find norm1(A). */ value = 0.f; i__1 = *n; for (j = 1; j <= i__1; ++j) { sum = 0.f; /* Computing MAX */ i__3 = *ku + 2 - j; /* Computing MIN */ i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1; i__2 = min(i__4,i__5); for (i__ = max(i__3,1); i__ <= i__2; ++i__) { sum += (r__1 = ab_ref(i__, j), dabs(r__1)); /* L30: */ } value = dmax(value,sum); /* L40: */ } } else if (lsame_(norm, "I")) { /* Find normI(A). */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.f; /* L50: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { k = *ku + 1 - j; /* Computing MAX */ i__2 = 1, i__3 = j - *ku; /* Computing MIN */ i__5 = *n, i__6 = j + *kl; i__4 = min(i__5,i__6); for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { work[i__] += (r__1 = ab_ref(k + i__, j), dabs(r__1)); /* L60: */ } /* L70: */ } value = 0.f; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { /* Computing MAX */ r__1 = value, r__2 = work[i__]; value = dmax(r__1,r__2); /* L80: */ } } else if (lsame_(norm, "F") || lsame_(norm, "E")) { /* Find normF(A). */ scale = 0.f; sum = 1.f; i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ i__4 = 1, i__2 = j - *ku; l = max(i__4,i__2); k = *ku + 1 - j + l; /* Computing MIN */ i__2 = *n, i__3 = j + *kl; i__4 = min(i__2,i__3) - l + 1; slassq_(&i__4, &ab_ref(k, j), &c__1, &scale, &sum); /* L90: */ } value = scale * sqrt(sum); } ret_val = value; return ret_val; /* End of SLANGB */ } /* slangb_ */
doublereal slange_(char *norm, integer *m, integer *n, real *a, integer *lda, real *work) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; real ret_val, r__1, r__2, r__3; /* Local variables */ integer i__, j; real sum, scale; real value; /* -- LAPACK auxiliary routine (version 3.2) -- */ /* November 2006 */ /* Purpose */ /* ======= */ /* SLANGE returns the value of the one norm, or the Frobenius norm, or */ /* the infinity norm, or the element of largest absolute value of a */ /* real matrix A. */ /* Description */ /* =========== */ /* SLANGE returns the value */ /* SLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ /* ( */ /* ( norm1(A), NORM = '1', 'O' or 'o' */ /* ( */ /* ( normI(A), NORM = 'I' or 'i' */ /* ( */ /* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ /* where norm1 denotes the one norm of a matrix (maximum column sum), */ /* normI denotes the infinity norm of a matrix (maximum row sum) and */ /* normF denotes the Frobenius norm of a matrix (square root of sum of */ /* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ /* Arguments */ /* ========= */ /* NORM (input) CHARACTER*1 */ /* Specifies the value to be returned in SLANGE as described */ /* above. */ /* M (input) INTEGER */ /* The number of rows of the matrix A. M >= 0. When M = 0, */ /* SLANGE is set to zero. */ /* N (input) INTEGER */ /* The number of columns of the matrix A. N >= 0. When N = 0, */ /* SLANGE is set to zero. */ /* A (input) REAL array, dimension (LDA,N) */ /* The m by n matrix A. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(M,1). */ /* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */ /* where LWORK >= M when NORM = 'I'; otherwise, WORK is not */ /* referenced. */ /* ===================================================================== */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --work; /* Function Body */ if (min(*m,*n) == 0) { value = 0.f; } else if (lsame_(norm, "M")) { /* Find max(abs(A(i,j))). */ value = 0.f; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1)); value = dmax(r__2,r__3); } } } else if (lsame_(norm, "O") || *(unsigned char *) norm == '1') { /* Find norm1(A). */ value = 0.f; i__1 = *n; for (j = 1; j <= i__1; ++j) { sum = 0.f; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { sum += (r__1 = a[i__ + j * a_dim1], dabs(r__1)); } value = dmax(value,sum); } } else if (lsame_(norm, "I")) { /* Find normI(A). */ i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.f; } i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { work[i__] += (r__1 = a[i__ + j * a_dim1], dabs(r__1)); } } value = 0.f; i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { /* Computing MAX */ r__1 = value, r__2 = work[i__]; value = dmax(r__1,r__2); } } else if (lsame_(norm, "F") || lsame_(norm, "E")) { /* Find normF(A). */ scale = 0.f; sum = 1.f; i__1 = *n; for (j = 1; j <= i__1; ++j) { slassq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum); } value = scale * sqrt(sum); } ret_val = value; return ret_val; /* End of SLANGE */ } /* slange_ */
/* ===================================================================== */ real slansp_(char *norm, char *uplo, integer *n, real *ap, real *work) { /* System generated locals */ integer i__1, i__2; real ret_val, r__1; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ integer i__, j, k; real sum, absa, scale; extern logical lsame_(char *, char *); real value; extern logical sisnan_(real *); extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, real *); /* -- LAPACK auxiliary routine (version 3.4.2) -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ /* September 2012 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ --work; --ap; /* Function Body */ if (*n == 0) { value = 0.f; } else if (lsame_(norm, "M")) { /* Find max(f2c_abs(A(i,j))). */ value = 0.f; if (lsame_(uplo, "U")) { k = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = k + j - 1; for (i__ = k; i__ <= i__2; ++i__) { sum = (r__1 = ap[i__], f2c_abs(r__1)); if (value < sum || sisnan_(&sum)) { value = sum; } /* L10: */ } k += j; /* L20: */ } } else { k = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = k + *n - j; for (i__ = k; i__ <= i__2; ++i__) { sum = (r__1 = ap[i__], f2c_abs(r__1)); if (value < sum || sisnan_(&sum)) { value = sum; } /* L30: */ } k = k + *n - j + 1; /* L40: */ } } } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') { /* Find normI(A) ( = norm1(A), since A is symmetric). */ value = 0.f; k = 1; if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= i__1; ++j) { sum = 0.f; i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { absa = (r__1 = ap[k], f2c_abs(r__1)); sum += absa; work[i__] += absa; ++k; /* L50: */ } work[j] = sum + (r__1 = ap[k], f2c_abs(r__1)); ++k; /* L60: */ } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { sum = work[i__]; if (value < sum || sisnan_(&sum)) { value = sum; } /* L70: */ } } else { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.f; /* L80: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { sum = work[j] + (r__1 = ap[k], f2c_abs(r__1)); ++k; i__2 = *n; for (i__ = j + 1; i__ <= i__2; ++i__) { absa = (r__1 = ap[k], f2c_abs(r__1)); sum += absa; work[i__] += absa; ++k; /* L90: */ } if (value < sum || sisnan_(&sum)) { value = sum; } /* L100: */ } } } else if (lsame_(norm, "F") || lsame_(norm, "E")) { /* Find normF(A). */ scale = 0.f; sum = 1.f; k = 2; if (lsame_(uplo, "U")) { i__1 = *n; for (j = 2; j <= i__1; ++j) { i__2 = j - 1; slassq_(&i__2, &ap[k], &c__1, &scale, &sum); k += j; /* L110: */ } } else { i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { i__2 = *n - j; slassq_(&i__2, &ap[k], &c__1, &scale, &sum); k = k + *n - j + 1; /* L120: */ } } sum *= 2; k = 1; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (ap[k] != 0.f) { absa = (r__1 = ap[k], f2c_abs(r__1)); if (scale < absa) { /* Computing 2nd power */ r__1 = scale / absa; sum = sum * (r__1 * r__1) + 1.f; scale = absa; } else { /* Computing 2nd power */ r__1 = absa / scale; sum += r__1 * r__1; } } if (lsame_(uplo, "U")) { k = k + i__ + 1; } else { k = k + *n - i__ + 1; } /* L130: */ } value = scale * sqrt(sum); } ret_val = value; return ret_val; /* End of SLANSP */ }
doublereal clanht_(char *norm, integer *n, real *d, complex *e) { /* -- LAPACK auxiliary routine (version 2.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University June 30, 1992 Purpose ======= CLANHT returns the value of the one norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a complex Hermitian tridiagonal matrix A. Description =========== CLANHT returns the value CLANHT = ( max(abs(A(i,j))), NORM = 'M' or 'm' ( ( norm1(A), NORM = '1', 'O' or 'o' ( ( normI(A), NORM = 'I' or 'i' ( ( normF(A), NORM = 'F', 'f', 'E' or 'e' where norm1 denotes the one norm of a matrix (maximum column sum), normI denotes the infinity norm of a matrix (maximum row sum) and normF denotes the Frobenius norm of a matrix (square root of sum of squares). Note that max(abs(A(i,j))) is not a matrix norm. Arguments ========= NORM (input) CHARACTER*1 Specifies the value to be returned in CLANHT as described above. N (input) INTEGER The order of the matrix A. N >= 0. When N = 0, CLANHT is set to zero. D (input) REAL array, dimension (N) The diagonal elements of A. E (input) COMPLEX array, dimension (N-1) The (n-1) sub-diagonal or super-diagonal elements of A. ===================================================================== Parameter adjustments Function Body */ /* Table of constant values */ static integer c__1 = 1; /* System generated locals */ integer i__1; real ret_val, r__1, r__2, r__3; /* Builtin functions */ double c_abs(complex *), sqrt(doublereal); /* Local variables */ static integer i; static real scale; extern logical lsame_(char *, char *); static real anorm; extern /* Subroutine */ int classq_(integer *, complex *, integer *, real *, real *), slassq_(integer *, real *, integer *, real *, real *); static real sum; #define E(I) e[(I)-1] #define D(I) d[(I)-1] if (*n <= 0) { anorm = 0.f; } else if (lsame_(norm, "M")) { /* Find max(abs(A(i,j))). */ anorm = (r__1 = D(*n), dabs(r__1)); i__1 = *n - 1; for (i = 1; i <= *n-1; ++i) { /* Computing MAX */ r__2 = anorm, r__3 = (r__1 = D(i), dabs(r__1)); anorm = dmax(r__2,r__3); /* Computing MAX */ r__1 = anorm, r__2 = c_abs(&E(i)); anorm = dmax(r__1,r__2); /* L10: */ } } else if (lsame_(norm, "O") || *(unsigned char *)norm == '1' || lsame_(norm, "I")) { /* Find norm1(A). */ if (*n == 1) { anorm = dabs(D(1)); } else { /* Computing MAX */ r__2 = dabs(D(1)) + c_abs(&E(1)), r__3 = c_abs(&E(*n - 1)) + ( r__1 = D(*n), dabs(r__1)); anorm = dmax(r__2,r__3); i__1 = *n - 1; for (i = 2; i <= *n-1; ++i) { /* Computing MAX */ r__2 = anorm, r__3 = (r__1 = D(i), dabs(r__1)) + c_abs(&E(i)) + c_abs(&E(i - 1)); anorm = dmax(r__2,r__3); /* L20: */ } } } else if (lsame_(norm, "F") || lsame_(norm, "E")) { /* Find normF(A). */ scale = 0.f; sum = 1.f; if (*n > 1) { i__1 = *n - 1; classq_(&i__1, &E(1), &c__1, &scale, &sum); sum *= 2; } slassq_(n, &D(1), &c__1, &scale, &sum); anorm = scale * sqrt(sum); } ret_val = anorm; return ret_val; /* End of CLANHT */ } /* clanht_ */
/* Subroutine */ int slatdf_(integer *ijob, integer *n, real *z__, integer * ldz, real *rhs, real *rdsum, real *rdscal, integer *ipiv, integer * jpiv) { /* System generated locals */ integer z_dim1, z_offset, i__1, i__2; real r__1; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ integer i__, j, k; real bm, bp, xm[8], xp[8]; integer info; real temp; extern real sdot_(integer *, real *, integer *, real *, integer *); real work[32]; extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); real pmone; extern real sasum_(integer *, real *, integer *); real sminu; integer iwork[8]; extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, integer *), saxpy_(integer *, real *, real *, integer *, real *, integer *); real splus; extern /* Subroutine */ int sgesc2_(integer *, real *, integer *, real *, integer *, integer *, real *), sgecon_(char *, integer *, real *, integer *, real *, real *, real *, integer *, integer *), slassq_(integer *, real *, integer *, real *, real *), slaswp_( integer *, real *, integer *, integer *, integer *, integer *, integer *); /* -- LAPACK auxiliary routine (version 3.4.2) -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ /* September 2012 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --rhs; --ipiv; --jpiv; /* Function Body */ if (*ijob != 2) { /* Apply permutations IPIV to RHS */ i__1 = *n - 1; slaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &ipiv[1], &c__1); /* Solve for L-part choosing RHS either to +1 or -1. */ pmone = -1.f; i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { bp = rhs[j] + 1.f; bm = rhs[j] - 1.f; splus = 1.f; /* Look-ahead for L-part RHS(1:N-1) = + or -1, SPLUS and */ /* SMIN computed more efficiently than in BSOLVE [1]. */ i__2 = *n - j; splus += sdot_(&i__2, &z__[j + 1 + j * z_dim1], &c__1, &z__[j + 1 + j * z_dim1], &c__1); i__2 = *n - j; sminu = sdot_(&i__2, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1], &c__1); splus *= rhs[j]; if (splus > sminu) { rhs[j] = bp; } else if (sminu > splus) { rhs[j] = bm; } else { /* In this case the updating sums are equal and we can */ /* choose RHS(J) +1 or -1. The first time this happens */ /* we choose -1, thereafter +1. This is a simple way to */ /* get good estimates of matrices like Byers well-known */ /* example (see [1]). (Not done in BSOLVE.) */ rhs[j] += pmone; pmone = 1.f; } /* Compute the remaining r.h.s. */ temp = -rhs[j]; i__2 = *n - j; saxpy_(&i__2, &temp, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1], &c__1); /* L10: */ } /* Solve for U-part, look-ahead for RHS(N) = +-1. This is not done */ /* in BSOLVE and will hopefully give us a better estimate because */ /* any ill-conditioning of the original matrix is transfered to U */ /* and not to L. U(N, N) is an approximation to sigma_min(LU). */ i__1 = *n - 1; scopy_(&i__1, &rhs[1], &c__1, xp, &c__1); xp[*n - 1] = rhs[*n] + 1.f; rhs[*n] += -1.f; splus = 0.f; sminu = 0.f; for (i__ = *n; i__ >= 1; --i__) { temp = 1.f / z__[i__ + i__ * z_dim1]; xp[i__ - 1] *= temp; rhs[i__] *= temp; i__1 = *n; for (k = i__ + 1; k <= i__1; ++k) { xp[i__ - 1] -= xp[k - 1] * (z__[i__ + k * z_dim1] * temp); rhs[i__] -= rhs[k] * (z__[i__ + k * z_dim1] * temp); /* L20: */ } splus += (r__1 = xp[i__ - 1], abs(r__1)); sminu += (r__1 = rhs[i__], abs(r__1)); /* L30: */ } if (splus > sminu) { scopy_(n, xp, &c__1, &rhs[1], &c__1); } /* Apply the permutations JPIV to the computed solution (RHS) */ i__1 = *n - 1; slaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &jpiv[1], &c_n1); /* Compute the sum of squares */ slassq_(n, &rhs[1], &c__1, rdscal, rdsum); } else { /* IJOB = 2, Compute approximate nullvector XM of Z */ sgecon_("I", n, &z__[z_offset], ldz, &c_b23, &temp, work, iwork, & info); scopy_(n, &work[*n], &c__1, xm, &c__1); /* Compute RHS */ i__1 = *n - 1; slaswp_(&c__1, xm, ldz, &c__1, &i__1, &ipiv[1], &c_n1); temp = 1.f / sqrt(sdot_(n, xm, &c__1, xm, &c__1)); sscal_(n, &temp, xm, &c__1); scopy_(n, xm, &c__1, xp, &c__1); saxpy_(n, &c_b23, &rhs[1], &c__1, xp, &c__1); saxpy_(n, &c_b37, xm, &c__1, &rhs[1], &c__1); sgesc2_(n, &z__[z_offset], ldz, &rhs[1], &ipiv[1], &jpiv[1], &temp); sgesc2_(n, &z__[z_offset], ldz, xp, &ipiv[1], &jpiv[1], &temp); if (sasum_(n, xp, &c__1) > sasum_(n, &rhs[1], &c__1)) { scopy_(n, xp, &c__1, &rhs[1], &c__1); } /* Compute the sum of squares */ slassq_(n, &rhs[1], &c__1, rdscal, rdsum); } return 0; /* End of SLATDF */ }
/*< REAL FUNCTION SLANGE( NORM, M, N, A, LDA, WORK ) >*/ doublereal slange_(char *norm, integer *m, integer *n, real *a, integer *lda, real *work, ftnlen norm_len) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; real ret_val, r__1, r__2, r__3; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ integer i__, j; real sum, scale; extern logical lsame_(const char *, const char *, ftnlen, ftnlen); real value=0; extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, real *); (void)norm_len; /* -- LAPACK auxiliary routine (version 3.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* October 31, 1992 */ /* .. Scalar Arguments .. */ /*< CHARACTER NORM >*/ /*< INTEGER LDA, M, N >*/ /* .. */ /* .. Array Arguments .. */ /*< REAL A( LDA, * ), WORK( * ) >*/ /* .. */ /* Purpose */ /* ======= */ /* SLANGE returns the value of the one norm, or the Frobenius norm, or */ /* the infinity norm, or the element of largest absolute value of a */ /* real matrix A. */ /* Description */ /* =========== */ /* SLANGE returns the value */ /* SLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ /* ( */ /* ( norm1(A), NORM = '1', 'O' or 'o' */ /* ( */ /* ( normI(A), NORM = 'I' or 'i' */ /* ( */ /* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ /* where norm1 denotes the one norm of a matrix (maximum column sum), */ /* normI denotes the infinity norm of a matrix (maximum row sum) and */ /* normF denotes the Frobenius norm of a matrix (square root of sum of */ /* squares). Note that max(abs(A(i,j))) is not a matrix norm. */ /* Arguments */ /* ========= */ /* NORM (input) CHARACTER*1 */ /* Specifies the value to be returned in SLANGE as described */ /* above. */ /* M (input) INTEGER */ /* The number of rows of the matrix A. M >= 0. When M = 0, */ /* SLANGE is set to zero. */ /* N (input) INTEGER */ /* The number of columns of the matrix A. N >= 0. When N = 0, */ /* SLANGE is set to zero. */ /* A (input) REAL array, dimension (LDA,N) */ /* The m by n matrix A. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(M,1). */ /* WORK (workspace) REAL array, dimension (LWORK), */ /* where LWORK >= M when NORM = 'I'; otherwise, WORK is not */ /* referenced. */ /* ===================================================================== */ /* .. Parameters .. */ /*< REAL ONE, ZERO >*/ /*< PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) >*/ /* .. */ /* .. Local Scalars .. */ /*< INTEGER I, J >*/ /*< REAL SCALE, SUM, VALUE >*/ /* .. */ /* .. External Subroutines .. */ /*< EXTERNAL SLASSQ >*/ /* .. */ /* .. External Functions .. */ /*< LOGICAL LSAME >*/ /*< EXTERNAL LSAME >*/ /* .. */ /* .. Intrinsic Functions .. */ /*< INTRINSIC ABS, MAX, MIN, SQRT >*/ /* .. */ /* .. Executable Statements .. */ /*< IF( MIN( M, N ).EQ.0 ) THEN >*/ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --work; /* Function Body */ if (min(*m,*n) == 0) { /*< VALUE = ZERO >*/ value = (float)0.; /*< ELSE IF( LSAME( NORM, 'M' ) ) THEN >*/ } else if (lsame_(norm, "M", (ftnlen)1, (ftnlen)1)) { /* Find max(abs(A(i,j))). */ /*< VALUE = ZERO >*/ value = (float)0.; /*< DO 20 J = 1, N >*/ i__1 = *n; for (j = 1; j <= i__1; ++j) { /*< DO 10 I = 1, M >*/ i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { /*< VALUE = MAX( VALUE, ABS( A( I, J ) ) ) >*/ /* Computing MAX */ r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1)); value = dmax(r__2,r__3); /*< 10 CONTINUE >*/ /* L10: */ } /*< 20 CONTINUE >*/ /* L20: */ } /*< ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN >*/ } else if (lsame_(norm, "O", (ftnlen)1, (ftnlen)1) || *(unsigned char *) norm == '1') { /* Find norm1(A). */ /*< VALUE = ZERO >*/ value = (float)0.; /*< DO 40 J = 1, N >*/ i__1 = *n; for (j = 1; j <= i__1; ++j) { /*< SUM = ZERO >*/ sum = (float)0.; /*< DO 30 I = 1, M >*/ i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { /*< SUM = SUM + ABS( A( I, J ) ) >*/ sum += (r__1 = a[i__ + j * a_dim1], dabs(r__1)); /*< 30 CONTINUE >*/ /* L30: */ } /*< VALUE = MAX( VALUE, SUM ) >*/ value = dmax(value,sum); /*< 40 CONTINUE >*/ /* L40: */ } /*< ELSE IF( LSAME( NORM, 'I' ) ) THEN >*/ } else if (lsame_(norm, "I", (ftnlen)1, (ftnlen)1)) { /* Find normI(A). */ /*< DO 50 I = 1, M >*/ i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { /*< WORK( I ) = ZERO >*/ work[i__] = (float)0.; /*< 50 CONTINUE >*/ /* L50: */ } /*< DO 70 J = 1, N >*/ i__1 = *n; for (j = 1; j <= i__1; ++j) { /*< DO 60 I = 1, M >*/ i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { /*< WORK( I ) = WORK( I ) + ABS( A( I, J ) ) >*/ work[i__] += (r__1 = a[i__ + j * a_dim1], dabs(r__1)); /*< 60 CONTINUE >*/ /* L60: */ } /*< 70 CONTINUE >*/ /* L70: */ } /*< VALUE = ZERO >*/ value = (float)0.; /*< DO 80 I = 1, M >*/ i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { /*< VALUE = MAX( VALUE, WORK( I ) ) >*/ /* Computing MAX */ r__1 = value, r__2 = work[i__]; value = dmax(r__1,r__2); /*< 80 CONTINUE >*/ /* L80: */ } /*< ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN >*/ } else if (lsame_(norm, "F", (ftnlen)1, (ftnlen)1) || lsame_(norm, "E", ( ftnlen)1, (ftnlen)1)) { /* Find normF(A). */ /*< SCALE = ZERO >*/ scale = (float)0.; /*< SUM = ONE >*/ sum = (float)1.; /*< DO 90 J = 1, N >*/ i__1 = *n; for (j = 1; j <= i__1; ++j) { /*< CALL SLASSQ( M, A( 1, J ), 1, SCALE, SUM ) >*/ slassq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum); /*< 90 CONTINUE >*/ /* L90: */ } /*< VALUE = SCALE*SQRT( SUM ) >*/ value = scale * sqrt(sum); /*< END IF >*/ } /*< SLANGE = VALUE >*/ ret_val = value; /*< RETURN >*/ return ret_val; /* End of SLANGE */ /*< END >*/ } /* slange_ */
doublereal clanht_(char *norm, integer *n, real *d__, complex *e) { /* System generated locals */ integer i__1; real ret_val, r__1, r__2, r__3; /* Local variables */ integer i__; real sum, scale; real anorm; /* -- LAPACK auxiliary routine (version 3.2) -- */ /* November 2006 */ /* Purpose */ /* ======= */ /* CLANHT returns the value of the one norm, or the Frobenius norm, or */ /* the infinity norm, or the element of largest absolute value of a */ /* complex Hermitian tridiagonal matrix A. */ /* Description */ /* =========== */ /* CLANHT returns the value */ /* CLANHT = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ /* ( */ /* ( norm1(A), NORM = '1', 'O' or 'o' */ /* ( */ /* ( normI(A), NORM = 'I' or 'i' */ /* ( */ /* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ /* where norm1 denotes the one norm of a matrix (maximum column sum), */ /* normI denotes the infinity norm of a matrix (maximum row sum) and */ /* normF denotes the Frobenius norm of a matrix (square root of sum of */ /* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ /* Arguments */ /* ========= */ /* NORM (input) CHARACTER*1 */ /* Specifies the value to be returned in CLANHT as described */ /* above. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. When N = 0, CLANHT is */ /* set to zero. */ /* D (input) REAL array, dimension (N) */ /* The diagonal elements of A. */ /* E (input) COMPLEX array, dimension (N-1) */ /* The (n-1) sub-diagonal or super-diagonal elements of A. */ /* ===================================================================== */ /* Parameter adjustments */ --e; --d__; /* Function Body */ if (*n <= 0) { anorm = 0.f; } else if (lsame_(norm, "M")) { /* Find max(abs(A(i,j))). */ anorm = (r__1 = d__[*n], dabs(r__1)); i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { /* Computing MAX */ r__2 = anorm, r__3 = (r__1 = d__[i__], dabs(r__1)); anorm = dmax(r__2,r__3); /* Computing MAX */ r__1 = anorm, r__2 = c_abs(&e[i__]); anorm = dmax(r__1,r__2); } } else if (lsame_(norm, "O") || *(unsigned char *) norm == '1' || lsame_(norm, "I")) { /* Find norm1(A). */ if (*n == 1) { anorm = dabs(d__[1]); } else { /* Computing MAX */ r__2 = dabs(d__[1]) + c_abs(&e[1]), r__3 = c_abs(&e[*n - 1]) + ( r__1 = d__[*n], dabs(r__1)); anorm = dmax(r__2,r__3); i__1 = *n - 1; for (i__ = 2; i__ <= i__1; ++i__) { /* Computing MAX */ r__2 = anorm, r__3 = (r__1 = d__[i__], dabs(r__1)) + c_abs(&e[ i__]) + c_abs(&e[i__ - 1]); anorm = dmax(r__2,r__3); } } } else if (lsame_(norm, "F") || lsame_(norm, "E")) { /* Find normF(A). */ scale = 0.f; sum = 1.f; if (*n > 1) { i__1 = *n - 1; classq_(&i__1, &e[1], &c__1, &scale, &sum); sum *= 2; } slassq_(n, &d__[1], &c__1, &scale, &sum); anorm = scale * sqrt(sum); } ret_val = anorm; return ret_val; /* End of CLANHT */ } /* clanht_ */
/* Subroutine */ int ssyequb_(char *uplo, integer *n, real *a, integer *lda, real *s, real *scond, real *amax, real *work, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; real r__1, r__2, r__3; /* Local variables */ real d__; integer i__, j; real t, u, c0, c1, c2, si; logical up; real avg, std, tol, base; integer iter; real smin, smax, scale; real sumsq; real bignum; real smlnum; /* -- LAPACK routine (version 3.2) -- */ /* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ /* -- Jason Riedy of Univ. of California Berkeley. -- */ /* -- November 2008 -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley and NAG Ltd. -- */ /* Purpose */ /* ======= */ /* SSYEQUB computes row and column scalings intended to equilibrate a */ /* symmetric matrix A and reduce its condition number */ /* (with respect to the two-norm). S contains the scale factors, */ /* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */ /* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */ /* choice of S puts the condition number of B within a factor N of the */ /* smallest possible condition number over all possible diagonal */ /* scalings. */ /* Arguments */ /* ========= */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* A (input) REAL array, dimension (LDA,N) */ /* The N-by-N symmetric matrix whose scaling */ /* factors are to be computed. Only the diagonal elements of A */ /* are referenced. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,N). */ /* S (output) REAL array, dimension (N) */ /* If INFO = 0, S contains the scale factors for A. */ /* SCOND (output) REAL */ /* If INFO = 0, S contains the ratio of the smallest S(i) to */ /* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */ /* large nor too small, it is not worth scaling by S. */ /* AMAX (output) REAL */ /* Absolute value of largest matrix element. If AMAX is very */ /* close to overflow or very close to underflow, the matrix */ /* should be scaled. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* > 0: if INFO = i, the i-th diagonal element is nonpositive. */ /* Further Details */ /* ======= ======= */ /* Reference: Livne, O.E. and Golub, G.H., "Scaling by Binormalization", */ /* Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004. */ /* DOI 10.1023/B:NUMA.0000016606.32820.69 */ /* Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf */ /* ===================================================================== */ /* Test input parameters. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --s; --work; /* Function Body */ *info = 0; if (! (lsame_(uplo, "U") || lsame_(uplo, "L"))) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < max(1,*n)) { *info = -4; } if (*info != 0) { i__1 = -(*info); xerbla_("SSYEQUB", &i__1); return 0; } up = lsame_(uplo, "U"); *amax = 0.f; /* Quick return if possible. */ if (*n == 0) { *scond = 1.f; return 0; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { s[i__] = 0.f; } *amax = 0.f; if (up) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = s[i__], r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1)) ; s[i__] = dmax(r__2,r__3); /* Computing MAX */ r__2 = s[j], r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1)); s[j] = dmax(r__2,r__3); /* Computing MAX */ r__2 = *amax, r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1)); *amax = dmax(r__2,r__3); } /* Computing MAX */ r__2 = s[j], r__3 = (r__1 = a[j + j * a_dim1], dabs(r__1)); s[j] = dmax(r__2,r__3); /* Computing MAX */ r__2 = *amax, r__3 = (r__1 = a[j + j * a_dim1], dabs(r__1)); *amax = dmax(r__2,r__3); } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ r__2 = s[j], r__3 = (r__1 = a[j + j * a_dim1], dabs(r__1)); s[j] = dmax(r__2,r__3); /* Computing MAX */ r__2 = *amax, r__3 = (r__1 = a[j + j * a_dim1], dabs(r__1)); *amax = dmax(r__2,r__3); i__2 = *n; for (i__ = j + 1; i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = s[i__], r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1)) ; s[i__] = dmax(r__2,r__3); /* Computing MAX */ r__2 = s[j], r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1)); s[j] = dmax(r__2,r__3); /* Computing MAX */ r__2 = *amax, r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1)); *amax = dmax(r__2,r__3); } } } i__1 = *n; for (j = 1; j <= i__1; ++j) { s[j] = 1.f / s[j]; } tol = 1.f / sqrt(*n * 2.f); for (iter = 1; iter <= 100; ++iter) { scale = 0.f; sumsq = 0.f; /* BETA = |A|S */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.f; } if (up) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { t = (r__1 = a[i__ + j * a_dim1], dabs(r__1)); work[i__] += (r__1 = a[i__ + j * a_dim1], dabs(r__1)) * s[ j]; work[j] += (r__1 = a[i__ + j * a_dim1], dabs(r__1)) * s[ i__]; } work[j] += (r__1 = a[j + j * a_dim1], dabs(r__1)) * s[j]; } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { work[j] += (r__1 = a[j + j * a_dim1], dabs(r__1)) * s[j]; i__2 = *n; for (i__ = j + 1; i__ <= i__2; ++i__) { t = (r__1 = a[i__ + j * a_dim1], dabs(r__1)); work[i__] += (r__1 = a[i__ + j * a_dim1], dabs(r__1)) * s[ j]; work[j] += (r__1 = a[i__ + j * a_dim1], dabs(r__1)) * s[ i__]; } } } /* avg = s^T beta / n */ avg = 0.f; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { avg += s[i__] * work[i__]; } avg /= *n; std = 0.f; i__1 = *n * 3; for (i__ = (*n << 1) + 1; i__ <= i__1; ++i__) { work[i__] = s[i__ - (*n << 1)] * work[i__ - (*n << 1)] - avg; } slassq_(n, &work[(*n << 1) + 1], &c__1, &scale, &sumsq); std = scale * sqrt(sumsq / *n); if (std < tol * avg) { goto L999; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { t = (r__1 = a[i__ + i__ * a_dim1], dabs(r__1)); si = s[i__]; c2 = (*n - 1) * t; c1 = (*n - 2) * (work[i__] - t * si); c0 = -(t * si) * si + work[i__] * 2 * si - *n * avg; d__ = c1 * c1 - c0 * 4 * c2; if (d__ <= 0.f) { *info = -1; return 0; } si = c0 * -2 / (c1 + sqrt(d__)); d__ = si - s[i__]; u = 0.f; if (up) { i__2 = i__; for (j = 1; j <= i__2; ++j) { t = (r__1 = a[j + i__ * a_dim1], dabs(r__1)); u += s[j] * t; work[j] += d__ * t; } i__2 = *n; for (j = i__ + 1; j <= i__2; ++j) { t = (r__1 = a[i__ + j * a_dim1], dabs(r__1)); u += s[j] * t; work[j] += d__ * t; } } else { i__2 = i__; for (j = 1; j <= i__2; ++j) { t = (r__1 = a[i__ + j * a_dim1], dabs(r__1)); u += s[j] * t; work[j] += d__ * t; } i__2 = *n; for (j = i__ + 1; j <= i__2; ++j) { t = (r__1 = a[j + i__ * a_dim1], dabs(r__1)); u += s[j] * t; work[j] += d__ * t; } } avg += (u + work[i__]) * d__ / *n; s[i__] = si; } } L999: smlnum = slamch_("SAFEMIN"); bignum = 1.f / smlnum; smin = bignum; smax = 0.f; t = 1.f / sqrt(avg); base = slamch_("B"); u = 1.f / log(base); i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = (integer) (u * log(s[i__] * t)); s[i__] = pow_ri(&base, &i__2); /* Computing MIN */ r__1 = smin, r__2 = s[i__]; smin = dmin(r__1,r__2); /* Computing MAX */ r__1 = smax, r__2 = s[i__]; smax = dmax(r__1,r__2); } *scond = dmax(smin,smlnum) / dmin(smax,bignum); return 0; } /* ssyequb_ */
doublereal slansb_(char *norm, char *uplo, integer *n, integer *k, real *ab, integer *ldab, real *work) { /* System generated locals */ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; real ret_val, r__1, r__2, r__3; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ integer i__, j, l; real sum, absa, scale; extern logical lsame_(char *, char *); real value; extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, real *); /* -- LAPACK auxiliary routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* SLANSB returns the value of the one norm, or the Frobenius norm, or */ /* the infinity norm, or the element of largest absolute value of an */ /* n by n symmetric band matrix A, with k super-diagonals. */ /* Description */ /* =========== */ /* SLANSB returns the value */ /* SLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ /* ( */ /* ( norm1(A), NORM = '1', 'O' or 'o' */ /* ( */ /* ( normI(A), NORM = 'I' or 'i' */ /* ( */ /* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ /* where norm1 denotes the one norm of a matrix (maximum column sum), */ /* normI denotes the infinity norm of a matrix (maximum row sum) and */ /* normF denotes the Frobenius norm of a matrix (square root of sum of */ /* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ /* Arguments */ /* ========= */ /* NORM (input) CHARACTER*1 */ /* Specifies the value to be returned in SLANSB as described */ /* above. */ /* UPLO (input) CHARACTER*1 */ /* Specifies whether the upper or lower triangular part of the */ /* band matrix A is supplied. */ /* = 'U': Upper triangular part is supplied */ /* = 'L': Lower triangular part is supplied */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. When N = 0, SLANSB is */ /* set to zero. */ /* K (input) INTEGER */ /* The number of super-diagonals or sub-diagonals of the */ /* band matrix A. K >= 0. */ /* AB (input) REAL array, dimension (LDAB,N) */ /* The upper or lower triangle of the symmetric band matrix A, */ /* stored in the first K+1 rows of AB. The j-th column of A is */ /* stored in the j-th column of the array AB as follows: */ /* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; */ /* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). */ /* LDAB (input) INTEGER */ /* The leading dimension of the array AB. LDAB >= K+1. */ /* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */ /* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */ /* WORK is not referenced. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ ab_dim1 = *ldab; ab_offset = 1 + ab_dim1; ab -= ab_offset; --work; /* Function Body */ if (*n == 0) { value = 0.f; } else if (lsame_(norm, "M")) { /* Find max(abs(A(i,j))). */ value = 0.f; if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ i__2 = *k + 2 - j; i__3 = *k + 1; for (i__ = max(i__2,1); i__ <= i__3; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = ab[i__ + j * ab_dim1], dabs( r__1)); value = dmax(r__2,r__3); /* L10: */ } /* L20: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ i__2 = *n + 1 - j, i__4 = *k + 1; i__3 = min(i__2,i__4); for (i__ = 1; i__ <= i__3; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = ab[i__ + j * ab_dim1], dabs( r__1)); value = dmax(r__2,r__3); /* L30: */ } /* L40: */ } } } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') { /* Find normI(A) ( = norm1(A), since A is symmetric). */ value = 0.f; if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= i__1; ++j) { sum = 0.f; l = *k + 1 - j; /* Computing MAX */ i__3 = 1, i__2 = j - *k; i__4 = j - 1; for (i__ = max(i__3,i__2); i__ <= i__4; ++i__) { absa = (r__1 = ab[l + i__ + j * ab_dim1], dabs(r__1)); sum += absa; work[i__] += absa; /* L50: */ } work[j] = sum + (r__1 = ab[*k + 1 + j * ab_dim1], dabs(r__1)); /* L60: */ } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { /* Computing MAX */ r__1 = value, r__2 = work[i__]; value = dmax(r__1,r__2); /* L70: */ } } else { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.f; /* L80: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { sum = work[j] + (r__1 = ab[j * ab_dim1 + 1], dabs(r__1)); l = 1 - j; /* Computing MIN */ i__3 = *n, i__2 = j + *k; i__4 = min(i__3,i__2); for (i__ = j + 1; i__ <= i__4; ++i__) { absa = (r__1 = ab[l + i__ + j * ab_dim1], dabs(r__1)); sum += absa; work[i__] += absa; /* L90: */ } value = dmax(value,sum); /* L100: */ } } } else if (lsame_(norm, "F") || lsame_(norm, "E")) { /* Find normF(A). */ scale = 0.f; sum = 1.f; if (*k > 0) { if (lsame_(uplo, "U")) { i__1 = *n; for (j = 2; j <= i__1; ++j) { /* Computing MIN */ i__3 = j - 1; i__4 = min(i__3,*k); /* Computing MAX */ i__2 = *k + 2 - j; slassq_(&i__4, &ab[max(i__2, 1)+ j * ab_dim1], &c__1, & scale, &sum); /* L110: */ } l = *k + 1; } else { i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ i__3 = *n - j; i__4 = min(i__3,*k); slassq_(&i__4, &ab[j * ab_dim1 + 2], &c__1, &scale, &sum); /* L120: */ } l = 1; } sum *= 2; } else { l = 1; } slassq_(n, &ab[l + ab_dim1], ldab, &scale, &sum); value = scale * sqrt(sum); } ret_val = value; return ret_val; /* End of SLANSB */ } /* slansb_ */
/* ===================================================================== */ real slantr_(char *norm, char *uplo, char *diag, integer *m, integer *n, real *a, integer *lda, real *work) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4; real ret_val, r__1; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ integer i__, j; real sum, scale; logical udiag; extern logical lsame_(char *, char *); real value; extern logical sisnan_(real *); extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, real *); /* -- LAPACK auxiliary routine (version 3.4.2) -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ /* September 2012 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --work; /* Function Body */ if (min(*m,*n) == 0) { value = 0.f; } else if (lsame_(norm, "M")) { /* Find max(f2c_abs(A(i,j))). */ if (lsame_(diag, "U")) { value = 1.f; if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ i__3 = *m; i__4 = j - 1; // , expr subst i__2 = min(i__3,i__4); for (i__ = 1; i__ <= i__2; ++i__) { sum = (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1)); if (value < sum || sisnan_(&sum)) { value = sum; } /* L10: */ } /* L20: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = j + 1; i__ <= i__2; ++i__) { sum = (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1)); if (value < sum || sisnan_(&sum)) { value = sum; } /* L30: */ } /* L40: */ } } } else { value = 0.f; if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = min(*m,j); for (i__ = 1; i__ <= i__2; ++i__) { sum = (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1)); if (value < sum || sisnan_(&sum)) { value = sum; } /* L50: */ } /* L60: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = j; i__ <= i__2; ++i__) { sum = (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1)); if (value < sum || sisnan_(&sum)) { value = sum; } /* L70: */ } /* L80: */ } } } } else if (lsame_(norm, "O") || *(unsigned char *) norm == '1') { /* Find norm1(A). */ value = 0.f; udiag = lsame_(diag, "U"); if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (udiag && j <= *m) { sum = 1.f; i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { sum += (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1)); /* L90: */ } } else { sum = 0.f; i__2 = min(*m,j); for (i__ = 1; i__ <= i__2; ++i__) { sum += (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1)); /* L100: */ } } if (value < sum || sisnan_(&sum)) { value = sum; } /* L110: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (udiag) { sum = 1.f; i__2 = *m; for (i__ = j + 1; i__ <= i__2; ++i__) { sum += (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1)); /* L120: */ } } else { sum = 0.f; i__2 = *m; for (i__ = j; i__ <= i__2; ++i__) { sum += (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1)); /* L130: */ } } if (value < sum || sisnan_(&sum)) { value = sum; } /* L140: */ } } } else if (lsame_(norm, "I")) { /* Find normI(A). */ if (lsame_(uplo, "U")) { if (lsame_(diag, "U")) { i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 1.f; /* L150: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ i__3 = *m; i__4 = j - 1; // , expr subst i__2 = min(i__3,i__4); for (i__ = 1; i__ <= i__2; ++i__) { work[i__] += (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1)); /* L160: */ } /* L170: */ } } else { i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.f; /* L180: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = min(*m,j); for (i__ = 1; i__ <= i__2; ++i__) { work[i__] += (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1)); /* L190: */ } /* L200: */ } } } else { if (lsame_(diag, "U")) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 1.f; /* L210: */ } i__1 = *m; for (i__ = *n + 1; i__ <= i__1; ++i__) { work[i__] = 0.f; /* L220: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = j + 1; i__ <= i__2; ++i__) { work[i__] += (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1)); /* L230: */ } /* L240: */ } } else { i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.f; /* L250: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = j; i__ <= i__2; ++i__) { work[i__] += (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1)); /* L260: */ } /* L270: */ } } } value = 0.f; i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { sum = work[i__]; if (value < sum || sisnan_(&sum)) { value = sum; } /* L280: */ } } else if (lsame_(norm, "F") || lsame_(norm, "E")) { /* Find normF(A). */ if (lsame_(uplo, "U")) { if (lsame_(diag, "U")) { scale = 1.f; sum = (real) min(*m,*n); i__1 = *n; for (j = 2; j <= i__1; ++j) { /* Computing MIN */ i__3 = *m; i__4 = j - 1; // , expr subst i__2 = min(i__3,i__4); slassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum); /* L290: */ } } else { scale = 0.f; sum = 1.f; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = min(*m,j); slassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum); /* L300: */ } } } else { if (lsame_(diag, "U")) { scale = 1.f; sum = (real) min(*m,*n); i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m - j; /* Computing MIN */ i__3 = *m; i__4 = j + 1; // , expr subst slassq_(&i__2, &a[min(i__3,i__4) + j * a_dim1], &c__1, & scale, &sum); /* L310: */ } } else { scale = 0.f; sum = 1.f; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m - j + 1; slassq_(&i__2, &a[j + j * a_dim1], &c__1, &scale, &sum); /* L320: */ } } } value = scale * sqrt(sum); } ret_val = value; return ret_val; /* End of SLANTR */ }
/* 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_ */
doublereal slansp_(char *norm, char *uplo, integer *n, real *ap, real *work) { /* -- LAPACK auxiliary routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University October 31, 1992 Purpose ======= SLANSP returns the value of the one norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric matrix A, supplied in packed form. Description =========== SLANSP returns the value SLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm' ( ( norm1(A), NORM = '1', 'O' or 'o' ( ( normI(A), NORM = 'I' or 'i' ( ( normF(A), NORM = 'F', 'f', 'E' or 'e' where norm1 denotes the one norm of a matrix (maximum column sum), normI denotes the infinity norm of a matrix (maximum row sum) and normF denotes the Frobenius norm of a matrix (square root of sum of squares). Note that max(abs(A(i,j))) is not a matrix norm. Arguments ========= NORM (input) CHARACTER*1 Specifies the value to be returned in SLANSP as described above. UPLO (input) CHARACTER*1 Specifies whether the upper or lower triangular part of the symmetric matrix A is supplied. = 'U': Upper triangular part of A is supplied = 'L': Lower triangular part of A is supplied N (input) INTEGER The order of the matrix A. N >= 0. When N = 0, SLANSP is set to zero. 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. WORK (workspace) REAL array, dimension (LWORK), where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, WORK is not referenced. ===================================================================== Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; /* System generated locals */ integer i__1, i__2; real ret_val, r__1, r__2, r__3; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static real absa; static integer i__, j, k; static real scale; extern logical lsame_(char *, char *); static real value; extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, real *); static real sum; --work; --ap; /* Function Body */ if (*n == 0) { value = 0.f; } else if (lsame_(norm, "M")) { /* Find max(abs(A(i,j))). */ value = 0.f; if (lsame_(uplo, "U")) { k = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = k + j - 1; for (i__ = k; i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = ap[i__], dabs(r__1)); value = dmax(r__2,r__3); /* L10: */ } k += j; /* L20: */ } } else { k = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = k + *n - j; for (i__ = k; i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = ap[i__], dabs(r__1)); value = dmax(r__2,r__3); /* L30: */ } k = k + *n - j + 1; /* L40: */ } } } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') { /* Find normI(A) ( = norm1(A), since A is symmetric). */ value = 0.f; k = 1; if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= i__1; ++j) { sum = 0.f; i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { absa = (r__1 = ap[k], dabs(r__1)); sum += absa; work[i__] += absa; ++k; /* L50: */ } work[j] = sum + (r__1 = ap[k], dabs(r__1)); ++k; /* L60: */ } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { /* Computing MAX */ r__1 = value, r__2 = work[i__]; value = dmax(r__1,r__2); /* L70: */ } } else { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.f; /* L80: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { sum = work[j] + (r__1 = ap[k], dabs(r__1)); ++k; i__2 = *n; for (i__ = j + 1; i__ <= i__2; ++i__) { absa = (r__1 = ap[k], dabs(r__1)); sum += absa; work[i__] += absa; ++k; /* L90: */ } value = dmax(value,sum); /* L100: */ } } } else if (lsame_(norm, "F") || lsame_(norm, "E")) { /* Find normF(A). */ scale = 0.f; sum = 1.f; k = 2; if (lsame_(uplo, "U")) { i__1 = *n; for (j = 2; j <= i__1; ++j) { i__2 = j - 1; slassq_(&i__2, &ap[k], &c__1, &scale, &sum); k += j; /* L110: */ } } else { i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { i__2 = *n - j; slassq_(&i__2, &ap[k], &c__1, &scale, &sum); k = k + *n - j + 1; /* L120: */ } } sum *= 2; k = 1; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (ap[k] != 0.f) { absa = (r__1 = ap[k], dabs(r__1)); if (scale < absa) { /* Computing 2nd power */ r__1 = scale / absa; sum = sum * (r__1 * r__1) + 1.f; scale = absa; } else { /* Computing 2nd power */ r__1 = absa / scale; sum += r__1 * r__1; } } if (lsame_(uplo, "U")) { k = k + i__ + 1; } else { k = k + *n - i__ + 1; } /* L130: */ } value = scale * sqrt(sum); } ret_val = value; return ret_val; /* End of SLANSP */ } /* slansp_ */
double slange_(char *norm, int *m, int *n, float *a, int *lda, float *work) { /* System generated locals */ int a_dim1, a_offset, i__1, i__2; float ret_val, r__1, r__2, r__3; /* Builtin functions */ double sqrt(double); /* Local variables */ int i__, j; float sum, scale; extern int lsame_(char *, char *); float value; extern int slassq_(int *, float *, int *, float *, float *); /* -- LAPACK auxiliary routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* SLANGE returns the value of the one norm, or the Frobenius norm, or */ /* the infinity norm, or the element of largest absolute value of a */ /* float matrix A. */ /* Description */ /* =========== */ /* SLANGE returns the value */ /* SLANGE = ( MAX(ABS(A(i,j))), NORM = 'M' or 'm' */ /* ( */ /* ( norm1(A), NORM = '1', 'O' or 'o' */ /* ( */ /* ( normI(A), NORM = 'I' or 'i' */ /* ( */ /* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ /* where norm1 denotes the one norm of a matrix (maximum column sum), */ /* normI denotes the infinity norm of a matrix (maximum row sum) and */ /* normF denotes the Frobenius norm of a matrix (square root of sum of */ /* squares). Note that MAX(ABS(A(i,j))) is not a consistent matrix norm. */ /* Arguments */ /* ========= */ /* NORM (input) CHARACTER*1 */ /* Specifies the value to be returned in SLANGE as described */ /* above. */ /* M (input) INTEGER */ /* The number of rows of the matrix A. M >= 0. When M = 0, */ /* SLANGE is set to zero. */ /* N (input) INTEGER */ /* The number of columns of the matrix A. N >= 0. When N = 0, */ /* SLANGE is set to zero. */ /* A (input) REAL array, dimension (LDA,N) */ /* The m by n matrix A. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= MAX(M,1). */ /* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */ /* where LWORK >= M when NORM = 'I'; otherwise, WORK is not */ /* referenced. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --work; /* Function Body */ if (MIN(*m,*n) == 0) { value = 0.f; } else if (lsame_(norm, "M")) { /* Find MAX(ABS(A(i,j))). */ value = 0.f; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1], ABS(r__1)); value = MAX(r__2,r__3); /* L10: */ } /* L20: */ } } else if (lsame_(norm, "O") || *(unsigned char *) norm == '1') { /* Find norm1(A). */ value = 0.f; i__1 = *n; for (j = 1; j <= i__1; ++j) { sum = 0.f; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { sum += (r__1 = a[i__ + j * a_dim1], ABS(r__1)); /* L30: */ } value = MAX(value,sum); /* L40: */ } } else if (lsame_(norm, "I")) { /* Find normI(A). */ i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.f; /* L50: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { work[i__] += (r__1 = a[i__ + j * a_dim1], ABS(r__1)); /* L60: */ } /* L70: */ } value = 0.f; i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { /* Computing MAX */ r__1 = value, r__2 = work[i__]; value = MAX(r__1,r__2); /* L80: */ } } else if (lsame_(norm, "F") || lsame_(norm, "E")) { /* Find normF(A). */ scale = 0.f; sum = 1.f; i__1 = *n; for (j = 1; j <= i__1; ++j) { slassq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum); /* L90: */ } value = scale * sqrt(sum); } ret_val = value; return ret_val; /* End of SLANGE */ } /* slange_ */
doublereal slanst_(char *norm, integer *n, real *d__, real *e) { /* -- LAPACK auxiliary routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University February 29, 1992 Purpose ======= SLANST returns the value of the one norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric tridiagonal matrix A. Description =========== SLANST returns the value SLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm' ( ( norm1(A), NORM = '1', 'O' or 'o' ( ( normI(A), NORM = 'I' or 'i' ( ( normF(A), NORM = 'F', 'f', 'E' or 'e' where norm1 denotes the one norm of a matrix (maximum column sum), normI denotes the infinity norm of a matrix (maximum row sum) and normF denotes the Frobenius norm of a matrix (square root of sum of squares). Note that max(abs(A(i,j))) is not a matrix norm. Arguments ========= NORM (input) CHARACTER*1 Specifies the value to be returned in SLANST as described above. N (input) INTEGER The order of the matrix A. N >= 0. When N = 0, SLANST is set to zero. D (input) REAL array, dimension (N) The diagonal elements of A. E (input) REAL array, dimension (N-1) The (n-1) sub-diagonal or super-diagonal elements of A. ===================================================================== Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; /* System generated locals */ integer i__1; real ret_val, r__1, r__2, r__3, r__4, r__5; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static integer i__; static real scale; extern logical lsame_(char *, char *); static real anorm; extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, real *); static real sum; --e; --d__; /* Function Body */ if (*n <= 0) { anorm = 0.f; } else if (lsame_(norm, "M")) { /* Find max(abs(A(i,j))). */ anorm = (r__1 = d__[*n], dabs(r__1)); i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { /* Computing MAX */ r__2 = anorm, r__3 = (r__1 = d__[i__], dabs(r__1)); anorm = dmax(r__2,r__3); /* Computing MAX */ r__2 = anorm, r__3 = (r__1 = e[i__], dabs(r__1)); anorm = dmax(r__2,r__3); /* L10: */ } } else if (lsame_(norm, "O") || *(unsigned char *) norm == '1' || lsame_(norm, "I")) { /* Find norm1(A). */ if (*n == 1) { anorm = dabs(d__[1]); } else { /* Computing MAX */ r__3 = dabs(d__[1]) + dabs(e[1]), r__4 = (r__1 = e[*n - 1], dabs( r__1)) + (r__2 = d__[*n], dabs(r__2)); anorm = dmax(r__3,r__4); i__1 = *n - 1; for (i__ = 2; i__ <= i__1; ++i__) { /* Computing MAX */ r__4 = anorm, r__5 = (r__1 = d__[i__], dabs(r__1)) + (r__2 = e[i__], dabs(r__2)) + (r__3 = e[i__ - 1], dabs(r__3)); anorm = dmax(r__4,r__5); /* L20: */ } } } else if (lsame_(norm, "F") || lsame_(norm, "E")) { /* Find normF(A). */ scale = 0.f; sum = 1.f; if (*n > 1) { i__1 = *n - 1; slassq_(&i__1, &e[1], &c__1, &scale, &sum); sum *= 2; } slassq_(n, &d__[1], &c__1, &scale, &sum); anorm = scale * sqrt(sum); } ret_val = anorm; return ret_val; /* End of SLANST */ } /* slanst_ */
doublereal slantp_(char *norm, char *uplo, char *diag, integer *n, real *ap, real *work) { /* System generated locals */ integer i__1, i__2; real ret_val, r__1, r__2, r__3; /* Local variables */ integer i__, j, k; real sum, scale; logical udiag; real value; /* -- LAPACK auxiliary routine (version 3.2) -- */ /* November 2006 */ /* Purpose */ /* ======= */ /* SLANTP returns the value of the one norm, or the Frobenius norm, or */ /* the infinity norm, or the element of largest absolute value of a */ /* triangular matrix A, supplied in packed form. */ /* Description */ /* =========== */ /* SLANTP returns the value */ /* SLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ /* ( */ /* ( norm1(A), NORM = '1', 'O' or 'o' */ /* ( */ /* ( normI(A), NORM = 'I' or 'i' */ /* ( */ /* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ /* where norm1 denotes the one norm of a matrix (maximum column sum), */ /* normI denotes the infinity norm of a matrix (maximum row sum) and */ /* normF denotes the Frobenius norm of a matrix (square root of sum of */ /* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ /* Arguments */ /* ========= */ /* NORM (input) CHARACTER*1 */ /* Specifies the value to be returned in SLANTP as described */ /* above. */ /* UPLO (input) CHARACTER*1 */ /* Specifies whether the matrix A is upper or lower triangular. */ /* = 'U': Upper triangular */ /* = 'L': Lower triangular */ /* DIAG (input) CHARACTER*1 */ /* Specifies whether or not the matrix A is unit triangular. */ /* = 'N': Non-unit triangular */ /* = 'U': Unit triangular */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. When N = 0, SLANTP is */ /* set to zero. */ /* 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. */ /* Note that when DIAG = 'U', the elements of the array AP */ /* corresponding to the diagonal elements of the matrix A are */ /* not referenced, but are assumed to be one. */ /* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */ /* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */ /* referenced. */ /* ===================================================================== */ /* Parameter adjustments */ --work; --ap; /* Function Body */ if (*n == 0) { value = 0.f; } else if (lsame_(norm, "M")) { /* Find max(abs(A(i,j))). */ k = 1; if (lsame_(diag, "U")) { value = 1.f; if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = k + j - 2; for (i__ = k; i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = ap[i__], dabs(r__1)); value = dmax(r__2,r__3); } k += j; } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = k + *n - j; for (i__ = k + 1; i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = ap[i__], dabs(r__1)); value = dmax(r__2,r__3); } k = k + *n - j + 1; } } } else { value = 0.f; if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = k + j - 1; for (i__ = k; i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = ap[i__], dabs(r__1)); value = dmax(r__2,r__3); } k += j; } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = k + *n - j; for (i__ = k; i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = ap[i__], dabs(r__1)); value = dmax(r__2,r__3); } k = k + *n - j + 1; } } } } else if (lsame_(norm, "O") || *(unsigned char *) norm == '1') { /* Find norm1(A). */ value = 0.f; k = 1; udiag = lsame_(diag, "U"); if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (udiag) { sum = 1.f; i__2 = k + j - 2; for (i__ = k; i__ <= i__2; ++i__) { sum += (r__1 = ap[i__], dabs(r__1)); } } else { sum = 0.f; i__2 = k + j - 1; for (i__ = k; i__ <= i__2; ++i__) { sum += (r__1 = ap[i__], dabs(r__1)); } } k += j; value = dmax(value,sum); } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (udiag) { sum = 1.f; i__2 = k + *n - j; for (i__ = k + 1; i__ <= i__2; ++i__) { sum += (r__1 = ap[i__], dabs(r__1)); } } else { sum = 0.f; i__2 = k + *n - j; for (i__ = k; i__ <= i__2; ++i__) { sum += (r__1 = ap[i__], dabs(r__1)); } } k = k + *n - j + 1; value = dmax(value,sum); } } } else if (lsame_(norm, "I")) { /* Find normI(A). */ k = 1; if (lsame_(uplo, "U")) { if (lsame_(diag, "U")) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 1.f; } i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { work[i__] += (r__1 = ap[k], dabs(r__1)); ++k; } ++k; } } else { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.f; } i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j; for (i__ = 1; i__ <= i__2; ++i__) { work[i__] += (r__1 = ap[k], dabs(r__1)); ++k; } } } } else { if (lsame_(diag, "U")) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 1.f; } i__1 = *n; for (j = 1; j <= i__1; ++j) { ++k; i__2 = *n; for (i__ = j + 1; i__ <= i__2; ++i__) { work[i__] += (r__1 = ap[k], dabs(r__1)); ++k; } } } else { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.f; } i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { work[i__] += (r__1 = ap[k], dabs(r__1)); ++k; } } } } value = 0.f; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { /* Computing MAX */ r__1 = value, r__2 = work[i__]; value = dmax(r__1,r__2); } } else if (lsame_(norm, "F") || lsame_(norm, "E")) { /* Find normF(A). */ if (lsame_(uplo, "U")) { if (lsame_(diag, "U")) { scale = 1.f; sum = (real) (*n); k = 2; i__1 = *n; for (j = 2; j <= i__1; ++j) { i__2 = j - 1; slassq_(&i__2, &ap[k], &c__1, &scale, &sum); k += j; } } else { scale = 0.f; sum = 1.f; k = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { slassq_(&j, &ap[k], &c__1, &scale, &sum); k += j; } } } else { if (lsame_(diag, "U")) { scale = 1.f; sum = (real) (*n); k = 2; i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { i__2 = *n - j; slassq_(&i__2, &ap[k], &c__1, &scale, &sum); k = k + *n - j + 1; } } else { scale = 0.f; sum = 1.f; k = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *n - j + 1; slassq_(&i__2, &ap[k], &c__1, &scale, &sum); k = k + *n - j + 1; } } } value = scale * sqrt(sum); } ret_val = value; return ret_val; /* End of SLANTP */ } /* slantp_ */
doublereal slantb_(char *norm, char *uplo, char *diag, integer *n, integer *k, real *ab, integer *ldab, real *work) { /* -- LAPACK auxiliary routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University October 31, 1992 Purpose ======= SLANTB returns the value of the one norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of an n by n triangular band matrix A, with ( k + 1 ) diagonals. Description =========== SLANTB returns the value SLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm' ( ( norm1(A), NORM = '1', 'O' or 'o' ( ( normI(A), NORM = 'I' or 'i' ( ( normF(A), NORM = 'F', 'f', 'E' or 'e' where norm1 denotes the one norm of a matrix (maximum column sum), normI denotes the infinity norm of a matrix (maximum row sum) and normF denotes the Frobenius norm of a matrix (square root of sum of squares). Note that max(abs(A(i,j))) is not a matrix norm. Arguments ========= NORM (input) CHARACTER*1 Specifies the value to be returned in SLANTB as described above. UPLO (input) CHARACTER*1 Specifies whether the matrix A is upper or lower triangular. = 'U': Upper triangular = 'L': Lower triangular DIAG (input) CHARACTER*1 Specifies whether or not the matrix A is unit triangular. = 'N': Non-unit triangular = 'U': Unit triangular N (input) INTEGER The order of the matrix A. N >= 0. When N = 0, SLANTB is set to zero. K (input) INTEGER The number of super-diagonals of the matrix A if UPLO = 'U', or the number of sub-diagonals of the matrix A if UPLO = 'L'. K >= 0. AB (input) REAL array, dimension (LDAB,N) The upper or lower triangular band matrix A, stored in the first k+1 rows of AB. The j-th column of A is stored in the j-th column of the array AB as follows: if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). Note that when DIAG = 'U', the elements of the array AB corresponding to the diagonal elements of the matrix A are not referenced, but are assumed to be one. LDAB (input) INTEGER The leading dimension of the array AB. LDAB >= K+1. WORK (workspace) REAL array, dimension (LWORK), where LWORK >= N when NORM = 'I'; otherwise, WORK is not referenced. ===================================================================== Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; /* System generated locals */ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5; real ret_val, r__1, r__2, r__3; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static integer i__, j, l; static real scale; static logical udiag; extern logical lsame_(char *, char *); static real value; extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, real *); static real sum; #define ab_ref(a_1,a_2) ab[(a_2)*ab_dim1 + a_1] ab_dim1 = *ldab; ab_offset = 1 + ab_dim1 * 1; ab -= ab_offset; --work; /* Function Body */ if (*n == 0) { value = 0.f; } else if (lsame_(norm, "M")) { /* Find max(abs(A(i,j))). */ if (lsame_(diag, "U")) { value = 1.f; if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ i__2 = *k + 2 - j; i__3 = *k; for (i__ = max(i__2,1); i__ <= i__3; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = ab_ref(i__, j), dabs( r__1)); value = dmax(r__2,r__3); /* L10: */ } /* L20: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ i__2 = *n + 1 - j, i__4 = *k + 1; i__3 = min(i__2,i__4); for (i__ = 2; i__ <= i__3; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = ab_ref(i__, j), dabs( r__1)); value = dmax(r__2,r__3); /* L30: */ } /* L40: */ } } } else { value = 0.f; if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ i__3 = *k + 2 - j; i__2 = *k + 1; for (i__ = max(i__3,1); i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = ab_ref(i__, j), dabs( r__1)); value = dmax(r__2,r__3); /* L50: */ } /* L60: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ i__3 = *n + 1 - j, i__4 = *k + 1; i__2 = min(i__3,i__4); for (i__ = 1; i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = ab_ref(i__, j), dabs( r__1)); value = dmax(r__2,r__3); /* L70: */ } /* L80: */ } } } } else if (lsame_(norm, "O") || *(unsigned char *) norm == '1') { /* Find norm1(A). */ value = 0.f; udiag = lsame_(diag, "U"); if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (udiag) { sum = 1.f; /* Computing MAX */ i__2 = *k + 2 - j; i__3 = *k; for (i__ = max(i__2,1); i__ <= i__3; ++i__) { sum += (r__1 = ab_ref(i__, j), dabs(r__1)); /* L90: */ } } else { sum = 0.f; /* Computing MAX */ i__3 = *k + 2 - j; i__2 = *k + 1; for (i__ = max(i__3,1); i__ <= i__2; ++i__) { sum += (r__1 = ab_ref(i__, j), dabs(r__1)); /* L100: */ } } value = dmax(value,sum); /* L110: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (udiag) { sum = 1.f; /* Computing MIN */ i__3 = *n + 1 - j, i__4 = *k + 1; i__2 = min(i__3,i__4); for (i__ = 2; i__ <= i__2; ++i__) { sum += (r__1 = ab_ref(i__, j), dabs(r__1)); /* L120: */ } } else { sum = 0.f; /* Computing MIN */ i__3 = *n + 1 - j, i__4 = *k + 1; i__2 = min(i__3,i__4); for (i__ = 1; i__ <= i__2; ++i__) { sum += (r__1 = ab_ref(i__, j), dabs(r__1)); /* L130: */ } } value = dmax(value,sum); /* L140: */ } } } else if (lsame_(norm, "I")) { /* Find normI(A). */ value = 0.f; if (lsame_(uplo, "U")) { if (lsame_(diag, "U")) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 1.f; /* L150: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { l = *k + 1 - j; /* Computing MAX */ i__2 = 1, i__3 = j - *k; i__4 = j - 1; for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { work[i__] += (r__1 = ab_ref(l + i__, j), dabs(r__1)); /* L160: */ } /* L170: */ } } else { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.f; /* L180: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { l = *k + 1 - j; /* Computing MAX */ i__4 = 1, i__2 = j - *k; i__3 = j; for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { work[i__] += (r__1 = ab_ref(l + i__, j), dabs(r__1)); /* L190: */ } /* L200: */ } } } else { if (lsame_(diag, "U")) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 1.f; /* L210: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { l = 1 - j; /* Computing MIN */ i__4 = *n, i__2 = j + *k; i__3 = min(i__4,i__2); for (i__ = j + 1; i__ <= i__3; ++i__) { work[i__] += (r__1 = ab_ref(l + i__, j), dabs(r__1)); /* L220: */ } /* L230: */ } } else { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.f; /* L240: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { l = 1 - j; /* Computing MIN */ i__4 = *n, i__2 = j + *k; i__3 = min(i__4,i__2); for (i__ = j; i__ <= i__3; ++i__) { work[i__] += (r__1 = ab_ref(l + i__, j), dabs(r__1)); /* L250: */ } /* L260: */ } } } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { /* Computing MAX */ r__1 = value, r__2 = work[i__]; value = dmax(r__1,r__2); /* L270: */ } } else if (lsame_(norm, "F") || lsame_(norm, "E")) { /* Find normF(A). */ if (lsame_(uplo, "U")) { if (lsame_(diag, "U")) { scale = 1.f; sum = (real) (*n); if (*k > 0) { i__1 = *n; for (j = 2; j <= i__1; ++j) { /* Computing MAX */ i__3 = *k + 2 - j; /* Computing MIN */ i__2 = j - 1; i__4 = min(i__2,*k); slassq_(&i__4, &ab_ref(max(i__3,1), j), &c__1, &scale, &sum); /* L280: */ } } } else { scale = 0.f; sum = 1.f; i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ i__3 = *k + 2 - j; /* Computing MIN */ i__2 = j, i__5 = *k + 1; i__4 = min(i__2,i__5); slassq_(&i__4, &ab_ref(max(i__3,1), j), &c__1, &scale, & sum); /* L290: */ } } } else { if (lsame_(diag, "U")) { scale = 1.f; sum = (real) (*n); if (*k > 0) { i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ i__4 = *n - j; i__3 = min(i__4,*k); slassq_(&i__3, &ab_ref(2, j), &c__1, &scale, &sum); /* L300: */ } } } else { scale = 0.f; sum = 1.f; i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ i__4 = *n - j + 1, i__2 = *k + 1; i__3 = min(i__4,i__2); slassq_(&i__3, &ab_ref(1, j), &c__1, &scale, &sum); /* L310: */ } } } value = scale * sqrt(sum); } ret_val = value; return ret_val; /* End of SLANTB */ } /* slantb_ */
doublereal slantb_(char *norm, char *uplo, char *diag, integer *n, integer *k, real *ab, integer *ldab, real *work) { /* System generated locals */ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5; real ret_val, r__1, r__2, r__3; /* Local variables */ integer i__, j, l; real sum, scale; logical udiag; real value; /* -- LAPACK auxiliary routine (version 3.2) -- */ /* November 2006 */ /* Purpose */ /* ======= */ /* SLANTB returns the value of the one norm, or the Frobenius norm, or */ /* the infinity norm, or the element of largest absolute value of an */ /* n by n triangular band matrix A, with ( k + 1 ) diagonals. */ /* Description */ /* =========== */ /* SLANTB returns the value */ /* SLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ /* ( */ /* ( norm1(A), NORM = '1', 'O' or 'o' */ /* ( */ /* ( normI(A), NORM = 'I' or 'i' */ /* ( */ /* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ /* where norm1 denotes the one norm of a matrix (maximum column sum), */ /* normI denotes the infinity norm of a matrix (maximum row sum) and */ /* normF denotes the Frobenius norm of a matrix (square root of sum of */ /* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ /* Arguments */ /* ========= */ /* NORM (input) CHARACTER*1 */ /* Specifies the value to be returned in SLANTB as described */ /* above. */ /* UPLO (input) CHARACTER*1 */ /* Specifies whether the matrix A is upper or lower triangular. */ /* = 'U': Upper triangular */ /* = 'L': Lower triangular */ /* DIAG (input) CHARACTER*1 */ /* Specifies whether or not the matrix A is unit triangular. */ /* = 'N': Non-unit triangular */ /* = 'U': Unit triangular */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. When N = 0, SLANTB is */ /* set to zero. */ /* K (input) INTEGER */ /* The number of super-diagonals of the matrix A if UPLO = 'U', */ /* or the number of sub-diagonals of the matrix A if UPLO = 'L'. */ /* K >= 0. */ /* AB (input) REAL array, dimension (LDAB,N) */ /* The upper or lower triangular band matrix A, stored in the */ /* first k+1 rows of AB. The j-th column of A is stored */ /* in the j-th column of the array AB as follows: */ /* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; */ /* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). */ /* Note that when DIAG = 'U', the elements of the array AB */ /* corresponding to the diagonal elements of the matrix A are */ /* not referenced, but are assumed to be one. */ /* LDAB (input) INTEGER */ /* The leading dimension of the array AB. LDAB >= K+1. */ /* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */ /* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */ /* referenced. */ /* ===================================================================== */ /* Parameter adjustments */ ab_dim1 = *ldab; ab_offset = 1 + ab_dim1; ab -= ab_offset; --work; /* Function Body */ if (*n == 0) { value = 0.f; } else if (lsame_(norm, "M")) { /* Find max(abs(A(i,j))). */ if (lsame_(diag, "U")) { value = 1.f; if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ i__2 = *k + 2 - j; i__3 = *k; for (i__ = max(i__2,1); i__ <= i__3; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = ab[i__ + j * ab_dim1], dabs(r__1)); value = dmax(r__2,r__3); } } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ i__2 = *n + 1 - j, i__4 = *k + 1; i__3 = min(i__2,i__4); for (i__ = 2; i__ <= i__3; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = ab[i__ + j * ab_dim1], dabs(r__1)); value = dmax(r__2,r__3); } } } } else { value = 0.f; if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ i__3 = *k + 2 - j; i__2 = *k + 1; for (i__ = max(i__3,1); i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = ab[i__ + j * ab_dim1], dabs(r__1)); value = dmax(r__2,r__3); } } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ i__3 = *n + 1 - j, i__4 = *k + 1; i__2 = min(i__3,i__4); for (i__ = 1; i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = ab[i__ + j * ab_dim1], dabs(r__1)); value = dmax(r__2,r__3); } } } } } else if (lsame_(norm, "O") || *(unsigned char *) norm == '1') { /* Find norm1(A). */ value = 0.f; udiag = lsame_(diag, "U"); if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (udiag) { sum = 1.f; /* Computing MAX */ i__2 = *k + 2 - j; i__3 = *k; for (i__ = max(i__2,1); i__ <= i__3; ++i__) { sum += (r__1 = ab[i__ + j * ab_dim1], dabs(r__1)); } } else { sum = 0.f; /* Computing MAX */ i__3 = *k + 2 - j; i__2 = *k + 1; for (i__ = max(i__3,1); i__ <= i__2; ++i__) { sum += (r__1 = ab[i__ + j * ab_dim1], dabs(r__1)); } } value = dmax(value,sum); } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (udiag) { sum = 1.f; /* Computing MIN */ i__3 = *n + 1 - j, i__4 = *k + 1; i__2 = min(i__3,i__4); for (i__ = 2; i__ <= i__2; ++i__) { sum += (r__1 = ab[i__ + j * ab_dim1], dabs(r__1)); } } else { sum = 0.f; /* Computing MIN */ i__3 = *n + 1 - j, i__4 = *k + 1; i__2 = min(i__3,i__4); for (i__ = 1; i__ <= i__2; ++i__) { sum += (r__1 = ab[i__ + j * ab_dim1], dabs(r__1)); } } value = dmax(value,sum); } } } else if (lsame_(norm, "I")) { /* Find normI(A). */ value = 0.f; if (lsame_(uplo, "U")) { if (lsame_(diag, "U")) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 1.f; } i__1 = *n; for (j = 1; j <= i__1; ++j) { l = *k + 1 - j; /* Computing MAX */ i__2 = 1, i__3 = j - *k; i__4 = j - 1; for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { work[i__] += (r__1 = ab[l + i__ + j * ab_dim1], dabs( r__1)); } } } else { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.f; } i__1 = *n; for (j = 1; j <= i__1; ++j) { l = *k + 1 - j; /* Computing MAX */ i__4 = 1, i__2 = j - *k; i__3 = j; for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { work[i__] += (r__1 = ab[l + i__ + j * ab_dim1], dabs( r__1)); } } } } else { if (lsame_(diag, "U")) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 1.f; } i__1 = *n; for (j = 1; j <= i__1; ++j) { l = 1 - j; /* Computing MIN */ i__4 = *n, i__2 = j + *k; i__3 = min(i__4,i__2); for (i__ = j + 1; i__ <= i__3; ++i__) { work[i__] += (r__1 = ab[l + i__ + j * ab_dim1], dabs( r__1)); } } } else { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.f; } i__1 = *n; for (j = 1; j <= i__1; ++j) { l = 1 - j; /* Computing MIN */ i__4 = *n, i__2 = j + *k; i__3 = min(i__4,i__2); for (i__ = j; i__ <= i__3; ++i__) { work[i__] += (r__1 = ab[l + i__ + j * ab_dim1], dabs( r__1)); } } } } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { /* Computing MAX */ r__1 = value, r__2 = work[i__]; value = dmax(r__1,r__2); } } else if (lsame_(norm, "F") || lsame_(norm, "E")) { /* Find normF(A). */ if (lsame_(uplo, "U")) { if (lsame_(diag, "U")) { scale = 1.f; sum = (real) (*n); if (*k > 0) { i__1 = *n; for (j = 2; j <= i__1; ++j) { /* Computing MIN */ i__4 = j - 1; i__3 = min(i__4,*k); /* Computing MAX */ i__2 = *k + 2 - j; slassq_(&i__3, &ab[max(i__2, 1)+ j * ab_dim1], &c__1, &scale, &sum); } } } else { scale = 0.f; sum = 1.f; i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ i__4 = j, i__2 = *k + 1; i__3 = min(i__4,i__2); /* Computing MAX */ i__5 = *k + 2 - j; slassq_(&i__3, &ab[max(i__5, 1)+ j * ab_dim1], &c__1, & scale, &sum); } } } else { if (lsame_(diag, "U")) { scale = 1.f; sum = (real) (*n); if (*k > 0) { i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ i__4 = *n - j; i__3 = min(i__4,*k); slassq_(&i__3, &ab[j * ab_dim1 + 2], &c__1, &scale, & sum); } } } else { scale = 0.f; sum = 1.f; i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ i__4 = *n - j + 1, i__2 = *k + 1; i__3 = min(i__4,i__2); slassq_(&i__3, &ab[j * ab_dim1 + 1], &c__1, &scale, &sum); } } } value = scale * sqrt(sum); } ret_val = value; return ret_val; /* End of SLANTB */ } /* slantb_ */
doublereal slansy_(char *norm, char *uplo, integer *n, real *a, integer *lda, real *work) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; real ret_val, r__1, r__2, r__3; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ integer i__, j; real sum, absa, scale; extern logical lsame_(char *, char *); real value; extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, real *); /* -- LAPACK auxiliary routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* SLANSY returns the value of the one norm, or the Frobenius norm, or */ /* the infinity norm, or the element of largest absolute value of a */ /* real symmetric matrix A. */ /* Description */ /* =========== */ /* SLANSY returns the value */ /* SLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ /* ( */ /* ( norm1(A), NORM = '1', 'O' or 'o' */ /* ( */ /* ( normI(A), NORM = 'I' or 'i' */ /* ( */ /* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ /* where norm1 denotes the one norm of a matrix (maximum column sum), */ /* normI denotes the infinity norm of a matrix (maximum row sum) and */ /* normF denotes the Frobenius norm of a matrix (square root of sum of */ /* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ /* Arguments */ /* ========= */ /* NORM (input) CHARACTER*1 */ /* Specifies the value to be returned in SLANSY as described */ /* above. */ /* UPLO (input) CHARACTER*1 */ /* Specifies whether the upper or lower triangular part of the */ /* symmetric matrix A is to be referenced. */ /* = 'U': Upper triangular part of A is referenced */ /* = 'L': Lower triangular part of A is referenced */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. When N = 0, SLANSY is */ /* set to zero. */ /* 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(N,1). */ /* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */ /* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */ /* WORK is not referenced. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --work; /* Function Body */ if (*n == 0) { value = 0.f; } else if (lsame_(norm, "M")) { /* Find max(abs(A(i,j))). */ value = 0.f; if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j; for (i__ = 1; i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1], dabs( r__1)); value = dmax(r__2,r__3); /* L10: */ } /* L20: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1], dabs( r__1)); value = dmax(r__2,r__3); /* L30: */ } /* L40: */ } } } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') { /* Find normI(A) ( = norm1(A), since A is symmetric). */ value = 0.f; if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= i__1; ++j) { sum = 0.f; i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { absa = (r__1 = a[i__ + j * a_dim1], dabs(r__1)); sum += absa; work[i__] += absa; /* L50: */ } work[j] = sum + (r__1 = a[j + j * a_dim1], dabs(r__1)); /* L60: */ } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { /* Computing MAX */ r__1 = value, r__2 = work[i__]; value = dmax(r__1,r__2); /* L70: */ } } else { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.f; /* L80: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { sum = work[j] + (r__1 = a[j + j * a_dim1], dabs(r__1)); i__2 = *n; for (i__ = j + 1; i__ <= i__2; ++i__) { absa = (r__1 = a[i__ + j * a_dim1], dabs(r__1)); sum += absa; work[i__] += absa; /* L90: */ } value = dmax(value,sum); /* L100: */ } } } else if (lsame_(norm, "F") || lsame_(norm, "E")) { /* Find normF(A). */ scale = 0.f; sum = 1.f; if (lsame_(uplo, "U")) { i__1 = *n; for (j = 2; j <= i__1; ++j) { i__2 = j - 1; slassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum); /* L110: */ } } else { i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { i__2 = *n - j; slassq_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &scale, &sum); /* L120: */ } } sum *= 2; i__1 = *lda + 1; slassq_(n, &a[a_offset], &i__1, &scale, &sum); value = scale * sqrt(sum); } ret_val = value; return ret_val; /* End of SLANSY */ } /* slansy_ */
/* ===================================================================== */ real slanst_(char *norm, integer *n, real *d__, real *e) { /* System generated locals */ integer i__1; real ret_val, r__1, r__2, r__3; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ integer i__; real sum, scale; extern logical lsame_(char *, char *); real anorm; extern logical sisnan_(real *); extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, real *); /* -- LAPACK auxiliary routine (version 3.4.2) -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ /* September 2012 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ --e; --d__; /* Function Body */ if (*n <= 0) { anorm = 0.f; } else if (lsame_(norm, "M")) { /* Find max(f2c_abs(A(i,j))). */ anorm = (r__1 = d__[*n], f2c_abs(r__1)); i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { sum = (r__1 = d__[i__], f2c_abs(r__1)); if (anorm < sum || sisnan_(&sum)) { anorm = sum; } sum = (r__1 = e[i__], f2c_abs(r__1)); if (anorm < sum || sisnan_(&sum)) { anorm = sum; } /* L10: */ } } else if (lsame_(norm, "O") || *(unsigned char *) norm == '1' || lsame_(norm, "I")) { /* Find norm1(A). */ if (*n == 1) { anorm = f2c_abs(d__[1]); } else { anorm = f2c_abs(d__[1]) + f2c_abs(e[1]); sum = (r__1 = e[*n - 1], f2c_abs(r__1)) + (r__2 = d__[*n], f2c_abs(r__2)); if (anorm < sum || sisnan_(&sum)) { anorm = sum; } i__1 = *n - 1; for (i__ = 2; i__ <= i__1; ++i__) { sum = (r__1 = d__[i__], f2c_abs(r__1)) + (r__2 = e[i__], f2c_abs(r__2) ) + (r__3 = e[i__ - 1], f2c_abs(r__3)); if (anorm < sum || sisnan_(&sum)) { anorm = sum; } /* L20: */ } } } else if (lsame_(norm, "F") || lsame_(norm, "E")) { /* Find normF(A). */ scale = 0.f; sum = 1.f; if (*n > 1) { i__1 = *n - 1; slassq_(&i__1, &e[1], &c__1, &scale, &sum); sum *= 2; } slassq_(n, &d__[1], &c__1, &scale, &sum); anorm = scale * sqrt(sum); } ret_val = anorm; return ret_val; /* End of SLANST */ }
/* Subroutine */ int stgex2_(logical *wantq, logical *wantz, integer *n, real *a, integer *lda, real *b, integer *ldb, real *q, integer *ldq, real * z__, integer *ldz, integer *j1, integer *n1, integer *n2, real *work, integer *lwork, integer *info) { /* 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); /* Local variables */ real f, g; integer i__, m; real s[16] /* was [4][4] */, t[16] /* was [4][4] */, be[2], ai[2], ar[2], sa, sb, li[16] /* was [4][4] */, ir[16] /* was [4][4] */, ss, ws, eps; logical weak; real ddum; integer idum; real taul[4], dsum, taur[4], scpy[16] /* was [4][4] */, tcpy[16] /* was [4][4] */; extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, integer *, real *, real *); real scale, bqra21, brqa21; extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); real licop[16] /* was [4][4] */; integer linfo; extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *); real ircop[16] /* was [4][4] */, dnorm; integer iwork[4]; extern /* Subroutine */ int slagv2_(real *, integer *, real *, integer *, real *, real *, real *, real *, real *, real *, real *), sgeqr2_( integer *, integer *, real *, integer *, real *, real *, integer * ), sgerq2_(integer *, integer *, real *, integer *, real *, real * , integer *), sorg2r_(integer *, integer *, integer *, real *, integer *, real *, real *, integer *), sorgr2_(integer *, integer *, integer *, real *, integer *, real *, real *, integer *), sorm2r_(char *, char *, integer *, integer *, integer *, real *, integer *, real *, real *, integer *, real *, integer *), sormr2_(char *, char *, integer *, integer *, integer *, real *, integer *, real *, real *, integer *, real *, integer *); real dscale; extern /* Subroutine */ int stgsy2_(char *, integer *, integer *, integer *, real *, integer *, real *, integer *, real *, integer *, real * , integer *, real *, integer *, real *, integer *, real *, real *, real *, integer *, integer *, integer *); extern doublereal slamch_(char *); extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *), slartg_(real *, real *, real *, real *, real *); real thresh; extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *, real *, real *, integer *), slassq_(integer *, real *, integer *, real *, real *); real smlnum; logical strong; /* -- LAPACK auxiliary routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* STGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22) */ /* of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair */ /* (A, B) by an orthogonal equivalence transformation. */ /* (A, B) must be in generalized real Schur canonical form (as returned */ /* by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 */ /* diagonal blocks. B is upper triangular. */ /* Optionally, the matrices Q and Z of generalized Schur vectors are */ /* updated. */ /* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)' */ /* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)' */ /* Arguments */ /* ========= */ /* WANTQ (input) LOGICAL */ /* .TRUE. : update the left transformation matrix Q; */ /* .FALSE.: do not update Q. */ /* WANTZ (input) LOGICAL */ /* .TRUE. : update the right transformation matrix Z; */ /* .FALSE.: do not update Z. */ /* N (input) INTEGER */ /* The order of the matrices A and B. N >= 0. */ /* A (input/output) REAL arrays, dimensions (LDA,N) */ /* On entry, the matrix A in the pair (A, B). */ /* On exit, the updated matrix A. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,N). */ /* B (input/output) REAL arrays, dimensions (LDB,N) */ /* On entry, the matrix B in the pair (A, B). */ /* On exit, the updated matrix B. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= max(1,N). */ /* Q (input/output) REAL array, dimension (LDZ,N) */ /* On entry, if WANTQ = .TRUE., the orthogonal matrix Q. */ /* On exit, the updated matrix Q. */ /* Not referenced if WANTQ = .FALSE.. */ /* LDQ (input) INTEGER */ /* The leading dimension of the array Q. LDQ >= 1. */ /* If WANTQ = .TRUE., LDQ >= N. */ /* Z (input/output) REAL array, dimension (LDZ,N) */ /* On entry, if WANTZ =.TRUE., the orthogonal matrix Z. */ /* On exit, the updated matrix Z. */ /* Not referenced if WANTZ = .FALSE.. */ /* LDZ (input) INTEGER */ /* The leading dimension of the array Z. LDZ >= 1. */ /* If WANTZ = .TRUE., LDZ >= N. */ /* J1 (input) INTEGER */ /* The index to the first block (A11, B11). 1 <= J1 <= N. */ /* N1 (input) INTEGER */ /* The order of the first block (A11, B11). N1 = 0, 1 or 2. */ /* N2 (input) INTEGER */ /* The order of the second block (A22, B22). N2 = 0, 1 or 2. */ /* WORK (workspace) REAL array, dimension (MAX(1,LWORK)). */ /* LWORK (input) INTEGER */ /* The dimension of the array WORK. */ /* LWORK >= MAX( N*(N2+N1), (N2+N1)*(N2+N1)*2 ) */ /* INFO (output) INTEGER */ /* =0: Successful exit */ /* >0: If INFO = 1, the transformed matrix (A, B) would be */ /* too far from generalized Schur form; the blocks are */ /* not swapped and (A, B) and (Q, Z) are unchanged. */ /* The problem of swapping is too ill-conditioned. */ /* <0: If INFO = -16: LWORK is too small. Appropriate value */ /* for LWORK is returned in WORK(1). */ /* Further Details */ /* =============== */ /* Based on contributions by */ /* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ /* Umea University, S-901 87 Umea, Sweden. */ /* In the current code both weak and strong stability tests are */ /* performed. The user can omit the strong stability test by changing */ /* the internal logical parameter WANDS to .FALSE.. See ref. [2] for */ /* details. */ /* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */ /* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */ /* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */ /* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */ /* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */ /* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */ /* Estimation: Theory, Algorithms and Software, */ /* Report UMINF - 94.04, Department of Computing Science, Umea */ /* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */ /* Note 87. To appear in Numerical Algorithms, 1996. */ /* ===================================================================== */ /* Replaced various illegal calls to SCOPY by calls to SLASET, or by DO */ /* loops. Sven Hammarling, 1/5/02. */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; q_dim1 = *ldq; q_offset = 1 + q_dim1; q -= q_offset; z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --work; /* Function Body */ *info = 0; /* Quick return if possible */ if (*n <= 1 || *n1 <= 0 || *n2 <= 0) { return 0; } if (*n1 > *n || *j1 + *n1 > *n) { return 0; } m = *n1 + *n2; /* Computing MAX */ i__1 = *n * m, i__2 = m * m << 1; if (*lwork < max(i__1,i__2)) { *info = -16; /* Computing MAX */ i__1 = *n * m, i__2 = m * m << 1; work[1] = (real) max(i__1,i__2); return 0; } weak = FALSE_; strong = FALSE_; /* Make a local copy of selected block */ slaset_("Full", &c__4, &c__4, &c_b5, &c_b5, li, &c__4); slaset_("Full", &c__4, &c__4, &c_b5, &c_b5, ir, &c__4); slacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, s, &c__4); slacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, t, &c__4); /* Compute threshold for testing acceptance of swapping. */ eps = slamch_("P"); smlnum = slamch_("S") / eps; dscale = 0.f; dsum = 1.f; slacpy_("Full", &m, &m, s, &c__4, &work[1], &m); i__1 = m * m; slassq_(&i__1, &work[1], &c__1, &dscale, &dsum); slacpy_("Full", &m, &m, t, &c__4, &work[1], &m); i__1 = m * m; slassq_(&i__1, &work[1], &c__1, &dscale, &dsum); dnorm = dscale * sqrt(dsum); /* Computing MAX */ r__1 = eps * 10.f * dnorm; thresh = dmax(r__1,smlnum); if (m == 2) { /* CASE 1: Swap 1-by-1 and 1-by-1 blocks. */ /* Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks */ /* using Givens rotations and perform the swap tentatively. */ f = s[5] * t[0] - t[5] * s[0]; g = s[5] * t[4] - t[5] * s[4]; sb = dabs(t[5]); sa = dabs(s[5]); slartg_(&f, &g, &ir[4], ir, &ddum); ir[1] = -ir[4]; ir[5] = ir[0]; srot_(&c__2, s, &c__1, &s[4], &c__1, ir, &ir[1]); srot_(&c__2, t, &c__1, &t[4], &c__1, ir, &ir[1]); if (sa >= sb) { slartg_(s, &s[1], li, &li[1], &ddum); } else { slartg_(t, &t[1], li, &li[1], &ddum); } srot_(&c__2, s, &c__4, &s[1], &c__4, li, &li[1]); srot_(&c__2, t, &c__4, &t[1], &c__4, li, &li[1]); li[5] = li[0]; li[4] = -li[1]; /* Weak stability test: */ /* |S21| + |T21| <= O(EPS * F-norm((S, T))) */ ws = dabs(s[1]) + dabs(t[1]); weak = ws <= thresh; if (! weak) { goto L70; } if (TRUE_) { /* Strong stability test: */ /* F-norm((A-QL'*S*QR, B-QL'*T*QR)) <= O(EPS*F-norm((A,B))) */ slacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, &work[m * m + 1], &m); sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, & work[1], &m); sgemm_("N", "T", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, & c_b42, &work[m * m + 1], &m); dscale = 0.f; dsum = 1.f; i__1 = m * m; slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum); slacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, &work[m * m + 1], &m); sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, & work[1], &m); sgemm_("N", "T", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, & c_b42, &work[m * m + 1], &m); i__1 = m * m; slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum); ss = dscale * sqrt(dsum); strong = ss <= thresh; if (! strong) { goto L70; } } /* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and */ /* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */ i__1 = *j1 + 1; srot_(&i__1, &a[*j1 * a_dim1 + 1], &c__1, &a[(*j1 + 1) * a_dim1 + 1], &c__1, ir, &ir[1]); i__1 = *j1 + 1; srot_(&i__1, &b[*j1 * b_dim1 + 1], &c__1, &b[(*j1 + 1) * b_dim1 + 1], &c__1, ir, &ir[1]); i__1 = *n - *j1 + 1; srot_(&i__1, &a[*j1 + *j1 * a_dim1], lda, &a[*j1 + 1 + *j1 * a_dim1], lda, li, &li[1]); i__1 = *n - *j1 + 1; srot_(&i__1, &b[*j1 + *j1 * b_dim1], ldb, &b[*j1 + 1 + *j1 * b_dim1], ldb, li, &li[1]); /* Set N1-by-N2 (2,1) - blocks to ZERO. */ a[*j1 + 1 + *j1 * a_dim1] = 0.f; b[*j1 + 1 + *j1 * b_dim1] = 0.f; /* Accumulate transformations into Q and Z if requested. */ if (*wantz) { srot_(n, &z__[*j1 * z_dim1 + 1], &c__1, &z__[(*j1 + 1) * z_dim1 + 1], &c__1, ir, &ir[1]); } if (*wantq) { srot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[(*j1 + 1) * q_dim1 + 1], &c__1, li, &li[1]); } /* Exit with INFO = 0 if swap was successfully performed. */ return 0; } else { /* CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2 */ /* and 2-by-2 blocks. */ /* Solve the generalized Sylvester equation */ /* S11 * R - L * S22 = SCALE * S12 */ /* T11 * R - L * T22 = SCALE * T12 */ /* for R and L. Solutions in LI and IR. */ slacpy_("Full", n1, n2, &t[(*n1 + 1 << 2) - 4], &c__4, li, &c__4); slacpy_("Full", n1, n2, &s[(*n1 + 1 << 2) - 4], &c__4, &ir[*n2 + 1 + ( *n1 + 1 << 2) - 5], &c__4); stgsy2_("N", &c__0, n1, n2, s, &c__4, &s[*n1 + 1 + (*n1 + 1 << 2) - 5] , &c__4, &ir[*n2 + 1 + (*n1 + 1 << 2) - 5], &c__4, t, &c__4, & t[*n1 + 1 + (*n1 + 1 << 2) - 5], &c__4, li, &c__4, &scale, & dsum, &dscale, iwork, &idum, &linfo); /* Compute orthogonal matrix QL: */ /* QL' * LI = [ TL ] */ /* [ 0 ] */ /* where */ /* LI = [ -L ] */ /* [ SCALE * identity(N2) ] */ i__1 = *n2; for (i__ = 1; i__ <= i__1; ++i__) { sscal_(n1, &c_b48, &li[(i__ << 2) - 4], &c__1); li[*n1 + i__ + (i__ << 2) - 5] = scale; /* L10: */ } sgeqr2_(&m, n2, li, &c__4, taul, &work[1], &linfo); if (linfo != 0) { goto L70; } sorg2r_(&m, &m, n2, li, &c__4, taul, &work[1], &linfo); if (linfo != 0) { goto L70; } /* Compute orthogonal matrix RQ: */ /* IR * RQ' = [ 0 TR], */ /* where IR = [ SCALE * identity(N1), R ] */ i__1 = *n1; for (i__ = 1; i__ <= i__1; ++i__) { ir[*n2 + i__ + (i__ << 2) - 5] = scale; /* L20: */ } sgerq2_(n1, &m, &ir[*n2], &c__4, taur, &work[1], &linfo); if (linfo != 0) { goto L70; } sorgr2_(&m, &m, n1, ir, &c__4, taur, &work[1], &linfo); if (linfo != 0) { goto L70; } /* Perform the swapping tentatively: */ sgemm_("T", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, & work[1], &m); sgemm_("N", "T", &m, &m, &m, &c_b42, &work[1], &m, ir, &c__4, &c_b5, s, &c__4); sgemm_("T", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, & work[1], &m); sgemm_("N", "T", &m, &m, &m, &c_b42, &work[1], &m, ir, &c__4, &c_b5, t, &c__4); slacpy_("F", &m, &m, s, &c__4, scpy, &c__4); slacpy_("F", &m, &m, t, &c__4, tcpy, &c__4); slacpy_("F", &m, &m, ir, &c__4, ircop, &c__4); slacpy_("F", &m, &m, li, &c__4, licop, &c__4); /* Triangularize the B-part by an RQ factorization. */ /* Apply transformation (from left) to A-part, giving S. */ sgerq2_(&m, &m, t, &c__4, taur, &work[1], &linfo); if (linfo != 0) { goto L70; } sormr2_("R", "T", &m, &m, &m, t, &c__4, taur, s, &c__4, &work[1], & linfo); if (linfo != 0) { goto L70; } sormr2_("L", "N", &m, &m, &m, t, &c__4, taur, ir, &c__4, &work[1], & linfo); if (linfo != 0) { goto L70; } /* Compute F-norm(S21) in BRQA21. (T21 is 0.) */ dscale = 0.f; dsum = 1.f; i__1 = *n2; for (i__ = 1; i__ <= i__1; ++i__) { slassq_(n1, &s[*n2 + 1 + (i__ << 2) - 5], &c__1, &dscale, &dsum); /* L30: */ } brqa21 = dscale * sqrt(dsum); /* Triangularize the B-part by a QR factorization. */ /* Apply transformation (from right) to A-part, giving S. */ sgeqr2_(&m, &m, tcpy, &c__4, taul, &work[1], &linfo); if (linfo != 0) { goto L70; } sorm2r_("L", "T", &m, &m, &m, tcpy, &c__4, taul, scpy, &c__4, &work[1] , info); sorm2r_("R", "N", &m, &m, &m, tcpy, &c__4, taul, licop, &c__4, &work[ 1], info); if (linfo != 0) { goto L70; } /* Compute F-norm(S21) in BQRA21. (T21 is 0.) */ dscale = 0.f; dsum = 1.f; i__1 = *n2; for (i__ = 1; i__ <= i__1; ++i__) { slassq_(n1, &scpy[*n2 + 1 + (i__ << 2) - 5], &c__1, &dscale, & dsum); /* L40: */ } bqra21 = dscale * sqrt(dsum); /* Decide which method to use. */ /* Weak stability test: */ /* F-norm(S21) <= O(EPS * F-norm((S, T))) */ if (bqra21 <= brqa21 && bqra21 <= thresh) { slacpy_("F", &m, &m, scpy, &c__4, s, &c__4); slacpy_("F", &m, &m, tcpy, &c__4, t, &c__4); slacpy_("F", &m, &m, ircop, &c__4, ir, &c__4); slacpy_("F", &m, &m, licop, &c__4, li, &c__4); } else if (brqa21 >= thresh) { goto L70; } /* Set lower triangle of B-part to zero */ i__1 = m - 1; i__2 = m - 1; slaset_("Lower", &i__1, &i__2, &c_b5, &c_b5, &t[1], &c__4); if (TRUE_) { /* Strong stability test: */ /* F-norm((A-QL*S*QR', B-QL*T*QR')) <= O(EPS*F-norm((A,B))) */ slacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, &work[m * m + 1], &m); sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, & work[1], &m); sgemm_("N", "N", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, & c_b42, &work[m * m + 1], &m); dscale = 0.f; dsum = 1.f; i__1 = m * m; slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum); slacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, &work[m * m + 1], &m); sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, & work[1], &m); sgemm_("N", "N", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, & c_b42, &work[m * m + 1], &m); i__1 = m * m; slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum); ss = dscale * sqrt(dsum); strong = ss <= thresh; if (! strong) { goto L70; } } /* If the swap is accepted ("weakly" and "strongly"), apply the */ /* transformations and set N1-by-N2 (2,1)-block to zero. */ slaset_("Full", n1, n2, &c_b5, &c_b5, &s[*n2], &c__4); /* copy back M-by-M diagonal block starting at index J1 of (A, B) */ slacpy_("F", &m, &m, s, &c__4, &a[*j1 + *j1 * a_dim1], lda) ; slacpy_("F", &m, &m, t, &c__4, &b[*j1 + *j1 * b_dim1], ldb) ; slaset_("Full", &c__4, &c__4, &c_b5, &c_b5, t, &c__4); /* Standardize existing 2-by-2 blocks. */ i__1 = m * m; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.f; /* L50: */ } work[1] = 1.f; t[0] = 1.f; idum = *lwork - m * m - 2; if (*n2 > 1) { slagv2_(&a[*j1 + *j1 * a_dim1], lda, &b[*j1 + *j1 * b_dim1], ldb, ar, ai, be, &work[1], &work[2], t, &t[1]); work[m + 1] = -work[2]; work[m + 2] = work[1]; t[*n2 + (*n2 << 2) - 5] = t[0]; t[4] = -t[1]; } work[m * m] = 1.f; t[m + (m << 2) - 5] = 1.f; if (*n1 > 1) { slagv2_(&a[*j1 + *n2 + (*j1 + *n2) * a_dim1], lda, &b[*j1 + *n2 + (*j1 + *n2) * b_dim1], ldb, taur, taul, &work[m * m + 1], &work[*n2 * m + *n2 + 1], &work[*n2 * m + *n2 + 2], &t[* n2 + 1 + (*n2 + 1 << 2) - 5], &t[m + (m - 1 << 2) - 5]); work[m * m] = work[*n2 * m + *n2 + 1]; work[m * m - 1] = -work[*n2 * m + *n2 + 2]; t[m + (m << 2) - 5] = t[*n2 + 1 + (*n2 + 1 << 2) - 5]; t[m - 1 + (m << 2) - 5] = -t[m + (m - 1 << 2) - 5]; } sgemm_("T", "N", n2, n1, n2, &c_b42, &work[1], &m, &a[*j1 + (*j1 + * n2) * a_dim1], lda, &c_b5, &work[m * m + 1], n2); slacpy_("Full", n2, n1, &work[m * m + 1], n2, &a[*j1 + (*j1 + *n2) * a_dim1], lda); sgemm_("T", "N", n2, n1, n2, &c_b42, &work[1], &m, &b[*j1 + (*j1 + * n2) * b_dim1], ldb, &c_b5, &work[m * m + 1], n2); slacpy_("Full", n2, n1, &work[m * m + 1], n2, &b[*j1 + (*j1 + *n2) * b_dim1], ldb); sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, &work[1], &m, &c_b5, & work[m * m + 1], &m); slacpy_("Full", &m, &m, &work[m * m + 1], &m, li, &c__4); sgemm_("N", "N", n2, n1, n1, &c_b42, &a[*j1 + (*j1 + *n2) * a_dim1], lda, &t[*n2 + 1 + (*n2 + 1 << 2) - 5], &c__4, &c_b5, &work[1], n2); slacpy_("Full", n2, n1, &work[1], n2, &a[*j1 + (*j1 + *n2) * a_dim1], lda); sgemm_("N", "N", n2, n1, n1, &c_b42, &b[*j1 + (*j1 + *n2) * b_dim1], ldb, &t[*n2 + 1 + (*n2 + 1 << 2) - 5], &c__4, &c_b5, &work[1], n2); slacpy_("Full", n2, n1, &work[1], n2, &b[*j1 + (*j1 + *n2) * b_dim1], ldb); sgemm_("T", "N", &m, &m, &m, &c_b42, ir, &c__4, t, &c__4, &c_b5, & work[1], &m); slacpy_("Full", &m, &m, &work[1], &m, ir, &c__4); /* Accumulate transformations into Q and Z if requested. */ if (*wantq) { sgemm_("N", "N", n, &m, &m, &c_b42, &q[*j1 * q_dim1 + 1], ldq, li, &c__4, &c_b5, &work[1], n); slacpy_("Full", n, &m, &work[1], n, &q[*j1 * q_dim1 + 1], ldq); } if (*wantz) { sgemm_("N", "N", n, &m, &m, &c_b42, &z__[*j1 * z_dim1 + 1], ldz, ir, &c__4, &c_b5, &work[1], n); slacpy_("Full", n, &m, &work[1], n, &z__[*j1 * z_dim1 + 1], ldz); } /* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and */ /* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */ i__ = *j1 + m; if (i__ <= *n) { i__1 = *n - i__ + 1; sgemm_("T", "N", &m, &i__1, &m, &c_b42, li, &c__4, &a[*j1 + i__ * a_dim1], lda, &c_b5, &work[1], &m); i__1 = *n - i__ + 1; slacpy_("Full", &m, &i__1, &work[1], &m, &a[*j1 + i__ * a_dim1], lda); i__1 = *n - i__ + 1; sgemm_("T", "N", &m, &i__1, &m, &c_b42, li, &c__4, &b[*j1 + i__ * b_dim1], ldb, &c_b5, &work[1], &m); i__1 = *n - i__ + 1; slacpy_("Full", &m, &i__1, &work[1], &m, &b[*j1 + i__ * b_dim1], ldb); } i__ = *j1 - 1; if (i__ > 0) { sgemm_("N", "N", &i__, &m, &m, &c_b42, &a[*j1 * a_dim1 + 1], lda, ir, &c__4, &c_b5, &work[1], &i__); slacpy_("Full", &i__, &m, &work[1], &i__, &a[*j1 * a_dim1 + 1], lda); sgemm_("N", "N", &i__, &m, &m, &c_b42, &b[*j1 * b_dim1 + 1], ldb, ir, &c__4, &c_b5, &work[1], &i__); slacpy_("Full", &i__, &m, &work[1], &i__, &b[*j1 * b_dim1 + 1], ldb); } /* Exit with INFO = 0 if swap was successfully performed. */ return 0; } /* Exit with INFO = 1 if swap was rejected. */ L70: *info = 1; return 0; /* End of STGEX2 */ } /* stgex2_ */
doublereal slantp_(char *norm, char *uplo, char *diag, integer *n, real *ap, real *work, ftnlen norm_len, ftnlen uplo_len, ftnlen diag_len) { /* System generated locals */ integer i__1, i__2; real ret_val, r__1, r__2, r__3; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static integer i__, j, k; static real sum, scale; static logical udiag; extern logical lsame_(char *, char *, ftnlen, ftnlen); static real value; extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, real *); /* -- LAPACK auxiliary routine (version 3.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* October 31, 1992 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* SLANTP returns the value of the one norm, or the Frobenius norm, or */ /* the infinity norm, or the element of largest absolute value of a */ /* triangular matrix A, supplied in packed form. */ /* Description */ /* =========== */ /* SLANTP returns the value */ /* SLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ /* ( */ /* ( norm1(A), NORM = '1', 'O' or 'o' */ /* ( */ /* ( normI(A), NORM = 'I' or 'i' */ /* ( */ /* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ /* where norm1 denotes the one norm of a matrix (maximum column sum), */ /* normI denotes the infinity norm of a matrix (maximum row sum) and */ /* normF denotes the Frobenius norm of a matrix (square root of sum of */ /* squares). Note that max(abs(A(i,j))) is not a matrix norm. */ /* Arguments */ /* ========= */ /* NORM (input) CHARACTER*1 */ /* Specifies the value to be returned in SLANTP as described */ /* above. */ /* UPLO (input) CHARACTER*1 */ /* Specifies whether the matrix A is upper or lower triangular. */ /* = 'U': Upper triangular */ /* = 'L': Lower triangular */ /* DIAG (input) CHARACTER*1 */ /* Specifies whether or not the matrix A is unit triangular. */ /* = 'N': Non-unit triangular */ /* = 'U': Unit triangular */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. When N = 0, SLANTP is */ /* set to zero. */ /* 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. */ /* Note that when DIAG = 'U', the elements of the array AP */ /* corresponding to the diagonal elements of the matrix A are */ /* not referenced, but are assumed to be one. */ /* WORK (workspace) REAL array, dimension (LWORK), */ /* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */ /* referenced. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ --work; --ap; /* Function Body */ if (*n == 0) { value = 0.f; } else if (lsame_(norm, "M", (ftnlen)1, (ftnlen)1)) { /* Find max(abs(A(i,j))). */ k = 1; if (lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) { value = 1.f; if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = k + j - 2; for (i__ = k; i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = ap[i__], dabs(r__1)); value = dmax(r__2,r__3); /* L10: */ } k += j; /* L20: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = k + *n - j; for (i__ = k + 1; i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = ap[i__], dabs(r__1)); value = dmax(r__2,r__3); /* L30: */ } k = k + *n - j + 1; /* L40: */ } } } else { value = 0.f; if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = k + j - 1; for (i__ = k; i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = ap[i__], dabs(r__1)); value = dmax(r__2,r__3); /* L50: */ } k += j; /* L60: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = k + *n - j; for (i__ = k; i__ <= i__2; ++i__) { /* Computing MAX */ r__2 = value, r__3 = (r__1 = ap[i__], dabs(r__1)); value = dmax(r__2,r__3); /* L70: */ } k = k + *n - j + 1; /* L80: */ } } } } else if (lsame_(norm, "O", (ftnlen)1, (ftnlen)1) || *(unsigned char *) norm == '1') { /* Find norm1(A). */ value = 0.f; k = 1; udiag = lsame_(diag, "U", (ftnlen)1, (ftnlen)1); if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (udiag) { sum = 1.f; i__2 = k + j - 2; for (i__ = k; i__ <= i__2; ++i__) { sum += (r__1 = ap[i__], dabs(r__1)); /* L90: */ } } else { sum = 0.f; i__2 = k + j - 1; for (i__ = k; i__ <= i__2; ++i__) { sum += (r__1 = ap[i__], dabs(r__1)); /* L100: */ } } k += j; value = dmax(value,sum); /* L110: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (udiag) { sum = 1.f; i__2 = k + *n - j; for (i__ = k + 1; i__ <= i__2; ++i__) { sum += (r__1 = ap[i__], dabs(r__1)); /* L120: */ } } else { sum = 0.f; i__2 = k + *n - j; for (i__ = k; i__ <= i__2; ++i__) { sum += (r__1 = ap[i__], dabs(r__1)); /* L130: */ } } k = k + *n - j + 1; value = dmax(value,sum); /* L140: */ } } } else if (lsame_(norm, "I", (ftnlen)1, (ftnlen)1)) { /* Find normI(A). */ k = 1; if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { if (lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 1.f; /* L150: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { work[i__] += (r__1 = ap[k], dabs(r__1)); ++k; /* L160: */ } ++k; /* L170: */ } } else { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.f; /* L180: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j; for (i__ = 1; i__ <= i__2; ++i__) { work[i__] += (r__1 = ap[k], dabs(r__1)); ++k; /* L190: */ } /* L200: */ } } } else { if (lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 1.f; /* L210: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { ++k; i__2 = *n; for (i__ = j + 1; i__ <= i__2; ++i__) { work[i__] += (r__1 = ap[k], dabs(r__1)); ++k; /* L220: */ } /* L230: */ } } else { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.f; /* L240: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { work[i__] += (r__1 = ap[k], dabs(r__1)); ++k; /* L250: */ } /* L260: */ } } } value = 0.f; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { /* Computing MAX */ r__1 = value, r__2 = work[i__]; value = dmax(r__1,r__2); /* L270: */ } } else if (lsame_(norm, "F", (ftnlen)1, (ftnlen)1) || lsame_(norm, "E", ( ftnlen)1, (ftnlen)1)) { /* Find normF(A). */ if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { if (lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) { scale = 1.f; sum = (real) (*n); k = 2; i__1 = *n; for (j = 2; j <= i__1; ++j) { i__2 = j - 1; slassq_(&i__2, &ap[k], &c__1, &scale, &sum); k += j; /* L280: */ } } else { scale = 0.f; sum = 1.f; k = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { slassq_(&j, &ap[k], &c__1, &scale, &sum); k += j; /* L290: */ } } } else { if (lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) { scale = 1.f; sum = (real) (*n); k = 2; i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { i__2 = *n - j; slassq_(&i__2, &ap[k], &c__1, &scale, &sum); k = k + *n - j + 1; /* L300: */ } } else { scale = 0.f; sum = 1.f; k = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *n - j + 1; slassq_(&i__2, &ap[k], &c__1, &scale, &sum); k = k + *n - j + 1; /* L310: */ } } } value = scale * sqrt(sum); } ret_val = value; return ret_val; /* End of SLANTP */ } /* slantp_ */