slafts.c
Go to the documentation of this file.
00001 /* slafts.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__1 = 1;
00019 static integer c__4 = 4;
00020 
00021 /* Subroutine */ int slafts_(char *type__, integer *m, integer *n, integer *
00022         imat, integer *ntests, real *result, integer *iseed, real *thresh, 
00023         integer *iounit, integer *ie)
00024 {
00025     /* Format strings */
00026     static char fmt_9999[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
00027             ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
00028             ",0p,f8.2)";
00029     static char fmt_9998[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
00030             ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
00031             ",1p,e10.3)";
00032     static char fmt_9997[] = "(1x,i5,\002 x\002,i5,\002 matrix, type=\002,"
00033             "i2,\002, s\002,\002eed=\002,3(i4,\002,\002),i4,\002: result \002"
00034             ",i3,\002 is\002,0p,f8.2)";
00035     static char fmt_9996[] = "(1x,i5,\002 x\002,i5,\002 matrix, type=\002,"
00036             "i2,\002, s\002,\002eed=\002,3(i4,\002,\002),i4,\002: result \002"
00037             ",i3,\002 is\002,1p,e10.3)";
00038 
00039     /* System generated locals */
00040     integer i__1;
00041 
00042     /* Builtin functions */
00043     integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
00044 
00045     /* Local variables */
00046     integer k;
00047     extern /* Subroutine */ int slahd2_(integer *, char *);
00048 
00049     /* Fortran I/O blocks */
00050     static cilist io___2 = { 0, 0, 0, fmt_9999, 0 };
00051     static cilist io___3 = { 0, 0, 0, fmt_9998, 0 };
00052     static cilist io___4 = { 0, 0, 0, fmt_9997, 0 };
00053     static cilist io___5 = { 0, 0, 0, fmt_9996, 0 };
00054 
00055 
00056 
00057 /*  -- LAPACK auxiliary test routine (version 3.1.2) -- */
00058 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00059 /*     April 2009 */
00060 
00061 /*     .. Scalar Arguments .. */
00062 /*     .. */
00063 /*     .. Array Arguments .. */
00064 /*     .. */
00065 
00066 /*  Purpose */
00067 /*  ======= */
00068 
00069 /*     SLAFTS tests the result vector against the threshold value to */
00070 /*     see which tests for this matrix type failed to pass the threshold. */
00071 /*     Output is to the file given by unit IOUNIT. */
00072 
00073 /*  Arguments */
00074 /*  ========= */
00075 
00076 /*  TYPE   - CHARACTER*3 */
00077 /*           On entry, TYPE specifies the matrix type to be used in the */
00078 /*           printed messages. */
00079 /*           Not modified. */
00080 
00081 /*  N      - INTEGER */
00082 /*           On entry, N specifies the order of the test matrix. */
00083 /*           Not modified. */
00084 
00085 /*  IMAT   - INTEGER */
00086 /*           On entry, IMAT specifies the type of the test matrix. */
00087 /*           A listing of the different types is printed by SLAHD2 */
00088 /*           to the output file if a test fails to pass the threshold. */
00089 /*           Not modified. */
00090 
00091 /*  NTESTS - INTEGER */
00092 /*           On entry, NTESTS is the number of tests performed on the */
00093 /*           subroutines in the path given by TYPE. */
00094 /*           Not modified. */
00095 
00096 /*  RESULT - REAL               array of dimension( NTESTS ) */
00097 /*           On entry, RESULT contains the test ratios from the tests */
00098 /*           performed in the calling program. */
00099 /*           Not modified. */
00100 
00101 /*  ISEED  - INTEGER            array of dimension( 4 ) */
00102 /*           Contains the random seed that generated the matrix used */
00103 /*           for the tests whose ratios are in RESULT. */
00104 /*           Not modified. */
00105 
00106 /*  THRESH - REAL */
00107 /*           On entry, THRESH specifies the acceptable threshold of the */
00108 /*           test ratios.  If RESULT( K ) > THRESH, then the K-th test */
00109 /*           did not pass the threshold and a message will be printed. */
00110 /*           Not modified. */
00111 
00112 /*  IOUNIT - INTEGER */
00113 /*           On entry, IOUNIT specifies the unit number of the file */
00114 /*           to which the messages are printed. */
00115 /*           Not modified. */
00116 
00117 /*  IE     - INTEGER */
00118 /*           On entry, IE contains the number of tests which have */
00119 /*           failed to pass the threshold so far. */
00120 /*           Updated on exit if any of the ratios in RESULT also fail. */
00121 
00122 /*  ===================================================================== */
00123 
00124 /*     .. Local Scalars .. */
00125 /*     .. */
00126 /*     .. External Subroutines .. */
00127 /*     .. */
00128 /*     .. Executable Statements .. */
00129 
00130     /* Parameter adjustments */
00131     --iseed;
00132     --result;
00133 
00134     /* Function Body */
00135     if (*m == *n) {
00136 
00137 /*     Output for square matrices: */
00138 
00139         i__1 = *ntests;
00140         for (k = 1; k <= i__1; ++k) {
00141             if (result[k] >= *thresh) {
00142 
00143 /*           If this is the first test to fail, call SLAHD2 */
00144 /*           to print a header to the data file. */
00145 
00146                 if (*ie == 0) {
00147                     slahd2_(iounit, type__);
00148                 }
00149                 ++(*ie);
00150                 if (result[k] < 1e4f) {
00151                     io___2.ciunit = *iounit;
00152                     s_wsfe(&io___2);
00153                     do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
00154                     do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
00155                     do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
00156                     do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
00157                     do_fio(&c__1, (char *)&result[k], (ftnlen)sizeof(real));
00158                     e_wsfe();
00159                 } else {
00160                     io___3.ciunit = *iounit;
00161                     s_wsfe(&io___3);
00162                     do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
00163                     do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
00164                     do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
00165                     do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
00166                     do_fio(&c__1, (char *)&result[k], (ftnlen)sizeof(real));
00167                     e_wsfe();
00168                 }
00169             }
00170 /* L10: */
00171         }
00172     } else {
00173 
00174 /*     Output for rectangular matrices */
00175 
00176         i__1 = *ntests;
00177         for (k = 1; k <= i__1; ++k) {
00178             if (result[k] >= *thresh) {
00179 
00180 /*              If this is the first test to fail, call SLAHD2 */
00181 /*              to print a header to the data file. */
00182 
00183                 if (*ie == 0) {
00184                     slahd2_(iounit, type__);
00185                 }
00186                 ++(*ie);
00187                 if (result[k] < 1e4f) {
00188                     io___4.ciunit = *iounit;
00189                     s_wsfe(&io___4);
00190                     do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
00191                     do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
00192                     do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
00193                     do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
00194                     do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
00195                     do_fio(&c__1, (char *)&result[k], (ftnlen)sizeof(real));
00196                     e_wsfe();
00197                 } else {
00198                     io___5.ciunit = *iounit;
00199                     s_wsfe(&io___5);
00200                     do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
00201                     do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
00202                     do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
00203                     do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
00204                     do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
00205                     do_fio(&c__1, (char *)&result[k], (ftnlen)sizeof(real));
00206                     e_wsfe();
00207                 }
00208             }
00209 /* L20: */
00210         }
00211 
00212     }
00213     return 0;
00214 
00215 /*     End of SLAFTS */
00216 
00217 } /* slafts_ */


swiftnav
Author(s):
autogenerated on Sat Jun 8 2019 18:56:10