int f2c_chpmv(char* uplo, integer* N, complex* alpha, complex* Ap, complex* X, integer* incX, complex* beta, complex* Y, integer* incY) { chpmv_(uplo, N, alpha, Ap, X, incX, beta, Y, incY); return 0; }
/* Subroutine */ int chprfs_(char *uplo, integer *n, integer *nrhs, complex * ap, complex *afp, integer *ipiv, 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 ik, kk; 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 *), chpmv_(char *, integer *, complex *, complex *, complex *, integer *, complex *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer *, complex *, integer *); integer count; logical upper; extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real *, integer *, integer *); extern doublereal slamch_(char *); real safmin; extern /* Subroutine */ int xerbla_(char *, integer *), chptrs_( char *, integer *, integer *, complex *, integer *, complex *, integer *, integer *); 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 */ /* ======= */ /* CHPRFS improves the computed solution to a system of linear */ /* equations when the coefficient matrix is Hermitian indefinite */ /* and packed, and provides error bounds and backward error estimates */ /* for the solution. */ /* Arguments */ /* ========= */ /* UPLO (input) CHARACTER*1 */ /* = 'U': Upper triangle of A is stored; */ /* = 'L': Lower triangle of A is stored. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* NRHS (input) INTEGER */ /* The number of right hand sides, i.e., the number of columns */ /* of the matrices B and X. NRHS >= 0. */ /* AP (input) COMPLEX array, dimension (N*(N+1)/2) */ /* 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. */ /* AFP (input) COMPLEX array, dimension (N*(N+1)/2) */ /* The factored form of the matrix A. AFP contains the block */ /* diagonal matrix D and the multipliers used to obtain the */ /* factor U or L from the factorization A = U*D*U**H or */ /* A = L*D*L**H as computed by CHPTRF, stored as a packed */ /* triangular matrix. */ /* IPIV (input) INTEGER array, dimension (N) */ /* Details of the interchanges and the block structure of D */ /* as determined by CHPTRF. */ /* 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/output) COMPLEX array, dimension (LDX,NRHS) */ /* On entry, the solution matrix X, as computed by CHPTRS. */ /* On exit, the improved solution matrix X. */ /* LDX (input) INTEGER */ /* The leading dimension of the array X. LDX >= max(1,N). */ /* FERR (output) REAL array, dimension (NRHS) */ /* The estimated forward error bound for each solution vector */ /* X(j) (the j-th column of the solution matrix X). */ /* If XTRUE is the true solution corresponding to X(j), FERR(j) */ /* is an estimated upper bound for the magnitude of the largest */ /* element in (X(j) - XTRUE) divided by the magnitude of the */ /* largest element in X(j). The estimate is as reliable as */ /* the estimate for RCOND, and is almost always a slight */ /* overestimate of the true error. */ /* BERR (output) REAL array, dimension (NRHS) */ /* The componentwise relative backward error of each solution */ /* vector X(j) (i.e., the smallest relative change in */ /* any element of A or B that makes X(j) an exact solution). */ /* WORK (workspace) 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 */ /* Internal Parameters */ /* =================== */ /* ITMAX is the maximum number of steps of iterative refinement. */ /* ===================================================================== */ /* .. 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; --afp; --ipiv; 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"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*nrhs < 0) { *info = -3; } else if (*ldb < max(1,*n)) { *info = -8; } else if (*ldx < max(1,*n)) { *info = -10; } if (*info != 0) { i__1 = -(*info); xerbla_("CHPRFS", &i__1); return 0; } /* Quick return if possible */ if (*n == 0 || *nrhs == 0) { i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { ferr[j] = 0.f; berr[j] = 0.f; /* L10: */ } return 0; } /* NZ = maximum number of nonzero elements in each row of A, plus 1 */ nz = *n + 1; eps = slamch_("Epsilon"); safmin = slamch_("Safe minimum"); safe1 = nz * safmin; safe2 = safe1 / eps; /* Do for each right hand side */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { count = 1; lstres = 3.f; L20: /* Loop until stopping criterion is satisfied. */ /* Compute residual R = B - A * X */ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1); q__1.r = -1.f, q__1.i = -0.f; chpmv_(uplo, n, &q__1, &ap[1], &x[j * x_dim1 + 1], &c__1, &c_b1, & work[1], &c__1); /* Compute componentwise relative backward error from formula */ /* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */ /* where abs(Z) is the componentwise absolute value of the matrix */ /* or vector Z. If the i-th component of the denominator is less */ /* than SAFE2, then SAFE1 is added to the i-th components of the */ /* numerator and denominator before dividing. */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { 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)); /* L30: */ } /* Compute abs(A)*abs(X) + abs(B). */ kk = 1; if (upper) { i__2 = *n; for (k = 1; k <= i__2; ++k) { s = 0.f; 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)); ik = kk; i__3 = k - 1; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = ik; rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&ap[ik]), dabs(r__2))) * xk; i__4 = ik; i__5 = i__ + j * x_dim1; s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(& ap[ik]), dabs(r__2))) * ((r__3 = x[i__5].r, dabs( r__3)) + (r__4 = r_imag(&x[i__ + j * x_dim1]), dabs(r__4))); ++ik; /* L40: */ } i__3 = kk + k - 1; rwork[k] = rwork[k] + (r__1 = ap[i__3].r, dabs(r__1)) * xk + s; kk += k; /* L50: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { s = 0.f; 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 = kk; rwork[k] += (r__1 = ap[i__3].r, dabs(r__1)) * xk; ik = kk + 1; i__3 = *n; for (i__ = k + 1; i__ <= i__3; ++i__) { i__4 = ik; rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&ap[ik]), dabs(r__2))) * xk; i__4 = ik; i__5 = i__ + j * x_dim1; s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(& ap[ik]), dabs(r__2))) * ((r__3 = x[i__5].r, dabs( r__3)) + (r__4 = r_imag(&x[i__ + j * x_dim1]), dabs(r__4))); ++ik; /* L60: */ } rwork[k] += s; kk += *n - k + 1; /* L70: */ } } 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); } /* L80: */ } berr[j] = s; /* Test stopping criterion. Continue iterating if */ /* 1) The residual BERR(J) is larger than machine epsilon, and */ /* 2) BERR(J) decreased by at least a factor of 2 during the */ /* last iteration, and */ /* 3) At most ITMAX iterations tried. */ if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) { /* Update solution and try again. */ chptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info); caxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1); lstres = berr[j]; ++count; goto L20; } /* Bound error from formula */ /* norm(X - XTRUE) / norm(X) .le. FERR = */ /* norm( abs(inv(A))* */ /* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */ /* where */ /* norm(Z) is the magnitude of the largest component of Z */ /* inv(A) is the inverse of A */ /* abs(Z) is the componentwise absolute value of the matrix or */ /* vector Z */ /* NZ is the maximum number of nonzeros in any row of A, plus 1 */ /* EPS is machine epsilon */ /* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */ /* is incremented by SAFE1 if the i-th component of */ /* abs(A)*abs(X) + abs(B) is less than SAFE2. */ /* Use CLACN2 to estimate the infinity-norm of the matrix */ /* inv(A) * diag(W), */ /* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { if (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; } /* L90: */ } kase = 0; L100: clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave); if (kase != 0) { if (kase == 1) { /* Multiply by diag(W)*inv(A'). */ chptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info); 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; /* L110: */ } } else if (kase == 2) { /* Multiply by inv(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; /* L120: */ } chptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info); } goto L100; } /* 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); /* L130: */ } if (lstres != 0.f) { ferr[j] /= lstres; } /* L140: */ } return 0; /* End of CHPRFS */ } /* chprfs_ */
void chpmv(char uplo, int n, complex *alpha, complex *ap, complex *x, int incx, complex *beta, complex *y, int incy) { chpmv_( &uplo, &n, alpha, ap, x, &incx, beta, y, &incy ); }
/* 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 cppt03_(char *uplo, integer *n, complex *a, complex * ainv, complex *work, integer *ldwork, real *rwork, real *rcond, real * resid) { /* System generated locals */ integer work_dim1, work_offset, i__1, i__2, i__3; complex q__1; /* Builtin functions */ void r_cnjg(complex *, complex *); /* Local variables */ integer i__, j, jj; real eps; extern logical lsame_(char *, char *); real anorm; extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, complex *, integer *), chpmv_(char *, integer *, complex *, complex *, complex *, integer *, complex *, complex *, integer *); extern doublereal clange_(char *, integer *, integer *, complex *, integer *, real *), clanhp_(char *, char *, integer *, complex *, real *), slamch_(char *); 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 */ /* ======= */ /* CPPT03 computes the residual for a Hermitian packed matrix times its */ /* inverse: */ /* norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ), */ /* where EPS is the machine epsilon. */ /* 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. */ /* AINV (input) COMPLEX array, dimension (N*(N+1)/2) */ /* The (Hermitian) inverse of the matrix A, stored as a packed */ /* triangular matrix. */ /* WORK (workspace) COMPLEX array, dimension (LDWORK,N) */ /* LDWORK (input) INTEGER */ /* The leading dimension of the array WORK. LDWORK >= max(1,N). */ /* RWORK (workspace) REAL array, dimension (N) */ /* RCOND (output) REAL */ /* The reciprocal of the condition number of A, computed as */ /* ( 1/norm(A) ) / norm(AINV). */ /* RESID (output) REAL */ /* norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS ) */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Executable Statements .. */ /* Quick exit if N = 0. */ /* Parameter adjustments */ --a; --ainv; work_dim1 = *ldwork; work_offset = 1 + work_dim1; work -= work_offset; --rwork; /* 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 = clanhp_("1", uplo, n, &a[1], &rwork[1]); ainvnm = clanhp_("1", uplo, n, &ainv[1], &rwork[1]); if (anorm <= 0.f || ainvnm <= 0.f) { *rcond = 0.f; *resid = 1.f / eps; return 0; } *rcond = 1.f / anorm / ainvnm; /* UPLO = 'U': */ /* Copy the leading N-1 x N-1 submatrix of AINV to WORK(1:N,2:N) and */ /* expand it to a full matrix, then multiply by A one column at a */ /* time, moving the result one column to the left. */ if (lsame_(uplo, "U")) { /* Copy AINV */ jj = 1; i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { ccopy_(&j, &ainv[jj], &c__1, &work[(j + 1) * work_dim1 + 1], & c__1); i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = j + (i__ + 1) * work_dim1; r_cnjg(&q__1, &ainv[jj + i__ - 1]); work[i__3].r = q__1.r, work[i__3].i = q__1.i; /* L10: */ } jj += j; /* L20: */ } jj = (*n - 1) * *n / 2 + 1; i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *n + (i__ + 1) * work_dim1; r_cnjg(&q__1, &ainv[jj + i__ - 1]); work[i__2].r = q__1.r, work[i__2].i = q__1.i; /* L30: */ } /* Multiply by A */ i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { q__1.r = -1.f, q__1.i = -0.f; chpmv_("Upper", n, &q__1, &a[1], &work[(j + 1) * work_dim1 + 1], & c__1, &c_b1, &work[j * work_dim1 + 1], &c__1); /* L40: */ } q__1.r = -1.f, q__1.i = -0.f; chpmv_("Upper", n, &q__1, &a[1], &ainv[jj], &c__1, &c_b1, &work[*n * work_dim1 + 1], &c__1); /* UPLO = 'L': */ /* Copy the trailing N-1 x N-1 submatrix of AINV to WORK(1:N,1:N-1) */ /* and multiply by A, moving each column to the right. */ } else { /* Copy AINV */ i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__ * work_dim1 + 1; r_cnjg(&q__1, &ainv[i__ + 1]); work[i__2].r = q__1.r, work[i__2].i = q__1.i; /* L50: */ } jj = *n + 1; i__1 = *n; for (j = 2; j <= i__1; ++j) { i__2 = *n - j + 1; ccopy_(&i__2, &ainv[jj], &c__1, &work[j + (j - 1) * work_dim1], & c__1); i__2 = *n - j; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = j + (j + i__ - 1) * work_dim1; r_cnjg(&q__1, &ainv[jj + i__]); work[i__3].r = q__1.r, work[i__3].i = q__1.i; /* L60: */ } jj = jj + *n - j + 1; /* L70: */ } /* Multiply by A */ for (j = *n; j >= 2; --j) { q__1.r = -1.f, q__1.i = -0.f; chpmv_("Lower", n, &q__1, &a[1], &work[(j - 1) * work_dim1 + 1], & c__1, &c_b1, &work[j * work_dim1 + 1], &c__1); /* L80: */ } q__1.r = -1.f, q__1.i = -0.f; chpmv_("Lower", n, &q__1, &a[1], &ainv[1], &c__1, &c_b1, &work[ work_dim1 + 1], &c__1); } /* Add the identity matrix to WORK . */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__ + i__ * work_dim1; i__3 = i__ + i__ * work_dim1; q__1.r = work[i__3].r + 1.f, q__1.i = work[i__3].i + 0.f; work[i__2].r = q__1.r, work[i__2].i = q__1.i; /* L90: */ } /* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS) */ *resid = clange_("1", n, n, &work[work_offset], ldwork, &rwork[1]); *resid = *resid * *rcond / eps / (real) (*n); return 0; /* End of CPPT03 */ } /* cppt03_ */
/* Subroutine */ int cppt02_(char *uplo, integer *n, integer *nrhs, complex * a, complex *x, integer *ldx, complex *b, integer *ldb, real *rwork, real *resid) { /* System generated locals */ integer b_dim1, b_offset, x_dim1, x_offset, i__1; real r__1, r__2; complex q__1; /* Local variables */ integer j; real eps, anorm, bnorm; real xnorm; /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CPPT02 computes the residual in the solution of a Hermitian system */ /* of linear equations A*x = b when packed storage is used for the */ /* coefficient matrix. The ratio computed is */ /* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS), */ /* where EPS is the machine precision. */ /* 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. */ /* NRHS (input) INTEGER */ /* The number of columns of B, the matrix of right hand sides. */ /* NRHS >= 0. */ /* A (input) COMPLEX array, dimension (N*(N+1)/2) */ /* The original Hermitian matrix A, stored as a packed */ /* triangular matrix. */ /* 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/output) COMPLEX array, dimension (LDB,NRHS) */ /* On entry, the right hand side vectors for the system of */ /* linear equations. */ /* On exit, B is overwritten with the difference B - A*X. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= max(1,N). */ /* RWORK (workspace) REAL array, dimension (N) */ /* RESID (output) REAL */ /* The maximum over the number of right hand sides of */ /* norm(B - A*X) / ( norm(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 */ --a; x_dim1 = *ldx; x_offset = 1 + x_dim1; x -= x_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; --rwork; /* Function Body */ if (*n <= 0 || *nrhs <= 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; } /* Compute B - A*X for the matrix of right hand sides B. */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { q__1.r = -1.f, q__1.i = -0.f; chpmv_(uplo, n, &q__1, &a[1], &x[j * x_dim1 + 1], &c__1, &c_b1, &b[j * b_dim1 + 1], &c__1); /* L10: */ } /* Compute the maximum over the number of right hand sides of */ /* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) . */ *resid = 0.f; i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { bnorm = scasum_(n, &b[j * b_dim1 + 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); } /* L20: */ } return 0; /* End of CPPT02 */ } /* cppt02_ */
/* Subroutine */ int chptrd_(char *uplo, integer *n, complex *ap, real *d__, real *e, complex *tau, integer *info) { /* System generated locals */ integer i__1, i__2, i__3; real r__1; complex q__1, q__2, q__3, q__4; /* Local variables */ integer i__, i1, ii, i1i1; complex taui; extern /* Subroutine */ int chpr2_(char *, integer *, complex *, complex * , integer *, complex *, integer *, complex *); complex alpha; extern /* Complex */ VOID cdotc_(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 *); logical upper; extern /* Subroutine */ int clarfg_(integer *, complex *, complex *, integer *, complex *), xerbla_(char *, integer *); /* -- LAPACK routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CHPTRD reduces a complex Hermitian matrix A stored in packed form to */ /* real symmetric tridiagonal form T by a unitary similarity */ /* transformation: Q**H * A * Q = T. */ /* Arguments */ /* ========= */ /* UPLO (input) CHARACTER*1 */ /* = 'U': Upper triangle of A is stored; */ /* = 'L': Lower triangle of A is stored. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* 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, if UPLO = 'U', the diagonal and first superdiagonal */ /* of A are overwritten by the corresponding elements of the */ /* tridiagonal matrix T, and the elements above the first */ /* superdiagonal, with the array TAU, represent the unitary */ /* matrix Q as a product of elementary reflectors; if UPLO */ /* = 'L', the diagonal and first subdiagonal of A are over- */ /* written by the corresponding elements of the tridiagonal */ /* matrix T, and the elements below the first subdiagonal, with */ /* the array TAU, represent the unitary matrix Q as a product */ /* of elementary reflectors. See Further Details. */ /* D (output) REAL array, dimension (N) */ /* The diagonal elements of the tridiagonal matrix T: */ /* D(i) = A(i,i). */ /* E (output) REAL array, dimension (N-1) */ /* The off-diagonal elements of the tridiagonal matrix T: */ /* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */ /* TAU (output) COMPLEX array, dimension (N-1) */ /* The scalar factors of the elementary reflectors (see Further */ /* Details). */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* Further Details */ /* =============== */ /* If UPLO = 'U', the matrix Q is represented as a product of elementary */ /* reflectors */ /* Q = H(n-1) . . . H(2) H(1). */ /* Each H(i) has the form */ /* H(i) = I - tau * v * v' */ /* where tau is a complex scalar, and v is a complex vector with */ /* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP, */ /* overwriting A(1:i-1,i+1), and tau is stored in TAU(i). */ /* If UPLO = 'L', the matrix Q is represented as a product of elementary */ /* reflectors */ /* Q = H(1) H(2) . . . H(n-1). */ /* Each H(i) has the form */ /* H(i) = I - tau * v * v' */ /* where tau is a complex scalar, and v is a complex vector with */ /* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP, */ /* overwriting A(i+2:n,i), and tau is stored in TAU(i). */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters */ /* Parameter adjustments */ --tau; --e; --d__; --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_("CHPTRD", &i__1); return 0; } /* Quick return if possible */ if (*n <= 0) { return 0; } if (upper) { /* Reduce the upper triangle of A. */ /* I1 is the index in AP of A(1,I+1). */ i1 = *n * (*n - 1) / 2 + 1; i__1 = i1 + *n - 1; i__2 = i1 + *n - 1; r__1 = ap[i__2].r; ap[i__1].r = r__1, ap[i__1].i = 0.f; for (i__ = *n - 1; i__ >= 1; --i__) { /* Generate elementary reflector H(i) = I - tau * v * v' */ /* to annihilate A(1:i-1,i+1) */ i__1 = i1 + i__ - 1; alpha.r = ap[i__1].r, alpha.i = ap[i__1].i; clarfg_(&i__, &alpha, &ap[i1], &c__1, &taui); i__1 = i__; e[i__1] = alpha.r; if (taui.r != 0.f || taui.i != 0.f) { /* Apply H(i) from both sides to A(1:i,1:i) */ i__1 = i1 + i__ - 1; ap[i__1].r = 1.f, ap[i__1].i = 0.f; /* Compute y := tau * A * v storing y in TAU(1:i) */ chpmv_(uplo, &i__, &taui, &ap[1], &ap[i1], &c__1, &c_b2, &tau[ 1], &c__1); /* Compute w := y - 1/2 * tau * (y'*v) * v */ q__3.r = -.5f, q__3.i = -0.f; q__2.r = q__3.r * taui.r - q__3.i * taui.i, q__2.i = q__3.r * taui.i + q__3.i * taui.r; cdotc_(&q__4, &i__, &tau[1], &c__1, &ap[i1], &c__1); q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i + q__2.i * q__4.r; alpha.r = q__1.r, alpha.i = q__1.i; caxpy_(&i__, &alpha, &ap[i1], &c__1, &tau[1], &c__1); /* Apply the transformation as a rank-2 update: */ /* A := A - v * w' - w * v' */ q__1.r = -1.f, q__1.i = -0.f; chpr2_(uplo, &i__, &q__1, &ap[i1], &c__1, &tau[1], &c__1, &ap[ 1]); } i__1 = i1 + i__ - 1; i__2 = i__; ap[i__1].r = e[i__2], ap[i__1].i = 0.f; i__1 = i__ + 1; i__2 = i1 + i__; d__[i__1] = ap[i__2].r; i__1 = i__; tau[i__1].r = taui.r, tau[i__1].i = taui.i; i1 -= i__; /* L10: */ } d__[1] = ap[1].r; } else { /* Reduce the lower triangle of A. II is the index in AP of */ /* A(i,i) and I1I1 is the index of A(i+1,i+1). */ ii = 1; r__1 = ap[1].r; ap[1].r = r__1, ap[1].i = 0.f; i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { i1i1 = ii + *n - i__ + 1; /* Generate elementary reflector H(i) = I - tau * v * v' */ /* to annihilate A(i+2:n,i) */ i__2 = ii + 1; alpha.r = ap[i__2].r, alpha.i = ap[i__2].i; i__2 = *n - i__; clarfg_(&i__2, &alpha, &ap[ii + 2], &c__1, &taui); i__2 = i__; e[i__2] = alpha.r; if (taui.r != 0.f || taui.i != 0.f) { /* Apply H(i) from both sides to A(i+1:n,i+1:n) */ i__2 = ii + 1; ap[i__2].r = 1.f, ap[i__2].i = 0.f; /* Compute y := tau * A * v storing y in TAU(i:n-1) */ i__2 = *n - i__; chpmv_(uplo, &i__2, &taui, &ap[i1i1], &ap[ii + 1], &c__1, & c_b2, &tau[i__], &c__1); /* Compute w := y - 1/2 * tau * (y'*v) * v */ q__3.r = -.5f, q__3.i = -0.f; q__2.r = q__3.r * taui.r - q__3.i * taui.i, q__2.i = q__3.r * taui.i + q__3.i * taui.r; i__2 = *n - i__; cdotc_(&q__4, &i__2, &tau[i__], &c__1, &ap[ii + 1], &c__1); q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i + q__2.i * q__4.r; alpha.r = q__1.r, alpha.i = q__1.i; i__2 = *n - i__; caxpy_(&i__2, &alpha, &ap[ii + 1], &c__1, &tau[i__], &c__1); /* Apply the transformation as a rank-2 update: */ /* A := A - v * w' - w * v' */ i__2 = *n - i__; q__1.r = -1.f, q__1.i = -0.f; chpr2_(uplo, &i__2, &q__1, &ap[ii + 1], &c__1, &tau[i__], & c__1, &ap[i1i1]); } i__2 = ii + 1; i__3 = i__; ap[i__2].r = e[i__3], ap[i__2].i = 0.f; i__2 = i__; i__3 = ii; d__[i__2] = ap[i__3].r; i__2 = i__; tau[i__2].r = taui.r, tau[i__2].i = taui.i; ii = i1i1; /* L20: */ } i__1 = *n; i__2 = ii; d__[i__1] = ap[i__2].r; } return 0; /* End of CHPTRD */ } /* chptrd_ */
/* 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_ */
void cblas_chpmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,const integer N, const void *alpha, const void *AP, const void *X, const integer incX, const void *beta, void *Y, const integer incY) { char UL; #ifdef F77_CHAR F77_CHAR F77_UL; #else #define F77_UL &UL #endif #define F77_N N #define F77_incX incx #define F77_incY incY integer n, i=0, incx=incX; const float *xx= (float *)X, *alp= (float *)alpha, *bet = (float *)beta; float ALPHA[2],BETA[2]; integer tincY, tincx; float *x=(float *)X, *y=(float *)Y, *st=0, *tx; extern integer CBLAS_CallFromC; extern integer RowMajorStrg; RowMajorStrg = 0; CBLAS_CallFromC = 1; if (order == CblasColMajor) { if (Uplo == CblasLower) UL = 'L'; else if (Uplo == CblasUpper) UL = 'U'; else { cblas_xerbla(2, "cblas_chpmv","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif chpmv_(F77_UL, &F77_N, alpha, AP, X, &F77_incX, beta, Y, &F77_incY); } else if (order == CblasRowMajor) { RowMajorStrg = 1; ALPHA[0]= *alp; ALPHA[1]= -alp[1]; BETA[0]= *bet; BETA[1]= -bet[1]; if (N > 0) { n = N << 1; x = malloc(n*sizeof(float)); tx = x; if( incX > 0 ) { i = incX << 1; tincx = 2; st= x+n; } else { i = incX *(-2); tincx = -2; st = x-2; x +=(n-2); } do { *x = *xx; x[1] = -xx[1]; x += tincx ; xx += i; } while (x != st); x=tx; incx = 1; if(incY > 0) tincY = incY; else tincY = -incY; y++; i = tincY << 1; n = i * N ; st = y + n; do { *y = -(*y); y += i; } while(y != st); y -= n; } else x = (float *) X; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; else { cblas_xerbla(2, "cblas_chpmv","Illegal Uplo setting, %d\n", Uplo ); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif chpmv_(F77_UL, &F77_N, ALPHA, AP, x, &F77_incX, BETA, Y, &F77_incY); } else { cblas_xerbla(1, "cblas_chpmv","Illegal Order setting, %d\n", order); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } if ( order == CblasRowMajor ) { RowMajorStrg = 1; if(X!=x) free(x); if (N > 0) { do { *y = -(*y); y += i; } while (y != st); } } CBLAS_CallFromC = 0; RowMajorStrg = 0; return; }
/* Subroutine */ int chptri_(char *uplo, integer *n, complex *ap, integer * ipiv, complex *work, integer *info) { /* -- LAPACK routine (version 2.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= CHPTRI computes the inverse of a complex Hermitian indefinite matrix A in packed storage using the factorization A = U*D*U**H or A = L*D*L**H computed by CHPTRF. Arguments ========= UPLO (input) CHARACTER*1 Specifies whether the details of the factorization are stored as an upper or lower triangular matrix. = 'U': Upper triangular, form is A = U*D*U**H; = 'L': Lower triangular, form is A = L*D*L**H. N (input) INTEGER The order of the matrix A. N >= 0. AP (input/output) COMPLEX array, dimension (N*(N+1)/2) On entry, the block diagonal matrix D and the multipliers used to obtain the factor U or L as computed by CHPTRF, stored as a packed triangular matrix. On exit, if INFO = 0, the (Hermitian) inverse of the original matrix, stored as a packed triangular matrix. The j-th column of inv(A) is stored in the array AP as follows: if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j; if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n. IPIV (input) INTEGER array, dimension (N) Details of the interchanges and the block structure of D as determined by CHPTRF. WORK (workspace) COMPLEX array, dimension (N) INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its inverse could not be computed. ===================================================================== Test the input parameters. Parameter adjustments Function Body */ /* Table of constant values */ static complex c_b2 = {0.f,0.f}; static integer c__1 = 1; /* System generated locals */ integer i__1, i__2, i__3; doublereal d__1; complex q__1, q__2; /* Builtin functions */ double c_abs(complex *); void r_cnjg(complex *, complex *); /* Local variables */ static complex temp, akkp1; static real d; static integer j, k; static real t; extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer *, complex *, integer *); extern logical lsame_(char *, char *); extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, complex *, integer *), chpmv_(char *, integer *, complex *, complex *, complex *, integer *, complex *, complex *, integer *), cswap_(integer *, complex *, integer *, complex *, integer *); static integer kstep; static logical upper; static real ak; static integer kc, kp, kx; extern /* Subroutine */ int xerbla_(char *, integer *); static integer kcnext, kpc, npp; static real akp1; #define WORK(I) work[(I)-1] #define IPIV(I) ipiv[(I)-1] #define AP(I) ap[(I)-1] *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_("CHPTRI", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Check that the diagonal matrix D is nonsingular. */ if (upper) { /* Upper triangular storage: examine D from bottom to top */ kp = *n * (*n + 1) / 2; for (*info = *n; *info >= 1; --(*info)) { i__1 = kp; if (IPIV(*info) > 0 && (AP(kp).r == 0.f && AP(kp).i == 0.f)) { return 0; } kp -= *info; /* L10: */ } } else { /* Lower triangular storage: examine D from top to bottom. */ kp = 1; i__1 = *n; for (*info = 1; *info <= i__1; ++(*info)) { i__2 = kp; if (IPIV(*info) > 0 && (AP(kp).r == 0.f && AP(kp).i == 0.f)) { return 0; } kp = kp + *n - *info + 1; /* L20: */ } } *info = 0; if (upper) { /* Compute inv(A) from the factorization A = U*D*U'. K is the main loop index, increasing from 1 to N in steps of 1 or 2, depending on the size of the diagonal blocks. */ k = 1; kc = 1; L30: /* If K > N, exit from loop. */ if (k > *n) { goto L50; } kcnext = kc + k; if (IPIV(k) > 0) { /* 1 x 1 diagonal block Invert the diagonal block. */ i__1 = kc + k - 1; i__2 = kc + k - 1; d__1 = 1.f / AP(kc+k-1).r; AP(kc+k-1).r = d__1, AP(kc+k-1).i = 0.f; /* Compute column K of the inverse. */ if (k > 1) { i__1 = k - 1; ccopy_(&i__1, &AP(kc), &c__1, &WORK(1), &c__1); i__1 = k - 1; q__1.r = -1.f, q__1.i = 0.f; chpmv_(uplo, &i__1, &q__1, &AP(1), &WORK(1), &c__1, &c_b2, & AP(kc), &c__1); i__1 = kc + k - 1; i__2 = kc + k - 1; i__3 = k - 1; cdotc_(&q__2, &i__3, &WORK(1), &c__1, &AP(kc), &c__1); d__1 = q__2.r; q__1.r = AP(kc+k-1).r - d__1, q__1.i = AP(kc+k-1).i; AP(kc+k-1).r = q__1.r, AP(kc+k-1).i = q__1.i; } kstep = 1; } else { /* 2 x 2 diagonal block Invert the diagonal block. */ t = c_abs(&AP(kcnext + k - 1)); i__1 = kc + k - 1; ak = AP(kc+k-1).r / t; i__1 = kcnext + k; akp1 = AP(kcnext+k).r / t; i__1 = kcnext + k - 1; q__1.r = AP(kcnext+k-1).r / t, q__1.i = AP(kcnext+k-1).i / t; akkp1.r = q__1.r, akkp1.i = q__1.i; d = t * (ak * akp1 - 1.f); i__1 = kc + k - 1; d__1 = akp1 / d; AP(kc+k-1).r = d__1, AP(kc+k-1).i = 0.f; i__1 = kcnext + k; d__1 = ak / d; AP(kcnext+k).r = d__1, AP(kcnext+k).i = 0.f; i__1 = kcnext + k - 1; q__2.r = -(doublereal)akkp1.r, q__2.i = -(doublereal)akkp1.i; q__1.r = q__2.r / d, q__1.i = q__2.i / d; AP(kcnext+k-1).r = q__1.r, AP(kcnext+k-1).i = q__1.i; /* Compute columns K and K+1 of the inverse. */ if (k > 1) { i__1 = k - 1; ccopy_(&i__1, &AP(kc), &c__1, &WORK(1), &c__1); i__1 = k - 1; q__1.r = -1.f, q__1.i = 0.f; chpmv_(uplo, &i__1, &q__1, &AP(1), &WORK(1), &c__1, &c_b2, & AP(kc), &c__1); i__1 = kc + k - 1; i__2 = kc + k - 1; i__3 = k - 1; cdotc_(&q__2, &i__3, &WORK(1), &c__1, &AP(kc), &c__1); d__1 = q__2.r; q__1.r = AP(kc+k-1).r - d__1, q__1.i = AP(kc+k-1).i; AP(kc+k-1).r = q__1.r, AP(kc+k-1).i = q__1.i; i__1 = kcnext + k - 1; i__2 = kcnext + k - 1; i__3 = k - 1; cdotc_(&q__2, &i__3, &AP(kc), &c__1, &AP(kcnext), &c__1); q__1.r = AP(kcnext+k-1).r - q__2.r, q__1.i = AP(kcnext+k-1).i - q__2.i; AP(kcnext+k-1).r = q__1.r, AP(kcnext+k-1).i = q__1.i; i__1 = k - 1; ccopy_(&i__1, &AP(kcnext), &c__1, &WORK(1), &c__1); i__1 = k - 1; q__1.r = -1.f, q__1.i = 0.f; chpmv_(uplo, &i__1, &q__1, &AP(1), &WORK(1), &c__1, &c_b2, & AP(kcnext), &c__1); i__1 = kcnext + k; i__2 = kcnext + k; i__3 = k - 1; cdotc_(&q__2, &i__3, &WORK(1), &c__1, &AP(kcnext), &c__1); d__1 = q__2.r; q__1.r = AP(kcnext+k).r - d__1, q__1.i = AP(kcnext+k).i; AP(kcnext+k).r = q__1.r, AP(kcnext+k).i = q__1.i; } kstep = 2; kcnext = kcnext + k + 1; } kp = (i__1 = IPIV(k), abs(i__1)); if (kp != k) { /* Interchange rows and columns K and KP in the leading submatrix A(1:k+1,1:k+1) */ kpc = (kp - 1) * kp / 2 + 1; i__1 = kp - 1; cswap_(&i__1, &AP(kc), &c__1, &AP(kpc), &c__1); kx = kpc + kp - 1; i__1 = k - 1; for (j = kp + 1; j <= k-1; ++j) { kx = kx + j - 1; r_cnjg(&q__1, &AP(kc + j - 1)); temp.r = q__1.r, temp.i = q__1.i; i__2 = kc + j - 1; r_cnjg(&q__1, &AP(kx)); AP(kc+j-1).r = q__1.r, AP(kc+j-1).i = q__1.i; i__2 = kx; AP(kx).r = temp.r, AP(kx).i = temp.i; /* L40: */ } i__1 = kc + kp - 1; r_cnjg(&q__1, &AP(kc + kp - 1)); AP(kc+kp-1).r = q__1.r, AP(kc+kp-1).i = q__1.i; i__1 = kc + k - 1; temp.r = AP(kc+k-1).r, temp.i = AP(kc+k-1).i; i__1 = kc + k - 1; i__2 = kpc + kp - 1; AP(kc+k-1).r = AP(kpc+kp-1).r, AP(kc+k-1).i = AP(kpc+kp-1).i; i__1 = kpc + kp - 1; AP(kpc+kp-1).r = temp.r, AP(kpc+kp-1).i = temp.i; if (kstep == 2) { i__1 = kc + k + k - 1; temp.r = AP(kc+k+k-1).r, temp.i = AP(kc+k+k-1).i; i__1 = kc + k + k - 1; i__2 = kc + k + kp - 1; AP(kc+k+k-1).r = AP(kc+k+kp-1).r, AP(kc+k+k-1).i = AP(kc+k+kp-1).i; i__1 = kc + k + kp - 1; AP(kc+k+kp-1).r = temp.r, AP(kc+k+kp-1).i = temp.i; } } k += kstep; kc = kcnext; goto L30; L50: ; } else { /* Compute inv(A) from the factorization A = L*D*L'. K is the main loop index, increasing from 1 to N in steps of 1 or 2, depending on the size of the diagonal blocks. */ npp = *n * (*n + 1) / 2; k = *n; kc = npp; L60: /* If K < 1, exit from loop. */ if (k < 1) { goto L80; } kcnext = kc - (*n - k + 2); if (IPIV(k) > 0) { /* 1 x 1 diagonal block Invert the diagonal block. */ i__1 = kc; i__2 = kc; d__1 = 1.f / AP(kc).r; AP(kc).r = d__1, AP(kc).i = 0.f; /* Compute column K of the inverse. */ if (k < *n) { i__1 = *n - k; ccopy_(&i__1, &AP(kc + 1), &c__1, &WORK(1), &c__1); i__1 = *n - k; q__1.r = -1.f, q__1.i = 0.f; chpmv_(uplo, &i__1, &q__1, &AP(kc + *n - k + 1), &WORK(1), & c__1, &c_b2, &AP(kc + 1), &c__1); i__1 = kc; i__2 = kc; i__3 = *n - k; cdotc_(&q__2, &i__3, &WORK(1), &c__1, &AP(kc + 1), &c__1); d__1 = q__2.r; q__1.r = AP(kc).r - d__1, q__1.i = AP(kc).i; AP(kc).r = q__1.r, AP(kc).i = q__1.i; } kstep = 1; } else { /* 2 x 2 diagonal block Invert the diagonal block. */ t = c_abs(&AP(kcnext + 1)); i__1 = kcnext; ak = AP(kcnext).r / t; i__1 = kc; akp1 = AP(kc).r / t; i__1 = kcnext + 1; q__1.r = AP(kcnext+1).r / t, q__1.i = AP(kcnext+1).i / t; akkp1.r = q__1.r, akkp1.i = q__1.i; d = t * (ak * akp1 - 1.f); i__1 = kcnext; d__1 = akp1 / d; AP(kcnext).r = d__1, AP(kcnext).i = 0.f; i__1 = kc; d__1 = ak / d; AP(kc).r = d__1, AP(kc).i = 0.f; i__1 = kcnext + 1; q__2.r = -(doublereal)akkp1.r, q__2.i = -(doublereal)akkp1.i; q__1.r = q__2.r / d, q__1.i = q__2.i / d; AP(kcnext+1).r = q__1.r, AP(kcnext+1).i = q__1.i; /* Compute columns K-1 and K of the inverse. */ if (k < *n) { i__1 = *n - k; ccopy_(&i__1, &AP(kc + 1), &c__1, &WORK(1), &c__1); i__1 = *n - k; q__1.r = -1.f, q__1.i = 0.f; chpmv_(uplo, &i__1, &q__1, &AP(kc + (*n - k + 1)), &WORK(1), & c__1, &c_b2, &AP(kc + 1), &c__1); i__1 = kc; i__2 = kc; i__3 = *n - k; cdotc_(&q__2, &i__3, &WORK(1), &c__1, &AP(kc + 1), &c__1); d__1 = q__2.r; q__1.r = AP(kc).r - d__1, q__1.i = AP(kc).i; AP(kc).r = q__1.r, AP(kc).i = q__1.i; i__1 = kcnext + 1; i__2 = kcnext + 1; i__3 = *n - k; cdotc_(&q__2, &i__3, &AP(kc + 1), &c__1, &AP(kcnext + 2), & c__1); q__1.r = AP(kcnext+1).r - q__2.r, q__1.i = AP(kcnext+1).i - q__2.i; AP(kcnext+1).r = q__1.r, AP(kcnext+1).i = q__1.i; i__1 = *n - k; ccopy_(&i__1, &AP(kcnext + 2), &c__1, &WORK(1), &c__1); i__1 = *n - k; q__1.r = -1.f, q__1.i = 0.f; chpmv_(uplo, &i__1, &q__1, &AP(kc + (*n - k + 1)), &WORK(1), & c__1, &c_b2, &AP(kcnext + 2), &c__1); i__1 = kcnext; i__2 = kcnext; i__3 = *n - k; cdotc_(&q__2, &i__3, &WORK(1), &c__1, &AP(kcnext + 2), &c__1); d__1 = q__2.r; q__1.r = AP(kcnext).r - d__1, q__1.i = AP(kcnext).i; AP(kcnext).r = q__1.r, AP(kcnext).i = q__1.i; } kstep = 2; kcnext -= *n - k + 3; } kp = (i__1 = IPIV(k), abs(i__1)); if (kp != k) { /* Interchange rows and columns K and KP in the trailing submatrix A(k-1:n,k-1:n) */ kpc = npp - (*n - kp + 1) * (*n - kp + 2) / 2 + 1; if (kp < *n) { i__1 = *n - kp; cswap_(&i__1, &AP(kc + kp - k + 1), &c__1, &AP(kpc + 1), & c__1); } kx = kc + kp - k; i__1 = kp - 1; for (j = k + 1; j <= kp-1; ++j) { kx = kx + *n - j + 1; r_cnjg(&q__1, &AP(kc + j - k)); temp.r = q__1.r, temp.i = q__1.i; i__2 = kc + j - k; r_cnjg(&q__1, &AP(kx)); AP(kc+j-k).r = q__1.r, AP(kc+j-k).i = q__1.i; i__2 = kx; AP(kx).r = temp.r, AP(kx).i = temp.i; /* L70: */ } i__1 = kc + kp - k; r_cnjg(&q__1, &AP(kc + kp - k)); AP(kc+kp-k).r = q__1.r, AP(kc+kp-k).i = q__1.i; i__1 = kc; temp.r = AP(kc).r, temp.i = AP(kc).i; i__1 = kc; i__2 = kpc; AP(kc).r = AP(kpc).r, AP(kc).i = AP(kpc).i; i__1 = kpc; AP(kpc).r = temp.r, AP(kpc).i = temp.i; if (kstep == 2) { i__1 = kc - *n + k - 1; temp.r = AP(kc-*n+k-1).r, temp.i = AP(kc-*n+k-1).i; i__1 = kc - *n + k - 1; i__2 = kc - *n + kp - 1; AP(kc-*n+k-1).r = AP(kc-*n+kp-1).r, AP(kc-*n+k-1).i = AP(kc-*n+kp-1).i; i__1 = kc - *n + kp - 1; AP(kc-*n+kp-1).r = temp.r, AP(kc-*n+kp-1).i = temp.i; } } k -= kstep; kc = kcnext; goto L60; L80: ; } return 0; /* End of CHPTRI */ } /* chptri_ */
/* 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 */ }