#include "f2c.h"

/* Subroutine */ int dposv_(char *uplo, integer *n, integer *nrhs, doublereal 
        *a, integer *lda, doublereal *b, integer *ldb, integer *info)
{
/*  -- LAPACK driver routine (version 2.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       March 31, 1993  


7/27/99  Modifications - C. A. Teolis 
	1.  to compile with MS Visual C++ version 5 changed declaration of s_copy
		from returning int to returning void:
		void s_copy(char *, char *, ftnlen, ftnlen);
	2.  to run from dSpace boards must not call IO library routines so commented
		out printf used for error handling:
               printf("** On entry to %6s, parameter number %2i had an illegal valuen",
                srname, *info);

  


    Purpose   
    =======   

    DPOSV computes the solution to a real system of linear equations   
       A * X = B,   
    where A is an N-by-N symmetric positive definite matrix and X and B   
    are N-by-NRHS matrices.   

    The Cholesky decomposition is used to factor A as   
       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 a lower triangular   
    matrix.  The factored form of A is then used to solve the system of   
    equations A * X = B.   

    Arguments   
    =========   

    UPLO    (input) CHARACTER*1   
            = 'U':  Upper triangle of A is stored;   
            = 'L':  Lower triangle of A is stored.   

    N       (input) INTEGER   
            The number of linear equations, i.e., the order of the   
            matrix A.  N >= 0.   

    NRHS    (input) INTEGER   
            The number of right hand sides, i.e., the number of columns   
            of the matrix B.  NRHS >= 0.   

    A       (input/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).   

    B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)   
            On entry, the N-by-NRHS right hand side matrix B.   
            On exit, if INFO = 0, the N-by-NRHS 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 leading minor of order i of A is not   
                  positive definite, so the factorization could not be   
                  completed, and the solution has not been computed.   

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


       Test the input parameters.   

    
   Parameter adjustments   
       Function Body */
    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_offset, i__1;
    /* Local variables */
    extern logical lsame_(char *, char *);
    extern /* Subroutine */ int xerbla_(char *, integer *), dpotrf_(
            char *, integer *, doublereal *, integer *, integer *), 
            dpotrs_(char *, integer *, integer *, doublereal *, integer *, 
            doublereal *, integer *, integer *);



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

    *info = 0;
    if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
        *info = -1;
    } else if (*n < 0) {
        *info = -2;
    } else if (*nrhs < 0) {
        *info = -3;
    } else if (*lda < max(1,*n)) {
        *info = -5;
    } else if (*ldb < max(1,*n)) {
        *info = -7;
    }
    if (*info != 0) {
        i__1 = -(*info);
        xerbla_("DPOSV ", &i__1);
        return 0;
    }

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

    dpotrf_(uplo, n, &A(1,1), lda, info);
    if (*info == 0) {

/*        Solve the system A*X = B, overwriting B with X. */

        dpotrs_(uplo, n, nrhs, &A(1,1), lda, &B(1,1), ldb, info)
                ;

    }
    return 0;

/*     End of DPOSV */

} /* dposv_ */

#include "f2c.h"

/* Subroutine */ int dpotf2_(char *uplo, integer *n, doublereal *a, integer *
        lda, integer *info)
{
/*  -- LAPACK routine (version 2.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       February 29, 1992   


    Purpose   
    =======   

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

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

    This is the unblocked version of the algorithm, calling Level 2 BLAS. 
  

    Arguments   
    =========   

    UPLO    (input) CHARACTER*1   
            Specifies whether the upper or lower triangular part of the   
            symmetric matrix A is stored.   
            = 'U':  Upper triangular   
            = 'L':  Lower triangular   

    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'*U  or A = L*L'.   

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

    INFO    (output) INTEGER   
            = 0: successful exit   
            < 0: if INFO = -k, the k-th argument had an illegal value   
            > 0: if INFO = k, the leading minor of order k is not   
                 positive definite, and the factorization could not be   
                 completed.   

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


       Test the input parameters.   

    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static integer c__1 = 1;
    static doublereal c_b10 = -1.;
    static doublereal c_b12 = 1.;
    
    /* System generated locals */
    integer a_dim1, a_offset, i__1, i__2, i__3;
    doublereal d__1;
    /* Builtin functions */
    double sqrt(doublereal);
    /* Local variables */
    extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, 
            integer *);
    static integer j;
    extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 
            integer *);
    extern logical lsame_(char *, char *);
    extern /* Subroutine */ int dgemv_(char *, integer *, integer *, 
            doublereal *, doublereal *, integer *, doublereal *, integer *, 
            doublereal *, doublereal *, integer *);
    static logical upper;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    static doublereal ajj;




#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]

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

/*     Quick return if possible */

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

    if (upper) {

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

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

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

            i__2 = j - 1;
            ajj = A(j,j) - ddot_(&i__2, &A(1,j), &c__1, 
                    &A(1,j), &c__1);
            if (ajj <= 0.) {
                A(j,j) = ajj;
                goto L30;
            }
            ajj = sqrt(ajj);
            A(j,j) = ajj;

/*           Compute elements J+1:N of row J. */

            if (j < *n) {
                i__2 = j - 1;
                i__3 = *n - j;
                dgemv_("Transpose", &i__2, &i__3, &c_b10, &A(1,j+1), lda, 
&A(1,j), &c__1, &c_b12, &A(j,j+1), lda);
                i__2 = *n - j;
                d__1 = 1. / ajj;
                dscal_(&i__2, &d__1, &A(j,j+1), lda);
            }
/* L10: */
        }
    } else {

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

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

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

            i__2 = j - 1;
            ajj = A(j,j) - ddot_(&i__2, &A(j,1), lda, &A(j,1), lda);
            if (ajj <= 0.) {
                A(j,j) = ajj;
                goto L30;
            }
            ajj = sqrt(ajj);
            A(j,j) = ajj;

/*           Compute elements J+1:N of column J. */

            if (j < *n) {
                i__2 = *n - j;
                i__3 = j - 1;
                dgemv_("No transpose", &i__2, &i__3, &c_b10, &A(j+1,1), lda, 
&A(j,1), lda, &c_b12, &A(j+1,j), &c__1);
                i__2 = *n - j;
                d__1 = 1. / ajj;
                dscal_(&i__2, &d__1, &A(j+1,j), &c__1);
            }
/* L20: */
        }
    }
    goto L40;

L30:
    *info = j;

L40:
    return 0;

/*     End of DPOTF2 */

} /* dpotf2_ */


#include "f2c.h"

/* Subroutine */ int dpotrf_(char *uplo, integer *n, doublereal *a, integer *
        lda, integer *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   
    =======   

    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   
       Function Body */
    /* 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 */ 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 logical upper;
    extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *, 
            doublereal *, doublereal *, integer *, doublereal *, doublereal *,
             integer *), dpotf2_(char *, integer *, 
            doublereal *, integer *, integer *);
    static integer jb, nb;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
            integer *, integer *, ftnlen, ftnlen);




#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]

    *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, 6L, 1L);
    if (nb <= 1 || nb >= *n) {

/*        Use unblocked code. */

        dpotf2_(uplo, n, &A(1,1), lda, info);
    } else {

/*        Use blocked code. */

        if (upper) {

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

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

/*              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(1,j), lda, 
&c_b14, &A(j,j), lda);
                dpotf2_("Upper", &jb, &A(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(1,j), lda, &A(1,j+jb), lda, &c_b14, 
&A(j,j+jb), lda);
                    i__3 = *n - j - jb + 1;
                    dtrsm_("Left", "Upper", "Transpose", "Non-unit", &jb, &
                            i__3, &c_b14, &A(j,j), lda, &A(j,j+jb), lda);
                }
/* L10: */
            }

        } else {

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

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

/*              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,1), 
lda, &c_b14, &A(j,j), lda);
                dpotf2_("Lower", &jb, &A(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(j+jb,1), lda, &A(j,1), 
                            lda, &c_b14, &A(j+jb,j), lda);
                    i__3 = *n - j - jb + 1;
                    dtrsm_("Right", "Lower", "Transpose", "Non-unit", &i__3, &
                            jb, &c_b14, &A(j,j), lda, &A(j+jb,j), lda);
                }
/* L20: */
            }
        }
    }
    goto L40;

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

L40:
    return 0;

/*     End of DPOTRF */

} /* dpotrf_ */


#include "f2c.h"

/* Subroutine */ int dpotrs_(char *uplo, integer *n, integer *nrhs, 
        doublereal *a, integer *lda, doublereal *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   
       March 31, 1993   


    Purpose   
    =======   

    DPOTRS solves a system of linear equations A*X = B with a symmetric   
    positive definite matrix A using the Cholesky factorization   
    A = U**T*U or A = L*L**T computed by DPOTRF.   

    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.   

    A       (input) DOUBLE PRECISION array, dimension (LDA,N)   
            The triangular factor U or L from the Cholesky factorization 
  
            A = U**T*U or A = L*L**T, as computed by DPOTRF.   

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

    B       (input/output) DOUBLE PRECISION 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 doublereal c_b9 = 1.;
    
    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_offset, i__1;
    /* Local variables */
    extern logical lsame_(char *, char *);
    extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, 
            integer *, integer *, doublereal *, doublereal *, integer *, 
            doublereal *, integer *);
    static logical upper;
    extern /* Subroutine */ int xerbla_(char *, integer *);




#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#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 (*lda < max(1,*n)) {
        *info = -5;
    } else if (*ldb < max(1,*n)) {
        *info = -7;
    }
    if (*info != 0) {
        i__1 = -(*info);
        xerbla_("DPOTRS", &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.   

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

        dtrsm_("Left", "Upper", "Transpose", "Non-unit", n, nrhs, &c_b9, 
&A(1,1), lda, &B(1,1), ldb);

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

        dtrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b9, &
                A(1,1), lda, &B(1,1), ldb);
    } else {

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

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

        dtrsm_("Left", "Lower", "No transpose", "Non-unit", n, nrhs, &c_b9, &
                A(1,1), lda, &B(1,1), ldb);

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

        dtrsm_("Left", "Lower", "Transpose", "Non-unit", n, nrhs, &c_b9, 
&A(1,1), lda, &B(1,1), ldb);
    }

    return 0;

/*     End of DPOTRS */

} /* dpotrs_ */


/* f2c.h  --  Standard Fortran to C header file */

/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."

        - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */

#ifndef F2C_INCLUDE
#define F2C_INCLUDE

typedef long int integer;
typedef char *address;
typedef short int shortint;
typedef float real;
typedef double doublereal;
typedef struct { real r, i; } complex;
typedef struct { doublereal r, i; } doublecomplex;
typedef long int logical;
typedef short int shortlogical;
typedef char logical1;
typedef char integer1;
/* typedef long long longint; */ /* system-dependent */

#define TRUE_ (1)
#define FALSE_ (0)

/* Extern is for use with -E */
#ifndef Extern
#define Extern extern
#endif

/* I/O stuff */

#ifdef f2c_i2
/* for -i2 */
typedef short flag;
typedef short ftnlen;
typedef short ftnint;
#else
typedef long flag;
typedef long ftnlen;
typedef long ftnint;
#endif

/*external read, write*/
typedef struct
{      flag cierr;
        ftnint ciunit;
        flag ciend;
        char *cifmt;
        ftnint cirec;
} cilist;

/*internal read, write*/
typedef struct
{      flag icierr;
        char *iciunit;
        flag iciend;
        char *icifmt;
        ftnint icirlen;
        ftnint icirnum;
} icilist;

/*open*/
typedef struct
{      flag oerr;
        ftnint ounit;
        char *ofnm;
        ftnlen ofnmlen;
        char *osta;
        char *oacc;
        char *ofm;
        ftnint orl;
        char *oblnk;
} olist;

/*close*/
typedef struct
{      flag cerr;
        ftnint cunit;
        char *csta;
} cllist;

/*rewind, backspace, endfile*/
typedef struct
{      flag aerr;
        ftnint aunit;
} alist;

/* inquire */
typedef struct
{      flag inerr;
        ftnint inunit;
        char *infile;
        ftnlen infilen;
        ftnint  *inex;  /*parameters in standard's order*/
        ftnint  *inopen;
        ftnint  *innum;
        ftnint  *innamed;
        char    *inname;
        ftnlen  innamlen;
        char    *inacc;
        ftnlen  inacclen;
        char    *inseq;
        ftnlen  inseqlen;
        char    *indir;
        ftnlen  indirlen;
        char    *infmt;
        ftnlen  infmtlen;
        char    *inform;
        ftnint  informlen;
        char    *inunf;
        ftnlen  inunflen;
        ftnint  *inrecl;
        ftnint  *innrec;
        char    *inblank;
        ftnlen  inblanklen;
} inlist;

#define VOID void

union Multitype {      /* for multiple entry points */
        integer1 g;
        shortint h;
        integer i;
        /* longint j; */
        real r;
        doublereal d;
        complex c;
        doublecomplex z;
        };

typedef union Multitype Multitype;

typedef long Long;      /* No longer used; formerly in Namelist */

struct Vardesc {       /* for Namelist */
        char *name;
        char *addr;
        ftnlen *dims;
        int  type;
        };
typedef struct Vardesc Vardesc;

struct Namelist {
        char *name;
        Vardesc **vars;
        int nvars;
        };
typedef struct Namelist Namelist;

#define abs(x) ((x) >= 0 ? (x) : -(x))
#define dabs(x) (doublereal)abs(x)
#define min(a,b) ((a) <= (b) ? (a) : (b))
#define max(a,b) ((a) >= (b) ? (a) : (b))
#define dmin(a,b) (doublereal)min(a,b)
#define dmax(a,b) (doublereal)max(a,b)

/* procedure parameter types for -A and -C++ */

#define F2C_proc_par_types 1
#ifdef __cplusplus
typedef int /* Unknown procedure type */ (*U_fp)(...);
typedef shortint (*J_fp)(...);
typedef integer (*I_fp)(...);
typedef real (*R_fp)(...);
typedef doublereal (*D_fp)(...), (*E_fp)(...);
typedef /* Complex */ VOID (*C_fp)(...);
typedef /* Double Complex */ VOID (*Z_fp)(...);
typedef logical (*L_fp)(...);
typedef shortlogical (*K_fp)(...);
typedef /* Character */ VOID (*H_fp)(...);
typedef /* Subroutine */ int (*S_fp)(...);
#else
typedef int /* Unknown procedure type */ (*U_fp)();
typedef shortint (*J_fp)();
typedef integer (*I_fp)();
typedef real (*R_fp)();
typedef doublereal (*D_fp)(), (*E_fp)();
typedef /* Complex */ VOID (*C_fp)();
typedef /* Double Complex */ VOID (*Z_fp)();
typedef logical (*L_fp)();
typedef shortlogical (*K_fp)();
typedef /* Character */ VOID (*H_fp)();
typedef /* Subroutine */ int (*S_fp)();
#endif
/* E_fp is for real functions when -R is not specified */
typedef VOID C_f;       /* complex function */
typedef VOID H_f;       /* character function */
typedef VOID Z_f;       /* double complex function */
typedef doublereal E_f; /* real function with -R not specified */

/* undef any lower-case symbols that your C compiler predefines, e.g.: */

#ifndef Skip_f2c_Undefs
#undef cray
#undef gcos
#undef mc68010
#undef mc68020
#undef mips
#undef pdp11
#undef sgi
#undef sparc
#undef sun
#undef sun2
#undef sun3
#undef sun4
#undef u370
#undef u3b
#undef u3b2
#undef u3b5
#undef unix
#undef vax
#endif
#endif

#include "f2c.h"

integer ilaenv_(integer *ispec, char *name, char *opts, integer *n1, integer *
        n2, integer *n3, integer *n4, ftnlen name_len, ftnlen opts_len)
{
/*  -- LAPACK auxiliary 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   
    =======   

    ILAENV is called from the LAPACK routines to choose problem-dependent 
  
    parameters for the local environment.  See ISPEC for a description of 
  
    the parameters.   

    This version provides a set of parameters which should give good,   
    but not optimal, performance on many of the currently available   
    computers.  Users are encouraged to modify this subroutine to set   
    the tuning parameters for their particular machine using the option   
    and problem size information in the arguments.   

    This routine will not function correctly if it is converted to all   
    lower case.  Converting it to all upper case is allowed.   

    Arguments   
    =========   

    ISPEC   (input) INTEGER   
            Specifies the parameter to be returned as the value of   
            ILAENV.   
            = 1: the optimal blocksize; if this value is 1, an unblocked 
  
                 algorithm will give the best performance.   
            = 2: the minimum block size for which the block routine   
                 should be used; if the usable block size is less than   
                 this value, an unblocked routine should be used.   
            = 3: the crossover point (in a block routine, for N less   
                 than this value, an unblocked routine should be used)   
            = 4: the number of shifts, used in the nonsymmetric   
                 eigenvalue routines   
            = 5: the minimum column dimension for blocking to be used;   
                 rectangular blocks must have dimension at least k by m, 
  
                 where k is given by ILAENV(2,...) and m by ILAENV(5,...) 
  
            = 6: the crossover point for the SVD (when reducing an m by n 
  
                 matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds 
  
                 this value, a QR factorization is used first to reduce   
                 the matrix to a triangular form.)   
            = 7: the number of processors   
            = 8: the crossover point for the multishift QR and QZ methods 
  
                 for nonsymmetric eigenvalue problems.   

    NAME    (input) CHARACTER*(*)   
            The name of the calling subroutine, in either upper case or   
            lower case.   

    OPTS    (input) CHARACTER*(*)   
            The character options to the subroutine NAME, concatenated   
            into a single character string.  For example, UPLO = 'U',   
            TRANS = 'T', and DIAG = 'N' for a triangular routine would   
            be specified as OPTS = 'UTN'.   

    N1      (input) INTEGER   
    N2      (input) INTEGER   
    N3      (input) INTEGER   
    N4      (input) INTEGER   
            Problem dimensions for the subroutine NAME; these may not all 
  
            be required.   

   (ILAENV) (output) INTEGER   
            >= 0: the value of the parameter specified by ISPEC   
            < 0:  if ILAENV = -k, the k-th argument had an illegal value. 
  

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

    The following conventions have been used when calling ILAENV from the 
  
    LAPACK routines:   
    1)  OPTS is a concatenation of all of the character options to   
        subroutine NAME, in the same order that they appear in the   
        argument list for NAME, even if they are not used in determining 
  
        the value of the parameter specified by ISPEC.   
    2)  The problem dimensions N1, N2, N3, N4 are specified in the order 
  
        that they appear in the argument list for NAME.  N1 is used   
        first, N2 second, and so on, and unused problem dimensions are   
        passed a value of -1.   
    3)  The parameter value returned by ILAENV is checked for validity in 
  
        the calling subroutine.  For example, ILAENV is used to retrieve 
  
        the optimal blocksize for STRTRI as follows:   

        NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )   
        IF( NB.LE.1 ) NB = MAX( 1, N )   

    ===================================================================== 
*/
/* >>Start of File<<   
       System generated locals */
    integer ret_val;
    /* Builtin functions   
       Subroutine */  void s_copy(char *, char *, ftnlen, ftnlen);
    integer s_cmp(char *, char *, ftnlen, ftnlen);
    /* Local variables */
    static integer i;
    static logical cname, sname;
    static integer nbmin;
    static char c1[1], c2[2], c3[3], c4[2];
    static integer ic, nb, iz, nx;
    static char subnam[6];



    switch (*ispec) {
        case 1:  goto L100;
        case 2:  goto L100;
        case 3:  goto L100;
        case 4:  goto L400;
        case 5:  goto L500;
        case 6:  goto L600;
        case 7:  goto L700;
        case 8:  goto L800;
    }

/*     Invalid value for ISPEC */

    ret_val = -1;
    return ret_val;

L100:

/*     Convert NAME to upper case if the first character is lower case. */

    ret_val = 1;
    s_copy(subnam, name, 6L, name_len);
    ic = *(unsigned char *)subnam;
    iz = 'Z';
    if (iz == 90 || iz == 122) {

/*        ASCII character set */

        if (ic >= 97 && ic <= 122) {
            *(unsigned char *)subnam = (char) (ic - 32);
            for (i = 2; i <= 6; ++i) {
                ic = *(unsigned char *)&subnam[i - 1];
                if (ic >= 97 && ic <= 122) {
                    *(unsigned char *)&subnam[i - 1] = (char) (ic - 32);
                }
/* L10: */
            }
        }

    } else if (iz == 233 || iz == 169) {

/*        EBCDIC character set */

        if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 162 && 
                ic <= 169) {
            *(unsigned char *)subnam = (char) (ic + 64);
            for (i = 2; i <= 6; ++i) {
                ic = *(unsigned char *)&subnam[i - 1];
                if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 
                        162 && ic <= 169) {
                    *(unsigned char *)&subnam[i - 1] = (char) (ic + 64);
                }
/* L20: */
            }
        }

    } else if (iz == 218 || iz == 250) {

/*        Prime machines:  ASCII+128 */

        if (ic >= 225 && ic <= 250) {
            *(unsigned char *)subnam = (char) (ic - 32);
            for (i = 2; i <= 6; ++i) {
                ic = *(unsigned char *)&subnam[i - 1];
                if (ic >= 225 && ic <= 250) {
                    *(unsigned char *)&subnam[i - 1] = (char) (ic - 32);
                }
/* L30: */
            }
        }
    }

    *(unsigned char *)c1 = *(unsigned char *)subnam;
    sname = *(unsigned char *)c1 == 'S' || *(unsigned char *)c1 == 'D';
    cname = *(unsigned char *)c1 == 'C' || *(unsigned char *)c1 == 'Z';
    if (! (cname || sname)) {
        return ret_val;
    }
    s_copy(c2, subnam + 1, 2L, 2L);
    s_copy(c3, subnam + 3, 3L, 3L);
    s_copy(c4, c3 + 1, 2L, 2L);

    switch (*ispec) {
        case 1:  goto L110;
        case 2:  goto L200;
        case 3:  goto L300;
    }

L110:

/*     ISPEC = 1:  block size   

       In these examples, separate code is provided for setting NB for   
       real and complex.  We assume that NB will take the same value in   
       single or double precision. */

    nb = 1;

    if (s_cmp(c2, "GE", 2L, 2L) == 0) {
        if (s_cmp(c3, "TRF", 3L, 3L) == 0) {
            if (sname) {
                nb = 64;
            } else {
                nb = 64;
            }
        } else if (s_cmp(c3, "QRF", 3L, 3L) == 0 || s_cmp(c3, "RQF", 3L, 3L) 
                == 0 || s_cmp(c3, "LQF", 3L, 3L) == 0 || s_cmp(c3, "QLF", 3L, 
                3L) == 0) {
            if (sname) {
                nb = 32;
            } else {
                nb = 32;
            }
        } else if (s_cmp(c3, "HRD", 3L, 3L) == 0) {
            if (sname) {
                nb = 32;
            } else {
                nb = 32;
            }
        } else if (s_cmp(c3, "BRD", 3L, 3L) == 0) {
            if (sname) {
                nb = 32;
            } else {
                nb = 32;
            }
        } else if (s_cmp(c3, "TRI", 3L, 3L) == 0) {
            if (sname) {
                nb = 64;
            } else {
                nb = 64;
            }
        }
    } else if (s_cmp(c2, "PO", 2L, 2L) == 0) {
        if (s_cmp(c3, "TRF", 3L, 3L) == 0) {
            if (sname) {
                nb = 64;
            } else {
                nb = 64;
            }
        }
    } else if (s_cmp(c2, "SY", 2L, 2L) == 0) {
        if (s_cmp(c3, "TRF", 3L, 3L) == 0) {
            if (sname) {
                nb = 64;
            } else {
                nb = 64;
            }
        } else if (sname && s_cmp(c3, "TRD", 3L, 3L) == 0) {
            nb = 1;
        } else if (sname && s_cmp(c3, "GST", 3L, 3L) == 0) {
            nb = 64;
        }
    } else if (cname && s_cmp(c2, "HE", 2L, 2L) == 0) {
        if (s_cmp(c3, "TRF", 3L, 3L) == 0) {
            nb = 64;
        } else if (s_cmp(c3, "TRD", 3L, 3L) == 0) {
            nb = 1;
        } else if (s_cmp(c3, "GST", 3L, 3L) == 0) {
            nb = 64;
        }
    } else if (sname && s_cmp(c2, "OR", 2L, 2L) == 0) {
        if (*(unsigned char *)c3 == 'G') {
            if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 
                    || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
                     == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 
                    2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
                nb = 32;
            }
        } else if (*(unsigned char *)c3 == 'M') {
            if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 
                    || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
                     == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 
                    2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
                nb = 32;
            }
        }
    } else if (cname && s_cmp(c2, "UN", 2L, 2L) == 0) {
        if (*(unsigned char *)c3 == 'G') {
            if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 
                    || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
                     == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 
                    2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
                nb = 32;
            }
        } else if (*(unsigned char *)c3 == 'M') {
            if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 
                    || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
                     == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 
                    2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
                nb = 32;
            }
        }
    } else if (s_cmp(c2, "GB", 2L, 2L) == 0) {
        if (s_cmp(c3, "TRF", 3L, 3L) == 0) {
            if (sname) {
                if (*n4 <= 64) {
                    nb = 1;
                } else {
                    nb = 32;
                }
            } else {
                if (*n4 <= 64) {
                    nb = 1;
                } else {
                    nb = 32;
                }
            }
        }
    } else if (s_cmp(c2, "PB", 2L, 2L) == 0) {
        if (s_cmp(c3, "TRF", 3L, 3L) == 0) {
            if (sname) {
                if (*n2 <= 64) {
                    nb = 1;
                } else {
                    nb = 32;
                }
            } else {
                if (*n2 <= 64) {
                    nb = 1;
                } else {
                    nb = 32;
                }
            }
        }
    } else if (s_cmp(c2, "TR", 2L, 2L) == 0) {
        if (s_cmp(c3, "TRI", 3L, 3L) == 0) {
            if (sname) {
                nb = 64;
            } else {
                nb = 64;
            }
        }
    } else if (s_cmp(c2, "LA", 2L, 2L) == 0) {
        if (s_cmp(c3, "UUM", 3L, 3L) == 0) {
            if (sname) {
                nb = 64;
            } else {
                nb = 64;
            }
        }
    } else if (sname && s_cmp(c2, "ST", 2L, 2L) == 0) {
        if (s_cmp(c3, "EBZ", 3L, 3L) == 0) {
            nb = 1;
        }
    }
    ret_val = nb;
    return ret_val;

L200:

/*     ISPEC = 2:  minimum block size */

    nbmin = 2;
    if (s_cmp(c2, "GE", 2L, 2L) == 0) {
        if (s_cmp(c3, "QRF", 3L, 3L) == 0 || s_cmp(c3, "RQF", 3L, 3L) == 0 || 
                s_cmp(c3, "LQF", 3L, 3L) == 0 || s_cmp(c3, "QLF", 3L, 3L) == 
                0) {
            if (sname) {
                nbmin = 2;
            } else {
                nbmin = 2;
            }
        } else if (s_cmp(c3, "HRD", 3L, 3L) == 0) {
            if (sname) {
                nbmin = 2;
            } else {
                nbmin = 2;
            }
        } else if (s_cmp(c3, "BRD", 3L, 3L) == 0) {
            if (sname) {
                nbmin = 2;
            } else {
                nbmin = 2;
            }
        } else if (s_cmp(c3, "TRI", 3L, 3L) == 0) {
            if (sname) {
                nbmin = 2;
            } else {
                nbmin = 2;
            }
        }
    } else if (s_cmp(c2, "SY", 2L, 2L) == 0) {
        if (s_cmp(c3, "TRF", 3L, 3L) == 0) {
            if (sname) {
                nbmin = 8;
            } else {
                nbmin = 8;
            }
        } else if (sname && s_cmp(c3, "TRD", 3L, 3L) == 0) {
            nbmin = 2;
        }
    } else if (cname && s_cmp(c2, "HE", 2L, 2L) == 0) {
        if (s_cmp(c3, "TRD", 3L, 3L) == 0) {
            nbmin = 2;
        }
    } else if (sname && s_cmp(c2, "OR", 2L, 2L) == 0) {
        if (*(unsigned char *)c3 == 'G') {
            if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 
                    || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
                     == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 
                    2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
                nbmin = 2;
            }
        } else if (*(unsigned char *)c3 == 'M') {
            if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 
                    || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
                     == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 
                    2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
                nbmin = 2;
            }
        }
    } else if (cname && s_cmp(c2, "UN", 2L, 2L) == 0) {
        if (*(unsigned char *)c3 == 'G') {
            if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 
                    || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
                     == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 
                    2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
                nbmin = 2;
            }
        } else if (*(unsigned char *)c3 == 'M') {
            if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 
                    || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
                     == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 
                    2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
                nbmin = 2;
            }
        }
    }
    ret_val = nbmin;
    return ret_val;

L300:

/*     ISPEC = 3:  crossover point */

    nx = 0;
    if (s_cmp(c2, "GE", 2L, 2L) == 0) {
        if (s_cmp(c3, "QRF", 3L, 3L) == 0 || s_cmp(c3, "RQF", 3L, 3L) == 0 || 
                s_cmp(c3, "LQF", 3L, 3L) == 0 || s_cmp(c3, "QLF", 3L, 3L) == 
                0) {
            if (sname) {
                nx = 128;
            } else {
                nx = 128;
            }
        } else if (s_cmp(c3, "HRD", 3L, 3L) == 0) {
            if (sname) {
                nx = 128;
            } else {
                nx = 128;
            }
        } else if (s_cmp(c3, "BRD", 3L, 3L) == 0) {
            if (sname) {
                nx = 128;
            } else {
                nx = 128;
            }
        }
    } else if (s_cmp(c2, "SY", 2L, 2L) == 0) {
        if (sname && s_cmp(c3, "TRD", 3L, 3L) == 0) {
            nx = 1;
        }
    } else if (cname && s_cmp(c2, "HE", 2L, 2L) == 0) {
        if (s_cmp(c3, "TRD", 3L, 3L) == 0) {
            nx = 1;
        }
    } else if (sname && s_cmp(c2, "OR", 2L, 2L) == 0) {
        if (*(unsigned char *)c3 == 'G') {
            if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 
                    || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
                     == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 
                    2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
                nx = 128;
            }
        }
    } else if (cname && s_cmp(c2, "UN", 2L, 2L) == 0) {
        if (*(unsigned char *)c3 == 'G') {
            if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 
                    || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
                     == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 
                    2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
                nx = 128;
            }
        }
    }
    ret_val = nx;
    return ret_val;

L400:

/*     ISPEC = 4:  number of shifts (used by xHSEQR) */

    ret_val = 6;
    return ret_val;

L500:

/*     ISPEC = 5:  minimum column dimension (not used) */

    ret_val = 2;
    return ret_val;

L600:

/*     ISPEC = 6:  crossover point for SVD (used by xGELSS and xGESVD) */

    ret_val = (integer) ((real) min(*n1,*n2) * 1.6f);
    return ret_val;

L700:

/*     ISPEC = 7:  number of processors (not used) */

    ret_val = 1;
    return ret_val;

L800:

/*     ISPEC = 8:  crossover point for multishift (used by xHSEQR) */

    ret_val = 50;
    return ret_val;

/*     End of ILAENV */

} /* ilaenv_ */


#include "f2c.h"

logical lsame_(char *ca, char *cb)
{
/*  -- LAPACK auxiliary 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   
    =======   

    LSAME returns .TRUE. if CA is the same letter as CB regardless of   
    case.   

    Arguments   
    =========   

    CA      (input) CHARACTER*1   
    CB      (input) CHARACTER*1   
            CA and CB specify the single characters to be compared.   

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


       Test if the characters are equal */
    /* System generated locals */
    logical ret_val;
    /* Local variables */
    static integer inta, intb, zcode;


    ret_val = *(unsigned char *)ca == *(unsigned char *)cb;
    if (ret_val) {
        return ret_val;
    }

/*     Now test for equivalence if both characters are alphabetic. */

    zcode = 'Z';

/*     Use 'Z' rather than 'A' so that ASCII can be detected on Prime   
       machines, on which ICHAR returns a value with bit 8 set.   
       ICHAR('A') on Prime machines returns 193 which is the same as   
       ICHAR('A') on an EBCDIC machine. */

    inta = *(unsigned char *)ca;
    intb = *(unsigned char *)cb;

    if (zcode == 90 || zcode == 122) {

/*        ASCII is assumed - ZCODE is the ASCII code of either lower o
r   
          upper case 'Z'. */

        if (inta >= 97 && inta <= 122) {
            inta += -32;
        }
        if (intb >= 97 && intb <= 122) {
            intb += -32;
        }

    } else if (zcode == 233 || zcode == 169) {

/*        EBCDIC is assumed - ZCODE is the EBCDIC code of either lower
 or   
          upper case 'Z'. */

        if (inta >= 129 && inta <= 137 || inta >= 145 && inta <= 153 || inta 
                >= 162 && inta <= 169) {
            inta += 64;
        }
        if (intb >= 129 && intb <= 137 || intb >= 145 && intb <= 153 || intb 
                >= 162 && intb <= 169) {
            intb += 64;
        }

    } else if (zcode == 218 || zcode == 250) {

/*        ASCII is assumed, on Prime machines - ZCODE is the ASCII cod
e   
          plus 128 of either lower or upper case 'Z'. */

        if (inta >= 225 && inta <= 250) {
            inta += -32;
        }
        if (intb >= 225 && intb <= 250) {
            intb += -32;
        }
    }
    ret_val = inta == intb;

/*     RETURN   

       End of LSAME */

    return ret_val;
} /* lsame_ */


#include "f2c.h"

/* Subroutine */ int xerbla_(char *srname, integer *info)
{
/*  -- LAPACK auxiliary 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   
    =======   

    XERBLA  is an error handler for the LAPACK routines.   
    It is called by an LAPACK routine if an input parameter has an   
    invalid value.  A message is printed and execution stops.   

    Installers may consider modifying the STOP statement in order to   
    call system-specific exception-handling facilities.   

    Arguments   
    =========   

    SRNAME  (input) CHARACTER*6   
            The name of the routine which called XERBLA.   

    INFO    (input) INTEGER   
            The position of the invalid parameter in the parameter list   

            of the calling routine.   

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

 /*   printf("** On entry to %6s, parameter number %2i had an illegal valuen",
                srname, *info);
*/

/*     End of XERBLA */

    return 0;
} /* xerbla_ */

#include "f2c.h"

/* Subroutine */ int dtrsm_(char *side, char *uplo, char *transa, char *diag, 
        integer *m, integer *n, doublereal *alpha, doublereal *a, integer *
        lda, doublereal *b, integer *ldb)
{


    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;

    /* Local variables */
    static integer info;
    static doublereal temp;
    static integer i, j, k;
    static logical lside;
    extern logical lsame_(char *, char *);
    static integer nrowa;
    static logical upper;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    static logical nounit;


/*  Purpose   
    =======   

    DTRSM  solves one of the matrix equations   

       op( A )*X = alpha*B,   or   X*op( A ) = alpha*B,   

    where alpha is a scalar, X and B are m by n matrices, A is a unit, or 
  
    non-unit,  upper or lower triangular matrix  and  op( A )  is one  of 
  

       op( A ) = A   or   op( A ) = A'.   

    The matrix X is overwritten on B.   

    Parameters   
    ==========   

    SIDE   - CHARACTER*1.   
             On entry, SIDE specifies whether op( A ) appears on the left 
  
             or right of X as follows:   

                SIDE = 'L' or 'l'   op( A )*X = alpha*B.   

                SIDE = 'R' or 'r'   X*op( A ) = alpha*B.   

             Unchanged on exit.   

    UPLO   - CHARACTER*1.   
             On entry, UPLO specifies whether the matrix A is an upper or 
  
             lower triangular matrix as follows:   

                UPLO = 'U' or 'u'   A is an upper triangular matrix.   

                UPLO = 'L' or 'l'   A is a lower triangular matrix.   

             Unchanged on exit.   

    TRANSA - CHARACTER*1.   
             On entry, TRANSA specifies the form of op( A ) to be used in 
  
             the matrix multiplication as follows:   

                TRANSA = 'N' or 'n'   op( A ) = A.   

                TRANSA = 'T' or 't'   op( A ) = A'.   

                TRANSA = 'C' or 'c'   op( A ) = A'.   

             Unchanged on exit.   

    DIAG   - CHARACTER*1.   
             On entry, DIAG specifies whether or not A is unit triangular 
  
             as follows:   

                DIAG = 'U' or 'u'   A is assumed to be unit triangular.   

                DIAG = 'N' or 'n'   A is not assumed to be unit   
                                    triangular.   

             Unchanged on exit.   

    M      - INTEGER.   
             On entry, M specifies the number of rows of B. M must be at 
  
             least zero.   
             Unchanged on exit.   

    N      - INTEGER.   
             On entry, N specifies the number of columns of B.  N must be 
  
             at least zero.   
             Unchanged on exit.   

    ALPHA  - DOUBLE PRECISION.   
             On entry,  ALPHA specifies the scalar  alpha. When  alpha is 
  
             zero then  A is not referenced and  B need not be set before 
  
             entry.   
             Unchanged on exit.   

    A      - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m 
  
             when  SIDE = 'L' or 'l'  and is  n  when  SIDE = 'R' or 'r'. 
  
             Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k 
  
             upper triangular part of the array  A must contain the upper 
  
             triangular matrix  and the strictly lower triangular part of 
  
             A is not referenced.   
             Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k 
  
             lower triangular part of the array  A must contain the lower 
  
             triangular matrix  and the strictly upper triangular part of 
  
             A is not referenced.   
             Note that when  DIAG = 'U' or 'u',  the diagonal elements of 
  
             A  are not referenced either,  but are assumed to be  unity. 
  
             Unchanged on exit.   

    LDA    - INTEGER.   
             On entry, LDA specifies the first dimension of A as declared 
  
             in the calling (sub) program.  When  SIDE = 'L' or 'l'  then 
  
             LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r' 
  
             then LDA must be at least max( 1, n ).   
             Unchanged on exit.   

    B      - DOUBLE PRECISION array of DIMENSION ( LDB, n ).   
             Before entry,  the leading  m by n part of the array  B must 
  
             contain  the  right-hand  side  matrix  B,  and  on exit  is 
  
             overwritten by the solution matrix  X.   

    LDB    - INTEGER.   
             On entry, LDB specifies the first dimension of B as declared 
  
             in  the  calling  (sub)  program.   LDB  must  be  at  least 
  
             max( 1, m ).   
             Unchanged on exit.   


    Level 3 Blas routine.   


    -- Written on 8-February-1989.   
       Jack Dongarra, Argonne National Laboratory.   
       Iain Duff, AERE Harwell.   
       Jeremy Du Croz, Numerical Algorithms Group Ltd.   
       Sven Hammarling, Numerical Algorithms Group Ltd.   



       Test the input parameters.   

    
   Parameter adjustments   
       Function Body */

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

    lside = lsame_(side, "L");
    if (lside) {
        nrowa = *m;
    } else {
        nrowa = *n;
    }
    nounit = lsame_(diag, "N");
    upper = lsame_(uplo, "U");

    info = 0;
    if (! lside && ! lsame_(side, "R")) {
        info = 1;
    } else if (! upper && ! lsame_(uplo, "L")) {
        info = 2;
    } else if (! lsame_(transa, "N") && ! lsame_(transa, "T") 
            && ! lsame_(transa, "C")) {
        info = 3;
    } else if (! lsame_(diag, "U") && ! lsame_(diag, "N")) {
        info = 4;
    } else if (*m < 0) {
        info = 5;
    } else if (*n < 0) {
        info = 6;
    } else if (*lda < max(1,nrowa)) {
        info = 9;
    } else if (*ldb < max(1,*m)) {
        info = 11;
    }
    if (info != 0) {
        xerbla_("DTRSM ", &info);
        return 0;
    }

/*     Quick return if possible. */

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

/*     And when  alpha.eq.zero. */

    if (*alpha == 0.) {
        i__1 = *n;
        for (j = 1; j <= *n; ++j) {
            i__2 = *m;
            for (i = 1; i <= *m; ++i) {
                B(i,j) = 0.;
/* L10: */
            }
/* L20: */
        }
        return 0;
    }

/*     Start the operations. */

    if (lside) {
        if (lsame_(transa, "N")) {

/*           Form  B := alpha*inv( A )*B. */

            if (upper) {
                i__1 = *n;
                for (j = 1; j <= *n; ++j) {
                    if (*alpha != 1.) {
                        i__2 = *m;
                        for (i = 1; i <= *m; ++i) {
                            B(i,j) = *alpha * B(i,j);
/* L30: */
                        }
                    }
                    for (k = *m; k >= 1; --k) {
                        if (B(k,j) != 0.) {
                            if (nounit) {
                                B(k,j) /= A(k,k);
                            }
                            i__2 = k - 1;
                            for (i = 1; i <= k-1; ++i) {
                                B(i,j) -= B(k,j) * A(i,k);
/* L40: */
                            }
                        }
/* L50: */
                    }
/* L60: */
                }
            } else {
                i__1 = *n;
                for (j = 1; j <= *n; ++j) {
                    if (*alpha != 1.) {
                        i__2 = *m;
                        for (i = 1; i <= *m; ++i) {
                            B(i,j) = *alpha * B(i,j);
/* L70: */
                        }
                    }
                    i__2 = *m;
                    for (k = 1; k <= *m; ++k) {
                        if (B(k,j) != 0.) {
                            if (nounit) {
                                B(k,j) /= A(k,k);
                            }
                            i__3 = *m;
                            for (i = k + 1; i <= *m; ++i) {
                                B(i,j) -= B(k,j) * A(i,k);
/* L80: */
                            }
                        }
/* L90: */
                    }
/* L100: */
                }
            }
        } else {

/*           Form  B := alpha*inv( A' )*B. */

            if (upper) {
                i__1 = *n;
                for (j = 1; j <= *n; ++j) {
                    i__2 = *m;
                    for (i = 1; i <= *m; ++i) {
                        temp = *alpha * B(i,j);
                        i__3 = i - 1;
                        for (k = 1; k <= i-1; ++k) {
                            temp -= A(k,i) * B(k,j);
/* L110: */
                        }
                        if (nounit) {
                            temp /= A(i,i);
                        }
                        B(i,j) = temp;
/* L120: */
                    }
/* L130: */
                }
            } else {
                i__1 = *n;
                for (j = 1; j <= *n; ++j) {
                    for (i = *m; i >= 1; --i) {
                        temp = *alpha * B(i,j);
                        i__2 = *m;
                        for (k = i + 1; k <= *m; ++k) {
                            temp -= A(k,i) * B(k,j);
/* L140: */
                        }
                        if (nounit) {
                            temp /= A(i,i);
                        }
                        B(i,j) = temp;
/* L150: */
                    }
/* L160: */
                }
            }
        }
    } else {
        if (lsame_(transa, "N")) {

/*           Form  B := alpha*B*inv( A ). */

            if (upper) {
                i__1 = *n;
                for (j = 1; j <= *n; ++j) {
                    if (*alpha != 1.) {
                        i__2 = *m;
                        for (i = 1; i <= *m; ++i) {
                            B(i,j) = *alpha * B(i,j);
/* L170: */
                        }
                    }
                    i__2 = j - 1;
                    for (k = 1; k <= j-1; ++k) {
                        if (A(k,j) != 0.) {
                            i__3 = *m;
                            for (i = 1; i <= *m; ++i) {
                                B(i,j) -= A(k,j) * B(i,k);
/* L180: */
                            }
                        }
/* L190: */
                    }
                    if (nounit) {
                        temp = 1. / A(j,j);
                        i__2 = *m;
                        for (i = 1; i <= *m; ++i) {
                            B(i,j) = temp * B(i,j);
/* L200: */
                        }
                    }
/* L210: */
                }
            } else {
                for (j = *n; j >= 1; --j) {
                    if (*alpha != 1.) {
                        i__1 = *m;
                        for (i = 1; i <= *m; ++i) {
                            B(i,j) = *alpha * B(i,j);
/* L220: */
                        }
                    }
                    i__1 = *n;
                    for (k = j + 1; k <= *n; ++k) {
                        if (A(k,j) != 0.) {
                            i__2 = *m;
                            for (i = 1; i <= *m; ++i) {
                                B(i,j) -= A(k,j) * B(i,k);
/* L230: */
                            }
                        }
/* L240: */
                    }
                    if (nounit) {
                        temp = 1. / A(j,j);
                        i__1 = *m;
                        for (i = 1; i <= *m; ++i) {
                            B(i,j) = temp * B(i,j);
/* L250: */
                        }
                    }
/* L260: */
                }
            }
        } else {

/*           Form  B := alpha*B*inv( A' ). */

            if (upper) {
                for (k = *n; k >= 1; --k) {
                    if (nounit) {
                        temp = 1. / A(k,k);
                        i__1 = *m;
                        for (i = 1; i <= *m; ++i) {
                            B(i,k) = temp * B(i,k);
/* L270: */
                        }
                    }
                    i__1 = k - 1;
                    for (j = 1; j <= k-1; ++j) {
                        if (A(j,k) != 0.) {
                            temp = A(j,k);
                            i__2 = *m;
                            for (i = 1; i <= *m; ++i) {
                                B(i,j) -= temp * B(i,k);
/* L280: */
                            }
                        }
/* L290: */
                    }
                    if (*alpha != 1.) {
                        i__1 = *m;
                        for (i = 1; i <= *m; ++i) {
                            B(i,k) = *alpha * B(i,k);
/* L300: */
                        }
                    }
/* L310: */
                }
            } else {
                i__1 = *n;
                for (k = 1; k <= *n; ++k) {
                    if (nounit) {
                        temp = 1. / A(k,k);
                        i__2 = *m;
                        for (i = 1; i <= *m; ++i) {
                            B(i,k) = temp * B(i,k);
/* L320: */
                        }
                    }
                    i__2 = *n;
                    for (j = k + 1; j <= *n; ++j) {
                        if (A(j,k) != 0.) {
                            temp = A(j,k);
                            i__3 = *m;
                            for (i = 1; i <= *m; ++i) {
                                B(i,j) -= temp * B(i,k);
/* L330: */
                            }
                        }
/* L340: */
                    }
                    if (*alpha != 1.) {
                        i__2 = *m;
                        for (i = 1; i <= *m; ++i) {
                            B(i,k) = *alpha * B(i,k);
/* L350: */
                        }
                    }
/* L360: */
                }
            }
        }
    }

    return 0;

/*     End of DTRSM . */

} /* dtrsm_ */

#include "f2c.h"

/* Subroutine */ int dsyrk_(char *uplo, char *trans, integer *n, integer *k, 
        doublereal *alpha, doublereal *a, integer *lda, doublereal *beta, 
        doublereal *c, integer *ldc)
{


    /* System generated locals */
    integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3;

    /* Local variables */
    static integer info;
    static doublereal temp;
    static integer i, j, l;
    extern logical lsame_(char *, char *);
    static integer nrowa;
    static logical upper;
    extern /* Subroutine */ int xerbla_(char *, integer *);


/*  Purpose   
    =======   

    DSYRK  performs one of the symmetric rank k operations   

       C := alpha*A*A' + beta*C,   

    or   

       C := alpha*A'*A + beta*C,   

    where  alpha and beta  are scalars, C is an  n by n  symmetric matrix 
  
    and  A  is an  n by k  matrix in the first case and a  k by n  matrix 
  
    in the second case.   

    Parameters   
    ==========   

    UPLO   - CHARACTER*1.   
             On  entry,   UPLO  specifies  whether  the  upper  or  lower 
  
             triangular  part  of the  array  C  is to be  referenced  as 
  
             follows:   

                UPLO = 'U' or 'u'   Only the  upper triangular part of  C 
  
                                    is to be referenced.   

                UPLO = 'L' or 'l'   Only the  lower triangular part of  C 
  
                                    is to be referenced.   

             Unchanged on exit.   

    TRANS  - CHARACTER*1.   
             On entry,  TRANS  specifies the operation to be performed as 
  
             follows:   

                TRANS = 'N' or 'n'   C := alpha*A*A' + beta*C.   

                TRANS = 'T' or 't'   C := alpha*A'*A + beta*C.   

                TRANS = 'C' or 'c'   C := alpha*A'*A + beta*C.   

             Unchanged on exit.   

    N      - INTEGER.   
             On entry,  N specifies the order of the matrix C.  N must be 
  
             at least zero.   
             Unchanged on exit.   

    K      - INTEGER.   
             On entry with  TRANS = 'N' or 'n',  K  specifies  the number 
  
             of  columns   of  the   matrix   A,   and  on   entry   with 
  
             TRANS = 'T' or 't' or 'C' or 'c',  K  specifies  the  number 
  
             of rows of the matrix  A.  K must be at least zero.   
             Unchanged on exit.   

    ALPHA  - DOUBLE PRECISION.   
             On entry, ALPHA specifies the scalar alpha.   
             Unchanged on exit.   

    A      - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is 
  
             k  when  TRANS = 'N' or 'n',  and is  n  otherwise.   
             Before entry with  TRANS = 'N' or 'n',  the  leading  n by k 
  
             part of the array  A  must contain the matrix  A,  otherwise 
  
             the leading  k by n  part of the array  A  must contain  the 
  
             matrix A.   
             Unchanged on exit.   

    LDA    - INTEGER.   
             On entry, LDA specifies the first dimension of A as declared 
  
             in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n' 
  
             then  LDA must be at least  max( 1, n ), otherwise  LDA must 
  
             be at least  max( 1, k ).   
             Unchanged on exit.   

    BETA   - DOUBLE PRECISION.   
             On entry, BETA specifies the scalar beta.   
             Unchanged on exit.   

    C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ).   
             Before entry  with  UPLO = 'U' or 'u',  the leading  n by n 
  
             upper triangular part of the array C must contain the upper 
  
             triangular part  of the  symmetric matrix  and the strictly 
  
             lower triangular part of C is not referenced.  On exit, the 
  
             upper triangular part of the array  C is overwritten by the 
  
             upper triangular part of the updated matrix.   
             Before entry  with  UPLO = 'L' or 'l',  the leading  n by n 
  
             lower triangular part of the array C must contain the lower 
  
             triangular part  of the  symmetric matrix  and the strictly 
  
             upper triangular part of C is not referenced.  On exit, the 
  
             lower triangular part of the array  C is overwritten by the 
  
             lower triangular part of the updated matrix.   

    LDC    - INTEGER.   
             On entry, LDC specifies the first dimension of C as declared 
  
             in  the  calling  (sub)  program.   LDC  must  be  at  least 
  
             max( 1, n ).   
             Unchanged on exit.   


    Level 3 Blas routine.   

    -- Written on 8-February-1989.   
       Jack Dongarra, Argonne National Laboratory.   
       Iain Duff, AERE Harwell.   
       Jeremy Du Croz, Numerical Algorithms Group Ltd.   
       Sven Hammarling, Numerical Algorithms Group Ltd.   



       Test the input parameters.   

    
   Parameter adjustments   
       Function Body */

#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define C(I,J) c[(I)-1 + ((J)-1)* ( *ldc)]

    if (lsame_(trans, "N")) {
        nrowa = *n;
    } else {
        nrowa = *k;
    }
    upper = lsame_(uplo, "U");

    info = 0;
    if (! upper && ! lsame_(uplo, "L")) {
        info = 1;
    } else if (! lsame_(trans, "N") && ! lsame_(trans, "T") &&
             ! lsame_(trans, "C")) {
        info = 2;
    } else if (*n < 0) {
        info = 3;
    } else if (*k < 0) {
        info = 4;
    } else if (*lda < max(1,nrowa)) {
        info = 7;
    } else if (*ldc < max(1,*n)) {
        info = 10;
    }
    if (info != 0) {
        xerbla_("DSYRK ", &info);
        return 0;
    }

/*     Quick return if possible. */

    if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) {
        return 0;
    }

/*     And when  alpha.eq.zero. */

    if (*alpha == 0.) {
        if (upper) {
            if (*beta == 0.) {
                i__1 = *n;
                for (j = 1; j <= *n; ++j) {
                    i__2 = j;
                    for (i = 1; i <= j; ++i) {
                        C(i,j) = 0.;
/* L10: */
                    }
/* L20: */
                }
            } else {
                i__1 = *n;
                for (j = 1; j <= *n; ++j) {
                    i__2 = j;
                    for (i = 1; i <= j; ++i) {
                        C(i,j) = *beta * C(i,j);
/* L30: */
                    }
/* L40: */
                }
            }
        } else {
            if (*beta == 0.) {
                i__1 = *n;
                for (j = 1; j <= *n; ++j) {
                    i__2 = *n;
                    for (i = j; i <= *n; ++i) {
                        C(i,j) = 0.;
/* L50: */
                    }
/* L60: */
                }
            } else {
                i__1 = *n;
                for (j = 1; j <= *n; ++j) {
                    i__2 = *n;
                    for (i = j; i <= *n; ++i) {
                        C(i,j) = *beta * C(i,j);
/* L70: */
                    }
/* L80: */
                }
            }
        }
        return 0;
    }

/*     Start the operations. */

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

/*        Form  C := alpha*A*A' + beta*C. */

        if (upper) {
            i__1 = *n;
            for (j = 1; j <= *n; ++j) {
                if (*beta == 0.) {
                    i__2 = j;
                    for (i = 1; i <= j; ++i) {
                        C(i,j) = 0.;
/* L90: */
                    }
                } else if (*beta != 1.) {
                    i__2 = j;
                    for (i = 1; i <= j; ++i) {
                        C(i,j) = *beta * C(i,j);
/* L100: */
                    }
                }
                i__2 = *k;
                for (l = 1; l <= *k; ++l) {
                    if (A(j,l) != 0.) {
                        temp = *alpha * A(j,l);
                        i__3 = j;
                        for (i = 1; i <= j; ++i) {
                            C(i,j) += temp * A(i,l);
/* L110: */
                        }
                    }
/* L120: */
                }
/* L130: */
            }
        } else {
            i__1 = *n;
            for (j = 1; j <= *n; ++j) {
                if (*beta == 0.) {
                    i__2 = *n;
                    for (i = j; i <= *n; ++i) {
                        C(i,j) = 0.;
/* L140: */
                    }
                } else if (*beta != 1.) {
                    i__2 = *n;
                    for (i = j; i <= *n; ++i) {
                        C(i,j) = *beta * C(i,j);
/* L150: */
                    }
                }
                i__2 = *k;
                for (l = 1; l <= *k; ++l) {
                    if (A(j,l) != 0.) {
                        temp = *alpha * A(j,l);
                        i__3 = *n;
                        for (i = j; i <= *n; ++i) {
                            C(i,j) += temp * A(i,l);
/* L160: */
                        }
                    }
/* L170: */
                }
/* L180: */
            }
        }
    } else {

/*        Form  C := alpha*A'*A + beta*C. */

        if (upper) {
            i__1 = *n;
            for (j = 1; j <= *n; ++j) {
                i__2 = j;
                for (i = 1; i <= j; ++i) {
                    temp = 0.;
                    i__3 = *k;
                    for (l = 1; l <= *k; ++l) {
                        temp += A(l,i) * A(l,j);
/* L190: */
                    }
                    if (*beta == 0.) {
                        C(i,j) = *alpha * temp;
                    } else {
                        C(i,j) = *alpha * temp + *beta * C(i,j);
                    }
/* L200: */
                }
/* L210: */
            }
        } else {
            i__1 = *n;
            for (j = 1; j <= *n; ++j) {
                i__2 = *n;
                for (i = j; i <= *n; ++i) {
                    temp = 0.;
                    i__3 = *k;
                    for (l = 1; l <= *k; ++l) {
                        temp += A(l,i) * A(l,j);
/* L220: */
                    }
                    if (*beta == 0.) {
                        C(i,j) = *alpha * temp;
                    } else {
                        C(i,j) = *alpha * temp + *beta * C(i,j);
                    }
/* L230: */
                }
/* L240: */
            }
        }
    }

    return 0;

/*     End of DSYRK . */

} /* dsyrk_ */

/*  -- translated by f2c (version 19940927).
   You must link the resulting object file with the libraries:
        -lf2c -lm   (in that order)
*/

#include "f2c.h"

doublereal ddot_(integer *n, doublereal *dx, integer *incx, doublereal *dy, 
        integer *incy)
{


    /* System generated locals */
    integer i__1;
    doublereal ret_val;

    /* Local variables */
    static integer i, m;
    static doublereal dtemp;
    static integer ix, iy, mp1;


/*     forms the dot product of two vectors.   
       uses unrolled loops for increments equal to one.   
       jack dongarra, linpack, 3/11/78.   
       modified 12/3/93, array(1) declarations changed to array(*)   


    
   Parameter adjustments   
       Function Body */
#define DY(I) dy[(I)-1]
#define DX(I) dx[(I)-1]


    ret_val = 0.;
    dtemp = 0.;
    if (*n <= 0) {
        return ret_val;
    }
    if (*incx == 1 && *incy == 1) {
        goto L20;
    }

/*        code for unequal increments or equal increments   
            not equal to 1 */

    ix = 1;
    iy = 1;
    if (*incx < 0) {
        ix = (-(*n) + 1) * *incx + 1;
    }
    if (*incy < 0) {
        iy = (-(*n) + 1) * *incy + 1;
    }
    i__1 = *n;
    for (i = 1; i <= *n; ++i) {
        dtemp += DX(ix) * DY(iy);
        ix += *incx;
        iy += *incy;
/* L10: */
    }
    ret_val = dtemp;
    return ret_val;

/*        code for both increments equal to 1   


          clean-up loop */

L20:
    m = *n % 5;
    if (m == 0) {
        goto L40;
    }
    i__1 = m;
    for (i = 1; i <= m; ++i) {
        dtemp += DX(i) * DY(i);
/* L30: */
    }
    if (*n < 5) {
        goto L60;
    }
L40:
    mp1 = m + 1;
    i__1 = *n;
    for (i = mp1; i <= *n; i += 5) {
        dtemp = dtemp + DX(i) * DY(i) + DX(i + 1) * DY(i + 1) + DX(i + 2) * 
                DY(i + 2) + DX(i + 3) * DY(i + 3) + DX(i + 4) * DY(i + 4);
/* L50: */
    }
L60:
    ret_val = dtemp;
    return ret_val;
} /* ddot_ */

/*  -- translated by f2c (version 19940927).
   You must link the resulting object file with the libraries:
        -lf2c -lm   (in that order)
*/

#include "f2c.h"
/* Subroutine */ int dgemm_(char *transa, char *transb, integer *m, integer *
        n, integer *k, doublereal *alpha, doublereal *a, integer *lda, 
        doublereal *b, integer *ldb, doublereal *beta, doublereal *c, integer 
        *ldc)
{


    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, 
            i__3;

    /* Local variables */
    static integer info;
    static logical nota, notb;
    static doublereal temp;
    static integer i, j, l, ncola;
    extern logical lsame_(char *, char *);
    static integer nrowa, nrowb;
    extern /* Subroutine */ int xerbla_(char *, integer *);


/*  Purpose   
    =======   

    DGEMM  performs one of the matrix-matrix operations   

       C := alpha*op( A )*op( B ) + beta*C,   

    where  op( X ) is one of   

       op( X ) = X   or   op( X ) = X',   

    alpha and beta are scalars, and A, B and C are matrices, with op( A ) 
  
    an m by k matrix,  op( B )  a  k by n matrix and  C an m by n matrix. 
  

    Parameters   
    ==========   

    TRANSA - CHARACTER*1.   
             On entry, TRANSA specifies the form of op( A ) to be used in 
  
             the matrix multiplication as follows:   

                TRANSA = 'N' or 'n',  op( A ) = A.   

                TRANSA = 'T' or 't',  op( A ) = A'.   

                TRANSA = 'C' or 'c',  op( A ) = A'.   

             Unchanged on exit.   

    TRANSB - CHARACTER*1.   
             On entry, TRANSB specifies the form of op( B ) to be used in 
  
             the matrix multiplication as follows:   

                TRANSB = 'N' or 'n',  op( B ) = B.   

                TRANSB = 'T' or 't',  op( B ) = B'.   

                TRANSB = 'C' or 'c',  op( B ) = B'.   

             Unchanged on exit.   

    M      - INTEGER.   
             On entry,  M  specifies  the number  of rows  of the  matrix 
  
             op( A )  and of the  matrix  C.  M  must  be at least  zero. 
  
             Unchanged on exit.   

    N      - INTEGER.   
             On entry,  N  specifies the number  of columns of the matrix 
  
             op( B ) and the number of columns of the matrix C. N must be 
  
             at least zero.   
             Unchanged on exit.   

    K      - INTEGER.   
             On entry,  K  specifies  the number of columns of the matrix 
  
             op( A ) and the number of rows of the matrix op( B ). K must 
  
             be at least  zero.   
             Unchanged on exit.   

    ALPHA  - DOUBLE PRECISION.   
             On entry, ALPHA specifies the scalar alpha.   
             Unchanged on exit.   

    A      - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is 
  
             k  when  TRANSA = 'N' or 'n',  and is  m  otherwise.   
             Before entry with  TRANSA = 'N' or 'n',  the leading  m by k 
  
             part of the array  A  must contain the matrix  A,  otherwise 
  
             the leading  k by m  part of the array  A  must contain  the 
  
             matrix A.   
             Unchanged on exit.   

    LDA    - INTEGER.   
             On entry, LDA specifies the first dimension of A as declared 
  
             in the calling (sub) program. When  TRANSA = 'N' or 'n' then 
  
             LDA must be at least  max( 1, m ), otherwise  LDA must be at 
  
             least  max( 1, k ).   
             Unchanged on exit.   

    B      - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is 
  
             n  when  TRANSB = 'N' or 'n',  and is  k  otherwise.   
             Before entry with  TRANSB = 'N' or 'n',  the leading  k by n 
  
             part of the array  B  must contain the matrix  B,  otherwise 
  
             the leading  n by k  part of the array  B  must contain  the 
  
             matrix B.   
             Unchanged on exit.   

    LDB    - INTEGER.   
             On entry, LDB specifies the first dimension of B as declared 
  
             in the calling (sub) program. When  TRANSB = 'N' or 'n' then 
  
             LDB must be at least  max( 1, k ), otherwise  LDB must be at 
  
             least  max( 1, n ).   
             Unchanged on exit.   

    BETA   - DOUBLE PRECISION.   
             On entry,  BETA  specifies the scalar  beta.  When  BETA  is 
  
             supplied as zero then C need not be set on input.   
             Unchanged on exit.   

    C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ).   
             Before entry, the leading  m by n  part of the array  C must 
  
             contain the matrix  C,  except when  beta  is zero, in which 
  
             case C need not be set on entry.   
             On exit, the array  C  is overwritten by the  m by n  matrix 
  
             ( alpha*op( A )*op( B ) + beta*C ).   

    LDC    - INTEGER.   
             On entry, LDC specifies the first dimension of C as declared 
  
             in  the  calling  (sub)  program.   LDC  must  be  at  least 
  
             max( 1, m ).   
             Unchanged on exit.   


    Level 3 Blas routine.   

    -- Written on 8-February-1989.   
       Jack Dongarra, Argonne National Laboratory.   
       Iain Duff, AERE Harwell.   
       Jeremy Du Croz, Numerical Algorithms Group Ltd.   
       Sven Hammarling, Numerical Algorithms Group Ltd.   



       Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not 
  
       transposed and set  NROWA, NCOLA and  NROWB  as the number of rows 
  
       and  columns of  A  and the  number of  rows  of  B  respectively. 
  

    
   Parameter adjustments   
       Function Body */

#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define C(I,J) c[(I)-1 + ((J)-1)* ( *ldc)]

    nota = lsame_(transa, "N");
    notb = lsame_(transb, "N");
    if (nota) {
        nrowa = *m;
        ncola = *k;
    } else {
        nrowa = *k;
        ncola = *m;
    }
    if (notb) {
        nrowb = *k;
    } else {
        nrowb = *n;
    }

/*     Test the input parameters. */

    info = 0;
    if (! nota && ! lsame_(transa, "C") && ! lsame_(transa, "T")) {
        info = 1;
    } else if (! notb && ! lsame_(transb, "C") && ! lsame_(transb, 
            "T")) {
        info = 2;
    } else if (*m < 0) {
        info = 3;
    } else if (*n < 0) {
        info = 4;
    } else if (*k < 0) {
        info = 5;
    } else if (*lda < max(1,nrowa)) {
        info = 8;
    } else if (*ldb < max(1,nrowb)) {
        info = 10;
    } else if (*ldc < max(1,*m)) {
        info = 13;
    }
    if (info != 0) {
        xerbla_("DGEMM ", &info);
        return 0;
    }

/*     Quick return if possible. */

    if (*m == 0 || *n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) {
        return 0;
    }

/*     And if  alpha.eq.zero. */

    if (*alpha == 0.) {
        if (*beta == 0.) {
            i__1 = *n;
            for (j = 1; j <= *n; ++j) {
                i__2 = *m;
                for (i = 1; i <= *m; ++i) {
                    C(i,j) = 0.;
/* L10: */
                }
/* L20: */
            }
        } else {
            i__1 = *n;
            for (j = 1; j <= *n; ++j) {
                i__2 = *m;
                for (i = 1; i <= *m; ++i) {
                    C(i,j) = *beta * C(i,j);
/* L30: */
                }
/* L40: */
            }
        }
        return 0;
    }

/*     Start the operations. */

    if (notb) {
        if (nota) {

/*           Form  C := alpha*A*B + beta*C. */

            i__1 = *n;
            for (j = 1; j <= *n; ++j) {
                if (*beta == 0.) {
                    i__2 = *m;
                    for (i = 1; i <= *m; ++i) {
                        C(i,j) = 0.;
/* L50: */
                    }
                } else if (*beta != 1.) {
                    i__2 = *m;
                    for (i = 1; i <= *m; ++i) {
                        C(i,j) = *beta * C(i,j);
/* L60: */
                    }
                }
                i__2 = *k;
                for (l = 1; l <= *k; ++l) {
                    if (B(l,j) != 0.) {
                        temp = *alpha * B(l,j);
                        i__3 = *m;
                        for (i = 1; i <= *m; ++i) {
                            C(i,j) += temp * A(i,l);
/* L70: */
                        }
                    }
/* L80: */
                }
/* L90: */
            }
        } else {

/*           Form  C := alpha*A'*B + beta*C */

            i__1 = *n;
            for (j = 1; j <= *n; ++j) {
                i__2 = *m;
                for (i = 1; i <= *m; ++i) {
                    temp = 0.;
                    i__3 = *k;
                    for (l = 1; l <= *k; ++l) {
                        temp += A(l,i) * B(l,j);
/* L100: */
                    }
                    if (*beta == 0.) {
                        C(i,j) = *alpha * temp;
                    } else {
                        C(i,j) = *alpha * temp + *beta * C(i,j);
                    }
/* L110: */
                }
/* L120: */
            }
        }
    } else {
        if (nota) {

/*           Form  C := alpha*A*B' + beta*C */

            i__1 = *n;
            for (j = 1; j <= *n; ++j) {
                if (*beta == 0.) {
                    i__2 = *m;
                    for (i = 1; i <= *m; ++i) {
                        C(i,j) = 0.;
/* L130: */
                    }
                } else if (*beta != 1.) {
                    i__2 = *m;
                    for (i = 1; i <= *m; ++i) {
                        C(i,j) = *beta * C(i,j);
/* L140: */
                    }
                }
                i__2 = *k;
                for (l = 1; l <= *k; ++l) {
                    if (B(j,l) != 0.) {
                        temp = *alpha * B(j,l);
                        i__3 = *m;
                        for (i = 1; i <= *m; ++i) {
                            C(i,j) += temp * A(i,l);
/* L150: */
                        }
                    }
/* L160: */
                }
/* L170: */
            }
        } else {

/*           Form  C := alpha*A'*B' + beta*C */

            i__1 = *n;
            for (j = 1; j <= *n; ++j) {
                i__2 = *m;
                for (i = 1; i <= *m; ++i) {
                    temp = 0.;
                    i__3 = *k;
                    for (l = 1; l <= *k; ++l) {
                        temp += A(l,i) * B(j,l);
/* L180: */
                    }
                    if (*beta == 0.) {
                        C(i,j) = *alpha * temp;
                    } else {
                        C(i,j) = *alpha * temp + *beta * C(i,j);
                    }
/* L190: */
                }
/* L200: */
            }
        }
    }

    return 0;

/*     End of DGEMM . */

} /* dgemm_ */

#include "f2c.h"

/* Subroutine */ int dgemv_(char *trans, integer *m, integer *n, doublereal *
        alpha, doublereal *a, integer *lda, doublereal *x, integer *incx, 
        doublereal *beta, doublereal *y, integer *incy)
{


    /* System generated locals */
    integer a_dim1, a_offset, i__1, i__2;

    /* Local variables */
    static integer info;
    static doublereal temp;
    static integer lenx, leny, i, j;
    extern logical lsame_(char *, char *);
    static integer ix, iy, jx, jy, kx, ky;
    extern /* Subroutine */ int xerbla_(char *, integer *);


/*  Purpose   
    =======   

    DGEMV  performs one of the matrix-vector operations   

       y := alpha*A*x + beta*y,   or   y := alpha*A'*x + beta*y,   

    where alpha and beta are scalars, x and y are vectors and A is an   
    m by n matrix.   

    Parameters   
    ==========   

    TRANS  - CHARACTER*1.   
             On entry, TRANS specifies the operation to be performed as   
             follows:   

                TRANS = 'N' or 'n'   y := alpha*A*x + beta*y.   

                TRANS = 'T' or 't'   y := alpha*A'*x + beta*y.   

                TRANS = 'C' or 'c'   y := alpha*A'*x + beta*y.   

             Unchanged on exit.   

    M      - INTEGER.   
             On entry, M specifies the number of rows of the matrix A.   
             M must be at least zero.   
             Unchanged on exit.   

    N      - INTEGER.   
             On entry, N specifies the number of columns of the matrix A. 
  
             N must be at least zero.   
             Unchanged on exit.   

    ALPHA  - DOUBLE PRECISION.   
             On entry, ALPHA specifies the scalar alpha.   
             Unchanged on exit.   

    A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).   
             Before entry, the leading m by n part of the array A must   
             contain the matrix of coefficients.   
             Unchanged on exit.   

    LDA    - INTEGER.   
             On entry, LDA specifies the first dimension of A as declared 
  
             in the calling (sub) program. LDA must be at least   
             max( 1, m ).   
             Unchanged on exit.   

    X      - DOUBLE PRECISION array of DIMENSION at least   
             ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'   
             and at least   
             ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.   
             Before entry, the incremented array X must contain the   
             vector x.   
             Unchanged on exit.   

    INCX   - INTEGER.   
             On entry, INCX specifies the increment for the elements of   
             X. INCX must not be zero.   
             Unchanged on exit.   

    BETA   - DOUBLE PRECISION.   
             On entry, BETA specifies the scalar beta. When BETA is   
             supplied as zero then Y need not be set on input.   
             Unchanged on exit.   

    Y      - DOUBLE PRECISION array of DIMENSION at least   
             ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'   
             and at least   
             ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.   
             Before entry with BETA non-zero, the incremented array Y   
             must contain the vector y. On exit, Y is overwritten by the 
  
             updated vector y.   

    INCY   - INTEGER.   
             On entry, INCY specifies the increment for the elements of   
             Y. INCY must not be zero.   
             Unchanged on exit.   


    Level 2 Blas routine.   

    -- Written on 22-October-1986.   
       Jack Dongarra, Argonne National Lab.   
       Jeremy Du Croz, Nag Central Office.   
       Sven Hammarling, Nag Central Office.   
       Richard Hanson, Sandia National Labs.   



       Test the input parameters.   

    
   Parameter adjustments   
       Function Body */
#define X(I) x[(I)-1]
#define Y(I) y[(I)-1]

#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]

    info = 0;
    if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! 
            lsame_(trans, "C")) {
        info = 1;
    } else if (*m < 0) {
        info = 2;
    } else if (*n < 0) {
        info = 3;
    } else if (*lda < max(1,*m)) {
        info = 6;
    } else if (*incx == 0) {
        info = 8;
    } else if (*incy == 0) {
        info = 11;
    }
    if (info != 0) {
        xerbla_("DGEMV ", &info);
        return 0;
    }

/*     Quick return if possible. */

    if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) {
        return 0;
    }

/*     Set  LENX  and  LENY, the lengths of the vectors x and y, and set 
  
       up the start points in  X  and  Y. */

    if (lsame_(trans, "N")) {
        lenx = *n;
        leny = *m;
    } else {
        lenx = *m;
        leny = *n;
    }
    if (*incx > 0) {
        kx = 1;
    } else {
        kx = 1 - (lenx - 1) * *incx;
    }
    if (*incy > 0) {
        ky = 1;
    } else {
        ky = 1 - (leny - 1) * *incy;
    }

/*     Start the operations. In this version the elements of A are   
       accessed sequentially with one pass through A.   

       First form  y := beta*y. */

    if (*beta != 1.) {
        if (*incy == 1) {
            if (*beta == 0.) {
                i__1 = leny;
                for (i = 1; i <= leny; ++i) {
                    Y(i) = 0.;
/* L10: */
                }
            } else {
                i__1 = leny;
                for (i = 1; i <= leny; ++i) {
                    Y(i) = *beta * Y(i);
/* L20: */
                }
            }
        } else {
            iy = ky;
            if (*beta == 0.) {
                i__1 = leny;
                for (i = 1; i <= leny; ++i) {
                    Y(iy) = 0.;
                    iy += *incy;
/* L30: */
                }
            } else {
                i__1 = leny;
                for (i = 1; i <= leny; ++i) {
                    Y(iy) = *beta * Y(iy);
                    iy += *incy;
/* L40: */
                }
            }
        }
    }
    if (*alpha == 0.) {
        return 0;
    }
    if (lsame_(trans, "N")) {

/*        Form  y := alpha*A*x + y. */

        jx = kx;
        if (*incy == 1) {
            i__1 = *n;
            for (j = 1; j <= *n; ++j) {
                if (X(jx) != 0.) {
                    temp = *alpha * X(jx);
                    i__2 = *m;
                    for (i = 1; i <= *m; ++i) {
                        Y(i) += temp * A(i,j);
/* L50: */
                    }
                }
                jx += *incx;
/* L60: */
            }
        } else {
            i__1 = *n;
            for (j = 1; j <= *n; ++j) {
                if (X(jx) != 0.) {
                    temp = *alpha * X(jx);
                    iy = ky;
                    i__2 = *m;
                    for (i = 1; i <= *m; ++i) {
                        Y(iy) += temp * A(i,j);
                        iy += *incy;
/* L70: */
                    }
                }
                jx += *incx;
/* L80: */
            }
        }
    } else {

/*        Form  y := alpha*A'*x + y. */

        jy = ky;
        if (*incx == 1) {
            i__1 = *n;
            for (j = 1; j <= *n; ++j) {
                temp = 0.;
                i__2 = *m;
                for (i = 1; i <= *m; ++i) {
                    temp += A(i,j) * X(i);
/* L90: */
                }
                Y(jy) += *alpha * temp;
                jy += *incy;
/* L100: */
            }
        } else {
            i__1 = *n;
            for (j = 1; j <= *n; ++j) {
                temp = 0.;
                ix = kx;
                i__2 = *m;
                for (i = 1; i <= *m; ++i) {
                    temp += A(i,j) * X(ix);
                    ix += *incx;
/* L110: */
                }
                Y(jy) += *alpha * temp;
                jy += *incy;
/* L120: */
            }
        }
    }

    return 0;

/*     End of DGEMV . */

} /* dgemv_ */

 #include "f2c.h"

/* Subroutine */ int dscal_(integer *n, doublereal *da, doublereal *dx, 
        integer *incx)
{


    /* System generated locals */
    integer i__1, i__2;

    /* Local variables */
    static integer i, m, nincx, mp1;


/*     scales a vector by a constant.   
       uses unrolled loops for increment equal to one.   
       jack dongarra, linpack, 3/11/78.   
       modified 3/93 to return if incx .le. 0.   
       modified 12/3/93, array(1) declarations changed to array(*)   


    
   Parameter adjustments   
       Function Body */
#define DX(I) dx[(I)-1]


    if (*n <= 0 || *incx <= 0) {
        return 0;
    }
    if (*incx == 1) {
        goto L20;
    }

/*        code for increment not equal to 1 */

    nincx = *n * *incx;
    i__1 = nincx;
    i__2 = *incx;
    for (i = 1; *incx < 0 ? i >= nincx : i <= nincx; i += *incx) {
        DX(i) = *da * DX(i);
/* L10: */
    }
    return 0;
    

/*        code for increment equal to 1   


          clean-up loop */

L20:
    m = *n % 5;
    if (m == 0) {
        goto L40;
    }
    i__2 = m;
    for (i = 1; i <= m; ++i) {
        DX(i) = *da * DX(i);
/* L30: */
    }
    if (*n < 5) {
        return 0;
    }
L40:
    mp1 = m + 1;
    i__2 = *n;
    for (i = mp1; i <= *n; i += 5) {
        DX(i) = *da * DX(i);
        DX(i + 1) = *da * DX(i + 1);
        DX(i + 2) = *da * DX(i + 2);
        DX(i + 3) = *da * DX(i + 3);
        DX(i + 4) = *da * DX(i + 4);
/* L50: */
    }
    return 0;
} /* dscal_ */

 #include "f2c.h"

/* compare two strings */

#ifdef KR_headers
integer s_cmp(a0, b0, la, lb) char *a0, *b0; ftnlen la, lb;
#else
integer s_cmp(char *a0, char *b0, ftnlen la, ftnlen lb)
#endif
{
register unsigned char *a, *aend, *b, *bend;
a = (unsigned char *)a0;
b = (unsigned char *)b0;
aend = a + la;
bend = b + lb;

if(la <= lb)
        {
        while(a < aend)
                if(*a != *b)
                        return( *a - *b );
                else
                        { ++a; ++b; }

        while(b < bend)
                if(*b != ' ')
                        return( ' ' - *b );
                else    ++b;
        }

else
        {
        while(b < bend)
                if(*a == *b)
                        { ++a; ++b; }
                else
                        return( *a - *b );
        while(a < aend)
                if(*a != ' ')
                        return(*a - ' ');
                else    ++a;
        }
return(0);
}

/* Unless compiled with -DNO_OVERWRITE, this variant of s_copy allows the
 * target of an assignment to appear on its right-hand side (contrary
 * to the Fortran 77 Standard, but in accordance with Fortran 90),
 * as in  a(2:5) = a(4:7) .
 */

#include "f2c.h"

/* assign strings:  a = b */


#ifdef KR_headers
VOID s_copy(a, b, la, lb) register char *a, *b; ftnlen la, lb;
#else
void s_copy(register char *a, register char *b, ftnlen la, ftnlen lb)
#endif
{
        register char *aend, *bend;

        aend = a + la;

        if(la <= lb)
#ifndef NO_OVERWRITE
                if (a <= b || a >= b + la)
#endif
                        while(a < aend)
                                *a++ = *b++;
#ifndef NO_OVERWRITE
                else
                        for(b += la; a < aend; )
                                *--aend = *--b;
#endif

        else {
                bend = b + lb;
#ifndef NO_OVERWRITE
                if (a <= b || a >= bend)
#endif
                        while(b < bend)
                                *a++ = *b++;
#ifndef NO_OVERWRITE
                else {
                        a += lb;
                        while(b < bend)
                                *--a = *--bend;
                        a += lb;
                        }
#endif
                while(a < aend)
                        *a++ = ' ';
                }
}










