alarqg.c

Go to the documentation of this file.

/* alarqg.f -- translated by f2c (version 20061008).
   You must link the resulting object file with libf2c:
        on Microsoft Windows system, link with libf2c.lib;
        on Linux or Unix systems, link with .../path/to/libf2c.a -lm
        or, if you install libf2c.a in a standard place, with -lf2c -lm
        -- in that order, at the end of the command line, as in
                cc *.o -lf2c -lm
        Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,

                http://www.netlib.org/f2c/libf2c.zip
*/

#include "f2c.h"
#include "blaswrap.h"

/* Table of constant values */

static integer c__1 = 1;

/* Subroutine */ int alarqg_(char *path, integer *nmats, logical *dotype, 
        integer *ntypes, integer *nin, integer *nout)
{
    /* Initialized data */

    static char intstr[10] = "0123456789";

    /* Format strings */
    static char fmt_9995[] = "(//\002 *** Not enough matrix types on input l"
            "ine\002,/a79)";
    static char fmt_9994[] = "(\002 ==> Specify \002,i4,\002 matrix types on"
            " this line or \002,\002adjust NTYPES on previous line\002)";
    static char fmt_9996[] = "(//\002 *** Invalid integer value in column"
            " \002,i2,\002 of input\002,\002 line:\002,/a79)";
    static char fmt_9997[] = "(\002 *** Warning:  duplicate request of matri"
            "x type \002,i2,\002 for \002,a3)";
    static char fmt_9999[] = "(\002 *** Invalid type request for \002,a3,"
            "\002, type  \002,i4,\002: must satisfy  1 <= type <= \002,i2)";
    static char fmt_9998[] = "(/\002 *** End of file reached when trying to "
            "read matrix \002,\002types for \002,a3,/\002 *** Check that you "
            "are requesting the\002,\002 right number of types for each pat"
            "h\002,/)";

    /* System generated locals */
    integer i__1;
    cilist ci__1;

    /* Builtin functions */
    integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void),
             i_len(char *, ftnlen), s_wsfe(cilist *), e_wsfe(void), s_wsle(
            cilist *), e_wsle(void);
    /* Subroutine */ int s_stop(char *, ftnlen);

    /* Local variables */
    integer i__, j, k;
    char c1[1];
    integer i1, ic, nt;
    char line[80];
    integer lenp, nreq[100];
    logical firstt;

    /* Fortran I/O blocks */
    static cilist io___9 = { 0, 0, 0, fmt_9995, 0 };
    static cilist io___10 = { 0, 0, 0, fmt_9994, 0 };
    static cilist io___14 = { 0, 0, 0, fmt_9996, 0 };
    static cilist io___15 = { 0, 0, 0, fmt_9994, 0 };
    static cilist io___17 = { 0, 0, 0, 0, 0 };
    static cilist io___18 = { 0, 0, 0, fmt_9997, 0 };
    static cilist io___19 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___20 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___21 = { 0, 0, 0, 0, 0 };



/*  -- LAPACK test routine (version 3.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

/*  Purpose */
/*  ======= */

/*  ALARQG handles input for the LAPACK test program.  It is called */
/*  to evaluate the input line which requested NMATS matrix types for */
/*  PATH.  The flow of control is as follows: */

/*  If NMATS = NTYPES then */
/*     DOTYPE(1:NTYPES) = .TRUE. */
/*  else */
/*     Read the next input line for NMATS matrix types */
/*     Set DOTYPE(I) = .TRUE. for each valid type I */
/*  endif */

/*  Arguments */
/*  ========= */

/*  PATH    (input) CHARACTER*3 */
/*          An LAPACK path name for testing. */

/*  NMATS   (input) INTEGER */
/*          The number of matrix types to be used in testing this path. */

/*  DOTYPE  (output) LOGICAL array, dimension (NTYPES) */
/*          The vector of flags indicating if each type will be tested. */

/*  NTYPES  (input) INTEGER */
/*          The maximum number of matrix types for this path. */

/*  NIN     (input) INTEGER */
/*          The unit number for input.  NIN >= 1. */

/*  NOUT    (input) INTEGER */
/*          The unit number for output.  NOUT >= 1. */

/* ====================================================================== */

/*     .. Local Scalars .. */
/*     .. */
/*     .. Local Arrays .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Data statements .. */
    /* Parameter adjustments */
    --dotype;

    /* Function Body */
/*     .. */
/*     .. Executable Statements .. */

    if (*nmats >= *ntypes) {

/*        Test everything if NMATS >= NTYPES. */

        i__1 = *ntypes;
        for (i__ = 1; i__ <= i__1; ++i__) {
            dotype[i__] = TRUE_;
/* L10: */
        }
    } else {
        i__1 = *ntypes;
        for (i__ = 1; i__ <= i__1; ++i__) {
            dotype[i__] = FALSE_;
/* L20: */
        }
        firstt = TRUE_;

/*        Read a line of matrix types if 0 < NMATS < NTYPES. */

        if (*nmats > 0) {
            ci__1.cierr = 0;
            ci__1.ciend = 1;
            ci__1.ciunit = *nin;
            ci__1.cifmt = "(A80)";
            i__1 = s_rsfe(&ci__1);
            if (i__1 != 0) {
                goto L90;
            }
            i__1 = do_fio(&c__1, line, (ftnlen)80);
            if (i__1 != 0) {
                goto L90;
            }
            i__1 = e_rsfe();
            if (i__1 != 0) {
                goto L90;
            }
            lenp = i_len(line, (ftnlen)80);
            i__ = 0;
            i__1 = *nmats;
            for (j = 1; j <= i__1; ++j) {
                nreq[j - 1] = 0;
                i1 = 0;
L30:
                ++i__;
                if (i__ > lenp) {
                    if (j == *nmats && i1 > 0) {
                        goto L60;
                    } else {
                        io___9.ciunit = *nout;
                        s_wsfe(&io___9);
                        do_fio(&c__1, line, (ftnlen)80);
                        e_wsfe();
                        io___10.ciunit = *nout;
                        s_wsfe(&io___10);
                        do_fio(&c__1, (char *)&(*nmats), (ftnlen)sizeof(
                                integer));
                        e_wsfe();
                        goto L80;
                    }
                }
                if (*(unsigned char *)&line[i__ - 1] != ' ' && *(unsigned 
                        char *)&line[i__ - 1] != ',') {
                    i1 = i__;
                    *(unsigned char *)c1 = *(unsigned char *)&line[i1 - 1];

/*              Check that a valid integer was read */

                    for (k = 1; k <= 10; ++k) {
                        if (*(unsigned char *)c1 == *(unsigned char *)&intstr[
                                k - 1]) {
                            ic = k - 1;
                            goto L50;
                        }
/* L40: */
                    }
                    io___14.ciunit = *nout;
                    s_wsfe(&io___14);
                    do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
                    do_fio(&c__1, line, (ftnlen)80);
                    e_wsfe();
                    io___15.ciunit = *nout;
                    s_wsfe(&io___15);
                    do_fio(&c__1, (char *)&(*nmats), (ftnlen)sizeof(integer));
                    e_wsfe();
                    goto L80;
L50:
                    nreq[j - 1] = nreq[j - 1] * 10 + ic;
                    goto L30;
                } else if (i1 > 0) {
                    goto L60;
                } else {
                    goto L30;
                }
L60:
                ;
            }
        }
        i__1 = *nmats;
        for (i__ = 1; i__ <= i__1; ++i__) {
            nt = nreq[i__ - 1];
            if (nt > 0 && nt <= *ntypes) {
                if (dotype[nt]) {
                    if (firstt) {
                        io___17.ciunit = *nout;
                        s_wsle(&io___17);
                        e_wsle();
                    }
                    firstt = FALSE_;
                    io___18.ciunit = *nout;
                    s_wsfe(&io___18);
                    do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
                    do_fio(&c__1, path, (ftnlen)3);
                    e_wsfe();
                }
                dotype[nt] = TRUE_;
            } else {
                io___19.ciunit = *nout;
                s_wsfe(&io___19);
                do_fio(&c__1, path, (ftnlen)3);
                do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
                do_fio(&c__1, (char *)&(*ntypes), (ftnlen)sizeof(integer));
                e_wsfe();
            }
/* L70: */
        }
L80:
        ;
    }
    return 0;

L90:
    io___20.ciunit = *nout;
    s_wsfe(&io___20);
    do_fio(&c__1, path, (ftnlen)3);
    e_wsfe();
    io___21.ciunit = *nout;
    s_wsle(&io___21);
    e_wsle();
    s_stop("", (ftnlen)0);

/*     End of ALARQG */

    return 0;
} /* alarqg_ */