sckgqr.c
Go to the documentation of this file.
00001 /* sckgqr.f -- translated by f2c (version 20061008).
00002    You must link the resulting object file with libf2c:
00003         on Microsoft Windows system, link with libf2c.lib;
00004         on Linux or Unix systems, link with .../path/to/libf2c.a -lm
00005         or, if you install libf2c.a in a standard place, with -lf2c -lm
00006         -- in that order, at the end of the command line, as in
00007                 cc *.o -lf2c -lm
00008         Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
00009 
00010                 http://www.netlib.org/f2c/libf2c.zip
00011 */
00012 
00013 #include "f2c.h"
00014 #include "blaswrap.h"
00015 
00016 /* Table of constant values */
00017 
00018 static integer c__8 = 8;
00019 static integer c__1 = 1;
00020 static integer c__0 = 0;
00021 
00022 /* Subroutine */ int sckgqr_(integer *nm, integer *mval, integer *np, integer 
00023         *pval, integer *nn, integer *nval, integer *nmats, integer *iseed, 
00024         real *thresh, integer *nmax, real *a, real *af, real *aq, real *ar, 
00025         real *taua, real *b, real *bf, real *bz, real *bt, real *bwk, real *
00026         taub, real *work, real *rwork, integer *nin, integer *nout, integer *
00027         info)
00028 {
00029     /* Format strings */
00030     static char fmt_9999[] = "(\002 SLATMS in SCKGQR:    INFO = \002,i5)";
00031     static char fmt_9998[] = "(\002 M=\002,i4,\002 P=\002,i4,\002, N=\002,"
00032             "i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
00033     static char fmt_9997[] = "(\002 N=\002,i4,\002 M=\002,i4,\002, P=\002,"
00034             "i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
00035 
00036     /* System generated locals */
00037     integer i__1, i__2, i__3, i__4;
00038 
00039     /* Builtin functions */
00040     /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
00041     integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
00042 
00043     /* Local variables */
00044     integer i__, m, n, p, im, in, ip, nt, lda, ldb, kla, klb, kua, kub;
00045     char path[3];
00046     integer imat;
00047     char type__[1];
00048     integer nrun, modea, modeb, nfail;
00049     char dista[1], distb[1];
00050     integer iinfo;
00051     real anorm, bnorm;
00052     integer lwork;
00053     extern /* Subroutine */ int slatb9_(char *, integer *, integer *, integer 
00054             *, integer *, char *, integer *, integer *, integer *, integer *, 
00055             real *, real *, integer *, integer *, real *, real *, char *, 
00056             char *), alahdg_(integer *, char *
00057 );
00058     real cndnma, cndnmb;
00059     extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer 
00060             *, integer *, integer *), alasum_(char *, integer *, 
00061             integer *, integer *, integer *), slatms_(integer *, 
00062             integer *, char *, integer *, char *, real *, integer *, real *, 
00063             real *, integer *, integer *, char *, real *, integer *, real *, 
00064             integer *);
00065     logical dotype[8], firstt;
00066     real result[7];
00067     extern /* Subroutine */ int sgqrts_(integer *, integer *, integer *, real 
00068             *, real *, real *, real *, integer *, real *, real *, real *, 
00069             real *, real *, real *, integer *, real *, real *, integer *, 
00070             real *, real *), sgrqts_(integer *, integer *, integer *, real *, 
00071             real *, real *, real *, integer *, real *, real *, real *, real *, 
00072              real *, real *, integer *, real *, real *, integer *, real *, 
00073             real *);
00074 
00075     /* Fortran I/O blocks */
00076     static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
00077     static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
00078     static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
00079     static cilist io___36 = { 0, 0, 0, fmt_9999, 0 };
00080     static cilist io___37 = { 0, 0, 0, fmt_9999, 0 };
00081     static cilist io___38 = { 0, 0, 0, fmt_9997, 0 };
00082 
00083 
00084 
00085 /*  -- LAPACK test routine (version 3.1) -- */
00086 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00087 /*     November 2006 */
00088 
00089 /*     .. Scalar Arguments .. */
00090 /*     .. */
00091 /*     .. Array Arguments .. */
00092 /*     .. */
00093 
00094 /*  Purpose */
00095 /*  ======= */
00096 
00097 /*  SCKGQR tests */
00098 /*  SGGQRF: GQR factorization for N-by-M matrix A and N-by-P matrix B, */
00099 /*  SGGRQF: GRQ factorization for M-by-N matrix A and P-by-N matrix B. */
00100 
00101 /*  Arguments */
00102 /*  ========= */
00103 
00104 /*  NM      (input) INTEGER */
00105 /*          The number of values of M contained in the vector MVAL. */
00106 
00107 /*  MVAL    (input) INTEGER array, dimension (NM) */
00108 /*          The values of the matrix row(column) dimension M. */
00109 
00110 /*  NP      (input) INTEGER */
00111 /*          The number of values of P contained in the vector PVAL. */
00112 
00113 /*  PVAL    (input) INTEGER array, dimension (NP) */
00114 /*          The values of the matrix row(column) dimension P. */
00115 
00116 /*  NN      (input) INTEGER */
00117 /*          The number of values of N contained in the vector NVAL. */
00118 
00119 /*  NVAL    (input) INTEGER array, dimension (NN) */
00120 /*          The values of the matrix column(row) dimension N. */
00121 
00122 /*  NMATS   (input) INTEGER */
00123 /*          The number of matrix types to be tested for each combination */
00124 /*          of matrix dimensions.  If NMATS >= NTYPES (the maximum */
00125 /*          number of matrix types), then all the different types are */
00126 /*          generated for testing.  If NMATS < NTYPES, another input line */
00127 /*          is read to get the numbers of the matrix types to be used. */
00128 
00129 /*  ISEED   (input/output) INTEGER array, dimension (4) */
00130 /*          On entry, the seed of the random number generator.  The array */
00131 /*          elements should be between 0 and 4095, otherwise they will be */
00132 /*          reduced mod 4096, and ISEED(4) must be odd. */
00133 /*          On exit, the next seed in the random number sequence after */
00134 /*          all the test matrices have been generated. */
00135 
00136 /*  THRESH  (input) REAL */
00137 /*          The threshold value for the test ratios.  A result is */
00138 /*          included in the output file if RESULT >= THRESH.  To have */
00139 /*          every test ratio printed, use THRESH = 0. */
00140 
00141 /*  NMAX    (input) INTEGER */
00142 /*          The maximum value permitted for M or N, used in dimensioning */
00143 /*          the work arrays. */
00144 
00145 /*  A       (workspace) REAL array, dimension (NMAX*NMAX) */
00146 
00147 /*  AF      (workspace) REAL array, dimension (NMAX*NMAX) */
00148 
00149 /*  AQ      (workspace) REAL array, dimension (NMAX*NMAX) */
00150 
00151 /*  AR      (workspace) REAL array, dimension (NMAX*NMAX) */
00152 
00153 /*  TAUA    (workspace) REAL array, dimension (NMAX) */
00154 
00155 /*  B       (workspace) REAL array, dimension (NMAX*NMAX) */
00156 
00157 /*  BF      (workspace) REAL array, dimension (NMAX*NMAX) */
00158 
00159 /*  BZ      (workspace) REAL array, dimension (NMAX*NMAX) */
00160 
00161 /*  BT      (workspace) REAL array, dimension (NMAX*NMAX) */
00162 
00163 /*  BWK     (workspace) REAL array, dimension (NMAX*NMAX) */
00164 
00165 /*  TAUB    (workspace) REAL array, dimension (NMAX) */
00166 
00167 /*  WORK    (workspace) REAL array, dimension (NMAX*NMAX) */
00168 
00169 /*  RWORK   (workspace) REAL array, dimension (NMAX) */
00170 
00171 /*  NIN     (input) INTEGER */
00172 /*          The unit number for input. */
00173 
00174 /*  NOUT    (input) INTEGER */
00175 /*          The unit number for output. */
00176 
00177 /*  INFO    (output) INTEGER */
00178 /*          = 0 :  successful exit */
00179 /*          > 0 :  If SLATMS returns an error code, the absolute value */
00180 /*                 of it is returned. */
00181 
00182 /*  ===================================================================== */
00183 
00184 /*     .. Parameters .. */
00185 /*     .. */
00186 /*     .. Local Scalars .. */
00187 /*     .. */
00188 /*     .. Local Arrays .. */
00189 /*     .. */
00190 /*     .. External Subroutines .. */
00191 /*     .. */
00192 /*     .. Intrinsic Functions .. */
00193 /*     .. */
00194 /*     .. Executable Statements .. */
00195 
00196 /*     Initialize constants. */
00197 
00198     /* Parameter adjustments */
00199     --rwork;
00200     --work;
00201     --taub;
00202     --bwk;
00203     --bt;
00204     --bz;
00205     --bf;
00206     --b;
00207     --taua;
00208     --ar;
00209     --aq;
00210     --af;
00211     --a;
00212     --iseed;
00213     --nval;
00214     --pval;
00215     --mval;
00216 
00217     /* Function Body */
00218     s_copy(path, "GQR", (ftnlen)3, (ftnlen)3);
00219     *info = 0;
00220     nrun = 0;
00221     nfail = 0;
00222     firstt = TRUE_;
00223     alareq_(path, nmats, dotype, &c__8, nin, nout);
00224     lda = *nmax;
00225     ldb = *nmax;
00226     lwork = *nmax * *nmax;
00227 
00228 /*     Do for each value of M in MVAL. */
00229 
00230     i__1 = *nm;
00231     for (im = 1; im <= i__1; ++im) {
00232         m = mval[im];
00233 
00234 /*        Do for each value of P in PVAL. */
00235 
00236         i__2 = *np;
00237         for (ip = 1; ip <= i__2; ++ip) {
00238             p = pval[ip];
00239 
00240 /*           Do for each value of N in NVAL. */
00241 
00242             i__3 = *nn;
00243             for (in = 1; in <= i__3; ++in) {
00244                 n = nval[in];
00245 
00246                 for (imat = 1; imat <= 8; ++imat) {
00247 
00248 /*                 Do the tests only if DOTYPE( IMAT ) is true. */
00249 
00250                     if (! dotype[imat - 1]) {
00251                         goto L30;
00252                     }
00253 
00254 /*                 Test SGGRQF */
00255 
00256 /*                 Set up parameters with SLATB9 and generate test */
00257 /*                 matrices A and B with SLATMS. */
00258 
00259                     slatb9_("GRQ", &imat, &m, &p, &n, type__, &kla, &kua, &
00260                             klb, &kub, &anorm, &bnorm, &modea, &modeb, &
00261                             cndnma, &cndnmb, dista, distb);
00262 
00263 /*                 Generate M by N matrix A */
00264 
00265                     slatms_(&m, &n, dista, &iseed[1], type__, &rwork[1], &
00266                             modea, &cndnma, &anorm, &kla, &kua, "No packing", 
00267                             &a[1], &lda, &work[1], &iinfo);
00268                     if (iinfo != 0) {
00269                         io___30.ciunit = *nout;
00270                         s_wsfe(&io___30);
00271                         do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
00272                                 ;
00273                         e_wsfe();
00274                         *info = abs(iinfo);
00275                         goto L30;
00276                     }
00277 
00278 /*                 Generate P by N matrix B */
00279 
00280                     slatms_(&p, &n, distb, &iseed[1], type__, &rwork[1], &
00281                             modeb, &cndnmb, &bnorm, &klb, &kub, "No packing", 
00282                             &b[1], &ldb, &work[1], &iinfo);
00283                     if (iinfo != 0) {
00284                         io___31.ciunit = *nout;
00285                         s_wsfe(&io___31);
00286                         do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
00287                                 ;
00288                         e_wsfe();
00289                         *info = abs(iinfo);
00290                         goto L30;
00291                     }
00292 
00293                     nt = 4;
00294 
00295                     sgrqts_(&m, &p, &n, &a[1], &af[1], &aq[1], &ar[1], &lda, &
00296                             taua[1], &b[1], &bf[1], &bz[1], &bt[1], &bwk[1], &
00297                             ldb, &taub[1], &work[1], &lwork, &rwork[1], 
00298                             result);
00299 
00300 /*                 Print information about the tests that did not */
00301 /*                 pass the threshold. */
00302 
00303                     i__4 = nt;
00304                     for (i__ = 1; i__ <= i__4; ++i__) {
00305                         if (result[i__ - 1] >= *thresh) {
00306                             if (nfail == 0 && firstt) {
00307                                 firstt = FALSE_;
00308                                 alahdg_(nout, "GRQ");
00309                             }
00310                             io___35.ciunit = *nout;
00311                             s_wsfe(&io___35);
00312                             do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
00313                                     ;
00314                             do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer))
00315                                     ;
00316                             do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
00317                                     ;
00318                             do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
00319                                     integer));
00320                             do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
00321                                     integer));
00322                             do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen)
00323                                     sizeof(real));
00324                             e_wsfe();
00325                             ++nfail;
00326                         }
00327 /* L10: */
00328                     }
00329                     nrun += nt;
00330 
00331 /*                 Test SGGQRF */
00332 
00333 /*                 Set up parameters with SLATB9 and generate test */
00334 /*                 matrices A and B with SLATMS. */
00335 
00336                     slatb9_("GQR", &imat, &m, &p, &n, type__, &kla, &kua, &
00337                             klb, &kub, &anorm, &bnorm, &modea, &modeb, &
00338                             cndnma, &cndnmb, dista, distb);
00339 
00340 /*                 Generate N-by-M matrix  A */
00341 
00342                     slatms_(&n, &m, dista, &iseed[1], type__, &rwork[1], &
00343                             modea, &cndnma, &anorm, &kla, &kua, "No packing", 
00344                             &a[1], &lda, &work[1], &iinfo);
00345                     if (iinfo != 0) {
00346                         io___36.ciunit = *nout;
00347                         s_wsfe(&io___36);
00348                         do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
00349                                 ;
00350                         e_wsfe();
00351                         *info = abs(iinfo);
00352                         goto L30;
00353                     }
00354 
00355 /*                 Generate N-by-P matrix  B */
00356 
00357                     slatms_(&n, &p, distb, &iseed[1], type__, &rwork[1], &
00358                             modea, &cndnma, &bnorm, &klb, &kub, "No packing", 
00359                             &b[1], &ldb, &work[1], &iinfo);
00360                     if (iinfo != 0) {
00361                         io___37.ciunit = *nout;
00362                         s_wsfe(&io___37);
00363                         do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
00364                                 ;
00365                         e_wsfe();
00366                         *info = abs(iinfo);
00367                         goto L30;
00368                     }
00369 
00370                     nt = 4;
00371 
00372                     sgqrts_(&n, &m, &p, &a[1], &af[1], &aq[1], &ar[1], &lda, &
00373                             taua[1], &b[1], &bf[1], &bz[1], &bt[1], &bwk[1], &
00374                             ldb, &taub[1], &work[1], &lwork, &rwork[1], 
00375                             result);
00376 
00377 /*                 Print information about the tests that did not */
00378 /*                 pass the threshold. */
00379 
00380                     i__4 = nt;
00381                     for (i__ = 1; i__ <= i__4; ++i__) {
00382                         if (result[i__ - 1] >= *thresh) {
00383                             if (nfail == 0 && firstt) {
00384                                 firstt = FALSE_;
00385                                 alahdg_(nout, path);
00386                             }
00387                             io___38.ciunit = *nout;
00388                             s_wsfe(&io___38);
00389                             do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
00390                                     ;
00391                             do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
00392                                     ;
00393                             do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer))
00394                                     ;
00395                             do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
00396                                     integer));
00397                             do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
00398                                     integer));
00399                             do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen)
00400                                     sizeof(real));
00401                             e_wsfe();
00402                             ++nfail;
00403                         }
00404 /* L20: */
00405                     }
00406                     nrun += nt;
00407 
00408 L30:
00409                     ;
00410                 }
00411 /* L40: */
00412             }
00413 /* L50: */
00414         }
00415 /* L60: */
00416     }
00417 
00418 /*     Print a summary of the results. */
00419 
00420     alasum_(path, nout, &nfail, &nrun, &c__0);
00421 
00422     return 0;
00423 
00424 /*     End of SCKGQR */
00425 
00426 } /* sckgqr_ */

swiftnav
Author(s):
autogenerated on Sat Jun 8 2019 18:55:59