void draw_uncollapsed_xaya(std::vector<double> &xaya, std::vector<double> &xa, std::vector<double> &xag, std::vector<double> Bg, double phi, int na, int p, int p_gamma) { double sd=sqrt(1/phi); std::vector<double> Z(na); for(std::vector<double>::iterator it=Z.begin(); it!=Z.end(); ++it) *it=Rf_rnorm(0,1); if(p_gamma!=0){ dgemv_(&transN , &na, &p_gamma, &unity, &*xag.begin(), &na, &*Bg.begin(), &inc, &inputscale0, &*xaya.begin(), &inc); daxpy_(&p, &sd, &*Z.begin(), &inc, &*xaya.begin(), &inc); //dtrmv_(&uplo, &transT, &unit_tri, &na, &*xa.begin(), &na, &*xaya.begin(), &inc); dtpmv_(&uplo, &transT, &unit_tri, &na, &*xa.begin(), &*xaya.begin(), &inc); }else{ for(size_t i=0; i!=xaya.size(); ++i) xaya[i]=sd*Z[i]; //dtrmv_(&uplo, &transT, &unit_tri, &na, &*xa.begin(), &na, &*xaya.begin(), &inc); dtpmv_(&uplo, &transT, &unit_tri, &na, &*xa.begin(), &*xaya.begin(), &inc); } }
int f2c_dtpmv(char* uplo, char* trans, char* diag, integer* N, doublereal* Ap, doublereal* X, integer* incX) { dtpmv_(uplo, trans, diag, N, Ap, X, incX); return 0; }
/* Subroutine */ int dppt01_(char *uplo, integer *n, doublereal *a, doublereal *afac, doublereal *rwork, doublereal *resid) { /* System generated locals */ integer i__1; /* Local variables */ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *); extern /* Subroutine */ int dspr_(char *, integer *, doublereal *, doublereal *, integer *, doublereal *); static integer i__, k; static doublereal t; extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, integer *); extern logical lsame_(char *, char *); static doublereal anorm; extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *, doublereal *, doublereal *, integer *); static integer kc; extern doublereal dlamch_(char *), dlansp_(char *, char *, integer *, doublereal *, doublereal *); static doublereal eps; static integer npp; /* -- LAPACK test routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University February 29, 1992 Purpose ======= DPPT01 reconstructs a symmetric positive definite packed matrix A from its L*L' or U'*U factorization and computes the residual norm( L*L' - A ) / ( N * norm(A) * EPS ) or norm( U'*U - A ) / ( N * norm(A) * EPS ), where EPS is the machine epsilon. Arguments ========== UPLO (input) CHARACTER*1 Specifies whether the upper or lower triangular part of the symmetric matrix A is stored: = 'U': Upper triangular = 'L': Lower triangular N (input) INTEGER The number of rows and columns of the matrix A. N >= 0. A (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) The original symmetric matrix A, stored as a packed triangular matrix. AFAC (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) On entry, the factor L or U from the L*L' or U'*U factorization of A, stored as a packed triangular matrix. Overwritten with the reconstructed matrix, and then with the difference L*L' - A (or U'*U - A). RWORK (workspace) DOUBLE PRECISION array, dimension (N) RESID (output) DOUBLE PRECISION If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) ===================================================================== Quick exit if N = 0 Parameter adjustments */ --rwork; --afac; --a; /* Function Body */ if (*n <= 0) { *resid = 0.; return 0; } /* Exit with RESID = 1/EPS if ANORM = 0. */ eps = dlamch_("Epsilon"); anorm = dlansp_("1", uplo, n, &a[1], &rwork[1]); if (anorm <= 0.) { *resid = 1. / eps; return 0; } /* Compute the product U'*U, overwriting U. */ if (lsame_(uplo, "U")) { kc = *n * (*n - 1) / 2 + 1; for (k = *n; k >= 1; --k) { /* Compute the (K,K) element of the result. */ t = ddot_(&k, &afac[kc], &c__1, &afac[kc], &c__1); afac[kc + k - 1] = t; /* Compute the rest of column K. */ if (k > 1) { i__1 = k - 1; dtpmv_("Upper", "Transpose", "Non-unit", &i__1, &afac[1], & afac[kc], &c__1); kc -= k - 1; } /* L10: */ } /* Compute the product L*L', overwriting L. */ } else { kc = *n * (*n + 1) / 2; for (k = *n; k >= 1; --k) { /* Add a multiple of column K of the factor L to each of columns K+1 through N. */ if (k < *n) { i__1 = *n - k; dspr_("Lower", &i__1, &c_b14, &afac[kc + 1], &c__1, &afac[kc + *n - k + 1]); } /* Scale column K by the diagonal element. */ t = afac[kc]; i__1 = *n - k + 1; dscal_(&i__1, &t, &afac[kc], &c__1); kc -= *n - k + 2; /* L20: */ } } /* Compute the difference L*L' - A (or U'*U - A). */ npp = *n * (*n + 1) / 2; i__1 = npp; for (i__ = 1; i__ <= i__1; ++i__) { afac[i__] -= a[i__]; /* L30: */ } /* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */ *resid = dlansp_("1", uplo, n, &afac[1], &rwork[1]); *resid = *resid / (doublereal) (*n) / anorm / eps; return 0; /* End of DPPT01 */ } /* dppt01_ */
/* Subroutine */ int dtptri_(char *uplo, char *diag, integer *n, doublereal * ap, integer *info) { /* System generated locals */ integer i__1, i__2; /* Local variables */ integer j, jc, jj; doublereal ajj; logical upper; integer jclast; logical nounit; /* -- LAPACK routine (version 3.2) -- */ /* November 2006 */ /* Purpose */ /* ======= */ /* DTPTRI computes the inverse of a real upper or lower triangular */ /* matrix A stored in packed format. */ /* Arguments */ /* ========= */ /* UPLO (input) CHARACTER*1 */ /* = 'U': A is upper triangular; */ /* = 'L': A is lower triangular. */ /* DIAG (input) CHARACTER*1 */ /* = 'N': A is non-unit triangular; */ /* = 'U': A is unit triangular. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ /* On entry, the upper or lower triangular matrix A, stored */ /* columnwise in a linear array. The j-th column of A is stored */ /* in the array AP as follows: */ /* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ /* if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n. */ /* See below for further details. */ /* On exit, the (triangular) inverse of the original matrix, in */ /* the same packed storage format. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* > 0: if INFO = i, A(i,i) is exactly zero. The triangular */ /* matrix is singular and its inverse can not be computed. */ /* Further Details */ /* =============== */ /* A triangular matrix A can be transferred to packed storage using one */ /* of the following program segments: */ /* UPLO = 'U': UPLO = 'L': */ /* JC = 1 JC = 1 */ /* DO 2 J = 1, N DO 2 J = 1, N */ /* DO 1 I = 1, J DO 1 I = J, N */ /* AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J) */ /* 1 CONTINUE 1 CONTINUE */ /* JC = JC + J JC = JC + N - J + 1 */ /* 2 CONTINUE 2 CONTINUE */ /* ===================================================================== */ /* Test the input parameters. */ /* Parameter adjustments */ --ap; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); nounit = lsame_(diag, "N"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (! nounit && ! lsame_(diag, "U")) { *info = -2; } else if (*n < 0) { *info = -3; } if (*info != 0) { i__1 = -(*info); xerbla_("DTPTRI", &i__1); return 0; } /* Check for singularity if non-unit. */ if (nounit) { if (upper) { jj = 0; i__1 = *n; for (*info = 1; *info <= i__1; ++(*info)) { jj += *info; if (ap[jj] == 0.) { return 0; } } } else { jj = 1; i__1 = *n; for (*info = 1; *info <= i__1; ++(*info)) { if (ap[jj] == 0.) { return 0; } jj = jj + *n - *info + 1; } } *info = 0; } if (upper) { /* Compute inverse of upper triangular matrix. */ jc = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { if (nounit) { ap[jc + j - 1] = 1. / ap[jc + j - 1]; ajj = -ap[jc + j - 1]; } else { ajj = -1.; } /* Compute elements 1:j-1 of j-th column. */ i__2 = j - 1; dtpmv_("Upper", "No transpose", diag, &i__2, &ap[1], &ap[jc], & c__1); i__2 = j - 1; dscal_(&i__2, &ajj, &ap[jc], &c__1); jc += j; } } else { /* Compute inverse of lower triangular matrix. */ jc = *n * (*n + 1) / 2; for (j = *n; j >= 1; --j) { if (nounit) { ap[jc] = 1. / ap[jc]; ajj = -ap[jc]; } else { ajj = -1.; } if (j < *n) { /* Compute elements j+1:n of j-th column. */ i__1 = *n - j; dtpmv_("Lower", "No transpose", diag, &i__1, &ap[jclast], &ap[ jc + 1], &c__1); i__1 = *n - j; dscal_(&i__1, &ajj, &ap[jc + 1], &c__1); } jclast = jc; jc = jc - *n + j - 2; } } return 0; /* End of DTPTRI */ } /* dtptri_ */
void dtpmv(char uplo, char transa, char diag, int n, double *ap, double *x, int incx) { dtpmv_( &uplo, &transa, &diag, &n, ap, x, &incx); }
/* Subroutine */ int dtptri_(char *uplo, char *diag, integer *n, doublereal * ap, 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 ======= DTPTRI computes the inverse of a real upper or lower triangular matrix A stored in packed format. Arguments ========= UPLO (input) CHARACTER*1 = 'U': A is upper triangular; = 'L': A is lower triangular. DIAG (input) CHARACTER*1 = 'N': A is non-unit triangular; = 'U': A is unit triangular. N (input) INTEGER The order of the matrix A. N >= 0. AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) On entry, the upper or lower triangular matrix A, stored columnwise in a linear array. The j-th column of A is stored in the array AP as follows: if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n. See below for further details. On exit, the (triangular) inverse of the original matrix, in the same packed storage format. INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value > 0: if INFO = i, A(i,i) is exactly zero. The triangular matrix is singular and its inverse can not be computed. Further Details =============== A triangular matrix A can be transferred to packed storage using one of the following program segments: UPLO = 'U': UPLO = 'L': JC = 1 JC = 1 DO 2 J = 1, N DO 2 J = 1, N DO 1 I = 1, J DO 1 I = J, N AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J) 1 CONTINUE 1 CONTINUE JC = JC + J JC = JC + N - J + 1 2 CONTINUE 2 CONTINUE ===================================================================== Test the input parameters. Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; /* System generated locals */ integer i__1, i__2; /* Local variables */ static integer j; extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, integer *); extern logical lsame_(char *, char *); extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *, doublereal *, doublereal *, integer *); static logical upper; static integer jc, jj; extern /* Subroutine */ int xerbla_(char *, integer *); static integer jclast; static logical nounit; static doublereal ajj; --ap; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); nounit = lsame_(diag, "N"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (! nounit && ! lsame_(diag, "U")) { *info = -2; } else if (*n < 0) { *info = -3; } if (*info != 0) { i__1 = -(*info); xerbla_("DTPTRI", &i__1); return 0; } /* Check for singularity if non-unit. */ if (nounit) { if (upper) { jj = 0; i__1 = *n; for (*info = 1; *info <= i__1; ++(*info)) { jj += *info; if (ap[jj] == 0.) { return 0; } /* L10: */ } } else { jj = 1; i__1 = *n; for (*info = 1; *info <= i__1; ++(*info)) { if (ap[jj] == 0.) { return 0; } jj = jj + *n - *info + 1; /* L20: */ } } *info = 0; } if (upper) { /* Compute inverse of upper triangular matrix. */ jc = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { if (nounit) { ap[jc + j - 1] = 1. / ap[jc + j - 1]; ajj = -ap[jc + j - 1]; } else { ajj = -1.; } /* Compute elements 1:j-1 of j-th column. */ i__2 = j - 1; dtpmv_("Upper", "No transpose", diag, &i__2, &ap[1], &ap[jc], & c__1); i__2 = j - 1; dscal_(&i__2, &ajj, &ap[jc], &c__1); jc += j; /* L30: */ } } else { /* Compute inverse of lower triangular matrix. */ jc = *n * (*n + 1) / 2; for (j = *n; j >= 1; --j) { if (nounit) { ap[jc] = 1. / ap[jc]; ajj = -ap[jc]; } else { ajj = -1.; } if (j < *n) { /* Compute elements j+1:n of j-th column. */ i__1 = *n - j; dtpmv_("Lower", "No transpose", diag, &i__1, &ap[jclast], &ap[ jc + 1], &c__1); i__1 = *n - j; dscal_(&i__1, &ajj, &ap[jc + 1], &c__1); } jclast = jc; jc = jc - *n + j - 2; /* L40: */ } } return 0; /* End of DTPTRI */ } /* dtptri_ */
/* Subroutine */ int dspgv_(integer *itype, char *jobz, char *uplo, integer * n, doublereal *ap, doublereal *bp, doublereal *w, doublereal *z__, integer *ldz, doublereal *work, integer *info) { /* -- LAPACK driver routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= DSPGV computes all the eigenvalues and, optionally, the eigenvectors of a real generalized symmetric-definite eigenproblem, of the form A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and B are assumed to be symmetric, stored in packed format, and B is also positive definite. Arguments ========= ITYPE (input) INTEGER Specifies the problem type to be solved: = 1: A*x = (lambda)*B*x = 2: A*B*x = (lambda)*x = 3: B*A*x = (lambda)*x JOBZ (input) CHARACTER*1 = 'N': Compute eigenvalues only; = 'V': Compute eigenvalues and eigenvectors. UPLO (input) CHARACTER*1 = 'U': Upper triangles of A and B are stored; = 'L': Lower triangles of A and B are stored. N (input) INTEGER The order of the matrices A and B. N >= 0. AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) On entry, the upper or lower triangle of the symmetric matrix A, packed columnwise in a linear array. The j-th column of A is stored in the array AP as follows: if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. On exit, the contents of AP are destroyed. BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) On entry, the upper or lower triangle of the symmetric matrix B, packed columnwise in a linear array. The j-th column of B is stored in the array BP as follows: if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. On exit, the triangular factor U or L from the Cholesky factorization B = U**T*U or B = L*L**T, in the same storage format as B. W (output) DOUBLE PRECISION array, dimension (N) If INFO = 0, the eigenvalues in ascending order. Z (output) DOUBLE PRECISION array, dimension (LDZ, N) If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of eigenvectors. The eigenvectors are normalized as follows: if ITYPE = 1 or 2, Z**T*B*Z = I; if ITYPE = 3, Z**T*inv(B)*Z = I. If JOBZ = 'N', then Z is not referenced. LDZ (input) INTEGER The leading dimension of the array Z. LDZ >= 1, and if JOBZ = 'V', LDZ >= max(1,N). WORK (workspace) DOUBLE PRECISION array, dimension (3*N) INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value > 0: DPPTRF or DSPEV returned an error code: <= N: if INFO = i, DSPEV failed to converge; i off-diagonal elements of an intermediate tridiagonal form did not converge to zero. > N: if INFO = n + i, for 1 <= i <= n, then the leading minor of order i of B is not positive definite. The factorization of B could not be completed and no eigenvalues or eigenvectors were computed. ===================================================================== Test the input parameters. Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; /* System generated locals */ integer z_dim1, z_offset, i__1; /* Local variables */ static integer neig, j; extern logical lsame_(char *, char *); extern /* Subroutine */ int dspev_(char *, char *, integer *, doublereal * , doublereal *, doublereal *, integer *, doublereal *, integer *); static char trans[1]; static logical upper; extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *, doublereal *, doublereal *, integer *), dtpsv_(char *, char *, char *, integer *, doublereal *, doublereal *, integer *); static logical wantz; extern /* Subroutine */ int xerbla_(char *, integer *), dpptrf_( char *, integer *, doublereal *, integer *), dspgst_( integer *, char *, integer *, doublereal *, doublereal *, integer *); #define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1] --ap; --bp; --w; z_dim1 = *ldz; z_offset = 1 + z_dim1 * 1; z__ -= z_offset; --work; /* Function Body */ wantz = lsame_(jobz, "V"); upper = lsame_(uplo, "U"); *info = 0; if (*itype < 0 || *itype > 3) { *info = -1; } else if (! (wantz || lsame_(jobz, "N"))) { *info = -2; } else if (! (upper || lsame_(uplo, "L"))) { *info = -3; } else if (*n < 0) { *info = -4; } else if (*ldz < 1 || wantz && *ldz < *n) { *info = -9; } if (*info != 0) { i__1 = -(*info); xerbla_("DSPGV ", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Form a Cholesky factorization of B. */ dpptrf_(uplo, n, &bp[1], info); if (*info != 0) { *info = *n + *info; return 0; } /* Transform problem to standard eigenvalue problem and solve. */ dspgst_(itype, uplo, n, &ap[1], &bp[1], info); dspev_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1], info); if (wantz) { /* Backtransform eigenvectors to the original problem. */ neig = *n; if (*info > 0) { neig = *info - 1; } if (*itype == 1 || *itype == 2) { /* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */ if (upper) { *(unsigned char *)trans = 'N'; } else { *(unsigned char *)trans = 'T'; } i__1 = neig; for (j = 1; j <= i__1; ++j) { dtpsv_(uplo, trans, "Non-unit", n, &bp[1], &z___ref(1, j), & c__1); /* L10: */ } } else if (*itype == 3) { /* For B*A*x=(lambda)*x; backtransform eigenvectors: x = L*y or U'*y */ if (upper) { *(unsigned char *)trans = 'T'; } else { *(unsigned char *)trans = 'N'; } i__1 = neig; for (j = 1; j <= i__1; ++j) { dtpmv_(uplo, trans, "Non-unit", n, &bp[1], &z___ref(1, j), & c__1); /* L20: */ } } } return 0; /* End of DSPGV */ } /* dspgv_ */
/* Subroutine */ int dspgvd_(integer *itype, char *jobz, char *uplo, integer * n, doublereal *ap, doublereal *bp, doublereal *w, doublereal *z__, integer *ldz, doublereal *work, integer *lwork, integer *iwork, integer *liwork, integer *info) { /* -- LAPACK driver routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University June 30, 1999 Purpose ======= DSPGVD computes all the eigenvalues, and optionally, the eigenvectors of a real generalized symmetric-definite eigenproblem, of the form A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and B are assumed to be symmetric, stored in packed format, and B is also positive definite. If eigenvectors are desired, it uses a divide and conquer algorithm. The divide and conquer algorithm makes very mild assumptions about floating point arithmetic. It will work on machines with a guard digit in add/subtract, or on those binary machines without guard digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. It could conceivably fail on hexadecimal or decimal machines without guard digits, but we know of none. Arguments ========= ITYPE (input) INTEGER Specifies the problem type to be solved: = 1: A*x = (lambda)*B*x = 2: A*B*x = (lambda)*x = 3: B*A*x = (lambda)*x JOBZ (input) CHARACTER*1 = 'N': Compute eigenvalues only; = 'V': Compute eigenvalues and eigenvectors. UPLO (input) CHARACTER*1 = 'U': Upper triangles of A and B are stored; = 'L': Lower triangles of A and B are stored. N (input) INTEGER The order of the matrices A and B. N >= 0. AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) On entry, the upper or lower triangle of the symmetric matrix A, packed columnwise in a linear array. The j-th column of A is stored in the array AP as follows: if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. On exit, the contents of AP are destroyed. BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) On entry, the upper or lower triangle of the symmetric matrix B, packed columnwise in a linear array. The j-th column of B is stored in the array BP as follows: if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. On exit, the triangular factor U or L from the Cholesky factorization B = U**T*U or B = L*L**T, in the same storage format as B. W (output) DOUBLE PRECISION array, dimension (N) If INFO = 0, the eigenvalues in ascending order. Z (output) DOUBLE PRECISION array, dimension (LDZ, N) If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of eigenvectors. The eigenvectors are normalized as follows: if ITYPE = 1 or 2, Z**T*B*Z = I; if ITYPE = 3, Z**T*inv(B)*Z = I. If JOBZ = 'N', then Z is not referenced. LDZ (input) INTEGER The leading dimension of the array Z. LDZ >= 1, and if JOBZ = 'V', LDZ >= max(1,N). WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) On exit, if INFO = 0, WORK(1) returns the optimal LWORK. LWORK (input) INTEGER The dimension of the array WORK. If N <= 1, LWORK >= 1. If JOBZ = 'N' and N > 1, LWORK >= 2*N. If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2. 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) On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. LIWORK (input) INTEGER The dimension of the array IWORK. If JOBZ = 'N' or N <= 1, LIWORK >= 1. If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. 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 > 0: DPPTRF or DSPEVD returned an error code: <= N: if INFO = i, DSPEVD failed to converge; i off-diagonal elements of an intermediate tridiagonal form did not converge to zero; > N: if INFO = N + i, for 1 <= i <= N, then the leading minor of order i of B is not positive definite. The factorization of B could not be completed and no eigenvalues or eigenvectors were computed. Further Details =============== Based on contributions by Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA ===================================================================== Test the input parameters. Parameter adjustments */ /* Table of constant values */ static integer c__2 = 2; static integer c__1 = 1; /* System generated locals */ integer z_dim1, z_offset, i__1; doublereal d__1, d__2; /* Builtin functions */ double log(doublereal); integer pow_ii(integer *, integer *); /* Local variables */ static integer neig, j; extern logical lsame_(char *, char *); static integer lwmin; static char trans[1]; static logical upper; extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *, doublereal *, doublereal *, integer *), dtpsv_(char *, char *, char *, integer *, doublereal *, doublereal *, integer *); static logical wantz; extern /* Subroutine */ int xerbla_(char *, integer *), dspevd_( char *, char *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *, integer *, integer *, integer *); static integer liwmin; extern /* Subroutine */ int dpptrf_(char *, integer *, doublereal *, integer *), dspgst_(integer *, char *, integer *, doublereal *, doublereal *, integer *); static logical lquery; static integer lgn; #define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1] --ap; --bp; --w; z_dim1 = *ldz; z_offset = 1 + z_dim1 * 1; z__ -= z_offset; --work; --iwork; /* Function Body */ wantz = lsame_(jobz, "V"); upper = lsame_(uplo, "U"); lquery = *lwork == -1 || *liwork == -1; *info = 0; if (*n <= 1) { lgn = 0; liwmin = 1; lwmin = 1; } else { lgn = (integer) (log((doublereal) (*n)) / log(2.)); if (pow_ii(&c__2, &lgn) < *n) { ++lgn; } if (pow_ii(&c__2, &lgn) < *n) { ++lgn; } if (wantz) { liwmin = *n * 5 + 3; /* Computing 2nd power */ i__1 = *n; lwmin = *n * 5 + 1 + (*n << 1) * lgn + (i__1 * i__1 << 1); } else { liwmin = 1; lwmin = *n << 1; } } if (*itype < 0 || *itype > 3) { *info = -1; } else if (! (wantz || lsame_(jobz, "N"))) { *info = -2; } else if (! (upper || lsame_(uplo, "L"))) { *info = -3; } else if (*n < 0) { *info = -4; } else if (*ldz < max(1,*n)) { *info = -9; } else if (*lwork < lwmin && ! lquery) { *info = -11; } else if (*liwork < liwmin && ! lquery) { *info = -13; } if (*info == 0) { work[1] = (doublereal) lwmin; iwork[1] = liwmin; } if (*info != 0) { i__1 = -(*info); xerbla_("DSPGVD", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Form a Cholesky factorization of BP. */ dpptrf_(uplo, n, &bp[1], info); if (*info != 0) { *info = *n + *info; return 0; } /* Transform problem to standard eigenvalue problem and solve. */ dspgst_(itype, uplo, n, &ap[1], &bp[1], info); dspevd_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1], lwork, &iwork[1], liwork, info); /* Computing MAX */ d__1 = (doublereal) lwmin; lwmin = (integer) max(d__1,work[1]); /* Computing MAX */ d__1 = (doublereal) liwmin, d__2 = (doublereal) iwork[1]; liwmin = (integer) max(d__1,d__2); if (wantz) { /* Backtransform eigenvectors to the original problem. */ neig = *n; if (*info > 0) { neig = *info - 1; } if (*itype == 1 || *itype == 2) { /* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */ if (upper) { *(unsigned char *)trans = 'N'; } else { *(unsigned char *)trans = 'T'; } i__1 = neig; for (j = 1; j <= i__1; ++j) { dtpsv_(uplo, trans, "Non-unit", n, &bp[1], &z___ref(1, j), & c__1); /* L10: */ } } else if (*itype == 3) { /* For B*A*x=(lambda)*x; backtransform eigenvectors: x = L*y or U'*y */ if (upper) { *(unsigned char *)trans = 'T'; } else { *(unsigned char *)trans = 'N'; } i__1 = neig; for (j = 1; j <= i__1; ++j) { dtpmv_(uplo, trans, "Non-unit", n, &bp[1], &z___ref(1, j), & c__1); /* L20: */ } } } work[1] = (doublereal) lwmin; iwork[1] = liwmin; return 0; /* End of DSPGVD */ } /* dspgvd_ */
/* Subroutine */ int dpptri_(char *uplo, integer *n, doublereal *ap, integer * info) { /* System generated locals */ integer i__1, i__2; /* Local variables */ integer j, jc, jj; doublereal ajj; integer jjn; extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *); extern /* Subroutine */ int dspr_(char *, integer *, doublereal *, doublereal *, integer *, doublereal *), dscal_(integer *, doublereal *, doublereal *, integer *); extern logical lsame_(char *, char *); extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *, doublereal *, doublereal *, integer *); logical upper; extern /* Subroutine */ int xerbla_(char *, integer *), dtptri_( char *, char *, integer *, doublereal *, integer *); /* -- LAPACK computational routine (version 3.4.0) -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ /* November 2011 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ --ap; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } if (*info != 0) { i__1 = -(*info); xerbla_("DPPTRI", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Invert the triangular Cholesky factor U or L. */ dtptri_(uplo, "Non-unit", n, &ap[1], info); if (*info > 0) { return 0; } if (upper) { /* Compute the product inv(U) * inv(U)**T. */ jj = 0; i__1 = *n; for (j = 1; j <= i__1; ++j) { jc = jj + 1; jj += j; if (j > 1) { i__2 = j - 1; dspr_("Upper", &i__2, &c_b8, &ap[jc], &c__1, &ap[1]); } ajj = ap[jj]; dscal_(&j, &ajj, &ap[jc], &c__1); /* L10: */ } } else { /* Compute the product inv(L)**T * inv(L). */ jj = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { jjn = jj + *n - j + 1; i__2 = *n - j + 1; ap[jj] = ddot_(&i__2, &ap[jj], &c__1, &ap[jj], &c__1); if (j < *n) { i__2 = *n - j; dtpmv_("Lower", "Transpose", "Non-unit", &i__2, &ap[jjn], &ap[ jj + 1], &c__1); } jj = jjn; /* L20: */ } } return 0; /* End of DPPTRI */ }
/* Subroutine */ int dppt01_(char *uplo, integer *n, doublereal *a, doublereal *afac, doublereal *rwork, doublereal *resid) { /* System generated locals */ integer i__1; /* Local variables */ integer i__, k; doublereal t; integer kc; doublereal eps; integer npp; doublereal anorm; /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* DPPT01 reconstructs a symmetric positive definite packed matrix A */ /* from its L*L' or U'*U factorization and computes the residual */ /* norm( L*L' - A ) / ( N * norm(A) * EPS ) or */ /* norm( U'*U - A ) / ( N * norm(A) * EPS ), */ /* where EPS is the machine epsilon. */ /* Arguments */ /* ========== */ /* UPLO (input) CHARACTER*1 */ /* Specifies whether the upper or lower triangular part of the */ /* symmetric matrix A is stored: */ /* = 'U': Upper triangular */ /* = 'L': Lower triangular */ /* N (input) INTEGER */ /* The number of rows and columns of the matrix A. N >= 0. */ /* A (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ /* The original symmetric matrix A, stored as a packed */ /* triangular matrix. */ /* AFAC (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ /* On entry, the factor L or U from the L*L' or U'*U */ /* factorization of A, stored as a packed triangular matrix. */ /* Overwritten with the reconstructed matrix, and then with the */ /* difference L*L' - A (or U'*U - A). */ /* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */ /* RESID (output) DOUBLE PRECISION */ /* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */ /* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Quick exit if N = 0 */ /* Parameter adjustments */ --rwork; --afac; --a; /* Function Body */ if (*n <= 0) { *resid = 0.; return 0; } /* Exit with RESID = 1/EPS if ANORM = 0. */ eps = dlamch_("Epsilon"); anorm = dlansp_("1", uplo, n, &a[1], &rwork[1]); if (anorm <= 0.) { *resid = 1. / eps; return 0; } /* Compute the product U'*U, overwriting U. */ if (lsame_(uplo, "U")) { kc = *n * (*n - 1) / 2 + 1; for (k = *n; k >= 1; --k) { /* Compute the (K,K) element of the result. */ t = ddot_(&k, &afac[kc], &c__1, &afac[kc], &c__1); afac[kc + k - 1] = t; /* Compute the rest of column K. */ if (k > 1) { i__1 = k - 1; dtpmv_("Upper", "Transpose", "Non-unit", &i__1, &afac[1], & afac[kc], &c__1); kc -= k - 1; } /* L10: */ } /* Compute the product L*L', overwriting L. */ } else { kc = *n * (*n + 1) / 2; for (k = *n; k >= 1; --k) { /* Add a multiple of column K of the factor L to each of */ /* columns K+1 through N. */ if (k < *n) { i__1 = *n - k; dspr_("Lower", &i__1, &c_b14, &afac[kc + 1], &c__1, &afac[kc + *n - k + 1]); } /* Scale column K by the diagonal element. */ t = afac[kc]; i__1 = *n - k + 1; dscal_(&i__1, &t, &afac[kc], &c__1); kc -= *n - k + 2; /* L20: */ } } /* Compute the difference L*L' - A (or U'*U - A). */ npp = *n * (*n + 1) / 2; i__1 = npp; for (i__ = 1; i__ <= i__1; ++i__) { afac[i__] -= a[i__]; /* L30: */ } /* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */ *resid = dlansp_("1", uplo, n, &afac[1], &rwork[1]); *resid = *resid / (doublereal) (*n) / anorm / eps; return 0; /* End of DPPT01 */ } /* dppt01_ */
/* Subroutine */ int dspgst_(integer *itype, char *uplo, integer *n, doublereal *ap, doublereal *bp, integer *info) { /* System generated locals */ integer i__1, i__2; doublereal d__1; /* Local variables */ integer j, k, j1, k1, jj, kk; doublereal ct, ajj; integer j1j1; doublereal akk; integer k1k1; doublereal bjj, bkk; extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *); extern /* Subroutine */ int dspr2_(char *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *), dscal_(integer *, doublereal *, doublereal *, integer *); extern logical lsame_(char *, char *); extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *), dspmv_(char *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, integer *); logical upper; extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *, doublereal *, doublereal *, integer *), dtpsv_(char *, char *, char *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *); /* -- LAPACK computational routine (version 3.4.0) -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ /* November 2011 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ --bp; --ap; /* 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; } if (*info != 0) { i__1 = -(*info); xerbla_("DSPGST", &i__1); return 0; } if (*itype == 1) { if (upper) { /* Compute inv(U**T)*A*inv(U) */ /* J1 and JJ are the indices of A(1,j) and A(j,j) */ jj = 0; i__1 = *n; for (j = 1; j <= i__1; ++j) { j1 = jj + 1; jj += j; /* Compute the j-th column of the upper triangle of A */ bjj = bp[jj]; dtpsv_(uplo, "Transpose", "Nonunit", &j, &bp[1], &ap[j1], & c__1); i__2 = j - 1; dspmv_(uplo, &i__2, &c_b9, &ap[1], &bp[j1], &c__1, &c_b11, & ap[j1], &c__1); i__2 = j - 1; d__1 = 1. / bjj; dscal_(&i__2, &d__1, &ap[j1], &c__1); i__2 = j - 1; ap[jj] = (ap[jj] - ddot_(&i__2, &ap[j1], &c__1, &bp[j1], & c__1)) / bjj; /* L10: */ } } else { /* Compute inv(L)*A*inv(L**T) */ /* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) */ kk = 1; i__1 = *n; for (k = 1; k <= i__1; ++k) { k1k1 = kk + *n - k + 1; /* Update the lower triangle of A(k:n,k:n) */ akk = ap[kk]; bkk = bp[kk]; /* Computing 2nd power */ d__1 = bkk; akk /= d__1 * d__1; ap[kk] = akk; if (k < *n) { i__2 = *n - k; d__1 = 1. / bkk; dscal_(&i__2, &d__1, &ap[kk + 1], &c__1); ct = akk * -.5; i__2 = *n - k; daxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) ; i__2 = *n - k; dspr2_(uplo, &i__2, &c_b9, &ap[kk + 1], &c__1, &bp[kk + 1] , &c__1, &ap[k1k1]); i__2 = *n - k; daxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) ; i__2 = *n - k; dtpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1], &ap[kk + 1], &c__1); } kk = k1k1; /* L20: */ } } } else { if (upper) { /* Compute U*A*U**T */ /* K1 and KK are the indices of A(1,k) and A(k,k) */ kk = 0; i__1 = *n; for (k = 1; k <= i__1; ++k) { k1 = kk + 1; kk += k; /* Update the upper triangle of A(1:k,1:k) */ akk = ap[kk]; bkk = bp[kk]; i__2 = k - 1; dtpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[ k1], &c__1); ct = akk * .5; i__2 = k - 1; daxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1); i__2 = k - 1; dspr2_(uplo, &i__2, &c_b11, &ap[k1], &c__1, &bp[k1], &c__1, & ap[1]); i__2 = k - 1; daxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1); i__2 = k - 1; dscal_(&i__2, &bkk, &ap[k1], &c__1); /* Computing 2nd power */ d__1 = bkk; ap[kk] = akk * (d__1 * d__1); /* L30: */ } } else { /* Compute L**T *A*L */ /* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) */ jj = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { j1j1 = jj + *n - j + 1; /* Compute the j-th column of the lower triangle of A */ ajj = ap[jj]; bjj = bp[jj]; i__2 = *n - j; ap[jj] = ajj * bjj + ddot_(&i__2, &ap[jj + 1], &c__1, &bp[jj + 1], &c__1); i__2 = *n - j; dscal_(&i__2, &bjj, &ap[jj + 1], &c__1); i__2 = *n - j; dspmv_(uplo, &i__2, &c_b11, &ap[j1j1], &bp[jj + 1], &c__1, & c_b11, &ap[jj + 1], &c__1); i__2 = *n - j + 1; dtpmv_(uplo, "Transpose", "Non-unit", &i__2, &bp[jj], &ap[jj], &c__1); jj = j1j1; /* L40: */ } } } return 0; /* End of DSPGST */ }
/* Subroutine */ int dspgst_(integer *itype, char *uplo, integer *n, doublereal *ap, doublereal *bp, integer *info) { /* -- LAPACK routine (version 2.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University March 31, 1993 Purpose ======= DSPGST reduces a real symmetric-definite generalized eigenproblem to standard form, using packed storage. 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 DPPTRF. 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. AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) On entry, 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. On exit, if INFO = 0, the transformed matrix, stored in the same format as A. BP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) The triangular factor from the Cholesky factorization of B, stored in the same format as A, as returned by DPPTRF. INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value ===================================================================== Test the input parameters. Parameter adjustments Function Body */ /* Table of constant values */ static integer c__1 = 1; static doublereal c_b9 = -1.; static doublereal c_b11 = 1.; /* System generated locals */ integer i__1, i__2; doublereal d__1; /* Local variables */ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *); extern /* Subroutine */ int dspr2_(char *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *); static integer j, k; extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, integer *); extern logical lsame_(char *, char *); extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *), dspmv_(char *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, integer *); static logical upper; static integer j1, k1; extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *, doublereal *, doublereal *, integer *), dtpsv_(char *, char *, char *, integer *, doublereal *, doublereal *, integer *); static integer jj, kk; static doublereal ct; extern /* Subroutine */ int xerbla_(char *, integer *); static doublereal ajj; static integer j1j1; static doublereal akk; static integer k1k1; static doublereal bjj, bkk; #define BP(I) bp[(I)-1] #define AP(I) ap[(I)-1] *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; } if (*info != 0) { i__1 = -(*info); xerbla_("DSPGST", &i__1); return 0; } if (*itype == 1) { if (upper) { /* Compute inv(U')*A*inv(U) J1 and JJ are the indices of A(1,j) and A(j,j) */ jj = 0; i__1 = *n; for (j = 1; j <= *n; ++j) { j1 = jj + 1; jj += j; /* Compute the j-th column of the upper triangle of A */ bjj = BP(jj); dtpsv_(uplo, "Transpose", "Nonunit", &j, &BP(1), &AP(j1), & c__1); i__2 = j - 1; dspmv_(uplo, &i__2, &c_b9, &AP(1), &BP(j1), &c__1, &c_b11, & AP(j1), &c__1); i__2 = j - 1; d__1 = 1. / bjj; dscal_(&i__2, &d__1, &AP(j1), &c__1); i__2 = j - 1; AP(jj) = (AP(jj) - ddot_(&i__2, &AP(j1), &c__1, &BP(j1), & c__1)) / bjj; /* L10: */ } } else { /* Compute inv(L)*A*inv(L') KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) */ kk = 1; i__1 = *n; for (k = 1; k <= *n; ++k) { k1k1 = kk + *n - k + 1; /* Update the lower triangle of A(k:n,k:n) */ akk = AP(kk); bkk = BP(kk); /* Computing 2nd power */ d__1 = bkk; akk /= d__1 * d__1; AP(kk) = akk; if (k < *n) { i__2 = *n - k; d__1 = 1. / bkk; dscal_(&i__2, &d__1, &AP(kk + 1), &c__1); ct = akk * -.5; i__2 = *n - k; daxpy_(&i__2, &ct, &BP(kk + 1), &c__1, &AP(kk + 1), &c__1) ; i__2 = *n - k; dspr2_(uplo, &i__2, &c_b9, &AP(kk + 1), &c__1, &BP(kk + 1) , &c__1, &AP(k1k1)); i__2 = *n - k; daxpy_(&i__2, &ct, &BP(kk + 1), &c__1, &AP(kk + 1), &c__1) ; i__2 = *n - k; dtpsv_(uplo, "No transpose", "Non-unit", &i__2, &BP(k1k1), &AP(kk + 1), &c__1); } kk = k1k1; /* L20: */ } } } else { if (upper) { /* Compute U*A*U' K1 and KK are the indices of A(1,k) and A(k,k) */ kk = 0; i__1 = *n; for (k = 1; k <= *n; ++k) { k1 = kk + 1; kk += k; /* Update the upper triangle of A(1:k,1:k) */ akk = AP(kk); bkk = BP(kk); i__2 = k - 1; dtpmv_(uplo, "No transpose", "Non-unit", &i__2, &BP(1), &AP( k1), &c__1); ct = akk * .5; i__2 = k - 1; daxpy_(&i__2, &ct, &BP(k1), &c__1, &AP(k1), &c__1); i__2 = k - 1; dspr2_(uplo, &i__2, &c_b11, &AP(k1), &c__1, &BP(k1), &c__1, & AP(1)); i__2 = k - 1; daxpy_(&i__2, &ct, &BP(k1), &c__1, &AP(k1), &c__1); i__2 = k - 1; dscal_(&i__2, &bkk, &AP(k1), &c__1); /* Computing 2nd power */ d__1 = bkk; AP(kk) = akk * (d__1 * d__1); /* L30: */ } } else { /* Compute L'*A*L JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) */ jj = 1; i__1 = *n; for (j = 1; j <= *n; ++j) { j1j1 = jj + *n - j + 1; /* Compute the j-th column of the lower triangle of A */ ajj = AP(jj); bjj = BP(jj); i__2 = *n - j; AP(jj) = ajj * bjj + ddot_(&i__2, &AP(jj + 1), &c__1, &BP(jj + 1), &c__1); i__2 = *n - j; dscal_(&i__2, &bjj, &AP(jj + 1), &c__1); i__2 = *n - j; dspmv_(uplo, &i__2, &c_b11, &AP(j1j1), &BP(jj + 1), &c__1, & c_b11, &AP(jj + 1), &c__1); i__2 = *n - j + 1; dtpmv_(uplo, "Transpose", "Non-unit", &i__2, &BP(jj), &AP(jj), &c__1); jj = j1j1; /* L40: */ } } } return 0; /* End of DSPGST */ } /* dspgst_ */
/* Subroutine */ int dspgvd_(integer *itype, char *jobz, char *uplo, integer * n, doublereal *ap, doublereal *bp, doublereal *w, doublereal *z__, integer *ldz, doublereal *work, integer *lwork, integer *iwork, integer *liwork, integer *info) { /* System generated locals */ integer z_dim1, z_offset, i__1; doublereal d__1, d__2; /* Local variables */ integer j, neig; extern logical lsame_(char *, char *); integer lwmin; char trans[1]; logical upper; extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *, doublereal *, doublereal *, integer *), dtpsv_(char *, char *, char *, integer *, doublereal *, doublereal *, integer *); logical wantz; extern /* Subroutine */ int xerbla_(char *, integer *), dspevd_( char *, char *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *, integer *, integer *, integer *); integer liwmin; extern /* Subroutine */ int dpptrf_(char *, integer *, doublereal *, integer *), dspgst_(integer *, char *, integer *, doublereal *, doublereal *, integer *); logical lquery; /* -- LAPACK driver routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* DSPGVD computes all the eigenvalues, and optionally, the eigenvectors */ /* of a real generalized symmetric-definite eigenproblem, of the form */ /* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and */ /* B are assumed to be symmetric, stored in packed format, and B is also */ /* positive definite. */ /* If eigenvectors are desired, it uses a divide and conquer algorithm. */ /* The divide and conquer algorithm makes very mild assumptions about */ /* floating point arithmetic. It will work on machines with a guard */ /* digit in add/subtract, or on those binary machines without guard */ /* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */ /* Cray-2. It could conceivably fail on hexadecimal or decimal machines */ /* without guard digits, but we know of none. */ /* Arguments */ /* ========= */ /* ITYPE (input) INTEGER */ /* Specifies the problem type to be solved: */ /* = 1: A*x = (lambda)*B*x */ /* = 2: A*B*x = (lambda)*x */ /* = 3: B*A*x = (lambda)*x */ /* JOBZ (input) CHARACTER*1 */ /* = 'N': Compute eigenvalues only; */ /* = 'V': Compute eigenvalues and eigenvectors. */ /* UPLO (input) CHARACTER*1 */ /* = 'U': Upper triangles of A and B are stored; */ /* = 'L': Lower triangles of A and B are stored. */ /* N (input) INTEGER */ /* The order of the matrices A and B. N >= 0. */ /* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ /* On entry, the upper or lower triangle of the symmetric matrix */ /* A, packed columnwise in a linear array. The j-th column of A */ /* is stored in the array AP as follows: */ /* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ /* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ /* On exit, the contents of AP are destroyed. */ /* BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ /* On entry, the upper or lower triangle of the symmetric matrix */ /* B, packed columnwise in a linear array. The j-th column of B */ /* is stored in the array BP as follows: */ /* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */ /* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */ /* On exit, the triangular factor U or L from the Cholesky */ /* factorization B = U**T*U or B = L*L**T, in the same storage */ /* format as B. */ /* W (output) DOUBLE PRECISION array, dimension (N) */ /* If INFO = 0, the eigenvalues in ascending order. */ /* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */ /* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */ /* eigenvectors. The eigenvectors are normalized as follows: */ /* if ITYPE = 1 or 2, Z**T*B*Z = I; */ /* if ITYPE = 3, Z**T*inv(B)*Z = I. */ /* If JOBZ = 'N', then Z is not referenced. */ /* LDZ (input) INTEGER */ /* The leading dimension of the array Z. LDZ >= 1, and if */ /* JOBZ = 'V', LDZ >= max(1,N). */ /* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ /* On exit, if INFO = 0, WORK(1) returns the required LWORK. */ /* LWORK (input) INTEGER */ /* The dimension of the array WORK. */ /* If N <= 1, LWORK >= 1. */ /* If JOBZ = 'N' and N > 1, LWORK >= 2*N. */ /* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2. */ /* If LWORK = -1, then a workspace query is assumed; the routine */ /* only calculates the required sizes of the WORK and IWORK */ /* arrays, returns these values as the first entries of the WORK */ /* and IWORK arrays, and no error message related to LWORK or */ /* LIWORK is issued by XERBLA. */ /* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ /* On exit, if INFO = 0, IWORK(1) returns the required LIWORK. */ /* LIWORK (input) INTEGER */ /* The dimension of the array IWORK. */ /* If JOBZ = 'N' or N <= 1, LIWORK >= 1. */ /* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */ /* If LIWORK = -1, then a workspace query is assumed; the */ /* routine only calculates the required sizes of the WORK and */ /* IWORK arrays, returns these values as the first entries of */ /* the WORK and IWORK arrays, and no error message related to */ /* LWORK or LIWORK is issued by XERBLA. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* > 0: DPPTRF or DSPEVD returned an error code: */ /* <= N: if INFO = i, DSPEVD failed to converge; */ /* i off-diagonal elements of an intermediate */ /* tridiagonal form did not converge to zero; */ /* > N: if INFO = N + i, for 1 <= i <= N, then the leading */ /* minor of order i of B is not positive definite. */ /* The factorization of B could not be completed and */ /* no eigenvalues or eigenvectors were computed. */ /* Further Details */ /* =============== */ /* Based on contributions by */ /* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ --ap; --bp; --w; z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --work; --iwork; /* Function Body */ wantz = lsame_(jobz, "V"); upper = lsame_(uplo, "U"); lquery = *lwork == -1 || *liwork == -1; *info = 0; if (*itype < 1 || *itype > 3) { *info = -1; } else if (! (wantz || lsame_(jobz, "N"))) { *info = -2; } else if (! (upper || lsame_(uplo, "L"))) { *info = -3; } else if (*n < 0) { *info = -4; } else if (*ldz < 1 || wantz && *ldz < *n) { *info = -9; } if (*info == 0) { if (*n <= 1) { liwmin = 1; lwmin = 1; } else { if (wantz) { liwmin = *n * 5 + 3; /* Computing 2nd power */ i__1 = *n; lwmin = *n * 6 + 1 + (i__1 * i__1 << 1); } else { liwmin = 1; lwmin = *n << 1; } } work[1] = (doublereal) lwmin; iwork[1] = liwmin; if (*lwork < lwmin && ! lquery) { *info = -11; } else if (*liwork < liwmin && ! lquery) { *info = -13; } } if (*info != 0) { i__1 = -(*info); xerbla_("DSPGVD", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Form a Cholesky factorization of BP. */ dpptrf_(uplo, n, &bp[1], info); if (*info != 0) { *info = *n + *info; return 0; } /* Transform problem to standard eigenvalue problem and solve. */ dspgst_(itype, uplo, n, &ap[1], &bp[1], info); dspevd_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1], lwork, &iwork[1], liwork, info); /* Computing MAX */ d__1 = (doublereal) lwmin; lwmin = (integer) max(d__1,work[1]); /* Computing MAX */ d__1 = (doublereal) liwmin, d__2 = (doublereal) iwork[1]; liwmin = (integer) max(d__1,d__2); if (wantz) { /* Backtransform eigenvectors to the original problem. */ neig = *n; if (*info > 0) { neig = *info - 1; } if (*itype == 1 || *itype == 2) { /* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */ /* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */ if (upper) { *(unsigned char *)trans = 'N'; } else { *(unsigned char *)trans = 'T'; } i__1 = neig; for (j = 1; j <= i__1; ++j) { dtpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + 1], &c__1); /* L10: */ } } else if (*itype == 3) { /* For B*A*x=(lambda)*x; */ /* backtransform eigenvectors: x = L*y or U'*y */ if (upper) { *(unsigned char *)trans = 'T'; } else { *(unsigned char *)trans = 'N'; } i__1 = neig; for (j = 1; j <= i__1; ++j) { dtpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + 1], &c__1); /* L20: */ } } } work[1] = (doublereal) lwmin; iwork[1] = liwmin; return 0; /* End of DSPGVD */ } /* dspgvd_ */
/* Subroutine */ int dpptri_(char *uplo, integer *n, doublereal *ap, integer * info) { /* System generated locals */ integer i__1, i__2; /* Local variables */ integer j, jc, jj; doublereal ajj; integer jjn; logical upper; /* -- LAPACK routine (version 3.2) -- */ /* November 2006 */ /* Purpose */ /* ======= */ /* DPPTRI computes the inverse of a real symmetric positive definite */ /* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T */ /* computed by DPPTRF. */ /* Arguments */ /* ========= */ /* UPLO (input) CHARACTER*1 */ /* = 'U': Upper triangular factor is stored in AP; */ /* = 'L': Lower triangular factor is stored in AP. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ /* On entry, the triangular factor U or L from the Cholesky */ /* factorization A = U**T*U or A = L*L**T, packed columnwise as */ /* a linear array. The j-th column of U or L is stored in the */ /* array AP as follows: */ /* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */ /* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */ /* On exit, the upper or lower triangle of the (symmetric) */ /* inverse of A, overwriting the input factor U or L. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* > 0: if INFO = i, the (i,i) element of the factor U or L is */ /* zero, and the inverse could not be computed. */ /* ===================================================================== */ /* Test the input parameters. */ /* Parameter adjustments */ --ap; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } if (*info != 0) { i__1 = -(*info); xerbla_("DPPTRI", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Invert the triangular Cholesky factor U or L. */ dtptri_(uplo, "Non-unit", n, &ap[1], info); if (*info > 0) { return 0; } if (upper) { /* Compute the product inv(U) * inv(U)'. */ jj = 0; i__1 = *n; for (j = 1; j <= i__1; ++j) { jc = jj + 1; jj += j; if (j > 1) { i__2 = j - 1; dspr_("Upper", &i__2, &c_b8, &ap[jc], &c__1, &ap[1]); } ajj = ap[jj]; dscal_(&j, &ajj, &ap[jc], &c__1); } } else { /* Compute the product inv(L)' * inv(L). */ jj = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { jjn = jj + *n - j + 1; i__2 = *n - j + 1; ap[jj] = ddot_(&i__2, &ap[jj], &c__1, &ap[jj], &c__1); if (j < *n) { i__2 = *n - j; dtpmv_("Lower", "Transpose", "Non-unit", &i__2, &ap[jjn], &ap[ jj + 1], &c__1); } jj = jjn; } } return 0; /* End of DPPTRI */ } /* dpptri_ */
/* Subroutine */ int dspgst_(integer *itype, char *uplo, integer *n, doublereal *ap, doublereal *bp, integer *info) { /* System generated locals */ integer i__1, i__2; doublereal d__1; /* Local variables */ integer j, k, j1, k1, jj, kk; doublereal ct, ajj; integer j1j1; doublereal akk; integer k1k1; doublereal bjj, bkk; extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *); extern /* Subroutine */ int dspr2_(char *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *), dscal_(integer *, doublereal *, doublereal *, integer *); extern logical lsame_(char *, char *); extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *), dspmv_(char *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, integer *); logical upper; extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *, doublereal *, doublereal *, integer *), dtpsv_(char *, char *, char *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *); /* -- LAPACK routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* DSPGST reduces a real symmetric-definite generalized eigenproblem */ /* to standard form, using packed storage. */ /* 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 DPPTRF. */ /* 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. */ /* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ /* On entry, 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. */ /* On exit, if INFO = 0, the transformed matrix, stored in the */ /* same format as A. */ /* BP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ /* The triangular factor from the Cholesky factorization of B, */ /* stored in the same format as A, as returned by DPPTRF. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ --bp; --ap; /* 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; } if (*info != 0) { i__1 = -(*info); xerbla_("DSPGST", &i__1); return 0; } if (*itype == 1) { if (upper) { /* Compute inv(U')*A*inv(U) */ /* J1 and JJ are the indices of A(1,j) and A(j,j) */ jj = 0; i__1 = *n; for (j = 1; j <= i__1; ++j) { j1 = jj + 1; jj += j; /* Compute the j-th column of the upper triangle of A */ bjj = bp[jj]; dtpsv_(uplo, "Transpose", "Nonunit", &j, &bp[1], &ap[j1], & c__1); i__2 = j - 1; dspmv_(uplo, &i__2, &c_b9, &ap[1], &bp[j1], &c__1, &c_b11, & ap[j1], &c__1); i__2 = j - 1; d__1 = 1. / bjj; dscal_(&i__2, &d__1, &ap[j1], &c__1); i__2 = j - 1; ap[jj] = (ap[jj] - ddot_(&i__2, &ap[j1], &c__1, &bp[j1], & c__1)) / bjj; /* L10: */ } } else { /* Compute inv(L)*A*inv(L') */ /* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) */ kk = 1; i__1 = *n; for (k = 1; k <= i__1; ++k) { k1k1 = kk + *n - k + 1; /* Update the lower triangle of A(k:n,k:n) */ akk = ap[kk]; bkk = bp[kk]; /* Computing 2nd power */ d__1 = bkk; akk /= d__1 * d__1; ap[kk] = akk; if (k < *n) { i__2 = *n - k; d__1 = 1. / bkk; dscal_(&i__2, &d__1, &ap[kk + 1], &c__1); ct = akk * -.5; i__2 = *n - k; daxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) ; i__2 = *n - k; dspr2_(uplo, &i__2, &c_b9, &ap[kk + 1], &c__1, &bp[kk + 1] , &c__1, &ap[k1k1]); i__2 = *n - k; daxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) ; i__2 = *n - k; dtpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1], &ap[kk + 1], &c__1); } kk = k1k1; /* L20: */ } } } else { if (upper) { /* Compute U*A*U' */ /* K1 and KK are the indices of A(1,k) and A(k,k) */ kk = 0; i__1 = *n; for (k = 1; k <= i__1; ++k) { k1 = kk + 1; kk += k; /* Update the upper triangle of A(1:k,1:k) */ akk = ap[kk]; bkk = bp[kk]; i__2 = k - 1; dtpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[ k1], &c__1); ct = akk * .5; i__2 = k - 1; daxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1); i__2 = k - 1; dspr2_(uplo, &i__2, &c_b11, &ap[k1], &c__1, &bp[k1], &c__1, & ap[1]); i__2 = k - 1; daxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1); i__2 = k - 1; dscal_(&i__2, &bkk, &ap[k1], &c__1); /* Computing 2nd power */ d__1 = bkk; ap[kk] = akk * (d__1 * d__1); /* L30: */ } } else { /* Compute L'*A*L */ /* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) */ jj = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { j1j1 = jj + *n - j + 1; /* Compute the j-th column of the lower triangle of A */ ajj = ap[jj]; bjj = bp[jj]; i__2 = *n - j; ap[jj] = ajj * bjj + ddot_(&i__2, &ap[jj + 1], &c__1, &bp[jj + 1], &c__1); i__2 = *n - j; dscal_(&i__2, &bjj, &ap[jj + 1], &c__1); i__2 = *n - j; dspmv_(uplo, &i__2, &c_b11, &ap[j1j1], &bp[jj + 1], &c__1, & c_b11, &ap[jj + 1], &c__1); i__2 = *n - j + 1; dtpmv_(uplo, "Transpose", "Non-unit", &i__2, &bp[jj], &ap[jj], &c__1); jj = j1j1; /* L40: */ } } } return 0; /* End of DSPGST */ } /* dspgst_ */
int dspgvx_(int *itype, char *jobz, char *range, char * uplo, int *n, double *ap, double *bp, double *vl, double *vu, int *il, int *iu, double *abstol, int *m, double *w, double *z__, int *ldz, double *work, int *iwork, int *ifail, int *info) { /* System generated locals */ int z_dim1, z_offset, i__1; /* Local variables */ int j; extern int lsame_(char *, char *); char trans[1]; int upper; extern int dtpmv_(char *, char *, char *, int *, double *, double *, int *), dtpsv_(char *, char *, char *, int *, double *, double *, int *); int wantz, alleig, indeig, valeig; extern int xerbla_(char *, int *), dpptrf_( char *, int *, double *, int *), dspgst_( int *, char *, int *, double *, double *, int *), dspevx_(char *, char *, char *, int *, double *, double *, double *, int *, int *, double *, int *, double *, double *, int *, double *, int *, int *, int *); /* -- LAPACK driver routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* DSPGVX computes selected eigenvalues, and optionally, eigenvectors */ /* of a float generalized symmetric-definite eigenproblem, of the form */ /* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A */ /* and B are assumed to be symmetric, stored in packed storage, and B */ /* is also positive definite. Eigenvalues and eigenvectors can be */ /* selected by specifying either a range of values or a range of indices */ /* for the desired eigenvalues. */ /* Arguments */ /* ========= */ /* ITYPE (input) INTEGER */ /* Specifies the problem type to be solved: */ /* = 1: A*x = (lambda)*B*x */ /* = 2: A*B*x = (lambda)*x */ /* = 3: B*A*x = (lambda)*x */ /* JOBZ (input) CHARACTER*1 */ /* = 'N': Compute eigenvalues only; */ /* = 'V': Compute eigenvalues and eigenvectors. */ /* RANGE (input) CHARACTER*1 */ /* = 'A': all eigenvalues will be found. */ /* = 'V': all eigenvalues in the half-open interval (VL,VU] */ /* will be found. */ /* = 'I': the IL-th through IU-th eigenvalues will be found. */ /* UPLO (input) CHARACTER*1 */ /* = 'U': Upper triangle of A and B are stored; */ /* = 'L': Lower triangle of A and B are stored. */ /* N (input) INTEGER */ /* The order of the matrix pencil (A,B). N >= 0. */ /* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ /* On entry, the upper or lower triangle of the symmetric matrix */ /* A, packed columnwise in a linear array. The j-th column of A */ /* is stored in the array AP as follows: */ /* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ /* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ /* On exit, the contents of AP are destroyed. */ /* BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ /* On entry, the upper or lower triangle of the symmetric matrix */ /* B, packed columnwise in a linear array. The j-th column of B */ /* is stored in the array BP as follows: */ /* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */ /* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */ /* On exit, the triangular factor U or L from the Cholesky */ /* factorization B = U**T*U or B = L*L**T, in the same storage */ /* format as B. */ /* VL (input) DOUBLE PRECISION */ /* VU (input) DOUBLE PRECISION */ /* If RANGE='V', the lower and upper bounds of the interval to */ /* be searched for eigenvalues. VL < VU. */ /* Not referenced if RANGE = 'A' or 'I'. */ /* IL (input) INTEGER */ /* IU (input) INTEGER */ /* If RANGE='I', the indices (in ascending order) of the */ /* smallest and largest eigenvalues to be returned. */ /* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ /* Not referenced if RANGE = 'A' or 'V'. */ /* ABSTOL (input) DOUBLE PRECISION */ /* The absolute error tolerance for the eigenvalues. */ /* An approximate eigenvalue is accepted as converged */ /* when it is determined to lie in an interval [a,b] */ /* of width less than or equal to */ /* ABSTOL + EPS * MAX( |a|,|b| ) , */ /* where EPS is the machine precision. If ABSTOL is less than */ /* or equal to zero, then EPS*|T| will be used in its place, */ /* where |T| is the 1-norm of the tridiagonal matrix obtained */ /* by reducing A to tridiagonal form. */ /* Eigenvalues will be computed most accurately when ABSTOL is */ /* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */ /* If this routine returns with INFO>0, indicating that some */ /* eigenvectors did not converge, try setting ABSTOL to */ /* 2*DLAMCH('S'). */ /* M (output) INTEGER */ /* The total number of eigenvalues found. 0 <= M <= N. */ /* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ /* W (output) DOUBLE PRECISION array, dimension (N) */ /* On normal exit, the first M elements contain the selected */ /* eigenvalues in ascending order. */ /* Z (output) DOUBLE PRECISION array, dimension (LDZ, MAX(1,M)) */ /* If JOBZ = 'N', then Z is not referenced. */ /* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */ /* contain the orthonormal eigenvectors of the matrix A */ /* corresponding to the selected eigenvalues, with the i-th */ /* column of Z holding the eigenvector associated with W(i). */ /* The eigenvectors are normalized as follows: */ /* if ITYPE = 1 or 2, Z**T*B*Z = I; */ /* if ITYPE = 3, Z**T*inv(B)*Z = I. */ /* If an eigenvector fails to converge, then that column of Z */ /* contains the latest approximation to the eigenvector, and the */ /* index of the eigenvector is returned in IFAIL. */ /* Note: the user must ensure that at least MAX(1,M) columns are */ /* supplied in the array Z; if RANGE = 'V', the exact value of M */ /* is not known in advance and an upper bound must be used. */ /* LDZ (input) INTEGER */ /* The leading dimension of the array Z. LDZ >= 1, and if */ /* JOBZ = 'V', LDZ >= MAX(1,N). */ /* WORK (workspace) DOUBLE PRECISION array, dimension (8*N) */ /* IWORK (workspace) INTEGER array, dimension (5*N) */ /* IFAIL (output) INTEGER array, dimension (N) */ /* If JOBZ = 'V', then if INFO = 0, the first M elements of */ /* IFAIL are zero. If INFO > 0, then IFAIL contains the */ /* indices of the eigenvectors that failed to converge. */ /* If JOBZ = 'N', then IFAIL is not referenced. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* > 0: DPPTRF or DSPEVX returned an error code: */ /* <= N: if INFO = i, DSPEVX failed to converge; */ /* i eigenvectors failed to converge. Their indices */ /* are stored in array IFAIL. */ /* > N: if INFO = N + i, for 1 <= i <= N, then the leading */ /* minor of order i of B is not positive definite. */ /* The factorization of B could not be completed and */ /* no eigenvalues or eigenvectors were computed. */ /* Further Details */ /* =============== */ /* Based on contributions by */ /* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */ /* ===================================================================== */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ --ap; --bp; --w; z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --work; --iwork; --ifail; /* Function Body */ upper = lsame_(uplo, "U"); wantz = lsame_(jobz, "V"); alleig = lsame_(range, "A"); valeig = lsame_(range, "V"); indeig = lsame_(range, "I"); *info = 0; if (*itype < 1 || *itype > 3) { *info = -1; } else if (! (wantz || lsame_(jobz, "N"))) { *info = -2; } else if (! (alleig || valeig || indeig)) { *info = -3; } else if (! (upper || lsame_(uplo, "L"))) { *info = -4; } else if (*n < 0) { *info = -5; } else { if (valeig) { if (*n > 0 && *vu <= *vl) { *info = -9; } } else if (indeig) { if (*il < 1) { *info = -10; } else if (*iu < MIN(*n,*il) || *iu > *n) { *info = -11; } } } if (*info == 0) { if (*ldz < 1 || wantz && *ldz < *n) { *info = -16; } } if (*info != 0) { i__1 = -(*info); xerbla_("DSPGVX", &i__1); return 0; } /* Quick return if possible */ *m = 0; if (*n == 0) { return 0; } /* Form a Cholesky factorization of B. */ dpptrf_(uplo, n, &bp[1], info); if (*info != 0) { *info = *n + *info; return 0; } /* Transform problem to standard eigenvalue problem and solve. */ dspgst_(itype, uplo, n, &ap[1], &bp[1], info); dspevx_(jobz, range, uplo, n, &ap[1], vl, vu, il, iu, abstol, m, &w[1], & z__[z_offset], ldz, &work[1], &iwork[1], &ifail[1], info); if (wantz) { /* Backtransform eigenvectors to the original problem. */ if (*info > 0) { *m = *info - 1; } if (*itype == 1 || *itype == 2) { /* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */ /* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */ if (upper) { *(unsigned char *)trans = 'N'; } else { *(unsigned char *)trans = 'T'; } i__1 = *m; for (j = 1; j <= i__1; ++j) { dtpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + 1], &c__1); /* L10: */ } } else if (*itype == 3) { /* For B*A*x=(lambda)*x; */ /* backtransform eigenvectors: x = L*y or U'*y */ if (upper) { *(unsigned char *)trans = 'T'; } else { *(unsigned char *)trans = 'N'; } i__1 = *m; for (j = 1; j <= i__1; ++j) { dtpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + 1], &c__1); /* L20: */ } } } return 0; /* End of DSPGVX */ } /* dspgvx_ */
/* Subroutine */ int dlarhs_(char *path, char *xtype, char *uplo, char *trans, integer *m, integer *n, integer *kl, integer *ku, integer *nrhs, doublereal *a, integer *lda, doublereal *x, integer *ldx, doublereal * b, integer *ldb, integer *iseed, integer *info) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1; /* Builtin functions Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); /* Local variables */ static logical band; static char diag[1]; static logical tran; static integer j; extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *), dgbmv_(char *, integer *, integer *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *); extern logical lsame_(char *, char *); extern /* Subroutine */ int dsbmv_(char *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *), dtbmv_(char *, char *, char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *), dtrmm_(char *, char *, char *, char *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *); static char c1[1], c2[2]; extern /* Subroutine */ int dspmv_(char *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, integer *), dsymm_(char *, char *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *), dtpmv_( char *, char *, char *, integer *, doublereal *, doublereal *, integer *); static integer mb, nx; extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *); extern logical lsamen_(integer *, char *, char *); extern /* Subroutine */ int dlarnv_(integer *, integer *, integer *, doublereal *); static logical notran, gen, tri, qrs, sym; #define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1] #define x_ref(a_1,a_2) x[(a_2)*x_dim1 + a_1] /* -- LAPACK test routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University February 29, 1992 Purpose ======= DLARHS chooses a set of NRHS random solution vectors and sets up the right hand sides for the linear system op( A ) * X = B, where op( A ) may be A or A' (transpose of A). Arguments ========= PATH (input) CHARACTER*3 The type of the real matrix A. PATH may be given in any combination of upper and lower case. Valid types include xGE: General m x n matrix xGB: General banded matrix xPO: Symmetric positive definite, 2-D storage xPP: Symmetric positive definite packed xPB: Symmetric positive definite banded xSY: Symmetric indefinite, 2-D storage xSP: Symmetric indefinite packed xSB: Symmetric indefinite banded xTR: Triangular xTP: Triangular packed xTB: Triangular banded xQR: General m x n matrix xLQ: General m x n matrix xQL: General m x n matrix xRQ: General m x n matrix where the leading character indicates the precision. XTYPE (input) CHARACTER*1 Specifies how the exact solution X will be determined: = 'N': New solution; generate a random X. = 'C': Computed; use value of X on entry. UPLO (input) CHARACTER*1 Specifies whether the upper or lower triangular part of the matrix A is stored, if A is symmetric. = 'U': Upper triangular = 'L': Lower triangular TRANS (input) CHARACTER*1 Specifies the operation applied to the matrix A. = 'N': System is A * x = b = 'T': System is A'* x = b = 'C': System is A'* x = b M (input) INTEGER The number or rows of the matrix A. M >= 0. N (input) INTEGER The number of columns of the matrix A. N >= 0. KL (input) INTEGER Used only if A is a band matrix; specifies the number of subdiagonals of A if A is a general band matrix or if A is symmetric or triangular and UPLO = 'L'; specifies the number of superdiagonals of A if A is symmetric or triangular and UPLO = 'U'. 0 <= KL <= M-1. KU (input) INTEGER Used only if A is a general band matrix or if A is triangular. If PATH = xGB, specifies the number of superdiagonals of A, and 0 <= KU <= N-1. If PATH = xTR, xTP, or xTB, specifies whether or not the matrix has unit diagonal: = 1: matrix has non-unit diagonal (default) = 2: matrix has unit diagonal NRHS (input) INTEGER The number of right hand side vectors in the system A*X = B. A (input) DOUBLE PRECISION array, dimension (LDA,N) The test matrix whose type is given by PATH. LDA (input) INTEGER The leading dimension of the array A. If PATH = xGB, LDA >= KL+KU+1. If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1. Otherwise, LDA >= max(1,M). X (input or output) DOUBLE PRECISION array, dimension(LDX,NRHS) On entry, if XTYPE = 'C' (for 'Computed'), then X contains the exact solution to the system of linear equations. On exit, if XTYPE = 'N' (for 'New'), then X is initialized with random values. LDX (input) INTEGER The leading dimension of the array X. If TRANS = 'N', LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M). B (output) DOUBLE PRECISION array, dimension (LDB,NRHS) The right hand side vector(s) for the system of equations, computed from B = op(A) * X, where op(A) is determined by TRANS. LDB (input) INTEGER The leading dimension of the array B. If TRANS = 'N', LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N). ISEED (input/output) INTEGER array, dimension (4) The seed vector for the random number generator (used in DLATMS). Modified on exit. INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value ===================================================================== Test the input parameters. Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; x_dim1 = *ldx; x_offset = 1 + x_dim1 * 1; x -= x_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; --iseed; /* Function Body */ *info = 0; *(unsigned char *)c1 = *(unsigned char *)path; s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2); tran = lsame_(trans, "T") || lsame_(trans, "C"); notran = ! tran; gen = lsame_(path + 1, "G"); qrs = lsame_(path + 1, "Q") || lsame_(path + 2, "Q"); sym = lsame_(path + 1, "P") || lsame_(path + 1, "S"); tri = lsame_(path + 1, "T"); band = lsame_(path + 2, "B"); if (! lsame_(c1, "Double precision")) { *info = -1; } else if (! (lsame_(xtype, "N") || lsame_(xtype, "C"))) { *info = -2; } else if ((sym || tri) && ! (lsame_(uplo, "U") || lsame_(uplo, "L"))) { *info = -3; } else if ((gen || qrs) && ! (tran || lsame_(trans, "N"))) { *info = -4; } else if (*m < 0) { *info = -5; } else if (*n < 0) { *info = -6; } else if (band && *kl < 0) { *info = -7; } else if (band && *ku < 0) { *info = -8; } else if (*nrhs < 0) { *info = -9; } else if (! band && *lda < max(1,*m) || band && (sym || tri) && *lda < * kl + 1 || band && gen && *lda < *kl + *ku + 1) { *info = -11; } else if (notran && *ldx < max(1,*n) || tran && *ldx < max(1,*m)) { *info = -13; } else if (notran && *ldb < max(1,*m) || tran && *ldb < max(1,*n)) { *info = -15; } if (*info != 0) { i__1 = -(*info); xerbla_("DLARHS", &i__1); return 0; } /* Initialize X to NRHS random vectors unless XTYPE = 'C'. */ if (tran) { nx = *m; mb = *n; } else { nx = *n; mb = *m; } if (! lsame_(xtype, "C")) { i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { dlarnv_(&c__2, &iseed[1], n, &x_ref(1, j)); /* L10: */ } } /* Multiply X by op( A ) using an appropriate matrix multiply routine. */ if (lsamen_(&c__2, c2, "GE") || lsamen_(&c__2, c2, "QR") || lsamen_(&c__2, c2, "LQ") || lsamen_(&c__2, c2, "QL") || lsamen_(&c__2, c2, "RQ")) { /* General matrix */ dgemm_(trans, "N", &mb, nrhs, &nx, &c_b32, &a[a_offset], lda, &x[ x_offset], ldx, &c_b33, &b[b_offset], ldb); } else if (lsamen_(&c__2, c2, "PO") || lsamen_(& c__2, c2, "SY")) { /* Symmetric matrix, 2-D storage */ dsymm_("Left", uplo, n, nrhs, &c_b32, &a[a_offset], lda, &x[x_offset], ldx, &c_b33, &b[b_offset], ldb); } else if (lsamen_(&c__2, c2, "GB")) { /* General matrix, band storage */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { dgbmv_(trans, &mb, &nx, kl, ku, &c_b32, &a[a_offset], lda, &x_ref( 1, j), &c__1, &c_b33, &b_ref(1, j), &c__1); /* L20: */ } } else if (lsamen_(&c__2, c2, "PB")) { /* Symmetric matrix, band storage */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { dsbmv_(uplo, n, kl, &c_b32, &a[a_offset], lda, &x_ref(1, j), & c__1, &c_b33, &b_ref(1, j), &c__1); /* L30: */ } } else if (lsamen_(&c__2, c2, "PP") || lsamen_(& c__2, c2, "SP")) { /* Symmetric matrix, packed storage */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { dspmv_(uplo, n, &c_b32, &a[a_offset], &x_ref(1, j), &c__1, &c_b33, &b_ref(1, j), &c__1); /* L40: */ } } else if (lsamen_(&c__2, c2, "TR")) { /* Triangular matrix. Note that for triangular matrices, KU = 1 => non-unit triangular KU = 2 => unit triangular */ dlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb); if (*ku == 2) { *(unsigned char *)diag = 'U'; } else { *(unsigned char *)diag = 'N'; } dtrmm_("Left", uplo, trans, diag, n, nrhs, &c_b32, &a[a_offset], lda, &b[b_offset], ldb) ; } else if (lsamen_(&c__2, c2, "TP")) { /* Triangular matrix, packed storage */ dlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb); if (*ku == 2) { *(unsigned char *)diag = 'U'; } else { *(unsigned char *)diag = 'N'; } i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { dtpmv_(uplo, trans, diag, n, &a[a_offset], &b_ref(1, j), &c__1); /* L50: */ } } else if (lsamen_(&c__2, c2, "TB")) { /* Triangular matrix, banded storage */ dlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb); if (*ku == 2) { *(unsigned char *)diag = 'U'; } else { *(unsigned char *)diag = 'N'; } i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { dtbmv_(uplo, trans, diag, n, kl, &a[a_offset], lda, &b_ref(1, j), &c__1); /* L60: */ } } else { /* If PATH is none of the above, return with an error code. */ *info = -1; i__1 = -(*info); xerbla_("DLARHS", &i__1); } return 0; /* End of DLARHS */ } /* dlarhs_ */
/* Subroutine */ int dtprfs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, doublereal *ap, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, integer *info) { /* System generated locals */ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3; doublereal d__1, d__2, d__3; /* Local variables */ integer i__, j, k; doublereal s; integer kc; doublereal xk; integer nz; doublereal eps; integer kase; doublereal safe1, safe2; extern logical lsame_(char *, char *); integer isave[3]; extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *), daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *), dtpmv_(char *, char *, char *, integer *, doublereal *, doublereal *, integer *); logical upper; extern /* Subroutine */ int dtpsv_(char *, char *, char *, integer *, doublereal *, doublereal *, integer *), dlacn2_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, integer *); extern doublereal dlamch_(char *); doublereal safmin; extern /* Subroutine */ int xerbla_(char *, integer *); logical notran; char transt[1]; logical nounit; doublereal lstres; /* -- LAPACK routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* DTPRFS provides error bounds and backward error estimates for the */ /* solution to a system of linear equations with a triangular packed */ /* coefficient matrix. */ /* The solution matrix X must be computed by DTPTRS or some other */ /* means before entering this routine. DTPRFS does not do iterative */ /* refinement because doing so cannot improve the backward error. */ /* Arguments */ /* ========= */ /* UPLO (input) CHARACTER*1 */ /* = 'U': A is upper triangular; */ /* = 'L': A is lower triangular. */ /* TRANS (input) CHARACTER*1 */ /* Specifies the form of the system of equations: */ /* = 'N': A * X = B (No transpose) */ /* = 'T': A**T * X = B (Transpose) */ /* = 'C': A**H * X = B (Conjugate transpose = Transpose) */ /* DIAG (input) CHARACTER*1 */ /* = 'N': A is non-unit triangular; */ /* = 'U': A is unit triangular. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* NRHS (input) INTEGER */ /* The number of right hand sides, i.e., the number of columns */ /* of the matrices B and X. NRHS >= 0. */ /* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ /* The upper or lower triangular matrix A, packed columnwise in */ /* a linear array. The j-th column of A is stored in the array */ /* AP as follows: */ /* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ /* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ /* If DIAG = 'U', the diagonal elements of A are not referenced */ /* and are assumed to be 1. */ /* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ /* The right hand side matrix B. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= max(1,N). */ /* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */ /* The solution matrix X. */ /* LDX (input) INTEGER */ /* The leading dimension of the array X. LDX >= max(1,N). */ /* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ /* The estimated forward error bound for each solution vector */ /* X(j) (the j-th column of the solution matrix X). */ /* If XTRUE is the true solution corresponding to X(j), FERR(j) */ /* is an estimated upper bound for the magnitude of the largest */ /* element in (X(j) - XTRUE) divided by the magnitude of the */ /* largest element in X(j). The estimate is as reliable as */ /* the estimate for RCOND, and is almost always a slight */ /* overestimate of the true error. */ /* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ /* The componentwise relative backward error of each solution */ /* vector X(j) (i.e., the smallest relative change in */ /* any element of A or B that makes X(j) an exact solution). */ /* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ /* IWORK (workspace) INTEGER array, dimension (N) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ --ap; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; x_dim1 = *ldx; x_offset = 1 + x_dim1; x -= x_offset; --ferr; --berr; --work; --iwork; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); notran = lsame_(trans, "N"); nounit = lsame_(diag, "N"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (! notran && ! lsame_(trans, "T") && ! lsame_(trans, "C")) { *info = -2; } else if (! nounit && ! lsame_(diag, "U")) { *info = -3; } else if (*n < 0) { *info = -4; } else if (*nrhs < 0) { *info = -5; } else if (*ldb < max(1,*n)) { *info = -8; } else if (*ldx < max(1,*n)) { *info = -10; } if (*info != 0) { i__1 = -(*info); xerbla_("DTPRFS", &i__1); return 0; } /* Quick return if possible */ if (*n == 0 || *nrhs == 0) { i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { ferr[j] = 0.; berr[j] = 0.; /* L10: */ } return 0; } if (notran) { *(unsigned char *)transt = 'T'; } else { *(unsigned char *)transt = 'N'; } /* NZ = maximum number of nonzero elements in each row of A, plus 1 */ nz = *n + 1; eps = dlamch_("Epsilon"); safmin = dlamch_("Safe minimum"); safe1 = nz * safmin; safe2 = safe1 / eps; /* Do for each right hand side */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { /* Compute residual R = B - op(A) * X, */ /* where op(A) = A or A', depending on TRANS. */ dcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[*n + 1], &c__1); dtpmv_(uplo, trans, diag, n, &ap[1], &work[*n + 1], &c__1); daxpy_(n, &c_b19, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); /* Compute componentwise relative backward error from formula */ /* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ /* where abs(Z) is the componentwise absolute value of the matrix */ /* or vector Z. If the i-th component of the denominator is less */ /* than SAFE2, then SAFE1 is added to the i-th components of the */ /* numerator and denominator before dividing. */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); /* L20: */ } if (notran) { /* Compute abs(A)*abs(X) + abs(B). */ if (upper) { kc = 1; if (nounit) { i__2 = *n; for (k = 1; k <= i__2; ++k) { xk = (d__1 = x[k + j * x_dim1], abs(d__1)); i__3 = k; for (i__ = 1; i__ <= i__3; ++i__) { work[i__] += (d__1 = ap[kc + i__ - 1], abs(d__1)) * xk; /* L30: */ } kc += k; /* L40: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { xk = (d__1 = x[k + j * x_dim1], abs(d__1)); i__3 = k - 1; for (i__ = 1; i__ <= i__3; ++i__) { work[i__] += (d__1 = ap[kc + i__ - 1], abs(d__1)) * xk; /* L50: */ } work[k] += xk; kc += k; /* L60: */ } } } else { kc = 1; if (nounit) { i__2 = *n; for (k = 1; k <= i__2; ++k) { xk = (d__1 = x[k + j * x_dim1], abs(d__1)); i__3 = *n; for (i__ = k; i__ <= i__3; ++i__) { work[i__] += (d__1 = ap[kc + i__ - k], abs(d__1)) * xk; /* L70: */ } kc = kc + *n - k + 1; /* L80: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { xk = (d__1 = x[k + j * x_dim1], abs(d__1)); i__3 = *n; for (i__ = k + 1; i__ <= i__3; ++i__) { work[i__] += (d__1 = ap[kc + i__ - k], abs(d__1)) * xk; /* L90: */ } work[k] += xk; kc = kc + *n - k + 1; /* L100: */ } } } } else { /* Compute abs(A')*abs(X) + abs(B). */ if (upper) { kc = 1; if (nounit) { i__2 = *n; for (k = 1; k <= i__2; ++k) { s = 0.; i__3 = k; for (i__ = 1; i__ <= i__3; ++i__) { s += (d__1 = ap[kc + i__ - 1], abs(d__1)) * (d__2 = x[i__ + j * x_dim1], abs(d__2)); /* L110: */ } work[k] += s; kc += k; /* L120: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { s = (d__1 = x[k + j * x_dim1], abs(d__1)); i__3 = k - 1; for (i__ = 1; i__ <= i__3; ++i__) { s += (d__1 = ap[kc + i__ - 1], abs(d__1)) * (d__2 = x[i__ + j * x_dim1], abs(d__2)); /* L130: */ } work[k] += s; kc += k; /* L140: */ } } } else { kc = 1; if (nounit) { i__2 = *n; for (k = 1; k <= i__2; ++k) { s = 0.; i__3 = *n; for (i__ = k; i__ <= i__3; ++i__) { s += (d__1 = ap[kc + i__ - k], abs(d__1)) * (d__2 = x[i__ + j * x_dim1], abs(d__2)); /* L150: */ } work[k] += s; kc = kc + *n - k + 1; /* L160: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { s = (d__1 = x[k + j * x_dim1], abs(d__1)); i__3 = *n; for (i__ = k + 1; i__ <= i__3; ++i__) { s += (d__1 = ap[kc + i__ - k], abs(d__1)) * (d__2 = x[i__ + j * x_dim1], abs(d__2)); /* L170: */ } work[k] += s; kc = kc + *n - k + 1; /* L180: */ } } } } s = 0.; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { if (work[i__] > safe2) { /* Computing MAX */ d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ i__]; s = max(d__2,d__3); } else { /* Computing MAX */ d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) / (work[i__] + safe1); s = max(d__2,d__3); } /* L190: */ } berr[j] = s; /* Bound error from formula */ /* norm(X - XTRUE) / norm(X) .le. FERR = */ /* norm( abs(inv(op(A)))* */ /* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ /* where */ /* norm(Z) is the magnitude of the largest component of Z */ /* inv(op(A)) is the inverse of op(A) */ /* abs(Z) is the componentwise absolute value of the matrix or */ /* vector Z */ /* NZ is the maximum number of nonzeros in any row of A, plus 1 */ /* EPS is machine epsilon */ /* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ /* is incremented by SAFE1 if the i-th component of */ /* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ /* Use DLACN2 to estimate the infinity-norm of the matrix */ /* inv(op(A)) * diag(W), */ /* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { if (work[i__] > safe2) { work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * work[i__]; } else { work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * work[i__] + safe1; } /* L200: */ } kase = 0; L210: dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & kase, isave); if (kase != 0) { if (kase == 1) { /* Multiply by diag(W)*inv(op(A)'). */ dtpsv_(uplo, transt, diag, n, &ap[1], &work[*n + 1], &c__1); i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { work[*n + i__] = work[i__] * work[*n + i__]; /* L220: */ } } else { /* Multiply by inv(op(A))*diag(W). */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { work[*n + i__] = work[i__] * work[*n + i__]; /* L230: */ } dtpsv_(uplo, trans, diag, n, &ap[1], &work[*n + 1], &c__1); } goto L210; } /* Normalize error. */ lstres = 0.; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { /* Computing MAX */ d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); lstres = max(d__2,d__3); /* L240: */ } if (lstres != 0.) { ferr[j] /= lstres; } /* L250: */ } return 0; /* End of DTPRFS */ } /* dtprfs_ */
/* Subroutine */ int dtpt02_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, doublereal *ap, doublereal *x, integer *ldx, doublereal *b, integer *ldb, doublereal *work, doublereal *resid) { /* System generated locals */ integer b_dim1, b_offset, x_dim1, x_offset, i__1; doublereal d__1, d__2; /* Local variables */ integer j; doublereal eps; extern logical lsame_(char *, char *); extern doublereal dasum_(integer *, doublereal *, integer *); doublereal anorm, bnorm; extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *), daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *), dtpmv_(char *, char *, char *, integer *, doublereal *, doublereal *, integer *); doublereal xnorm; extern doublereal dlamch_(char *), dlantp_(char *, char *, char *, integer *, doublereal *, doublereal *); /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* DTPT02 computes the residual for the computed solution to a */ /* triangular system of linear equations A*x = b or A'*x = b when */ /* the triangular matrix A is stored in packed format. Here A' is the */ /* transpose of A and x and b are N by NRHS matrices. The test ratio is */ /* the maximum over the number of right hand sides of */ /* norm(b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */ /* where op(A) denotes A or A' and EPS is the machine epsilon. */ /* Arguments */ /* ========= */ /* UPLO (input) CHARACTER*1 */ /* Specifies whether the matrix A is upper or lower triangular. */ /* = 'U': Upper triangular */ /* = 'L': Lower triangular */ /* TRANS (input) CHARACTER*1 */ /* Specifies the operation applied to A. */ /* = 'N': A *x = b (No transpose) */ /* = 'T': A'*x = b (Transpose) */ /* = 'C': A'*x = b (Conjugate transpose = Transpose) */ /* DIAG (input) CHARACTER*1 */ /* Specifies whether or not the matrix A is unit triangular. */ /* = 'N': Non-unit triangular */ /* = 'U': Unit triangular */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* NRHS (input) INTEGER */ /* The number of right hand sides, i.e., the number of columns */ /* of the matrices X and B. NRHS >= 0. */ /* AP (input) DOUBLE PRECISION 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((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */ /* if UPLO = 'L', */ /* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */ /* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */ /* The computed solution vectors for the system of linear */ /* equations. */ /* LDX (input) INTEGER */ /* The leading dimension of the array X. LDX >= max(1,N). */ /* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ /* The right hand side vectors for the system of linear */ /* equations. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= max(1,N). */ /* WORK (workspace) DOUBLE PRECISION array, dimension (N) */ /* RESID (output) DOUBLE PRECISION */ /* The maximum over the number of right hand sides of */ /* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Quick exit if N = 0 or NRHS = 0 */ /* Parameter adjustments */ --ap; x_dim1 = *ldx; x_offset = 1 + x_dim1; x -= x_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; --work; /* Function Body */ if (*n <= 0 || *nrhs <= 0) { *resid = 0.; return 0; } /* Compute the 1-norm of A or A'. */ if (lsame_(trans, "N")) { anorm = dlantp_("1", uplo, diag, n, &ap[1], &work[1]); } else { anorm = dlantp_("I", uplo, diag, n, &ap[1], &work[1]); } /* Exit with RESID = 1/EPS if ANORM = 0. */ eps = dlamch_("Epsilon"); if (anorm <= 0.) { *resid = 1. / eps; return 0; } /* Compute the maximum over the number of right hand sides of */ /* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */ *resid = 0.; i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { dcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1); dtpmv_(uplo, trans, diag, n, &ap[1], &work[1], &c__1); daxpy_(n, &c_b10, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1); bnorm = dasum_(n, &work[1], &c__1); xnorm = dasum_(n, &x[j * x_dim1 + 1], &c__1); if (xnorm <= 0.) { *resid = 1. / eps; } else { /* Computing MAX */ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps; *resid = max(d__1,d__2); } /* L10: */ } return 0; /* End of DTPT02 */ } /* dtpt02_ */