/* Subroutine */ int ssygst_(integer *itype, char *uplo, integer *n, real *a, integer *lda, real *b, integer *ldb, integer *info) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; /* Local variables */ integer k, kb, nb; extern logical lsame_(char *, char *); logical upper; extern /* Subroutine */ int strmm_(char *, char *, char *, char *, integer *, integer *, real *, real *, integer *, real *, integer * ), ssymm_(char *, char *, integer *, integer *, real *, real *, integer *, real *, integer *, real * , real *, integer *), strsm_(char *, char *, char *, char *, integer *, integer *, real *, real *, integer *, real * , integer *), ssygs2_(integer *, char *, integer *, real *, integer *, real *, integer *, integer * ), ssyr2k_(char *, char *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *), xerbla_(char *, integer *); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *); /* -- LAPACK routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* SSYGST reduces a real symmetric-definite generalized eigenproblem */ /* to standard form. */ /* If ITYPE = 1, the problem is A*x = lambda*B*x, */ /* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) */ /* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */ /* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L. */ /* B must have been previously factorized as U**T*U or L*L**T by SPOTRF. */ /* Arguments */ /* ========= */ /* ITYPE (input) INTEGER */ /* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); */ /* = 2 or 3: compute U*A*U**T or L**T*A*L. */ /* UPLO (input) CHARACTER*1 */ /* = 'U': Upper triangle of A is stored and B is factored as */ /* U**T*U; */ /* = 'L': Lower triangle of A is stored and B is factored as */ /* L*L**T. */ /* N (input) INTEGER */ /* The order of the matrices A and B. N >= 0. */ /* A (input/output) REAL array, dimension (LDA,N) */ /* On entry, 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. */ /* On exit, if INFO = 0, the transformed matrix, stored in the */ /* same format as A. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,N). */ /* B (input) REAL array, dimension (LDB,N) */ /* The triangular factor from the Cholesky factorization of B, */ /* as returned by SPOTRF. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= max(1,N). */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (*itype < 1 || *itype > 3) { *info = -1; } else if (! upper && ! lsame_(uplo, "L")) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*lda < max(1,*n)) { *info = -5; } else if (*ldb < max(1,*n)) { *info = -7; } if (*info != 0) { i__1 = -(*info); xerbla_("SSYGST", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Determine the block size for this environment. */ nb = ilaenv_(&c__1, "SSYGST", uplo, n, &c_n1, &c_n1, &c_n1); if (nb <= 1 || nb >= *n) { /* Use unblocked code */ ssygs2_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info); } else { /* Use blocked code */ if (*itype == 1) { if (upper) { /* Compute inv(U')*A*inv(U) */ i__1 = *n; i__2 = nb; for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) { /* Computing MIN */ i__3 = *n - k + 1; kb = min(i__3,nb); /* Update the upper triangle of A(k:n,k:n) */ ssygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + k * b_dim1], ldb, info); if (k + kb <= *n) { i__3 = *n - k - kb + 1; strsm_("Left", uplo, "Transpose", "Non-unit", &kb, & i__3, &c_b14, &b[k + k * b_dim1], ldb, &a[k + (k + kb) * a_dim1], lda); i__3 = *n - k - kb + 1; ssymm_("Left", uplo, &kb, &i__3, &c_b16, &a[k + k * a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb, &c_b14, &a[k + (k + kb) * a_dim1], lda); i__3 = *n - k - kb + 1; ssyr2k_(uplo, "Transpose", &i__3, &kb, &c_b19, &a[k + (k + kb) * a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb, &c_b14, &a[k + kb + (k + kb) * a_dim1], lda); i__3 = *n - k - kb + 1; ssymm_("Left", uplo, &kb, &i__3, &c_b16, &a[k + k * a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb, &c_b14, &a[k + (k + kb) * a_dim1], lda); i__3 = *n - k - kb + 1; strsm_("Right", uplo, "No transpose", "Non-unit", &kb, &i__3, &c_b14, &b[k + kb + (k + kb) * b_dim1] , ldb, &a[k + (k + kb) * a_dim1], lda); } /* L10: */ } } else { /* Compute inv(L)*A*inv(L') */ i__2 = *n; i__1 = nb; for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) { /* Computing MIN */ i__3 = *n - k + 1; kb = min(i__3,nb); /* Update the lower triangle of A(k:n,k:n) */ ssygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + k * b_dim1], ldb, info); if (k + kb <= *n) { i__3 = *n - k - kb + 1; strsm_("Right", uplo, "Transpose", "Non-unit", &i__3, &kb, &c_b14, &b[k + k * b_dim1], ldb, &a[k + kb + k * a_dim1], lda); i__3 = *n - k - kb + 1; ssymm_("Right", uplo, &i__3, &kb, &c_b16, &a[k + k * a_dim1], lda, &b[k + kb + k * b_dim1], ldb, & c_b14, &a[k + kb + k * a_dim1], lda); i__3 = *n - k - kb + 1; ssyr2k_(uplo, "No transpose", &i__3, &kb, &c_b19, &a[ k + kb + k * a_dim1], lda, &b[k + kb + k * b_dim1], ldb, &c_b14, &a[k + kb + (k + kb) * a_dim1], lda); i__3 = *n - k - kb + 1; ssymm_("Right", uplo, &i__3, &kb, &c_b16, &a[k + k * a_dim1], lda, &b[k + kb + k * b_dim1], ldb, & c_b14, &a[k + kb + k * a_dim1], lda); i__3 = *n - k - kb + 1; strsm_("Left", uplo, "No transpose", "Non-unit", & i__3, &kb, &c_b14, &b[k + kb + (k + kb) * b_dim1], ldb, &a[k + kb + k * a_dim1], lda); } /* L20: */ } } } else { if (upper) { /* Compute U*A*U' */ i__1 = *n; i__2 = nb; for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) { /* Computing MIN */ i__3 = *n - k + 1; kb = min(i__3,nb); /* Update the upper triangle of A(1:k+kb-1,1:k+kb-1) */ i__3 = k - 1; strmm_("Left", uplo, "No transpose", "Non-unit", &i__3, & kb, &c_b14, &b[b_offset], ldb, &a[k * a_dim1 + 1], lda) ; i__3 = k - 1; ssymm_("Right", uplo, &i__3, &kb, &c_b52, &a[k + k * a_dim1], lda, &b[k * b_dim1 + 1], ldb, &c_b14, &a[ k * a_dim1 + 1], lda); i__3 = k - 1; ssyr2k_(uplo, "No transpose", &i__3, &kb, &c_b14, &a[k * a_dim1 + 1], lda, &b[k * b_dim1 + 1], ldb, &c_b14, &a[a_offset], lda); i__3 = k - 1; ssymm_("Right", uplo, &i__3, &kb, &c_b52, &a[k + k * a_dim1], lda, &b[k * b_dim1 + 1], ldb, &c_b14, &a[ k * a_dim1 + 1], lda); i__3 = k - 1; strmm_("Right", uplo, "Transpose", "Non-unit", &i__3, &kb, &c_b14, &b[k + k * b_dim1], ldb, &a[k * a_dim1 + 1], lda); ssygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + k * b_dim1], ldb, info); /* L30: */ } } else { /* Compute L'*A*L */ i__2 = *n; i__1 = nb; for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) { /* Computing MIN */ i__3 = *n - k + 1; kb = min(i__3,nb); /* Update the lower triangle of A(1:k+kb-1,1:k+kb-1) */ i__3 = k - 1; strmm_("Right", uplo, "No transpose", "Non-unit", &kb, & i__3, &c_b14, &b[b_offset], ldb, &a[k + a_dim1], lda); i__3 = k - 1; ssymm_("Left", uplo, &kb, &i__3, &c_b52, &a[k + k * a_dim1], lda, &b[k + b_dim1], ldb, &c_b14, &a[k + a_dim1], lda); i__3 = k - 1; ssyr2k_(uplo, "Transpose", &i__3, &kb, &c_b14, &a[k + a_dim1], lda, &b[k + b_dim1], ldb, &c_b14, &a[ a_offset], lda); i__3 = k - 1; ssymm_("Left", uplo, &kb, &i__3, &c_b52, &a[k + k * a_dim1], lda, &b[k + b_dim1], ldb, &c_b14, &a[k + a_dim1], lda); i__3 = k - 1; strmm_("Left", uplo, "Transpose", "Non-unit", &kb, &i__3, &c_b14, &b[k + k * b_dim1], ldb, &a[k + a_dim1], lda); ssygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + k * b_dim1], ldb, info); /* L40: */ } } } } return 0; /* End of SSYGST */ } /* ssygst_ */
/* Subroutine */ int ssygst_(integer *itype, char *uplo, integer *n, real *a, integer *lda, real *b, integer *ldb, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= SSYGST reduces a real symmetric-definite generalized eigenproblem to standard form. If ITYPE = 1, the problem is A*x = lambda*B*x, and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L. B must have been previously factorized as U**T*U or L*L**T by SPOTRF. Arguments ========= ITYPE (input) INTEGER = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); = 2 or 3: compute U*A*U**T or L**T*A*L. UPLO (input) CHARACTER = 'U': Upper triangle of A is stored and B is factored as U**T*U; = 'L': Lower triangle of A is stored and B is factored as L*L**T. N (input) INTEGER The order of the matrices A and B. N >= 0. A (input/output) REAL array, dimension (LDA,N) On entry, 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. On exit, if INFO = 0, the transformed matrix, stored in the same format as A. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,N). B (input) REAL array, dimension (LDB,N) The triangular factor from the Cholesky factorization of B, as returned by SPOTRF. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,N). INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value ===================================================================== Test the input parameters. Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; static integer c_n1 = -1; static real c_b14 = 1.f; static real c_b16 = -.5f; static real c_b19 = -1.f; static real c_b52 = .5f; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; /* Local variables */ static integer k; extern logical lsame_(char *, char *); static logical upper; extern /* Subroutine */ int strmm_(char *, char *, char *, char *, integer *, integer *, real *, real *, integer *, real *, integer * ), ssymm_(char *, char *, integer *, integer *, real *, real *, integer *, real *, integer *, real * , real *, integer *), strsm_(char *, char *, char *, char *, integer *, integer *, real *, real *, integer *, real * , integer *); static integer kb, nb; extern /* Subroutine */ int ssygs2_(integer *, char *, integer *, real *, integer *, real *, integer *, integer *), ssyr2k_(char *, char *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *), xerbla_( char *, integer *); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); #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] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (*itype < 1 || *itype > 3) { *info = -1; } else if (! upper && ! lsame_(uplo, "L")) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*lda < max(1,*n)) { *info = -5; } else if (*ldb < max(1,*n)) { *info = -7; } if (*info != 0) { i__1 = -(*info); xerbla_("SSYGST", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Determine the block size for this environment. */ nb = ilaenv_(&c__1, "SSYGST", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, ( ftnlen)1); if (nb <= 1 || nb >= *n) { /* Use unblocked code */ ssygs2_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info); } else { /* Use blocked code */ if (*itype == 1) { if (upper) { /* Compute inv(U')*A*inv(U) */ i__1 = *n; i__2 = nb; for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) { /* Computing MIN */ i__3 = *n - k + 1; kb = min(i__3,nb); /* Update the upper triangle of A(k:n,k:n) */ ssygs2_(itype, uplo, &kb, &a_ref(k, k), lda, &b_ref(k, k), ldb, info); if (k + kb <= *n) { i__3 = *n - k - kb + 1; strsm_("Left", uplo, "Transpose", "Non-unit", &kb, & i__3, &c_b14, &b_ref(k, k), ldb, &a_ref(k, k + kb), lda); i__3 = *n - k - kb + 1; ssymm_("Left", uplo, &kb, &i__3, &c_b16, &a_ref(k, k), lda, &b_ref(k, k + kb), ldb, &c_b14, &a_ref( k, k + kb), lda); i__3 = *n - k - kb + 1; ssyr2k_(uplo, "Transpose", &i__3, &kb, &c_b19, &a_ref( k, k + kb), lda, &b_ref(k, k + kb), ldb, & c_b14, &a_ref(k + kb, k + kb), lda); i__3 = *n - k - kb + 1; ssymm_("Left", uplo, &kb, &i__3, &c_b16, &a_ref(k, k), lda, &b_ref(k, k + kb), ldb, &c_b14, &a_ref( k, k + kb), lda); i__3 = *n - k - kb + 1; strsm_("Right", uplo, "No transpose", "Non-unit", &kb, &i__3, &c_b14, &b_ref(k + kb, k + kb), ldb, & a_ref(k, k + kb), lda); } /* L10: */ } } else { /* Compute inv(L)*A*inv(L') */ i__2 = *n; i__1 = nb; for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) { /* Computing MIN */ i__3 = *n - k + 1; kb = min(i__3,nb); /* Update the lower triangle of A(k:n,k:n) */ ssygs2_(itype, uplo, &kb, &a_ref(k, k), lda, &b_ref(k, k), ldb, info); if (k + kb <= *n) { i__3 = *n - k - kb + 1; strsm_("Right", uplo, "Transpose", "Non-unit", &i__3, &kb, &c_b14, &b_ref(k, k), ldb, &a_ref(k + kb, k), lda); i__3 = *n - k - kb + 1; ssymm_("Right", uplo, &i__3, &kb, &c_b16, &a_ref(k, k) , lda, &b_ref(k + kb, k), ldb, &c_b14, &a_ref( k + kb, k), lda); i__3 = *n - k - kb + 1; ssyr2k_(uplo, "No transpose", &i__3, &kb, &c_b19, & a_ref(k + kb, k), lda, &b_ref(k + kb, k), ldb, &c_b14, &a_ref(k + kb, k + kb), lda); i__3 = *n - k - kb + 1; ssymm_("Right", uplo, &i__3, &kb, &c_b16, &a_ref(k, k) , lda, &b_ref(k + kb, k), ldb, &c_b14, &a_ref( k + kb, k), lda); i__3 = *n - k - kb + 1; strsm_("Left", uplo, "No transpose", "Non-unit", & i__3, &kb, &c_b14, &b_ref(k + kb, k + kb), ldb, &a_ref(k + kb, k), lda); } /* L20: */ } } } else { if (upper) { /* Compute U*A*U' */ i__1 = *n; i__2 = nb; for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) { /* Computing MIN */ i__3 = *n - k + 1; kb = min(i__3,nb); /* Update the upper triangle of A(1:k+kb-1,1:k+kb-1) */ i__3 = k - 1; strmm_("Left", uplo, "No transpose", "Non-unit", &i__3, & kb, &c_b14, &b[b_offset], ldb, &a_ref(1, k), lda); i__3 = k - 1; ssymm_("Right", uplo, &i__3, &kb, &c_b52, &a_ref(k, k), lda, &b_ref(1, k), ldb, &c_b14, &a_ref(1, k), lda); i__3 = k - 1; ssyr2k_(uplo, "No transpose", &i__3, &kb, &c_b14, &a_ref( 1, k), lda, &b_ref(1, k), ldb, &c_b14, &a[ a_offset], lda); i__3 = k - 1; ssymm_("Right", uplo, &i__3, &kb, &c_b52, &a_ref(k, k), lda, &b_ref(1, k), ldb, &c_b14, &a_ref(1, k), lda); i__3 = k - 1; strmm_("Right", uplo, "Transpose", "Non-unit", &i__3, &kb, &c_b14, &b_ref(k, k), ldb, &a_ref(1, k), lda); ssygs2_(itype, uplo, &kb, &a_ref(k, k), lda, &b_ref(k, k), ldb, info); /* L30: */ } } else { /* Compute L'*A*L */ i__2 = *n; i__1 = nb; for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) { /* Computing MIN */ i__3 = *n - k + 1; kb = min(i__3,nb); /* Update the lower triangle of A(1:k+kb-1,1:k+kb-1) */ i__3 = k - 1; strmm_("Right", uplo, "No transpose", "Non-unit", &kb, & i__3, &c_b14, &b[b_offset], ldb, &a_ref(k, 1), lda); i__3 = k - 1; ssymm_("Left", uplo, &kb, &i__3, &c_b52, &a_ref(k, k), lda, &b_ref(k, 1), ldb, &c_b14, &a_ref(k, 1), lda); i__3 = k - 1; ssyr2k_(uplo, "Transpose", &i__3, &kb, &c_b14, &a_ref(k, 1), lda, &b_ref(k, 1), ldb, &c_b14, &a[a_offset], lda); i__3 = k - 1; ssymm_("Left", uplo, &kb, &i__3, &c_b52, &a_ref(k, k), lda, &b_ref(k, 1), ldb, &c_b14, &a_ref(k, 1), lda); i__3 = k - 1; strmm_("Left", uplo, "Transpose", "Non-unit", &kb, &i__3, &c_b14, &b_ref(k, k), ldb, &a_ref(k, 1), lda); ssygs2_(itype, uplo, &kb, &a_ref(k, k), lda, &b_ref(k, k), ldb, info); /* L40: */ } } } } return 0; /* End of SSYGST */ } /* ssygst_ */
/* Subroutine */ int ssytrd_(char *uplo, integer *n, real *a, integer *lda, real *d__, real *e, real *tau, real *work, integer *lwork, integer * info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; /* Local variables */ integer i__, j, nb, kk, nx, iws; integer nbmin, iinfo; logical upper; integer ldwork, lwkopt; logical lquery; /* -- LAPACK routine (version 3.2) -- */ /* November 2006 */ /* Purpose */ /* ======= */ /* SSYTRD reduces a real symmetric matrix A to real symmetric */ /* tridiagonal form T by an orthogonal similarity transformation: */ /* Q**T * A * Q = T. */ /* Arguments */ /* ========= */ /* UPLO (input) CHARACTER*1 */ /* = 'U': Upper triangle of A is stored; */ /* = 'L': Lower triangle of A is stored. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* A (input/output) REAL array, dimension (LDA,N) */ /* On entry, 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. */ /* On exit, if UPLO = 'U', the diagonal and first superdiagonal */ /* of A are overwritten by the corresponding elements of the */ /* tridiagonal matrix T, and the elements above the first */ /* superdiagonal, with the array TAU, represent the orthogonal */ /* matrix Q as a product of elementary reflectors; if UPLO */ /* = 'L', the diagonal and first subdiagonal of A are over- */ /* written by the corresponding elements of the tridiagonal */ /* matrix T, and the elements below the first subdiagonal, with */ /* the array TAU, represent the orthogonal matrix Q as a product */ /* of elementary reflectors. See Further Details. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,N). */ /* D (output) REAL array, dimension (N) */ /* The diagonal elements of the tridiagonal matrix T: */ /* D(i) = A(i,i). */ /* E (output) REAL array, dimension (N-1) */ /* The off-diagonal elements of the tridiagonal matrix T: */ /* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */ /* TAU (output) REAL array, dimension (N-1) */ /* The scalar factors of the elementary reflectors (see Further */ /* Details). */ /* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */ /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ /* LWORK (input) INTEGER */ /* The dimension of the array WORK. LWORK >= 1. */ /* For optimum performance LWORK >= N*NB, where NB is the */ /* optimal blocksize. */ /* If LWORK = -1, then a workspace query is assumed; the routine */ /* only calculates the optimal size of the WORK array, returns */ /* this value as the first entry of the WORK array, and no error */ /* message related to LWORK is issued by XERBLA. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* Further Details */ /* =============== */ /* If UPLO = 'U', the matrix Q is represented as a product of elementary */ /* reflectors */ /* Q = H(n-1) . . . H(2) H(1). */ /* Each H(i) has the form */ /* H(i) = I - tau * v * v' */ /* where tau is a real scalar, and v is a real vector with */ /* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in */ /* A(1:i-1,i+1), and tau in TAU(i). */ /* If UPLO = 'L', the matrix Q is represented as a product of elementary */ /* reflectors */ /* Q = H(1) H(2) . . . H(n-1). */ /* Each H(i) has the form */ /* H(i) = I - tau * v * v' */ /* where tau is a real scalar, and v is a real vector with */ /* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), */ /* and tau in TAU(i). */ /* The contents of A on exit are illustrated by the following examples */ /* with n = 5: */ /* if UPLO = 'U': if UPLO = 'L': */ /* ( d e v2 v3 v4 ) ( d ) */ /* ( d e v3 v4 ) ( e d ) */ /* ( d e v4 ) ( v1 e d ) */ /* ( d e ) ( v1 v2 e d ) */ /* ( d ) ( v1 v2 v3 e d ) */ /* where d and e denote diagonal and off-diagonal elements of T, and vi */ /* denotes an element of the vector defining H(i). */ /* ===================================================================== */ /* Test the input parameters */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --d__; --e; --tau; --work; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); lquery = *lwork == -1; if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < max(1,*n)) { *info = -4; } else if (*lwork < 1 && ! lquery) { *info = -9; } if (*info == 0) { /* Determine the block size. */ nb = ilaenv_(&c__1, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1); lwkopt = *n * nb; work[1] = (real) lwkopt; } if (*info != 0) { i__1 = -(*info); xerbla_("SSYTRD", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible */ if (*n == 0) { work[1] = 1.f; return 0; } nx = *n; iws = 1; if (nb > 1 && nb < *n) { /* Determine when to cross over from blocked to unblocked code */ /* (last block is always handled by unblocked code). */ /* Computing MAX */ i__1 = nb, i__2 = ilaenv_(&c__3, "SSYTRD", uplo, n, &c_n1, &c_n1, & c_n1); nx = max(i__1,i__2); if (nx < *n) { /* Determine if workspace is large enough for blocked code. */ ldwork = *n; iws = ldwork * nb; if (*lwork < iws) { /* Not enough workspace to use optimal NB: determine the */ /* minimum value of NB, and reduce NB or force use of */ /* unblocked code by setting NX = N. */ /* Computing MAX */ i__1 = *lwork / ldwork; nb = max(i__1,1); nbmin = ilaenv_(&c__2, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1); if (nb < nbmin) { nx = *n; } } } else { nx = *n; } } else { nb = 1; } if (upper) { /* Reduce the upper triangle of A. */ /* Columns 1:kk are handled by the unblocked method. */ kk = *n - (*n - nx + nb - 1) / nb * nb; i__1 = kk + 1; i__2 = -nb; for (i__ = *n - nb + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /* Reduce columns i:i+nb-1 to tridiagonal form and form the */ /* matrix W which is needed to update the unreduced part of */ /* the matrix */ i__3 = i__ + nb - 1; slatrd_(uplo, &i__3, &nb, &a[a_offset], lda, &e[1], &tau[1], & work[1], &ldwork); /* Update the unreduced submatrix A(1:i-1,1:i-1), using an */ /* update of the form: A := A - V*W' - W*V' */ i__3 = i__ - 1; ssyr2k_(uplo, "No transpose", &i__3, &nb, &c_b22, &a[i__ * a_dim1 + 1], lda, &work[1], &ldwork, &c_b23, &a[a_offset], lda); /* Copy superdiagonal elements back into A, and diagonal */ /* elements into D */ i__3 = i__ + nb - 1; for (j = i__; j <= i__3; ++j) { a[j - 1 + j * a_dim1] = e[j - 1]; d__[j] = a[j + j * a_dim1]; } } /* Use unblocked code to reduce the last or only block */ ssytd2_(uplo, &kk, &a[a_offset], lda, &d__[1], &e[1], &tau[1], &iinfo); } else { /* Reduce the lower triangle of A */ i__2 = *n - nx; i__1 = nb; for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { /* Reduce columns i:i+nb-1 to tridiagonal form and form the */ /* matrix W which is needed to update the unreduced part of */ /* the matrix */ i__3 = *n - i__ + 1; slatrd_(uplo, &i__3, &nb, &a[i__ + i__ * a_dim1], lda, &e[i__], & tau[i__], &work[1], &ldwork); /* Update the unreduced submatrix A(i+ib:n,i+ib:n), using */ /* an update of the form: A := A - V*W' - W*V' */ i__3 = *n - i__ - nb + 1; ssyr2k_(uplo, "No transpose", &i__3, &nb, &c_b22, &a[i__ + nb + i__ * a_dim1], lda, &work[nb + 1], &ldwork, &c_b23, &a[ i__ + nb + (i__ + nb) * a_dim1], lda); /* Copy subdiagonal elements back into A, and diagonal */ /* elements into D */ i__3 = i__ + nb - 1; for (j = i__; j <= i__3; ++j) { a[j + 1 + j * a_dim1] = e[j]; d__[j] = a[j + j * a_dim1]; } } /* Use unblocked code to reduce the last or only block */ i__1 = *n - i__ + 1; ssytd2_(uplo, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], &tau[i__], &iinfo); } work[1] = (real) lwkopt; return 0; /* End of SSYTRD */ } /* ssytrd_ */
void cblas_ssyr2k(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE Trans, const integer N, const integer K, const float alpha, const float *A, const integer lda, const float *B, const integer ldb, const float beta, float *C, const integer ldc) { char UL, TR; #ifdef F77_CHAR F77_CHAR F77_TA, F77_UL; #else #define F77_TR &TR #define F77_UL &UL #endif #define F77_N N #define F77_K K #define F77_lda lda #define F77_ldb ldb #define F77_ldc ldc extern integer CBLAS_CallFromC; extern integer RowMajorStrg; RowMajorStrg = 0; CBLAS_CallFromC = 1; if( Order == CblasColMajor ) { if( Uplo == CblasUpper) UL='U'; else if ( Uplo == CblasLower ) UL='L'; else { cblas_xerbla(2, "cblas_ssyr2k", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } if( Trans == CblasTrans) TR ='T'; else if ( Trans == CblasConjTrans ) TR='C'; else if ( Trans == CblasNoTrans ) TR='N'; else { cblas_xerbla(3, "cblas_ssyr2k", "Illegal Trans setting, %d\n", Trans); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); F77_TR = C2F_CHAR(&TR); #endif ssyr2k_(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); } else if (Order == CblasRowMajor) { RowMajorStrg = 1; if( Uplo == CblasUpper) UL='L'; else if ( Uplo == CblasLower ) UL='U'; else { cblas_xerbla(3, "cblas_ssyr2k", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } if( Trans == CblasTrans) TR ='N'; else if ( Trans == CblasConjTrans ) TR='N'; else if ( Trans == CblasNoTrans ) TR='T'; else { cblas_xerbla(3, "cblas_ssyr2k", "Illegal Trans setting, %d\n", Trans); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); F77_TR = C2F_CHAR(&TR); #endif ssyr2k_(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); } else cblas_xerbla(1, "cblas_ssyr2k", "Illegal Order setting, %d\n", Order); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; }
/* Subroutine */ int ssytrd_(char *uplo, integer *n, real *a, integer *lda, real *d, real *e, real *tau, real *work, integer *lwork, integer * info) { /* -- LAPACK routine (version 2.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= SSYTRD reduces a real symmetric matrix A to real symmetric tridiagonal form T by an orthogonal similarity transformation: Q**T * A * Q = T. Arguments ========= UPLO (input) CHARACTER*1 = 'U': Upper triangle of A is stored; = 'L': Lower triangle of A is stored. N (input) INTEGER The order of the matrix A. N >= 0. A (input/output) REAL array, dimension (LDA,N) On entry, 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. On exit, if UPLO = 'U', the diagonal and first superdiagonal of A are overwritten by the corresponding elements of the tridiagonal matrix T, and the elements above the first superdiagonal, with the array TAU, represent the orthogonal matrix Q as a product of elementary reflectors; if UPLO = 'L', the diagonal and first subdiagonal of A are over- written by the corresponding elements of the tridiagonal matrix T, and the elements below the first subdiagonal, with the array TAU, represent the orthogonal matrix Q as a product of elementary reflectors. See Further Details. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,N). D (output) REAL array, dimension (N) The diagonal elements of the tridiagonal matrix T: D(i) = A(i,i). E (output) REAL array, dimension (N-1) The off-diagonal elements of the tridiagonal matrix T: E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. TAU (output) REAL array, dimension (N-1) The scalar factors of the elementary reflectors (see Further Details). WORK (workspace/output) REAL array, dimension (LWORK) On exit, if INFO = 0, WORK(1) returns the optimal LWORK. LWORK (input) INTEGER The dimension of the array WORK. LWORK >= 1. For optimum performance LWORK >= N*NB, where NB is the optimal blocksize. INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value Further Details =============== If UPLO = 'U', the matrix Q is represented as a product of elementary reflectors Q = H(n-1) . . . H(2) H(1). Each H(i) has the form H(i) = I - tau * v * v' where tau is a real scalar, and v is a real vector with v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in A(1:i-1,i+1), and tau in TAU(i). If UPLO = 'L', the matrix Q is represented as a product of elementary reflectors Q = H(1) H(2) . . . H(n-1). Each H(i) has the form H(i) = I - tau * v * v' where tau is a real scalar, and v is a real vector with v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), and tau in TAU(i). The contents of A on exit are illustrated by the following examples with n = 5: if UPLO = 'U': if UPLO = 'L': ( d e v2 v3 v4 ) ( d ) ( d e v3 v4 ) ( e d ) ( d e v4 ) ( v1 e d ) ( d e ) ( v1 v2 e d ) ( d ) ( v1 v2 v3 e d ) where d and e denote diagonal and off-diagonal elements of T, and vi denotes an element of the vector defining H(i). ===================================================================== Test the input parameters Parameter adjustments Function Body */ /* Table of constant values */ static integer c__1 = 1; static integer c_n1 = -1; static integer c__3 = 3; static integer c__2 = 2; static real c_b22 = -1.f; static real c_b23 = 1.f; /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; /* Local variables */ static integer i, j; extern logical lsame_(char *, char *); static integer nbmin, iinfo; static logical upper; static integer nb, kk; extern /* Subroutine */ int ssytd2_(char *, integer *, real *, integer *, real *, real *, real *, integer *), ssyr2k_(char *, char * , integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *); static integer nx; extern /* Subroutine */ int xerbla_(char *, integer *); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); extern /* Subroutine */ int slatrd_(char *, integer *, integer *, real *, integer *, real *, real *, real *, integer *); static integer ldwork, iws; #define D(I) d[(I)-1] #define E(I) e[(I)-1] #define TAU(I) tau[(I)-1] #define WORK(I) work[(I)-1] #define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)] *info = 0; upper = lsame_(uplo, "U"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < max(1,*n)) { *info = -4; } else if (*lwork < 1) { *info = -9; } if (*info != 0) { i__1 = -(*info); xerbla_("SSYTRD", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { WORK(1) = 1.f; return 0; } /* Determine the block size. */ nb = ilaenv_(&c__1, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, 6L, 1L); nx = *n; iws = 1; if (nb > 1 && nb < *n) { /* Determine when to cross over from blocked to unblocked code (last block is always handled by unblocked code). Computing MAX */ i__1 = nb, i__2 = ilaenv_(&c__3, "SSYTRD", uplo, n, &c_n1, &c_n1, & c_n1, 6L, 1L); nx = max(i__1,i__2); if (nx < *n) { /* Determine if workspace is large enough for blocked co de. */ ldwork = *n; iws = ldwork * nb; if (*lwork < iws) { /* Not enough workspace to use optimal NB: deter mine the minimum value of NB, and reduce NB or force us e of unblocked code by setting NX = N. Computing MAX */ i__1 = *lwork / ldwork; nb = max(i__1,1); nbmin = ilaenv_(&c__2, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, 6L, 1L); if (nb < nbmin) { nx = *n; } } } else { nx = *n; } } else { nb = 1; } if (upper) { /* Reduce the upper triangle of A. Columns 1:kk are handled by the unblocked method. */ kk = *n - (*n - nx + nb - 1) / nb * nb; i__1 = kk + 1; i__2 = -nb; for (i = *n - nb + 1; -nb < 0 ? i >= kk+1 : i <= kk+1; i += -nb) { /* Reduce columns i:i+nb-1 to tridiagonal form and form the matrix W which is needed to update the unreduced part of the matrix */ i__3 = i + nb - 1; slatrd_(uplo, &i__3, &nb, &A(1,1), lda, &E(1), &TAU(1), & WORK(1), &ldwork); /* Update the unreduced submatrix A(1:i-1,1:i-1), using an update of the form: A := A - V*W' - W*V' */ i__3 = i - 1; ssyr2k_(uplo, "No transpose", &i__3, &nb, &c_b22, &A(1,i), lda, &WORK(1), &ldwork, &c_b23, &A(1,1), lda); /* Copy superdiagonal elements back into A, and diagonal elements into D */ i__3 = i + nb - 1; for (j = i; j <= i+nb-1; ++j) { A(j-1,j) = E(j - 1); D(j) = A(j,j); /* L10: */ } /* L20: */ } /* Use unblocked code to reduce the last or only block */ ssytd2_(uplo, &kk, &A(1,1), lda, &D(1), &E(1), &TAU(1), &iinfo); } else { /* Reduce the lower triangle of A */ i__2 = *n - nx; i__1 = nb; for (i = 1; nb < 0 ? i >= *n-nx : i <= *n-nx; i += nb) { /* Reduce columns i:i+nb-1 to tridiagonal form and form the matrix W which is needed to update the unreduced part of the matrix */ i__3 = *n - i + 1; slatrd_(uplo, &i__3, &nb, &A(i,i), lda, &E(i), &TAU(i), &WORK(1), &ldwork); /* Update the unreduced submatrix A(i+ib:n,i+ib:n), usin g an update of the form: A := A - V*W' - W*V' */ i__3 = *n - i - nb + 1; ssyr2k_(uplo, "No transpose", &i__3, &nb, &c_b22, &A(i+nb,i), lda, &WORK(nb + 1), &ldwork, &c_b23, &A(i+nb,i+nb), lda); /* Copy subdiagonal elements back into A, and diagonal elements into D */ i__3 = i + nb - 1; for (j = i; j <= i+nb-1; ++j) { A(j+1,j) = E(j); D(j) = A(j,j); /* L30: */ } /* L40: */ } /* Use unblocked code to reduce the last or only block */ i__1 = *n - i + 1; ssytd2_(uplo, &i__1, &A(i,i), lda, &D(i), &E(i), &TAU(i), & iinfo); } WORK(1) = (real) iws; return 0; /* End of SSYTRD */ } /* ssytrd_ */