alareq.c
Go to the documentation of this file.
00001 /* alareq.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 
00020 /* Subroutine */ int alareq_(char *path, integer *nmats, logical *dotype, 
00021         integer *ntypes, integer *nin, integer *nout)
00022 {
00023     /* Initialized data */
00024 
00025     static char intstr[10] = "0123456789";
00026 
00027     /* Format strings */
00028     static char fmt_9995[] = "(//\002 *** Not enough matrix types on input l"
00029             "ine\002,/a79)";
00030     static char fmt_9994[] = "(\002 ==> Specify \002,i4,\002 matrix types on"
00031             " this line or \002,\002adjust NTYPES on previous line\002)";
00032     static char fmt_9996[] = "(//\002 *** Invalid integer value in column"
00033             " \002,i2,\002 of input\002,\002 line:\002,/a79)";
00034     static char fmt_9997[] = "(\002 *** Warning:  duplicate request of matri"
00035             "x type \002,i2,\002 for \002,a3)";
00036     static char fmt_9999[] = "(\002 *** Invalid type request for \002,a3,"
00037             "\002, type  \002,i4,\002: must satisfy  1 <= type <= \002,i2)";
00038     static char fmt_9998[] = "(/\002 *** End of file reached when trying to "
00039             "read matrix \002,\002types for \002,a3,/\002 *** Check that you "
00040             "are requesting the\002,\002 right number of types for each pat"
00041             "h\002,/)";
00042 
00043     /* System generated locals */
00044     integer i__1;
00045     cilist ci__1;
00046 
00047     /* Builtin functions */
00048     integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void),
00049              i_len(char *, ftnlen), s_wsfe(cilist *), e_wsfe(void), s_wsle(
00050             cilist *), e_wsle(void);
00051     /* Subroutine */ int s_stop(char *, ftnlen);
00052 
00053     /* Local variables */
00054     integer i__, j, k;
00055     char c1[1];
00056     integer i1, ic, nt;
00057     char line[80];
00058     integer lenp, nreq[100];
00059     logical firstt;
00060 
00061     /* Fortran I/O blocks */
00062     static cilist io___9 = { 0, 0, 0, fmt_9995, 0 };
00063     static cilist io___10 = { 0, 0, 0, fmt_9994, 0 };
00064     static cilist io___14 = { 0, 0, 0, fmt_9996, 0 };
00065     static cilist io___15 = { 0, 0, 0, fmt_9994, 0 };
00066     static cilist io___17 = { 0, 0, 0, 0, 0 };
00067     static cilist io___18 = { 0, 0, 0, fmt_9997, 0 };
00068     static cilist io___19 = { 0, 0, 0, fmt_9999, 0 };
00069     static cilist io___20 = { 0, 0, 0, fmt_9998, 0 };
00070     static cilist io___21 = { 0, 0, 0, 0, 0 };
00071 
00072 
00073 
00074 /*  -- LAPACK test routine (version 3.1) -- */
00075 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00076 /*     November 2006 */
00077 
00078 /*     .. Scalar Arguments .. */
00079 /*     .. */
00080 /*     .. Array Arguments .. */
00081 /*     .. */
00082 
00083 /*  Purpose */
00084 /*  ======= */
00085 
00086 /*  ALAREQ handles input for the LAPACK test program.  It is called */
00087 /*  to evaluate the input line which requested NMATS matrix types for */
00088 /*  PATH.  The flow of control is as follows: */
00089 
00090 /*  If NMATS = NTYPES then */
00091 /*     DOTYPE(1:NTYPES) = .TRUE. */
00092 /*  else */
00093 /*     Read the next input line for NMATS matrix types */
00094 /*     Set DOTYPE(I) = .TRUE. for each valid type I */
00095 /*  endif */
00096 
00097 /*  Arguments */
00098 /*  ========= */
00099 
00100 /*  PATH    (input) CHARACTER*3 */
00101 /*          An LAPACK path name for testing. */
00102 
00103 /*  NMATS   (input) INTEGER */
00104 /*          The number of matrix types to be used in testing this path. */
00105 
00106 /*  DOTYPE  (output) LOGICAL array, dimension (NTYPES) */
00107 /*          The vector of flags indicating if each type will be tested. */
00108 
00109 /*  NTYPES  (input) INTEGER */
00110 /*          The maximum number of matrix types for this path. */
00111 
00112 /*  NIN     (input) INTEGER */
00113 /*          The unit number for input.  NIN >= 1. */
00114 
00115 /*  NOUT    (input) INTEGER */
00116 /*          The unit number for output.  NOUT >= 1. */
00117 
00118 /*  ===================================================================== */
00119 
00120 /*     .. Local Scalars .. */
00121 /*     .. */
00122 /*     .. Local Arrays .. */
00123 /*     .. */
00124 /*     .. Intrinsic Functions .. */
00125 /*     .. */
00126 /*     .. Data statements .. */
00127     /* Parameter adjustments */
00128     --dotype;
00129 
00130     /* Function Body */
00131 /*     .. */
00132 /*     .. Executable Statements .. */
00133 
00134     if (*nmats >= *ntypes) {
00135 
00136 /*        Test everything if NMATS >= NTYPES. */
00137 
00138         i__1 = *ntypes;
00139         for (i__ = 1; i__ <= i__1; ++i__) {
00140             dotype[i__] = TRUE_;
00141 /* L10: */
00142         }
00143     } else {
00144         i__1 = *ntypes;
00145         for (i__ = 1; i__ <= i__1; ++i__) {
00146             dotype[i__] = FALSE_;
00147 /* L20: */
00148         }
00149         firstt = TRUE_;
00150 
00151 /*        Read a line of matrix types if 0 < NMATS < NTYPES. */
00152 
00153         if (*nmats > 0) {
00154             ci__1.cierr = 0;
00155             ci__1.ciend = 1;
00156             ci__1.ciunit = *nin;
00157             ci__1.cifmt = "(A80)";
00158             i__1 = s_rsfe(&ci__1);
00159             if (i__1 != 0) {
00160                 goto L90;
00161             }
00162             i__1 = do_fio(&c__1, line, (ftnlen)80);
00163             if (i__1 != 0) {
00164                 goto L90;
00165             }
00166             i__1 = e_rsfe();
00167             if (i__1 != 0) {
00168                 goto L90;
00169             }
00170             lenp = i_len(line, (ftnlen)80);
00171             i__ = 0;
00172             i__1 = *nmats;
00173             for (j = 1; j <= i__1; ++j) {
00174                 nreq[j - 1] = 0;
00175                 i1 = 0;
00176 L30:
00177                 ++i__;
00178                 if (i__ > lenp) {
00179                     if (j == *nmats && i1 > 0) {
00180                         goto L60;
00181                     } else {
00182                         io___9.ciunit = *nout;
00183                         s_wsfe(&io___9);
00184                         do_fio(&c__1, line, (ftnlen)80);
00185                         e_wsfe();
00186                         io___10.ciunit = *nout;
00187                         s_wsfe(&io___10);
00188                         do_fio(&c__1, (char *)&(*nmats), (ftnlen)sizeof(
00189                                 integer));
00190                         e_wsfe();
00191                         goto L80;
00192                     }
00193                 }
00194                 if (*(unsigned char *)&line[i__ - 1] != ' ' && *(unsigned 
00195                         char *)&line[i__ - 1] != ',') {
00196                     i1 = i__;
00197                     *(unsigned char *)c1 = *(unsigned char *)&line[i1 - 1];
00198 
00199 /*              Check that a valid integer was read */
00200 
00201                     for (k = 1; k <= 10; ++k) {
00202                         if (*(unsigned char *)c1 == *(unsigned char *)&intstr[
00203                                 k - 1]) {
00204                             ic = k - 1;
00205                             goto L50;
00206                         }
00207 /* L40: */
00208                     }
00209                     io___14.ciunit = *nout;
00210                     s_wsfe(&io___14);
00211                     do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
00212                     do_fio(&c__1, line, (ftnlen)80);
00213                     e_wsfe();
00214                     io___15.ciunit = *nout;
00215                     s_wsfe(&io___15);
00216                     do_fio(&c__1, (char *)&(*nmats), (ftnlen)sizeof(integer));
00217                     e_wsfe();
00218                     goto L80;
00219 L50:
00220                     nreq[j - 1] = nreq[j - 1] * 10 + ic;
00221                     goto L30;
00222                 } else if (i1 > 0) {
00223                     goto L60;
00224                 } else {
00225                     goto L30;
00226                 }
00227 L60:
00228                 ;
00229             }
00230         }
00231         i__1 = *nmats;
00232         for (i__ = 1; i__ <= i__1; ++i__) {
00233             nt = nreq[i__ - 1];
00234             if (nt > 0 && nt <= *ntypes) {
00235                 if (dotype[nt]) {
00236                     if (firstt) {
00237                         io___17.ciunit = *nout;
00238                         s_wsle(&io___17);
00239                         e_wsle();
00240                     }
00241                     firstt = FALSE_;
00242                     io___18.ciunit = *nout;
00243                     s_wsfe(&io___18);
00244                     do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
00245                     do_fio(&c__1, path, (ftnlen)3);
00246                     e_wsfe();
00247                 }
00248                 dotype[nt] = TRUE_;
00249             } else {
00250                 io___19.ciunit = *nout;
00251                 s_wsfe(&io___19);
00252                 do_fio(&c__1, path, (ftnlen)3);
00253                 do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
00254                 do_fio(&c__1, (char *)&(*ntypes), (ftnlen)sizeof(integer));
00255                 e_wsfe();
00256             }
00257 /* L70: */
00258         }
00259 L80:
00260         ;
00261     }
00262     return 0;
00263 
00264 L90:
00265     io___20.ciunit = *nout;
00266     s_wsfe(&io___20);
00267     do_fio(&c__1, path, (ftnlen)3);
00268     e_wsfe();
00269     io___21.ciunit = *nout;
00270     s_wsle(&io___21);
00271     e_wsle();
00272     s_stop("", (ftnlen)0);
00273 
00274 /*     End of ALAREQ */
00275 
00276     return 0;
00277 } /* alareq_ */


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