Ejemplo n.º 1
0
/* Subroutine */ int dchkbb_(integer *nsizes, integer *mval, integer *nval, 
	integer *nwdths, integer *kk, integer *ntypes, logical *dotype, 
	integer *nrhs, integer *iseed, doublereal *thresh, integer *nounit, 
	doublereal *a, integer *lda, doublereal *ab, integer *ldab, 
	doublereal *bd, doublereal *be, doublereal *q, integer *ldq, 
	doublereal *p, integer *ldp, doublereal *c__, integer *ldc, 
	doublereal *cc, doublereal *work, integer *lwork, doublereal *result, 
	integer *info)
{
    /* Initialized data */

    static integer ktype[15] = { 1,2,4,4,4,4,4,6,6,6,6,6,9,9,9 };
    static integer kmagn[15] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3 };
    static integer kmode[15] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0 };

    /* Format strings */
    static char fmt_9999[] = "(\002 DCHKBB: \002,a,\002 returned INFO=\002,i"
	    "5,\002.\002,/9x,\002M=\002,i5,\002 N=\002,i5,\002 K=\002,i5,\002"
	    ", JTYPE=\002,i5,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
    static char fmt_9998[] = "(\002 M =\002,i4,\002 N=\002,i4,\002, K=\002,i"
	    "3,\002, seed=\002,4(i4,\002,\002),\002 type \002,i2,\002, test"
	    "(\002,i2,\002)=\002,g10.3)";

    /* System generated locals */
    integer a_dim1, a_offset, ab_dim1, ab_offset, c_dim1, c_offset, cc_dim1, 
	    cc_offset, p_dim1, p_offset, q_dim1, q_offset, i__1, i__2, i__3, 
	    i__4, i__5, i__6, i__7, i__8, i__9;

    /* Builtin functions */
    double sqrt(doublereal);
    integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);

    /* Local variables */
    integer i__, j, k, m, n, kl, jr, ku;
    doublereal ulp, cond;
    integer jcol, kmax, mmax, nmax;
    doublereal unfl, ovfl;
    extern /* Subroutine */ int dbdt01_(integer *, integer *, integer *, 
	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
	    doublereal *, doublereal *, integer *, doublereal *, doublereal *)
	    , dbdt02_(integer *, integer *, doublereal *, integer *, 
	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
	    doublereal *);
    logical badmm, badnn;
    integer imode, iinfo;
    extern /* Subroutine */ int dort01_(char *, integer *, integer *, 
	    doublereal *, integer *, doublereal *, integer *, doublereal *);
    doublereal anorm;
    integer mnmin, mnmax, nmats, jsize, nerrs, itype, jtype, ntest;
    extern /* Subroutine */ int dlahd2_(integer *, char *);
    logical badnnb;
    extern /* Subroutine */ int dgbbrd_(char *, integer *, integer *, integer 
	    *, integer *, integer *, doublereal *, integer *, doublereal *, 
	    doublereal *, doublereal *, integer *, doublereal *, integer *, 
	    doublereal *, integer *, doublereal *, integer *);
    extern doublereal dlamch_(char *);
    integer idumma[1];
    extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, 
	    doublereal *, integer *, doublereal *, integer *);
    integer ioldsd[4];
    extern /* Subroutine */ int dlaset_(char *, integer *, integer *, 
	    doublereal *, doublereal *, doublereal *, integer *), 
	    xerbla_(char *, integer *), dlatmr_(integer *, integer *, 
	    char *, integer *, char *, doublereal *, integer *, doublereal *, 
	    doublereal *, char *, char *, doublereal *, integer *, doublereal 
	    *, doublereal *, integer *, doublereal *, char *, integer *, 
	    integer *, integer *, doublereal *, doublereal *, char *, 
	    doublereal *, integer *, integer *, integer *), dlatms_(integer *, integer *, 
	    char *, integer *, char *, doublereal *, integer *, doublereal *, 
	    doublereal *, integer *, integer *, char *, doublereal *, integer 
	    *, doublereal *, integer *), dlasum_(char 
	    *, integer *, integer *, integer *);
    doublereal amninv;
    integer jwidth;
    doublereal rtunfl, rtovfl, ulpinv;
    integer mtypes, ntestt;

    /* Fortran I/O blocks */
    static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };



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

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

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

/*  DCHKBB tests the reduction of a general real rectangular band */
/*  matrix to bidiagonal form. */

/*  DGBBRD factors a general band matrix A as  Q B P* , where * means */
/*  transpose, B is upper bidiagonal, and Q and P are orthogonal; */
/*  DGBBRD can also overwrite a given matrix C with Q* C . */

/*  For each pair of matrix dimensions (M,N) and each selected matrix */
/*  type, an M by N matrix A and an M by NRHS matrix C are generated. */
/*  The problem dimensions are as follows */
/*     A:          M x N */
/*     Q:          M x M */
/*     P:          N x N */
/*     B:          min(M,N) x min(M,N) */
/*     C:          M x NRHS */

/*  For each generated matrix, 4 tests are performed: */

/*  (1)   | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P' */

/*  (2)   | I - Q' Q | / ( M ulp ) */

/*  (3)   | I - PT PT' | / ( N ulp ) */

/*  (4)   | Y - Q' C | / ( |Y| max(M,NRHS) ulp ), where Y = Q' C. */

/*  The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
/*  if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/*  Currently, the list of possible types is: */

/*  The possible matrix types are */

/*  (1)  The zero matrix. */
/*  (2)  The identity matrix. */

/*  (3)  A diagonal matrix with evenly spaced entries */
/*       1, ..., ULP  and random signs. */
/*       (ULP = (first number larger than 1) - 1 ) */
/*  (4)  A diagonal matrix with geometrically spaced entries */
/*       1, ..., ULP  and random signs. */
/*  (5)  A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
/*       and random signs. */

/*  (6)  Same as (3), but multiplied by SQRT( overflow threshold ) */
/*  (7)  Same as (3), but multiplied by SQRT( underflow threshold ) */

/*  (8)  A matrix of the form  U D V, where U and V are orthogonal and */
/*       D has evenly spaced entries 1, ..., ULP with random signs */
/*       on the diagonal. */

/*  (9)  A matrix of the form  U D V, where U and V are orthogonal and */
/*       D has geometrically spaced entries 1, ..., ULP with random */
/*       signs on the diagonal. */

/*  (10) A matrix of the form  U D V, where U and V are orthogonal and */
/*       D has "clustered" entries 1, ULP,..., ULP with random */
/*       signs on the diagonal. */

/*  (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
/*  (12) Same as (8), but multiplied by SQRT( underflow threshold ) */

/*  (13) Rectangular matrix with random entries chosen from (-1,1). */
/*  (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
/*  (15) Same as (13), but multiplied by SQRT( underflow threshold ) */

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

/*  NSIZES  (input) INTEGER */
/*          The number of values of M and N contained in the vectors */
/*          MVAL and NVAL.  The matrix sizes are used in pairs (M,N). */
/*          If NSIZES is zero, DCHKBB does nothing.  NSIZES must be at */
/*          least zero. */

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

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

/*  NWDTHS  (input) INTEGER */
/*          The number of bandwidths to use.  If it is zero, */
/*          DCHKBB does nothing.  It must be at least zero. */

/*  KK      (input) INTEGER array, dimension (NWDTHS) */
/*          An array containing the bandwidths to be used for the band */
/*          matrices.  The values must be at least zero. */

/*  NTYPES  (input) INTEGER */
/*          The number of elements in DOTYPE.   If it is zero, DCHKBB */
/*          does nothing.  It must be at least zero.  If it is MAXTYP+1 */
/*          and NSIZES is 1, then an additional type, MAXTYP+1 is */
/*          defined, which is to use whatever matrix is in A.  This */
/*          is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/*          DOTYPE(MAXTYP+1) is .TRUE. . */

/*  DOTYPE  (input) LOGICAL array, dimension (NTYPES) */
/*          If DOTYPE(j) is .TRUE., then for each size in NN a */
/*          matrix of that size and of type j will be generated. */
/*          If NTYPES is smaller than the maximum number of types */
/*          defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/*          MAXTYP will not be generated.  If NTYPES is larger */
/*          than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/*          will be ignored. */

/*  NRHS    (input) INTEGER */
/*          The number of columns in the "right-hand side" matrix C. */
/*          If NRHS = 0, then the operations on the right-hand side will */
/*          not be tested. NRHS must be at least 0. */

/*  ISEED   (input/output) INTEGER array, dimension (4) */
/*          On entry ISEED specifies the seed of the random number */
/*          generator. The array elements should be between 0 and 4095; */
/*          if not they will be reduced mod 4096.  Also, ISEED(4) must */
/*          be odd.  The random number generator uses a linear */
/*          congruential sequence limited to small integers, and so */
/*          should produce machine independent random numbers. The */
/*          values of ISEED are changed on exit, and can be used in the */
/*          next call to DCHKBB to continue the same random number */
/*          sequence. */

/*  THRESH  (input) DOUBLE PRECISION */
/*          A test will count as "failed" if the "error", computed as */
/*          described above, exceeds THRESH.  Note that the error */
/*          is scaled to be O(1), so THRESH should be a reasonably */
/*          small multiple of 1, e.g., 10 or 100.  In particular, */
/*          it should not depend on the precision (single vs. double) */
/*          or the size of the matrix.  It must be at least zero. */

/*  NOUNIT  (input) INTEGER */
/*          The FORTRAN unit number for printing out error messages */
/*          (e.g., if a routine returns IINFO not equal to 0.) */

/*  A       (input/workspace) DOUBLE PRECISION array, dimension */
/*                            (LDA, max(NN)) */
/*          Used to hold the matrix A. */

/*  LDA     (input) INTEGER */
/*          The leading dimension of A.  It must be at least 1 */
/*          and at least max( NN ). */

/*  AB      (workspace) DOUBLE PRECISION array, dimension (LDAB, max(NN)) */
/*          Used to hold A in band storage format. */

/*  LDAB    (input) INTEGER */
/*          The leading dimension of AB.  It must be at least 2 (not 1!) */
/*          and at least max( KK )+1. */

/*  BD      (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
/*          Used to hold the diagonal of the bidiagonal matrix computed */
/*          by DGBBRD. */

/*  BE      (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
/*          Used to hold the off-diagonal of the bidiagonal matrix */
/*          computed by DGBBRD. */

/*  Q       (workspace) DOUBLE PRECISION array, dimension (LDQ, max(NN)) */
/*          Used to hold the orthogonal matrix Q computed by DGBBRD. */

/*  LDQ     (input) INTEGER */
/*          The leading dimension of Q.  It must be at least 1 */
/*          and at least max( NN ). */

/*  P       (workspace) DOUBLE PRECISION array, dimension (LDP, max(NN)) */
/*          Used to hold the orthogonal matrix P computed by DGBBRD. */

/*  LDP     (input) INTEGER */
/*          The leading dimension of P.  It must be at least 1 */
/*          and at least max( NN ). */

/*  C       (workspace) DOUBLE PRECISION array, dimension (LDC, max(NN)) */
/*          Used to hold the matrix C updated by DGBBRD. */

/*  LDC     (input) INTEGER */
/*          The leading dimension of U.  It must be at least 1 */
/*          and at least max( NN ). */

/*  CC      (workspace) DOUBLE PRECISION array, dimension (LDC, max(NN)) */
/*          Used to hold a copy of the matrix C. */

/*  WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK) */

/*  LWORK   (input) INTEGER */
/*          The number of entries in WORK.  This must be at least */
/*          max( LDA+1, max(NN)+1 )*max(NN). */

/*  RESULT  (output) DOUBLE PRECISION array, dimension (4) */
/*          The values computed by the tests described above. */
/*          The values are currently limited to 1/ulp, to avoid */
/*          overflow. */

/*  INFO    (output) INTEGER */
/*          If 0, then everything ran OK. */

/* ----------------------------------------------------------------------- */

/*       Some Local Variables and Parameters: */
/*       ---- ----- --------- --- ---------- */
/*       ZERO, ONE       Real 0 and 1. */
/*       MAXTYP          The number of types defined. */
/*       NTEST           The number of tests performed, or which can */
/*                       be performed so far, for the current matrix. */
/*       NTESTT          The total number of tests performed so far. */
/*       NMAX            Largest value in NN. */
/*       NMATS           The number of matrices generated so far. */
/*       NERRS           The number of tests which have exceeded THRESH */
/*                       so far. */
/*       COND, IMODE     Values to be passed to the matrix generators. */
/*       ANORM           Norm of A; passed to matrix generators. */

/*       OVFL, UNFL      Overflow and underflow thresholds. */
/*       ULP, ULPINV     Finest relative precision and its inverse. */
/*       RTOVFL, RTUNFL  Square roots of the previous 2 values. */
/*               The following four arrays decode JTYPE: */
/*       KTYPE(j)        The general type (1-10) for type "j". */
/*       KMODE(j)        The MODE value to be passed to the matrix */
/*                       generator for type "j". */
/*       KMAGN(j)        The order of magnitude ( O(1), */
/*                       O(overflow^(1/2) ), O(underflow^(1/2) ) */

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. Local Arrays .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Data statements .. */
    /* Parameter adjustments */
    --mval;
    --nval;
    --kk;
    --dotype;
    --iseed;
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    ab_dim1 = *ldab;
    ab_offset = 1 + ab_dim1;
    ab -= ab_offset;
    --bd;
    --be;
    q_dim1 = *ldq;
    q_offset = 1 + q_dim1;
    q -= q_offset;
    p_dim1 = *ldp;
    p_offset = 1 + p_dim1;
    p -= p_offset;
    cc_dim1 = *ldc;
    cc_offset = 1 + cc_dim1;
    cc -= cc_offset;
    c_dim1 = *ldc;
    c_offset = 1 + c_dim1;
    c__ -= c_offset;
    --work;
    --result;

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

/*     Check for errors */

    ntestt = 0;
    *info = 0;

/*     Important constants */

    badmm = FALSE_;
    badnn = FALSE_;
    mmax = 1;
    nmax = 1;
    mnmax = 1;
    i__1 = *nsizes;
    for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
	i__2 = mmax, i__3 = mval[j];
	mmax = max(i__2,i__3);
	if (mval[j] < 0) {
	    badmm = TRUE_;
	}
/* Computing MAX */
	i__2 = nmax, i__3 = nval[j];
	nmax = max(i__2,i__3);
	if (nval[j] < 0) {
	    badnn = TRUE_;
	}
/* Computing MAX */
/* Computing MIN */
	i__4 = mval[j], i__5 = nval[j];
	i__2 = mnmax, i__3 = min(i__4,i__5);
	mnmax = max(i__2,i__3);
/* L10: */
    }

    badnnb = FALSE_;
    kmax = 0;
    i__1 = *nwdths;
    for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
	i__2 = kmax, i__3 = kk[j];
	kmax = max(i__2,i__3);
	if (kk[j] < 0) {
	    badnnb = TRUE_;
	}
/* L20: */
    }

/*     Check for errors */

    if (*nsizes < 0) {
	*info = -1;
    } else if (badmm) {
	*info = -2;
    } else if (badnn) {
	*info = -3;
    } else if (*nwdths < 0) {
	*info = -4;
    } else if (badnnb) {
	*info = -5;
    } else if (*ntypes < 0) {
	*info = -6;
    } else if (*nrhs < 0) {
	*info = -8;
    } else if (*lda < nmax) {
	*info = -13;
    } else if (*ldab < (kmax << 1) + 1) {
	*info = -15;
    } else if (*ldq < nmax) {
	*info = -19;
    } else if (*ldp < nmax) {
	*info = -21;
    } else if (*ldc < nmax) {
	*info = -23;
    } else if ((max(*lda,nmax) + 1) * nmax > *lwork) {
	*info = -26;
    }

    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DCHKBB", &i__1);
	return 0;
    }

/*     Quick return if possible */

    if (*nsizes == 0 || *ntypes == 0 || *nwdths == 0) {
	return 0;
    }

/*     More Important constants */

    unfl = dlamch_("Safe minimum");
    ovfl = 1. / unfl;
    ulp = dlamch_("Epsilon") * dlamch_("Base");
    ulpinv = 1. / ulp;
    rtunfl = sqrt(unfl);
    rtovfl = sqrt(ovfl);

/*     Loop over sizes, widths, types */

    nerrs = 0;
    nmats = 0;

    i__1 = *nsizes;
    for (jsize = 1; jsize <= i__1; ++jsize) {
	m = mval[jsize];
	n = nval[jsize];
	mnmin = min(m,n);
/* Computing MAX */
	i__2 = max(1,m);
	amninv = 1. / (doublereal) max(i__2,n);

	i__2 = *nwdths;
	for (jwidth = 1; jwidth <= i__2; ++jwidth) {
	    k = kk[jwidth];
	    if (k >= m && k >= n) {
		goto L150;
	    }
/* Computing MAX */
/* Computing MIN */
	    i__5 = m - 1;
	    i__3 = 0, i__4 = min(i__5,k);
	    kl = max(i__3,i__4);
/* Computing MAX */
/* Computing MIN */
	    i__5 = n - 1;
	    i__3 = 0, i__4 = min(i__5,k);
	    ku = max(i__3,i__4);

	    if (*nsizes != 1) {
		mtypes = min(15,*ntypes);
	    } else {
		mtypes = min(16,*ntypes);
	    }

	    i__3 = mtypes;
	    for (jtype = 1; jtype <= i__3; ++jtype) {
		if (! dotype[jtype]) {
		    goto L140;
		}
		++nmats;
		ntest = 0;

		for (j = 1; j <= 4; ++j) {
		    ioldsd[j - 1] = iseed[j];
/* L30: */
		}

/*              Compute "A". */

/*              Control parameters: */

/*                  KMAGN  KMODE        KTYPE */
/*              =1  O(1)   clustered 1  zero */
/*              =2  large  clustered 2  identity */
/*              =3  small  exponential  (none) */
/*              =4         arithmetic   diagonal, (w/ singular values) */
/*              =5         random log   (none) */
/*              =6         random       nonhermitian, w/ singular values */
/*              =7                      (none) */
/*              =8                      (none) */
/*              =9                      random nonhermitian */

		if (mtypes > 15) {
		    goto L90;
		}

		itype = ktype[jtype - 1];
		imode = kmode[jtype - 1];

/*              Compute norm */

		switch (kmagn[jtype - 1]) {
		    case 1:  goto L40;
		    case 2:  goto L50;
		    case 3:  goto L60;
		}

L40:
		anorm = 1.;
		goto L70;

L50:
		anorm = rtovfl * ulp * amninv;
		goto L70;

L60:
		anorm = rtunfl * max(m,n) * ulpinv;
		goto L70;

L70:

		dlaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
		dlaset_("Full", ldab, &n, &c_b18, &c_b18, &ab[ab_offset], 
			ldab);
		iinfo = 0;
		cond = ulpinv;

/*              Special Matrices -- Identity & Jordan block */

/*                 Zero */

		if (itype == 1) {
		    iinfo = 0;

		} else if (itype == 2) {

/*                 Identity */

		    i__4 = n;
		    for (jcol = 1; jcol <= i__4; ++jcol) {
			a[jcol + jcol * a_dim1] = anorm;
/* L80: */
		    }

		} else if (itype == 4) {

/*                 Diagonal Matrix, singular values specified */

		    dlatms_(&m, &n, "S", &iseed[1], "N", &work[1], &imode, &
			    cond, &anorm, &c__0, &c__0, "N", &a[a_offset], 
			    lda, &work[m + 1], &iinfo);

		} else if (itype == 6) {

/*                 Nonhermitian, singular values specified */

		    dlatms_(&m, &n, "S", &iseed[1], "N", &work[1], &imode, &
			    cond, &anorm, &kl, &ku, "N", &a[a_offset], lda, &
			    work[m + 1], &iinfo);

		} else if (itype == 9) {

/*                 Nonhermitian, random entries */

		    dlatmr_(&m, &n, "S", &iseed[1], "N", &work[1], &c__6, &
			    c_b35, &c_b35, "T", "N", &work[n + 1], &c__1, &
			    c_b35, &work[(n << 1) + 1], &c__1, &c_b35, "N", 
			    idumma, &kl, &ku, &c_b18, &anorm, "N", &a[
			    a_offset], lda, idumma, &iinfo);

		} else {

		    iinfo = 1;
		}

/*              Generate Right-Hand Side */

		dlatmr_(&m, nrhs, "S", &iseed[1], "N", &work[1], &c__6, &
			c_b35, &c_b35, "T", "N", &work[m + 1], &c__1, &c_b35, 
			&work[(m << 1) + 1], &c__1, &c_b35, "N", idumma, &m, 
			nrhs, &c_b18, &c_b35, "NO", &c__[c_offset], ldc, 
			idumma, &iinfo);

		if (iinfo != 0) {
		    io___41.ciunit = *nounit;
		    s_wsfe(&io___41);
		    do_fio(&c__1, "Generator", (ftnlen)9);
		    do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
		    do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
			    ;
		    e_wsfe();
		    *info = abs(iinfo);
		    return 0;
		}

L90:

/*              Copy A to band storage. */

		i__4 = n;
		for (j = 1; j <= i__4; ++j) {
/* Computing MAX */
		    i__5 = 1, i__6 = j - ku;
/* Computing MIN */
		    i__8 = m, i__9 = j + kl;
		    i__7 = min(i__8,i__9);
		    for (i__ = max(i__5,i__6); i__ <= i__7; ++i__) {
			ab[ku + 1 + i__ - j + j * ab_dim1] = a[i__ + j * 
				a_dim1];
/* L100: */
		    }
/* L110: */
		}

/*              Copy C */

		dlacpy_("Full", &m, nrhs, &c__[c_offset], ldc, &cc[cc_offset], 
			 ldc);

/*              Call DGBBRD to compute B, Q and P, and to update C. */

		dgbbrd_("B", &m, &n, nrhs, &kl, &ku, &ab[ab_offset], ldab, &
			bd[1], &be[1], &q[q_offset], ldq, &p[p_offset], ldp, &
			cc[cc_offset], ldc, &work[1], &iinfo);

		if (iinfo != 0) {
		    io___43.ciunit = *nounit;
		    s_wsfe(&io___43);
		    do_fio(&c__1, "DGBBRD", (ftnlen)6);
		    do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
		    do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
			    ;
		    e_wsfe();
		    *info = abs(iinfo);
		    if (iinfo < 0) {
			return 0;
		    } else {
			result[1] = ulpinv;
			goto L120;
		    }
		}

/*              Test 1:  Check the decomposition A := Q * B * P' */
/*                   2:  Check the orthogonality of Q */
/*                   3:  Check the orthogonality of P */
/*                   4:  Check the computation of Q' * C */

		dbdt01_(&m, &n, &c_n1, &a[a_offset], lda, &q[q_offset], ldq, &
			bd[1], &be[1], &p[p_offset], ldp, &work[1], &result[1]
);
		dort01_("Columns", &m, &m, &q[q_offset], ldq, &work[1], lwork, 
			 &result[2]);
		dort01_("Rows", &n, &n, &p[p_offset], ldp, &work[1], lwork, &
			result[3]);
		dbdt02_(&m, nrhs, &c__[c_offset], ldc, &cc[cc_offset], ldc, &
			q[q_offset], ldq, &work[1], &result[4]);

/*              End of Loop -- Check for RESULT(j) > THRESH */

		ntest = 4;
L120:
		ntestt += ntest;

/*              Print out tests which fail. */

		i__4 = ntest;
		for (jr = 1; jr <= i__4; ++jr) {
		    if (result[jr] >= *thresh) {
			if (nerrs == 0) {
			    dlahd2_(nounit, "DBB");
			}
			++nerrs;
			io___45.ciunit = *nounit;
			s_wsfe(&io___45);
			do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
			do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
			do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
			do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
				integer));
			do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
				;
			do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
			do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
				doublereal));
			e_wsfe();
		    }
/* L130: */
		}

L140:
		;
	    }
L150:
	    ;
	}
/* L160: */
    }

/*     Summary */

    dlasum_("DBB", nounit, &nerrs, &ntestt);
    return 0;


/*     End of DCHKBB */

} /* dchkbb_ */
Ejemplo n.º 2
0
/* Subroutine */ int dchkbd_(integer *nsizes, integer *mval, integer *nval, 
	integer *ntypes, logical *dotype, integer *nrhs, integer *iseed, 
	doublereal *thresh, doublereal *a, integer *lda, doublereal *bd, 
	doublereal *be, doublereal *s1, doublereal *s2, doublereal *x, 
	integer *ldx, doublereal *y, doublereal *z__, doublereal *q, integer *
	ldq, doublereal *pt, integer *ldpt, doublereal *u, doublereal *vt, 
	doublereal *work, integer *lwork, integer *iwork, integer *nout, 
	integer *info)
{
    /* Initialized data */

    static integer ktype[16] = { 1,2,4,4,4,4,4,6,6,6,6,6,9,9,9,10 };
    static integer kmagn[16] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3,0 };
    static integer kmode[16] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0,0 };

    /* Format strings */
    static char fmt_9998[] = "(\002 DCHKBD: \002,a,\002 returned INFO=\002,i"
	    "6,\002.\002,/9x,\002M=\002,i6,\002, N=\002,i6,\002, JTYPE=\002,i"
	    "6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
    static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, type "
	    "\002,i2,\002, seed=\002,4(i4,\002,\002),\002 test(\002,i2,\002)"
	    "=\002,g11.4)";

    /* System generated locals */
    integer a_dim1, a_offset, pt_dim1, pt_offset, q_dim1, q_offset, u_dim1, 
	    u_offset, vt_dim1, vt_offset, x_dim1, x_offset, y_dim1, y_offset, 
	    z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
    doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7;

    /* Builtin functions */
    /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
    double log(doublereal), sqrt(doublereal), exp(doublereal);
    integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);

    /* Local variables */
    integer i__, j, m, n, mq;
    doublereal dum[1], ulp, cond;
    integer jcol;
    char path[3];
    integer idum[1], mmax, nmax;
    doublereal unfl, ovfl;
    char uplo[1];
    doublereal temp1, temp2;
    extern /* Subroutine */ int dbdt01_(integer *, integer *, integer *, 
	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
	    doublereal *, doublereal *, integer *, doublereal *, doublereal *)
	    , dbdt02_(integer *, integer *, doublereal *, integer *, 
	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
	    doublereal *);
    logical badmm;
    extern /* Subroutine */ int dbdt03_(char *, integer *, integer *, 
	    doublereal *, doublereal *, doublereal *, integer *, doublereal *, 
	     doublereal *, integer *, doublereal *, doublereal *);
    logical badnn;
    integer nfail;
    extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, 
	    integer *, doublereal *, doublereal *, integer *, doublereal *, 
	    integer *, doublereal *, doublereal *, integer *);
    integer imode;
    doublereal dumma[1];
    integer iinfo;
    extern /* Subroutine */ int dort01_(char *, integer *, integer *, 
	    doublereal *, integer *, doublereal *, integer *, doublereal *);
    doublereal anorm;
    integer mnmin;
    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
	    doublereal *, integer *);
    integer mnmax, jsize, itype, jtype, ntest;
    extern /* Subroutine */ int dlahd2_(integer *, char *);
    integer log2ui;
    extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
    logical bidiag;
    extern /* Subroutine */ int dbdsdc_(char *, char *, integer *, doublereal 
	    *, doublereal *, doublereal *, integer *, doublereal *, integer *, 
	     doublereal *, integer *, doublereal *, integer *, integer *), dgebrd_(integer *, integer *, doublereal *, 
	    integer *, doublereal *, doublereal *, doublereal *, doublereal *, 
	     doublereal *, integer *, integer *);
    extern doublereal dlamch_(char *), dlarnd_(integer *, integer *);
    extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, 
	    doublereal *, integer *, doublereal *, integer *), 
	    dlaset_(char *, integer *, integer *, doublereal *, doublereal *, 
	    doublereal *, integer *);
    integer ioldsd[4];
    extern /* Subroutine */ int dbdsqr_(char *, integer *, integer *, integer 
	    *, integer *, doublereal *, doublereal *, doublereal *, integer *, 
	     doublereal *, integer *, doublereal *, integer *, doublereal *, 
	    integer *), dorgbr_(char *, integer *, integer *, integer 
	    *, doublereal *, integer *, doublereal *, doublereal *, integer *, 
	     integer *), xerbla_(char *, integer *), alasum_(
	    char *, integer *, integer *, integer *, integer *), 
	    dlatmr_(integer *, integer *, char *, integer *, char *, 
	    doublereal *, integer *, doublereal *, doublereal *, char *, char 
	    *, doublereal *, integer *, doublereal *, doublereal *, integer *, 
	     doublereal *, char *, integer *, integer *, integer *, 
	    doublereal *, doublereal *, char *, doublereal *, integer *, 
	    integer *, integer *), dlatms_(integer *, integer *, char *, integer *, char *, 
	    doublereal *, integer *, doublereal *, doublereal *, integer *, 
	    integer *, char *, doublereal *, integer *, doublereal *, integer 
	    *);
    doublereal amninv;
    integer minwrk;
    doublereal rtunfl, rtovfl, ulpinv, result[19];
    integer mtypes;

    /* Fortran I/O blocks */
    static cilist io___39 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___40 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___43 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___53 = { 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 */
/*  ======= */

/*  DCHKBD checks the singular value decomposition (SVD) routines. */

/*  DGEBRD reduces a real general m by n matrix A to upper or lower */
/*  bidiagonal form B by an orthogonal transformation:  Q' * A * P = B */
/*  (or A = Q * B * P').  The matrix B is upper bidiagonal if m >= n */
/*  and lower bidiagonal if m < n. */

/*  DORGBR generates the orthogonal matrices Q and P' from DGEBRD. */
/*  Note that Q and P are not necessarily square. */

/*  DBDSQR computes the singular value decomposition of the bidiagonal */
/*  matrix B as B = U S V'.  It is called three times to compute */
/*     1)  B = U S1 V', where S1 is the diagonal matrix of singular */
/*         values and the columns of the matrices U and V are the left */
/*         and right singular vectors, respectively, of B. */
/*     2)  Same as 1), but the singular values are stored in S2 and the */
/*         singular vectors are not computed. */
/*     3)  A = (UQ) S (P'V'), the SVD of the original matrix A. */
/*  In addition, DBDSQR has an option to apply the left orthogonal matrix */
/*  U to a matrix X, useful in least squares applications. */

/*  DBDSDC computes the singular value decomposition of the bidiagonal */
/*  matrix B as B = U S V' using divide-and-conquer. It is called twice */
/*  to compute */
/*     1) B = U S1 V', where S1 is the diagonal matrix of singular */
/*         values and the columns of the matrices U and V are the left */
/*         and right singular vectors, respectively, of B. */
/*     2) Same as 1), but the singular values are stored in S2 and the */
/*         singular vectors are not computed. */

/*  For each pair of matrix dimensions (M,N) and each selected matrix */
/*  type, an M by N matrix A and an M by NRHS matrix X are generated. */
/*  The problem dimensions are as follows */
/*     A:          M x N */
/*     Q:          M x min(M,N) (but M x M if NRHS > 0) */
/*     P:          min(M,N) x N */
/*     B:          min(M,N) x min(M,N) */
/*     U, V:       min(M,N) x min(M,N) */
/*     S1, S2      diagonal, order min(M,N) */
/*     X:          M x NRHS */

/*  For each generated matrix, 14 tests are performed: */

/*  Test DGEBRD and DORGBR */

/*  (1)   | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P' */

/*  (2)   | I - Q' Q | / ( M ulp ) */

/*  (3)   | I - PT PT' | / ( N ulp ) */

/*  Test DBDSQR on bidiagonal matrix B */

/*  (4)   | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V' */

/*  (5)   | Y - U Z | / ( |Y| max(min(M,N),k) ulp ), where Y = Q' X */
/*                                                   and   Z = U' Y. */
/*  (6)   | I - U' U | / ( min(M,N) ulp ) */

/*  (7)   | I - VT VT' | / ( min(M,N) ulp ) */

/*  (8)   S1 contains min(M,N) nonnegative values in decreasing order. */
/*        (Return 0 if true, 1/ULP if false.) */

/*  (9)   | S1 - S2 | / ( |S1| ulp ), where S2 is computed without */
/*                                    computing U and V. */

/*  (10)  0 if the true singular values of B are within THRESH of */
/*        those in S1.  2*THRESH if they are not.  (Tested using */
/*        DSVDCH) */

/*  Test DBDSQR on matrix A */

/*  (11)  | A - (QU) S (VT PT) | / ( |A| max(M,N) ulp ) */

/*  (12)  | X - (QU) Z | / ( |X| max(M,k) ulp ) */

/*  (13)  | I - (QU)'(QU) | / ( M ulp ) */

/*  (14)  | I - (VT PT) (PT'VT') | / ( N ulp ) */

/*  Test DBDSDC on bidiagonal matrix B */

/*  (15)  | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V' */

/*  (16)  | I - U' U | / ( min(M,N) ulp ) */

/*  (17)  | I - VT VT' | / ( min(M,N) ulp ) */

/*  (18)  S1 contains min(M,N) nonnegative values in decreasing order. */
/*        (Return 0 if true, 1/ULP if false.) */

/*  (19)  | S1 - S2 | / ( |S1| ulp ), where S2 is computed without */
/*                                    computing U and V. */
/*  The possible matrix types are */

/*  (1)  The zero matrix. */
/*  (2)  The identity matrix. */

/*  (3)  A diagonal matrix with evenly spaced entries */
/*       1, ..., ULP  and random signs. */
/*       (ULP = (first number larger than 1) - 1 ) */
/*  (4)  A diagonal matrix with geometrically spaced entries */
/*       1, ..., ULP  and random signs. */
/*  (5)  A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
/*       and random signs. */

/*  (6)  Same as (3), but multiplied by SQRT( overflow threshold ) */
/*  (7)  Same as (3), but multiplied by SQRT( underflow threshold ) */

/*  (8)  A matrix of the form  U D V, where U and V are orthogonal and */
/*       D has evenly spaced entries 1, ..., ULP with random signs */
/*       on the diagonal. */

/*  (9)  A matrix of the form  U D V, where U and V are orthogonal and */
/*       D has geometrically spaced entries 1, ..., ULP with random */
/*       signs on the diagonal. */

/*  (10) A matrix of the form  U D V, where U and V are orthogonal and */
/*       D has "clustered" entries 1, ULP,..., ULP with random */
/*       signs on the diagonal. */

/*  (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
/*  (12) Same as (8), but multiplied by SQRT( underflow threshold ) */

/*  (13) Rectangular matrix with random entries chosen from (-1,1). */
/*  (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
/*  (15) Same as (13), but multiplied by SQRT( underflow threshold ) */

/*  Special case: */
/*  (16) A bidiagonal matrix with random entries chosen from a */
/*       logarithmic distribution on [ulp^2,ulp^(-2)]  (I.e., each */
/*       entry is  e^x, where x is chosen uniformly on */
/*       [ 2 log(ulp), -2 log(ulp) ] .)  For *this* type: */
/*       (a) DGEBRD is not called to reduce it to bidiagonal form. */
/*       (b) the bidiagonal is  min(M,N) x min(M,N); if M<N, the */
/*           matrix will be lower bidiagonal, otherwise upper. */
/*       (c) only tests 5--8 and 14 are performed. */

/*  A subset of the full set of matrix types may be selected through */
/*  the logical array DOTYPE. */

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

/*  NSIZES  (input) INTEGER */
/*          The number of values of M and N contained in the vectors */
/*          MVAL and NVAL.  The matrix sizes are used in pairs (M,N). */

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

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

/*  NTYPES  (input) INTEGER */
/*          The number of elements in DOTYPE.   If it is zero, DCHKBD */
/*          does nothing.  It must be at least zero.  If it is MAXTYP+1 */
/*          and NSIZES is 1, then an additional type, MAXTYP+1 is */
/*          defined, which is to use whatever matrices are in A and B. */
/*          This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/*          DOTYPE(MAXTYP+1) is .TRUE. . */

/*  DOTYPE  (input) LOGICAL array, dimension (NTYPES) */
/*          If DOTYPE(j) is .TRUE., then for each size (m,n), a matrix */
/*          of type j will be generated.  If NTYPES is smaller than the */
/*          maximum number of types defined (PARAMETER MAXTYP), then */
/*          types NTYPES+1 through MAXTYP will not be generated.  If */
/*          NTYPES is larger than MAXTYP, DOTYPE(MAXTYP+1) through */
/*          DOTYPE(NTYPES) will be ignored. */

/*  NRHS    (input) INTEGER */
/*          The number of columns in the "right-hand side" matrices X, Y, */
/*          and Z, used in testing DBDSQR.  If NRHS = 0, then the */
/*          operations on the right-hand side will not be tested. */
/*          NRHS must be at least 0. */

/*  ISEED   (input/output) INTEGER array, dimension (4) */
/*          On entry ISEED specifies the seed of the random number */
/*          generator. The array elements should be between 0 and 4095; */
/*          if not they will be reduced mod 4096.  Also, ISEED(4) must */
/*          be odd.  The values of ISEED are changed on exit, and can be */
/*          used in the next call to DCHKBD to continue the same random */
/*          number sequence. */

/*  THRESH  (input) DOUBLE PRECISION */
/*          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.  Note that the */
/*          expected value of the test ratios is O(1), so THRESH should */
/*          be a reasonably small multiple of 1, e.g., 10 or 100. */

/*  A       (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX) */
/*          where NMAX is the maximum value of N in NVAL. */

/*  LDA     (input) INTEGER */
/*          The leading dimension of the array A.  LDA >= max(1,MMAX), */
/*          where MMAX is the maximum value of M in MVAL. */

/*  BD      (workspace) DOUBLE PRECISION array, dimension */
/*                      (max(min(MVAL(j),NVAL(j)))) */

/*  BE      (workspace) DOUBLE PRECISION array, dimension */
/*                      (max(min(MVAL(j),NVAL(j)))) */

/*  S1      (workspace) DOUBLE PRECISION array, dimension */
/*                      (max(min(MVAL(j),NVAL(j)))) */

/*  S2      (workspace) DOUBLE PRECISION array, dimension */
/*                      (max(min(MVAL(j),NVAL(j)))) */

/*  X       (workspace) DOUBLE PRECISION array, dimension (LDX,NRHS) */

/*  LDX     (input) INTEGER */
/*          The leading dimension of the arrays X, Y, and Z. */
/*          LDX >= max(1,MMAX) */

/*  Y       (workspace) DOUBLE PRECISION array, dimension (LDX,NRHS) */

/*  Z       (workspace) DOUBLE PRECISION array, dimension (LDX,NRHS) */

/*  Q       (workspace) DOUBLE PRECISION array, dimension (LDQ,MMAX) */

/*  LDQ     (input) INTEGER */
/*          The leading dimension of the array Q.  LDQ >= max(1,MMAX). */

/*  PT      (workspace) DOUBLE PRECISION array, dimension (LDPT,NMAX) */

/*  LDPT    (input) INTEGER */
/*          The leading dimension of the arrays PT, U, and V. */
/*          LDPT >= max(1, max(min(MVAL(j),NVAL(j)))). */

/*  U       (workspace) DOUBLE PRECISION array, dimension */
/*                      (LDPT,max(min(MVAL(j),NVAL(j)))) */

/*  V       (workspace) DOUBLE PRECISION array, dimension */
/*                      (LDPT,max(min(MVAL(j),NVAL(j)))) */

/*  WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK) */

/*  LWORK   (input) INTEGER */
/*          The number of entries in WORK.  This must be at least */
/*          3(M+N) and  M(M + max(M,N,k) + 1) + N*min(M,N)  for all */
/*          pairs  (M,N)=(MM(j),NN(j)) */

/*  IWORK   (workspace) INTEGER array, dimension at least 8*min(M,N) */

/*  NOUT    (input) INTEGER */
/*          The FORTRAN unit number for printing out error messages */
/*          (e.g., if a routine returns IINFO not equal to 0.) */

/*  INFO    (output) INTEGER */
/*          If 0, then everything ran OK. */
/*           -1: NSIZES < 0 */
/*           -2: Some MM(j) < 0 */
/*           -3: Some NN(j) < 0 */
/*           -4: NTYPES < 0 */
/*           -6: NRHS  < 0 */
/*           -8: THRESH < 0 */
/*          -11: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ). */
/*          -17: LDB < 1 or LDB < MMAX. */
/*          -21: LDQ < 1 or LDQ < MMAX. */
/*          -23: LDPT< 1 or LDPT< MNMAX. */
/*          -27: LWORK too small. */
/*          If  DLATMR, SLATMS, DGEBRD, DORGBR, or DBDSQR, */
/*              returns an error code, the */
/*              absolute value of it is returned. */

/* ----------------------------------------------------------------------- */

/*     Some Local Variables and Parameters: */
/*     ---- ----- --------- --- ---------- */

/*     ZERO, ONE       Real 0 and 1. */
/*     MAXTYP          The number of types defined. */
/*     NTEST           The number of tests performed, or which can */
/*                     be performed so far, for the current matrix. */
/*     MMAX            Largest value in NN. */
/*     NMAX            Largest value in NN. */
/*     MNMIN           min(MM(j), NN(j)) (the dimension of the bidiagonal */
/*                     matrix.) */
/*     MNMAX           The maximum value of MNMIN for j=1,...,NSIZES. */
/*     NFAIL           The number of tests which have exceeded THRESH */
/*     COND, IMODE     Values to be passed to the matrix generators. */
/*     ANORM           Norm of A; passed to matrix generators. */

/*     OVFL, UNFL      Overflow and underflow thresholds. */
/*     RTOVFL, RTUNFL  Square roots of the previous 2 values. */
/*     ULP, ULPINV     Finest relative precision and its inverse. */

/*             The following four arrays decode JTYPE: */
/*     KTYPE(j)        The general type (1-10) for type "j". */
/*     KMODE(j)        The MODE value to be passed to the matrix */
/*                     generator for type "j". */
/*     KMAGN(j)        The order of magnitude ( O(1), */
/*                     O(overflow^(1/2) ), O(underflow^(1/2) ) */

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. Local Arrays .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Scalars in Common .. */
/*     .. */
/*     .. Common blocks .. */
/*     .. */
/*     .. Data statements .. */
    /* Parameter adjustments */
    --mval;
    --nval;
    --dotype;
    --iseed;
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    --bd;
    --be;
    --s1;
    --s2;
    z_dim1 = *ldx;
    z_offset = 1 + z_dim1;
    z__ -= z_offset;
    y_dim1 = *ldx;
    y_offset = 1 + y_dim1;
    y -= y_offset;
    x_dim1 = *ldx;
    x_offset = 1 + x_dim1;
    x -= x_offset;
    q_dim1 = *ldq;
    q_offset = 1 + q_dim1;
    q -= q_offset;
    vt_dim1 = *ldpt;
    vt_offset = 1 + vt_dim1;
    vt -= vt_offset;
    u_dim1 = *ldpt;
    u_offset = 1 + u_dim1;
    u -= u_offset;
    pt_dim1 = *ldpt;
    pt_offset = 1 + pt_dim1;
    pt -= pt_offset;
    --work;
    --iwork;

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

/*     Check for errors */

    *info = 0;

    badmm = FALSE_;
    badnn = FALSE_;
    mmax = 1;
    nmax = 1;
    mnmax = 1;
    minwrk = 1;
    i__1 = *nsizes;
    for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
	i__2 = mmax, i__3 = mval[j];
	mmax = max(i__2,i__3);
	if (mval[j] < 0) {
	    badmm = TRUE_;
	}
/* Computing MAX */
	i__2 = nmax, i__3 = nval[j];
	nmax = max(i__2,i__3);
	if (nval[j] < 0) {
	    badnn = TRUE_;
	}
/* Computing MAX */
/* Computing MIN */
	i__4 = mval[j], i__5 = nval[j];
	i__2 = mnmax, i__3 = min(i__4,i__5);
	mnmax = max(i__2,i__3);
/* Computing MAX */
/* Computing MAX */
	i__4 = mval[j], i__5 = nval[j], i__4 = max(i__4,i__5);
/* Computing MIN */
	i__6 = nval[j], i__7 = mval[j];
	i__2 = minwrk, i__3 = (mval[j] + nval[j]) * 3, i__2 = max(i__2,i__3), 
		i__3 = mval[j] * (mval[j] + max(i__4,*nrhs) + 1) + nval[j] * 
		min(i__6,i__7);
	minwrk = max(i__2,i__3);
/* L10: */
    }

/*     Check for errors */

    if (*nsizes < 0) {
	*info = -1;
    } else if (badmm) {
	*info = -2;
    } else if (badnn) {
	*info = -3;
    } else if (*ntypes < 0) {
	*info = -4;
    } else if (*nrhs < 0) {
	*info = -6;
    } else if (*lda < mmax) {
	*info = -11;
    } else if (*ldx < mmax) {
	*info = -17;
    } else if (*ldq < mmax) {
	*info = -21;
    } else if (*ldpt < mnmax) {
	*info = -23;
    } else if (minwrk > *lwork) {
	*info = -27;
    }

    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DCHKBD", &i__1);
	return 0;
    }

/*     Initialize constants */

    s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
    s_copy(path + 1, "BD", (ftnlen)2, (ftnlen)2);
    nfail = 0;
    ntest = 0;
    unfl = dlamch_("Safe minimum");
    ovfl = dlamch_("Overflow");
    dlabad_(&unfl, &ovfl);
    ulp = dlamch_("Precision");
    ulpinv = 1. / ulp;
    log2ui = (integer) (log(ulpinv) / log(2.));
    rtunfl = sqrt(unfl);
    rtovfl = sqrt(ovfl);
    infoc_1.infot = 0;

/*     Loop over sizes, types */

    i__1 = *nsizes;
    for (jsize = 1; jsize <= i__1; ++jsize) {
	m = mval[jsize];
	n = nval[jsize];
	mnmin = min(m,n);
/* Computing MAX */
	i__2 = max(m,n);
	amninv = 1. / max(i__2,1);

	if (*nsizes != 1) {
	    mtypes = min(16,*ntypes);
	} else {
	    mtypes = min(17,*ntypes);
	}

	i__2 = mtypes;
	for (jtype = 1; jtype <= i__2; ++jtype) {
	    if (! dotype[jtype]) {
		goto L190;
	    }

	    for (j = 1; j <= 4; ++j) {
		ioldsd[j - 1] = iseed[j];
/* L20: */
	    }

	    for (j = 1; j <= 14; ++j) {
		result[j - 1] = -1.;
/* L30: */
	    }

	    *(unsigned char *)uplo = ' ';

/*           Compute "A" */

/*           Control parameters: */

/*           KMAGN  KMODE        KTYPE */
/*       =1  O(1)   clustered 1  zero */
/*       =2  large  clustered 2  identity */
/*       =3  small  exponential  (none) */
/*       =4         arithmetic   diagonal, (w/ eigenvalues) */
/*       =5         random       symmetric, w/ eigenvalues */
/*       =6                      nonsymmetric, w/ singular values */
/*       =7                      random diagonal */
/*       =8                      random symmetric */
/*       =9                      random nonsymmetric */
/*       =10                     random bidiagonal (log. distrib.) */

	    if (mtypes > 16) {
		goto L100;
	    }

	    itype = ktype[jtype - 1];
	    imode = kmode[jtype - 1];

/*           Compute norm */

	    switch (kmagn[jtype - 1]) {
		case 1:  goto L40;
		case 2:  goto L50;
		case 3:  goto L60;
	    }

L40:
	    anorm = 1.;
	    goto L70;

L50:
	    anorm = rtovfl * ulp * amninv;
	    goto L70;

L60:
	    anorm = rtunfl * max(m,n) * ulpinv;
	    goto L70;

L70:

	    dlaset_("Full", lda, &n, &c_b20, &c_b20, &a[a_offset], lda);
	    iinfo = 0;
	    cond = ulpinv;

	    bidiag = FALSE_;
	    if (itype == 1) {

/*              Zero matrix */

		iinfo = 0;

	    } else if (itype == 2) {

/*              Identity */

		i__3 = mnmin;
		for (jcol = 1; jcol <= i__3; ++jcol) {
		    a[jcol + jcol * a_dim1] = anorm;
/* L80: */
		}

	    } else if (itype == 4) {

/*              Diagonal Matrix, [Eigen]values Specified */

		dlatms_(&mnmin, &mnmin, "S", &iseed[1], "N", &work[1], &imode, 
			 &cond, &anorm, &c__0, &c__0, "N", &a[a_offset], lda, 
			&work[mnmin + 1], &iinfo);

	    } else if (itype == 5) {

/*              Symmetric, eigenvalues specified */

		dlatms_(&mnmin, &mnmin, "S", &iseed[1], "S", &work[1], &imode, 
			 &cond, &anorm, &m, &n, "N", &a[a_offset], lda, &work[
			mnmin + 1], &iinfo);

	    } else if (itype == 6) {

/*              Nonsymmetric, singular values specified */

		dlatms_(&m, &n, "S", &iseed[1], "N", &work[1], &imode, &cond, 
			&anorm, &m, &n, "N", &a[a_offset], lda, &work[mnmin + 
			1], &iinfo);

	    } else if (itype == 7) {

/*              Diagonal, random entries */

		dlatmr_(&mnmin, &mnmin, "S", &iseed[1], "N", &work[1], &c__6, 
			&c_b37, &c_b37, "T", "N", &work[mnmin + 1], &c__1, &
			c_b37, &work[(mnmin << 1) + 1], &c__1, &c_b37, "N", &
			iwork[1], &c__0, &c__0, &c_b20, &anorm, "NO", &a[
			a_offset], lda, &iwork[1], &iinfo);

	    } else if (itype == 8) {

/*              Symmetric, random entries */

		dlatmr_(&mnmin, &mnmin, "S", &iseed[1], "S", &work[1], &c__6, 
			&c_b37, &c_b37, "T", "N", &work[mnmin + 1], &c__1, &
			c_b37, &work[m + mnmin + 1], &c__1, &c_b37, "N", &
			iwork[1], &m, &n, &c_b20, &anorm, "NO", &a[a_offset], 
			lda, &iwork[1], &iinfo);

	    } else if (itype == 9) {

/*              Nonsymmetric, random entries */

		dlatmr_(&m, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b37, 
			&c_b37, "T", "N", &work[mnmin + 1], &c__1, &c_b37, &
			work[m + mnmin + 1], &c__1, &c_b37, "N", &iwork[1], &
			m, &n, &c_b20, &anorm, "NO", &a[a_offset], lda, &
			iwork[1], &iinfo);

	    } else if (itype == 10) {

/*              Bidiagonal, random entries */

		temp1 = log(ulp) * -2.;
		i__3 = mnmin;
		for (j = 1; j <= i__3; ++j) {
		    bd[j] = exp(temp1 * dlarnd_(&c__2, &iseed[1]));
		    if (j < mnmin) {
			be[j] = exp(temp1 * dlarnd_(&c__2, &iseed[1]));
		    }
/* L90: */
		}

		iinfo = 0;
		bidiag = TRUE_;
		if (m >= n) {
		    *(unsigned char *)uplo = 'U';
		} else {
		    *(unsigned char *)uplo = 'L';
		}
	    } else {
		iinfo = 1;
	    }

	    if (iinfo == 0) {

/*              Generate Right-Hand Side */

		if (bidiag) {
		    dlatmr_(&mnmin, nrhs, "S", &iseed[1], "N", &work[1], &
			    c__6, &c_b37, &c_b37, "T", "N", &work[mnmin + 1], 
			    &c__1, &c_b37, &work[(mnmin << 1) + 1], &c__1, &
			    c_b37, "N", &iwork[1], &mnmin, nrhs, &c_b20, &
			    c_b37, "NO", &y[y_offset], ldx, &iwork[1], &iinfo);
		} else {
		    dlatmr_(&m, nrhs, "S", &iseed[1], "N", &work[1], &c__6, &
			    c_b37, &c_b37, "T", "N", &work[m + 1], &c__1, &
			    c_b37, &work[(m << 1) + 1], &c__1, &c_b37, "N", &
			    iwork[1], &m, nrhs, &c_b20, &c_b37, "NO", &x[
			    x_offset], ldx, &iwork[1], &iinfo);
		}
	    }

/*           Error Exit */

	    if (iinfo != 0) {
		io___39.ciunit = *nout;
		s_wsfe(&io___39);
		do_fio(&c__1, "Generator", (ftnlen)9);
		do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
		do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
		e_wsfe();
		*info = abs(iinfo);
		return 0;
	    }

L100:

/*           Call DGEBRD and DORGBR to compute B, Q, and P, do tests. */

	    if (! bidiag) {

/*              Compute transformations to reduce A to bidiagonal form: */
/*              B := Q' * A * P. */

		dlacpy_(" ", &m, &n, &a[a_offset], lda, &q[q_offset], ldq);
		i__3 = *lwork - (mnmin << 1);
		dgebrd_(&m, &n, &q[q_offset], ldq, &bd[1], &be[1], &work[1], &
			work[mnmin + 1], &work[(mnmin << 1) + 1], &i__3, &
			iinfo);

/*              Check error code from DGEBRD. */

		if (iinfo != 0) {
		    io___40.ciunit = *nout;
		    s_wsfe(&io___40);
		    do_fio(&c__1, "DGEBRD", (ftnlen)6);
		    do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
		    do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
			    ;
		    e_wsfe();
		    *info = abs(iinfo);
		    return 0;
		}

		dlacpy_(" ", &m, &n, &q[q_offset], ldq, &pt[pt_offset], ldpt);
		if (m >= n) {
		    *(unsigned char *)uplo = 'U';
		} else {
		    *(unsigned char *)uplo = 'L';
		}

/*              Generate Q */

		mq = m;
		if (*nrhs <= 0) {
		    mq = mnmin;
		}
		i__3 = *lwork - (mnmin << 1);
		dorgbr_("Q", &m, &mq, &n, &q[q_offset], ldq, &work[1], &work[(
			mnmin << 1) + 1], &i__3, &iinfo);

/*              Check error code from DORGBR. */

		if (iinfo != 0) {
		    io___42.ciunit = *nout;
		    s_wsfe(&io___42);
		    do_fio(&c__1, "DORGBR(Q)", (ftnlen)9);
		    do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
		    do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
			    ;
		    e_wsfe();
		    *info = abs(iinfo);
		    return 0;
		}

/*              Generate P' */

		i__3 = *lwork - (mnmin << 1);
		dorgbr_("P", &mnmin, &n, &m, &pt[pt_offset], ldpt, &work[
			mnmin + 1], &work[(mnmin << 1) + 1], &i__3, &iinfo);

/*              Check error code from DORGBR. */

		if (iinfo != 0) {
		    io___43.ciunit = *nout;
		    s_wsfe(&io___43);
		    do_fio(&c__1, "DORGBR(P)", (ftnlen)9);
		    do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
		    do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
			    ;
		    e_wsfe();
		    *info = abs(iinfo);
		    return 0;
		}

/*              Apply Q' to an M by NRHS matrix X:  Y := Q' * X. */

		dgemm_("Transpose", "No transpose", &m, nrhs, &m, &c_b37, &q[
			q_offset], ldq, &x[x_offset], ldx, &c_b20, &y[
			y_offset], ldx);

/*              Test 1:  Check the decomposition A := Q * B * PT */
/*                   2:  Check the orthogonality of Q */
/*                   3:  Check the orthogonality of PT */

		dbdt01_(&m, &n, &c__1, &a[a_offset], lda, &q[q_offset], ldq, &
			bd[1], &be[1], &pt[pt_offset], ldpt, &work[1], result)
			;
		dort01_("Columns", &m, &mq, &q[q_offset], ldq, &work[1], 
			lwork, &result[1]);
		dort01_("Rows", &mnmin, &n, &pt[pt_offset], ldpt, &work[1], 
			lwork, &result[2]);
	    }

/*           Use DBDSQR to form the SVD of the bidiagonal matrix B: */
/*           B := U * S1 * VT, and compute Z = U' * Y. */

	    dcopy_(&mnmin, &bd[1], &c__1, &s1[1], &c__1);
	    if (mnmin > 0) {
		i__3 = mnmin - 1;
		dcopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
	    }
	    dlacpy_(" ", &m, nrhs, &y[y_offset], ldx, &z__[z_offset], ldx);
	    dlaset_("Full", &mnmin, &mnmin, &c_b20, &c_b37, &u[u_offset], 
		    ldpt);
	    dlaset_("Full", &mnmin, &mnmin, &c_b20, &c_b37, &vt[vt_offset], 
		    ldpt);

	    dbdsqr_(uplo, &mnmin, &mnmin, &mnmin, nrhs, &s1[1], &work[1], &vt[
		    vt_offset], ldpt, &u[u_offset], ldpt, &z__[z_offset], ldx, 
		     &work[mnmin + 1], &iinfo);

/*           Check error code from DBDSQR. */

	    if (iinfo != 0) {
		io___44.ciunit = *nout;
		s_wsfe(&io___44);
		do_fio(&c__1, "DBDSQR(vects)", (ftnlen)13);
		do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
		do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
		e_wsfe();
		*info = abs(iinfo);
		if (iinfo < 0) {
		    return 0;
		} else {
		    result[3] = ulpinv;
		    goto L170;
		}
	    }

/*           Use DBDSQR to compute only the singular values of the */
/*           bidiagonal matrix B;  U, VT, and Z should not be modified. */

	    dcopy_(&mnmin, &bd[1], &c__1, &s2[1], &c__1);
	    if (mnmin > 0) {
		i__3 = mnmin - 1;
		dcopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
	    }

	    dbdsqr_(uplo, &mnmin, &c__0, &c__0, &c__0, &s2[1], &work[1], &vt[
		    vt_offset], ldpt, &u[u_offset], ldpt, &z__[z_offset], ldx, 
		     &work[mnmin + 1], &iinfo);

/*           Check error code from DBDSQR. */

	    if (iinfo != 0) {
		io___45.ciunit = *nout;
		s_wsfe(&io___45);
		do_fio(&c__1, "DBDSQR(values)", (ftnlen)14);
		do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
		do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
		e_wsfe();
		*info = abs(iinfo);
		if (iinfo < 0) {
		    return 0;
		} else {
		    result[8] = ulpinv;
		    goto L170;
		}
	    }

/*           Test 4:  Check the decomposition B := U * S1 * VT */
/*                5:  Check the computation Z := U' * Y */
/*                6:  Check the orthogonality of U */
/*                7:  Check the orthogonality of VT */

	    dbdt03_(uplo, &mnmin, &c__1, &bd[1], &be[1], &u[u_offset], ldpt, &
		    s1[1], &vt[vt_offset], ldpt, &work[1], &result[3]);
	    dbdt02_(&mnmin, nrhs, &y[y_offset], ldx, &z__[z_offset], ldx, &u[
		    u_offset], ldpt, &work[1], &result[4]);
	    dort01_("Columns", &mnmin, &mnmin, &u[u_offset], ldpt, &work[1], 
		    lwork, &result[5]);
	    dort01_("Rows", &mnmin, &mnmin, &vt[vt_offset], ldpt, &work[1], 
		    lwork, &result[6]);

/*           Test 8:  Check that the singular values are sorted in */
/*                    non-increasing order and are non-negative */

	    result[7] = 0.;
	    i__3 = mnmin - 1;
	    for (i__ = 1; i__ <= i__3; ++i__) {
		if (s1[i__] < s1[i__ + 1]) {
		    result[7] = ulpinv;
		}
		if (s1[i__] < 0.) {
		    result[7] = ulpinv;
		}
/* L110: */
	    }
	    if (mnmin >= 1) {
		if (s1[mnmin] < 0.) {
		    result[7] = ulpinv;
		}
	    }

/*           Test 9:  Compare DBDSQR with and without singular vectors */

	    temp2 = 0.;

	    i__3 = mnmin;
	    for (j = 1; j <= i__3; ++j) {
/* Computing MAX */
/* Computing MAX */
		d__6 = (d__1 = s1[j], abs(d__1)), d__7 = (d__2 = s2[j], abs(
			d__2));
		d__4 = sqrt(unfl) * max(s1[1],1.), d__5 = ulp * max(d__6,d__7)
			;
		temp1 = (d__3 = s1[j] - s2[j], abs(d__3)) / max(d__4,d__5);
		temp2 = max(temp1,temp2);
/* L120: */
	    }

	    result[8] = temp2;

/*           Test 10:  Sturm sequence test of singular values */
/*                     Go up by factors of two until it succeeds */

	    temp1 = *thresh * (.5 - ulp);

	    i__3 = log2ui;
	    for (j = 0; j <= i__3; ++j) {
/*               CALL DSVDCH( MNMIN, BD, BE, S1, TEMP1, IINFO ) */
		if (iinfo == 0) {
		    goto L140;
		}
		temp1 *= 2.;
/* L130: */
	    }

L140:
	    result[9] = temp1;

/*           Use DBDSQR to form the decomposition A := (QU) S (VT PT) */
/*           from the bidiagonal form A := Q B PT. */

	    if (! bidiag) {
		dcopy_(&mnmin, &bd[1], &c__1, &s2[1], &c__1);
		if (mnmin > 0) {
		    i__3 = mnmin - 1;
		    dcopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
		}

		dbdsqr_(uplo, &mnmin, &n, &m, nrhs, &s2[1], &work[1], &pt[
			pt_offset], ldpt, &q[q_offset], ldq, &y[y_offset], 
			ldx, &work[mnmin + 1], &iinfo);

/*              Test 11:  Check the decomposition A := Q*U * S2 * VT*PT */
/*                   12:  Check the computation Z := U' * Q' * X */
/*                   13:  Check the orthogonality of Q*U */
/*                   14:  Check the orthogonality of VT*PT */

		dbdt01_(&m, &n, &c__0, &a[a_offset], lda, &q[q_offset], ldq, &
			s2[1], dumma, &pt[pt_offset], ldpt, &work[1], &result[
			10]);
		dbdt02_(&m, nrhs, &x[x_offset], ldx, &y[y_offset], ldx, &q[
			q_offset], ldq, &work[1], &result[11]);
		dort01_("Columns", &m, &mq, &q[q_offset], ldq, &work[1], 
			lwork, &result[12]);
		dort01_("Rows", &mnmin, &n, &pt[pt_offset], ldpt, &work[1], 
			lwork, &result[13]);
	    }

/*           Use DBDSDC to form the SVD of the bidiagonal matrix B: */
/*           B := U * S1 * VT */

	    dcopy_(&mnmin, &bd[1], &c__1, &s1[1], &c__1);
	    if (mnmin > 0) {
		i__3 = mnmin - 1;
		dcopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
	    }
	    dlaset_("Full", &mnmin, &mnmin, &c_b20, &c_b37, &u[u_offset], 
		    ldpt);
	    dlaset_("Full", &mnmin, &mnmin, &c_b20, &c_b37, &vt[vt_offset], 
		    ldpt);

	    dbdsdc_(uplo, "I", &mnmin, &s1[1], &work[1], &u[u_offset], ldpt, &
		    vt[vt_offset], ldpt, dum, idum, &work[mnmin + 1], &iwork[
		    1], &iinfo);

/*           Check error code from DBDSDC. */

	    if (iinfo != 0) {
		io___51.ciunit = *nout;
		s_wsfe(&io___51);
		do_fio(&c__1, "DBDSDC(vects)", (ftnlen)13);
		do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
		do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
		e_wsfe();
		*info = abs(iinfo);
		if (iinfo < 0) {
		    return 0;
		} else {
		    result[14] = ulpinv;
		    goto L170;
		}
	    }

/*           Use DBDSDC to compute only the singular values of the */
/*           bidiagonal matrix B;  U and VT should not be modified. */

	    dcopy_(&mnmin, &bd[1], &c__1, &s2[1], &c__1);
	    if (mnmin > 0) {
		i__3 = mnmin - 1;
		dcopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
	    }

	    dbdsdc_(uplo, "N", &mnmin, &s2[1], &work[1], dum, &c__1, dum, &
		    c__1, dum, idum, &work[mnmin + 1], &iwork[1], &iinfo);

/*           Check error code from DBDSDC. */

	    if (iinfo != 0) {
		io___52.ciunit = *nout;
		s_wsfe(&io___52);
		do_fio(&c__1, "DBDSDC(values)", (ftnlen)14);
		do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
		do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
		e_wsfe();
		*info = abs(iinfo);
		if (iinfo < 0) {
		    return 0;
		} else {
		    result[17] = ulpinv;
		    goto L170;
		}
	    }

/*           Test 15:  Check the decomposition B := U * S1 * VT */
/*                16:  Check the orthogonality of U */
/*                17:  Check the orthogonality of VT */

	    dbdt03_(uplo, &mnmin, &c__1, &bd[1], &be[1], &u[u_offset], ldpt, &
		    s1[1], &vt[vt_offset], ldpt, &work[1], &result[14]);
	    dort01_("Columns", &mnmin, &mnmin, &u[u_offset], ldpt, &work[1], 
		    lwork, &result[15]);
	    dort01_("Rows", &mnmin, &mnmin, &vt[vt_offset], ldpt, &work[1], 
		    lwork, &result[16]);

/*           Test 18:  Check that the singular values are sorted in */
/*                     non-increasing order and are non-negative */

	    result[17] = 0.;
	    i__3 = mnmin - 1;
	    for (i__ = 1; i__ <= i__3; ++i__) {
		if (s1[i__] < s1[i__ + 1]) {
		    result[17] = ulpinv;
		}
		if (s1[i__] < 0.) {
		    result[17] = ulpinv;
		}
/* L150: */
	    }
	    if (mnmin >= 1) {
		if (s1[mnmin] < 0.) {
		    result[17] = ulpinv;
		}
	    }

/*           Test 19:  Compare DBDSQR with and without singular vectors */

	    temp2 = 0.;

	    i__3 = mnmin;
	    for (j = 1; j <= i__3; ++j) {
/* Computing MAX */
/* Computing MAX */
		d__4 = abs(s1[1]), d__5 = abs(s2[1]);
		d__2 = sqrt(unfl) * max(s1[1],1.), d__3 = ulp * max(d__4,d__5)
			;
		temp1 = (d__1 = s1[j] - s2[j], abs(d__1)) / max(d__2,d__3);
		temp2 = max(temp1,temp2);
/* L160: */
	    }

	    result[18] = temp2;

/*           End of Loop -- Check for RESULT(j) > THRESH */

L170:
	    for (j = 1; j <= 19; ++j) {
		if (result[j - 1] >= *thresh) {
		    if (nfail == 0) {
			dlahd2_(nout, path);
		    }
		    io___53.ciunit = *nout;
		    s_wsfe(&io___53);
		    do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
		    do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
			    ;
		    do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(
			    doublereal));
		    e_wsfe();
		    ++nfail;
		}
/* L180: */
	    }
	    if (! bidiag) {
		ntest += 19;
	    } else {
		ntest += 5;
	    }

L190:
	    ;
	}
/* L200: */
    }

/*     Summary */

    alasum_(path, nout, &nfail, &ntest, &c__0);

    return 0;

/*     End of DCHKBD */


} /* dchkbd_ */
Ejemplo n.º 3
0
/* Subroutine */ int dlafts_(char *type__, integer *m, integer *n, integer *
	imat, integer *ntests, doublereal *result, integer *iseed, doublereal 
	*thresh, integer *iounit, integer *ie)
{
    /* Format strings */
    static char fmt_9999[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
	    ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
	    ",0p,f8.2)";
    static char fmt_9998[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
	    ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
	    ",1p,d10.3)";
    static char fmt_9997[] = "(1x,i5,\002 x\002,i5,\002 matrix, type=\002,"
	    "i2,\002, s\002,\002eed=\002,3(i4,\002,\002),i4,\002: result \002"
	    ",i3,\002 is\002,0p,f8.2)";
    static char fmt_9996[] = "(1x,i5,\002 x\002,i5,\002 matrix, type=\002,"
	    "i2,\002, s\002,\002eed=\002,3(i4,\002,\002),i4,\002: result \002"
	    ",i3,\002 is\002,1p,d10.3)";

    /* System generated locals */
    integer i__1;

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

    /* Local variables */
    integer k;
    extern /* Subroutine */ int dlahd2_(integer *, char *);

    /* Fortran I/O blocks */
    static cilist io___2 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___3 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___4 = { 0, 0, 0, fmt_9997, 0 };
    static cilist io___5 = { 0, 0, 0, fmt_9996, 0 };



/*  -- LAPACK auxiliary test routine (version 3.1.2) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     April 2009 */

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

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

/*     DLAFTS tests the result vector against the threshold value to */
/*     see which tests for this matrix type failed to pass the threshold. */
/*     Output is to the file given by unit IOUNIT. */

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

/*  TYPE   - CHARACTER*3 */
/*           On entry, TYPE specifies the matrix type to be used in the */
/*           printed messages. */
/*           Not modified. */

/*  N      - INTEGER */
/*           On entry, N specifies the order of the test matrix. */
/*           Not modified. */

/*  IMAT   - INTEGER */
/*           On entry, IMAT specifies the type of the test matrix. */
/*           A listing of the different types is printed by DLAHD2 */
/*           to the output file if a test fails to pass the threshold. */
/*           Not modified. */

/*  NTESTS - INTEGER */
/*           On entry, NTESTS is the number of tests performed on the */
/*           subroutines in the path given by TYPE. */
/*           Not modified. */

/*  RESULT - DOUBLE PRECISION               array of dimension( NTESTS ) */
/*           On entry, RESULT contains the test ratios from the tests */
/*           performed in the calling program. */
/*           Not modified. */

/*  ISEED  - INTEGER            array of dimension( 4 ) */
/*           Contains the random seed that generated the matrix used */
/*           for the tests whose ratios are in RESULT. */
/*           Not modified. */

/*  THRESH - DOUBLE PRECISION */
/*           On entry, THRESH specifies the acceptable threshold of the */
/*           test ratios.  If RESULT( K ) > THRESH, then the K-th test */
/*           did not pass the threshold and a message will be printed. */
/*           Not modified. */

/*  IOUNIT - INTEGER */
/*           On entry, IOUNIT specifies the unit number of the file */
/*           to which the messages are printed. */
/*           Not modified. */

/*  IE     - INTEGER */
/*           On entry, IE contains the number of tests which have */
/*           failed to pass the threshold so far. */
/*           Updated on exit if any of the ratios in RESULT also fail. */

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

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

    /* Parameter adjustments */
    --iseed;
    --result;

    /* Function Body */
    if (*m == *n) {

/*     Output for square matrices: */

	i__1 = *ntests;
	for (k = 1; k <= i__1; ++k) {
	    if (result[k] >= *thresh) {

/*           If this is the first test to fail, call DLAHD2 */
/*           to print a header to the data file. */

		if (*ie == 0) {
		    dlahd2_(iounit, type__);
		}
		++(*ie);
		if (result[k] < 1e4) {
		    io___2.ciunit = *iounit;
		    s_wsfe(&io___2);
		    do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
		    do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&result[k], (ftnlen)sizeof(
			    doublereal));
		    e_wsfe();
		} else {
		    io___3.ciunit = *iounit;
		    s_wsfe(&io___3);
		    do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
		    do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&result[k], (ftnlen)sizeof(
			    doublereal));
		    e_wsfe();
		}
	    }
/* L10: */
	}
    } else {

/*     Output for rectangular matrices */

	i__1 = *ntests;
	for (k = 1; k <= i__1; ++k) {
	    if (result[k] >= *thresh) {

/*              If this is the first test to fail, call DLAHD2 */
/*              to print a header to the data file. */

		if (*ie == 0) {
		    dlahd2_(iounit, type__);
		}
		++(*ie);
		if (result[k] < 1e4) {
		    io___4.ciunit = *iounit;
		    s_wsfe(&io___4);
		    do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
		    do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&result[k], (ftnlen)sizeof(
			    doublereal));
		    e_wsfe();
		} else {
		    io___5.ciunit = *iounit;
		    s_wsfe(&io___5);
		    do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
		    do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&result[k], (ftnlen)sizeof(
			    doublereal));
		    e_wsfe();
		}
	    }
/* L20: */
	}

    }
    return 0;

/*     End of DLAFTS */

} /* dlafts_ */