/* zcposv.f -- translated by f2c (version 20061008). You must link the resulting object file with libf2c: on Microsoft Windows system, link with libf2c.lib; on Linux or Unix systems, link with .../path/to/libf2c.a -lm or, if you install libf2c.a in a standard place, with -lf2c -lm -- in that order, at the end of the command line, as in cc *.o -lf2c -lm Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., http://www.netlib.org/f2c/libf2c.zip */ #include "f2c.h" #include "blaswrap.h" /* Table of constant values */ static doublecomplex c_b1 = {-1.,0.}; static doublecomplex c_b2 = {1.,0.}; static integer c__1 = 1; /* Subroutine */ int zcposv_(char *uplo, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublecomplex *work, complex *swork, doublereal *rwork, integer *iter, integer *info) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, work_dim1, work_offset, x_dim1, x_offset, i__1, i__2; doublereal d__1, d__2; /* Builtin functions */ double sqrt(doublereal), d_imag(doublecomplex *); /* Local variables */ integer i__; doublereal cte, eps, anrm; integer ptsa; doublereal rnrm, xnrm; integer ptsx; extern logical lsame_(char *, char *); integer iiter; extern /* Subroutine */ int zhemm_(char *, char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), zlag2c_(integer *, integer *, doublecomplex *, integer *, complex *, integer *, integer *), clag2z_(integer *, integer *, complex *, integer *, doublecomplex *, integer *, integer *), zlat2c_(char *, integer *, doublecomplex *, integer *, complex *, integer *, integer *); extern doublereal dlamch_(char *); extern /* Subroutine */ int xerbla_(char *, integer *); extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *, integer *, doublereal *); extern integer izamax_(integer *, doublecomplex *, integer *); extern /* Subroutine */ int cpotrf_(char *, integer *, complex *, integer *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), cpotrs_(char *, integer *, integer *, complex *, integer *, complex *, integer *, integer *), zpotrf_(char *, integer *, doublecomplex *, integer *, integer *), zpotrs_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex * , integer *, integer *); /* -- LAPACK PROTOTYPE driver routine (version 3.2.1) -- */ /* -- April 2009 -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ /* .. */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZCPOSV computes the solution to a complex system of linear equations */ /* A * X = B, */ /* where A is an N-by-N Hermitian positive definite matrix and X and B */ /* are N-by-NRHS matrices. */ /* ZCPOSV first attempts to factorize the matrix in COMPLEX and use this */ /* factorization within an iterative refinement procedure to produce a */ /* solution with COMPLEX*16 normwise backward error quality (see below). */ /* If the approach fails the method switches to a COMPLEX*16 */ /* factorization and solve. */ /* The iterative refinement is not going to be a winning strategy if */ /* the ratio COMPLEX performance over COMPLEX*16 performance is too */ /* small. A reasonable strategy should take the number of right-hand */ /* sides and the size of the matrix into account. This might be done */ /* with a call to ILAENV in the future. Up to now, we always try */ /* iterative refinement. */ /* The iterative refinement process is stopped if */ /* ITER > ITERMAX */ /* or for all the RHS we have: */ /* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX */ /* where */ /* o ITER is the number of the current iteration in the iterative */ /* refinement process */ /* o RNRM is the infinity-norm of the residual */ /* o XNRM is the infinity-norm of the solution */ /* o ANRM is the infinity-operator-norm of the matrix A */ /* o EPS is the machine epsilon returned by DLAMCH('Epsilon') */ /* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00 */ /* respectively. */ /* Arguments */ /* ========= */ /* UPLO (input) CHARACTER */ /* = 'U': Upper triangle of A is stored; */ /* = 'L': Lower triangle of A is stored. */ /* N (input) INTEGER */ /* The number of linear equations, i.e., 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 matrix B. NRHS >= 0. */ /* A (input or input/ouptut) COMPLEX*16 array, */ /* dimension (LDA,N) */ /* On entry, the Hermitian matrix A. If UPLO = 'U', the leading */ /* N-by-N upper triangular part of A contains the upper */ /* triangular part of the matrix A, and the strictly lower */ /* triangular part of A is not referenced. If UPLO = 'L', the */ /* leading N-by-N lower triangular part of A contains the lower */ /* triangular part of the matrix A, and the strictly upper */ /* triangular part of A is not referenced. */ /* Note that the imaginary parts of the diagonal */ /* elements need not be set and are assumed to be zero. */ /* On exit, if iterative refinement has been successfully used */ /* (INFO.EQ.0 and ITER.GE.0, see description below), then A is */ /* unchanged, if double precision factorization has been used */ /* (INFO.EQ.0 and ITER.LT.0, see description below), then the */ /* array A contains the factor U or L from the Cholesky */ /* factorization A = U**H*U or A = L*L**H. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,N). */ /* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */ /* The N-by-NRHS right hand side matrix B. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= max(1,N). */ /* X (output) COMPLEX*16 array, dimension (LDX,NRHS) */ /* If INFO = 0, the N-by-NRHS solution matrix X. */ /* LDX (input) INTEGER */ /* The leading dimension of the array X. LDX >= max(1,N). */ /* WORK (workspace) COMPLEX*16 array, dimension (N*NRHS) */ /* This array is used to hold the residual vectors. */ /* SWORK (workspace) COMPLEX array, dimension (N*(N+NRHS)) */ /* This array is used to use the single precision matrix and the */ /* right-hand sides or solutions in single precision. */ /* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */ /* ITER (output) INTEGER */ /* < 0: iterative refinement has failed, COMPLEX*16 */ /* factorization has been performed */ /* -1 : the routine fell back to full precision for */ /* implementation- or machine-specific reasons */ /* -2 : narrowing the precision induced an overflow, */ /* the routine fell back to full precision */ /* -3 : failure of CPOTRF */ /* -31: stop the iterative refinement after the 30th */ /* iterations */ /* > 0: iterative refinement has been sucessfully used. */ /* Returns the number of iterations */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* > 0: if INFO = i, the leading minor of order i of */ /* (COMPLEX*16) A is not positive definite, so the */ /* factorization could not be completed, and the solution */ /* has not been computed. */ /* ========= */ /* .. Parameters .. */ /* .. Local Scalars .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. Statement Functions .. */ /* .. */ /* .. Statement Function definitions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ work_dim1 = *n; work_offset = 1 + work_dim1; work -= work_offset; a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; x_dim1 = *ldx; x_offset = 1 + x_dim1; x -= x_offset; --swork; --rwork; /* Function Body */ *info = 0; *iter = 0; /* Test the input parameters. */ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*nrhs < 0) { *info = -3; } else if (*lda < max(1,*n)) { *info = -5; } else if (*ldb < max(1,*n)) { *info = -7; } else if (*ldx < max(1,*n)) { *info = -9; } if (*info != 0) { i__1 = -(*info); xerbla_("ZCPOSV", &i__1); return 0; } /* Quick return if (N.EQ.0). */ if (*n == 0) { return 0; } /* Skip single precision iterative refinement if a priori slower */ /* than double precision factorization. */ if (FALSE_) { *iter = -1; goto L40; } /* Compute some constants. */ anrm = zlanhe_("I", uplo, n, &a[a_offset], lda, &rwork[1]); eps = dlamch_("Epsilon"); cte = anrm * eps * sqrt((doublereal) (*n)) * 1.; /* Set the indices PTSA, PTSX for referencing SA and SX in SWORK. */ ptsa = 1; ptsx = ptsa + *n * *n; /* Convert B from double precision to single precision and store the */ /* result in SX. */ zlag2c_(n, nrhs, &b[b_offset], ldb, &swork[ptsx], n, info); if (*info != 0) { *iter = -2; goto L40; } /* Convert A from double precision to single precision and store the */ /* result in SA. */ zlat2c_(uplo, n, &a[a_offset], lda, &swork[ptsa], n, info); if (*info != 0) { *iter = -2; goto L40; } /* Compute the Cholesky factorization of SA. */ cpotrf_(uplo, n, &swork[ptsa], n, info); if (*info != 0) { *iter = -3; goto L40; } /* Solve the system SA*SX = SB. */ cpotrs_(uplo, n, nrhs, &swork[ptsa], n, &swork[ptsx], n, info); /* Convert SX back to COMPLEX*16 */ clag2z_(n, nrhs, &swork[ptsx], n, &x[x_offset], ldx, info); /* Compute R = B - AX (R is WORK). */ zlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n); zhemm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset], ldx, &c_b2, &work[work_offset], n); /* Check whether the NRHS normwise backward errors satisfy the */ /* stopping criterion. If yes, set ITER=0 and return. */ i__1 = *nrhs; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = izamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ * x_dim1; xnrm = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x[izamax_(n, & x[i__ * x_dim1 + 1], &c__1) + i__ * x_dim1]), abs(d__2)); i__2 = izamax_(n, &work[i__ * work_dim1 + 1], &c__1) + i__ * work_dim1; rnrm = (d__1 = work[i__2].r, abs(d__1)) + (d__2 = d_imag(&work[ izamax_(n, &work[i__ * work_dim1 + 1], &c__1) + i__ * work_dim1]), abs(d__2)); if (rnrm > xnrm * cte) { goto L10; } } /* If we are here, the NRHS normwise backward errors satisfy the */ /* stopping criterion. We are good to exit. */ *iter = 0; return 0; L10: for (iiter = 1; iiter <= 30; ++iiter) { /* Convert R (in WORK) from double precision to single precision */ /* and store the result in SX. */ zlag2c_(n, nrhs, &work[work_offset], n, &swork[ptsx], n, info); if (*info != 0) { *iter = -2; goto L40; } /* Solve the system SA*SX = SR. */ cpotrs_(uplo, n, nrhs, &swork[ptsa], n, &swork[ptsx], n, info); /* Convert SX back to double precision and update the current */ /* iterate. */ clag2z_(n, nrhs, &swork[ptsx], n, &work[work_offset], n, info); i__1 = *nrhs; for (i__ = 1; i__ <= i__1; ++i__) { zaxpy_(n, &c_b2, &work[i__ * work_dim1 + 1], &c__1, &x[i__ * x_dim1 + 1], &c__1); } /* Compute R = B - AX (R is WORK). */ zlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n); zhemm_("L", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset], ldx, &c_b2, &work[work_offset], n); /* Check whether the NRHS normwise backward errors satisfy the */ /* stopping criterion. If yes, set ITER=IITER>0 and return. */ i__1 = *nrhs; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = izamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ * x_dim1; xnrm = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x[izamax_( n, &x[i__ * x_dim1 + 1], &c__1) + i__ * x_dim1]), abs( d__2)); i__2 = izamax_(n, &work[i__ * work_dim1 + 1], &c__1) + i__ * work_dim1; rnrm = (d__1 = work[i__2].r, abs(d__1)) + (d__2 = d_imag(&work[ izamax_(n, &work[i__ * work_dim1 + 1], &c__1) + i__ * work_dim1]), abs(d__2)); if (rnrm > xnrm * cte) { goto L20; } } /* If we are here, the NRHS normwise backward errors satisfy the */ /* stopping criterion, we are good to exit. */ *iter = iiter; return 0; L20: /* L30: */ ; } /* If we are at this place of the code, this is because we have */ /* performed ITER=ITERMAX iterations and never satisified the */ /* stopping criterion, set up the ITER flag accordingly and follow */ /* up on double precision routine. */ *iter = -31; L40: /* Single-precision iterative refinement failed to converge to a */ /* satisfactory solution, so we resort to double precision. */ zpotrf_(uplo, n, &a[a_offset], lda, info); if (*info != 0) { return 0; } zlacpy_("All", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); zpotrs_(uplo, n, nrhs, &a[a_offset], lda, &x[x_offset], ldx, info); return 0; /* End of ZCPOSV. */ } /* zcposv_ */