示例#1
0
/* Subroutine */ int cpptrs_(char *uplo, integer *n, integer *nrhs, complex *
	ap, complex *b, integer *ldb, 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   
    =======   

    CPPTRS solves a system of linear equations A*X = B with a Hermitian   
    positive definite matrix A in packed storage using the Cholesky   
    factorization A = U**H*U or A = L*L**H computed by CPPTRF.   

    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 matrix B.  NRHS >= 0.   

    AP      (input) COMPLEX array, dimension (N*(N+1)/2)   
            The triangular factor U or L from the Cholesky factorization 
  
            A = U**H*U or A = L*L**H, packed columnwise in 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.   

    B       (input/output) COMPLEX array, dimension (LDB,NRHS)   
            On entry, the right hand side matrix B.   
            On exit, the solution matrix X.   

    LDB     (input) INTEGER   
            The leading dimension of the array B.  LDB >= max(1,N).   

    INFO    (output) INTEGER   
            = 0:  successful exit   
            < 0:  if INFO = -i, the i-th argument had an illegal value   

    ===================================================================== 
  


       Test the input parameters.   

    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static integer c__1 = 1;
    
    /* System generated locals */
    integer b_dim1, b_offset, i__1;
    /* Local variables */
    static integer i;
    extern logical lsame_(char *, char *);
    static logical upper;
    extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *, 
	    complex *, complex *, integer *), xerbla_(
	    char *, integer *);



#define AP(I) ap[(I)-1]

#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]

    *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 = -6;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("CPPTRS", &i__1);
	return 0;
    }

/*     Quick return if possible */

    if (*n == 0 || *nrhs == 0) {
	return 0;
    }

    if (upper) {

/*        Solve A*X = B where A = U'*U. */

	i__1 = *nrhs;
	for (i = 1; i <= *nrhs; ++i) {

/*           Solve U'*X = B, overwriting B with X. */

	    ctpsv_("Upper", "Conjugate transpose", "Non-unit", n, &AP(1), &B(1,i), &c__1);

/*           Solve U*X = B, overwriting B with X. */

	    ctpsv_("Upper", "No transpose", "Non-unit", n, &AP(1), &B(1,i), &c__1);
/* L10: */
	}
    } else {

/*        Solve A*X = B where A = L*L'. */

	i__1 = *nrhs;
	for (i = 1; i <= *nrhs; ++i) {

/*           Solve L*Y = B, overwriting B with X. */

	    ctpsv_("Lower", "No transpose", "Non-unit", n, &AP(1), &B(1,i), &c__1);

/*           Solve L'*X = Y, overwriting B with X. */

	    ctpsv_("Lower", "Conjugate transpose", "Non-unit", n, &AP(1), &B(1,i), &c__1);
/* L20: */
	}
    }

    return 0;

/*     End of CPPTRS */

} /* cpptrs_ */
示例#2
0
/* Subroutine */ int ctptrs_(char *uplo, char *trans, char *diag, integer *n, 
	integer *nrhs, complex *ap, complex *b, integer *ldb, integer *info)
{
    /* System generated locals */
    integer b_dim1, b_offset, i__1, i__2;

    /* Local variables */
    integer j, jc;
    logical upper;
    logical nounit;

/*  -- LAPACK routine (version 3.2) -- */
/*     November 2006 */

/*  Purpose */
/*  ======= */

/*  CTPTRS solves a triangular system of the form */

/*     A * X = B,  A**T * X = B,  or  A**H * X = B, */

/*  where A is a triangular matrix of order N stored in packed format, */
/*  and B is an N-by-NRHS matrix.  A check is made to verify that A is */
/*  nonsingular. */

/*  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 matrix 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(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. */

/*  B       (input/output) COMPLEX array, dimension (LDB,NRHS) */
/*          On entry, the right hand side matrix B. */
/*          On exit, if INFO = 0, the solution matrix X. */

/*  LDB     (input) INTEGER */
/*          The leading dimension of the array B.  LDB >= max(1,N). */

/*  INFO    (output) INTEGER */
/*          = 0:  successful exit */
/*          < 0:  if INFO = -i, the i-th argument had an illegal value */
/*          > 0:  if INFO = i, the i-th diagonal element of A is zero, */
/*                indicating that the matrix is singular and the */
/*                solutions X have not been computed. */

/*  ===================================================================== */

/*     Test the input parameters. */

    /* Parameter adjustments */
    --ap;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1;
    b -= b_offset;

    /* Function Body */
    *info = 0;
    upper = lsame_(uplo, "U");
    nounit = lsame_(diag, "N");
    if (! upper && ! lsame_(uplo, "L")) {
	*info = -1;
    } else if (! lsame_(trans, "N") && ! 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;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("CTPTRS", &i__1);
	return 0;
    }

/*     Quick return if possible */

    if (*n == 0) {
	return 0;
    }

/*     Check for singularity. */

    if (nounit) {
	if (upper) {
	    jc = 1;
	    i__1 = *n;
	    for (*info = 1; *info <= i__1; ++(*info)) {
		i__2 = jc + *info - 1;
		if (ap[i__2].r == 0.f && ap[i__2].i == 0.f) {
		    return 0;
		}
		jc += *info;
	    }
	} else {
	    jc = 1;
	    i__1 = *n;
	    for (*info = 1; *info <= i__1; ++(*info)) {
		i__2 = jc;
		if (ap[i__2].r == 0.f && ap[i__2].i == 0.f) {
		    return 0;
		}
		jc = jc + *n - *info + 1;
	    }
	}
    }
    *info = 0;

/*     Solve  A * x = b,  A**T * x = b,  or  A**H * x = b. */

    i__1 = *nrhs;
    for (j = 1; j <= i__1; ++j) {
	ctpsv_(uplo, trans, diag, n, &ap[1], &b[j * b_dim1 + 1], &c__1);
    }

    return 0;

/*     End of CTPTRS */

} /* ctptrs_ */
示例#3
0
/* 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_ */
示例#4
0
/* Subroutine */ int cpptrs_(char *uplo, integer *n, integer *nrhs, complex *
	ap, complex *b, integer *ldb, integer *info, ftnlen uplo_len)
{
    /* System generated locals */
    integer b_dim1, b_offset, i__1;

    /* Local variables */
    static integer i__;
    extern logical lsame_(char *, char *, ftnlen, ftnlen);
    static logical upper;
    extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *, 
	    complex *, complex *, integer *, ftnlen, ftnlen, ftnlen), 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 */
/*  ======= */

/*  CPPTRS solves a system of linear equations A*X = B with a Hermitian */
/*  positive definite matrix A in packed storage using the Cholesky */
/*  factorization A = U**H*U or A = L*L**H computed by CPPTRF. */

/*  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 matrix B.  NRHS >= 0. */

/*  AP      (input) COMPLEX array, dimension (N*(N+1)/2) */
/*          The triangular factor U or L from the Cholesky factorization */
/*          A = U**H*U or A = L*L**H, packed columnwise in 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. */

/*  B       (input/output) COMPLEX array, dimension (LDB,NRHS) */
/*          On entry, the right hand side matrix B. */
/*          On exit, the solution matrix X. */

/*  LDB     (input) INTEGER */
/*          The leading dimension of the array B.  LDB >= max(1,N). */

/*  INFO    (output) INTEGER */
/*          = 0:  successful exit */
/*          < 0:  if INFO = -i, the i-th argument had an illegal value */

/*  ===================================================================== */

/*     .. Local Scalars .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Executable Statements .. */

/*     Test the input parameters. */

    /* Parameter adjustments */
    --ap;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1;
    b -= b_offset;

    /* Function Body */
    *info = 0;
    upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
    if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    } else if (*nrhs < 0) {
	*info = -3;
    } else if (*ldb < max(1,*n)) {
	*info = -6;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("CPPTRS", &i__1, (ftnlen)6);
	return 0;
    }

/*     Quick return if possible */

    if (*n == 0 || *nrhs == 0) {
	return 0;
    }

    if (upper) {

/*        Solve A*X = B where A = U'*U. */

	i__1 = *nrhs;
	for (i__ = 1; i__ <= i__1; ++i__) {

/*           Solve U'*X = B, overwriting B with X. */

	    ctpsv_("Upper", "Conjugate transpose", "Non-unit", n, &ap[1], &b[
		    i__ * b_dim1 + 1], &c__1, (ftnlen)5, (ftnlen)19, (ftnlen)
		    8);

/*           Solve U*X = B, overwriting B with X. */

	    ctpsv_("Upper", "No transpose", "Non-unit", n, &ap[1], &b[i__ * 
		    b_dim1 + 1], &c__1, (ftnlen)5, (ftnlen)12, (ftnlen)8);
/* L10: */
	}
    } else {

/*        Solve A*X = B where A = L*L'. */

	i__1 = *nrhs;
	for (i__ = 1; i__ <= i__1; ++i__) {

/*           Solve L*Y = B, overwriting B with X. */

	    ctpsv_("Lower", "No transpose", "Non-unit", n, &ap[1], &b[i__ * 
		    b_dim1 + 1], &c__1, (ftnlen)5, (ftnlen)12, (ftnlen)8);

/*           Solve L'*X = Y, overwriting B with X. */

	    ctpsv_("Lower", "Conjugate transpose", "Non-unit", n, &ap[1], &b[
		    i__ * b_dim1 + 1], &c__1, (ftnlen)5, (ftnlen)19, (ftnlen)
		    8);
/* L20: */
	}
    }

    return 0;

/*     End of CPPTRS */

} /* cpptrs_ */
示例#5
0
/* Subroutine */ int ctptrs_(char *uplo, char *trans, char *diag, integer *n, 
	integer *nrhs, complex *ap, complex *b, integer *ldb, integer *info)
{
/*  -- LAPACK routine (version 3.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       September 30, 1994   


    Purpose   
    =======   

    CTPTRS solves a triangular system of the form   

       A * X = B,  A**T * X = B,  or  A**H * X = B,   

    where A is a triangular matrix of order N stored in packed format,   
    and B is an N-by-NRHS matrix.  A check is made to verify that A is   
    nonsingular.   

    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 matrix 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(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.   

    B       (input/output) COMPLEX array, dimension (LDB,NRHS)   
            On entry, the right hand side matrix B.   
            On exit, if INFO = 0, the solution matrix X.   

    LDB     (input) INTEGER   
            The leading dimension of the array B.  LDB >= max(1,N).   

    INFO    (output) INTEGER   
            = 0:  successful exit   
            < 0:  if INFO = -i, the i-th argument had an illegal value   
            > 0:  if INFO = i, the i-th diagonal element of A is zero,   
                  indicating that the matrix is singular and the   
                  solutions X have not been computed.   

    =====================================================================   


       Test the input parameters.   

       Parameter adjustments */
    /* Table of constant values */
    static integer c__1 = 1;
    
    /* System generated locals */
    integer b_dim1, b_offset, i__1, i__2;
    /* Local variables */
    static integer j;
    extern logical lsame_(char *, char *);
    static logical upper;
    extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *, 
	    complex *, complex *, integer *);
    static integer jc;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    static logical nounit;
#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)]


    --ap;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1 * 1;
    b -= b_offset;

    /* Function Body */
    *info = 0;
    upper = lsame_(uplo, "U");
    nounit = lsame_(diag, "N");
    if (! upper && ! lsame_(uplo, "L")) {
	*info = -1;
    } else if (! lsame_(trans, "N") && ! 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;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("CTPTRS", &i__1);
	return 0;
    }

/*     Quick return if possible */

    if (*n == 0) {
	return 0;
    }

/*     Check for singularity. */

    if (nounit) {
	if (upper) {
	    jc = 1;
	    i__1 = *n;
	    for (*info = 1; *info <= i__1; ++(*info)) {
		i__2 = jc + *info - 1;
		if (ap[i__2].r == 0.f && ap[i__2].i == 0.f) {
		    return 0;
		}
		jc += *info;
/* L10: */
	    }
	} else {
	    jc = 1;
	    i__1 = *n;
	    for (*info = 1; *info <= i__1; ++(*info)) {
		i__2 = jc;
		if (ap[i__2].r == 0.f && ap[i__2].i == 0.f) {
		    return 0;
		}
		jc = jc + *n - *info + 1;
/* L20: */
	    }
	}
    }
    *info = 0;

/*     Solve  A * x = b,  A**T * x = b,  or  A**H * x = b. */

    i__1 = *nrhs;
    for (j = 1; j <= i__1; ++j) {
	ctpsv_(uplo, trans, diag, n, &ap[1], &b_ref(1, j), &c__1);
/* L30: */
    }

    return 0;

/*     End of CTPTRS */

} /* ctptrs_ */
示例#6
0
文件: cpptrs.c 项目: csapng/libflame
/* Subroutine */
int cpptrs_(char *uplo, integer *n, integer *nrhs, complex * ap, complex *b, integer *ldb, integer *info)
{
    /* System generated locals */
    integer b_dim1, b_offset, i__1;
    /* Local variables */
    integer i__;
    extern logical lsame_(char *, char *);
    logical upper;
    extern /* Subroutine */
    int ctpsv_(char *, char *, char *, integer *, complex *, 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 .. */
    /* .. */
    /* ===================================================================== */
    /* .. Local Scalars .. */
    /* .. */
    /* .. External Functions .. */
    /* .. */
    /* .. External Subroutines .. */
    /* .. */
    /* .. Intrinsic Functions .. */
    /* .. */
    /* .. Executable Statements .. */
    /* Test the input parameters. */
    /* Parameter adjustments */
    --ap;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1;
    b -= b_offset;
    /* 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 = -6;
    }
    if (*info != 0)
    {
        i__1 = -(*info);
        xerbla_("CPPTRS", &i__1);
        return 0;
    }
    /* Quick return if possible */
    if (*n == 0 || *nrhs == 0)
    {
        return 0;
    }
    if (upper)
    {
        /* Solve A*X = B where A = U**H * U. */
        i__1 = *nrhs;
        for (i__ = 1;
                i__ <= i__1;
                ++i__)
        {
            /* Solve U**H *X = B, overwriting B with X. */
            ctpsv_("Upper", "Conjugate transpose", "Non-unit", n, &ap[1], &b[ i__ * b_dim1 + 1], &c__1);
            /* Solve U*X = B, overwriting B with X. */
            ctpsv_("Upper", "No transpose", "Non-unit", n, &ap[1], &b[i__ * b_dim1 + 1], &c__1);
            /* L10: */
        }
    }
    else
    {
        /* Solve A*X = B where A = L * L**H. */
        i__1 = *nrhs;
        for (i__ = 1;
                i__ <= i__1;
                ++i__)
        {
            /* Solve L*Y = B, overwriting B with X. */
            ctpsv_("Lower", "No transpose", "Non-unit", n, &ap[1], &b[i__ * b_dim1 + 1], &c__1);
            /* Solve L**H *X = Y, overwriting B with X. */
            ctpsv_("Lower", "Conjugate transpose", "Non-unit", n, &ap[1], &b[ i__ * b_dim1 + 1], &c__1);
            /* L20: */
        }
    }
    return 0;
    /* End of CPPTRS */
}
示例#7
0
/* Subroutine */ int cpptrf_(char *uplo, 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   
    =======   

    CPPTRF computes the Cholesky factorization of a complex Hermitian   
    positive definite matrix A stored in packed format.   

    The factorization has the form   
       A = U**H * U,  if UPLO = 'U', or   
       A = L  * L**H,  if UPLO = 'L',   
    where U is an upper triangular matrix and L is lower triangular.   

    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)*(2n-j)/2) = A(i,j) for j<=i<=n.   
            See below for further details.   

            On exit, if INFO = 0, the triangular factor U or L from the   
            Cholesky factorization A = U**H*U or A = L*L**H, in the same   
            storage format as A.   

    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 is not   
                  positive definite, and the factorization could not be   
                  completed.   

    Further Details   
    ===============   

    The packed storage scheme is illustrated by the following example   
    when N = 4, UPLO = 'U':   

    Two-dimensional storage of the Hermitian matrix A:   

       a11 a12 a13 a14   
           a22 a23 a24   
               a33 a34     (aij = conjg(aji))   
                   a44   

    Packed storage of the upper triangle of A:   

    AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]   

    =====================================================================   


       Test the input parameters.   

       Parameter adjustments */
    /* Table of constant values */
    static integer c__1 = 1;
    static real c_b16 = -1.f;
    
    /* System generated locals */
    integer i__1, i__2, i__3;
    real r__1;
    complex q__1, q__2;
    /* Builtin functions */
    double sqrt(doublereal);
    /* Local variables */
    extern /* Subroutine */ int chpr_(char *, integer *, real *, complex *, 
	    integer *, complex *);
    static integer j;
    extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer 
	    *, complex *, integer *);
    extern logical lsame_(char *, char *);
    static logical upper;
    extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *, 
	    complex *, complex *, integer *);
    static integer jc, jj;
    extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer 
	    *), xerbla_(char *, integer *);
    static real ajj;


    --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_("CPPTRF", &i__1);
	return 0;
    }

/*     Quick return if possible */

    if (*n == 0) {
	return 0;
    }

    if (upper) {

/*        Compute the Cholesky factorization A = U'*U. */

	jj = 0;
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    jc = jj + 1;
	    jj += j;

/*           Compute elements 1:J-1 of column J. */

	    if (j > 1) {
		i__2 = j - 1;
		ctpsv_("Upper", "Conjugate transpose", "Non-unit", &i__2, &ap[
			1], &ap[jc], &c__1);
	    }

/*           Compute U(J,J) and test for non-positive-definiteness. */

	    i__2 = jj;
	    r__1 = ap[i__2].r;
	    i__3 = j - 1;
	    cdotc_(&q__2, &i__3, &ap[jc], &c__1, &ap[jc], &c__1);
	    q__1.r = r__1 - q__2.r, q__1.i = -q__2.i;
	    ajj = q__1.r;
	    if (ajj <= 0.f) {
		i__2 = jj;
		ap[i__2].r = ajj, ap[i__2].i = 0.f;
		goto L30;
	    }
	    i__2 = jj;
	    r__1 = sqrt(ajj);
	    ap[i__2].r = r__1, ap[i__2].i = 0.f;
/* L10: */
	}
    } else {

/*        Compute the Cholesky factorization A = L*L'. */

	jj = 1;
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {

/*           Compute L(J,J) and test for non-positive-definiteness. */

	    i__2 = jj;
	    ajj = ap[i__2].r;
	    if (ajj <= 0.f) {
		i__2 = jj;
		ap[i__2].r = ajj, ap[i__2].i = 0.f;
		goto L30;
	    }
	    ajj = sqrt(ajj);
	    i__2 = jj;
	    ap[i__2].r = ajj, ap[i__2].i = 0.f;

/*           Compute elements J+1:N of column J and update the trailing   
             submatrix. */

	    if (j < *n) {
		i__2 = *n - j;
		r__1 = 1.f / ajj;
		csscal_(&i__2, &r__1, &ap[jj + 1], &c__1);
		i__2 = *n - j;
		chpr_("Lower", &i__2, &c_b16, &ap[jj + 1], &c__1, &ap[jj + *n 
			- j + 1]);
		jj = jj + *n - j + 1;
	    }
/* L20: */
	}
    }
    goto L40;

L30:
    *info = j;

L40:
    return 0;

/*     End of CPPTRF */

} /* cpptrf_ */
示例#8
0
/* 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_ */
示例#9
0
文件: clatps.c 项目: csapng/libflame
/* Subroutine */
int clatps_(char *uplo, char *trans, char *diag, char * normin, integer *n, complex *ap, complex *x, real *scale, real *cnorm, integer *info)
{
    /* System generated locals */
    integer i__1, i__2, i__3, i__4, i__5;
    real r__1, r__2, r__3, r__4;
    complex q__1, q__2, q__3, q__4;
    /* Builtin functions */
    double r_imag(complex *);
    void r_cnjg(complex *, complex *);
    /* Local variables */
    integer i__, j, ip;
    real xj, rec, tjj;
    integer jinc, jlen;
    real xbnd;
    integer imax;
    real tmax;
    complex tjjs;
    real xmax, grow;
    extern /* Complex */
    VOID cdotc_f2c_(complex *, integer *, complex *, integer *, complex *, integer *);
    extern logical lsame_(char *, char *);
    extern /* Subroutine */
    int sscal_(integer *, real *, real *, integer *);
    real tscal;
    complex uscal;
    integer jlast;
    extern /* Complex */
    VOID cdotu_f2c_(complex *, integer *, complex *, integer *, complex *, integer *);
    complex csumj;
    extern /* Subroutine */
    int caxpy_(integer *, complex *, complex *, integer *, complex *, integer *);
    logical upper;
    extern /* Subroutine */
    int ctpsv_(char *, char *, char *, integer *, complex *, complex *, integer *), slabad_( real *, real *);
    extern integer icamax_(integer *, complex *, integer *);
    extern /* Complex */
    VOID cladiv_(complex *, complex *, complex *);
    extern real slamch_(char *);
    extern /* Subroutine */
    int csscal_(integer *, real *, complex *, integer *), xerbla_(char *, integer *);
    real bignum;
    extern integer isamax_(integer *, real *, integer *);
    extern real scasum_(integer *, complex *, integer *);
    logical notran;
    integer jfirst;
    real smlnum;
    logical nounit;
    /* -- LAPACK auxiliary routine (version 3.4.2) -- */
    /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
    /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
    /* September 2012 */
    /* .. Scalar Arguments .. */
    /* .. */
    /* .. Array Arguments .. */
    /* .. */
    /* ===================================================================== */
    /* .. Parameters .. */
    /* .. */
    /* .. Local Scalars .. */
    /* .. */
    /* .. External Functions .. */
    /* .. */
    /* .. External Subroutines .. */
    /* .. */
    /* .. Intrinsic Functions .. */
    /* .. */
    /* .. Statement Functions .. */
    /* .. */
    /* .. Statement Function definitions .. */
    /* .. */
    /* .. Executable Statements .. */
    /* Parameter adjustments */
    --cnorm;
    --x;
    --ap;
    /* Function Body */
    *info = 0;
    upper = lsame_(uplo, "U");
    notran = lsame_(trans, "N");
    nounit = lsame_(diag, "N");
    /* Test the input parameters. */
    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 (! lsame_(normin, "Y") && ! lsame_(normin, "N"))
    {
        *info = -4;
    }
    else if (*n < 0)
    {
        *info = -5;
    }
    if (*info != 0)
    {
        i__1 = -(*info);
        xerbla_("CLATPS", &i__1);
        return 0;
    }
    /* Quick return if possible */
    if (*n == 0)
    {
        return 0;
    }
    /* Determine machine dependent parameters to control overflow. */
    smlnum = slamch_("Safe minimum");
    bignum = 1.f / smlnum;
    slabad_(&smlnum, &bignum);
    smlnum /= slamch_("Precision");
    bignum = 1.f / smlnum;
    *scale = 1.f;
    if (lsame_(normin, "N"))
    {
        /* Compute the 1-norm of each column, not including the diagonal. */
        if (upper)
        {
            /* A is upper triangular. */
            ip = 1;
            i__1 = *n;
            for (j = 1;
                    j <= i__1;
                    ++j)
            {
                i__2 = j - 1;
                cnorm[j] = scasum_(&i__2, &ap[ip], &c__1);
                ip += j;
                /* L10: */
            }
        }
        else
        {
            /* A is lower triangular. */
            ip = 1;
            i__1 = *n - 1;
            for (j = 1;
                    j <= i__1;
                    ++j)
            {
                i__2 = *n - j;
                cnorm[j] = scasum_(&i__2, &ap[ip + 1], &c__1);
                ip = ip + *n - j + 1;
                /* L20: */
            }
            cnorm[*n] = 0.f;
        }
    }
    /* Scale the column norms by TSCAL if the maximum element in CNORM is */
    /* greater than BIGNUM/2. */
    imax = isamax_(n, &cnorm[1], &c__1);
    tmax = cnorm[imax];
    if (tmax <= bignum * .5f)
    {
        tscal = 1.f;
    }
    else
    {
        tscal = .5f / (smlnum * tmax);
        sscal_(n, &tscal, &cnorm[1], &c__1);
    }
    /* Compute a bound on the computed solution vector to see if the */
    /* Level 2 BLAS routine CTPSV can be used. */
    xmax = 0.f;
    i__1 = *n;
    for (j = 1;
            j <= i__1;
            ++j)
    {
        /* Computing MAX */
        i__2 = j;
        r__3 = xmax;
        r__4 = (r__1 = x[i__2].r / 2.f, abs(r__1)) + (r__2 = r_imag(&x[j]) / 2.f, abs(r__2)); // , expr subst
        xmax = max(r__3,r__4);
        /* L30: */
    }
    xbnd = xmax;
    if (notran)
    {
        /* Compute the growth in A * x = b. */
        if (upper)
        {
            jfirst = *n;
            jlast = 1;
            jinc = -1;
        }
        else
        {
            jfirst = 1;
            jlast = *n;
            jinc = 1;
        }
        if (tscal != 1.f)
        {
            grow = 0.f;
            goto L60;
        }
        if (nounit)
        {
            /* A is non-unit triangular. */
            /* Compute GROW = 1/G(j) and XBND = 1/M(j). */
            /* Initially, G(0) = max{
            x(i), i=1,...,n}
            . */
            grow = .5f / max(xbnd,smlnum);
            xbnd = grow;
            ip = jfirst * (jfirst + 1) / 2;
            jlen = *n;
            i__1 = jlast;
            i__2 = jinc;
            for (j = jfirst;
                    i__2 < 0 ? j >= i__1 : j <= i__1;
                    j += i__2)
            {
                /* Exit the loop if the growth factor is too small. */
                if (grow <= smlnum)
                {
                    goto L60;
                }
                i__3 = ip;
                tjjs.r = ap[i__3].r;
                tjjs.i = ap[i__3].i; // , expr subst
                tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs( r__2));
                if (tjj >= smlnum)
                {
                    /* M(j) = G(j-1) / abs(A(j,j)) */
                    /* Computing MIN */
                    r__1 = xbnd;
                    r__2 = min(1.f,tjj) * grow; // , expr subst
                    xbnd = min(r__1,r__2);
                }
                else
                {
                    /* M(j) could overflow, set XBND to 0. */
                    xbnd = 0.f;
                }
                if (tjj + cnorm[j] >= smlnum)
                {
                    /* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */
                    grow *= tjj / (tjj + cnorm[j]);
                }
                else
                {
                    /* G(j) could overflow, set GROW to 0. */
                    grow = 0.f;
                }
                ip += jinc * jlen;
                --jlen;
                /* L40: */
            }
            grow = xbnd;
        }
        else
        {
            /* A is unit triangular. */
            /* Compute GROW = 1/G(j), where G(0) = max{
            x(i), i=1,...,n}
            . */
            /* Computing MIN */
            r__1 = 1.f;
            r__2 = .5f / max(xbnd,smlnum); // , expr subst
            grow = min(r__1,r__2);
            i__2 = jlast;
            i__1 = jinc;
            for (j = jfirst;
                    i__1 < 0 ? j >= i__2 : j <= i__2;
                    j += i__1)
            {
                /* Exit the loop if the growth factor is too small. */
                if (grow <= smlnum)
                {
                    goto L60;
                }
                /* G(j) = G(j-1)*( 1 + CNORM(j) ) */
                grow *= 1.f / (cnorm[j] + 1.f);
                /* L50: */
            }
        }
L60:
        ;
    }
    else
    {
        /* Compute the growth in A**T * x = b or A**H * x = b. */
        if (upper)
        {
            jfirst = 1;
            jlast = *n;
            jinc = 1;
        }
        else
        {
            jfirst = *n;
            jlast = 1;
            jinc = -1;
        }
        if (tscal != 1.f)
        {
            grow = 0.f;
            goto L90;
        }
        if (nounit)
        {
            /* A is non-unit triangular. */
            /* Compute GROW = 1/G(j) and XBND = 1/M(j). */
            /* Initially, M(0) = max{
            x(i), i=1,...,n}
            . */
            grow = .5f / max(xbnd,smlnum);
            xbnd = grow;
            ip = jfirst * (jfirst + 1) / 2;
            jlen = 1;
            i__1 = jlast;
            i__2 = jinc;
            for (j = jfirst;
                    i__2 < 0 ? j >= i__1 : j <= i__1;
                    j += i__2)
            {
                /* Exit the loop if the growth factor is too small. */
                if (grow <= smlnum)
                {
                    goto L90;
                }
                /* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
                xj = cnorm[j] + 1.f;
                /* Computing MIN */
                r__1 = grow;
                r__2 = xbnd / xj; // , expr subst
                grow = min(r__1,r__2);
                i__3 = ip;
                tjjs.r = ap[i__3].r;
                tjjs.i = ap[i__3].i; // , expr subst
                tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs( r__2));
                if (tjj >= smlnum)
                {
                    /* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
                    if (xj > tjj)
                    {
                        xbnd *= tjj / xj;
                    }
                }
                else
                {
                    /* M(j) could overflow, set XBND to 0. */
                    xbnd = 0.f;
                }
                ++jlen;
                ip += jinc * jlen;
                /* L70: */
            }
            grow = min(grow,xbnd);
        }
        else
        {
            /* A is unit triangular. */
            /* Compute GROW = 1/G(j), where G(0) = max{
            x(i), i=1,...,n}
            . */
            /* Computing MIN */
            r__1 = 1.f;
            r__2 = .5f / max(xbnd,smlnum); // , expr subst
            grow = min(r__1,r__2);
            i__2 = jlast;
            i__1 = jinc;
            for (j = jfirst;
                    i__1 < 0 ? j >= i__2 : j <= i__2;
                    j += i__1)
            {
                /* Exit the loop if the growth factor is too small. */
                if (grow <= smlnum)
                {
                    goto L90;
                }
                /* G(j) = ( 1 + CNORM(j) )*G(j-1) */
                xj = cnorm[j] + 1.f;
                grow /= xj;
                /* L80: */
            }
        }
L90:
        ;
    }
    if (grow * tscal > smlnum)
    {
        /* Use the Level 2 BLAS solve if the reciprocal of the bound on */
        /* elements of X is not too small. */
        ctpsv_(uplo, trans, diag, n, &ap[1], &x[1], &c__1);
    }
    else
    {
        /* Use a Level 1 BLAS solve, scaling intermediate results. */
        if (xmax > bignum * .5f)
        {
            /* Scale X so that its components are less than or equal to */
            /* BIGNUM in absolute value. */
            *scale = bignum * .5f / xmax;
            csscal_(n, scale, &x[1], &c__1);
            xmax = bignum;
        }
        else
        {
            xmax *= 2.f;
        }
        if (notran)
        {
            /* Solve A * x = b */
            ip = jfirst * (jfirst + 1) / 2;
            i__1 = jlast;
            i__2 = jinc;
            for (j = jfirst;
                    i__2 < 0 ? j >= i__1 : j <= i__1;
                    j += i__2)
            {
                /* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
                i__3 = j;
                xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]), abs(r__2));
                if (nounit)
                {
                    i__3 = ip;
                    q__1.r = tscal * ap[i__3].r;
                    q__1.i = tscal * ap[i__3].i; // , expr subst
                    tjjs.r = q__1.r;
                    tjjs.i = q__1.i; // , expr subst
                }
                else
                {
                    tjjs.r = tscal;
                    tjjs.i = 0.f; // , expr subst
                    if (tscal == 1.f)
                    {
                        goto L105;
                    }
                }
                tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs( r__2));
                if (tjj > smlnum)
                {
                    /* abs(A(j,j)) > SMLNUM: */
                    if (tjj < 1.f)
                    {
                        if (xj > tjj * bignum)
                        {
                            /* Scale x by 1/b(j). */
                            rec = 1.f / xj;
                            csscal_(n, &rec, &x[1], &c__1);
                            *scale *= rec;
                            xmax *= rec;
                        }
                    }
                    i__3 = j;
                    cladiv_(&q__1, &x[j], &tjjs);
                    x[i__3].r = q__1.r;
                    x[i__3].i = q__1.i; // , expr subst
                    i__3 = j;
                    xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]) , abs(r__2));
                }
                else if (tjj > 0.f)
                {
                    /* 0 < abs(A(j,j)) <= SMLNUM: */
                    if (xj > tjj * bignum)
                    {
                        /* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */
                        /* to avoid overflow when dividing by A(j,j). */
                        rec = tjj * bignum / xj;
                        if (cnorm[j] > 1.f)
                        {
                            /* Scale by 1/CNORM(j) to avoid overflow when */
                            /* multiplying x(j) times column j. */
                            rec /= cnorm[j];
                        }
                        csscal_(n, &rec, &x[1], &c__1);
                        *scale *= rec;
                        xmax *= rec;
                    }
                    i__3 = j;
                    cladiv_(&q__1, &x[j], &tjjs);
                    x[i__3].r = q__1.r;
                    x[i__3].i = q__1.i; // , expr subst
                    i__3 = j;
                    xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]) , abs(r__2));
                }
                else
                {
                    /* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
                    /* scale = 0, and compute a solution to A*x = 0. */
                    i__3 = *n;
                    for (i__ = 1;
                            i__ <= i__3;
                            ++i__)
                    {
                        i__4 = i__;
                        x[i__4].r = 0.f;
                        x[i__4].i = 0.f; // , expr subst
                        /* L100: */
                    }
                    i__3 = j;
                    x[i__3].r = 1.f;
                    x[i__3].i = 0.f; // , expr subst
                    xj = 1.f;
                    *scale = 0.f;
                    xmax = 0.f;
                }
L105: /* Scale x if necessary to avoid overflow when adding a */
                /* multiple of column j of A. */
                if (xj > 1.f)
                {
                    rec = 1.f / xj;
                    if (cnorm[j] > (bignum - xmax) * rec)
                    {
                        /* Scale x by 1/(2*abs(x(j))). */
                        rec *= .5f;
                        csscal_(n, &rec, &x[1], &c__1);
                        *scale *= rec;
                    }
                }
                else if (xj * cnorm[j] > bignum - xmax)
                {
                    /* Scale x by 1/2. */
                    csscal_(n, &c_b36, &x[1], &c__1);
                    *scale *= .5f;
                }
                if (upper)
                {
                    if (j > 1)
                    {
                        /* Compute the update */
                        /* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */
                        i__3 = j - 1;
                        i__4 = j;
                        q__2.r = -x[i__4].r;
                        q__2.i = -x[i__4].i; // , expr subst
                        q__1.r = tscal * q__2.r;
                        q__1.i = tscal * q__2.i; // , expr subst
                        caxpy_(&i__3, &q__1, &ap[ip - j + 1], &c__1, &x[1], & c__1);
                        i__3 = j - 1;
                        i__ = icamax_(&i__3, &x[1], &c__1);
                        i__3 = i__;
                        xmax = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag( &x[i__]), abs(r__2));
                    }
                    ip -= j;
                }
                else
                {
                    if (j < *n)
                    {
                        /* Compute the update */
                        /* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */
                        i__3 = *n - j;
                        i__4 = j;
                        q__2.r = -x[i__4].r;
                        q__2.i = -x[i__4].i; // , expr subst
                        q__1.r = tscal * q__2.r;
                        q__1.i = tscal * q__2.i; // , expr subst
                        caxpy_(&i__3, &q__1, &ap[ip + 1], &c__1, &x[j + 1], & c__1);
                        i__3 = *n - j;
                        i__ = j + icamax_(&i__3, &x[j + 1], &c__1);
                        i__3 = i__;
                        xmax = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag( &x[i__]), abs(r__2));
                    }
                    ip = ip + *n - j + 1;
                }
                /* L110: */
            }
        }
        else if (lsame_(trans, "T"))
        {
            /* Solve A**T * x = b */
            ip = jfirst * (jfirst + 1) / 2;
            jlen = 1;
            i__2 = jlast;
            i__1 = jinc;
            for (j = jfirst;
                    i__1 < 0 ? j >= i__2 : j <= i__2;
                    j += i__1)
            {
                /* Compute x(j) = b(j) - sum A(k,j)*x(k). */
                /* k<>j */
                i__3 = j;
                xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]), abs(r__2));
                uscal.r = tscal;
                uscal.i = 0.f; // , expr subst
                rec = 1.f / max(xmax,1.f);
                if (cnorm[j] > (bignum - xj) * rec)
                {
                    /* If x(j) could overflow, scale x by 1/(2*XMAX). */
                    rec *= .5f;
                    if (nounit)
                    {
                        i__3 = ip;
                        q__1.r = tscal * ap[i__3].r;
                        q__1.i = tscal * ap[i__3] .i; // , expr subst
                        tjjs.r = q__1.r;
                        tjjs.i = q__1.i; // , expr subst
                    }
                    else
                    {
                        tjjs.r = tscal;
                        tjjs.i = 0.f; // , expr subst
                    }
                    tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs(r__2));
                    if (tjj > 1.f)
                    {
                        /* Divide by A(j,j) when scaling x if A(j,j) > 1. */
                        /* Computing MIN */
                        r__1 = 1.f;
                        r__2 = rec * tjj; // , expr subst
                        rec = min(r__1,r__2);
                        cladiv_(&q__1, &uscal, &tjjs);
                        uscal.r = q__1.r;
                        uscal.i = q__1.i; // , expr subst
                    }
                    if (rec < 1.f)
                    {
                        csscal_(n, &rec, &x[1], &c__1);
                        *scale *= rec;
                        xmax *= rec;
                    }
                }
                csumj.r = 0.f;
                csumj.i = 0.f; // , expr subst
                if (uscal.r == 1.f && uscal.i == 0.f)
                {
                    /* If the scaling needed for A in the dot product is 1, */
                    /* call CDOTU to perform the dot product. */
                    if (upper)
                    {
                        i__3 = j - 1;
                        cdotu_f2c_(&q__1, &i__3, &ap[ip - j + 1], &c__1, &x[1], & c__1);
                        csumj.r = q__1.r;
                        csumj.i = q__1.i; // , expr subst
                    }
                    else if (j < *n)
                    {
                        i__3 = *n - j;
                        cdotu_f2c_(&q__1, &i__3, &ap[ip + 1], &c__1, &x[j + 1], & c__1);
                        csumj.r = q__1.r;
                        csumj.i = q__1.i; // , expr subst
                    }
                }
                else
                {
                    /* Otherwise, use in-line code for the dot product. */
                    if (upper)
                    {
                        i__3 = j - 1;
                        for (i__ = 1;
                                i__ <= i__3;
                                ++i__)
                        {
                            i__4 = ip - j + i__;
                            q__3.r = ap[i__4].r * uscal.r - ap[i__4].i * uscal.i;
                            q__3.i = ap[i__4].r * uscal.i + ap[i__4].i * uscal.r; // , expr subst
                            i__5 = i__;
                            q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i;
                            q__2.i = q__3.r * x[i__5].i + q__3.i * x[ i__5].r; // , expr subst
                            q__1.r = csumj.r + q__2.r;
                            q__1.i = csumj.i + q__2.i; // , expr subst
                            csumj.r = q__1.r;
                            csumj.i = q__1.i; // , expr subst
                            /* L120: */
                        }
                    }
                    else if (j < *n)
                    {
                        i__3 = *n - j;
                        for (i__ = 1;
                                i__ <= i__3;
                                ++i__)
                        {
                            i__4 = ip + i__;
                            q__3.r = ap[i__4].r * uscal.r - ap[i__4].i * uscal.i;
                            q__3.i = ap[i__4].r * uscal.i + ap[i__4].i * uscal.r; // , expr subst
                            i__5 = j + i__;
                            q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i;
                            q__2.i = q__3.r * x[i__5].i + q__3.i * x[ i__5].r; // , expr subst
                            q__1.r = csumj.r + q__2.r;
                            q__1.i = csumj.i + q__2.i; // , expr subst
                            csumj.r = q__1.r;
                            csumj.i = q__1.i; // , expr subst
                            /* L130: */
                        }
                    }
                }
                q__1.r = tscal;
                q__1.i = 0.f; // , expr subst
                if (uscal.r == q__1.r && uscal.i == q__1.i)
                {
                    /* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
                    /* was not used to scale the dotproduct. */
                    i__3 = j;
                    i__4 = j;
                    q__1.r = x[i__4].r - csumj.r;
                    q__1.i = x[i__4].i - csumj.i; // , expr subst
                    x[i__3].r = q__1.r;
                    x[i__3].i = q__1.i; // , expr subst
                    i__3 = j;
                    xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]) , abs(r__2));
                    if (nounit)
                    {
                        /* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
                        i__3 = ip;
                        q__1.r = tscal * ap[i__3].r;
                        q__1.i = tscal * ap[i__3] .i; // , expr subst
                        tjjs.r = q__1.r;
                        tjjs.i = q__1.i; // , expr subst
                    }
                    else
                    {
                        tjjs.r = tscal;
                        tjjs.i = 0.f; // , expr subst
                        if (tscal == 1.f)
                        {
                            goto L145;
                        }
                    }
                    tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs(r__2));
                    if (tjj > smlnum)
                    {
                        /* abs(A(j,j)) > SMLNUM: */
                        if (tjj < 1.f)
                        {
                            if (xj > tjj * bignum)
                            {
                                /* Scale X by 1/abs(x(j)). */
                                rec = 1.f / xj;
                                csscal_(n, &rec, &x[1], &c__1);
                                *scale *= rec;
                                xmax *= rec;
                            }
                        }
                        i__3 = j;
                        cladiv_(&q__1, &x[j], &tjjs);
                        x[i__3].r = q__1.r;
                        x[i__3].i = q__1.i; // , expr subst
                    }
                    else if (tjj > 0.f)
                    {
                        /* 0 < abs(A(j,j)) <= SMLNUM: */
                        if (xj > tjj * bignum)
                        {
                            /* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
                            rec = tjj * bignum / xj;
                            csscal_(n, &rec, &x[1], &c__1);
                            *scale *= rec;
                            xmax *= rec;
                        }
                        i__3 = j;
                        cladiv_(&q__1, &x[j], &tjjs);
                        x[i__3].r = q__1.r;
                        x[i__3].i = q__1.i; // , expr subst
                    }
                    else
                    {
                        /* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
                        /* scale = 0 and compute a solution to A**T *x = 0. */
                        i__3 = *n;
                        for (i__ = 1;
                                i__ <= i__3;
                                ++i__)
                        {
                            i__4 = i__;
                            x[i__4].r = 0.f;
                            x[i__4].i = 0.f; // , expr subst
                            /* L140: */
                        }
                        i__3 = j;
                        x[i__3].r = 1.f;
                        x[i__3].i = 0.f; // , expr subst
                        *scale = 0.f;
                        xmax = 0.f;
                    }
L145:
                    ;
                }
                else
                {
                    /* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
                    /* product has already been divided by 1/A(j,j). */
                    i__3 = j;
                    cladiv_(&q__2, &x[j], &tjjs);
                    q__1.r = q__2.r - csumj.r;
                    q__1.i = q__2.i - csumj.i; // , expr subst
                    x[i__3].r = q__1.r;
                    x[i__3].i = q__1.i; // , expr subst
                }
                /* Computing MAX */
                i__3 = j;
                r__3 = xmax;
                r__4 = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]), abs(r__2)); // , expr subst
                xmax = max(r__3,r__4);
                ++jlen;
                ip += jinc * jlen;
                /* L150: */
            }
        }
        else
        {
            /* Solve A**H * x = b */
            ip = jfirst * (jfirst + 1) / 2;
            jlen = 1;
            i__1 = jlast;
            i__2 = jinc;
            for (j = jfirst;
                    i__2 < 0 ? j >= i__1 : j <= i__1;
                    j += i__2)
            {
                /* Compute x(j) = b(j) - sum A(k,j)*x(k). */
                /* k<>j */
                i__3 = j;
                xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]), abs(r__2));
                uscal.r = tscal;
                uscal.i = 0.f; // , expr subst
                rec = 1.f / max(xmax,1.f);
                if (cnorm[j] > (bignum - xj) * rec)
                {
                    /* If x(j) could overflow, scale x by 1/(2*XMAX). */
                    rec *= .5f;
                    if (nounit)
                    {
                        r_cnjg(&q__2, &ap[ip]);
                        q__1.r = tscal * q__2.r;
                        q__1.i = tscal * q__2.i; // , expr subst
                        tjjs.r = q__1.r;
                        tjjs.i = q__1.i; // , expr subst
                    }
                    else
                    {
                        tjjs.r = tscal;
                        tjjs.i = 0.f; // , expr subst
                    }
                    tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs(r__2));
                    if (tjj > 1.f)
                    {
                        /* Divide by A(j,j) when scaling x if A(j,j) > 1. */
                        /* Computing MIN */
                        r__1 = 1.f;
                        r__2 = rec * tjj; // , expr subst
                        rec = min(r__1,r__2);
                        cladiv_(&q__1, &uscal, &tjjs);
                        uscal.r = q__1.r;
                        uscal.i = q__1.i; // , expr subst
                    }
                    if (rec < 1.f)
                    {
                        csscal_(n, &rec, &x[1], &c__1);
                        *scale *= rec;
                        xmax *= rec;
                    }
                }
                csumj.r = 0.f;
                csumj.i = 0.f; // , expr subst
                if (uscal.r == 1.f && uscal.i == 0.f)
                {
                    /* If the scaling needed for A in the dot product is 1, */
                    /* call CDOTC to perform the dot product. */
                    if (upper)
                    {
                        i__3 = j - 1;
                        cdotc_f2c_(&q__1, &i__3, &ap[ip - j + 1], &c__1, &x[1], & c__1);
                        csumj.r = q__1.r;
                        csumj.i = q__1.i; // , expr subst
                    }
                    else if (j < *n)
                    {
                        i__3 = *n - j;
                        cdotc_f2c_(&q__1, &i__3, &ap[ip + 1], &c__1, &x[j + 1], & c__1);
                        csumj.r = q__1.r;
                        csumj.i = q__1.i; // , expr subst
                    }
                }
                else
                {
                    /* Otherwise, use in-line code for the dot product. */
                    if (upper)
                    {
                        i__3 = j - 1;
                        for (i__ = 1;
                                i__ <= i__3;
                                ++i__)
                        {
                            r_cnjg(&q__4, &ap[ip - j + i__]);
                            q__3.r = q__4.r * uscal.r - q__4.i * uscal.i;
                            q__3.i = q__4.r * uscal.i + q__4.i * uscal.r; // , expr subst
                            i__4 = i__;
                            q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i;
                            q__2.i = q__3.r * x[i__4].i + q__3.i * x[ i__4].r; // , expr subst
                            q__1.r = csumj.r + q__2.r;
                            q__1.i = csumj.i + q__2.i; // , expr subst
                            csumj.r = q__1.r;
                            csumj.i = q__1.i; // , expr subst
                            /* L160: */
                        }
                    }
                    else if (j < *n)
                    {
                        i__3 = *n - j;
                        for (i__ = 1;
                                i__ <= i__3;
                                ++i__)
                        {
                            r_cnjg(&q__4, &ap[ip + i__]);
                            q__3.r = q__4.r * uscal.r - q__4.i * uscal.i;
                            q__3.i = q__4.r * uscal.i + q__4.i * uscal.r; // , expr subst
                            i__4 = j + i__;
                            q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i;
                            q__2.i = q__3.r * x[i__4].i + q__3.i * x[ i__4].r; // , expr subst
                            q__1.r = csumj.r + q__2.r;
                            q__1.i = csumj.i + q__2.i; // , expr subst
                            csumj.r = q__1.r;
                            csumj.i = q__1.i; // , expr subst
                            /* L170: */
                        }
                    }
                }
                q__1.r = tscal;
                q__1.i = 0.f; // , expr subst
                if (uscal.r == q__1.r && uscal.i == q__1.i)
                {
                    /* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
                    /* was not used to scale the dotproduct. */
                    i__3 = j;
                    i__4 = j;
                    q__1.r = x[i__4].r - csumj.r;
                    q__1.i = x[i__4].i - csumj.i; // , expr subst
                    x[i__3].r = q__1.r;
                    x[i__3].i = q__1.i; // , expr subst
                    i__3 = j;
                    xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]) , abs(r__2));
                    if (nounit)
                    {
                        /* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
                        r_cnjg(&q__2, &ap[ip]);
                        q__1.r = tscal * q__2.r;
                        q__1.i = tscal * q__2.i; // , expr subst
                        tjjs.r = q__1.r;
                        tjjs.i = q__1.i; // , expr subst
                    }
                    else
                    {
                        tjjs.r = tscal;
                        tjjs.i = 0.f; // , expr subst
                        if (tscal == 1.f)
                        {
                            goto L185;
                        }
                    }
                    tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs(r__2));
                    if (tjj > smlnum)
                    {
                        /* abs(A(j,j)) > SMLNUM: */
                        if (tjj < 1.f)
                        {
                            if (xj > tjj * bignum)
                            {
                                /* Scale X by 1/abs(x(j)). */
                                rec = 1.f / xj;
                                csscal_(n, &rec, &x[1], &c__1);
                                *scale *= rec;
                                xmax *= rec;
                            }
                        }
                        i__3 = j;
                        cladiv_(&q__1, &x[j], &tjjs);
                        x[i__3].r = q__1.r;
                        x[i__3].i = q__1.i; // , expr subst
                    }
                    else if (tjj > 0.f)
                    {
                        /* 0 < abs(A(j,j)) <= SMLNUM: */
                        if (xj > tjj * bignum)
                        {
                            /* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
                            rec = tjj * bignum / xj;
                            csscal_(n, &rec, &x[1], &c__1);
                            *scale *= rec;
                            xmax *= rec;
                        }
                        i__3 = j;
                        cladiv_(&q__1, &x[j], &tjjs);
                        x[i__3].r = q__1.r;
                        x[i__3].i = q__1.i; // , expr subst
                    }
                    else
                    {
                        /* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
                        /* scale = 0 and compute a solution to A**H *x = 0. */
                        i__3 = *n;
                        for (i__ = 1;
                                i__ <= i__3;
                                ++i__)
                        {
                            i__4 = i__;
                            x[i__4].r = 0.f;
                            x[i__4].i = 0.f; // , expr subst
                            /* L180: */
                        }
                        i__3 = j;
                        x[i__3].r = 1.f;
                        x[i__3].i = 0.f; // , expr subst
                        *scale = 0.f;
                        xmax = 0.f;
                    }
L185:
                    ;
                }
                else
                {
                    /* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
                    /* product has already been divided by 1/A(j,j). */
                    i__3 = j;
                    cladiv_(&q__2, &x[j], &tjjs);
                    q__1.r = q__2.r - csumj.r;
                    q__1.i = q__2.i - csumj.i; // , expr subst
                    x[i__3].r = q__1.r;
                    x[i__3].i = q__1.i; // , expr subst
                }
                /* Computing MAX */
                i__3 = j;
                r__3 = xmax;
                r__4 = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]), abs(r__2)); // , expr subst
                xmax = max(r__3,r__4);
                ++jlen;
                ip += jinc * jlen;
                /* L190: */
            }
        }
        *scale /= tscal;
    }
    /* Scale the column norms by 1/TSCAL for return. */
    if (tscal != 1.f)
    {
        r__1 = 1.f / tscal;
        sscal_(n, &r__1, &cnorm[1], &c__1);
    }
    return 0;
    /* End of CLATPS */
}
示例#10
0
/* Subroutine */ int clatps_(char *uplo, char *trans, char *diag, char *
	normin, integer *n, complex *ap, complex *x, real *scale, real *cnorm,
	 integer *info)
{
/*  -- LAPACK auxiliary routine (version 3.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       October 31, 1992   


    Purpose   
    =======   

    CLATPS solves one of the triangular systems   

       A * x = s*b,  A**T * x = s*b,  or  A**H * x = s*b,   

    with scaling to prevent overflow, where A is an upper or lower   
    triangular matrix stored in packed form.  Here A**T denotes the   
    transpose of A, A**H denotes the conjugate transpose of A, x and b   
    are n-element vectors, and s is a scaling factor, usually less than   
    or equal to 1, chosen so that the components of x will be less than   
    the overflow threshold.  If the unscaled problem will not cause   
    overflow, the Level 2 BLAS routine CTPSV is called. If the matrix A   
    is singular (A(j,j) = 0 for some j), then s is set to 0 and a   
    non-trivial solution to A*x = 0 is returned.   

    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':  Solve A * x = s*b     (No transpose)   
            = 'T':  Solve A**T * x = s*b  (Transpose)   
            = 'C':  Solve A**H * x = s*b  (Conjugate transpose)   

    DIAG    (input) CHARACTER*1   
            Specifies whether or not the matrix A is unit triangular.   
            = 'N':  Non-unit triangular   
            = 'U':  Unit triangular   

    NORMIN  (input) CHARACTER*1   
            Specifies whether CNORM has been set or not.   
            = 'Y':  CNORM contains the column norms on entry   
            = 'N':  CNORM is not set on entry.  On exit, the norms will   
                    be computed and stored in CNORM.   

    N       (input) INTEGER   
            The order of the matrix A.  N >= 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.   

    X       (input/output) COMPLEX array, dimension (N)   
            On entry, the right hand side b of the triangular system.   
            On exit, X is overwritten by the solution vector x.   

    SCALE   (output) REAL   
            The scaling factor s for the triangular system   
               A * x = s*b,  A**T * x = s*b,  or  A**H * x = s*b.   
            If SCALE = 0, the matrix A is singular or badly scaled, and   
            the vector x is an exact or approximate solution to A*x = 0.   

    CNORM   (input or output) REAL array, dimension (N)   

            If NORMIN = 'Y', CNORM is an input argument and CNORM(j)   
            contains the norm of the off-diagonal part of the j-th column   
            of A.  If TRANS = 'N', CNORM(j) must be greater than or equal   
            to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)   
            must be greater than or equal to the 1-norm.   

            If NORMIN = 'N', CNORM is an output argument and CNORM(j)   
            returns the 1-norm of the offdiagonal part of the j-th column   
            of A.   

    INFO    (output) INTEGER   
            = 0:  successful exit   
            < 0:  if INFO = -k, the k-th argument had an illegal value   

    Further Details   
    ======= =======   

    A rough bound on x is computed; if that is less than overflow, CTPSV   
    is called, otherwise, specific code is used which checks for possible   
    overflow or divide-by-zero at every operation.   

    A columnwise scheme is used for solving A*x = b.  The basic algorithm   
    if A is lower triangular is   

         x[1:n] := b[1:n]   
         for j = 1, ..., n   
              x(j) := x(j) / A(j,j)   
              x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]   
         end   

    Define bounds on the components of x after j iterations of the loop:   
       M(j) = bound on x[1:j]   
       G(j) = bound on x[j+1:n]   
    Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.   

    Then for iteration j+1 we have   
       M(j+1) <= G(j) / | A(j+1,j+1) |   
       G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |   
              <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )   

    where CNORM(j+1) is greater than or equal to the infinity-norm of   
    column j+1 of A, not counting the diagonal.  Hence   

       G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )   
                    1<=i<=j   
    and   

       |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )   
                                     1<=i< j   

    Since |x(j)| <= M(j), we use the Level 2 BLAS routine CTPSV if the   
    reciprocal of the largest M(j), j=1,..,n, is larger than   
    max(underflow, 1/overflow).   

    The bound on x(j) is also used to determine when a step in the   
    columnwise method can be performed without fear of overflow.  If   
    the computed bound is greater than a large constant, x is scaled to   
    prevent overflow, but if the bound overflows, x is set to 0, x(j) to   
    1, and scale to 0, and a non-trivial solution to A*x = 0 is found.   

    Similarly, a row-wise scheme is used to solve A**T *x = b  or   
    A**H *x = b.  The basic algorithm for A upper triangular is   

         for j = 1, ..., n   
              x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)   
         end   

    We simultaneously compute two bounds   
         G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j   
         M(j) = bound on x(i), 1<=i<=j   

    The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we   
    add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.   
    Then the bound on x(j) is   

         M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |   

              <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )   
                        1<=i<=j   

    and we can safely call CTPSV if 1/M(n) and 1/G(n) are both greater   
    than max(underflow, 1/overflow).   

    =====================================================================   


       Parameter adjustments */
    /* Table of constant values */
    static integer c__1 = 1;
    static real c_b36 = .5f;
    
    /* System generated locals */
    integer i__1, i__2, i__3, i__4, i__5;
    real r__1, r__2, r__3, r__4;
    complex q__1, q__2, q__3, q__4;
    /* Builtin functions */
    double r_imag(complex *);
    void r_cnjg(complex *, complex *);
    /* Local variables */
    static integer jinc, jlen;
    static real xbnd;
    static integer imax;
    static real tmax;
    static complex tjjs;
    static real xmax, grow;
    static integer i__, j;
    extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer 
	    *, complex *, integer *);
    extern logical lsame_(char *, char *);
    extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
    static real tscal;
    static complex uscal;
    static integer jlast;
    extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer 
	    *, complex *, integer *);
    static complex csumj;
    extern /* Subroutine */ int caxpy_(integer *, complex *, complex *, 
	    integer *, complex *, integer *);
    static logical upper;
    extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *, 
	    complex *, complex *, integer *), slabad_(
	    real *, real *);
    static integer ip;
    static real xj;
    extern integer icamax_(integer *, complex *, integer *);
    extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
    extern doublereal slamch_(char *);
    extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer 
	    *), xerbla_(char *, integer *);
    static real bignum;
    extern integer isamax_(integer *, real *, integer *);
    extern doublereal scasum_(integer *, complex *, integer *);
    static logical notran;
    static integer jfirst;
    static real smlnum;
    static logical nounit;
    static real rec, tjj;


    --cnorm;
    --x;
    --ap;

    /* Function Body */
    *info = 0;
    upper = lsame_(uplo, "U");
    notran = lsame_(trans, "N");
    nounit = lsame_(diag, "N");

/*     Test the input parameters. */

    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 (! lsame_(normin, "Y") && ! lsame_(normin,
	     "N")) {
	*info = -4;
    } else if (*n < 0) {
	*info = -5;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("CLATPS", &i__1);
	return 0;
    }

/*     Quick return if possible */

    if (*n == 0) {
	return 0;
    }

/*     Determine machine dependent parameters to control overflow. */

    smlnum = slamch_("Safe minimum");
    bignum = 1.f / smlnum;
    slabad_(&smlnum, &bignum);
    smlnum /= slamch_("Precision");
    bignum = 1.f / smlnum;
    *scale = 1.f;

    if (lsame_(normin, "N")) {

/*        Compute the 1-norm of each column, not including the diagonal. */

	if (upper) {

/*           A is upper triangular. */

	    ip = 1;
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = j - 1;
		cnorm[j] = scasum_(&i__2, &ap[ip], &c__1);
		ip += j;
/* L10: */
	    }
	} else {

/*           A is lower triangular. */

	    ip = 1;
	    i__1 = *n - 1;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = *n - j;
		cnorm[j] = scasum_(&i__2, &ap[ip + 1], &c__1);
		ip = ip + *n - j + 1;
/* L20: */
	    }
	    cnorm[*n] = 0.f;
	}
    }

/*     Scale the column norms by TSCAL if the maximum element in CNORM is   
       greater than BIGNUM/2. */

    imax = isamax_(n, &cnorm[1], &c__1);
    tmax = cnorm[imax];
    if (tmax <= bignum * .5f) {
	tscal = 1.f;
    } else {
	tscal = .5f / (smlnum * tmax);
	sscal_(n, &tscal, &cnorm[1], &c__1);
    }

/*     Compute a bound on the computed solution vector to see if the   
       Level 2 BLAS routine CTPSV can be used. */

    xmax = 0.f;
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
	i__2 = j;
	r__3 = xmax, r__4 = (r__1 = x[i__2].r / 2.f, dabs(r__1)) + (r__2 = 
		r_imag(&x[j]) / 2.f, dabs(r__2));
	xmax = dmax(r__3,r__4);
/* L30: */
    }
    xbnd = xmax;
    if (notran) {

/*        Compute the growth in A * x = b. */

	if (upper) {
	    jfirst = *n;
	    jlast = 1;
	    jinc = -1;
	} else {
	    jfirst = 1;
	    jlast = *n;
	    jinc = 1;
	}

	if (tscal != 1.f) {
	    grow = 0.f;
	    goto L60;
	}

	if (nounit) {

/*           A is non-unit triangular.   

             Compute GROW = 1/G(j) and XBND = 1/M(j).   
             Initially, G(0) = max{x(i), i=1,...,n}. */

	    grow = .5f / dmax(xbnd,smlnum);
	    xbnd = grow;
	    ip = jfirst * (jfirst + 1) / 2;
	    jlen = *n;
	    i__1 = jlast;
	    i__2 = jinc;
	    for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {

/*              Exit the loop if the growth factor is too small. */

		if (grow <= smlnum) {
		    goto L60;
		}

		i__3 = ip;
		tjjs.r = ap[i__3].r, tjjs.i = ap[i__3].i;
		tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs), 
			dabs(r__2));

		if (tjj >= smlnum) {

/*                 M(j) = G(j-1) / abs(A(j,j))   

   Computing MIN */
		    r__1 = xbnd, r__2 = dmin(1.f,tjj) * grow;
		    xbnd = dmin(r__1,r__2);
		} else {

/*                 M(j) could overflow, set XBND to 0. */

		    xbnd = 0.f;
		}

		if (tjj + cnorm[j] >= smlnum) {

/*                 G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */

		    grow *= tjj / (tjj + cnorm[j]);
		} else {

/*                 G(j) could overflow, set GROW to 0. */

		    grow = 0.f;
		}
		ip += jinc * jlen;
		--jlen;
/* L40: */
	    }
	    grow = xbnd;
	} else {

/*           A is unit triangular.   

             Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.   

   Computing MIN */
	    r__1 = 1.f, r__2 = .5f / dmax(xbnd,smlnum);
	    grow = dmin(r__1,r__2);
	    i__2 = jlast;
	    i__1 = jinc;
	    for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {

/*              Exit the loop if the growth factor is too small. */

		if (grow <= smlnum) {
		    goto L60;
		}

/*              G(j) = G(j-1)*( 1 + CNORM(j) ) */

		grow *= 1.f / (cnorm[j] + 1.f);
/* L50: */
	    }
	}
L60:

	;
    } else {

/*        Compute the growth in A**T * x = b  or  A**H * x = b. */

	if (upper) {
	    jfirst = 1;
	    jlast = *n;
	    jinc = 1;
	} else {
	    jfirst = *n;
	    jlast = 1;
	    jinc = -1;
	}

	if (tscal != 1.f) {
	    grow = 0.f;
	    goto L90;
	}

	if (nounit) {

/*           A is non-unit triangular.   

             Compute GROW = 1/G(j) and XBND = 1/M(j).   
             Initially, M(0) = max{x(i), i=1,...,n}. */

	    grow = .5f / dmax(xbnd,smlnum);
	    xbnd = grow;
	    ip = jfirst * (jfirst + 1) / 2;
	    jlen = 1;
	    i__1 = jlast;
	    i__2 = jinc;
	    for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {

/*              Exit the loop if the growth factor is too small. */

		if (grow <= smlnum) {
		    goto L90;
		}

/*              G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */

		xj = cnorm[j] + 1.f;
/* Computing MIN */
		r__1 = grow, r__2 = xbnd / xj;
		grow = dmin(r__1,r__2);

		i__3 = ip;
		tjjs.r = ap[i__3].r, tjjs.i = ap[i__3].i;
		tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs), 
			dabs(r__2));

		if (tjj >= smlnum) {

/*                 M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */

		    if (xj > tjj) {
			xbnd *= tjj / xj;
		    }
		} else {

/*                 M(j) could overflow, set XBND to 0. */

		    xbnd = 0.f;
		}
		++jlen;
		ip += jinc * jlen;
/* L70: */
	    }
	    grow = dmin(grow,xbnd);
	} else {

/*           A is unit triangular.   

             Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.   

   Computing MIN */
	    r__1 = 1.f, r__2 = .5f / dmax(xbnd,smlnum);
	    grow = dmin(r__1,r__2);
	    i__2 = jlast;
	    i__1 = jinc;
	    for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {

/*              Exit the loop if the growth factor is too small. */

		if (grow <= smlnum) {
		    goto L90;
		}

/*              G(j) = ( 1 + CNORM(j) )*G(j-1) */

		xj = cnorm[j] + 1.f;
		grow /= xj;
/* L80: */
	    }
	}
L90:
	;
    }

    if (grow * tscal > smlnum) {

/*        Use the Level 2 BLAS solve if the reciprocal of the bound on   
          elements of X is not too small. */

	ctpsv_(uplo, trans, diag, n, &ap[1], &x[1], &c__1);
    } else {

/*        Use a Level 1 BLAS solve, scaling intermediate results. */

	if (xmax > bignum * .5f) {

/*           Scale X so that its components are less than or equal to   
             BIGNUM in absolute value. */

	    *scale = bignum * .5f / xmax;
	    csscal_(n, scale, &x[1], &c__1);
	    xmax = bignum;
	} else {
	    xmax *= 2.f;
	}

	if (notran) {

/*           Solve A * x = b */

	    ip = jfirst * (jfirst + 1) / 2;
	    i__1 = jlast;
	    i__2 = jinc;
	    for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {

/*              Compute x(j) = b(j) / A(j,j), scaling x if necessary. */

		i__3 = j;
		xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]), 
			dabs(r__2));
		if (nounit) {
		    i__3 = ip;
		    q__1.r = tscal * ap[i__3].r, q__1.i = tscal * ap[i__3].i;
		    tjjs.r = q__1.r, tjjs.i = q__1.i;
		} else {
		    tjjs.r = tscal, tjjs.i = 0.f;
		    if (tscal == 1.f) {
			goto L105;
		    }
		}
		tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs), 
			dabs(r__2));
		if (tjj > smlnum) {

/*                    abs(A(j,j)) > SMLNUM: */

		    if (tjj < 1.f) {
			if (xj > tjj * bignum) {

/*                          Scale x by 1/b(j). */

			    rec = 1.f / xj;
			    csscal_(n, &rec, &x[1], &c__1);
			    *scale *= rec;
			    xmax *= rec;
			}
		    }
		    i__3 = j;
		    cladiv_(&q__1, &x[j], &tjjs);
		    x[i__3].r = q__1.r, x[i__3].i = q__1.i;
		    i__3 = j;
		    xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
			    ), dabs(r__2));
		} else if (tjj > 0.f) {

/*                    0 < abs(A(j,j)) <= SMLNUM: */

		    if (xj > tjj * bignum) {

/*                       Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM   
                         to avoid overflow when dividing by A(j,j). */

			rec = tjj * bignum / xj;
			if (cnorm[j] > 1.f) {

/*                          Scale by 1/CNORM(j) to avoid overflow when   
                            multiplying x(j) times column j. */

			    rec /= cnorm[j];
			}
			csscal_(n, &rec, &x[1], &c__1);
			*scale *= rec;
			xmax *= rec;
		    }
		    i__3 = j;
		    cladiv_(&q__1, &x[j], &tjjs);
		    x[i__3].r = q__1.r, x[i__3].i = q__1.i;
		    i__3 = j;
		    xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
			    ), dabs(r__2));
		} else {

/*                    A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and   
                      scale = 0, and compute a solution to A*x = 0. */

		    i__3 = *n;
		    for (i__ = 1; i__ <= i__3; ++i__) {
			i__4 = i__;
			x[i__4].r = 0.f, x[i__4].i = 0.f;
/* L100: */
		    }
		    i__3 = j;
		    x[i__3].r = 1.f, x[i__3].i = 0.f;
		    xj = 1.f;
		    *scale = 0.f;
		    xmax = 0.f;
		}
L105:

/*              Scale x if necessary to avoid overflow when adding a   
                multiple of column j of A. */

		if (xj > 1.f) {
		    rec = 1.f / xj;
		    if (cnorm[j] > (bignum - xmax) * rec) {

/*                    Scale x by 1/(2*abs(x(j))). */

			rec *= .5f;
			csscal_(n, &rec, &x[1], &c__1);
			*scale *= rec;
		    }
		} else if (xj * cnorm[j] > bignum - xmax) {

/*                 Scale x by 1/2. */

		    csscal_(n, &c_b36, &x[1], &c__1);
		    *scale *= .5f;
		}

		if (upper) {
		    if (j > 1) {

/*                    Compute the update   
                         x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */

			i__3 = j - 1;
			i__4 = j;
			q__2.r = -x[i__4].r, q__2.i = -x[i__4].i;
			q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
			caxpy_(&i__3, &q__1, &ap[ip - j + 1], &c__1, &x[1], &
				c__1);
			i__3 = j - 1;
			i__ = icamax_(&i__3, &x[1], &c__1);
			i__3 = i__;
			xmax = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = 
				r_imag(&x[i__]), dabs(r__2));
		    }
		    ip -= j;
		} else {
		    if (j < *n) {

/*                    Compute the update   
                         x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */

			i__3 = *n - j;
			i__4 = j;
			q__2.r = -x[i__4].r, q__2.i = -x[i__4].i;
			q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
			caxpy_(&i__3, &q__1, &ap[ip + 1], &c__1, &x[j + 1], &
				c__1);
			i__3 = *n - j;
			i__ = j + icamax_(&i__3, &x[j + 1], &c__1);
			i__3 = i__;
			xmax = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = 
				r_imag(&x[i__]), dabs(r__2));
		    }
		    ip = ip + *n - j + 1;
		}
/* L110: */
	    }

	} else if (lsame_(trans, "T")) {

/*           Solve A**T * x = b */

	    ip = jfirst * (jfirst + 1) / 2;
	    jlen = 1;
	    i__2 = jlast;
	    i__1 = jinc;
	    for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {

/*              Compute x(j) = b(j) - sum A(k,j)*x(k).   
                                      k<>j */

		i__3 = j;
		xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]), 
			dabs(r__2));
		uscal.r = tscal, uscal.i = 0.f;
		rec = 1.f / dmax(xmax,1.f);
		if (cnorm[j] > (bignum - xj) * rec) {

/*                 If x(j) could overflow, scale x by 1/(2*XMAX). */

		    rec *= .5f;
		    if (nounit) {
			i__3 = ip;
			q__1.r = tscal * ap[i__3].r, q__1.i = tscal * ap[i__3]
				.i;
			tjjs.r = q__1.r, tjjs.i = q__1.i;
		    } else {
			tjjs.r = tscal, tjjs.i = 0.f;
		    }
		    tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
			     dabs(r__2));
		    if (tjj > 1.f) {

/*                       Divide by A(j,j) when scaling x if A(j,j) > 1.   

   Computing MIN */
			r__1 = 1.f, r__2 = rec * tjj;
			rec = dmin(r__1,r__2);
			cladiv_(&q__1, &uscal, &tjjs);
			uscal.r = q__1.r, uscal.i = q__1.i;
		    }
		    if (rec < 1.f) {
			csscal_(n, &rec, &x[1], &c__1);
			*scale *= rec;
			xmax *= rec;
		    }
		}

		csumj.r = 0.f, csumj.i = 0.f;
		if (uscal.r == 1.f && uscal.i == 0.f) {

/*                 If the scaling needed for A in the dot product is 1,   
                   call CDOTU to perform the dot product. */

		    if (upper) {
			i__3 = j - 1;
			cdotu_(&q__1, &i__3, &ap[ip - j + 1], &c__1, &x[1], &
				c__1);
			csumj.r = q__1.r, csumj.i = q__1.i;
		    } else if (j < *n) {
			i__3 = *n - j;
			cdotu_(&q__1, &i__3, &ap[ip + 1], &c__1, &x[j + 1], &
				c__1);
			csumj.r = q__1.r, csumj.i = q__1.i;
		    }
		} else {

/*                 Otherwise, use in-line code for the dot product. */

		    if (upper) {
			i__3 = j - 1;
			for (i__ = 1; i__ <= i__3; ++i__) {
			    i__4 = ip - j + i__;
			    q__3.r = ap[i__4].r * uscal.r - ap[i__4].i * 
				    uscal.i, q__3.i = ap[i__4].r * uscal.i + 
				    ap[i__4].i * uscal.r;
			    i__5 = i__;
			    q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i, 
				    q__2.i = q__3.r * x[i__5].i + q__3.i * x[
				    i__5].r;
			    q__1.r = csumj.r + q__2.r, q__1.i = csumj.i + 
				    q__2.i;
			    csumj.r = q__1.r, csumj.i = q__1.i;
/* L120: */
			}
		    } else if (j < *n) {
			i__3 = *n - j;
			for (i__ = 1; i__ <= i__3; ++i__) {
			    i__4 = ip + i__;
			    q__3.r = ap[i__4].r * uscal.r - ap[i__4].i * 
				    uscal.i, q__3.i = ap[i__4].r * uscal.i + 
				    ap[i__4].i * uscal.r;
			    i__5 = j + i__;
			    q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i, 
				    q__2.i = q__3.r * x[i__5].i + q__3.i * x[
				    i__5].r;
			    q__1.r = csumj.r + q__2.r, q__1.i = csumj.i + 
				    q__2.i;
			    csumj.r = q__1.r, csumj.i = q__1.i;
/* L130: */
			}
		    }
		}

		q__1.r = tscal, q__1.i = 0.f;
		if (uscal.r == q__1.r && uscal.i == q__1.i) {

/*                 Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j)   
                   was not used to scale the dotproduct. */

		    i__3 = j;
		    i__4 = j;
		    q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i - 
			    csumj.i;
		    x[i__3].r = q__1.r, x[i__3].i = q__1.i;
		    i__3 = j;
		    xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
			    ), dabs(r__2));
		    if (nounit) {

/*                    Compute x(j) = x(j) / A(j,j), scaling if necessary. */

			i__3 = ip;
			q__1.r = tscal * ap[i__3].r, q__1.i = tscal * ap[i__3]
				.i;
			tjjs.r = q__1.r, tjjs.i = q__1.i;
		    } else {
			tjjs.r = tscal, tjjs.i = 0.f;
			if (tscal == 1.f) {
			    goto L145;
			}
		    }
		    tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
			     dabs(r__2));
		    if (tjj > smlnum) {

/*                       abs(A(j,j)) > SMLNUM: */

			if (tjj < 1.f) {
			    if (xj > tjj * bignum) {

/*                             Scale X by 1/abs(x(j)). */

				rec = 1.f / xj;
				csscal_(n, &rec, &x[1], &c__1);
				*scale *= rec;
				xmax *= rec;
			    }
			}
			i__3 = j;
			cladiv_(&q__1, &x[j], &tjjs);
			x[i__3].r = q__1.r, x[i__3].i = q__1.i;
		    } else if (tjj > 0.f) {

/*                       0 < abs(A(j,j)) <= SMLNUM: */

			if (xj > tjj * bignum) {

/*                          Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */

			    rec = tjj * bignum / xj;
			    csscal_(n, &rec, &x[1], &c__1);
			    *scale *= rec;
			    xmax *= rec;
			}
			i__3 = j;
			cladiv_(&q__1, &x[j], &tjjs);
			x[i__3].r = q__1.r, x[i__3].i = q__1.i;
		    } else {

/*                       A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and   
                         scale = 0 and compute a solution to A**T *x = 0. */

			i__3 = *n;
			for (i__ = 1; i__ <= i__3; ++i__) {
			    i__4 = i__;
			    x[i__4].r = 0.f, x[i__4].i = 0.f;
/* L140: */
			}
			i__3 = j;
			x[i__3].r = 1.f, x[i__3].i = 0.f;
			*scale = 0.f;
			xmax = 0.f;
		    }
L145:
		    ;
		} else {

/*                 Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot   
                   product has already been divided by 1/A(j,j). */

		    i__3 = j;
		    cladiv_(&q__2, &x[j], &tjjs);
		    q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i;
		    x[i__3].r = q__1.r, x[i__3].i = q__1.i;
		}
/* Computing MAX */
		i__3 = j;
		r__3 = xmax, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = 
			r_imag(&x[j]), dabs(r__2));
		xmax = dmax(r__3,r__4);
		++jlen;
		ip += jinc * jlen;
/* L150: */
	    }

	} else {

/*           Solve A**H * x = b */

	    ip = jfirst * (jfirst + 1) / 2;
	    jlen = 1;
	    i__1 = jlast;
	    i__2 = jinc;
	    for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {

/*              Compute x(j) = b(j) - sum A(k,j)*x(k).   
                                      k<>j */

		i__3 = j;
		xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]), 
			dabs(r__2));
		uscal.r = tscal, uscal.i = 0.f;
		rec = 1.f / dmax(xmax,1.f);
		if (cnorm[j] > (bignum - xj) * rec) {

/*                 If x(j) could overflow, scale x by 1/(2*XMAX). */

		    rec *= .5f;
		    if (nounit) {
			r_cnjg(&q__2, &ap[ip]);
			q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
			tjjs.r = q__1.r, tjjs.i = q__1.i;
		    } else {
			tjjs.r = tscal, tjjs.i = 0.f;
		    }
		    tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
			     dabs(r__2));
		    if (tjj > 1.f) {

/*                       Divide by A(j,j) when scaling x if A(j,j) > 1.   

   Computing MIN */
			r__1 = 1.f, r__2 = rec * tjj;
			rec = dmin(r__1,r__2);
			cladiv_(&q__1, &uscal, &tjjs);
			uscal.r = q__1.r, uscal.i = q__1.i;
		    }
		    if (rec < 1.f) {
			csscal_(n, &rec, &x[1], &c__1);
			*scale *= rec;
			xmax *= rec;
		    }
		}

		csumj.r = 0.f, csumj.i = 0.f;
		if (uscal.r == 1.f && uscal.i == 0.f) {

/*                 If the scaling needed for A in the dot product is 1,   
                   call CDOTC to perform the dot product. */

		    if (upper) {
			i__3 = j - 1;
			cdotc_(&q__1, &i__3, &ap[ip - j + 1], &c__1, &x[1], &
				c__1);
			csumj.r = q__1.r, csumj.i = q__1.i;
		    } else if (j < *n) {
			i__3 = *n - j;
			cdotc_(&q__1, &i__3, &ap[ip + 1], &c__1, &x[j + 1], &
				c__1);
			csumj.r = q__1.r, csumj.i = q__1.i;
		    }
		} else {

/*                 Otherwise, use in-line code for the dot product. */

		    if (upper) {
			i__3 = j - 1;
			for (i__ = 1; i__ <= i__3; ++i__) {
			    r_cnjg(&q__4, &ap[ip - j + i__]);
			    q__3.r = q__4.r * uscal.r - q__4.i * uscal.i, 
				    q__3.i = q__4.r * uscal.i + q__4.i * 
				    uscal.r;
			    i__4 = i__;
			    q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, 
				    q__2.i = q__3.r * x[i__4].i + q__3.i * x[
				    i__4].r;
			    q__1.r = csumj.r + q__2.r, q__1.i = csumj.i + 
				    q__2.i;
			    csumj.r = q__1.r, csumj.i = q__1.i;
/* L160: */
			}
		    } else if (j < *n) {
			i__3 = *n - j;
			for (i__ = 1; i__ <= i__3; ++i__) {
			    r_cnjg(&q__4, &ap[ip + i__]);
			    q__3.r = q__4.r * uscal.r - q__4.i * uscal.i, 
				    q__3.i = q__4.r * uscal.i + q__4.i * 
				    uscal.r;
			    i__4 = j + i__;
			    q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, 
				    q__2.i = q__3.r * x[i__4].i + q__3.i * x[
				    i__4].r;
			    q__1.r = csumj.r + q__2.r, q__1.i = csumj.i + 
				    q__2.i;
			    csumj.r = q__1.r, csumj.i = q__1.i;
/* L170: */
			}
		    }
		}

		q__1.r = tscal, q__1.i = 0.f;
		if (uscal.r == q__1.r && uscal.i == q__1.i) {

/*                 Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j)   
                   was not used to scale the dotproduct. */

		    i__3 = j;
		    i__4 = j;
		    q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i - 
			    csumj.i;
		    x[i__3].r = q__1.r, x[i__3].i = q__1.i;
		    i__3 = j;
		    xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
			    ), dabs(r__2));
		    if (nounit) {

/*                    Compute x(j) = x(j) / A(j,j), scaling if necessary. */

			r_cnjg(&q__2, &ap[ip]);
			q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
			tjjs.r = q__1.r, tjjs.i = q__1.i;
		    } else {
			tjjs.r = tscal, tjjs.i = 0.f;
			if (tscal == 1.f) {
			    goto L185;
			}
		    }
		    tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
			     dabs(r__2));
		    if (tjj > smlnum) {

/*                       abs(A(j,j)) > SMLNUM: */

			if (tjj < 1.f) {
			    if (xj > tjj * bignum) {

/*                             Scale X by 1/abs(x(j)). */

				rec = 1.f / xj;
				csscal_(n, &rec, &x[1], &c__1);
				*scale *= rec;
				xmax *= rec;
			    }
			}
			i__3 = j;
			cladiv_(&q__1, &x[j], &tjjs);
			x[i__3].r = q__1.r, x[i__3].i = q__1.i;
		    } else if (tjj > 0.f) {

/*                       0 < abs(A(j,j)) <= SMLNUM: */

			if (xj > tjj * bignum) {

/*                          Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */

			    rec = tjj * bignum / xj;
			    csscal_(n, &rec, &x[1], &c__1);
			    *scale *= rec;
			    xmax *= rec;
			}
			i__3 = j;
			cladiv_(&q__1, &x[j], &tjjs);
			x[i__3].r = q__1.r, x[i__3].i = q__1.i;
		    } else {

/*                       A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and   
                         scale = 0 and compute a solution to A**H *x = 0. */

			i__3 = *n;
			for (i__ = 1; i__ <= i__3; ++i__) {
			    i__4 = i__;
			    x[i__4].r = 0.f, x[i__4].i = 0.f;
/* L180: */
			}
			i__3 = j;
			x[i__3].r = 1.f, x[i__3].i = 0.f;
			*scale = 0.f;
			xmax = 0.f;
		    }
L185:
		    ;
		} else {

/*                 Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot   
                   product has already been divided by 1/A(j,j). */

		    i__3 = j;
		    cladiv_(&q__2, &x[j], &tjjs);
		    q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i;
		    x[i__3].r = q__1.r, x[i__3].i = q__1.i;
		}
/* Computing MAX */
		i__3 = j;
		r__3 = xmax, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = 
			r_imag(&x[j]), dabs(r__2));
		xmax = dmax(r__3,r__4);
		++jlen;
		ip += jinc * jlen;
/* L190: */
	    }
	}
	*scale /= tscal;
    }

/*     Scale the column norms by 1/TSCAL for return. */

    if (tscal != 1.f) {
	r__1 = 1.f / tscal;
	sscal_(n, &r__1, &cnorm[1], &c__1);
    }

    return 0;

/*     End of CLATPS */

} /* clatps_ */
示例#11
0
文件: chpgvx.c 项目: csapng/libflame
/* 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 */
}
示例#12
0
文件: ctprfs.c 项目: otoauler/sdkpub
/* 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)
{
    /*  -- 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
        =======

        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

        =====================================================================


           Test the input parameters.

           Parameter adjustments */
    /* Table of constant values */
    static integer c__1 = 1;

    /* 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 */
    static integer kase;
    static real safe1, safe2;
    static integer i__, j, k;
    static real s;
    extern logical lsame_(char *, char *);
    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 logical upper;
    extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *,
                                       complex *, complex *, integer *);
    static integer kc;
    extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real
                                        *, integer *);
    static real xk;
    extern doublereal slamch_(char *);
    static integer nz;
    static real safmin;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    static logical notran;
    static char transn[1], transt[1];
    static logical nounit;
    static real lstres, 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)]


    --ap;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1 * 1;
    b -= b_offset;
    x_dim1 = *ldx;
    x_offset = 1 + x_dim1 * 1;
    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_ref(1, j), &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_ref(1, j), &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 = b_subscr(i__, j);
            rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
                         b_ref(i__, j)), 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 = x_subscr(k, j);
                        xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
                                                               x_ref(k, j)), 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 = x_subscr(k, j);
                        xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
                                                               x_ref(k, j)), 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 = x_subscr(k, j);
                        xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
                                                               x_ref(k, j)), 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 = x_subscr(k, j);
                        xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
                                                               x_ref(k, j)), 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 = x_subscr(i__, j);
                            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_ref(i__, j)), dabs(r__4)));
                            /* L110: */
                        }
                        rwork[k] += s;
                        kc += k;
                        /* L120: */
                    }
                } else {
                    i__2 = *n;
                    for (k = 1; k <= i__2; ++k) {
                        i__3 = x_subscr(k, j);
                        s = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
                                                              x_ref(k, j)), dabs(r__2));
                        i__3 = k - 1;
                        for (i__ = 1; i__ <= i__3; ++i__) {
                            i__4 = kc + i__ - 1;
                            i__5 = x_subscr(i__, j);
                            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_ref(i__, j)), 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 = x_subscr(i__, j);
                            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_ref(i__, j)), 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 = x_subscr(k, j);
                        s = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
                                                              x_ref(k, j)), dabs(r__2));
                        i__3 = *n;
                        for (i__ = k + 1; i__ <= i__3; ++i__) {
                            i__4 = kc + i__ - k;
                            i__5 = x_subscr(i__, j);
                            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_ref(i__, j)), 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 CLACON 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:
        clacon_(n, &work[*n + 1], &work[1], &ferr[j], &kase);
        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 = x_subscr(i__, j);
            r__3 = lstres, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
                                      r_imag(&x_ref(i__, j)), dabs(r__2));
            lstres = dmax(r__3,r__4);
            /* L240: */
        }
        if (lstres != 0.f) {
            ferr[j] /= lstres;
        }

        /* L250: */
    }

    return 0;

    /*     End of CTPRFS */

} /* ctprfs_ */
示例#13
0
void cblas_ctpsv(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_ctpsv","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_ctpsv","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_ctpsv","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
      ctpsv_( 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_ctpsv","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;
 
            n = N*2*(tincX);
 
            x++;

            st=x+n;

            i = tincX << 1;
            do
            {
               *x = -(*x);
               x+=i;
            }
            while (x != st);
            x -= n;
         }
      }
      else 
      {
         cblas_xerbla(3, "cblas_ctpsv","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_ctpsv","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

      ctpsv_( 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_ctpsv", "Illegal Order setting, %d\n", order);
   CBLAS_CallFromC = 0;
   RowMajorStrg = 0;
   return;
}
示例#14
0
文件: chpgst.c 项目: csapng/libflame
/* 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 */
}