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

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