Ejemplo n.º 1
0
int GMRFLib_comp_posdef_inverse(double *matrix, int dim)
{
	/*
	 * overwrite a symmetric MATRIX with its inverse 
	 */
	int info = 0, i, j;

	switch (GMRFLib_blas_level) {
	case BLAS_LEVEL2:
		dpotf2_("L", &dim, matrix, &dim, &info, 1);
		break;
	case BLAS_LEVEL3:
		dpotrf_("L", &dim, matrix, &dim, &info, 1);
		break;
	default:
		GMRFLib_ASSERT(1 == 0, GMRFLib_ESNH);
		break;
	}
	if (info)
		GMRFLib_ERROR(GMRFLib_ESINGMAT);

	dpotri_("L", &dim, matrix, &dim, &info, 1);
	if (info)
		GMRFLib_ERROR(GMRFLib_ESINGMAT);

	for (i = 0; i < dim; i++)			       /* fill the U-part */
		for (j = i + 1; j < dim; j++)
			matrix[i + j * dim] = matrix[j + i * dim];

	return GMRFLib_SUCCESS;
}
Ejemplo n.º 2
0
int GMRFLib_comp_chol_general(double **chol, double *matrix, int dim, double *logdet, int ecode)
{
	/*
	 * return a malloc'ed cholesky factorisation of MATRIX in *chol and optional the log(determinant). if fail return
	 * `ecode'
	 * 
	 */
	int info = 0, i, j;
	double *a = NULL, det;

	if (dim == 0) {
		*chol = NULL;
		return GMRFLib_SUCCESS;
	}

	a = Calloc(ISQR(dim), double);
	memcpy(a, matrix, ISQR(dim) * sizeof(double));

	switch (GMRFLib_blas_level) {
	case BLAS_LEVEL2:
		dpotf2_("L", &dim, a, &dim, &info, 1);
		break;
	case BLAS_LEVEL3:
		dpotrf_("L", &dim, a, &dim, &info, 1);
		break;
	default:
		GMRFLib_ASSERT(1 == 0, GMRFLib_ESNH);
		break;
	}

	if (info) {
		Free(a);
		*chol = NULL;

		return ecode;
	}

	if (logdet) {
		for (det = 0.0, i = 0; i < dim; i++) {
			det += log(a[i + i * dim]);
		}
		*logdet = 2.0 * det;
	}

	for (i = 0; i < dim; i++) {			       /* set to zero the upper part */
		for (j = i + 1; j < dim; j++) {
			a[i + j * dim] = 0.0;
		}
	}

	*chol = a;
	return GMRFLib_SUCCESS;
}
double dcholfact(int n, double *A, double *L)
{
	/* if A is p.d. , A = L*L'
	   if A is p.s.d. , A + lambda*I = L*L'; */  
	int indef, i;
	static double lambda = 1e-3/512/512;
	memcpy(L, A, sizeof(double)*n*n);
	dpotf2_("L", &n, L, &n, &indef);
	if (indef != 0)
	{
		memcpy(L, A, sizeof(double)*n*n);
		for (i=0;i<n;i++)
			L[i*n+i] += lambda; 
		dpotf2_("L", &n, L, &n, &indef);
		if (indef != 0)
		{
			printf("A is not positive semi-definite\n");
			lambda *= 2;
		}
		return lambda;
	}
	return 0;
}
Ejemplo n.º 4
0
/* Subroutine */ int dpotrf_(char *uplo, integer *n, doublereal *a, integer *
                             lda, integer *info)
{
    /* System generated locals */
    integer a_dim1, a_offset, i__1, i__2, i__3, i__4;

    /* Local variables */
    integer j, jb, nb;
    extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
                                       integer *, doublereal *, doublereal *, integer *, doublereal *,
                                       integer *, doublereal *, doublereal *, integer *);
    extern logical lsame_(char *, char *);
    extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
                                       integer *, integer *, doublereal *, doublereal *, integer *,
                                       doublereal *, integer *);
    logical upper;
    extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
                                       doublereal *, doublereal *, integer *, doublereal *, doublereal *,
                                       integer *), dpotf2_(char *, integer *,
                                               doublereal *, integer *, integer *), xerbla_(char *,
                                                       integer *);
    extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
                           integer *, integer *);


    /*  -- LAPACK routine (version 3.2) -- */
    /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
    /*     November 2006 */

    /*     .. Scalar Arguments .. */
    /*     .. */
    /*     .. Array Arguments .. */
    /*     .. */

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

    /*  DPOTRF computes the Cholesky factorization of a real symmetric */
    /*  positive definite matrix A. */

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

    /*  This is the block version of the algorithm, calling Level 3 BLAS. */

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

    /*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
    /*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading */
    /*          N-by-N upper triangular part of A contains the upper */
    /*          triangular part of the matrix A, and the strictly lower */
    /*          triangular part of A is not referenced.  If UPLO = 'L', the */
    /*          leading N-by-N lower triangular part of A contains the lower */
    /*          triangular part of the matrix A, and the strictly upper */
    /*          triangular part of A is not referenced. */

    /*          On exit, if INFO = 0, the factor U or L from the Cholesky */
    /*          factorization A = U**T*U or A = L*L**T. */

    /*  LDA     (input) INTEGER */
    /*          The leading dimension of the array A.  LDA >= 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 leading minor of order i is not */
    /*                positive definite, and the factorization could not be */
    /*                completed. */

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

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

    /*     Test the input parameters. */

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;

    /* Function Body */
    *info = 0;
    upper = lsame_(uplo, "U");
    if (! upper && ! lsame_(uplo, "L")) {
        *info = -1;
    } else if (*n < 0) {
        *info = -2;
    } else if (*lda < max(1,*n)) {
        *info = -4;
    }
    if (*info != 0) {
        i__1 = -(*info);
        xerbla_("DPOTRF", &i__1);
        return 0;
    }

    /*     Quick return if possible */

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

    /*     Determine the block size for this environment. */

    nb = ilaenv_(&c__1, "DPOTRF", uplo, n, &c_n1, &c_n1, &c_n1);
    if (nb <= 1 || nb >= *n) {

        /*        Use unblocked code. */

        dpotf2_(uplo, n, &a[a_offset], lda, info);
    } else {

        /*        Use blocked code. */

        if (upper) {

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

            i__1 = *n;
            i__2 = nb;
            for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {

                /*              Update and factorize the current diagonal block and test */
                /*              for non-positive-definiteness. */

                /* Computing MIN */
                i__3 = nb, i__4 = *n - j + 1;
                jb = min(i__3,i__4);
                i__3 = j - 1;
                dsyrk_("Upper", "Transpose", &jb, &i__3, &c_b13, &a[j *
                        a_dim1 + 1], lda, &c_b14, &a[j + j * a_dim1], lda);
                dpotf2_("Upper", &jb, &a[j + j * a_dim1], lda, info);
                if (*info != 0) {
                    goto L30;
                }
                if (j + jb <= *n) {

                    /*                 Compute the current block row. */

                    i__3 = *n - j - jb + 1;
                    i__4 = j - 1;
                    dgemm_("Transpose", "No transpose", &jb, &i__3, &i__4, &
                           c_b13, &a[j * a_dim1 + 1], lda, &a[(j + jb) *
                                   a_dim1 + 1], lda, &c_b14, &a[j + (j + jb) *
                                           a_dim1], lda);
                    i__3 = *n - j - jb + 1;
                    dtrsm_("Left", "Upper", "Transpose", "Non-unit", &jb, &
                           i__3, &c_b14, &a[j + j * a_dim1], lda, &a[j + (j
                                   + jb) * a_dim1], lda);
                }
                /* L10: */
            }

        } else {

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

            i__2 = *n;
            i__1 = nb;
            for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {

                /*              Update and factorize the current diagonal block and test */
                /*              for non-positive-definiteness. */

                /* Computing MIN */
                i__3 = nb, i__4 = *n - j + 1;
                jb = min(i__3,i__4);
                i__3 = j - 1;
                dsyrk_("Lower", "No transpose", &jb, &i__3, &c_b13, &a[j +
                        a_dim1], lda, &c_b14, &a[j + j * a_dim1], lda);
                dpotf2_("Lower", &jb, &a[j + j * a_dim1], lda, info);
                if (*info != 0) {
                    goto L30;
                }
                if (j + jb <= *n) {

                    /*                 Compute the current block column. */

                    i__3 = *n - j - jb + 1;
                    i__4 = j - 1;
                    dgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &
                           c_b13, &a[j + jb + a_dim1], lda, &a[j + a_dim1],
                           lda, &c_b14, &a[j + jb + j * a_dim1], lda);
                    i__3 = *n - j - jb + 1;
                    dtrsm_("Right", "Lower", "Transpose", "Non-unit", &i__3, &
                           jb, &c_b14, &a[j + j * a_dim1], lda, &a[j + jb +
                                   j * a_dim1], lda);
                }
                /* L20: */
            }
        }
    }
    goto L40;

L30:
    *info = *info + j - 1;

L40:
    return 0;

    /*     End of DPOTRF */

} /* dpotrf_ */
Ejemplo n.º 5
0
/* Subroutine */ HYPRE_Int dpotrf_(char *uplo, integer *n, doublereal *a, integer *
	lda, integer *info)
{
/*  -- LAPACK routine (version 3.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       March 31, 1993   


    Purpose   
    =======   

    DPOTRF computes the Cholesky factorization of a real symmetric   
    positive definite matrix A.   

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

    This is the block version of the algorithm, calling Level 3 BLAS.   

    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.   

    A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)   
            On entry, the symmetric matrix A.  If UPLO = 'U', the leading   
            N-by-N upper triangular part of A contains the upper   
            triangular part of the matrix A, and the strictly lower   
            triangular part of A is not referenced.  If UPLO = 'L', the   
            leading N-by-N lower triangular part of A contains the lower   
            triangular part of the matrix A, and the strictly upper   
            triangular part of A is not referenced.   

            On exit, if INFO = 0, the factor U or L from the Cholesky   
            factorization A = U**T*U or A = L*L**T.   

    LDA     (input) INTEGER   
            The leading dimension of the array A.  LDA >= 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 leading minor of order i is not   
                  positive definite, and the factorization could not be   
                  completed.   

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


       Test the input parameters.   

       Parameter adjustments */
    /* Table of constant values */
    static integer c__1 = 1;
    static integer c_n1 = -1;
    static doublereal c_b13 = -1.;
    static doublereal c_b14 = 1.;
    
    /* System generated locals */
    integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
    /* Local variables */
    static integer j;
    extern /* Subroutine */ HYPRE_Int dgemm_(char *, char *, integer *, integer *, 
	    integer *, doublereal *, doublereal *, integer *, doublereal *, 
	    integer *, doublereal *, doublereal *, integer *);
    extern logical lsame_(char *, char *);
    extern /* Subroutine */ HYPRE_Int dtrsm_(char *, char *, char *, char *, 
	    integer *, integer *, doublereal *, doublereal *, integer *, 
	    doublereal *, integer *);
    static logical upper;
    extern /* Subroutine */ HYPRE_Int dsyrk_(char *, char *, integer *, integer *, 
	    doublereal *, doublereal *, integer *, doublereal *, doublereal *,
	     integer *), dpotf2_(char *, integer *, 
	    doublereal *, integer *, integer *);
    static integer jb, nb;
    extern /* Subroutine */ HYPRE_Int xerbla_(char *, integer *);
    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
	    integer *, integer *, ftnlen, ftnlen);
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]


    a_dim1 = *lda;
    a_offset = 1 + a_dim1 * 1;
    a -= a_offset;

    /* Function Body */
    *info = 0;
    upper = lsame_(uplo, "U");
    if (! upper && ! lsame_(uplo, "L")) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    } else if (*lda < max(1,*n)) {
	*info = -4;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DPOTRF", &i__1);
	return 0;
    }

/*     Quick return if possible */

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

/*     Determine the block size for this environment. */

    nb = ilaenv_(&c__1, "DPOTRF", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (
	    ftnlen)1);
    if (nb <= 1 || nb >= *n) {

/*        Use unblocked code. */

	dpotf2_(uplo, n, &a[a_offset], lda, info);
    } else {

/*        Use blocked code. */

	if (upper) {

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

	    i__1 = *n;
	    i__2 = nb;
	    for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {

/*              Update and factorize the current diagonal block and test   
                for non-positive-definiteness.   

   Computing MIN */
		i__3 = nb, i__4 = *n - j + 1;
		jb = min(i__3,i__4);
		i__3 = j - 1;
		dsyrk_("Upper", "Transpose", &jb, &i__3, &c_b13, &a_ref(1, j),
			 lda, &c_b14, &a_ref(j, j), lda)
			;
		dpotf2_("Upper", &jb, &a_ref(j, j), lda, info);
		if (*info != 0) {
		    goto L30;
		}
		if (j + jb <= *n) {

/*                 Compute the current block row. */

		    i__3 = *n - j - jb + 1;
		    i__4 = j - 1;
		    dgemm_("Transpose", "No transpose", &jb, &i__3, &i__4, &
			    c_b13, &a_ref(1, j), lda, &a_ref(1, j + jb), lda, 
			    &c_b14, &a_ref(j, j + jb), lda);
		    i__3 = *n - j - jb + 1;
		    dtrsm_("Left", "Upper", "Transpose", "Non-unit", &jb, &
			    i__3, &c_b14, &a_ref(j, j), lda, &a_ref(j, j + jb)
			    , lda)
			    ;
		}
/* L10: */
	    }

	} else {

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

	    i__2 = *n;
	    i__1 = nb;
	    for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {

/*              Update and factorize the current diagonal block and test   
                for non-positive-definiteness.   

   Computing MIN */
		i__3 = nb, i__4 = *n - j + 1;
		jb = min(i__3,i__4);
		i__3 = j - 1;
		dsyrk_("Lower", "No transpose", &jb, &i__3, &c_b13, &a_ref(j, 
			1), lda, &c_b14, &a_ref(j, j), lda);
		dpotf2_("Lower", &jb, &a_ref(j, j), lda, info);
		if (*info != 0) {
		    goto L30;
		}
		if (j + jb <= *n) {

/*                 Compute the current block column. */

		    i__3 = *n - j - jb + 1;
		    i__4 = j - 1;
		    dgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &
			    c_b13, &a_ref(j + jb, 1), lda, &a_ref(j, 1), lda, 
			    &c_b14, &a_ref(j + jb, j), lda);
		    i__3 = *n - j - jb + 1;
		    dtrsm_("Right", "Lower", "Transpose", "Non-unit", &i__3, &
			    jb, &c_b14, &a_ref(j, j), lda, &a_ref(j + jb, j), 
			    lda);
		}
/* L20: */
	    }
	}
    }
    goto L40;

L30:
    *info = *info + j - 1;

L40:
    return 0;

/*     End of DPOTRF */

} /* dpotrf_ */
Ejemplo n.º 6
0
/* Subroutine */ int derrpo_(char *path, integer *nunit)
{
    /* Builtin functions */
    integer s_wsle(cilist *), e_wsle(void);
    /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);

    /* Local variables */
    doublereal a[16]	/* was [4][4] */, b[4];
    integer i__, j;
    doublereal w[12], x[4];
    char c2[2];
    doublereal r1[4], r2[4], af[16]	/* was [4][4] */;
    integer iw[4], info;
    doublereal anrm, rcond;
    extern /* Subroutine */ int dpbtf2_(char *, integer *, integer *, 
	    doublereal *, integer *, integer *), dpotf2_(char *, 
	    integer *, doublereal *, integer *, integer *), alaesm_(
	    char *, logical *, integer *), dpbcon_(char *, integer *, 
	    integer *, doublereal *, integer *, doublereal *, doublereal *, 
	    doublereal *, integer *, integer *);
    extern logical lsamen_(integer *, char *, char *);
    extern /* Subroutine */ int dpbequ_(char *, integer *, integer *, 
	    doublereal *, integer *, doublereal *, doublereal *, doublereal *, 
	     integer *), dpbrfs_(char *, integer *, integer *, 
	    integer *, doublereal *, integer *, doublereal *, integer *, 
	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
	    doublereal *, doublereal *, integer *, integer *), 
	    dpbtrf_(char *, integer *, integer *, doublereal *, integer *, 
	    integer *), dpocon_(char *, integer *, doublereal *, 
	    integer *, doublereal *, doublereal *, doublereal *, integer *, 
	    integer *), chkxer_(char *, integer *, integer *, logical 
	    *, logical *), dppcon_(char *, integer *, doublereal *, 
	    doublereal *, doublereal *, doublereal *, integer *, integer *), dpoequ_(integer *, doublereal *, integer *, doublereal *, 
	     doublereal *, doublereal *, integer *), dpbtrs_(char *, integer *
, integer *, integer *, doublereal *, integer *, doublereal *, 
	    integer *, integer *), dporfs_(char *, integer *, integer 
	    *, doublereal *, integer *, doublereal *, integer *, doublereal *, 
	     integer *, doublereal *, integer *, doublereal *, doublereal *, 
	    doublereal *, integer *, integer *), dpotrf_(char *, 
	    integer *, doublereal *, integer *, integer *), dpotri_(
	    char *, integer *, doublereal *, integer *, integer *), 
	    dppequ_(char *, integer *, doublereal *, doublereal *, doublereal 
	    *, doublereal *, integer *), dpprfs_(char *, integer *, 
	    integer *, doublereal *, doublereal *, doublereal *, integer *, 
	    doublereal *, integer *, doublereal *, doublereal *, doublereal *, 
	     integer *, integer *), dpptrf_(char *, integer *, 
	    doublereal *, integer *), dpptri_(char *, integer *, 
	    doublereal *, integer *), dpotrs_(char *, integer *, 
	    integer *, doublereal *, integer *, doublereal *, integer *, 
	    integer *), dpptrs_(char *, integer *, integer *, 
	    doublereal *, doublereal *, integer *, integer *);

    /* Fortran I/O blocks */
    static cilist io___1 = { 0, 0, 0, 0, 0 };



/*  -- LAPACK test routine (version 3.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */

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

/*  DERRPO tests the error exits for the DOUBLE PRECISION routines */
/*  for symmetric positive definite matrices. */

/*  Arguments */
/*  ========= */

/*  PATH    (input) CHARACTER*3 */
/*          The LAPACK path name for the routines to be tested. */

/*  NUNIT   (input) INTEGER */
/*          The unit number for output. */

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. Local Arrays .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Scalars in Common .. */
/*     .. */
/*     .. Common blocks .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Executable Statements .. */

    infoc_1.nout = *nunit;
    io___1.ciunit = infoc_1.nout;
    s_wsle(&io___1);
    e_wsle();
    s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);

/*     Set the variables to innocuous values. */

    for (j = 1; j <= 4; ++j) {
	for (i__ = 1; i__ <= 4; ++i__) {
	    a[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
	    af[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
/* L10: */
	}
	b[j - 1] = 0.;
	r1[j - 1] = 0.;
	r2[j - 1] = 0.;
	w[j - 1] = 0.;
	x[j - 1] = 0.;
	iw[j - 1] = j;
/* L20: */
    }
    infoc_1.ok = TRUE_;

    if (lsamen_(&c__2, c2, "PO")) {

/*        Test error exits of the routines that use the Cholesky */
/*        decomposition of a symmetric positive definite matrix. */

/*        DPOTRF */

	s_copy(srnamc_1.srnamt, "DPOTRF", (ftnlen)32, (ftnlen)6);
	infoc_1.infot = 1;
	dpotrf_("/", &c__0, a, &c__1, &info);
	chkxer_("DPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	dpotrf_("U", &c_n1, a, &c__1, &info);
	chkxer_("DPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 4;
	dpotrf_("U", &c__2, a, &c__1, &info);
	chkxer_("DPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

/*        DPOTF2 */

	s_copy(srnamc_1.srnamt, "DPOTF2", (ftnlen)32, (ftnlen)6);
	infoc_1.infot = 1;
	dpotf2_("/", &c__0, a, &c__1, &info);
	chkxer_("DPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	dpotf2_("U", &c_n1, a, &c__1, &info);
	chkxer_("DPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 4;
	dpotf2_("U", &c__2, a, &c__1, &info);
	chkxer_("DPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

/*        DPOTRI */

	s_copy(srnamc_1.srnamt, "DPOTRI", (ftnlen)32, (ftnlen)6);
	infoc_1.infot = 1;
	dpotri_("/", &c__0, a, &c__1, &info);
	chkxer_("DPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	dpotri_("U", &c_n1, a, &c__1, &info);
	chkxer_("DPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 4;
	dpotri_("U", &c__2, a, &c__1, &info);
	chkxer_("DPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

/*        DPOTRS */

	s_copy(srnamc_1.srnamt, "DPOTRS", (ftnlen)32, (ftnlen)6);
	infoc_1.infot = 1;
	dpotrs_("/", &c__0, &c__0, a, &c__1, b, &c__1, &info);
	chkxer_("DPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	dpotrs_("U", &c_n1, &c__0, a, &c__1, b, &c__1, &info);
	chkxer_("DPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 3;
	dpotrs_("U", &c__0, &c_n1, a, &c__1, b, &c__1, &info);
	chkxer_("DPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 5;
	dpotrs_("U", &c__2, &c__1, a, &c__1, b, &c__2, &info);
	chkxer_("DPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 7;
	dpotrs_("U", &c__2, &c__1, a, &c__2, b, &c__1, &info);
	chkxer_("DPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

/*        DPORFS */

	s_copy(srnamc_1.srnamt, "DPORFS", (ftnlen)32, (ftnlen)6);
	infoc_1.infot = 1;
	dporfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &c__1, 
		r1, r2, w, iw, &info);
	chkxer_("DPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	dporfs_("U", &c_n1, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &c__1, 
		r1, r2, w, iw, &info);
	chkxer_("DPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 3;
	dporfs_("U", &c__0, &c_n1, a, &c__1, af, &c__1, b, &c__1, x, &c__1, 
		r1, r2, w, iw, &info);
	chkxer_("DPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 5;
	dporfs_("U", &c__2, &c__1, a, &c__1, af, &c__2, b, &c__2, x, &c__2, 
		r1, r2, w, iw, &info);
	chkxer_("DPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 7;
	dporfs_("U", &c__2, &c__1, a, &c__2, af, &c__1, b, &c__2, x, &c__2, 
		r1, r2, w, iw, &info);
	chkxer_("DPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 9;
	dporfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, b, &c__1, x, &c__2, 
		r1, r2, w, iw, &info);
	chkxer_("DPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 11;
	dporfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, b, &c__2, x, &c__1, 
		r1, r2, w, iw, &info);
	chkxer_("DPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

/*        DPOCON */

	s_copy(srnamc_1.srnamt, "DPOCON", (ftnlen)32, (ftnlen)6);
	infoc_1.infot = 1;
	dpocon_("/", &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
	chkxer_("DPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	dpocon_("U", &c_n1, a, &c__1, &anrm, &rcond, w, iw, &info);
	chkxer_("DPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 4;
	dpocon_("U", &c__2, a, &c__1, &anrm, &rcond, w, iw, &info);
	chkxer_("DPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

/*        DPOEQU */

	s_copy(srnamc_1.srnamt, "DPOEQU", (ftnlen)32, (ftnlen)6);
	infoc_1.infot = 1;
	dpoequ_(&c_n1, a, &c__1, r1, &rcond, &anrm, &info);
	chkxer_("DPOEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 3;
	dpoequ_(&c__2, a, &c__1, r1, &rcond, &anrm, &info);
	chkxer_("DPOEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

    } else if (lsamen_(&c__2, c2, "PP")) {

/*        Test error exits of the routines that use the Cholesky */
/*        decomposition of a symmetric positive definite packed matrix. */

/*        DPPTRF */

	s_copy(srnamc_1.srnamt, "DPPTRF", (ftnlen)32, (ftnlen)6);
	infoc_1.infot = 1;
	dpptrf_("/", &c__0, a, &info);
	chkxer_("DPPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	dpptrf_("U", &c_n1, a, &info);
	chkxer_("DPPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

/*        DPPTRI */

	s_copy(srnamc_1.srnamt, "DPPTRI", (ftnlen)32, (ftnlen)6);
	infoc_1.infot = 1;
	dpptri_("/", &c__0, a, &info);
	chkxer_("DPPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	dpptri_("U", &c_n1, a, &info);
	chkxer_("DPPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

/*        DPPTRS */

	s_copy(srnamc_1.srnamt, "DPPTRS", (ftnlen)32, (ftnlen)6);
	infoc_1.infot = 1;
	dpptrs_("/", &c__0, &c__0, a, b, &c__1, &info);
	chkxer_("DPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	dpptrs_("U", &c_n1, &c__0, a, b, &c__1, &info);
	chkxer_("DPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 3;
	dpptrs_("U", &c__0, &c_n1, a, b, &c__1, &info);
	chkxer_("DPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 6;
	dpptrs_("U", &c__2, &c__1, a, b, &c__1, &info);
	chkxer_("DPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

/*        DPPRFS */

	s_copy(srnamc_1.srnamt, "DPPRFS", (ftnlen)32, (ftnlen)6);
	infoc_1.infot = 1;
	dpprfs_("/", &c__0, &c__0, a, af, b, &c__1, x, &c__1, r1, r2, w, iw, &
		info);
	chkxer_("DPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	dpprfs_("U", &c_n1, &c__0, a, af, b, &c__1, x, &c__1, r1, r2, w, iw, &
		info);
	chkxer_("DPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 3;
	dpprfs_("U", &c__0, &c_n1, a, af, b, &c__1, x, &c__1, r1, r2, w, iw, &
		info);
	chkxer_("DPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 7;
	dpprfs_("U", &c__2, &c__1, a, af, b, &c__1, x, &c__2, r1, r2, w, iw, &
		info);
	chkxer_("DPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 9;
	dpprfs_("U", &c__2, &c__1, a, af, b, &c__2, x, &c__1, r1, r2, w, iw, &
		info);
	chkxer_("DPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

/*        DPPCON */

	s_copy(srnamc_1.srnamt, "DPPCON", (ftnlen)32, (ftnlen)6);
	infoc_1.infot = 1;
	dppcon_("/", &c__0, a, &anrm, &rcond, w, iw, &info);
	chkxer_("DPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	dppcon_("U", &c_n1, a, &anrm, &rcond, w, iw, &info);
	chkxer_("DPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

/*        DPPEQU */

	s_copy(srnamc_1.srnamt, "DPPEQU", (ftnlen)32, (ftnlen)6);
	infoc_1.infot = 1;
	dppequ_("/", &c__0, a, r1, &rcond, &anrm, &info);
	chkxer_("DPPEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	dppequ_("U", &c_n1, a, r1, &rcond, &anrm, &info);
	chkxer_("DPPEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

    } else if (lsamen_(&c__2, c2, "PB")) {

/*        Test error exits of the routines that use the Cholesky */
/*        decomposition of a symmetric positive definite band matrix. */

/*        DPBTRF */

	s_copy(srnamc_1.srnamt, "DPBTRF", (ftnlen)32, (ftnlen)6);
	infoc_1.infot = 1;
	dpbtrf_("/", &c__0, &c__0, a, &c__1, &info);
	chkxer_("DPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	dpbtrf_("U", &c_n1, &c__0, a, &c__1, &info);
	chkxer_("DPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 3;
	dpbtrf_("U", &c__1, &c_n1, a, &c__1, &info);
	chkxer_("DPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 5;
	dpbtrf_("U", &c__2, &c__1, a, &c__1, &info);
	chkxer_("DPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

/*        DPBTF2 */

	s_copy(srnamc_1.srnamt, "DPBTF2", (ftnlen)32, (ftnlen)6);
	infoc_1.infot = 1;
	dpbtf2_("/", &c__0, &c__0, a, &c__1, &info);
	chkxer_("DPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	dpbtf2_("U", &c_n1, &c__0, a, &c__1, &info);
	chkxer_("DPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 3;
	dpbtf2_("U", &c__1, &c_n1, a, &c__1, &info);
	chkxer_("DPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 5;
	dpbtf2_("U", &c__2, &c__1, a, &c__1, &info);
	chkxer_("DPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

/*        DPBTRS */

	s_copy(srnamc_1.srnamt, "DPBTRS", (ftnlen)32, (ftnlen)6);
	infoc_1.infot = 1;
	dpbtrs_("/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &info);
	chkxer_("DPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	dpbtrs_("U", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, &info);
	chkxer_("DPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 3;
	dpbtrs_("U", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, &info);
	chkxer_("DPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 4;
	dpbtrs_("U", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, &info);
	chkxer_("DPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 6;
	dpbtrs_("U", &c__2, &c__1, &c__1, a, &c__1, b, &c__1, &info);
	chkxer_("DPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 8;
	dpbtrs_("U", &c__2, &c__0, &c__1, a, &c__1, b, &c__1, &info);
	chkxer_("DPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

/*        DPBRFS */

	s_copy(srnamc_1.srnamt, "DPBRFS", (ftnlen)32, (ftnlen)6);
	infoc_1.infot = 1;
	dpbrfs_("/", &c__0, &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
		c__1, r1, r2, w, iw, &info);
	chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	dpbrfs_("U", &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
		c__1, r1, r2, w, iw, &info);
	chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 3;
	dpbrfs_("U", &c__1, &c_n1, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
		c__1, r1, r2, w, iw, &info);
	chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 4;
	dpbrfs_("U", &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, b, &c__1, x, &
		c__1, r1, r2, w, iw, &info);
	chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 6;
	dpbrfs_("U", &c__2, &c__1, &c__1, a, &c__1, af, &c__2, b, &c__2, x, &
		c__2, r1, r2, w, iw, &info);
	chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 8;
	dpbrfs_("U", &c__2, &c__1, &c__1, a, &c__2, af, &c__1, b, &c__2, x, &
		c__2, r1, r2, w, iw, &info);
	chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 10;
	dpbrfs_("U", &c__2, &c__0, &c__1, a, &c__1, af, &c__1, b, &c__1, x, &
		c__2, r1, r2, w, iw, &info);
	chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 12;
	dpbrfs_("U", &c__2, &c__0, &c__1, a, &c__1, af, &c__1, b, &c__2, x, &
		c__1, r1, r2, w, iw, &info);
	chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

/*        DPBCON */

	s_copy(srnamc_1.srnamt, "DPBCON", (ftnlen)32, (ftnlen)6);
	infoc_1.infot = 1;
	dpbcon_("/", &c__0, &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
	chkxer_("DPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	dpbcon_("U", &c_n1, &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
	chkxer_("DPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 3;
	dpbcon_("U", &c__1, &c_n1, a, &c__1, &anrm, &rcond, w, iw, &info);
	chkxer_("DPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 5;
	dpbcon_("U", &c__2, &c__1, a, &c__1, &anrm, &rcond, w, iw, &info);
	chkxer_("DPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);

/*        DPBEQU */

	s_copy(srnamc_1.srnamt, "DPBEQU", (ftnlen)32, (ftnlen)6);
	infoc_1.infot = 1;
	dpbequ_("/", &c__0, &c__0, a, &c__1, r1, &rcond, &anrm, &info);
	chkxer_("DPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 2;
	dpbequ_("U", &c_n1, &c__0, a, &c__1, r1, &rcond, &anrm, &info);
	chkxer_("DPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 3;
	dpbequ_("U", &c__1, &c_n1, a, &c__1, r1, &rcond, &anrm, &info);
	chkxer_("DPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
	infoc_1.infot = 5;
	dpbequ_("U", &c__2, &c__1, a, &c__1, r1, &rcond, &anrm, &info);
	chkxer_("DPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
		infoc_1.ok);
    }

/*     Print a summary line. */

    alaesm_(path, &infoc_1.ok, &infoc_1.nout);

    return 0;

/*     End of DERRPO */

} /* derrpo_ */
Ejemplo n.º 7
0
/* Subroutine */ int dpbtrf_(char *uplo, integer *n, integer *kd, doublereal *
                             ab, integer *ldab, integer *info)
{
    /*  -- LAPACK routine (version 3.0) --
           Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
           Courant Institute, Argonne National Lab, and Rice University
           March 31, 1993


        Purpose
        =======

        DPBTRF computes the Cholesky factorization of a real symmetric
        positive definite band matrix A.

        The factorization has the form
           A = U**T * U,  if UPLO = 'U', or
           A = L  * L**T,  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.

        KD      (input) INTEGER
                The number of superdiagonals of the matrix A if UPLO = 'U',
                or the number of subdiagonals if UPLO = 'L'.  KD >= 0.

        AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
                On entry, the upper or lower triangle of the symmetric band
                matrix A, stored in the first KD+1 rows of the array.  The
                j-th column of A is stored in the j-th column of the array AB
                as follows:
                if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
                if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).

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

        LDAB    (input) INTEGER
                The leading dimension of the array AB.  LDAB >= KD+1.

        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 band storage scheme is illustrated by the following example, when
        N = 6, KD = 2, and UPLO = 'U':

        On entry:                       On exit:

            *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46
            *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
           a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66

        Similarly, if UPLO = 'L' the format of A is as follows:

        On entry:                       On exit:

           a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66
           a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *
           a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *

        Array elements marked * are not used by the routine.

        Contributed by
        Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989

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


           Test the input parameters.

           Parameter adjustments */
    /* Table of constant values */
    static integer c__1 = 1;
    static integer c_n1 = -1;
    static doublereal c_b18 = 1.;
    static doublereal c_b21 = -1.;
    static integer c__33 = 33;

    /* System generated locals */
    integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
    /* Local variables */
    static doublereal work[1056]	/* was [33][32] */;
    static integer i__, j;
    extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
                                       integer *, doublereal *, doublereal *, integer *, doublereal *,
                                       integer *, doublereal *, doublereal *, integer *);
    extern logical lsame_(char *, char *);
    extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
                                       integer *, integer *, doublereal *, doublereal *, integer *,
                                       doublereal *, integer *);
    static integer i2, i3;
    extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
                                       doublereal *, doublereal *, integer *, doublereal *, doublereal *,
                                       integer *), dpbtf2_(char *, integer *, integer *,
                                               doublereal *, integer *, integer *), dpotf2_(char *,
                                                       integer *, doublereal *, integer *, integer *);
    static integer ib, nb, ii, jj;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
                           integer *, integer *, ftnlen, ftnlen);
#define work_ref(a_1,a_2) work[(a_2)*33 + a_1 - 34]
#define ab_ref(a_1,a_2) ab[(a_2)*ab_dim1 + a_1]


    ab_dim1 = *ldab;
    ab_offset = 1 + ab_dim1 * 1;
    ab -= ab_offset;

    /* Function Body */
    *info = 0;
    if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
        *info = -1;
    } else if (*n < 0) {
        *info = -2;
    } else if (*kd < 0) {
        *info = -3;
    } else if (*ldab < *kd + 1) {
        *info = -5;
    }
    if (*info != 0) {
        i__1 = -(*info);
        xerbla_("DPBTRF", &i__1);
        return 0;
    }

    /*     Quick return if possible */

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

    /*     Determine the block size for this environment */

    nb = ilaenv_(&c__1, "DPBTRF", uplo, n, kd, &c_n1, &c_n1, (ftnlen)6, (
                     ftnlen)1);

    /*     The block size must not exceed the semi-bandwidth KD, and must not
           exceed the limit set by the size of the local array WORK. */

    nb = min(nb,32);

    if (nb <= 1 || nb > *kd) {

        /*        Use unblocked code */

        dpbtf2_(uplo, n, kd, &ab[ab_offset], ldab, info);
    } else {

        /*        Use blocked code */

        if (lsame_(uplo, "U")) {

            /*           Compute the Cholesky factorization of a symmetric band
                         matrix, given the upper triangle of the matrix in band
                         storage.

                         Zero the upper triangle of the work array. */

            i__1 = nb;
            for (j = 1; j <= i__1; ++j) {
                i__2 = j - 1;
                for (i__ = 1; i__ <= i__2; ++i__) {
                    work_ref(i__, j) = 0.;
                    /* L10: */
                }
                /* L20: */
            }

            /*           Process the band matrix one diagonal block at a time. */

            i__1 = *n;
            i__2 = nb;
            for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
                /* Computing MIN */
                i__3 = nb, i__4 = *n - i__ + 1;
                ib = min(i__3,i__4);

                /*              Factorize the diagonal block */

                i__3 = *ldab - 1;
                dpotf2_(uplo, &ib, &ab_ref(*kd + 1, i__), &i__3, &ii);
                if (ii != 0) {
                    *info = i__ + ii - 1;
                    goto L150;
                }
                if (i__ + ib <= *n) {

                    /*                 Update the relevant part of the trailing submatrix.
                                       If A11 denotes the diagonal block which has just been
                                       factorized, then we need to update the remaining
                                       blocks in the diagram:

                                          A11   A12   A13
                                                A22   A23
                                                      A33

                                       The numbers of rows and columns in the partitioning
                                       are IB, I2, I3 respectively. The blocks A12, A22 and
                                       A23 are empty if IB = KD. The upper triangle of A13
                                       lies outside the band.

                       Computing MIN */
                    i__3 = *kd - ib, i__4 = *n - i__ - ib + 1;
                    i2 = min(i__3,i__4);
                    /* Computing MIN */
                    i__3 = ib, i__4 = *n - i__ - *kd + 1;
                    i3 = min(i__3,i__4);

                    if (i2 > 0) {

                        /*                    Update A12 */

                        i__3 = *ldab - 1;
                        i__4 = *ldab - 1;
                        dtrsm_("Left", "Upper", "Transpose", "Non-unit", &ib,
                               &i2, &c_b18, &ab_ref(*kd + 1, i__), &i__3, &
                               ab_ref(*kd + 1 - ib, i__ + ib), &i__4);

                        /*                    Update A22 */

                        i__3 = *ldab - 1;
                        i__4 = *ldab - 1;
                        dsyrk_("Upper", "Transpose", &i2, &ib, &c_b21, &
                               ab_ref(*kd + 1 - ib, i__ + ib), &i__3, &c_b18,
                               &ab_ref(*kd + 1, i__ + ib), &i__4);
                    }

                    if (i3 > 0) {

                        /*                    Copy the lower triangle of A13 into the work array. */

                        i__3 = i3;
                        for (jj = 1; jj <= i__3; ++jj) {
                            i__4 = ib;
                            for (ii = jj; ii <= i__4; ++ii) {
                                work_ref(ii, jj) = ab_ref(ii - jj + 1, jj +
                                                          i__ + *kd - 1);
                                /* L30: */
                            }
                            /* L40: */
                        }

                        /*                    Update A13 (in the work array). */

                        i__3 = *ldab - 1;
                        dtrsm_("Left", "Upper", "Transpose", "Non-unit", &ib,
                               &i3, &c_b18, &ab_ref(*kd + 1, i__), &i__3,
                               work, &c__33);

                        /*                    Update A23 */

                        if (i2 > 0) {
                            i__3 = *ldab - 1;
                            i__4 = *ldab - 1;
                            dgemm_("Transpose", "No Transpose", &i2, &i3, &ib,
                                   &c_b21, &ab_ref(*kd + 1 - ib, i__ + ib),
                                   &i__3, work, &c__33, &c_b18, &ab_ref(ib +
                                           1, i__ + *kd), &i__4);
                        }

                        /*                    Update A33 */

                        i__3 = *ldab - 1;
                        dsyrk_("Upper", "Transpose", &i3, &ib, &c_b21, work, &
                               c__33, &c_b18, &ab_ref(*kd + 1, i__ + *kd), &
                               i__3);

                        /*                    Copy the lower triangle of A13 back into place. */

                        i__3 = i3;
                        for (jj = 1; jj <= i__3; ++jj) {
                            i__4 = ib;
                            for (ii = jj; ii <= i__4; ++ii) {
                                ab_ref(ii - jj + 1, jj + i__ + *kd - 1) =
                                    work_ref(ii, jj);
                                /* L50: */
                            }
                            /* L60: */
                        }
                    }
                }
                /* L70: */
            }
        } else {

            /*           Compute the Cholesky factorization of a symmetric band
                         matrix, given the lower triangle of the matrix in band
                         storage.

                         Zero the lower triangle of the work array. */

            i__2 = nb;
            for (j = 1; j <= i__2; ++j) {
                i__1 = nb;
                for (i__ = j + 1; i__ <= i__1; ++i__) {
                    work_ref(i__, j) = 0.;
                    /* L80: */
                }
                /* L90: */
            }

            /*           Process the band matrix one diagonal block at a time. */

            i__2 = *n;
            i__1 = nb;
            for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
                /* Computing MIN */
                i__3 = nb, i__4 = *n - i__ + 1;
                ib = min(i__3,i__4);

                /*              Factorize the diagonal block */

                i__3 = *ldab - 1;
                dpotf2_(uplo, &ib, &ab_ref(1, i__), &i__3, &ii);
                if (ii != 0) {
                    *info = i__ + ii - 1;
                    goto L150;
                }
                if (i__ + ib <= *n) {

                    /*                 Update the relevant part of the trailing submatrix.
                                       If A11 denotes the diagonal block which has just been
                                       factorized, then we need to update the remaining
                                       blocks in the diagram:

                                          A11
                                          A21   A22
                                          A31   A32   A33

                                       The numbers of rows and columns in the partitioning
                                       are IB, I2, I3 respectively. The blocks A21, A22 and
                                       A32 are empty if IB = KD. The lower triangle of A31
                                       lies outside the band.

                       Computing MIN */
                    i__3 = *kd - ib, i__4 = *n - i__ - ib + 1;
                    i2 = min(i__3,i__4);
                    /* Computing MIN */
                    i__3 = ib, i__4 = *n - i__ - *kd + 1;
                    i3 = min(i__3,i__4);

                    if (i2 > 0) {

                        /*                    Update A21 */

                        i__3 = *ldab - 1;
                        i__4 = *ldab - 1;
                        dtrsm_("Right", "Lower", "Transpose", "Non-unit", &i2,
                               &ib, &c_b18, &ab_ref(1, i__), &i__3, &ab_ref(
                                   ib + 1, i__), &i__4);

                        /*                    Update A22 */

                        i__3 = *ldab - 1;
                        i__4 = *ldab - 1;
                        dsyrk_("Lower", "No Transpose", &i2, &ib, &c_b21, &
                               ab_ref(ib + 1, i__), &i__3, &c_b18, &ab_ref(1,
                                       i__ + ib), &i__4);
                    }

                    if (i3 > 0) {

                        /*                    Copy the upper triangle of A31 into the work array. */

                        i__3 = ib;
                        for (jj = 1; jj <= i__3; ++jj) {
                            i__4 = min(jj,i3);
                            for (ii = 1; ii <= i__4; ++ii) {
                                work_ref(ii, jj) = ab_ref(*kd + 1 - jj + ii,
                                                          jj + i__ - 1);
                                /* L100: */
                            }
                            /* L110: */
                        }

                        /*                    Update A31 (in the work array). */

                        i__3 = *ldab - 1;
                        dtrsm_("Right", "Lower", "Transpose", "Non-unit", &i3,
                               &ib, &c_b18, &ab_ref(1, i__), &i__3, work, &
                               c__33);

                        /*                    Update A32 */

                        if (i2 > 0) {
                            i__3 = *ldab - 1;
                            i__4 = *ldab - 1;
                            dgemm_("No transpose", "Transpose", &i3, &i2, &ib,
                                   &c_b21, work, &c__33, &ab_ref(ib + 1,
                                                                 i__), &i__3, &c_b18, &ab_ref(*kd + 1 - ib,
                                                                         i__ + ib), &i__4);
                        }

                        /*                    Update A33 */

                        i__3 = *ldab - 1;
                        dsyrk_("Lower", "No Transpose", &i3, &ib, &c_b21,
                               work, &c__33, &c_b18, &ab_ref(1, i__ + *kd), &
                               i__3);

                        /*                    Copy the upper triangle of A31 back into place. */

                        i__3 = ib;
                        for (jj = 1; jj <= i__3; ++jj) {
                            i__4 = min(jj,i3);
                            for (ii = 1; ii <= i__4; ++ii) {
                                ab_ref(*kd + 1 - jj + ii, jj + i__ - 1) =
                                    work_ref(ii, jj);
                                /* L120: */
                            }
                            /* L130: */
                        }
                    }
                }
                /* L140: */
            }
        }
    }
    return 0;

L150:
    return 0;

    /*     End of DPBTRF */

} /* dpbtrf_ */
Ejemplo n.º 8
0
/* Subroutine */ int dpbtrf_(char *uplo, integer *n, integer *kd, doublereal *
	ab, integer *ldab, integer *info)
{
    /* System generated locals */
    integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;

    /* Local variables */
    integer i__, j, i2, i3, ib, nb, ii, jj;
    doublereal work[1056]	/* was [33][32] */;

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

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

/*  DPBTRF computes the Cholesky factorization of a real symmetric */
/*  positive definite band matrix A. */

/*  The factorization has the form */
/*     A = U**T * U,  if UPLO = 'U', or */
/*     A = L  * L**T,  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. */

/*  KD      (input) INTEGER */
/*          The number of superdiagonals of the matrix A if UPLO = 'U', */
/*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0. */

/*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */
/*          On entry, the upper or lower triangle of the symmetric band */
/*          matrix A, stored in the first KD+1 rows of the array.  The */
/*          j-th column of A is stored in the j-th column of the array AB */
/*          as follows: */
/*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
/*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd). */

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

/*  LDAB    (input) INTEGER */
/*          The leading dimension of the array AB.  LDAB >= KD+1. */

/*  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 band storage scheme is illustrated by the following example, when */
/*  N = 6, KD = 2, and UPLO = 'U': */

/*  On entry:                       On exit: */

/*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46 */
/*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56 */
/*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66 */

/*  Similarly, if UPLO = 'L' the format of A is as follows: */

/*  On entry:                       On exit: */

/*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66 */
/*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   * */
/*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    * */

/*  Array elements marked * are not used by the routine. */

/*  Contributed by */
/*  Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989 */

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

/*     Test the input parameters. */

    /* Parameter adjustments */
    ab_dim1 = *ldab;
    ab_offset = 1 + ab_dim1;
    ab -= ab_offset;

    /* Function Body */
    *info = 0;
    if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    } else if (*kd < 0) {
	*info = -3;
    } else if (*ldab < *kd + 1) {
	*info = -5;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DPBTRF", &i__1);
	return 0;
    }

/*     Quick return if possible */

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

/*     Determine the block size for this environment */

    nb = ilaenv_(&c__1, "DPBTRF", uplo, n, kd, &c_n1, &c_n1);

/*     The block size must not exceed the semi-bandwidth KD, and must not */
/*     exceed the limit set by the size of the local array WORK. */

    nb = min(nb,32);

    if (nb <= 1 || nb > *kd) {

/*        Use unblocked code */

	dpbtf2_(uplo, n, kd, &ab[ab_offset], ldab, info);
    } else {

/*        Use blocked code */

	if (lsame_(uplo, "U")) {

/*           Compute the Cholesky factorization of a symmetric band */
/*           matrix, given the upper triangle of the matrix in band */
/*           storage. */

/*           Zero the upper triangle of the work array. */

	    i__1 = nb;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = j - 1;
		for (i__ = 1; i__ <= i__2; ++i__) {
		    work[i__ + j * 33 - 34] = 0.;
		}
	    }

/*           Process the band matrix one diagonal block at a time. */

	    i__1 = *n;
	    i__2 = nb;
	    for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
		i__3 = nb, i__4 = *n - i__ + 1;
		ib = min(i__3,i__4);

/*              Factorize the diagonal block */

		i__3 = *ldab - 1;
		dpotf2_(uplo, &ib, &ab[*kd + 1 + i__ * ab_dim1], &i__3, &ii);
		if (ii != 0) {
		    *info = i__ + ii - 1;
		    goto L150;
		}
		if (i__ + ib <= *n) {

/*                 Update the relevant part of the trailing submatrix. */
/*                 If A11 denotes the diagonal block which has just been */
/*                 factorized, then we need to update the remaining */
/*                 blocks in the diagram: */

/*                    A11   A12   A13 */
/*                          A22   A23 */
/*                                A33 */

/*                 The numbers of rows and columns in the partitioning */
/*                 are IB, I2, I3 respectively. The blocks A12, A22 and */
/*                 A23 are empty if IB = KD. The upper triangle of A13 */
/*                 lies outside the band. */

/* Computing MIN */
		    i__3 = *kd - ib, i__4 = *n - i__ - ib + 1;
		    i2 = min(i__3,i__4);
/* Computing MIN */
		    i__3 = ib, i__4 = *n - i__ - *kd + 1;
		    i3 = min(i__3,i__4);

		    if (i2 > 0) {

/*                    Update A12 */

			i__3 = *ldab - 1;
			i__4 = *ldab - 1;
			dtrsm_("Left", "Upper", "Transpose", "Non-unit", &ib, 
				&i2, &c_b18, &ab[*kd + 1 + i__ * ab_dim1], &
				i__3, &ab[*kd + 1 - ib + (i__ + ib) * ab_dim1]
, &i__4);

/*                    Update A22 */

			i__3 = *ldab - 1;
			i__4 = *ldab - 1;
			dsyrk_("Upper", "Transpose", &i2, &ib, &c_b21, &ab[*
				kd + 1 - ib + (i__ + ib) * ab_dim1], &i__3, &
				c_b18, &ab[*kd + 1 + (i__ + ib) * ab_dim1], &
				i__4);
		    }

		    if (i3 > 0) {

/*                    Copy the lower triangle of A13 into the work array. */

			i__3 = i3;
			for (jj = 1; jj <= i__3; ++jj) {
			    i__4 = ib;
			    for (ii = jj; ii <= i__4; ++ii) {
				work[ii + jj * 33 - 34] = ab[ii - jj + 1 + (
					jj + i__ + *kd - 1) * ab_dim1];
			    }
			}

/*                    Update A13 (in the work array). */

			i__3 = *ldab - 1;
			dtrsm_("Left", "Upper", "Transpose", "Non-unit", &ib, 
				&i3, &c_b18, &ab[*kd + 1 + i__ * ab_dim1], &
				i__3, work, &c__33);

/*                    Update A23 */

			if (i2 > 0) {
			    i__3 = *ldab - 1;
			    i__4 = *ldab - 1;
			    dgemm_("Transpose", "No Transpose", &i2, &i3, &ib, 
				     &c_b21, &ab[*kd + 1 - ib + (i__ + ib) * 
				    ab_dim1], &i__3, work, &c__33, &c_b18, &
				    ab[ib + 1 + (i__ + *kd) * ab_dim1], &i__4);
			}

/*                    Update A33 */

			i__3 = *ldab - 1;
			dsyrk_("Upper", "Transpose", &i3, &ib, &c_b21, work, &
				c__33, &c_b18, &ab[*kd + 1 + (i__ + *kd) * 
				ab_dim1], &i__3);

/*                    Copy the lower triangle of A13 back into place. */

			i__3 = i3;
			for (jj = 1; jj <= i__3; ++jj) {
			    i__4 = ib;
			    for (ii = jj; ii <= i__4; ++ii) {
				ab[ii - jj + 1 + (jj + i__ + *kd - 1) * 
					ab_dim1] = work[ii + jj * 33 - 34];
			    }
			}
		    }
		}
	    }
	} else {

/*           Compute the Cholesky factorization of a symmetric band */
/*           matrix, given the lower triangle of the matrix in band */
/*           storage. */

/*           Zero the lower triangle of the work array. */

	    i__2 = nb;
	    for (j = 1; j <= i__2; ++j) {
		i__1 = nb;
		for (i__ = j + 1; i__ <= i__1; ++i__) {
		    work[i__ + j * 33 - 34] = 0.;
		}
	    }

/*           Process the band matrix one diagonal block at a time. */

	    i__2 = *n;
	    i__1 = nb;
	    for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
/* Computing MIN */
		i__3 = nb, i__4 = *n - i__ + 1;
		ib = min(i__3,i__4);

/*              Factorize the diagonal block */

		i__3 = *ldab - 1;
		dpotf2_(uplo, &ib, &ab[i__ * ab_dim1 + 1], &i__3, &ii);
		if (ii != 0) {
		    *info = i__ + ii - 1;
		    goto L150;
		}
		if (i__ + ib <= *n) {

/*                 Update the relevant part of the trailing submatrix. */
/*                 If A11 denotes the diagonal block which has just been */
/*                 factorized, then we need to update the remaining */
/*                 blocks in the diagram: */

/*                    A11 */
/*                    A21   A22 */
/*                    A31   A32   A33 */

/*                 The numbers of rows and columns in the partitioning */
/*                 are IB, I2, I3 respectively. The blocks A21, A22 and */
/*                 A32 are empty if IB = KD. The lower triangle of A31 */
/*                 lies outside the band. */

/* Computing MIN */
		    i__3 = *kd - ib, i__4 = *n - i__ - ib + 1;
		    i2 = min(i__3,i__4);
/* Computing MIN */
		    i__3 = ib, i__4 = *n - i__ - *kd + 1;
		    i3 = min(i__3,i__4);

		    if (i2 > 0) {

/*                    Update A21 */

			i__3 = *ldab - 1;
			i__4 = *ldab - 1;
			dtrsm_("Right", "Lower", "Transpose", "Non-unit", &i2, 
				 &ib, &c_b18, &ab[i__ * ab_dim1 + 1], &i__3, &
				ab[ib + 1 + i__ * ab_dim1], &i__4);

/*                    Update A22 */

			i__3 = *ldab - 1;
			i__4 = *ldab - 1;
			dsyrk_("Lower", "No Transpose", &i2, &ib, &c_b21, &ab[
				ib + 1 + i__ * ab_dim1], &i__3, &c_b18, &ab[(
				i__ + ib) * ab_dim1 + 1], &i__4);
		    }

		    if (i3 > 0) {

/*                    Copy the upper triangle of A31 into the work array. */

			i__3 = ib;
			for (jj = 1; jj <= i__3; ++jj) {
			    i__4 = min(jj,i3);
			    for (ii = 1; ii <= i__4; ++ii) {
				work[ii + jj * 33 - 34] = ab[*kd + 1 - jj + 
					ii + (jj + i__ - 1) * ab_dim1];
			    }
			}

/*                    Update A31 (in the work array). */

			i__3 = *ldab - 1;
			dtrsm_("Right", "Lower", "Transpose", "Non-unit", &i3, 
				 &ib, &c_b18, &ab[i__ * ab_dim1 + 1], &i__3, 
				work, &c__33);

/*                    Update A32 */

			if (i2 > 0) {
			    i__3 = *ldab - 1;
			    i__4 = *ldab - 1;
			    dgemm_("No transpose", "Transpose", &i3, &i2, &ib, 
				     &c_b21, work, &c__33, &ab[ib + 1 + i__ * 
				    ab_dim1], &i__3, &c_b18, &ab[*kd + 1 - ib 
				    + (i__ + ib) * ab_dim1], &i__4);
			}

/*                    Update A33 */

			i__3 = *ldab - 1;
			dsyrk_("Lower", "No Transpose", &i3, &ib, &c_b21, 
				work, &c__33, &c_b18, &ab[(i__ + *kd) * 
				ab_dim1 + 1], &i__3);

/*                    Copy the upper triangle of A31 back into place. */

			i__3 = ib;
			for (jj = 1; jj <= i__3; ++jj) {
			    i__4 = min(jj,i3);
			    for (ii = 1; ii <= i__4; ++ii) {
				ab[*kd + 1 - jj + ii + (jj + i__ - 1) * 
					ab_dim1] = work[ii + jj * 33 - 34];
			    }
			}
		    }
		}
	    }
	}
    }
    return 0;

L150:
    return 0;

/*     End of DPBTRF */

} /* dpbtrf_ */
Ejemplo n.º 9
0
/* Subroutine */ void qpbtrf_(char *uplo, int *n, int *kd, LONG DOUBLE *
#endif

	ab, int *ldab, int *info)
{
/*  -- LAPACK routine (version 2.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       March 31, 1993   


    Purpose   
    =======   

    DPBTRF computes the Cholesky factorization of a real symmetric   
    positive definite band matrix A.   

    The factorization has the form   
       A = U**T * U,  if UPLO = 'U', or   
       A = L  * L**T,  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.   

    KD      (input) INTEGER   
            The number of superdiagonals of the matrix A if UPLO = 'U',   
            or the number of subdiagonals if UPLO = 'L'.  KD >= 0.   

    AB      (input/output) LONG DOUBLE PRECISION array, dimension (LDAB,N)   
            On entry, the upper or lower triangle of the symmetric band   
            matrix A, stored in the first KD+1 rows of the array.  The   
            j-th column of A is stored in the j-th column of the array AB 
  
            as follows:   
            if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for MAX(1,j-kd)<=i<=j; 
  
            if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=MIN(n,j+kd). 
  

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

    LDAB    (input) INTEGER   
            The leading dimension of the array AB.  LDAB >= KD+1.   

    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 band storage scheme is illustrated by the following example, when 
  
    N = 6, KD = 2, and UPLO = 'U':   

    On entry:                       On exit:   

        *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46   
        *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56   
       a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66   

    Similarly, if UPLO = 'L' the format of A is as follows:   

    On entry:                       On exit:   

       a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66   
       a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *   
       a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *   

    Array elements marked * are not used by the routine.   

    Contributed by   
    Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989   

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


       Test the input parameters.   

    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static int c__1 = 1;
    static int c_n1 = -1;
    static LONG DOUBLE c_b18 = 1.;
    static LONG DOUBLE c_b21 = -1.;
    static int c__33 = 33;
    
    /* System generated locals */
    int  i__1, i__2, i__3, i__4;
    /* Local variables */
    static LONG DOUBLE work[1056]	/* was [33][32] */;
    static int i, j;

#ifdef PETSC_PREFIX_SUFFIX
    extern /* Subroutine */ void dgemm_(char *, char *, int *, int *, 
#endif
#ifdef Q_C_PREFIX_SUFFIX
    extern /* Subroutine */ void qgemm(char *, char *, int *, int *, 
#endif
#ifdef Q_NORMAL_PREFIX_SUFFIX
    extern /* Subroutine */ void qgemm_(char *, char *, int *, int *, 
#endif

	    int *, LONG DOUBLE *, LONG DOUBLE *, int *, LONG DOUBLE *, 
	    int *, LONG DOUBLE *, LONG DOUBLE *, int *);
    extern long int lsame_(char *, char *);

#ifdef PETSC_PREFIX_SUFFIX
    extern /* Subroutine */ void dtrsm_(char *, char *, char *, char *, 
#endif
#ifdef Q_C_PREFIX_SUFFIX
    extern /* Subroutine */ void qtrsm(char *, char *, char *, char *, 
#endif
#ifdef Q_NORMAL_PREFIX_SUFFIX
    extern /* Subroutine */ void qtrsm_(char *, char *, char *, char *, 
#endif

	    int *, int *, LONG DOUBLE *, LONG DOUBLE *, int *, 
	    LONG DOUBLE *, int *);
    static int i2, i3;

#ifdef PETSC_PREFIX_SUFFIX
    extern /* Subroutine */ void dsyrk_(char *, char *, int *, int *, 
#endif
#ifdef Q_C_PREFIX_SUFFIX
    extern /* Subroutine */ void qsyrk(char *, char *, int *, int *, 
#endif
#ifdef Q_NORMAL_PREFIX_SUFFIX
    extern /* Subroutine */ void qsyrk_(char *, char *, int *, int *, 
#endif

	    LONG DOUBLE *, LONG DOUBLE *, int *, LONG DOUBLE *, LONG DOUBLE *,

#ifdef PETSC_PREFIX_SUFFIX
	     int *), dpbtf2_(char *, int *, int *,
#endif
#ifdef Q_C_PREFIX_SUFFIX
	     int *), qpbtf2(char *, int *, int *,
#endif
#ifdef Q_NORMAL_PREFIX_SUFFIX
	     int *), qpbtf2_(char *, int *, int *,
#endif


#ifdef PETSC_PREFIX_SUFFIX
	     LONG DOUBLE *, int *, int *), dpotf2_(char *, 
#endif
#ifdef Q_C_PREFIX_SUFFIX
	     LONG DOUBLE *, int *, int *), qpotf2(char *, 
#endif
#ifdef Q_NORMAL_PREFIX_SUFFIX
	     LONG DOUBLE *, int *, int *), qpotf2_(char *, 
#endif

	    int *, LONG DOUBLE *, int *, int *);
    static int ib, nb, ii, jj;
    extern /* Subroutine */ void xerbla_(char *, int *);
    extern int ilaenv_(int *, char *, char *, int *, int *, 
	    int *, int *, long int, long int);



#define WORK(I) work[(I)]
#define WAS(I) was[(I)]

#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]

    *info = 0;
    if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    } else if (*kd < 0) {
	*info = -3;
    } else if (*ldab < *kd + 1) {
	*info = -5;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DPBTRF", &i__1);
	return;
    }

/*     Quick return if possible */

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

/*     Determine the block size for this environment */

    nb = ilaenv_(&c__1, "DPBTRF", uplo, n, kd, &c_n1, &c_n1, 6L, 1L);

/*     The block size must not exceed the semi-bandwidth KD, and must not 
  
       exceed the limit set by the size of the local array WORK. */

    nb = MIN(nb,32);

    if (nb <= 1 || nb > *kd) {

/*        Use unblocked code */


#ifdef PETSC_PREFIX_SUFFIX
	dpbtf2_(uplo, n, kd, &AB(1,1), ldab, info);
#endif
#ifdef Q_C_PREFIX_SUFFIX
	qpbtf2(uplo, n, kd, &AB(1,1), ldab, info);
#endif
#ifdef Q_NORMAL_PREFIX_SUFFIX
	qpbtf2_(uplo, n, kd, &AB(1,1), ldab, info);
#endif

    } else {

/*        Use blocked code */

	if (lsame_(uplo, "U")) {

/*           Compute the Cholesky factorization of a symmetric ban
d   
             matrix, given the upper triangle of the matrix in ban
d   
             storage.   

             Zero the upper triangle of the work array. */

	    i__1 = nb;
	    for (j = 1; j <= nb; ++j) {
		i__2 = j - 1;
		for (i = 1; i <= j-1; ++i) {
		    WORK(i + j * 33 - 34) = 0.;
/* L10: */
		}
/* L20: */
	    }

/*           Process the band matrix one diagonal block at a time.
 */

	    i__1 = *n;
	    i__2 = nb;
	    for (i = 1; nb < 0 ? i >= *n : i <= *n; i += nb) {
/* Computing MIN */
		i__3 = nb, i__4 = *n - i + 1;
		ib = MIN(i__3,i__4);

/*              Factorize the diagonal block */

		i__3 = *ldab - 1;

#ifdef PETSC_PREFIX_SUFFIX
		dpotf2_(uplo, &ib, &AB(*kd+1,i), &i__3, &ii)
#endif
#ifdef Q_C_PREFIX_SUFFIX
		qpotf2(uplo, &ib, &AB(*kd+1,i), &i__3, &ii)
#endif
#ifdef Q_NORMAL_PREFIX_SUFFIX
		qpotf2_(uplo, &ib, &AB(*kd+1,i), &i__3, &ii)
#endif

			;
		if (ii != 0) {
		    *info = i + ii - 1;
		    goto L150;
		}
		if (i + ib <= *n) {

/*                 Update the relevant part of the trailin
g submatrix.   
                   If A11 denotes the diagonal block which
 has just been   
                   factorized, then we need to update the 
remaining   
                   blocks in the diagram:   

                      A11   A12   A13   
                            A22   A23   
                                  A33   

                   The numbers of rows and columns in the 
partitioning   
                   are IB, I2, I3 respectively. The blocks
 A12, A22 and   
                   A23 are empty if IB = KD. The upper tri
angle of A13   
                   lies outside the band.   

   Computing MIN */
		    i__3 = *kd - ib, i__4 = *n - i - ib + 1;
		    i2 = MIN(i__3,i__4);
/* Computing MIN */
		    i__3 = ib, i__4 = *n - i - *kd + 1;
		    i3 = MIN(i__3,i__4);

		    if (i2 > 0) {

/*                    Update A12 */

			i__3 = *ldab - 1;
			i__4 = *ldab - 1;

#ifdef PETSC_PREFIX_SUFFIX
			dtrsm_("Left", "Upper", "Transpose", "Non-unit", &ib, 
#endif
#ifdef Q_C_PREFIX_SUFFIX
			qtrsm("Left", "Upper", "Transpose", "Non-unit", &ib, 
#endif
#ifdef Q_NORMAL_PREFIX_SUFFIX
			qtrsm_("Left", "Upper", "Transpose", "Non-unit", &ib, 
#endif

				&i2, &c_b18, &AB(*kd+1,i), &
				i__3, &AB(*kd+1-ib,i+ib), 
				&i__4);

/*                    Update A22 */

			i__3 = *ldab - 1;
			i__4 = *ldab - 1;

#ifdef PETSC_PREFIX_SUFFIX
			dsyrk_("Upper", "Transpose", &i2, &ib, &c_b21, &AB(*kd+1-ib,i+ib), &i__3, &
#endif
#ifdef Q_C_PREFIX_SUFFIX
			qsyrk("Upper", "Transpose", &i2, &ib, &c_b21, &AB(*kd+1-ib,i+ib), &i__3, &
#endif
#ifdef Q_NORMAL_PREFIX_SUFFIX
			qsyrk_("Upper", "Transpose", &i2, &ib, &c_b21, &AB(*kd+1-ib,i+ib), &i__3, &
#endif

				c_b18, &AB(*kd+1,i+ib), &
				i__4);
		    }

		    if (i3 > 0) {

/*                    Copy the lower triangle of A13 i
nto the work array. */

			i__3 = i3;
			for (jj = 1; jj <= i3; ++jj) {
			    i__4 = ib;
			    for (ii = jj; ii <= ib; ++ii) {
				WORK(ii + jj * 33 - 34) = AB(ii-jj+1,jj+i+*kd-1);
/* L30: */
			    }
/* L40: */
			}

/*                    Update A13 (in the work array). 
*/

			i__3 = *ldab - 1;

#ifdef PETSC_PREFIX_SUFFIX
			dtrsm_("Left", "Upper", "Transpose", "Non-unit", &ib, 
#endif
#ifdef Q_C_PREFIX_SUFFIX
			qtrsm("Left", "Upper", "Transpose", "Non-unit", &ib, 
#endif
#ifdef Q_NORMAL_PREFIX_SUFFIX
			qtrsm_("Left", "Upper", "Transpose", "Non-unit", &ib, 
#endif

				&i3, &c_b18, &AB(*kd+1,i), &
				i__3, work, &c__33);

/*                    Update A23 */

			if (i2 > 0) {
			    i__3 = *ldab - 1;
			    i__4 = *ldab - 1;

#ifdef PETSC_PREFIX_SUFFIX
			    dgemm_("Transpose", "No Transpose", &i2, &i3, &ib,
#endif
#ifdef Q_C_PREFIX_SUFFIX
			    qgemm("Transpose", "No Transpose", &i2, &i3, &ib,
#endif
#ifdef Q_NORMAL_PREFIX_SUFFIX
			    qgemm_("Transpose", "No Transpose", &i2, &i3, &ib,
#endif

				     &c_b21, &AB(*kd+1-ib,i+ib), &i__3, work, &c__33, &c_b18, &
				    AB(ib+1,i+*kd), &i__4);
			}

/*                    Update A33 */

			i__3 = *ldab - 1;

#ifdef PETSC_PREFIX_SUFFIX
			dsyrk_("Upper", "Transpose", &i3, &ib, &c_b21, work, &
#endif
#ifdef Q_C_PREFIX_SUFFIX
			qsyrk("Upper", "Transpose", &i3, &ib, &c_b21, work, &
#endif
#ifdef Q_NORMAL_PREFIX_SUFFIX
			qsyrk_("Upper", "Transpose", &i3, &ib, &c_b21, work, &
#endif

				c__33, &c_b18, &AB(*kd+1,i+*kd), &i__3);

/*                    Copy the lower triangle of A13 b
ack into place. */

			i__3 = i3;
			for (jj = 1; jj <= i3; ++jj) {
			    i__4 = ib;
			    for (ii = jj; ii <= ib; ++ii) {
				AB(ii-jj+1,jj+i+*kd-1)
					 = WORK(ii + jj * 33 - 34);
/* L50: */
			    }
/* L60: */
			}
		    }