/* dckgqr.f -- translated by f2c (version 20061008). You must link the resulting object file with libf2c: on Microsoft Windows system, link with libf2c.lib; on Linux or Unix systems, link with .../path/to/libf2c.a -lm or, if you install libf2c.a in a standard place, with -lf2c -lm -- in that order, at the end of the command line, as in cc *.o -lf2c -lm Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., http://www.netlib.org/f2c/libf2c.zip */ #include "f2c.h" #include "blaswrap.h" /* Table of constant values */ static integer c__8 = 8; static integer c__1 = 1; static integer c__0 = 0; /* Subroutine */ int dckgqr_(integer *nm, integer *mval, integer *np, integer *pval, integer *nn, integer *nval, integer *nmats, integer *iseed, doublereal *thresh, integer *nmax, doublereal *a, doublereal *af, doublereal *aq, doublereal *ar, doublereal *taua, doublereal *b, doublereal *bf, doublereal *bz, doublereal *bt, doublereal *bwk, doublereal *taub, doublereal *work, doublereal *rwork, integer *nin, integer *nout, integer *info) { /* Format strings */ static char fmt_9999[] = "(\002 DLATMS in DCKGQR: INFO = \002,i5)"; static char fmt_9998[] = "(\002 M=\002,i4,\002 P=\002,i4,\002, N=\002," "i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)"; static char fmt_9997[] = "(\002 N=\002,i4,\002 M=\002,i4,\002, P=\002," "i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)"; /* System generated locals */ integer i__1, i__2, i__3, i__4; /* 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__, m, n, p, im, in, ip, nt, lda, ldb, kla, klb, kua, kub; char path[3]; integer imat; char type__[1]; integer nrun, modea, modeb, nfail; char dista[1], distb[1]; integer iinfo; doublereal anorm, bnorm; integer lwork; extern /* Subroutine */ int dlatb9_(char *, integer *, integer *, integer *, integer *, char *, integer *, integer *, integer *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, doublereal *, char *, char *), alahdg_(integer *, char *); doublereal cndnma, cndnmb; extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer *, integer *, integer *), alasum_(char *, integer *, integer *, integer *, integer *), dlatms_(integer *, integer *, char *, integer *, char *, doublereal *, integer *, doublereal *, doublereal *, integer *, integer *, char *, doublereal *, integer *, doublereal *, integer *); logical dotype[8]; extern /* Subroutine */ int dgqrts_(integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, doublereal *), dgrqts_(integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, doublereal * , doublereal *, integer *, doublereal *, doublereal *); logical firstt; doublereal result[7]; /* Fortran I/O blocks */ static cilist io___30 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___31 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___35 = { 0, 0, 0, fmt_9998, 0 }; static cilist io___36 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___37 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___38 = { 0, 0, 0, fmt_9997, 0 }; /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* DCKGQR tests */ /* DGGQRF: GQR factorization for N-by-M matrix A and N-by-P matrix B, */ /* DGGRQF: GRQ factorization for M-by-N matrix A and P-by-N matrix B. */ /* Arguments */ /* ========= */ /* 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(column) dimension M. */ /* NP (input) INTEGER */ /* The number of values of P contained in the vector PVAL. */ /* PVAL (input) INTEGER array, dimension (NP) */ /* The values of the matrix row(column) dimension P. */ /* 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(row) dimension N. */ /* NMATS (input) INTEGER */ /* The number of matrix types to be tested for each combination */ /* of matrix dimensions. If NMATS >= NTYPES (the maximum */ /* number of matrix types), then all the different types are */ /* generated for testing. If NMATS < NTYPES, another input line */ /* is read to get the numbers of the matrix types to be used. */ /* ISEED (input/output) INTEGER array, dimension (4) */ /* On entry, the seed of the random number generator. The array */ /* elements should be between 0 and 4095, otherwise they will be */ /* reduced mod 4096, and ISEED(4) must be odd. */ /* On exit, the next seed in the random number sequence after */ /* all the test matrices have been generated. */ /* 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. */ /* NMAX (input) INTEGER */ /* The maximum value permitted for M or N, used in dimensioning */ /* the work arrays. */ /* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */ /* AF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */ /* AQ (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */ /* AR (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */ /* TAUA (workspace) DOUBLE PRECISION array, dimension (NMAX) */ /* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */ /* BF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */ /* BZ (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */ /* BT (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */ /* BWK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */ /* TAUB (workspace) DOUBLE PRECISION array, dimension (NMAX) */ /* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */ /* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) */ /* NIN (input) INTEGER */ /* The unit number for input. */ /* NOUT (input) INTEGER */ /* The unit number for output. */ /* INFO (output) INTEGER */ /* = 0 : successful exit */ /* > 0 : If DLATMS returns an error code, the absolute value */ /* of it is returned. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Initialize constants. */ /* Parameter adjustments */ --rwork; --work; --taub; --bwk; --bt; --bz; --bf; --b; --taua; --ar; --aq; --af; --a; --iseed; --nval; --pval; --mval; /* Function Body */ s_copy(path, "GQR", (ftnlen)3, (ftnlen)3); *info = 0; nrun = 0; nfail = 0; firstt = TRUE_; alareq_(path, nmats, dotype, &c__8, nin, nout); lda = *nmax; ldb = *nmax; lwork = *nmax * *nmax; /* Do for each value of M in MVAL. */ i__1 = *nm; for (im = 1; im <= i__1; ++im) { m = mval[im]; /* Do for each value of P in PVAL. */ i__2 = *np; for (ip = 1; ip <= i__2; ++ip) { p = pval[ip]; /* Do for each value of N in NVAL. */ i__3 = *nn; for (in = 1; in <= i__3; ++in) { n = nval[in]; for (imat = 1; imat <= 8; ++imat) { /* Do the tests only if DOTYPE( IMAT ) is true. */ if (! dotype[imat - 1]) { goto L30; } /* Test DGGRQF */ /* Set up parameters with DLATB9 and generate test */ /* matrices A and B with DLATMS. */ dlatb9_("GRQ", &imat, &m, &p, &n, type__, &kla, &kua, & klb, &kub, &anorm, &bnorm, &modea, &modeb, & cndnma, &cndnmb, dista, distb); /* Generate M by N matrix A */ dlatms_(&m, &n, dista, &iseed[1], type__, &rwork[1], & modea, &cndnma, &anorm, &kla, &kua, "No packing", &a[1], &lda, &work[1], &iinfo); if (iinfo != 0) { io___30.ciunit = *nout; s_wsfe(&io___30); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)) ; e_wsfe(); *info = abs(iinfo); goto L30; } /* Generate P by N matrix B */ dlatms_(&p, &n, distb, &iseed[1], type__, &rwork[1], & modeb, &cndnmb, &bnorm, &klb, &kub, "No packing", &b[1], &ldb, &work[1], &iinfo); if (iinfo != 0) { io___31.ciunit = *nout; s_wsfe(&io___31); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)) ; e_wsfe(); *info = abs(iinfo); goto L30; } nt = 4; dgrqts_(&m, &p, &n, &a[1], &af[1], &aq[1], &ar[1], &lda, & taua[1], &b[1], &bf[1], &bz[1], &bt[1], &bwk[1], & ldb, &taub[1], &work[1], &lwork, &rwork[1], result); /* Print information about the tests that did not */ /* pass the threshold. */ i__4 = nt; for (i__ = 1; i__ <= i__4; ++i__) { if (result[i__ - 1] >= *thresh) { if (nfail == 0 && firstt) { firstt = FALSE_; alahdg_(nout, "GRQ"); } io___35.ciunit = *nout; s_wsfe(&io___35); do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer)) ; do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer)) ; do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)) ; do_fio(&c__1, (char *)&imat, (ftnlen)sizeof( integer)); do_fio(&c__1, (char *)&i__, (ftnlen)sizeof( integer)); do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen) sizeof(doublereal)); e_wsfe(); ++nfail; } /* L10: */ } nrun += nt; /* Test DGGQRF */ /* Set up parameters with DLATB9 and generate test */ /* matrices A and B with DLATMS. */ dlatb9_("GQR", &imat, &m, &p, &n, type__, &kla, &kua, & klb, &kub, &anorm, &bnorm, &modea, &modeb, & cndnma, &cndnmb, dista, distb); /* Generate N-by-M matrix A */ dlatms_(&n, &m, dista, &iseed[1], type__, &rwork[1], & modea, &cndnma, &anorm, &kla, &kua, "No packing", &a[1], &lda, &work[1], &iinfo); if (iinfo != 0) { io___36.ciunit = *nout; s_wsfe(&io___36); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)) ; e_wsfe(); *info = abs(iinfo); goto L30; } /* Generate N-by-P matrix B */ dlatms_(&n, &p, distb, &iseed[1], type__, &rwork[1], & modea, &cndnma, &bnorm, &klb, &kub, "No packing", &b[1], &ldb, &work[1], &iinfo); if (iinfo != 0) { io___37.ciunit = *nout; s_wsfe(&io___37); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)) ; e_wsfe(); *info = abs(iinfo); goto L30; } nt = 4; dgqrts_(&n, &m, &p, &a[1], &af[1], &aq[1], &ar[1], &lda, & taua[1], &b[1], &bf[1], &bz[1], &bt[1], &bwk[1], & ldb, &taub[1], &work[1], &lwork, &rwork[1], result); /* Print information about the tests that did not */ /* pass the threshold. */ i__4 = nt; for (i__ = 1; i__ <= i__4; ++i__) { if (result[i__ - 1] >= *thresh) { if (nfail == 0 && firstt) { firstt = FALSE_; alahdg_(nout, path); } io___38.ciunit = *nout; s_wsfe(&io___38); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)) ; do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer)) ; do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer)) ; do_fio(&c__1, (char *)&imat, (ftnlen)sizeof( integer)); do_fio(&c__1, (char *)&i__, (ftnlen)sizeof( integer)); do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen) sizeof(doublereal)); e_wsfe(); ++nfail; } /* L20: */ } nrun += nt; L30: ; } /* L40: */ } /* L50: */ } /* L60: */ } /* Print a summary of the results. */ alasum_(path, nout, &nfail, &nrun, &c__0); return 0; /* End of DCKGQR */ } /* dckgqr_ */