dcklse.c
Go to the documentation of this file.
00001 /* dcklse.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 dcklse_(integer *nn, integer *mval, integer *pval, 
00023         integer *nval, integer *nmats, integer *iseed, doublereal *thresh, 
00024         integer *nmax, doublereal *a, doublereal *af, doublereal *b, 
00025         doublereal *bf, doublereal *x, doublereal *work, doublereal *rwork, 
00026         integer *nin, integer *nout, integer *info)
00027 {
00028     /* Format strings */
00029     static char fmt_9997[] = "(\002 *** Invalid input  for LSE:  M = \002,"
00030             "i6,\002, P = \002,i6,\002, N = \002,i6,\002;\002,/\002     must "
00031             "satisfy P <= N <= P+M  \002,\002(this set of values will be skip"
00032             "ped)\002)";
00033     static char fmt_9999[] = "(\002 DLATMS in DCKLSE   INFO = \002,i5)";
00034     static char fmt_9998[] = "(\002 M=\002,i4,\002 P=\002,i4,\002, N=\002,"
00035             "i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
00036 
00037     /* System generated locals */
00038     integer i__1, i__2, i__3, i__4, i__5, i__6, i__7;
00039 
00040     /* Builtin functions */
00041     /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
00042     integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), do_fio(integer *
00043             , char *, ftnlen), e_wsfe(void);
00044 
00045     /* Local variables */
00046     integer i__, m, n, p, ik, nt, lda, ldb, kla, klb, kua, kub, imat;
00047     char path[3], type__[1];
00048     integer nrun, modea, modeb, nfail;
00049     char dista[1], distb[1];
00050     integer iinfo;
00051     doublereal anorm, bnorm;
00052     integer lwork;
00053     extern /* Subroutine */ int dlatb9_(char *, integer *, integer *, integer 
00054             *, integer *, char *, integer *, integer *, integer *, integer *, 
00055             doublereal *, doublereal *, integer *, integer *, doublereal *, 
00056             doublereal *, char *, char *), 
00057             alahdg_(integer *, char *);
00058     doublereal cndnma, cndnmb;
00059     extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer 
00060             *, integer *, integer *), dlarhs_(char *, char *, char *, 
00061             char *, integer *, integer *, integer *, integer *, integer *, 
00062             doublereal *, integer *, doublereal *, integer *, doublereal *, 
00063             integer *, integer *, integer *), 
00064             alasum_(char *, integer *, integer *, integer *, integer *), dlatms_(integer *, integer *, char *, integer *, char *, 
00065             doublereal *, integer *, doublereal *, doublereal *, integer *, 
00066             integer *, char *, doublereal *, integer *, doublereal *, integer 
00067             *), dlsets_(integer *, integer *, integer 
00068             *, doublereal *, doublereal *, integer *, doublereal *, 
00069             doublereal *, integer *, doublereal *, doublereal *, doublereal *, 
00070              doublereal *, doublereal *, doublereal *, integer *, doublereal *
00071 , doublereal *);
00072     logical dotype[8], firstt;
00073     doublereal result[7];
00074 
00075     /* Fortran I/O blocks */
00076     static cilist io___13 = { 0, 0, 0, 0, 0 };
00077     static cilist io___14 = { 0, 0, 0, fmt_9997, 0 };
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 
00082 
00083 
00084 /*  -- LAPACK test routine (version 3.1) -- */
00085 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00086 /*     November 2006 */
00087 
00088 /*     .. Scalar Arguments .. */
00089 /*     .. */
00090 /*     .. Array Arguments .. */
00091 /*     .. */
00092 
00093 /*  Purpose */
00094 /*  ======= */
00095 
00096 /*  DCKLSE tests DGGLSE - a subroutine for solving linear equality */
00097 /*  constrained least square problem (LSE). */
00098 
00099 /*  Arguments */
00100 /*  ========= */
00101 
00102 /*  NN      (input) INTEGER */
00103 /*          The number of values of (M,P,N) contained in the vectors */
00104 /*          (MVAL, PVAL, NVAL). */
00105 
00106 /*  MVAL    (input) INTEGER array, dimension (NN) */
00107 /*          The values of the matrix row(column) dimension M. */
00108 
00109 /*  PVAL    (input) INTEGER array, dimension (NN) */
00110 /*          The values of the matrix row(column) dimension P. */
00111 
00112 /*  NVAL    (input) INTEGER array, dimension (NN) */
00113 /*          The values of the matrix column(row) dimension N. */
00114 
00115 /*  NMATS   (input) INTEGER */
00116 /*          The number of matrix types to be tested for each combination */
00117 /*          of matrix dimensions.  If NMATS >= NTYPES (the maximum */
00118 /*          number of matrix types), then all the different types are */
00119 /*          generated for testing.  If NMATS < NTYPES, another input line */
00120 /*          is read to get the numbers of the matrix types to be used. */
00121 
00122 /*  ISEED   (input/output) INTEGER array, dimension (4) */
00123 /*          On entry, the seed of the random number generator.  The array */
00124 /*          elements should be between 0 and 4095, otherwise they will be */
00125 /*          reduced mod 4096, and ISEED(4) must be odd. */
00126 /*          On exit, the next seed in the random number sequence after */
00127 /*          all the test matrices have been generated. */
00128 
00129 /*  THRESH  (input) DOUBLE PRECISION */
00130 /*          The threshold value for the test ratios.  A result is */
00131 /*          included in the output file if RESULT >= THRESH.  To have */
00132 /*          every test ratio printed, use THRESH = 0. */
00133 
00134 /*  NMAX    (input) INTEGER */
00135 /*          The maximum value permitted for M or N, used in dimensioning */
00136 /*          the work arrays. */
00137 
00138 /*  A       (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
00139 
00140 /*  AF      (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
00141 
00142 /*  B       (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
00143 
00144 /*  BF      (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
00145 
00146 /*  X       (workspace) DOUBLE PRECISION array, dimension (5*NMAX) */
00147 
00148 /*  WORK    (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
00149 
00150 /*  RWORK   (workspace) DOUBLE PRECISION array, dimension (NMAX) */
00151 
00152 /*  NIN     (input) INTEGER */
00153 /*          The unit number for input. */
00154 
00155 /*  NOUT    (input) INTEGER */
00156 /*          The unit number for output. */
00157 
00158 /*  INFO    (output) INTEGER */
00159 /*          = 0 :  successful exit */
00160 /*          > 0 :  If DLATMS returns an error code, the absolute value */
00161 /*                 of it is returned. */
00162 
00163 /*  ===================================================================== */
00164 
00165 /*     .. Parameters .. */
00166 /*     .. */
00167 /*     .. Local Scalars .. */
00168 /*     .. */
00169 /*     .. Local Arrays .. */
00170 /*     .. */
00171 /*     .. External Subroutines .. */
00172 /*     .. */
00173 /*     .. Intrinsic Functions .. */
00174 /*     .. */
00175 /*     .. Executable Statements .. */
00176 
00177 /*     Initialize constants and the random number seed. */
00178 
00179     /* Parameter adjustments */
00180     --rwork;
00181     --work;
00182     --x;
00183     --bf;
00184     --b;
00185     --af;
00186     --a;
00187     --iseed;
00188     --nval;
00189     --pval;
00190     --mval;
00191 
00192     /* Function Body */
00193     s_copy(path, "LSE", (ftnlen)3, (ftnlen)3);
00194     *info = 0;
00195     nrun = 0;
00196     nfail = 0;
00197     firstt = TRUE_;
00198     alareq_(path, nmats, dotype, &c__8, nin, nout);
00199     lda = *nmax;
00200     ldb = *nmax;
00201     lwork = *nmax * *nmax;
00202 
00203 /*     Check for valid input values. */
00204 
00205     i__1 = *nn;
00206     for (ik = 1; ik <= i__1; ++ik) {
00207         m = mval[ik];
00208         p = pval[ik];
00209         n = nval[ik];
00210         if (p > n || n > m + p) {
00211             if (firstt) {
00212                 io___13.ciunit = *nout;
00213                 s_wsle(&io___13);
00214                 e_wsle();
00215                 firstt = FALSE_;
00216             }
00217             io___14.ciunit = *nout;
00218             s_wsfe(&io___14);
00219             do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
00220             do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
00221             do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
00222             e_wsfe();
00223         }
00224 /* L10: */
00225     }
00226     firstt = TRUE_;
00227 
00228 /*     Do for each value of M in MVAL. */
00229 
00230     i__1 = *nn;
00231     for (ik = 1; ik <= i__1; ++ik) {
00232         m = mval[ik];
00233         p = pval[ik];
00234         n = nval[ik];
00235         if (p > n || n > m + p) {
00236             goto L40;
00237         }
00238 
00239         for (imat = 1; imat <= 8; ++imat) {
00240 
00241 /*           Do the tests only if DOTYPE( IMAT ) is true. */
00242 
00243             if (! dotype[imat - 1]) {
00244                 goto L30;
00245             }
00246 
00247 /*           Set up parameters with DLATB9 and generate test */
00248 /*           matrices A and B with DLATMS. */
00249 
00250             dlatb9_(path, &imat, &m, &p, &n, type__, &kla, &kua, &klb, &kub, &
00251                     anorm, &bnorm, &modea, &modeb, &cndnma, &cndnmb, dista, 
00252                     distb);
00253 
00254             dlatms_(&m, &n, dista, &iseed[1], type__, &rwork[1], &modea, &
00255                     cndnma, &anorm, &kla, &kua, "No packing", &a[1], &lda, &
00256                     work[1], &iinfo);
00257             if (iinfo != 0) {
00258                 io___30.ciunit = *nout;
00259                 s_wsfe(&io___30);
00260                 do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
00261                 e_wsfe();
00262                 *info = abs(iinfo);
00263                 goto L30;
00264             }
00265 
00266             dlatms_(&p, &n, distb, &iseed[1], type__, &rwork[1], &modeb, &
00267                     cndnmb, &bnorm, &klb, &kub, "No packing", &b[1], &ldb, &
00268                     work[1], &iinfo);
00269             if (iinfo != 0) {
00270                 io___31.ciunit = *nout;
00271                 s_wsfe(&io___31);
00272                 do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
00273                 e_wsfe();
00274                 *info = abs(iinfo);
00275                 goto L30;
00276             }
00277 
00278 /*           Generate the right-hand sides C and D for the LSE. */
00279 
00280 /* Computing MAX */
00281             i__3 = m - 1;
00282             i__2 = max(i__3,0);
00283 /* Computing MAX */
00284             i__5 = n - 1;
00285             i__4 = max(i__5,0);
00286             i__6 = max(n,1);
00287             i__7 = max(m,1);
00288             dlarhs_("DGE", "New solution", "Upper", "N", &m, &n, &i__2, &i__4, 
00289                      &c__1, &a[1], &lda, &x[(*nmax << 2) + 1], &i__6, &x[1], &
00290                     i__7, &iseed[1], &iinfo);
00291 
00292 /* Computing MAX */
00293             i__3 = p - 1;
00294             i__2 = max(i__3,0);
00295 /* Computing MAX */
00296             i__5 = n - 1;
00297             i__4 = max(i__5,0);
00298             i__6 = max(n,1);
00299             i__7 = max(p,1);
00300             dlarhs_("DGE", "Computed", "Upper", "N", &p, &n, &i__2, &i__4, &
00301                     c__1, &b[1], &ldb, &x[(*nmax << 2) + 1], &i__6, &x[(*nmax 
00302                     << 1) + 1], &i__7, &iseed[1], &iinfo);
00303 
00304             nt = 2;
00305 
00306             dlsets_(&m, &p, &n, &a[1], &af[1], &lda, &b[1], &bf[1], &ldb, &x[
00307                     1], &x[*nmax + 1], &x[(*nmax << 1) + 1], &x[*nmax * 3 + 1]
00308 , &x[(*nmax << 2) + 1], &work[1], &lwork, &rwork[1], 
00309                     result);
00310 
00311 /*           Print information about the tests that did not */
00312 /*           pass the threshold. */
00313 
00314             i__2 = nt;
00315             for (i__ = 1; i__ <= i__2; ++i__) {
00316                 if (result[i__ - 1] >= *thresh) {
00317                     if (nfail == 0 && firstt) {
00318                         firstt = FALSE_;
00319                         alahdg_(nout, path);
00320                     }
00321                     io___35.ciunit = *nout;
00322                     s_wsfe(&io___35);
00323                     do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
00324                     do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
00325                     do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
00326                     do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
00327                     do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
00328                     do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen)sizeof(
00329                             doublereal));
00330                     e_wsfe();
00331                     ++nfail;
00332                 }
00333 /* L20: */
00334             }
00335             nrun += nt;
00336 
00337 L30:
00338             ;
00339         }
00340 L40:
00341         ;
00342     }
00343 
00344 /*     Print a summary of the results. */
00345 
00346     alasum_(path, nout, &nfail, &nrun, &c__0);
00347 
00348     return 0;
00349 
00350 /*     End of DCKLSE */
00351 
00352 } /* dcklse_ */


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