int f2c_ctpmv(char* uplo, char* trans, char* diag, integer* N, complex* Ap, complex* X, integer* incX) { ctpmv_(uplo, trans, diag, N, Ap, X, incX); return 0; }
/* Subroutine */ int ctpt02_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, complex *ap, complex *x, integer *ldx, complex *b, integer *ldb, complex *work, real *rwork, real *resid) { /* System generated locals */ integer b_dim1, b_offset, x_dim1, x_offset, i__1; real r__1, r__2; /* Local variables */ static integer j; extern logical lsame_(char *, char *); static real anorm, bnorm; extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer *, complex *, integer *), ctpmv_(char *, char *, char *, integer *, complex *, complex *, integer *); static real xnorm; extern doublereal slamch_(char *), clantp_(char *, char *, char *, integer *, complex *, real *), scasum_( integer *, complex *, integer *); static real eps; #define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1 #define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)] #define x_subscr(a_1,a_2) (a_2)*x_dim1 + a_1 #define x_ref(a_1,a_2) x[x_subscr(a_1,a_2)] /* -- 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 ======= CTPT02 computes the residual for the computed solution to a triangular system of linear equations A*x = b, A**T *x = b, or A**H *x = b, when the triangular matrix A is stored in packed format. Here A**T denotes the transpose of A, A**H denotes the conjugate 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 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, A**T, or A**H, 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**T *x = b (Transpose) = 'C': A**H *x = b (Conjugate 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) COMPLEX array, dimension (N*(N+1)/2) The upper or lower triangular matrix A, packed columnwise in a linear array. The j-th column of A is stored in the array AP as follows: if UPLO = 'U', AP((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) COMPLEX 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) COMPLEX array, dimension (LDB,NRHS) The right hand side vectors for the system of linear equations. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,N). WORK (workspace) COMPLEX array, dimension (N) RWORK (workspace) REAL array, dimension (N) RESID (output) REAL The maximum over the number of right hand sides of norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). ===================================================================== Quick exit if N = 0 or NRHS = 0 Parameter adjustments */ --ap; x_dim1 = *ldx; x_offset = 1 + x_dim1 * 1; x -= x_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; --work; --rwork; /* Function Body */ if (*n <= 0 || *nrhs <= 0) { *resid = 0.f; return 0; } /* Compute the 1-norm of A or A**H. */ if (lsame_(trans, "N")) { anorm = clantp_("1", uplo, diag, n, &ap[1], &rwork[1]); } else { anorm = clantp_("I", uplo, diag, n, &ap[1], &rwork[1]); } /* Exit with RESID = 1/EPS if ANORM = 0. */ eps = slamch_("Epsilon"); if (anorm <= 0.f) { *resid = 1.f / 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.f; i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { ccopy_(n, &x_ref(1, j), &c__1, &work[1], &c__1); ctpmv_(uplo, trans, diag, n, &ap[1], &work[1], &c__1); caxpy_(n, &c_b12, &b_ref(1, j), &c__1, &work[1], &c__1); bnorm = scasum_(n, &work[1], &c__1); xnorm = scasum_(n, &x_ref(1, j), &c__1); if (xnorm <= 0.f) { *resid = 1.f / eps; } else { /* Computing MAX */ r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps; *resid = dmax(r__1,r__2); } /* L10: */ } return 0; /* End of CTPT02 */ } /* ctpt02_ */
/* Subroutine */ int ctprfs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, complex *ap, complex *b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork, integer *info) { /* System generated locals */ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5; real r__1, r__2, r__3, r__4; complex q__1; /* Builtin functions */ double r_imag(complex *); /* Local variables */ integer i__, j, k; real s; integer kc; real xk; integer nz; real eps; integer kase; real safe1, safe2; extern logical lsame_(char *, char *); integer isave[3]; extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer *, complex *, integer *), ctpmv_(char *, char *, char *, integer *, complex *, complex *, integer *); logical upper; extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *, complex *, complex *, integer *), clacn2_( integer *, complex *, complex *, real *, integer *, integer *); extern doublereal slamch_(char *); real safmin; extern /* Subroutine */ int xerbla_(char *, integer *); logical notran; char transn[1], transt[1]; logical nounit; real lstres; /* -- LAPACK routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CTPRFS provides error bounds and backward error estimates for the */ /* solution to a system of linear equations with a triangular packed */ /* coefficient matrix. */ /* The solution matrix X must be computed by CTPTRS or some other */ /* means before entering this routine. CTPRFS does not do iterative */ /* refinement because doing so cannot improve the backward error. */ /* Arguments */ /* ========= */ /* UPLO (input) CHARACTER*1 */ /* = 'U': A is upper triangular; */ /* = 'L': A is lower triangular. */ /* TRANS (input) CHARACTER*1 */ /* Specifies the form of the system of equations: */ /* = 'N': A * X = B (No transpose) */ /* = 'T': A**T * X = B (Transpose) */ /* = 'C': A**H * X = B (Conjugate transpose) */ /* DIAG (input) CHARACTER*1 */ /* = 'N': A is non-unit triangular; */ /* = 'U': A is unit triangular. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* NRHS (input) INTEGER */ /* The number of right hand sides, i.e., the number of columns */ /* of the matrices B and X. NRHS >= 0. */ /* AP (input) COMPLEX array, dimension (N*(N+1)/2) */ /* The upper or lower triangular matrix A, packed columnwise in */ /* a linear array. The j-th column of A is stored in the array */ /* AP as follows: */ /* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ /* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ /* If DIAG = 'U', the diagonal elements of A are not referenced */ /* and are assumed to be 1. */ /* B (input) COMPLEX array, dimension (LDB,NRHS) */ /* The right hand side matrix B. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= max(1,N). */ /* X (input) COMPLEX array, dimension (LDX,NRHS) */ /* The solution matrix X. */ /* LDX (input) INTEGER */ /* The leading dimension of the array X. LDX >= max(1,N). */ /* FERR (output) REAL array, dimension (NRHS) */ /* The estimated forward error bound for each solution vector */ /* X(j) (the j-th column of the solution matrix X). */ /* If XTRUE is the true solution corresponding to X(j), FERR(j) */ /* is an estimated upper bound for the magnitude of the largest */ /* element in (X(j) - XTRUE) divided by the magnitude of the */ /* largest element in X(j). The estimate is as reliable as */ /* the estimate for RCOND, and is almost always a slight */ /* overestimate of the true error. */ /* BERR (output) REAL array, dimension (NRHS) */ /* The componentwise relative backward error of each solution */ /* vector X(j) (i.e., the smallest relative change in */ /* any element of A or B that makes X(j) an exact solution). */ /* WORK (workspace) COMPLEX array, dimension (2*N) */ /* RWORK (workspace) REAL array, dimension (N) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Statement Functions .. */ /* .. */ /* .. Statement Function definitions .. */ /* .. */ /* .. 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; --rwork; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); notran = lsame_(trans, "N"); nounit = lsame_(diag, "N"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (! notran && ! lsame_(trans, "T") && ! lsame_(trans, "C")) { *info = -2; } else if (! nounit && ! lsame_(diag, "U")) { *info = -3; } else if (*n < 0) { *info = -4; } else if (*nrhs < 0) { *info = -5; } else if (*ldb < max(1,*n)) { *info = -8; } else if (*ldx < max(1,*n)) { *info = -10; } if (*info != 0) { i__1 = -(*info); xerbla_("CTPRFS", &i__1); return 0; } /* Quick return if possible */ if (*n == 0 || *nrhs == 0) { i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { ferr[j] = 0.f; berr[j] = 0.f; /* L10: */ } return 0; } if (notran) { *(unsigned char *)transn = 'N'; *(unsigned char *)transt = 'C'; } else { *(unsigned char *)transn = 'C'; *(unsigned char *)transt = 'N'; } /* NZ = maximum number of nonzero elements in each row of A, plus 1 */ nz = *n + 1; eps = slamch_("Epsilon"); safmin = slamch_("Safe minimum"); safe1 = nz * safmin; safe2 = safe1 / eps; /* Do for each right hand side */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { /* Compute residual R = B - op(A) * X, */ /* where op(A) = A, A**T, or A**H, depending on TRANS. */ ccopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1); ctpmv_(uplo, trans, diag, n, &ap[1], &work[1], &c__1); q__1.r = -1.f, q__1.i = -0.f; caxpy_(n, &q__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1); /* Compute componentwise relative backward error from formula */ /* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ /* where abs(Z) is the componentwise absolute value of the matrix */ /* or vector Z. If the i-th component of the denominator is less */ /* than SAFE2, then SAFE1 is added to the i-th components of the */ /* numerator and denominator before dividing. */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + j * b_dim1; rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[ i__ + j * b_dim1]), dabs(r__2)); /* L20: */ } if (notran) { /* Compute abs(A)*abs(X) + abs(B). */ if (upper) { kc = 1; if (nounit) { i__2 = *n; for (k = 1; k <= i__2; ++k) { i__3 = k + j * x_dim1; xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(& x[k + j * x_dim1]), dabs(r__2)); i__3 = k; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = kc + i__ - 1; rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + ( r__2 = r_imag(&ap[kc + i__ - 1]), dabs( r__2))) * xk; /* L30: */ } kc += k; /* L40: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { i__3 = k + j * x_dim1; xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(& x[k + j * x_dim1]), dabs(r__2)); i__3 = k - 1; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = kc + i__ - 1; rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + ( r__2 = r_imag(&ap[kc + i__ - 1]), dabs( r__2))) * xk; /* L50: */ } rwork[k] += xk; kc += k; /* L60: */ } } } else { kc = 1; if (nounit) { i__2 = *n; for (k = 1; k <= i__2; ++k) { i__3 = k + j * x_dim1; xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(& x[k + j * x_dim1]), dabs(r__2)); i__3 = *n; for (i__ = k; i__ <= i__3; ++i__) { i__4 = kc + i__ - k; rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + ( r__2 = r_imag(&ap[kc + i__ - k]), dabs( r__2))) * xk; /* L70: */ } kc = kc + *n - k + 1; /* L80: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { i__3 = k + j * x_dim1; xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(& x[k + j * x_dim1]), dabs(r__2)); i__3 = *n; for (i__ = k + 1; i__ <= i__3; ++i__) { i__4 = kc + i__ - k; rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + ( r__2 = r_imag(&ap[kc + i__ - k]), dabs( r__2))) * xk; /* L90: */ } rwork[k] += xk; kc = kc + *n - k + 1; /* L100: */ } } } } else { /* Compute abs(A**H)*abs(X) + abs(B). */ if (upper) { kc = 1; if (nounit) { i__2 = *n; for (k = 1; k <= i__2; ++k) { s = 0.f; i__3 = k; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = kc + i__ - 1; i__5 = i__ + j * x_dim1; s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&ap[kc + i__ - 1]), dabs(r__2))) * ((r__3 = x[i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[i__ + j * x_dim1]), dabs(r__4))) ; /* L110: */ } rwork[k] += s; kc += k; /* L120: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { i__3 = k + j * x_dim1; s = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(& x[k + j * x_dim1]), dabs(r__2)); i__3 = k - 1; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = kc + i__ - 1; i__5 = i__ + j * x_dim1; s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&ap[kc + i__ - 1]), dabs(r__2))) * ((r__3 = x[i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[i__ + j * x_dim1]), dabs(r__4))) ; /* L130: */ } rwork[k] += s; kc += k; /* L140: */ } } } else { kc = 1; if (nounit) { i__2 = *n; for (k = 1; k <= i__2; ++k) { s = 0.f; i__3 = *n; for (i__ = k; i__ <= i__3; ++i__) { i__4 = kc + i__ - k; i__5 = i__ + j * x_dim1; s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&ap[kc + i__ - k]), dabs(r__2))) * ((r__3 = x[i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[i__ + j * x_dim1]), dabs(r__4))) ; /* L150: */ } rwork[k] += s; kc = kc + *n - k + 1; /* L160: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { i__3 = k + j * x_dim1; s = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(& x[k + j * x_dim1]), dabs(r__2)); i__3 = *n; for (i__ = k + 1; i__ <= i__3; ++i__) { i__4 = kc + i__ - k; i__5 = i__ + j * x_dim1; s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&ap[kc + i__ - k]), dabs(r__2))) * ((r__3 = x[i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[i__ + j * x_dim1]), dabs(r__4))) ; /* L170: */ } rwork[k] += s; kc = kc + *n - k + 1; /* L180: */ } } } } s = 0.f; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { if (rwork[i__] > safe2) { /* Computing MAX */ i__3 = i__; r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 = r_imag(&work[i__]), dabs(r__2))) / rwork[i__]; s = dmax(r__3,r__4); } else { /* Computing MAX */ i__3 = i__; r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 = r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__] + safe1); s = dmax(r__3,r__4); } /* L190: */ } berr[j] = s; /* Bound error from formula */ /* norm(X - XTRUE) / norm(X) .le. FERR = */ /* norm( abs(inv(op(A)))* */ /* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ /* where */ /* norm(Z) is the magnitude of the largest component of Z */ /* inv(op(A)) is the inverse of op(A) */ /* abs(Z) is the componentwise absolute value of the matrix or */ /* vector Z */ /* NZ is the maximum number of nonzeros in any row of A, plus 1 */ /* EPS is machine epsilon */ /* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ /* is incremented by SAFE1 if the i-th component of */ /* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ /* Use CLACN2 to estimate the infinity-norm of the matrix */ /* inv(op(A)) * diag(W), */ /* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { if (rwork[i__] > safe2) { i__3 = i__; rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 = r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[ i__]; } else { i__3 = i__; rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 = r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[ i__] + safe1; } /* L200: */ } kase = 0; L210: clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave); if (kase != 0) { if (kase == 1) { /* Multiply by diag(W)*inv(op(A)**H). */ ctpsv_(uplo, transt, diag, n, &ap[1], &work[1], &c__1); i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__; i__4 = i__; i__5 = i__; q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4] * work[i__5].i; work[i__3].r = q__1.r, work[i__3].i = q__1.i; /* L220: */ } } else { /* Multiply by inv(op(A))*diag(W). */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__; i__4 = i__; i__5 = i__; q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4] * work[i__5].i; work[i__3].r = q__1.r, work[i__3].i = q__1.i; /* L230: */ } ctpsv_(uplo, transn, diag, n, &ap[1], &work[1], &c__1); } goto L210; } /* Normalize error. */ lstres = 0.f; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { /* Computing MAX */ i__3 = i__ + j * x_dim1; r__3 = lstres, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[i__ + j * x_dim1]), dabs(r__2)); lstres = dmax(r__3,r__4); /* L240: */ } if (lstres != 0.f) { ferr[j] /= lstres; } /* L250: */ } return 0; /* End of CTPRFS */ } /* ctprfs_ */
void ctpmv(char uplo, char transa, char diag, int n, complex *ap, complex *x, int incx) { ctpmv_( &uplo, &transa, &diag, &n, ap, x, &incx); }
/* Subroutine */ int chpgst_(integer *itype, char *uplo, integer *n, complex * ap, complex *bp, integer *info, ftnlen uplo_len) { /* System generated locals */ integer i__1, i__2, i__3, i__4; real r__1, r__2; complex q__1, q__2, q__3; /* Local variables */ static integer j, k, j1, k1, jj, kk; static complex ct; static real ajj; static integer j1j1; static real akk; static integer k1k1; static real bjj, bkk; extern /* Subroutine */ int chpr2_(char *, integer *, complex *, complex * , integer *, complex *, integer *, complex *, ftnlen); extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer *, complex *, integer *); extern logical lsame_(char *, char *, ftnlen, ftnlen); extern /* Subroutine */ int chpmv_(char *, integer *, complex *, complex * , complex *, integer *, complex *, complex *, integer *, ftnlen), caxpy_(integer *, complex *, complex *, integer *, complex *, integer *), ctpmv_(char *, char *, char *, integer *, complex *, complex *, integer *, ftnlen, ftnlen, ftnlen); static logical upper; extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *, complex *, complex *, integer *, ftnlen, ftnlen, ftnlen), csscal_( integer *, real *, complex *, integer *), xerbla_(char *, integer *, ftnlen); /* -- LAPACK routine (version 3.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* September 30, 1994 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CHPGST reduces a complex Hermitian-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**H)*A*inv(U) or inv(L)*A*inv(L**H) */ /* 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**H or L**H*A*L. */ /* B must have been previously factorized as U**H*U or L*L**H by CPPTRF. */ /* Arguments */ /* ========= */ /* ITYPE (input) INTEGER */ /* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H); */ /* = 2 or 3: compute U*A*U**H or L**H*A*L. */ /* UPLO (input) CHARACTER */ /* = 'U': Upper triangle of A is stored and B is factored as */ /* U**H*U; */ /* = 'L': Lower triangle of A is stored and B is factored as */ /* L*L**H. */ /* N (input) INTEGER */ /* The order of the matrices A and B. N >= 0. */ /* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */ /* On entry, the upper or lower triangle of the Hermitian 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) COMPLEX 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 CPPTRF. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ --bp; --ap; /* Function Body */ *info = 0; upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1); if (*itype < 1 || *itype > 3) { *info = -1; } else if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) { *info = -2; } else if (*n < 0) { *info = -3; } if (*info != 0) { i__1 = -(*info); xerbla_("CHPGST", &i__1, (ftnlen)6); 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 */ i__2 = jj; i__3 = jj; r__1 = ap[i__3].r; ap[i__2].r = r__1, ap[i__2].i = 0.f; i__2 = jj; bjj = bp[i__2].r; ctpsv_(uplo, "Conjugate transpose", "Non-unit", &j, &bp[1], & ap[j1], &c__1, (ftnlen)1, (ftnlen)19, (ftnlen)8); i__2 = j - 1; q__1.r = -1.f, q__1.i = -0.f; chpmv_(uplo, &i__2, &q__1, &ap[1], &bp[j1], &c__1, &c_b1, &ap[ j1], &c__1, (ftnlen)1); i__2 = j - 1; r__1 = 1.f / bjj; csscal_(&i__2, &r__1, &ap[j1], &c__1); i__2 = jj; i__3 = jj; i__4 = j - 1; cdotc_(&q__3, &i__4, &ap[j1], &c__1, &bp[j1], &c__1); q__2.r = ap[i__3].r - q__3.r, q__2.i = ap[i__3].i - q__3.i; q__1.r = q__2.r / bjj, q__1.i = q__2.i / bjj; ap[i__2].r = q__1.r, ap[i__2].i = q__1.i; /* 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) */ i__2 = kk; akk = ap[i__2].r; i__2 = kk; bkk = bp[i__2].r; /* Computing 2nd power */ r__1 = bkk; akk /= r__1 * r__1; i__2 = kk; ap[i__2].r = akk, ap[i__2].i = 0.f; if (k < *n) { i__2 = *n - k; r__1 = 1.f / bkk; csscal_(&i__2, &r__1, &ap[kk + 1], &c__1); r__1 = akk * -.5f; ct.r = r__1, ct.i = 0.f; i__2 = *n - k; caxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) ; i__2 = *n - k; q__1.r = -1.f, q__1.i = -0.f; chpr2_(uplo, &i__2, &q__1, &ap[kk + 1], &c__1, &bp[kk + 1] , &c__1, &ap[k1k1], (ftnlen)1); i__2 = *n - k; caxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) ; i__2 = *n - k; ctpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1], &ap[kk + 1], &c__1, (ftnlen)1, (ftnlen)12, ( ftnlen)8); } 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) */ i__2 = kk; akk = ap[i__2].r; i__2 = kk; bkk = bp[i__2].r; i__2 = k - 1; ctpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[ k1], &c__1, (ftnlen)1, (ftnlen)12, (ftnlen)8); r__1 = akk * .5f; ct.r = r__1, ct.i = 0.f; i__2 = k - 1; caxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1); i__2 = k - 1; chpr2_(uplo, &i__2, &c_b1, &ap[k1], &c__1, &bp[k1], &c__1, & ap[1], (ftnlen)1); i__2 = k - 1; caxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1); i__2 = k - 1; csscal_(&i__2, &bkk, &ap[k1], &c__1); i__2 = kk; /* Computing 2nd power */ r__2 = bkk; r__1 = akk * (r__2 * r__2); ap[i__2].r = r__1, ap[i__2].i = 0.f; /* 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 */ i__2 = jj; ajj = ap[i__2].r; i__2 = jj; bjj = bp[i__2].r; i__2 = jj; r__1 = ajj * bjj; i__3 = *n - j; cdotc_(&q__2, &i__3, &ap[jj + 1], &c__1, &bp[jj + 1], &c__1); q__1.r = r__1 + q__2.r, q__1.i = q__2.i; ap[i__2].r = q__1.r, ap[i__2].i = q__1.i; i__2 = *n - j; csscal_(&i__2, &bjj, &ap[jj + 1], &c__1); i__2 = *n - j; chpmv_(uplo, &i__2, &c_b1, &ap[j1j1], &bp[jj + 1], &c__1, & c_b1, &ap[jj + 1], &c__1, (ftnlen)1); i__2 = *n - j + 1; ctpmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &bp[jj] , &ap[jj], &c__1, (ftnlen)1, (ftnlen)19, (ftnlen)8); jj = j1j1; /* L40: */ } } } return 0; /* End of CHPGST */ } /* chpgst_ */
/* Subroutine */ int chpgv_(integer *itype, char *jobz, char *uplo, integer * n, complex *ap, complex *bp, real *w, complex *z__, integer *ldz, complex *work, real *rwork, integer *info, ftnlen jobz_len, ftnlen uplo_len) { /* System generated locals */ integer z_dim1, z_offset, i__1; /* Local variables */ static integer j, neig; extern logical lsame_(char *, char *, ftnlen, ftnlen); extern /* Subroutine */ int chpev_(char *, char *, integer *, complex *, real *, complex *, integer *, complex *, real *, integer *, ftnlen, ftnlen); static char trans[1]; extern /* Subroutine */ int ctpmv_(char *, char *, char *, integer *, complex *, complex *, integer *, ftnlen, ftnlen, ftnlen); static logical upper; extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *, complex *, complex *, integer *, ftnlen, ftnlen, ftnlen); static logical wantz; extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), chpgst_( integer *, char *, integer *, complex *, complex *, integer *, ftnlen), cpptrf_(char *, integer *, complex *, integer *, ftnlen); /* -- 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 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CHPGV computes all the eigenvalues and, optionally, the eigenvectors */ /* of a complex generalized Hermitian-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 Hermitian, 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) COMPLEX array, dimension (N*(N+1)/2) */ /* On entry, the upper or lower triangle of the Hermitian 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) COMPLEX array, dimension (N*(N+1)/2) */ /* On entry, the upper or lower triangle of the Hermitian 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**H*U or B = L*L**H, in the same storage */ /* format as B. */ /* W (output) REAL array, dimension (N) */ /* If INFO = 0, the eigenvalues in ascending order. */ /* Z (output) COMPLEX 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**H*B*Z = I; */ /* if ITYPE = 3, Z**H*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) COMPLEX array, dimension (max(1, 2*N-1)) */ /* RWORK (workspace) REAL array, dimension (max(1, 3*N-2)) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* > 0: CPPTRF or CHPEV returned an error code: */ /* <= N: if INFO = i, CHPEV failed to converge; */ /* i off-diagonal elements of an intermediate */ /* tridiagonal form did not convergeto 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. */ /* ===================================================================== */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ --ap; --bp; --w; z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --work; --rwork; /* Function Body */ wantz = lsame_(jobz, "V", (ftnlen)1, (ftnlen)1); upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1); *info = 0; if (*itype < 0 || *itype > 3) { *info = -1; } else if (! (wantz || lsame_(jobz, "N", (ftnlen)1, (ftnlen)1))) { *info = -2; } else if (! (upper || lsame_(uplo, "L", (ftnlen)1, (ftnlen)1))) { *info = -3; } else if (*n < 0) { *info = -4; } else if (*ldz < 1 || wantz && *ldz < *n) { *info = -9; } if (*info != 0) { i__1 = -(*info); xerbla_("CHPGV ", &i__1, (ftnlen)6); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Form a Cholesky factorization of B. */ cpptrf_(uplo, n, &bp[1], info, (ftnlen)1); if (*info != 0) { *info = *n + *info; return 0; } /* Transform problem to standard eigenvalue problem and solve. */ chpgst_(itype, uplo, n, &ap[1], &bp[1], info, (ftnlen)1); chpev_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1], & rwork[1], info, (ftnlen)1, (ftnlen)1); 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 = 'C'; } i__1 = neig; for (j = 1; j <= i__1; ++j) { ctpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + 1], &c__1, (ftnlen)1, (ftnlen)1, (ftnlen)8); /* L10: */ } } else if (*itype == 3) { /* For B*A*x=(lambda)*x; */ /* backtransform eigenvectors: x = L*y or U'*y */ if (upper) { *(unsigned char *)trans = 'C'; } else { *(unsigned char *)trans = 'N'; } i__1 = neig; for (j = 1; j <= i__1; ++j) { ctpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + 1], &c__1, (ftnlen)1, (ftnlen)1, (ftnlen)8); /* L20: */ } } } return 0; /* End of CHPGV */ } /* chpgv_ */
/* Subroutine */ int chpgvx_(integer *itype, char *jobz, char *range, char * uplo, integer *n, complex *ap, complex *bp, real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *m, real *w, complex * z__, integer *ldz, complex *work, real *rwork, integer *iwork, integer *ifail, integer *info) { /* System generated locals */ integer z_dim1, z_offset, i__1; /* Local variables */ integer j; extern logical lsame_(char *, char *); char trans[1]; extern /* Subroutine */ int ctpmv_(char *, char *, char *, integer *, complex *, complex *, integer *); logical upper; extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *, complex *, complex *, integer *); logical wantz, alleig, indeig, valeig; extern /* Subroutine */ int xerbla_(char *, integer *), chpgst_( integer *, char *, integer *, complex *, complex *, integer *), chpevx_(char *, char *, char *, integer *, complex *, real *, real *, integer *, integer *, real *, integer *, real *, complex *, integer *, complex *, real *, integer *, integer *, integer *), cpptrf_(char *, integer *, complex *, integer *); /* -- LAPACK driver 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 .. */ /* .. */ /* ===================================================================== */ /* .. 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; --rwork; --iwork; --ifail; /* Function Body */ wantz = lsame_(jobz, "V"); upper = lsame_(uplo, "U"); 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_("CHPGVX", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Form a Cholesky factorization of B. */ cpptrf_(uplo, n, &bp[1], info); if (*info != 0) { *info = *n + *info; return 0; } /* Transform problem to standard eigenvalue problem and solve. */ chpgst_(itype, uplo, n, &ap[1], &bp[1], info); chpevx_(jobz, range, uplo, n, &ap[1], vl, vu, il, iu, abstol, m, &w[1], & z__[z_offset], ldz, &work[1], &rwork[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)**H*y or inv(U)*y */ if (upper) { *(unsigned char *)trans = 'N'; } else { *(unsigned char *)trans = 'C'; } i__1 = *m; for (j = 1; j <= i__1; ++j) { ctpsv_(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**H*y */ if (upper) { *(unsigned char *)trans = 'C'; } else { *(unsigned char *)trans = 'N'; } i__1 = *m; for (j = 1; j <= i__1; ++j) { ctpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + 1], &c__1); /* L20: */ } } } return 0; /* End of CHPGVX */ }
void cblas_ctpmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, const integer N, const void *Ap, void *X, const integer incX) { char TA; char UL; char DI; #ifdef F77_CHAR F77_CHAR F77_TA, F77_UL, F77_DI; #else #define F77_TA &TA #define F77_UL &UL #define F77_DI &DI #endif #define F77_N N #define F77_incX incX integer n, i=0, tincX; float *st=0,*x=(float *)X; extern integer CBLAS_CallFromC; extern integer RowMajorStrg; RowMajorStrg = 0; CBLAS_CallFromC = 1; if (order == CblasColMajor) { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; else { cblas_xerbla(2, "cblas_ctpmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; else { cblas_xerbla(3, "cblas_ctpmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; else { cblas_xerbla(4, "cblas_ctpmv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); F77_TA = C2F_CHAR(&TA); F77_DI = C2F_CHAR(&DI); #endif ctpmv_( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X, &F77_incX); } else if (order == CblasRowMajor) { RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; else { cblas_xerbla(2, "cblas_ctpmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } if (TransA == CblasNoTrans) TA = 'T'; else if (TransA == CblasTrans) TA = 'N'; else if (TransA == CblasConjTrans) { TA = 'N'; if ( N > 0) { if(incX > 0) tincX = incX; else tincX = -incX; i = tincX << 1; n = i * N; x++; st = x + n; do { *x = -(*x); x += i; } while (x != st); x -= n; } } else { cblas_xerbla(3, "cblas_ctpmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; else { cblas_xerbla(4, "cblas_ctpmv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); F77_TA = C2F_CHAR(&TA); F77_DI = C2F_CHAR(&DI); #endif ctpmv_( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X,&F77_incX); if (TransA == CblasConjTrans) { if (N > 0) { do { *x = -(*x); x += i; } while (x != st); } } } else cblas_xerbla(1, "cblas_ctpmv", "Illegal Order setting, %d\n", order); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; }
/* Subroutine */ int clarhs_(char *path, char *xtype, char *uplo, char *trans, integer *m, integer *n, integer *kl, integer *ku, integer *nrhs, complex *a, integer *lda, complex *x, integer *ldx, complex *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; /* Local variables */ integer j; char c1[1], c2[2]; integer mb, nx; logical gen, tri, qrs, sym, band; char diag[1]; logical tran; extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *), chemm_(char *, char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *), cgbmv_(char *, integer *, integer *, integer *, integer * , complex *, complex *, integer *, complex *, integer *, complex * , complex *, integer *), chbmv_(char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *); extern /* Subroutine */ int csbmv_(char *, integer *, integer *, complex * , complex *, integer *, complex *, integer *, complex *, complex * , integer *), ctbmv_(char *, char *, char *, integer *, integer *, complex *, integer *, complex *, integer *), chpmv_(char *, integer *, complex *, complex *, complex *, integer *, complex *, complex *, integer *), ctrmm_(char *, char *, char *, char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *), cspmv_(char *, integer *, complex *, complex *, complex *, integer *, complex *, complex *, integer *), csymm_(char *, char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *), ctpmv_(char *, char *, char *, integer *, complex *, complex *, integer *), clacpy_(char *, integer *, integer *, complex *, integer *, complex *, integer *), xerbla_(char *, integer *); extern logical lsamen_(integer *, char *, char *); extern /* Subroutine */ int clarnv_(integer *, integer *, integer *, complex *); logical notran; /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CLARHS 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, A**T (transpose of A), or A**H (conjugate */ /* transpose of A). */ /* Arguments */ /* ========= */ /* PATH (input) CHARACTER*3 */ /* The type of the complex matrix A. PATH may be given in any */ /* combination of upper and lower case. Valid paths include */ /* xGE: General m x n matrix */ /* xGB: General banded matrix */ /* xPO: Hermitian positive definite, 2-D storage */ /* xPP: Hermitian positive definite packed */ /* xPB: Hermitian positive definite banded */ /* xHE: Hermitian indefinite, 2-D storage */ /* xHP: Hermitian indefinite packed */ /* xHB: Hermitian indefinite 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 */ /* Used only if A is symmetric or triangular; specifies whether */ /* the upper or lower triangular part of the matrix A is stored. */ /* = 'U': Upper triangular */ /* = 'L': Lower triangular */ /* TRANS (input) CHARACTER*1 */ /* Used only if A is nonsymmetric; specifies the operation */ /* applied to the matrix A. */ /* = 'N': B := A * X */ /* = 'T': B := A**T * X */ /* = 'C': B := A**H * X */ /* M (input) INTEGER */ /* The number of rows of the matrix A. M >= 0. */ /* N (input) INTEGER */ /* The number of columns of the matrix A. N >= 0. */ /* 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) COMPLEX 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) COMPLEX 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) COMPLEX 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 */ /* CLATMS). Modified on exit. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; x_dim1 = *ldx; x_offset = 1 + x_dim1; x -= x_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1; 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") || lsame_(path + 1, "H"); tri = lsame_(path + 1, "T"); band = lsame_(path + 2, "B"); if (! lsame_(c1, "Complex 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_("CLARHS", &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) { clarnv_(&c__2, &iseed[1], n, &x[j * x_dim1 + 1]); /* 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 */ cgemm_(trans, "N", &mb, nrhs, &nx, &c_b1, &a[a_offset], lda, &x[ x_offset], ldx, &c_b2, &b[b_offset], ldb); } else if (lsamen_(&c__2, c2, "PO") || lsamen_(& c__2, c2, "HE")) { /* Hermitian matrix, 2-D storage */ chemm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset], ldx, &c_b2, &b[b_offset], ldb); } else if (lsamen_(&c__2, c2, "SY")) { /* Symmetric matrix, 2-D storage */ csymm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset], ldx, &c_b2, &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) { cgbmv_(trans, m, n, kl, ku, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1); /* L20: */ } } else if (lsamen_(&c__2, c2, "PB") || lsamen_(& c__2, c2, "HB")) { /* Hermitian matrix, band storage */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { chbmv_(uplo, n, kl, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1); /* L30: */ } } else if (lsamen_(&c__2, c2, "SB")) { /* Symmetric matrix, band storage */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { csbmv_(uplo, n, kl, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1); /* L40: */ } } else if (lsamen_(&c__2, c2, "PP") || lsamen_(& c__2, c2, "HP")) { /* Hermitian matrix, packed storage */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { chpmv_(uplo, n, &c_b1, &a[a_offset], &x[j * x_dim1 + 1], &c__1, & c_b2, &b[j * b_dim1 + 1], &c__1); /* L50: */ } } else if (lsamen_(&c__2, c2, "SP")) { /* Symmetric matrix, packed storage */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { cspmv_(uplo, n, &c_b1, &a[a_offset], &x[j * x_dim1 + 1], &c__1, & c_b2, &b[j * b_dim1 + 1], &c__1); /* L60: */ } } else if (lsamen_(&c__2, c2, "TR")) { /* Triangular matrix. Note that for triangular matrices, */ /* KU = 1 => non-unit triangular */ /* KU = 2 => unit triangular */ clacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb); if (*ku == 2) { *(unsigned char *)diag = 'U'; } else { *(unsigned char *)diag = 'N'; } ctrmm_("Left", uplo, trans, diag, n, nrhs, &c_b1, &a[a_offset], lda, & b[b_offset], ldb); } else if (lsamen_(&c__2, c2, "TP")) { /* Triangular matrix, packed storage */ clacpy_("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) { ctpmv_(uplo, trans, diag, n, &a[a_offset], &b[j * b_dim1 + 1], & c__1); /* L70: */ } } else if (lsamen_(&c__2, c2, "TB")) { /* Triangular matrix, banded storage */ clacpy_("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) { ctbmv_(uplo, trans, diag, n, kl, &a[a_offset], lda, &b[j * b_dim1 + 1], &c__1); /* L80: */ } } else { /* If none of the above, set INFO = -1 and return */ *info = -1; i__1 = -(*info); xerbla_("CLARHS", &i__1); } return 0; /* End of CLARHS */ } /* clarhs_ */
/* Subroutine */ int ctpt01_(char *uplo, char *diag, integer *n, complex *ap, complex *ainvp, real *rcond, real *rwork, real *resid) { /* System generated locals */ integer i__1, i__2, i__3; complex q__1; /* Local variables */ integer j, jc; real eps; extern logical lsame_(char *, char *); real anorm; logical unitd; extern /* Subroutine */ int ctpmv_(char *, char *, char *, integer *, complex *, complex *, integer *); extern doublereal slamch_(char *), clantp_(char *, char *, char *, integer *, complex *, real *); real ainvnm; /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CTPT01 computes the residual for a triangular matrix A times its */ /* inverse when A is stored in packed format: */ /* RESID = norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS ), */ /* where 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 */ /* 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. */ /* AP (input) COMPLEX array, dimension (N*(N+1)/2) */ /* The original 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. */ /* AINVP (input) COMPLEX array, dimension (N*(N+1)/2) */ /* On entry, the (triangular) inverse of the matrix A, packed */ /* columnwise in a linear array as in AP. */ /* On exit, the contents of AINVP are destroyed. */ /* RCOND (output) REAL */ /* The reciprocal condition number of A, computed as */ /* 1/(norm(A) * norm(AINV)). */ /* RWORK (workspace) REAL array, dimension (N) */ /* RESID (output) REAL */ /* norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS ) */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Quick exit if N = 0. */ /* Parameter adjustments */ --rwork; --ainvp; --ap; /* Function Body */ if (*n <= 0) { *rcond = 1.f; *resid = 0.f; return 0; } /* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */ eps = slamch_("Epsilon"); anorm = clantp_("1", uplo, diag, n, &ap[1], &rwork[1]); ainvnm = clantp_("1", uplo, diag, n, &ainvp[1], &rwork[1]); if (anorm <= 0.f || ainvnm <= 0.f) { *rcond = 0.f; *resid = 1.f / eps; return 0; } *rcond = 1.f / anorm / ainvnm; /* Compute A * AINV, overwriting AINV. */ unitd = lsame_(diag, "U"); if (lsame_(uplo, "U")) { jc = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { if (unitd) { i__2 = jc + j - 1; ainvp[i__2].r = 1.f, ainvp[i__2].i = 0.f; } /* Form the j-th column of A*AINV. */ ctpmv_("Upper", "No transpose", diag, &j, &ap[1], &ainvp[jc], & c__1); /* Subtract 1 from the diagonal to form A*AINV - I. */ i__2 = jc + j - 1; i__3 = jc + j - 1; q__1.r = ainvp[i__3].r - 1.f, q__1.i = ainvp[i__3].i; ainvp[i__2].r = q__1.r, ainvp[i__2].i = q__1.i; jc += j; /* L10: */ } } else { jc = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { if (unitd) { i__2 = jc; ainvp[i__2].r = 1.f, ainvp[i__2].i = 0.f; } /* Form the j-th column of A*AINV. */ i__2 = *n - j + 1; ctpmv_("Lower", "No transpose", diag, &i__2, &ap[jc], &ainvp[jc], &c__1); /* Subtract 1 from the diagonal to form A*AINV - I. */ i__2 = jc; i__3 = jc; q__1.r = ainvp[i__3].r - 1.f, q__1.i = ainvp[i__3].i; ainvp[i__2].r = q__1.r, ainvp[i__2].i = q__1.i; jc = jc + *n - j + 1; /* L20: */ } } /* Compute norm(A*AINV - I) / (N * norm(A) * norm(AINV) * EPS) */ *resid = clantp_("1", uplo, "Non-unit", n, &ainvp[1], &rwork[1]); *resid = *resid * *rcond / (real) (*n) / eps; return 0; /* End of CTPT01 */ } /* ctpt01_ */
int ctptri_(char *uplo, char *diag, int *n, complex *ap, int *info) { /* System generated locals */ int i__1, i__2; complex q__1; /* Builtin functions */ void c_div(complex *, complex *, complex *); /* Local variables */ int j, jc, jj; complex ajj; extern int cscal_(int *, complex *, complex *, int *); extern int lsame_(char *, char *); extern int ctpmv_(char *, char *, char *, int *, complex *, complex *, int *); int upper; extern int xerbla_(char *, int *); int jclast; int nounit; /* -- LAPACK routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CTPTRI computes the inverse of a complex 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) COMPLEX 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 */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Executable Statements .. */ /* 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_("CTPTRI", &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; i__2 = jj; if (ap[i__2].r == 0.f && ap[i__2].i == 0.f) { return 0; } /* L10: */ } } else { jj = 1; i__1 = *n; for (*info = 1; *info <= i__1; ++(*info)) { i__2 = jj; if (ap[i__2].r == 0.f && ap[i__2].i == 0.f) { 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) { i__2 = jc + j - 1; c_div(&q__1, &c_b1, &ap[jc + j - 1]); ap[i__2].r = q__1.r, ap[i__2].i = q__1.i; i__2 = jc + j - 1; q__1.r = -ap[i__2].r, q__1.i = -ap[i__2].i; ajj.r = q__1.r, ajj.i = q__1.i; } else { q__1.r = -1.f, q__1.i = -0.f; ajj.r = q__1.r, ajj.i = q__1.i; } /* Compute elements 1:j-1 of j-th column. */ i__2 = j - 1; ctpmv_("Upper", "No transpose", diag, &i__2, &ap[1], &ap[jc], & c__1); i__2 = j - 1; cscal_(&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) { i__1 = jc; c_div(&q__1, &c_b1, &ap[jc]); ap[i__1].r = q__1.r, ap[i__1].i = q__1.i; i__1 = jc; q__1.r = -ap[i__1].r, q__1.i = -ap[i__1].i; ajj.r = q__1.r, ajj.i = q__1.i; } else { q__1.r = -1.f, q__1.i = -0.f; ajj.r = q__1.r, ajj.i = q__1.i; } if (j < *n) { /* Compute elements j+1:n of j-th column. */ i__1 = *n - j; ctpmv_("Lower", "No transpose", diag, &i__1, &ap[jclast], &ap[ jc + 1], &c__1); i__1 = *n - j; cscal_(&i__1, &ajj, &ap[jc + 1], &c__1); } jclast = jc; jc = jc - *n + j - 2; /* L40: */ } } return 0; /* End of CTPTRI */ } /* ctptri_ */
int cpptri_(char *uplo, int *n, complex *ap, int * info) { /* System generated locals */ int i__1, i__2, i__3; float r__1; complex q__1; /* Local variables */ int j, jc, jj; float ajj; int jjn; extern int chpr_(char *, int *, float *, complex *, int *, complex *); extern /* Complex */ VOID cdotc_(complex *, int *, complex *, int *, complex *, int *); extern int lsame_(char *, char *); extern int ctpmv_(char *, char *, char *, int *, complex *, complex *, int *); int upper; extern int csscal_(int *, float *, complex *, int *), xerbla_(char *, int *), ctptri_(char *, char *, int *, complex *, int *); /* -- LAPACK routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CPPTRI computes the inverse of a complex Hermitian positive definite */ /* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H */ /* computed by CPPTRF. */ /* 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) COMPLEX array, dimension (N*(N+1)/2) */ /* On entry, the triangular factor U or L from the Cholesky */ /* factorization A = U**H*U or A = L*L**H, 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 (Hermitian) */ /* 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. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. 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_("CPPTRI", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Invert the triangular Cholesky factor U or L. */ ctptri_(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; chpr_("Upper", &i__2, &c_b8, &ap[jc], &c__1, &ap[1]); } i__2 = jj; ajj = ap[i__2].r; csscal_(&j, &ajj, &ap[jc], &c__1); /* L10: */ } } 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 = jj; i__3 = *n - j + 1; cdotc_(&q__1, &i__3, &ap[jj], &c__1, &ap[jj], &c__1); r__1 = q__1.r; ap[i__2].r = r__1, ap[i__2].i = 0.f; if (j < *n) { i__2 = *n - j; ctpmv_("Lower", "Conjugate transpose", "Non-unit", &i__2, &ap[ jjn], &ap[jj + 1], &c__1); } jj = jjn; /* L20: */ } } return 0; /* End of CPPTRI */ } /* cpptri_ */
/* Subroutine */ int ctptri_(char *uplo, char *diag, integer *n, complex *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 ======= CTPTRI computes the inverse of a complex 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) COMPLEX 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 complex c_b1 = {1.f,0.f}; static integer c__1 = 1; /* System generated locals */ integer i__1, i__2; complex q__1; /* Builtin functions */ void c_div(complex *, complex *, complex *); /* Local variables */ static integer j; extern /* Subroutine */ int cscal_(integer *, complex *, complex *, integer *); extern logical lsame_(char *, char *); extern /* Subroutine */ int ctpmv_(char *, char *, char *, integer *, complex *, complex *, integer *); static logical upper; static integer jc, jj; extern /* Subroutine */ int xerbla_(char *, integer *); static integer jclast; static logical nounit; static complex 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_("CTPTRI", &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; i__2 = jj; if (ap[i__2].r == 0.f && ap[i__2].i == 0.f) { return 0; } /* L10: */ } } else { jj = 1; i__1 = *n; for (*info = 1; *info <= i__1; ++(*info)) { i__2 = jj; if (ap[i__2].r == 0.f && ap[i__2].i == 0.f) { 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) { i__2 = jc + j - 1; c_div(&q__1, &c_b1, &ap[jc + j - 1]); ap[i__2].r = q__1.r, ap[i__2].i = q__1.i; i__2 = jc + j - 1; q__1.r = -ap[i__2].r, q__1.i = -ap[i__2].i; ajj.r = q__1.r, ajj.i = q__1.i; } else { q__1.r = -1.f, q__1.i = 0.f; ajj.r = q__1.r, ajj.i = q__1.i; } /* Compute elements 1:j-1 of j-th column. */ i__2 = j - 1; ctpmv_("Upper", "No transpose", diag, &i__2, &ap[1], &ap[jc], & c__1); i__2 = j - 1; cscal_(&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) { i__1 = jc; c_div(&q__1, &c_b1, &ap[jc]); ap[i__1].r = q__1.r, ap[i__1].i = q__1.i; i__1 = jc; q__1.r = -ap[i__1].r, q__1.i = -ap[i__1].i; ajj.r = q__1.r, ajj.i = q__1.i; } else { q__1.r = -1.f, q__1.i = 0.f; ajj.r = q__1.r, ajj.i = q__1.i; } if (j < *n) { /* Compute elements j+1:n of j-th column. */ i__1 = *n - j; ctpmv_("Lower", "No transpose", diag, &i__1, &ap[jclast], &ap[ jc + 1], &c__1); i__1 = *n - j; cscal_(&i__1, &ajj, &ap[jc + 1], &c__1); } jclast = jc; jc = jc - *n + j - 2; /* L40: */ } } return 0; /* End of CTPTRI */ } /* ctptri_ */
/* Subroutine */ int cppt01_(char *uplo, integer *n, complex *a, complex * afac, real *rwork, real *resid) { /* System generated locals */ integer i__1, i__2, i__3, i__4, i__5; real r__1; complex q__1; /* Builtin functions */ double r_imag(complex *); /* Local variables */ integer i__, k, kc; complex tc; real tr, eps; extern /* Subroutine */ int chpr_(char *, integer *, real *, complex *, integer *, complex *), cscal_(integer *, complex *, complex *, integer *); extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer *, complex *, integer *); extern logical lsame_(char *, char *); real anorm; extern /* Subroutine */ int ctpmv_(char *, char *, char *, integer *, complex *, complex *, integer *); extern doublereal clanhp_(char *, char *, integer *, complex *, real *), slamch_(char *); /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CPPT01 reconstructs a Hermitian 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, L' is the conjugate transpose of */ /* L, and U' is the conjugate transpose of U. */ /* Arguments */ /* ========== */ /* UPLO (input) CHARACTER*1 */ /* Specifies whether the upper or lower triangular part of the */ /* Hermitian 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) COMPLEX array, dimension (N*(N+1)/2) */ /* The original Hermitian matrix A, stored as a packed */ /* triangular matrix. */ /* AFAC (input/output) COMPLEX 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) REAL array, dimension (N) */ /* RESID (output) REAL */ /* 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.f; return 0; } /* Exit with RESID = 1/EPS if ANORM = 0. */ eps = slamch_("Epsilon"); anorm = clanhp_("1", uplo, n, &a[1], &rwork[1]); if (anorm <= 0.f) { *resid = 1.f / eps; return 0; } /* Check the imaginary parts of the diagonal elements and return with */ /* an error code if any are nonzero. */ kc = 1; if (lsame_(uplo, "U")) { i__1 = *n; for (k = 1; k <= i__1; ++k) { if (r_imag(&afac[kc]) != 0.f) { *resid = 1.f / eps; return 0; } kc = kc + k + 1; /* L10: */ } } else { i__1 = *n; for (k = 1; k <= i__1; ++k) { if (r_imag(&afac[kc]) != 0.f) { *resid = 1.f / eps; return 0; } kc = kc + *n - k + 1; /* L20: */ } } /* 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. */ cdotc_(&q__1, &k, &afac[kc], &c__1, &afac[kc], &c__1); tr = q__1.r; i__1 = kc + k - 1; afac[i__1].r = tr, afac[i__1].i = 0.f; /* Compute the rest of column K. */ if (k > 1) { i__1 = k - 1; ctpmv_("Upper", "Conjugate", "Non-unit", &i__1, &afac[1], & afac[kc], &c__1); kc -= k - 1; } /* L30: */ } /* Compute the difference L*L' - A */ kc = 1; i__1 = *n; for (k = 1; k <= i__1; ++k) { i__2 = k - 1; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = kc + i__ - 1; i__4 = kc + i__ - 1; i__5 = kc + i__ - 1; q__1.r = afac[i__4].r - a[i__5].r, q__1.i = afac[i__4].i - a[ i__5].i; afac[i__3].r = q__1.r, afac[i__3].i = q__1.i; /* L40: */ } i__2 = kc + k - 1; i__3 = kc + k - 1; i__4 = kc + k - 1; r__1 = a[i__4].r; q__1.r = afac[i__3].r - r__1, q__1.i = afac[i__3].i; afac[i__2].r = q__1.r, afac[i__2].i = q__1.i; kc += k; /* L50: */ } /* 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; chpr_("Lower", &i__1, &c_b19, &afac[kc + 1], &c__1, &afac[kc + *n - k + 1]); } /* Scale column K by the diagonal element. */ i__1 = kc; tc.r = afac[i__1].r, tc.i = afac[i__1].i; i__1 = *n - k + 1; cscal_(&i__1, &tc, &afac[kc], &c__1); kc -= *n - k + 2; /* L60: */ } /* Compute the difference U'*U - A */ kc = 1; i__1 = *n; for (k = 1; k <= i__1; ++k) { i__2 = kc; i__3 = kc; i__4 = kc; r__1 = a[i__4].r; q__1.r = afac[i__3].r - r__1, q__1.i = afac[i__3].i; afac[i__2].r = q__1.r, afac[i__2].i = q__1.i; i__2 = *n; for (i__ = k + 1; i__ <= i__2; ++i__) { i__3 = kc + i__ - k; i__4 = kc + i__ - k; i__5 = kc + i__ - k; q__1.r = afac[i__4].r - a[i__5].r, q__1.i = afac[i__4].i - a[ i__5].i; afac[i__3].r = q__1.r, afac[i__3].i = q__1.i; /* L70: */ } kc = kc + *n - k + 1; /* L80: */ } } /* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */ *resid = clanhp_("1", uplo, n, &afac[1], &rwork[1]); *resid = *resid / (real) (*n) / anorm / eps; return 0; /* End of CPPT01 */ } /* cppt01_ */
/* Subroutine */ int ctpt02_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, complex *ap, complex *x, integer *ldx, complex *b, integer *ldb, complex *work, real *rwork, real *resid) { /* System generated locals */ integer b_dim1, b_offset, x_dim1, x_offset, i__1; real r__1, r__2; /* Local variables */ integer j; real eps; extern logical lsame_(char *, char *); real anorm, bnorm; extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer *, complex *, integer *), ctpmv_(char *, char *, char *, integer *, complex *, complex *, integer *); real xnorm; extern doublereal slamch_(char *), clantp_(char *, char *, char *, integer *, complex *, real *), scasum_( integer *, complex *, integer *); /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CTPT02 computes the residual for the computed solution to a */ /* triangular system of linear equations A*x = b, A**T *x = b, or */ /* A**H *x = b, when the triangular matrix A is stored in packed format. */ /* Here A**T denotes the transpose of A, A**H denotes the conjugate */ /* 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 */ /* 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, A**T, or A**H, 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**T *x = b (Transpose) */ /* = 'C': A**H *x = b (Conjugate 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) COMPLEX array, dimension (N*(N+1)/2) */ /* The upper or lower triangular matrix A, packed columnwise in */ /* a linear array. The j-th column of A is stored in the array */ /* AP as follows: */ /* if UPLO = 'U', AP((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) COMPLEX 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) COMPLEX array, dimension (LDB,NRHS) */ /* The right hand side vectors for the system of linear */ /* equations. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= max(1,N). */ /* WORK (workspace) COMPLEX array, dimension (N) */ /* RWORK (workspace) REAL array, dimension (N) */ /* RESID (output) REAL */ /* 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; --rwork; /* Function Body */ if (*n <= 0 || *nrhs <= 0) { *resid = 0.f; return 0; } /* Compute the 1-norm of A or A**H. */ if (lsame_(trans, "N")) { anorm = clantp_("1", uplo, diag, n, &ap[1], &rwork[1]); } else { anorm = clantp_("I", uplo, diag, n, &ap[1], &rwork[1]); } /* Exit with RESID = 1/EPS if ANORM = 0. */ eps = slamch_("Epsilon"); if (anorm <= 0.f) { *resid = 1.f / 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.f; i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { ccopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1); ctpmv_(uplo, trans, diag, n, &ap[1], &work[1], &c__1); caxpy_(n, &c_b12, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1); bnorm = scasum_(n, &work[1], &c__1); xnorm = scasum_(n, &x[j * x_dim1 + 1], &c__1); if (xnorm <= 0.f) { *resid = 1.f / eps; } else { /* Computing MAX */ r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps; *resid = dmax(r__1,r__2); } /* L10: */ } return 0; /* End of CTPT02 */ } /* ctpt02_ */
/* Subroutine */ int chpgst_(integer *itype, char *uplo, integer *n, complex * ap, complex *bp, integer *info) { /* System generated locals */ integer i__1, i__2, i__3, i__4; real r__1, r__2; complex q__1, q__2, q__3; /* Local variables */ integer j, k, j1, k1, jj, kk; complex ct; real ajj; integer j1j1; real akk; integer k1k1; real bjj, bkk; extern /* Subroutine */ int chpr2_(char *, integer *, complex *, complex * , integer *, complex *, integer *, complex *); extern /* Complex */ VOID cdotc_f2c_(complex *, integer *, complex *, integer *, complex *, integer *); extern logical lsame_(char *, char *); extern /* Subroutine */ int chpmv_(char *, integer *, complex *, complex * , complex *, integer *, complex *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer *, complex *, integer *), ctpmv_(char *, char *, char *, integer *, complex *, complex *, integer *); logical upper; extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *, complex *, complex *, integer *), csscal_( integer *, real *, complex *, 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 .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. 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_("CHPGST", &i__1); return 0; } if (*itype == 1) { if (upper) { /* Compute inv(U**H)*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 */ i__2 = jj; i__3 = jj; r__1 = ap[i__3].r; ap[i__2].r = r__1; ap[i__2].i = 0.f; // , expr subst i__2 = jj; bjj = bp[i__2].r; ctpsv_(uplo, "Conjugate transpose", "Non-unit", &j, &bp[1], & ap[j1], &c__1); i__2 = j - 1; q__1.r = -1.f; q__1.i = -0.f; // , expr subst chpmv_(uplo, &i__2, &q__1, &ap[1], &bp[j1], &c__1, &c_b1, &ap[ j1], &c__1); i__2 = j - 1; r__1 = 1.f / bjj; csscal_(&i__2, &r__1, &ap[j1], &c__1); i__2 = jj; i__3 = jj; i__4 = j - 1; cdotc_f2c_(&q__3, &i__4, &ap[j1], &c__1, &bp[j1], &c__1); q__2.r = ap[i__3].r - q__3.r; q__2.i = ap[i__3].i - q__3.i; // , expr subst q__1.r = q__2.r / bjj; q__1.i = q__2.i / bjj; // , expr subst ap[i__2].r = q__1.r; ap[i__2].i = q__1.i; // , expr subst /* L10: */ } } else { /* Compute inv(L)*A*inv(L**H) */ /* 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) */ i__2 = kk; akk = ap[i__2].r; i__2 = kk; bkk = bp[i__2].r; /* Computing 2nd power */ r__1 = bkk; akk /= r__1 * r__1; i__2 = kk; ap[i__2].r = akk; ap[i__2].i = 0.f; // , expr subst if (k < *n) { i__2 = *n - k; r__1 = 1.f / bkk; csscal_(&i__2, &r__1, &ap[kk + 1], &c__1); r__1 = akk * -.5f; ct.r = r__1; ct.i = 0.f; // , expr subst i__2 = *n - k; caxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) ; i__2 = *n - k; q__1.r = -1.f; q__1.i = -0.f; // , expr subst chpr2_(uplo, &i__2, &q__1, &ap[kk + 1], &c__1, &bp[kk + 1] , &c__1, &ap[k1k1]); i__2 = *n - k; caxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) ; i__2 = *n - k; ctpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1], &ap[kk + 1], &c__1); } kk = k1k1; /* L20: */ } } } else { if (upper) { /* Compute U*A*U**H */ /* 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) */ i__2 = kk; akk = ap[i__2].r; i__2 = kk; bkk = bp[i__2].r; i__2 = k - 1; ctpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[ k1], &c__1); r__1 = akk * .5f; ct.r = r__1; ct.i = 0.f; // , expr subst i__2 = k - 1; caxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1); i__2 = k - 1; chpr2_(uplo, &i__2, &c_b1, &ap[k1], &c__1, &bp[k1], &c__1, & ap[1]); i__2 = k - 1; caxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1); i__2 = k - 1; csscal_(&i__2, &bkk, &ap[k1], &c__1); i__2 = kk; /* Computing 2nd power */ r__2 = bkk; r__1 = akk * (r__2 * r__2); ap[i__2].r = r__1; ap[i__2].i = 0.f; // , expr subst /* L30: */ } } else { /* Compute L**H *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 */ i__2 = jj; ajj = ap[i__2].r; i__2 = jj; bjj = bp[i__2].r; i__2 = jj; r__1 = ajj * bjj; i__3 = *n - j; cdotc_f2c_(&q__2, &i__3, &ap[jj + 1], &c__1, &bp[jj + 1], &c__1); q__1.r = r__1 + q__2.r; q__1.i = q__2.i; // , expr subst ap[i__2].r = q__1.r; ap[i__2].i = q__1.i; // , expr subst i__2 = *n - j; csscal_(&i__2, &bjj, &ap[jj + 1], &c__1); i__2 = *n - j; chpmv_(uplo, &i__2, &c_b1, &ap[j1j1], &bp[jj + 1], &c__1, & c_b1, &ap[jj + 1], &c__1); i__2 = *n - j + 1; ctpmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &bp[jj] , &ap[jj], &c__1); jj = j1j1; /* L40: */ } } } return 0; /* End of CHPGST */ }