예제 #1
0
파일: cchkq3.c 프로젝트: kstraube/hysim
/* Subroutine */ int cchkq3_(logical *dotype, integer *nm, integer *mval, 
	integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
	nxval, real *thresh, complex *a, complex *copya, real *s, real *copys, 
	 complex *tau, complex *work, real *rwork, integer *iwork, integer *
	nout)
{
    /* Initialized data */

    static integer iseedy[4] = { 1988,1989,1990,1991 };

    /* Format strings */
    static char fmt_9999[] = "(1x,a6,\002 M =\002,i5,\002, N =\002,i5,\002, "
	    "NB =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
	    "=\002,g12.5)";

    /* System generated locals */
    integer i__1, i__2, i__3, i__4;
    real r__1;

    /* Builtin functions */
    /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
    integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);

    /* Local variables */
    integer i__, k, m, n, nb, im, in, lw, nx, lda, inb;
    real eps;
    integer mode, info;
    char path[3];
    integer ilow, nrun;
    extern /* Subroutine */ int alahd_(integer *, char *);
    integer ihigh, nfail, iseed[4], imode;
    extern doublereal cqpt01_(integer *, integer *, integer *, complex *, 
	    complex *, integer *, complex *, integer *, complex *, integer *),
	     cqrt11_(integer *, integer *, complex *, integer *, complex *, 
	    complex *, integer *), cqrt12_(integer *, integer *, complex *, 
	    integer *, real *, complex *, integer *, real *);
    integer mnmin;
    extern /* Subroutine */ int icopy_(integer *, integer *, integer *, 
	    integer *, integer *);
    integer istep, nerrs, lwork;
    extern /* Subroutine */ int cgeqp3_(integer *, integer *, complex *, 
	    integer *, integer *, complex *, complex *, integer *, real *, 
	    integer *);
    extern doublereal slamch_(char *);
    extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex 
	    *, integer *, complex *, integer *), claset_(char *, 
	    integer *, integer *, complex *, complex *, complex *, integer *), alasum_(char *, integer *, integer *, integer *, integer 
	    *), clatms_(integer *, integer *, char *, integer *, char 
	    *, real *, integer *, real *, real *, integer *, integer *, char *
, complex *, integer *, complex *, integer *), slaord_(char *, integer *, real *, integer *), 
	    xlaenv_(integer *, integer *);
    real result[3];

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



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

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

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

/*  CCHKQ3 tests CGEQP3. */

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

/*  DOTYPE  (input) LOGICAL array, dimension (NTYPES) */
/*          The matrix types to be used for testing.  Matrices of type j */
/*          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/*          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */

/*  NM      (input) INTEGER */
/*          The number of values of M contained in the vector MVAL. */

/*  MVAL    (input) INTEGER array, dimension (NM) */
/*          The values of the matrix row dimension M. */

/*  NN      (input) INTEGER */
/*          The number of values of N contained in the vector NVAL. */

/*  NVAL    (input) INTEGER array, dimension (NN) */
/*          The values of the matrix column dimension N. */

/*  NNB     (input) INTEGER */
/*          The number of values of NB and NX contained in the */
/*          vectors NBVAL and NXVAL.  The blocking parameters are used */
/*          in pairs (NB,NX). */

/*  NBVAL   (input) INTEGER array, dimension (NNB) */
/*          The values of the blocksize NB. */

/*  NXVAL   (input) INTEGER array, dimension (NNB) */
/*          The values of the crossover point NX. */

/*  THRESH  (input) REAL */
/*          The threshold value for the test ratios.  A result is */
/*          included in the output file if RESULT >= THRESH.  To have */
/*          every test ratio printed, use THRESH = 0. */

/*  A       (workspace) COMPLEX array, dimension (MMAX*NMAX) */
/*          where MMAX is the maximum value of M in MVAL and NMAX is the */
/*          maximum value of N in NVAL. */

/*  COPYA   (workspace) COMPLEX array, dimension (MMAX*NMAX) */

/*  S       (workspace) REAL array, dimension */
/*                      (min(MMAX,NMAX)) */

/*  COPYS   (workspace) REAL array, dimension */
/*                      (min(MMAX,NMAX)) */

/*  TAU     (workspace) COMPLEX array, dimension (MMAX) */

/*  WORK    (workspace) COMPLEX array, dimension */
/*                      (max(M*max(M,N) + 4*min(M,N) + max(M,N))) */

/*  RWORK   (workspace) REAL array, dimension (4*NMAX) */

/*  IWORK   (workspace) INTEGER array, dimension (2*NMAX) */

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

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. Local Arrays .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Scalars in Common .. */
/*     .. */
/*     .. Common blocks .. */
/*     .. */
/*     .. Data statements .. */
    /* Parameter adjustments */
    --iwork;
    --rwork;
    --work;
    --tau;
    --copys;
    --s;
    --copya;
    --a;
    --nxval;
    --nbval;
    --nval;
    --mval;
    --dotype;

    /* Function Body */
/*     .. */
/*     .. Executable Statements .. */

/*     Initialize constants and the random number seed. */

    s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
    s_copy(path + 1, "Q3", (ftnlen)2, (ftnlen)2);
    nrun = 0;
    nfail = 0;
    nerrs = 0;
    for (i__ = 1; i__ <= 4; ++i__) {
	iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
    }
    eps = slamch_("Epsilon");
    infoc_1.infot = 0;

    i__1 = *nm;
    for (im = 1; im <= i__1; ++im) {

/*        Do for each value of M in MVAL. */

	m = mval[im];
	lda = max(1,m);

	i__2 = *nn;
	for (in = 1; in <= i__2; ++in) {

/*           Do for each value of N in NVAL. */

	    n = nval[in];
	    mnmin = min(m,n);
/* Computing MAX */
	    i__3 = 1, i__4 = m * max(m,n) + (mnmin << 2) + max(m,n);
	    lwork = max(i__3,i__4);

	    for (imode = 1; imode <= 6; ++imode) {
		if (! dotype[imode]) {
		    goto L70;
		}

/*              Do for each type of matrix */
/*                 1:  zero matrix */
/*                 2:  one small singular value */
/*                 3:  geometric distribution of singular values */
/*                 4:  first n/2 columns fixed */
/*                 5:  last n/2 columns fixed */
/*                 6:  every second column fixed */

		mode = imode;
		if (imode > 3) {
		    mode = 1;
		}

/*              Generate test matrix of size m by n using */
/*              singular value distribution indicated by `mode'. */

		i__3 = n;
		for (i__ = 1; i__ <= i__3; ++i__) {
		    iwork[i__] = 0;
/* L20: */
		}
		if (imode == 1) {
		    claset_("Full", &m, &n, &c_b1, &c_b1, &copya[1], &lda);
		    i__3 = mnmin;
		    for (i__ = 1; i__ <= i__3; ++i__) {
			copys[i__] = 0.f;
/* L30: */
		    }
		} else {
		    r__1 = 1.f / eps;
		    clatms_(&m, &n, "Uniform", iseed, "Nonsymm", &copys[1], &
			    mode, &r__1, &c_b15, &m, &n, "No packing", &copya[
			    1], &lda, &work[1], &info);
		    if (imode >= 4) {
			if (imode == 4) {
			    ilow = 1;
			    istep = 1;
/* Computing MAX */
			    i__3 = 1, i__4 = n / 2;
			    ihigh = max(i__3,i__4);
			} else if (imode == 5) {
/* Computing MAX */
			    i__3 = 1, i__4 = n / 2;
			    ilow = max(i__3,i__4);
			    istep = 1;
			    ihigh = n;
			} else if (imode == 6) {
			    ilow = 1;
			    istep = 2;
			    ihigh = n;
			}
			i__3 = ihigh;
			i__4 = istep;
			for (i__ = ilow; i__4 < 0 ? i__ >= i__3 : i__ <= i__3;
				 i__ += i__4) {
			    iwork[i__] = 1;
/* L40: */
			}
		    }
		    slaord_("Decreasing", &mnmin, &copys[1], &c__1);
		}

		i__4 = *nnb;
		for (inb = 1; inb <= i__4; ++inb) {

/*                 Do for each pair of values (NB,NX) in NBVAL and NXVAL. */

		    nb = nbval[inb];
		    xlaenv_(&c__1, &nb);
		    nx = nxval[inb];
		    xlaenv_(&c__3, &nx);

/*                 Save A and its singular values and a copy of */
/*                 vector IWORK. */

		    clacpy_("All", &m, &n, &copya[1], &lda, &a[1], &lda);
		    icopy_(&n, &iwork[1], &c__1, &iwork[n + 1], &c__1);

/*                 Workspace needed. */

		    lw = nb * (n + 1);

		    s_copy(srnamc_1.srnamt, "CGEQP3", (ftnlen)6, (ftnlen)6);
		    cgeqp3_(&m, &n, &a[1], &lda, &iwork[n + 1], &tau[1], &
			    work[1], &lw, &rwork[1], &info);

/*                 Compute norm(svd(a) - svd(r)) */

		    result[0] = cqrt12_(&m, &n, &a[1], &lda, &copys[1], &work[
			    1], &lwork, &rwork[1]);

/*                 Compute norm( A*P - Q*R ) */

		    result[1] = cqpt01_(&m, &n, &mnmin, &copya[1], &a[1], &
			    lda, &tau[1], &iwork[n + 1], &work[1], &lwork);

/*                 Compute Q'*Q */

		    result[2] = cqrt11_(&m, &mnmin, &a[1], &lda, &tau[1], &
			    work[1], &lwork);

/*                 Print information about the tests that did not pass */
/*                 the threshold. */

		    for (k = 1; k <= 3; ++k) {
			if (result[k - 1] >= *thresh) {
			    if (nfail == 0 && nerrs == 0) {
				alahd_(nout, path);
			    }
			    io___28.ciunit = *nout;
			    s_wsfe(&io___28);
			    do_fio(&c__1, "CGEQP3", (ftnlen)6);
			    do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
				    ;
			    do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
				    ;
			    do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
				    );
			    do_fio(&c__1, (char *)&imode, (ftnlen)sizeof(
				    integer));
			    do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
				    ;
			    do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
				    sizeof(real));
			    e_wsfe();
			    ++nfail;
			}
/* L50: */
		    }
		    nrun += 3;

/* L60: */
		}
L70:
		;
	    }
/* L80: */
	}
/* L90: */
    }

/*     Print a summary of the results. */

    alasum_(path, nout, &nfail, &nrun, &nerrs);


/*     End of CCHKQ3 */

    return 0;
} /* cchkq3_ */
예제 #2
0
파일: sqrt15.c 프로젝트: zangel/uquad
/* Subroutine */ int sqrt15_(integer *scale, integer *rksel, integer *m,
                             integer *n, integer *nrhs, real *a, integer *lda, real *b, integer *
                             ldb, real *s, integer *rank, real *norma, real *normb, integer *iseed,
                             real *work, integer *lwork)
{
    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
    real r__1;

    /* Local variables */
    static integer info;
    static real temp;
    extern doublereal snrm2_(integer *, real *, integer *);
    static integer j;
    extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
           slarf_(char *, integer *, integer *, real *, integer *, real *,
                  real *, integer *, real *), sgemm_(char *, char *,
                          integer *, integer *, integer *, real *, real *, integer *, real *
                          , integer *, real *, real *, integer *);
    extern doublereal sasum_(integer *, real *, integer *);
    static real dummy[1];
    static integer mn;
    extern doublereal slamch_(char *), slange_(char *, integer *,
            integer *, real *, integer *, real *);
    extern /* Subroutine */ int xerbla_(char *, integer *);
    static real bignum;
    extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
                                        real *, integer *, integer *, real *, integer *, integer *);
    extern doublereal slarnd_(integer *, integer *);
    extern /* Subroutine */ int slaord_(char *, integer *, real *, integer *), slaset_(char *, integer *, integer *, real *, real *,
            real *, integer *), slaror_(char *, char *, integer *,
                                        integer *, real *, integer *, integer *, real *, integer *), slarnv_(integer *, integer *, integer *, real *);
    static real smlnum, eps;


#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]


    /*  -- LAPACK test routine (version 3.0) --
           Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
           Courant Institute, Argonne National Lab, and Rice University
           September 30, 1994


        Purpose
        =======

        SQRT15 generates a matrix with full or deficient rank and of various
        norms.

        Arguments
        =========

        SCALE   (input) INTEGER
                SCALE = 1: normally scaled matrix
                SCALE = 2: matrix scaled up
                SCALE = 3: matrix scaled down

        RKSEL   (input) INTEGER
                RKSEL = 1: full rank matrix
                RKSEL = 2: rank-deficient matrix

        M       (input) INTEGER
                The number of rows of the matrix A.

        N       (input) INTEGER
                The number of columns of A.

        NRHS    (input) INTEGER
                The number of columns of B.

        A       (output) REAL array, dimension (LDA,N)
                The M-by-N matrix A.

        LDA     (input) INTEGER
                The leading dimension of the array A.

        B       (output) REAL array, dimension (LDB, NRHS)
                A matrix that is in the range space of matrix A.

        LDB     (input) INTEGER
                The leading dimension of the array B.

        S       (output) REAL array, dimension MIN(M,N)
                Singular values of A.

        RANK    (output) INTEGER
                number of nonzero singular values of A.

        NORMA   (output) REAL
                one-norm of A.

        NORMB   (output) REAL
                one-norm of B.

        ISEED   (input/output) integer array, dimension (4)
                seed for random number generator.

        WORK    (workspace) REAL array, dimension (LWORK)

        LWORK   (input) INTEGER
                length of work space required.
                LWORK >= MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M)

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


           Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1 * 1;
    a -= a_offset;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1 * 1;
    b -= b_offset;
    --s;
    --iseed;
    --work;

    /* Function Body */
    mn = min(*m,*n);
    /* Computing MAX */
    i__1 = *m + mn, i__2 = mn * *nrhs, i__1 = max(i__1,i__2), i__2 = (*n << 1)
                           + *m;
    if (*lwork < max(i__1,i__2)) {
        xerbla_("SQRT15", &c__16);
        return 0;
    }

    smlnum = slamch_("Safe minimum");
    bignum = 1.f / smlnum;
    eps = slamch_("Epsilon");
    smlnum = smlnum / eps / eps;
    bignum = 1.f / smlnum;

    /*     Determine rank and (unscaled) singular values */

    if (*rksel == 1) {
        *rank = mn;
    } else if (*rksel == 2) {
        *rank = mn * 3 / 4;
        i__1 = mn;
        for (j = *rank + 1; j <= i__1; ++j) {
            s[j] = 0.f;
            /* L10: */
        }
    } else {
        xerbla_("SQRT15", &c__2);
    }

    if (*rank > 0) {

        /*        Nontrivial case */

        s[1] = 1.f;
        i__1 = *rank;
        for (j = 2; j <= i__1; ++j) {
L20:
            temp = slarnd_(&c__1, &iseed[1]);
            if (temp > .1f) {
                s[j] = dabs(temp);
            } else {
                goto L20;
            }
            /* L30: */
        }
        slaord_("Decreasing", rank, &s[1], &c__1);

        /*        Generate 'rank' columns of a random orthogonal matrix in A */

        slarnv_(&c__2, &iseed[1], m, &work[1]);
        r__1 = 1.f / snrm2_(m, &work[1], &c__1);
        sscal_(m, &r__1, &work[1], &c__1);
        slaset_("Full", m, rank, &c_b18, &c_b19, &a[a_offset], lda)
        ;
        slarf_("Left", m, rank, &work[1], &c__1, &c_b22, &a[a_offset], lda, &
               work[*m + 1]);

        /*        workspace used: m+mn

                  Generate consistent rhs in the range space of A */

        i__1 = *rank * *nrhs;
        slarnv_(&c__2, &iseed[1], &i__1, &work[1]);
        sgemm_("No transpose", "No transpose", m, nrhs, rank, &c_b19, &a[
                   a_offset], lda, &work[1], rank, &c_b18, &b[b_offset], ldb);

        /*        work space used: <= mn *nrhs

                  generate (unscaled) matrix A */

        i__1 = *rank;
        for (j = 1; j <= i__1; ++j) {
            sscal_(m, &s[j], &a_ref(1, j), &c__1);
            /* L40: */
        }
        if (*rank < *n) {
            i__1 = *n - *rank;
            slaset_("Full", m, &i__1, &c_b18, &c_b18, &a_ref(1, *rank + 1),
                    lda);
        }
        slaror_("Right", "No initialization", m, n, &a[a_offset], lda, &iseed[
                    1], &work[1], &info);

    } else {

        /*        work space used 2*n+m

                  Generate null matrix and rhs */

        i__1 = mn;
        for (j = 1; j <= i__1; ++j) {
            s[j] = 0.f;
            /* L50: */
        }
        slaset_("Full", m, n, &c_b18, &c_b18, &a[a_offset], lda);
        slaset_("Full", m, nrhs, &c_b18, &c_b18, &b[b_offset], ldb)
        ;

    }

    /*     Scale the matrix */

    if (*scale != 1) {
        *norma = slange_("Max", m, n, &a[a_offset], lda, dummy);
        if (*norma != 0.f) {
            if (*scale == 2) {

                /*              matrix scaled up */

                slascl_("General", &c__0, &c__0, norma, &bignum, m, n, &a[
                            a_offset], lda, &info);
                slascl_("General", &c__0, &c__0, norma, &bignum, &mn, &c__1, &
                        s[1], &mn, &info);
                slascl_("General", &c__0, &c__0, norma, &bignum, m, nrhs, &b[
                            b_offset], ldb, &info);
            } else if (*scale == 3) {

                /*              matrix scaled down */

                slascl_("General", &c__0, &c__0, norma, &smlnum, m, n, &a[
                            a_offset], lda, &info);
                slascl_("General", &c__0, &c__0, norma, &smlnum, &mn, &c__1, &
                        s[1], &mn, &info);
                slascl_("General", &c__0, &c__0, norma, &smlnum, m, nrhs, &b[
                            b_offset], ldb, &info);
            } else {
                xerbla_("SQRT15", &c__1);
                return 0;
            }
        }
    }

    *norma = sasum_(&mn, &s[1], &c__1);
    *normb = slange_("One-norm", m, nrhs, &b[b_offset], ldb, dummy)
             ;

    return 0;

    /*     End of SQRT15 */

} /* sqrt15_ */
예제 #3
0
파일: schktz.c 프로젝트: 3deggi/levmar-ndk
/* Subroutine */ int schktz_(logical *dotype, integer *nm, integer *mval, 
	integer *nn, integer *nval, real *thresh, logical *tsterr, real *a, 
	real *copya, real *s, real *copys, real *tau, real *work, integer *
	nout)
{
    /* Initialized data */

    static integer iseedy[4] = { 1988,1989,1990,1991 };

    /* Format strings */
    static char fmt_9999[] = "(\002 M =\002,i5,\002, N =\002,i5,\002, type"
	    " \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";

    /* System generated locals */
    integer i__1, i__2, i__3, i__4;
    real r__1;

    /* Builtin functions */
    /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
    integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);

    /* Local variables */
    integer i__, k, m, n, im, in, lda;
    real eps;
    integer mode, info;
    char path[3];
    integer nrun;
    extern /* Subroutine */ int alahd_(integer *, char *);
    integer nfail, iseed[4], imode, mnmin, nerrs;
    extern doublereal sqrt12_(integer *, integer *, real *, integer *, real *, 
	     real *, integer *);
    integer lwork;
    extern doublereal srzt01_(integer *, integer *, real *, real *, integer *, 
	     real *, real *, integer *), srzt02_(integer *, integer *, real *, 
	     integer *, real *, real *, integer *), stzt01_(integer *, 
	    integer *, real *, real *, integer *, real *, real *, integer *), 
	    stzt02_(integer *, integer *, real *, integer *, real *, real *, 
	    integer *);
    extern /* Subroutine */ int sgeqr2_(integer *, integer *, real *, integer 
	    *, real *, real *, integer *);
    extern doublereal slamch_(char *);
    extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer 
	    *, integer *), slaord_(char *, integer *, real *, integer 
	    *), slacpy_(char *, integer *, integer *, real *, integer 
	    *, real *, integer *), slaset_(char *, integer *, integer 
	    *, real *, real *, real *, integer *), slatms_(integer *, 
	    integer *, char *, integer *, char *, real *, integer *, real *, 
	    real *, integer *, integer *, char *, real *, integer *, real *, 
	    integer *);
    real result[6];
    extern /* Subroutine */ int serrtz_(char *, integer *), stzrqf_(
	    integer *, integer *, real *, integer *, real *, integer *), 
	    stzrzf_(integer *, integer *, real *, integer *, real *, real *, 
	    integer *, integer *);

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



/*  -- LAPACK test routine (version 3.1.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     January 2007 */

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

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

/*  SCHKTZ tests STZRQF and STZRZF. */

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

/*  DOTYPE  (input) LOGICAL array, dimension (NTYPES) */
/*          The matrix types to be used for testing.  Matrices of type j */
/*          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/*          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */

/*  NM      (input) INTEGER */
/*          The number of values of M contained in the vector MVAL. */

/*  MVAL    (input) INTEGER array, dimension (NM) */
/*          The values of the matrix row dimension M. */

/*  NN      (input) INTEGER */
/*          The number of values of N contained in the vector NVAL. */

/*  NVAL    (input) INTEGER array, dimension (NN) */
/*          The values of the matrix column dimension N. */

/*  THRESH  (input) REAL */
/*          The threshold value for the test ratios.  A result is */
/*          included in the output file if RESULT >= THRESH.  To have */
/*          every test ratio printed, use THRESH = 0. */

/*  TSTERR  (input) LOGICAL */
/*          Flag that indicates whether error exits are to be tested. */

/*  A       (workspace) REAL array, dimension (MMAX*NMAX) */
/*          where MMAX is the maximum value of M in MVAL and NMAX is the */
/*          maximum value of N in NVAL. */

/*  COPYA   (workspace) REAL array, dimension (MMAX*NMAX) */

/*  S       (workspace) REAL array, dimension */
/*                      (min(MMAX,NMAX)) */

/*  COPYS   (workspace) REAL array, dimension */
/*                      (min(MMAX,NMAX)) */

/*  TAU     (workspace) REAL array, dimension (MMAX) */

/*  WORK    (workspace) REAL array, dimension */
/*                      (MMAX*NMAX + 4*NMAX + MMAX) */

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

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. Local Arrays .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Scalars in Common .. */
/*     .. */
/*     .. Common blocks .. */
/*     .. */
/*     .. Data statements .. */
    /* Parameter adjustments */
    --work;
    --tau;
    --copys;
    --s;
    --copya;
    --a;
    --nval;
    --mval;
    --dotype;

    /* Function Body */
/*     .. */
/*     .. Executable Statements .. */

/*     Initialize constants and the random number seed. */

    s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
    s_copy(path + 1, "TZ", (ftnlen)2, (ftnlen)2);
    nrun = 0;
    nfail = 0;
    nerrs = 0;
    for (i__ = 1; i__ <= 4; ++i__) {
	iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
    }
    eps = slamch_("Epsilon");

/*     Test the error exits */

    if (*tsterr) {
	serrtz_(path, nout);
    }
    infoc_1.infot = 0;

    i__1 = *nm;
    for (im = 1; im <= i__1; ++im) {

/*        Do for each value of M in MVAL. */

	m = mval[im];
	lda = max(1,m);

	i__2 = *nn;
	for (in = 1; in <= i__2; ++in) {

/*           Do for each value of N in NVAL for which M .LE. N. */

	    n = nval[in];
	    mnmin = min(m,n);
/* Computing MAX */
	    i__3 = 1, i__4 = n * n + (m << 2) + n, i__3 = max(i__3,i__4), 
		    i__4 = m * n + (mnmin << 1) + (n << 2);
	    lwork = max(i__3,i__4);

	    if (m <= n) {
		for (imode = 1; imode <= 3; ++imode) {
		    if (! dotype[imode]) {
			goto L50;
		    }

/*                 Do for each type of singular value distribution. */
/*                    0:  zero matrix */
/*                    1:  one small singular value */
/*                    2:  exponential distribution */

		    mode = imode - 1;

/*                 Test STZRQF */

/*                 Generate test matrix of size m by n using */
/*                 singular value distribution indicated by `mode'. */

		    if (mode == 0) {
			slaset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda);
			i__3 = mnmin;
			for (i__ = 1; i__ <= i__3; ++i__) {
			    copys[i__] = 0.f;
/* L20: */
			}
		    } else {
			r__1 = 1.f / eps;
			slatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &
				copys[1], &imode, &r__1, &c_b15, &m, &n, 
				"No packing", &a[1], &lda, &work[1], &info);
			sgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin + 
				1], &info);
			i__3 = m - 1;
			slaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &
				lda);
			slaord_("Decreasing", &mnmin, &copys[1], &c__1);
		    }

/*                 Save A and its singular values */

		    slacpy_("All", &m, &n, &a[1], &lda, &copya[1], &lda);

/*                 Call STZRQF to reduce the upper trapezoidal matrix to */
/*                 upper triangular form. */

		    s_copy(srnamc_1.srnamt, "STZRQF", (ftnlen)32, (ftnlen)6);
		    stzrqf_(&m, &n, &a[1], &lda, &tau[1], &info);

/*                 Compute norm(svd(a) - svd(r)) */

		    result[0] = sqrt12_(&m, &m, &a[1], &lda, &copys[1], &work[
			    1], &lwork);

/*                 Compute norm( A - R*Q ) */

		    result[1] = stzt01_(&m, &n, &copya[1], &a[1], &lda, &tau[
			    1], &work[1], &lwork);

/*                 Compute norm(Q'*Q - I). */

		    result[2] = stzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1]
, &lwork);

/*                 Test STZRZF */

/*                 Generate test matrix of size m by n using */
/*                 singular value distribution indicated by `mode'. */

		    if (mode == 0) {
			slaset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda);
			i__3 = mnmin;
			for (i__ = 1; i__ <= i__3; ++i__) {
			    copys[i__] = 0.f;
/* L30: */
			}
		    } else {
			r__1 = 1.f / eps;
			slatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &
				copys[1], &imode, &r__1, &c_b15, &m, &n, 
				"No packing", &a[1], &lda, &work[1], &info);
			sgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin + 
				1], &info);
			i__3 = m - 1;
			slaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &
				lda);
			slaord_("Decreasing", &mnmin, &copys[1], &c__1);
		    }

/*                 Save A and its singular values */

		    slacpy_("All", &m, &n, &a[1], &lda, &copya[1], &lda);

/*                 Call STZRZF to reduce the upper trapezoidal matrix to */
/*                 upper triangular form. */

		    s_copy(srnamc_1.srnamt, "STZRZF", (ftnlen)32, (ftnlen)6);
		    stzrzf_(&m, &n, &a[1], &lda, &tau[1], &work[1], &lwork, &
			    info);

/*                 Compute norm(svd(a) - svd(r)) */

		    result[3] = sqrt12_(&m, &m, &a[1], &lda, &copys[1], &work[
			    1], &lwork);

/*                 Compute norm( A - R*Q ) */

		    result[4] = srzt01_(&m, &n, &copya[1], &a[1], &lda, &tau[
			    1], &work[1], &lwork);

/*                 Compute norm(Q'*Q - I). */

		    result[5] = srzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1]
, &lwork);

/*                 Print information about the tests that did not pass */
/*                 the threshold. */

		    for (k = 1; k <= 6; ++k) {
			if (result[k - 1] >= *thresh) {
			    if (nfail == 0 && nerrs == 0) {
				alahd_(nout, path);
			    }
			    io___21.ciunit = *nout;
			    s_wsfe(&io___21);
			    do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
				    ;
			    do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
				    ;
			    do_fio(&c__1, (char *)&imode, (ftnlen)sizeof(
				    integer));
			    do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
				    ;
			    do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
				    sizeof(real));
			    e_wsfe();
			    ++nfail;
			}
/* L40: */
		    }
		    nrun += 6;
L50:
		    ;
		}
	    }
/* L60: */
	}
/* L70: */
    }

/*     Print a summary of the results. */

    alasum_(path, nout, &nfail, &nrun, &nerrs);


/*     End if SCHKTZ */

    return 0;
} /* schktz_ */
예제 #4
0
/* Subroutine */ int cqrt15_(integer *scale, integer *rksel, integer *m, 
	integer *n, integer *nrhs, complex *a, integer *lda, complex *b, 
	integer *ldb, real *s, integer *rank, real *norma, real *normb, 
	integer *iseed, complex *work, integer *lwork)
{
    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
    real r__1;

    /* Local variables */
    integer j, mn;
    real eps;
    integer info;
    real temp;
    extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *, 
	    integer *, complex *, complex *, integer *, complex *, integer *, 
	    complex *, complex *, integer *), clarf_(char *, 
	    integer *, integer *, complex *, integer *, complex *, complex *, 
	    integer *, complex *);
    extern doublereal sasum_(integer *, real *, integer *);
    real dummy[1];
    extern doublereal scnrm2_(integer *, complex *, integer *);
    extern /* Subroutine */ int slabad_(real *, real *);
    extern doublereal clange_(char *, integer *, integer *, complex *, 
	    integer *, real *);
    extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *, 
	    real *, integer *, integer *, complex *, integer *, integer *);
    extern doublereal slamch_(char *);
    extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer 
	    *), claset_(char *, integer *, integer *, complex *, complex *, 
	    complex *, integer *), xerbla_(char *, integer *);
    real bignum;
    extern /* Subroutine */ int claror_(char *, char *, integer *, integer *, 
	    complex *, integer *, integer *, complex *, integer *);
    extern doublereal slarnd_(integer *, integer *);
    extern /* Subroutine */ int slaord_(char *, integer *, real *, integer *), clarnv_(integer *, integer *, integer *, complex *), 
	    slascl_(char *, integer *, integer *, real *, real *, integer *, 
	    integer *, real *, integer *, integer *);
    real smlnum;


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

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

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

/*  CQRT15 generates a matrix with full or deficient rank and of various */
/*  norms. */

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

/*  SCALE   (input) INTEGER */
/*          SCALE = 1: normally scaled matrix */
/*          SCALE = 2: matrix scaled up */
/*          SCALE = 3: matrix scaled down */

/*  RKSEL   (input) INTEGER */
/*          RKSEL = 1: full rank matrix */
/*          RKSEL = 2: rank-deficient matrix */

/*  M       (input) INTEGER */
/*          The number of rows of the matrix A. */

/*  N       (input) INTEGER */
/*          The number of columns of A. */

/*  NRHS    (input) INTEGER */
/*          The number of columns of B. */

/*  A       (output) COMPLEX array, dimension (LDA,N) */
/*          The M-by-N matrix A. */

/*  LDA     (input) INTEGER */
/*          The leading dimension of the array A. */

/*  B       (output) COMPLEX array, dimension (LDB, NRHS) */
/*          A matrix that is in the range space of matrix A. */

/*  LDB     (input) INTEGER */
/*          The leading dimension of the array B. */

/*  S       (output) REAL array, dimension MIN(M,N) */
/*          Singular values of A. */

/*  RANK    (output) INTEGER */
/*          number of nonzero singular values of A. */

/*  NORMA   (output) REAL */
/*          one-norm norm of A. */

/*  NORMB   (output) REAL */
/*          one-norm norm of B. */

/*  ISEED   (input/output) integer array, dimension (4) */
/*          seed for random number generator. */

/*  WORK    (workspace) COMPLEX array, dimension (LWORK) */

/*  LWORK   (input) INTEGER */
/*          length of work space required. */
/*          LWORK >= MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M) */

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

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

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1;
    b -= b_offset;
    --s;
    --iseed;
    --work;

    /* Function Body */
    mn = min(*m,*n);
/* Computing MAX */
    i__1 = *m + mn, i__2 = mn * *nrhs, i__1 = max(i__1,i__2), i__2 = (*n << 1)
	     + *m;
    if (*lwork < max(i__1,i__2)) {
	xerbla_("CQRT15", &c__16);
	return 0;
    }

    smlnum = slamch_("Safe minimum");
    bignum = 1.f / smlnum;
    slabad_(&smlnum, &bignum);
    eps = slamch_("Epsilon");
    smlnum = smlnum / eps / eps;
    bignum = 1.f / smlnum;

/*     Determine rank and (unscaled) singular values */

    if (*rksel == 1) {
	*rank = mn;
    } else if (*rksel == 2) {
	*rank = mn * 3 / 4;
	i__1 = mn;
	for (j = *rank + 1; j <= i__1; ++j) {
	    s[j] = 0.f;
/* L10: */
	}
    } else {
	xerbla_("CQRT15", &c__2);
    }

    if (*rank > 0) {

/*        Nontrivial case */

	s[1] = 1.f;
	i__1 = *rank;
	for (j = 2; j <= i__1; ++j) {
L20:
	    temp = slarnd_(&c__1, &iseed[1]);
	    if (temp > .1f) {
		s[j] = dabs(temp);
	    } else {
		goto L20;
	    }
/* L30: */
	}
	slaord_("Decreasing", rank, &s[1], &c__1);

/*        Generate 'rank' columns of a random orthogonal matrix in A */

	clarnv_(&c__2, &iseed[1], m, &work[1]);
	r__1 = 1.f / scnrm2_(m, &work[1], &c__1);
	csscal_(m, &r__1, &work[1], &c__1);
	claset_("Full", m, rank, &c_b1, &c_b2, &a[a_offset], lda);
	clarf_("Left", m, rank, &work[1], &c__1, &c_b22, &a[a_offset], lda, &
		work[*m + 1]);

/*        workspace used: m+mn */

/*        Generate consistent rhs in the range space of A */

	i__1 = *rank * *nrhs;
	clarnv_(&c__2, &iseed[1], &i__1, &work[1]);
	cgemm_("No transpose", "No transpose", m, nrhs, rank, &c_b2, &a[
		a_offset], lda, &work[1], rank, &c_b1, &b[b_offset], ldb);

/*        work space used: <= mn *nrhs */

/*        generate (unscaled) matrix A */

	i__1 = *rank;
	for (j = 1; j <= i__1; ++j) {
	    csscal_(m, &s[j], &a[j * a_dim1 + 1], &c__1);
/* L40: */
	}
	if (*rank < *n) {
	    i__1 = *n - *rank;
	    claset_("Full", m, &i__1, &c_b1, &c_b1, &a[(*rank + 1) * a_dim1 + 
		    1], lda);
	}
	claror_("Right", "No initialization", m, n, &a[a_offset], lda, &iseed[
		1], &work[1], &info);

    } else {

/*        work space used 2*n+m */

/*        Generate null matrix and rhs */

	i__1 = mn;
	for (j = 1; j <= i__1; ++j) {
	    s[j] = 0.f;
/* L50: */
	}
	claset_("Full", m, n, &c_b1, &c_b1, &a[a_offset], lda);
	claset_("Full", m, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);

    }

/*     Scale the matrix */

    if (*scale != 1) {
	*norma = clange_("Max", m, n, &a[a_offset], lda, dummy);
	if (*norma != 0.f) {
	    if (*scale == 2) {

/*              matrix scaled up */

		clascl_("General", &c__0, &c__0, norma, &bignum, m, n, &a[
			a_offset], lda, &info);
		slascl_("General", &c__0, &c__0, norma, &bignum, &mn, &c__1, &
			s[1], &mn, &info);
		clascl_("General", &c__0, &c__0, norma, &bignum, m, nrhs, &b[
			b_offset], ldb, &info);
	    } else if (*scale == 3) {

/*              matrix scaled down */

		clascl_("General", &c__0, &c__0, norma, &smlnum, m, n, &a[
			a_offset], lda, &info);
		slascl_("General", &c__0, &c__0, norma, &smlnum, &mn, &c__1, &
			s[1], &mn, &info);
		clascl_("General", &c__0, &c__0, norma, &smlnum, m, nrhs, &b[
			b_offset], ldb, &info);
	    } else {
		xerbla_("CQRT15", &c__1);
		return 0;
	    }
	}
    }

    *norma = sasum_(&mn, &s[1], &c__1);
    *normb = clange_("One-norm", m, nrhs, &b[b_offset], ldb, dummy)
	    ;

    return 0;

/*     End of CQRT15 */

} /* cqrt15_ */