/* sblat2.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"
/* Common Block Declarations */
union {
struct {
integer infot, noutc;
logical ok, lerr;
} _1;
struct {
integer infot, nout;
logical ok, lerr;
} _2;
} infoc_;
#define infoc_1 (infoc_._1)
#define infoc_2 (infoc_._2)
struct {
char srnamt[6];
} srnamc_;
#define srnamc_1 srnamc_
/* Table of constant values */
static integer c__9 = 9;
static integer c__1 = 1;
static integer c__3 = 3;
static integer c__8 = 8;
static integer c__4 = 4;
static integer c__65 = 65;
static integer c__7 = 7;
static integer c__2 = 2;
static real c_b121 = 1.f;
static real c_b133 = 0.f;
static logical c_true = TRUE_;
static integer c_n1 = -1;
static integer c__0 = 0;
static logical c_false = FALSE_;
/* Main program */ int MAIN__(void)
{
/* Initialized data */
static char snames[6*16] = "SGEMV " "SGBMV " "SSYMV " "SSBMV " "SSPMV "
"STRMV " "STBMV " "STPMV " "STRSV " "STBSV " "STPSV " "SGER "
"SSYR " "SSPR " "SSYR2 " "SSPR2 ";
/* Format strings */
static char fmt_9997[] = "(\002 NUMBER OF VALUES OF \002,a,\002 IS LESS "
"THAN 1 OR GREATER \002,\002THAN \002,i2)";
static char fmt_9996[] = "(\002 VALUE OF N IS LESS THAN 0 OR GREATER THA"
"N \002,i2)";
static char fmt_9995[] = "(\002 VALUE OF K IS LESS THAN 0\002)";
static char fmt_9994[] = "(\002 ABSOLUTE VALUE OF INCX OR INCY IS 0 OR G"
"REATER THAN \002,i2)";
static char fmt_9993[] = "(\002 TESTS OF THE REAL LEVEL 2 BL"
"AS\002,//\002 THE F\002,\002OLLOWING PARAMETER VALUES WILL BE US"
"ED:\002)";
static char fmt_9992[] = "(\002 FOR N \002,9i6)";
static char fmt_9991[] = "(\002 FOR K \002,7i6)";
static char fmt_9990[] = "(\002 FOR INCX AND INCY \002,7i6)";
static char fmt_9989[] = "(\002 FOR ALPHA \002,7f6.1)";
static char fmt_9988[] = "(\002 FOR BETA \002,7f6.1)";
static char fmt_9980[] = "(\002 ERROR-EXITS WILL NOT BE TESTED\002)";
static char fmt_9999[] = "(\002 ROUTINES PASS COMPUTATIONAL TESTS IF TES"
"T RATIO IS LES\002,\002S THAN\002,f8.2)";
static char fmt_9984[] = "(a6,l2)";
static char fmt_9986[] = "(\002 SUBPROGRAM NAME \002,a6,\002 NOT RECOGNI"
"ZED\002,/\002 ******* T\002,\002ESTS ABANDONED *******\002)";
static char fmt_9998[] = "(\002 RELATIVE MACHINE PRECISION IS TAKEN TO"
" BE\002,1p,e9.1)";
static char fmt_9985[] = "(\002 ERROR IN SMVCH - IN-LINE DOT PRODUCTS A"
"RE BEING EVALU\002,\002ATED WRONGLY.\002,/\002 SMVCH WAS CALLED "
"WITH TRANS = \002,a1,\002 AND RETURNED SAME = \002,l1,\002 AND E"
"RR = \002,f12.3,\002.\002,/\002 THIS MAY BE DUE TO FAULTS IN THE"
" ARITHMETIC OR THE COMPILER.\002,/\002 ******* TESTS ABANDONED *"
"******\002)";
static char fmt_9983[] = "(1x,a6,\002 WAS NOT TESTED\002)";
static char fmt_9982[] = "(/\002 END OF TESTS\002)";
static char fmt_9981[] = "(/\002 ******* FATAL ERROR - TESTS ABANDONED *"
"******\002)";
static char fmt_9987[] = "(\002 AMEND DATA FILE OR INCREASE ARRAY SIZES "
"IN PROGRAM\002,/\002 ******* TESTS ABANDONED *******\002)";
/* System generated locals */
integer i__1, i__2, i__3;
real r__1;
olist o__1;
cllist cl__1;
/* Builtin functions */
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void), f_open(olist *), s_wsfe(cilist *), do_fio(integer *,
char *, ftnlen), e_wsfe(void), s_wsle(cilist *), e_wsle(void),
s_rsfe(cilist *), e_rsfe(void), s_cmp(char *, char *, ftnlen,
ftnlen);
/* Subroutine */ int s_stop(char *, ftnlen);
integer f_clos(cllist *);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
real a[4225] /* was [65][65] */, g[65];
integer i__, j, n;
real x[65], y[65], z__[130], aa[4225];
integer kb[7];
real as[4225], xs[130], ys[130], yt[65], xx[130], yy[130], alf[7];
integer inc[7], nkb;
real bet[7];
extern logical lse_(real *, real *, integer *);
real eps, err;
integer nalf, idim[9];
logical same;
integer ninc, nbet, ntra;
logical rewi;
integer nout;
extern /* Subroutine */ int schk1_(char *, real *, real *, integer *,
integer *, logical *, logical *, logical *, integer *, integer *,
integer *, integer *, integer *, real *, integer *, real *,
integer *, integer *, integer *, integer *, real *, real *, real *
, real *, real *, real *, real *, real *, real *, real *, real *,
ftnlen), schk2_(char *, real *, real *, integer *, integer *,
logical *, logical *, logical *, integer *, integer *, integer *,
integer *, integer *, real *, integer *, real *, integer *,
integer *, integer *, integer *, real *, real *, real *, real *,
real *, real *, real *, real *, real *, real *, real *, ftnlen),
schk3_(char *, real *, real *, integer *, integer *, logical *,
logical *, logical *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, real *, real *, real *
, real *, real *, real *, real *, real *, real *, ftnlen), schk4_(
char *, real *, real *, integer *, integer *, logical *, logical *
, logical *, integer *, integer *, integer *, real *, integer *,
integer *, integer *, integer *, real *, real *, real *, real *,
real *, real *, real *, real *, real *, real *, real *, real *,
ftnlen), schk5_(char *, real *, real *, integer *, integer *,
logical *, logical *, logical *, integer *, integer *, integer *,
real *, integer *, integer *, integer *, integer *, real *, real *
, real *, real *, real *, real *, real *, real *, real *, real *,
real *, real *, ftnlen), schk6_(char *, real *, real *, integer *,
integer *, logical *, logical *, logical *, integer *, integer *,
integer *, real *, integer *, integer *, integer *, integer *,
real *, real *, real *, real *, real *, real *, real *, real *,
real *, real *, real *, real *, ftnlen);
logical fatal;
extern doublereal sdiff_(real *, real *);
extern /* Subroutine */ int schke_(integer *, char *, integer *, ftnlen);
logical trace;
integer nidim;
extern /* Subroutine */ int smvch_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *,
real *, real *, real *, real *, real *, logical *, integer *,
logical *, ftnlen);
char snaps[32], trans[1];
integer isnum;
logical ltest[16], sfatal;
char snamet[6];
real thresh;
logical ltestt, tsterr;
char summry[32];
/* Fortran I/O blocks */
static cilist io___2 = { 0, 5, 0, 0, 0 };
static cilist io___4 = { 0, 5, 0, 0, 0 };
static cilist io___6 = { 0, 5, 0, 0, 0 };
static cilist io___8 = { 0, 5, 0, 0, 0 };
static cilist io___11 = { 0, 5, 0, 0, 0 };
static cilist io___13 = { 0, 5, 0, 0, 0 };
static cilist io___15 = { 0, 5, 0, 0, 0 };
static cilist io___17 = { 0, 5, 0, 0, 0 };
static cilist io___19 = { 0, 5, 0, 0, 0 };
static cilist io___21 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___22 = { 0, 5, 0, 0, 0 };
static cilist io___25 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___26 = { 0, 5, 0, 0, 0 };
static cilist io___28 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___29 = { 0, 5, 0, 0, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___32 = { 0, 5, 0, 0, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___35 = { 0, 5, 0, 0, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___38 = { 0, 5, 0, 0, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___41 = { 0, 5, 0, 0, 0 };
static cilist io___43 = { 0, 5, 0, 0, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___46 = { 0, 5, 0, 0, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9990, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9989, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9988, 0 };
static cilist io___54 = { 0, 0, 0, 0, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9980, 0 };
static cilist io___56 = { 0, 0, 0, 0, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___58 = { 0, 0, 0, 0, 0 };
static cilist io___60 = { 0, 5, 1, fmt_9984, 0 };
static cilist io___63 = { 0, 0, 0, fmt_9986, 0 };
static cilist io___65 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___78 = { 0, 0, 0, fmt_9985, 0 };
static cilist io___79 = { 0, 0, 0, fmt_9985, 0 };
static cilist io___81 = { 0, 0, 0, 0, 0 };
static cilist io___82 = { 0, 0, 0, fmt_9983, 0 };
static cilist io___83 = { 0, 0, 0, 0, 0 };
static cilist io___90 = { 0, 0, 0, fmt_9982, 0 };
static cilist io___91 = { 0, 0, 0, fmt_9981, 0 };
static cilist io___92 = { 0, 0, 0, fmt_9987, 0 };
/* Test program for the REAL Level 2 Blas. */
/* The program must be driven by a short data file. The first 18 records */
/* of the file are read using list-directed input, the last 16 records */
/* are read using the format ( A6, L2 ). An annotated example of a data */
/* file can be obtained by deleting the first 3 characters from the */
/* following 34 lines: */
/* 'sblat2.out' NAME OF SUMMARY OUTPUT FILE */
/* 6 UNIT NUMBER OF SUMMARY FILE */
/* 'SBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE */
/* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) */
/* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. */
/* F LOGICAL FLAG, T TO STOP ON FAILURES. */
/* T LOGICAL FLAG, T TO TEST ERROR EXITS. */
/* 16.0 THRESHOLD VALUE OF TEST RATIO */
/* 6 NUMBER OF VALUES OF N */
/* 0 1 2 3 5 9 VALUES OF N */
/* 4 NUMBER OF VALUES OF K */
/* 0 1 2 4 VALUES OF K */
/* 4 NUMBER OF VALUES OF INCX AND INCY */
/* 1 2 -1 -2 VALUES OF INCX AND INCY */
/* 3 NUMBER OF VALUES OF ALPHA */
/* 0.0 1.0 0.7 VALUES OF ALPHA */
/* 3 NUMBER OF VALUES OF BETA */
/* 0.0 1.0 0.9 VALUES OF BETA */
/* SGEMV T PUT F FOR NO TEST. SAME COLUMNS. */
/* SGBMV T PUT F FOR NO TEST. SAME COLUMNS. */
/* SSYMV T PUT F FOR NO TEST. SAME COLUMNS. */
/* SSBMV T PUT F FOR NO TEST. SAME COLUMNS. */
/* SSPMV T PUT F FOR NO TEST. SAME COLUMNS. */
/* STRMV T PUT F FOR NO TEST. SAME COLUMNS. */
/* STBMV T PUT F FOR NO TEST. SAME COLUMNS. */
/* STPMV T PUT F FOR NO TEST. SAME COLUMNS. */
/* STRSV T PUT F FOR NO TEST. SAME COLUMNS. */
/* STBSV T PUT F FOR NO TEST. SAME COLUMNS. */
/* STPSV T PUT F FOR NO TEST. SAME COLUMNS. */
/* SGER T PUT F FOR NO TEST. SAME COLUMNS. */
/* SSYR T PUT F FOR NO TEST. SAME COLUMNS. */
/* SSPR T PUT F FOR NO TEST. SAME COLUMNS. */
/* SSYR2 T PUT F FOR NO TEST. SAME COLUMNS. */
/* SSPR2 T PUT F FOR NO TEST. SAME COLUMNS. */
/* See: */
/* Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J.. */
/* An extended set of Fortran Basic Linear Algebra Subprograms. */
/* Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics */
/* and Computer Science Division, Argonne National Laboratory, */
/* 9700 South Cass Avenue, Argonne, Illinois 60439, US. */
/* Or */
/* NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms */
/* Group Ltd., NAG Central Office, 256 Banbury Road, Oxford */
/* OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st */
/* Street, Suite 100, Downers Grove, Illinois 60515-1263, USA. */
/* -- Written on 10-August-1987. */
/* Richard Hanson, Sandia National Labs. */
/* Jeremy Du Croz, NAG Central Office. */
/* 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers */
/* can be run multiple times without deleting generated */
/* output files (susan) */
/* .. Parameters .. */
/* .. Local Scalars .. */
/* .. Local Arrays .. */
/* .. External Functions .. */
/* .. External Subroutines .. */
/* .. Intrinsic Functions .. */
/* .. Scalars in Common .. */
/* .. Common blocks .. */
/* .. Data statements .. */
/* .. Executable Statements .. */
/* Read name and unit number for summary output file and open file. */
s_rsle(&io___2);
do_lio(&c__9, &c__1, summry, (ftnlen)32);
e_rsle();
s_rsle(&io___4);
do_lio(&c__3, &c__1, (char *)&nout, (ftnlen)sizeof(integer));
e_rsle();
o__1.oerr = 0;
o__1.ounit = nout;
o__1.ofnmlen = 32;
o__1.ofnm = summry;
o__1.orl = 0;
o__1.osta = "UNKNOWN";
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = 0;
f_open(&o__1);
infoc_1.noutc = nout;
/* Read name and unit number for snapshot output file and open file. */
s_rsle(&io___6);
do_lio(&c__9, &c__1, snaps, (ftnlen)32);
e_rsle();
s_rsle(&io___8);
do_lio(&c__3, &c__1, (char *)&ntra, (ftnlen)sizeof(integer));
e_rsle();
trace = ntra >= 0;
if (trace) {
o__1.oerr = 0;
o__1.ounit = ntra;
o__1.ofnmlen = 32;
o__1.ofnm = snaps;
o__1.orl = 0;
o__1.osta = "UNKNOWN";
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = 0;
f_open(&o__1);
}
/* Read the flag that directs rewinding of the snapshot file. */
s_rsle(&io___11);
do_lio(&c__8, &c__1, (char *)&rewi, (ftnlen)sizeof(logical));
e_rsle();
rewi = rewi && trace;
/* Read the flag that directs stopping on any failure. */
s_rsle(&io___13);
do_lio(&c__8, &c__1, (char *)&sfatal, (ftnlen)sizeof(logical));
e_rsle();
/* Read the flag that indicates whether error exits are to be tested. */
s_rsle(&io___15);
do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
e_rsle();
/* Read the threshold value of the test ratio */
s_rsle(&io___17);
do_lio(&c__4, &c__1, (char *)&thresh, (ftnlen)sizeof(real));
e_rsle();
/* Read and check the parameter values for the tests. */
/* Values of N */
s_rsle(&io___19);
do_lio(&c__3, &c__1, (char *)&nidim, (ftnlen)sizeof(integer));
e_rsle();
if (nidim < 1 || nidim > 9) {
io___21.ciunit = nout;
s_wsfe(&io___21);
do_fio(&c__1, "N", (ftnlen)1);
do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
e_wsfe();
goto L230;
}
s_rsle(&io___22);
i__1 = nidim;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
}
e_rsle();
i__1 = nidim;
for (i__ = 1; i__ <= i__1; ++i__) {
if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) {
io___25.ciunit = nout;
s_wsfe(&io___25);
do_fio(&c__1, (char *)&c__65, (ftnlen)sizeof(integer));
e_wsfe();
goto L230;
}
/* L10: */
}
/* Values of K */
s_rsle(&io___26);
do_lio(&c__3, &c__1, (char *)&nkb, (ftnlen)sizeof(integer));
e_rsle();
if (nkb < 1 || nkb > 7) {
io___28.ciunit = nout;
s_wsfe(&io___28);
do_fio(&c__1, "K", (ftnlen)1);
do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
e_wsfe();
goto L230;
}
s_rsle(&io___29);
i__1 = nkb;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&kb[i__ - 1], (ftnlen)sizeof(integer));
}
e_rsle();
i__1 = nkb;
for (i__ = 1; i__ <= i__1; ++i__) {
if (kb[i__ - 1] < 0) {
io___31.ciunit = nout;
s_wsfe(&io___31);
e_wsfe();
goto L230;
}
/* L20: */
}
/* Values of INCX and INCY */
s_rsle(&io___32);
do_lio(&c__3, &c__1, (char *)&ninc, (ftnlen)sizeof(integer));
e_rsle();
if (ninc < 1 || ninc > 7) {
io___34.ciunit = nout;
s_wsfe(&io___34);
do_fio(&c__1, "INCX AND INCY", (ftnlen)13);
do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
e_wsfe();
goto L230;
}
s_rsle(&io___35);
i__1 = ninc;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&inc[i__ - 1], (ftnlen)sizeof(integer));
}
e_rsle();
i__1 = ninc;
for (i__ = 1; i__ <= i__1; ++i__) {
if (inc[i__ - 1] == 0 || (i__2 = inc[i__ - 1], abs(i__2)) > 2) {
io___37.ciunit = nout;
s_wsfe(&io___37);
do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
e_wsfe();
goto L230;
}
/* L30: */
}
/* Values of ALPHA */
s_rsle(&io___38);
do_lio(&c__3, &c__1, (char *)&nalf, (ftnlen)sizeof(integer));
e_rsle();
if (nalf < 1 || nalf > 7) {
io___40.ciunit = nout;
s_wsfe(&io___40);
do_fio(&c__1, "ALPHA", (ftnlen)5);
do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
e_wsfe();
goto L230;
}
s_rsle(&io___41);
i__1 = nalf;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__4, &c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(real));
}
e_rsle();
/* Values of BETA */
s_rsle(&io___43);
do_lio(&c__3, &c__1, (char *)&nbet, (ftnlen)sizeof(integer));
e_rsle();
if (nbet < 1 || nbet > 7) {
io___45.ciunit = nout;
s_wsfe(&io___45);
do_fio(&c__1, "BETA", (ftnlen)4);
do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
e_wsfe();
goto L230;
}
s_rsle(&io___46);
i__1 = nbet;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__4, &c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(real));
}
e_rsle();
/* Report values of parameters. */
io___48.ciunit = nout;
s_wsfe(&io___48);
e_wsfe();
io___49.ciunit = nout;
s_wsfe(&io___49);
i__1 = nidim;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
io___50.ciunit = nout;
s_wsfe(&io___50);
i__1 = nkb;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&kb[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
io___51.ciunit = nout;
s_wsfe(&io___51);
i__1 = ninc;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&inc[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
io___52.ciunit = nout;
s_wsfe(&io___52);
i__1 = nalf;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(real));
}
e_wsfe();
io___53.ciunit = nout;
s_wsfe(&io___53);
i__1 = nbet;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(real));
}
e_wsfe();
if (! tsterr) {
io___54.ciunit = nout;
s_wsle(&io___54);
e_wsle();
io___55.ciunit = nout;
s_wsfe(&io___55);
e_wsfe();
}
io___56.ciunit = nout;
s_wsle(&io___56);
e_wsle();
io___57.ciunit = nout;
s_wsfe(&io___57);
do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(real));
e_wsfe();
io___58.ciunit = nout;
s_wsle(&io___58);
e_wsle();
/* Read names of subroutines and flags which indicate */
/* whether they are to be tested. */
for (i__ = 1; i__ <= 16; ++i__) {
ltest[i__ - 1] = FALSE_;
/* L40: */
}
L50:
i__1 = s_rsfe(&io___60);
if (i__1 != 0) {
goto L80;
}
i__1 = do_fio(&c__1, snamet, (ftnlen)6);
if (i__1 != 0) {
goto L80;
}
i__1 = do_fio(&c__1, (char *)<estt, (ftnlen)sizeof(logical));
if (i__1 != 0) {
goto L80;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L80;
}
for (i__ = 1; i__ <= 16; ++i__) {
if (s_cmp(snamet, snames + (i__ - 1) * 6, (ftnlen)6, (ftnlen)6) == 0)
{
goto L70;
}
/* L60: */
}
io___63.ciunit = nout;
s_wsfe(&io___63);
do_fio(&c__1, snamet, (ftnlen)6);
e_wsfe();
s_stop("", (ftnlen)0);
L70:
ltest[i__ - 1] = ltestt;
goto L50;
L80:
cl__1.cerr = 0;
cl__1.cunit = 5;
cl__1.csta = 0;
f_clos(&cl__1);
/* Compute EPS (the machine precision). */
eps = 1.f;
L90:
r__1 = eps + 1.f;
if (sdiff_(&r__1, &c_b121) == 0.f) {
goto L100;
}
eps *= .5f;
goto L90;
L100:
eps += eps;
io___65.ciunit = nout;
s_wsfe(&io___65);
do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
e_wsfe();
/* Check the reliability of SMVCH using exact data. */
n = 32;
i__1 = n;
for (j = 1; j <= i__1; ++j) {
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = i__ - j + 1;
a[i__ + j * 65 - 66] = (real) max(i__3,0);
/* L110: */
}
x[j - 1] = (real) j;
y[j - 1] = 0.f;
/* L120: */
}
i__1 = n;
for (j = 1; j <= i__1; ++j) {
yy[j - 1] = (real) (j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3)
;
/* L130: */
}
/* YY holds the exact result. On exit from SMVCH YT holds */
/* the result computed by SMVCH. */
*(unsigned char *)trans = 'N';
smvch_(trans, &n, &n, &c_b121, a, &c__65, x, &c__1, &c_b133, y, &c__1, yt,
g, yy, &eps, &err, &fatal, &nout, &c_true, (ftnlen)1);
same = lse_(yy, yt, &n);
if (! same || err != 0.f) {
io___78.ciunit = nout;
s_wsfe(&io___78);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
e_wsfe();
s_stop("", (ftnlen)0);
}
*(unsigned char *)trans = 'T';
smvch_(trans, &n, &n, &c_b121, a, &c__65, x, &c_n1, &c_b133, y, &c_n1, yt,
g, yy, &eps, &err, &fatal, &nout, &c_true, (ftnlen)1);
same = lse_(yy, yt, &n);
if (! same || err != 0.f) {
io___79.ciunit = nout;
s_wsfe(&io___79);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
e_wsfe();
s_stop("", (ftnlen)0);
}
/* Test each subroutine in turn. */
for (isnum = 1; isnum <= 16; ++isnum) {
io___81.ciunit = nout;
s_wsle(&io___81);
e_wsle();
if (! ltest[isnum - 1]) {
/* Subprogram is not to be tested. */
io___82.ciunit = nout;
s_wsfe(&io___82);
do_fio(&c__1, snames + (isnum - 1) * 6, (ftnlen)6);
e_wsfe();
} else {
s_copy(srnamc_1.srnamt, snames + (isnum - 1) * 6, (ftnlen)6, (
ftnlen)6);
/* Test error exits. */
if (tsterr) {
schke_(&isnum, snames + (isnum - 1) * 6, &nout, (ftnlen)6);
io___83.ciunit = nout;
s_wsle(&io___83);
e_wsle();
}
/* Test computations. */
infoc_1.infot = 0;
infoc_1.ok = TRUE_;
fatal = FALSE_;
switch (isnum) {
case 1: goto L140;
case 2: goto L140;
case 3: goto L150;
case 4: goto L150;
case 5: goto L150;
case 6: goto L160;
case 7: goto L160;
case 8: goto L160;
case 9: goto L160;
case 10: goto L160;
case 11: goto L160;
case 12: goto L170;
case 13: goto L180;
case 14: goto L180;
case 15: goto L190;
case 16: goto L190;
}
/* Test SGEMV, 01, and SGBMV, 02. */
L140:
schk1_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, alf,
&nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, as, x, xx,
xs, y, yy, ys, yt, g, (ftnlen)6);
goto L200;
/* Test SSYMV, 03, SSBMV, 04, and SSPMV, 05. */
L150:
schk2_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, alf,
&nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, as, x, xx,
xs, y, yy, ys, yt, g, (ftnlen)6);
goto L200;
/* Test STRMV, 06, STBMV, 07, STPMV, 08, */
/* STRSV, 09, STBSV, 10, and STPSV, 11. */
L160:
schk3_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &ninc, inc,
&c__65, &c__2, a, aa, as, y, yy, ys, yt, g, z__, (ftnlen)
6);
goto L200;
/* Test SGER, 12. */
L170:
schk4_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &ninc,
inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, ys, yt,
g, z__, (ftnlen)6);
goto L200;
/* Test SSYR, 13, and SSPR, 14. */
L180:
schk5_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &ninc,
inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, ys, yt,
g, z__, (ftnlen)6);
goto L200;
/* Test SSYR2, 15, and SSPR2, 16. */
L190:
schk6_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &ninc,
inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, ys, yt,
g, z__, (ftnlen)6);
L200:
if (fatal && sfatal) {
goto L220;
}
}
/* L210: */
}
io___90.ciunit = nout;
s_wsfe(&io___90);
e_wsfe();
goto L240;
L220:
io___91.ciunit = nout;
s_wsfe(&io___91);
e_wsfe();
goto L240;
L230:
io___92.ciunit = nout;
s_wsfe(&io___92);
e_wsfe();
L240:
if (trace) {
cl__1.cerr = 0;
cl__1.cunit = ntra;
cl__1.csta = 0;
f_clos(&cl__1);
}
cl__1.cerr = 0;
cl__1.cunit = nout;
cl__1.csta = 0;
f_clos(&cl__1);
s_stop("", (ftnlen)0);
/* End of SBLAT2. */
return 0;
} /* MAIN__ */
/* Subroutine */ int schk1_(char *sname, real *eps, real *thresh, integer *
nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
integer *nidim, integer *idim, integer *nkb, integer *kb, integer *
nalf, real *alf, integer *nbet, real *bet, integer *ninc, integer *
inc, integer *nmax, integer *incmax, real *a, real *aa, real *as,
real *x, real *xx, real *xs, real *y, real *yy, real *ys, real *yt,
real *g, ftnlen sname_len)
{
/* Initialized data */
static char ich[3] = "NTC";
/* Format strings */
static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
"2(i3,\002,\002),f4.1,\002, A,\002,i3,\002, X,\002,i2,\002,\002,f"
"4.1,\002, Y,\002,i2,\002) .\002)";
static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
"4(i3,\002,\002),f4.1,\002, A,\002,i3,\002, X,\002,i2,\002,\002,f"
"4.1,\002, Y,\002,i2,\002) .\002)";
static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
"N VALID CALL *\002,\002******\002)";
static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
" \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
"STS (\002,i6,\002 CALL\002,\002S)\002)";
static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
" TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
"MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
"ER:\002)";
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;
alist al__1;
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
f_rew(alist *);
/* Local variables */
integer i__, m, n, ia, ib, ic, nc, nd, im, in, kl, ml, nk, nl, ku, ix, iy,
ms, lx, ly, ns, laa, lda;
real als, bls;
extern logical lse_(real *, real *, integer *);
real err;
integer iku, kls, kus;
real beta;
integer ldas;
logical same;
integer incx, incy;
logical full, tran, null;
real alpha;
logical isame[13];
extern /* Subroutine */ int smake_(char *, char *, char *, integer *,
integer *, real *, integer *, real *, integer *, integer *,
integer *, logical *, real *, ftnlen, ftnlen, ftnlen);
integer nargs;
extern /* Subroutine */ int sgbmv_(char *, integer *, integer *, integer *
, integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *), smvch_(char *, integer *, integer *,
real *, real *, integer *, real *, integer *, real *, real *,
integer *, real *, real *, real *, real *, real *, logical *,
integer *, logical *, ftnlen), sgemv_(char *, integer *, integer *
, real *, real *, integer *, real *, integer *, real *, real *,
integer *);
logical reset;
integer incxs, incys;
char trans[1];
logical banded;
real errmax;
extern logical lseres_(char *, char *, integer *, integer *, real *, real
*, integer *, ftnlen, ftnlen);
real transl;
char transs[1];
/* Fortran I/O blocks */
static cilist io___139 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___140 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___141 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___144 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___146 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___147 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___148 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___149 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___150 = { 0, 0, 0, fmt_9995, 0 };
/* Tests SGEMV and SGBMV. */
/* Auxiliary routine for test program for Level 2 Blas. */
/* -- Written on 10-August-1987. */
/* Richard Hanson, Sandia National Labs. */
/* Jeremy Du Croz, NAG Central Office. */
/* .. Parameters .. */
/* .. Scalar Arguments .. */
/* .. Array Arguments .. */
/* .. Local Scalars .. */
/* .. Local Arrays .. */
/* .. External Functions .. */
/* .. External Subroutines .. */
/* .. Intrinsic Functions .. */
/* .. Scalars in Common .. */
/* .. Common blocks .. */
/* .. Data statements .. */
/* Parameter adjustments */
--idim;
--kb;
--alf;
--bet;
--inc;
--g;
--yt;
--y;
--x;
--as;
--aa;
a_dim1 = *nmax;
a_offset = 1 + a_dim1;
a -= a_offset;
--ys;
--yy;
--xs;
--xx;
/* Function Body */
/* .. Executable Statements .. */
full = *(unsigned char *)&sname[2] == 'E';
banded = *(unsigned char *)&sname[2] == 'B';
/* Define the number of arguments. */
if (full) {
nargs = 11;
} else if (banded) {
nargs = 13;
}
nc = 0;
reset = TRUE_;
errmax = 0.f;
i__1 = *nidim;
for (in = 1; in <= i__1; ++in) {
n = idim[in];
nd = n / 2 + 1;
for (im = 1; im <= 2; ++im) {
if (im == 1) {
/* Computing MAX */
i__2 = n - nd;
m = max(i__2,0);
}
if (im == 2) {
/* Computing MIN */
i__2 = n + nd;
m = min(i__2,*nmax);
}
if (banded) {
nk = *nkb;
} else {
nk = 1;
}
i__2 = nk;
for (iku = 1; iku <= i__2; ++iku) {
if (banded) {
ku = kb[iku];
/* Computing MAX */
i__3 = ku - 1;
kl = max(i__3,0);
} else {
ku = n - 1;
kl = m - 1;
}
/* Set LDA to 1 more than minimum value if room. */
if (banded) {
lda = kl + ku + 1;
} else {
lda = m;
}
if (lda < *nmax) {
++lda;
}
/* Skip tests if not enough room. */
if (lda > *nmax) {
goto L100;
}
laa = lda * n;
null = n <= 0 || m <= 0;
/* Generate the matrix A. */
transl = 0.f;
smake_(sname + 1, " ", " ", &m, &n, &a[a_offset], nmax, &aa[1]
, &lda, &kl, &ku, &reset, &transl, (ftnlen)2, (ftnlen)
1, (ftnlen)1);
for (ic = 1; ic <= 3; ++ic) {
*(unsigned char *)trans = *(unsigned char *)&ich[ic - 1];
tran = *(unsigned char *)trans == 'T' || *(unsigned char *
)trans == 'C';
if (tran) {
ml = n;
nl = m;
} else {
ml = m;
nl = n;
}
i__3 = *ninc;
for (ix = 1; ix <= i__3; ++ix) {
incx = inc[ix];
lx = abs(incx) * nl;
/* Generate the vector X. */
transl = .5f;
i__4 = abs(incx);
i__5 = nl - 1;
smake_("GE", " ", " ", &c__1, &nl, &x[1], &c__1, &xx[
1], &i__4, &c__0, &i__5, &reset, &transl, (
ftnlen)2, (ftnlen)1, (ftnlen)1);
if (nl > 1) {
x[nl / 2] = 0.f;
xx[abs(incx) * (nl / 2 - 1) + 1] = 0.f;
}
i__4 = *ninc;
for (iy = 1; iy <= i__4; ++iy) {
incy = inc[iy];
ly = abs(incy) * ml;
i__5 = *nalf;
for (ia = 1; ia <= i__5; ++ia) {
alpha = alf[ia];
i__6 = *nbet;
for (ib = 1; ib <= i__6; ++ib) {
beta = bet[ib];
/* Generate the vector Y. */
transl = 0.f;
i__7 = abs(incy);
i__8 = ml - 1;
smake_("GE", " ", " ", &c__1, &ml, &y[1],
&c__1, &yy[1], &i__7, &c__0, &
i__8, &reset, &transl, (ftnlen)2,
(ftnlen)1, (ftnlen)1);
++nc;
/* Save every datum before calling the */
/* subroutine. */
*(unsigned char *)transs = *(unsigned
char *)trans;
ms = m;
ns = n;
kls = kl;
kus = ku;
als = alpha;
i__7 = laa;
for (i__ = 1; i__ <= i__7; ++i__) {
as[i__] = aa[i__];
/* L10: */
}
ldas = lda;
i__7 = lx;
for (i__ = 1; i__ <= i__7; ++i__) {
xs[i__] = xx[i__];
/* L20: */
}
incxs = incx;
bls = beta;
i__7 = ly;
for (i__ = 1; i__ <= i__7; ++i__) {
ys[i__] = yy[i__];
/* L30: */
}
incys = incy;
/* Call the subroutine. */
if (full) {
if (*trace) {
io___139.ciunit = *ntra;
s_wsfe(&io___139);
do_fio(&c__1, (char *)&nc, (
ftnlen)sizeof(integer));
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&m, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&alpha, (
ftnlen)sizeof(real));
do_fio(&c__1, (char *)&lda, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&incx, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&beta, (
ftnlen)sizeof(real));
do_fio(&c__1, (char *)&incy, (
ftnlen)sizeof(integer));
e_wsfe();
}
if (*rewi) {
al__1.aerr = 0;
al__1.aunit = *ntra;
f_rew(&al__1);
}
sgemv_(trans, &m, &n, &alpha, &aa[1],
&lda, &xx[1], &incx, &beta, &
yy[1], &incy);
} else if (banded) {
if (*trace) {
io___140.ciunit = *ntra;
s_wsfe(&io___140);
do_fio(&c__1, (char *)&nc, (
ftnlen)sizeof(integer));
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&m, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&kl, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ku, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&alpha, (
ftnlen)sizeof(real));
do_fio(&c__1, (char *)&lda, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&incx, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&beta, (
ftnlen)sizeof(real));
do_fio(&c__1, (char *)&incy, (
ftnlen)sizeof(integer));
e_wsfe();
}
if (*rewi) {
al__1.aerr = 0;
al__1.aunit = *ntra;
f_rew(&al__1);
}
sgbmv_(trans, &m, &n, &kl, &ku, &
alpha, &aa[1], &lda, &xx[1], &
incx, &beta, &yy[1], &incy);
}
/* Check if error-exit was taken incorrectly. */
if (! infoc_1.ok) {
io___141.ciunit = *nout;
s_wsfe(&io___141);
e_wsfe();
*fatal = TRUE_;
goto L130;
}
/* See what data changed inside subroutines. */
isame[0] = *(unsigned char *)trans == *(
unsigned char *)transs;
isame[1] = ms == m;
isame[2] = ns == n;
if (full) {
isame[3] = als == alpha;
isame[4] = lse_(&as[1], &aa[1], &laa);
isame[5] = ldas == lda;
isame[6] = lse_(&xs[1], &xx[1], &lx);
isame[7] = incxs == incx;
isame[8] = bls == beta;
if (null) {
isame[9] = lse_(&ys[1], &yy[1], &
ly);
} else {
i__7 = abs(incy);
isame[9] = lseres_("GE", " ", &
c__1, &ml, &ys[1], &yy[1],
&i__7, (ftnlen)2, (
ftnlen)1);
}
isame[10] = incys == incy;
} else if (banded) {
isame[3] = kls == kl;
isame[4] = kus == ku;
isame[5] = als == alpha;
isame[6] = lse_(&as[1], &aa[1], &laa);
isame[7] = ldas == lda;
isame[8] = lse_(&xs[1], &xx[1], &lx);
isame[9] = incxs == incx;
isame[10] = bls == beta;
if (null) {
isame[11] = lse_(&ys[1], &yy[1], &
ly);
} else {
i__7 = abs(incy);
isame[11] = lseres_("GE", " ", &
c__1, &ml, &ys[1], &yy[1],
&i__7, (ftnlen)2, (
ftnlen)1);
}
isame[12] = incys == incy;
}
/* If data was incorrectly changed, report */
/* and return. */
same = TRUE_;
i__7 = nargs;
for (i__ = 1; i__ <= i__7; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
io___144.ciunit = *nout;
s_wsfe(&io___144);
do_fio(&c__1, (char *)&i__, (
ftnlen)sizeof(integer));
e_wsfe();
}
/* L40: */
}
if (! same) {
*fatal = TRUE_;
goto L130;
}
if (! null) {
/* Check the result. */
smvch_(trans, &m, &n, &alpha, &a[
a_offset], nmax, &x[1], &incx,
&beta, &y[1], &incy, &yt[1],
&g[1], &yy[1], eps, &err,
fatal, nout, &c_true, (ftnlen)
1);
errmax = dmax(errmax,err);
/* If got really bad answer, report and */
/* return. */
if (*fatal) {
goto L130;
}
} else {
/* Avoid repeating tests with M.le.0 or */
/* N.le.0. */
goto L110;
}
/* L50: */
}
/* L60: */
}
/* L70: */
}
/* L80: */
}
/* L90: */
}
L100:
;
}
L110:
;
}
/* L120: */
}
/* Report result. */
if (errmax < *thresh) {
io___146.ciunit = *nout;
s_wsfe(&io___146);
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___147.ciunit = *nout;
s_wsfe(&io___147);
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
e_wsfe();
}
goto L140;
L130:
io___148.ciunit = *nout;
s_wsfe(&io___148);
do_fio(&c__1, sname, (ftnlen)6);
e_wsfe();
if (full) {
io___149.ciunit = *nout;
s_wsfe(&io___149);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
e_wsfe();
} else if (banded) {
io___150.ciunit = *nout;
s_wsfe(&io___150);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
e_wsfe();
}
L140:
return 0;
/* End of SCHK1. */
} /* schk1_ */
/* Subroutine */ int schk2_(char *sname, real *eps, real *thresh, integer *
nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
integer *nidim, integer *idim, integer *nkb, integer *kb, integer *
nalf, real *alf, integer *nbet, real *bet, integer *ninc, integer *
inc, integer *nmax, integer *incmax, real *a, real *aa, real *as,
real *x, real *xx, real *xs, real *y, real *yy, real *ys, real *yt,
real *g, ftnlen sname_len)
{
/* Initialized data */
static char ich[2] = "UL";
/* Format strings */
static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
"i3,\002,\002,f4.1,\002, A,\002,i3,\002, X,\002,i2,\002,\002,f4.1,"
"\002, Y,\002,i2,\002) .\002)";
static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
"2(i3,\002,\002),f4.1,\002, A,\002,i3,\002, X,\002,i2,\002,\002,f"
"4.1,\002, Y,\002,i2,\002) .\002)";
static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
"i3,\002,\002,f4.1,\002, AP\002,\002, X,\002,i2,\002,\002,f4.1"
",\002, Y,\002,i2,\002) .\002)";
static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
"N VALID CALL *\002,\002******\002)";
static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
" \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
"STS (\002,i6,\002 CALL\002,\002S)\002)";
static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
" TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
"MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
"ER:\002)";
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;
alist al__1;
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
f_rew(alist *);
/* Local variables */
integer i__, k, n, ia, ib, ic, nc, ik, in, nk, ks, ix, iy, ns, lx, ly,
laa, lda;
real als, bls;
extern logical lse_(real *, real *, integer *);
real err, beta;
integer ldas;
logical same;
integer incx, incy;
logical full, null;
char uplo[1];
real alpha;
logical isame[13];
extern /* Subroutine */ int smake_(char *, char *, char *, integer *,
integer *, real *, integer *, real *, integer *, integer *,
integer *, logical *, real *, ftnlen, ftnlen, ftnlen);
integer nargs;
extern /* Subroutine */ int smvch_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *,
real *, real *, real *, real *, real *, logical *, integer *,
logical *, ftnlen);
logical reset;
integer incxs, incys;
extern /* Subroutine */ int ssbmv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *);
char uplos[1];
extern /* Subroutine */ int sspmv_(char *, integer *, real *, real *,
real *, integer *, real *, real *, integer *), ssymv_(
char *, integer *, real *, real *, integer *, real *, integer *,
real *, real *, integer *);
logical banded, packed;
real errmax;
extern logical lseres_(char *, char *, integer *, integer *, real *, real
*, integer *, ftnlen, ftnlen);
real transl;
/* Fortran I/O blocks */
static cilist io___189 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___190 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___191 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___192 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___195 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___197 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___198 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___199 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___200 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___201 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___202 = { 0, 0, 0, fmt_9995, 0 };
/* Tests SSYMV, SSBMV and SSPMV. */
/* Auxiliary routine for test program for Level 2 Blas. */
/* -- Written on 10-August-1987. */
/* Richard Hanson, Sandia National Labs. */
/* Jeremy Du Croz, NAG Central Office. */
/* .. Parameters .. */
/* .. Scalar Arguments .. */
/* .. Array Arguments .. */
/* .. Local Scalars .. */
/* .. Local Arrays .. */
/* .. External Functions .. */
/* .. External Subroutines .. */
/* .. Intrinsic Functions .. */
/* .. Scalars in Common .. */
/* .. Common blocks .. */
/* .. Data statements .. */
/* Parameter adjustments */
--idim;
--kb;
--alf;
--bet;
--inc;
--g;
--yt;
--y;
--x;
--as;
--aa;
a_dim1 = *nmax;
a_offset = 1 + a_dim1;
a -= a_offset;
--ys;
--yy;
--xs;
--xx;
/* Function Body */
/* .. Executable Statements .. */
full = *(unsigned char *)&sname[2] == 'Y';
banded = *(unsigned char *)&sname[2] == 'B';
packed = *(unsigned char *)&sname[2] == 'P';
/* Define the number of arguments. */
if (full) {
nargs = 10;
} else if (banded) {
nargs = 11;
} else if (packed) {
nargs = 9;
}
nc = 0;
reset = TRUE_;
errmax = 0.f;
i__1 = *nidim;
for (in = 1; in <= i__1; ++in) {
n = idim[in];
if (banded) {
nk = *nkb;
} else {
nk = 1;
}
i__2 = nk;
for (ik = 1; ik <= i__2; ++ik) {
if (banded) {
k = kb[ik];
} else {
k = n - 1;
}
/* Set LDA to 1 more than minimum value if room. */
if (banded) {
lda = k + 1;
} else {
lda = n;
}
if (lda < *nmax) {
++lda;
}
/* Skip tests if not enough room. */
if (lda > *nmax) {
goto L100;
}
if (packed) {
laa = n * (n + 1) / 2;
} else {
laa = lda * n;
}
null = n <= 0;
for (ic = 1; ic <= 2; ++ic) {
*(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1];
/* Generate the matrix A. */
transl = 0.f;
smake_(sname + 1, uplo, " ", &n, &n, &a[a_offset], nmax, &aa[
1], &lda, &k, &k, &reset, &transl, (ftnlen)2, (ftnlen)
1, (ftnlen)1);
i__3 = *ninc;
for (ix = 1; ix <= i__3; ++ix) {
incx = inc[ix];
lx = abs(incx) * n;
/* Generate the vector X. */
transl = .5f;
i__4 = abs(incx);
i__5 = n - 1;
smake_("GE", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &
i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, (
ftnlen)1, (ftnlen)1);
if (n > 1) {
x[n / 2] = 0.f;
xx[abs(incx) * (n / 2 - 1) + 1] = 0.f;
}
i__4 = *ninc;
for (iy = 1; iy <= i__4; ++iy) {
incy = inc[iy];
ly = abs(incy) * n;
i__5 = *nalf;
for (ia = 1; ia <= i__5; ++ia) {
alpha = alf[ia];
i__6 = *nbet;
for (ib = 1; ib <= i__6; ++ib) {
beta = bet[ib];
/* Generate the vector Y. */
transl = 0.f;
i__7 = abs(incy);
i__8 = n - 1;
smake_("GE", " ", " ", &c__1, &n, &y[1], &
c__1, &yy[1], &i__7, &c__0, &i__8, &
reset, &transl, (ftnlen)2, (ftnlen)1,
(ftnlen)1);
++nc;
/* Save every datum before calling the */
/* subroutine. */
*(unsigned char *)uplos = *(unsigned char *)
uplo;
ns = n;
ks = k;
als = alpha;
i__7 = laa;
for (i__ = 1; i__ <= i__7; ++i__) {
as[i__] = aa[i__];
/* L10: */
}
ldas = lda;
i__7 = lx;
for (i__ = 1; i__ <= i__7; ++i__) {
xs[i__] = xx[i__];
/* L20: */
}
incxs = incx;
bls = beta;
i__7 = ly;
for (i__ = 1; i__ <= i__7; ++i__) {
ys[i__] = yy[i__];
/* L30: */
}
incys = incy;
/* Call the subroutine. */
if (full) {
if (*trace) {
io___189.ciunit = *ntra;
s_wsfe(&io___189);
do_fio(&c__1, (char *)&nc, (ftnlen)
sizeof(integer));
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&alpha, (ftnlen)
sizeof(real));
do_fio(&c__1, (char *)&lda, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&incx, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&beta, (ftnlen)
sizeof(real));
do_fio(&c__1, (char *)&incy, (ftnlen)
sizeof(integer));
e_wsfe();
}
if (*rewi) {
al__1.aerr = 0;
al__1.aunit = *ntra;
f_rew(&al__1);
}
ssymv_(uplo, &n, &alpha, &aa[1], &lda, &
xx[1], &incx, &beta, &yy[1], &
incy);
} else if (banded) {
if (*trace) {
io___190.ciunit = *ntra;
s_wsfe(&io___190);
do_fio(&c__1, (char *)&nc, (ftnlen)
sizeof(integer));
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&alpha, (ftnlen)
sizeof(real));
do_fio(&c__1, (char *)&lda, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&incx, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&beta, (ftnlen)
sizeof(real));
do_fio(&c__1, (char *)&incy, (ftnlen)
sizeof(integer));
e_wsfe();
}
if (*rewi) {
al__1.aerr = 0;
al__1.aunit = *ntra;
f_rew(&al__1);
}
ssbmv_(uplo, &n, &k, &alpha, &aa[1], &lda,
&xx[1], &incx, &beta, &yy[1], &
incy);
} else if (packed) {
if (*trace) {
io___191.ciunit = *ntra;
s_wsfe(&io___191);
do_fio(&c__1, (char *)&nc, (ftnlen)
sizeof(integer));
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&alpha, (ftnlen)
sizeof(real));
do_fio(&c__1, (char *)&incx, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&beta, (ftnlen)
sizeof(real));
do_fio(&c__1, (char *)&incy, (ftnlen)
sizeof(integer));
e_wsfe();
}
if (*rewi) {
al__1.aerr = 0;
al__1.aunit = *ntra;
f_rew(&al__1);
}
sspmv_(uplo, &n, &alpha, &aa[1], &xx[1], &
incx, &beta, &yy[1], &incy);
}
/* Check if error-exit was taken incorrectly. */
if (! infoc_1.ok) {
io___192.ciunit = *nout;
s_wsfe(&io___192);
e_wsfe();
*fatal = TRUE_;
goto L120;
}
/* See what data changed inside subroutines. */
isame[0] = *(unsigned char *)uplo == *(
unsigned char *)uplos;
isame[1] = ns == n;
if (full) {
isame[2] = als == alpha;
isame[3] = lse_(&as[1], &aa[1], &laa);
isame[4] = ldas == lda;
isame[5] = lse_(&xs[1], &xx[1], &lx);
isame[6] = incxs == incx;
isame[7] = bls == beta;
if (null) {
isame[8] = lse_(&ys[1], &yy[1], &ly);
} else {
i__7 = abs(incy);
isame[8] = lseres_("GE", " ", &c__1, &
n, &ys[1], &yy[1], &i__7, (
ftnlen)2, (ftnlen)1);
}
isame[9] = incys == incy;
} else if (banded) {
isame[2] = ks == k;
isame[3] = als == alpha;
isame[4] = lse_(&as[1], &aa[1], &laa);
isame[5] = ldas == lda;
isame[6] = lse_(&xs[1], &xx[1], &lx);
isame[7] = incxs == incx;
isame[8] = bls == beta;
if (null) {
isame[9] = lse_(&ys[1], &yy[1], &ly);
} else {
i__7 = abs(incy);
isame[9] = lseres_("GE", " ", &c__1, &
n, &ys[1], &yy[1], &i__7, (
ftnlen)2, (ftnlen)1);
}
isame[10] = incys == incy;
} else if (packed) {
isame[2] = als == alpha;
isame[3] = lse_(&as[1], &aa[1], &laa);
isame[4] = lse_(&xs[1], &xx[1], &lx);
isame[5] = incxs == incx;
isame[6] = bls == beta;
if (null) {
isame[7] = lse_(&ys[1], &yy[1], &ly);
} else {
i__7 = abs(incy);
isame[7] = lseres_("GE", " ", &c__1, &
n, &ys[1], &yy[1], &i__7, (
ftnlen)2, (ftnlen)1);
}
isame[8] = incys == incy;
}
/* If data was incorrectly changed, report and */
/* return. */
same = TRUE_;
i__7 = nargs;
for (i__ = 1; i__ <= i__7; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
io___195.ciunit = *nout;
s_wsfe(&io___195);
do_fio(&c__1, (char *)&i__, (ftnlen)
sizeof(integer));
e_wsfe();
}
/* L40: */
}
if (! same) {
*fatal = TRUE_;
goto L120;
}
if (! null) {
/* Check the result. */
smvch_("N", &n, &n, &alpha, &a[a_offset],
nmax, &x[1], &incx, &beta, &y[1],
&incy, &yt[1], &g[1], &yy[1], eps,
&err, fatal, nout, &c_true, (
ftnlen)1);
errmax = dmax(errmax,err);
/* If got really bad answer, report and */
/* return. */
if (*fatal) {
goto L120;
}
} else {
/* Avoid repeating tests with N.le.0 */
goto L110;
}
/* L50: */
}
/* L60: */
}
/* L70: */
}
/* L80: */
}
/* L90: */
}
L100:
;
}
L110:
;
}
/* Report result. */
if (errmax < *thresh) {
io___197.ciunit = *nout;
s_wsfe(&io___197);
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___198.ciunit = *nout;
s_wsfe(&io___198);
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
e_wsfe();
}
goto L130;
L120:
io___199.ciunit = *nout;
s_wsfe(&io___199);
do_fio(&c__1, sname, (ftnlen)6);
e_wsfe();
if (full) {
io___200.ciunit = *nout;
s_wsfe(&io___200);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
e_wsfe();
} else if (banded) {
io___201.ciunit = *nout;
s_wsfe(&io___201);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
e_wsfe();
} else if (packed) {
io___202.ciunit = *nout;
s_wsfe(&io___202);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
e_wsfe();
}
L130:
return 0;
/* End of SCHK2. */
} /* schk2_ */
/* Subroutine */ int schk3_(char *sname, real *eps, real *thresh, integer *
nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
integer *nidim, integer *idim, integer *nkb, integer *kb, integer *
ninc, integer *inc, integer *nmax, integer *incmax, real *a, real *aa,
real *as, real *x, real *xx, real *xs, real *xt, real *g, real *z__,
ftnlen sname_len)
{
/* Initialized data */
static char ichu[2] = "UL";
static char icht[3] = "NTC";
static char ichd[2] = "UN";
/* Format strings */
static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002(\002,3(\002'\002,a1"
",\002',\002),i3,\002, A,\002,i3,\002, X,\002,i2,\002) "
" .\002)";
static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002(\002,3(\002'\002,a1"
",\002',\002),2(i3,\002,\002),\002 A,\002,i3,\002, X,\002,i2,\002"
") .\002)";
static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002(\002,3(\002'\002,a1"
",\002',\002),i3,\002, AP, \002,\002X,\002,i2,\002) "
" .\002)";
static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
"N VALID CALL *\002,\002******\002)";
static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
" \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
"STS (\002,i6,\002 CALL\002,\002S)\002)";
static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
" TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
"MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
"ER:\002)";
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
alist al__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), do_fio(
integer *, char *, ftnlen), e_wsfe(void), f_rew(alist *);
/* Local variables */
integer i__, k, n, nc, ik, in, nk, ks, ix, ns, lx, laa, icd, lda, ict,
icu;
extern logical lse_(real *, real *, integer *);
real err;
char diag[1];
integer ldas;
logical same;
integer incx;
logical full, null;
char uplo[1], diags[1];
logical isame[13];
extern /* Subroutine */ int smake_(char *, char *, char *, integer *,
integer *, real *, integer *, real *, integer *, integer *,
integer *, logical *, real *, ftnlen, ftnlen, ftnlen);
integer nargs;
extern /* Subroutine */ int smvch_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *,
real *, real *, real *, real *, real *, logical *, integer *,
logical *, ftnlen);
logical reset;
integer incxs;
char trans[1];
extern /* Subroutine */ int stbmv_(char *, char *, char *, integer *,
integer *, real *, integer *, real *, integer *), stbsv_(char *, char *, char *, integer *, integer *,
real *, integer *, real *, integer *);
char uplos[1];
extern /* Subroutine */ int stpmv_(char *, char *, char *, integer *,
real *, real *, integer *), strmv_(char *,
char *, char *, integer *, real *, integer *, real *, integer *), stpsv_(char *, char *, char *, integer *,
real *, real *, integer *), strsv_(char *
, char *, char *, integer *, real *, integer *, real *, integer *);
logical banded, packed;
real errmax;
extern logical lseres_(char *, char *, integer *, integer *, real *, real
*, integer *, ftnlen, ftnlen);
real transl;
char transs[1];
/* Fortran I/O blocks */
static cilist io___239 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___240 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___241 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___242 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___243 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___244 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___245 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___248 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___250 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___251 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___252 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___253 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___254 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___255 = { 0, 0, 0, fmt_9995, 0 };
/* Tests STRMV, STBMV, STPMV, STRSV, STBSV and STPSV. */
/* Auxiliary routine for test program for Level 2 Blas. */
/* -- Written on 10-August-1987. */
/* Richard Hanson, Sandia National Labs. */
/* Jeremy Du Croz, NAG Central Office. */
/* .. Parameters .. */
/* .. Scalar Arguments .. */
/* .. Array Arguments .. */
/* .. Local Scalars .. */
/* .. Local Arrays .. */
/* .. External Functions .. */
/* .. External Subroutines .. */
/* .. Intrinsic Functions .. */
/* .. Scalars in Common .. */
/* .. Common blocks .. */
/* .. Data statements .. */
/* Parameter adjustments */
--idim;
--kb;
--inc;
--z__;
--g;
--xt;
--x;
--as;
--aa;
a_dim1 = *nmax;
a_offset = 1 + a_dim1;
a -= a_offset;
--xs;
--xx;
/* Function Body */
/* .. Executable Statements .. */
full = *(unsigned char *)&sname[2] == 'R';
banded = *(unsigned char *)&sname[2] == 'B';
packed = *(unsigned char *)&sname[2] == 'P';
/* Define the number of arguments. */
if (full) {
nargs = 8;
} else if (banded) {
nargs = 9;
} else if (packed) {
nargs = 7;
}
nc = 0;
reset = TRUE_;
errmax = 0.f;
/* Set up zero vector for SMVCH. */
i__1 = *nmax;
for (i__ = 1; i__ <= i__1; ++i__) {
z__[i__] = 0.f;
/* L10: */
}
i__1 = *nidim;
for (in = 1; in <= i__1; ++in) {
n = idim[in];
if (banded) {
nk = *nkb;
} else {
nk = 1;
}
i__2 = nk;
for (ik = 1; ik <= i__2; ++ik) {
if (banded) {
k = kb[ik];
} else {
k = n - 1;
}
/* Set LDA to 1 more than minimum value if room. */
if (banded) {
lda = k + 1;
} else {
lda = n;
}
if (lda < *nmax) {
++lda;
}
/* Skip tests if not enough room. */
if (lda > *nmax) {
goto L100;
}
if (packed) {
laa = n * (n + 1) / 2;
} else {
laa = lda * n;
}
null = n <= 0;
for (icu = 1; icu <= 2; ++icu) {
*(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
for (ict = 1; ict <= 3; ++ict) {
*(unsigned char *)trans = *(unsigned char *)&icht[ict - 1]
;
for (icd = 1; icd <= 2; ++icd) {
*(unsigned char *)diag = *(unsigned char *)&ichd[icd
- 1];
/* Generate the matrix A. */
transl = 0.f;
smake_(sname + 1, uplo, diag, &n, &n, &a[a_offset],
nmax, &aa[1], &lda, &k, &k, &reset, &transl, (
ftnlen)2, (ftnlen)1, (ftnlen)1);
i__3 = *ninc;
for (ix = 1; ix <= i__3; ++ix) {
incx = inc[ix];
lx = abs(incx) * n;
/* Generate the vector X. */
transl = .5f;
i__4 = abs(incx);
i__5 = n - 1;
smake_("GE", " ", " ", &c__1, &n, &x[1], &c__1, &
xx[1], &i__4, &c__0, &i__5, &reset, &
transl, (ftnlen)2, (ftnlen)1, (ftnlen)1);
if (n > 1) {
x[n / 2] = 0.f;
xx[abs(incx) * (n / 2 - 1) + 1] = 0.f;
}
++nc;
/* Save every datum before calling the subroutine. */
*(unsigned char *)uplos = *(unsigned char *)uplo;
*(unsigned char *)transs = *(unsigned char *)
trans;
*(unsigned char *)diags = *(unsigned char *)diag;
ns = n;
ks = k;
i__4 = laa;
for (i__ = 1; i__ <= i__4; ++i__) {
as[i__] = aa[i__];
/* L20: */
}
ldas = lda;
i__4 = lx;
for (i__ = 1; i__ <= i__4; ++i__) {
xs[i__] = xx[i__];
/* L30: */
}
incxs = incx;
/* Call the subroutine. */
if (s_cmp(sname + 3, "MV", (ftnlen)2, (ftnlen)2)
== 0) {
if (full) {
if (*trace) {
io___239.ciunit = *ntra;
s_wsfe(&io___239);
do_fio(&c__1, (char *)&nc, (ftnlen)
sizeof(integer));
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&lda, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&incx, (ftnlen)
sizeof(integer));
e_wsfe();
}
if (*rewi) {
al__1.aerr = 0;
al__1.aunit = *ntra;
f_rew(&al__1);
}
strmv_(uplo, trans, diag, &n, &aa[1], &
lda, &xx[1], &incx);
} else if (banded) {
if (*trace) {
io___240.ciunit = *ntra;
s_wsfe(&io___240);
do_fio(&c__1, (char *)&nc, (ftnlen)
sizeof(integer));
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&lda, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&incx, (ftnlen)
sizeof(integer));
e_wsfe();
}
if (*rewi) {
al__1.aerr = 0;
al__1.aunit = *ntra;
f_rew(&al__1);
}
stbmv_(uplo, trans, diag, &n, &k, &aa[1],
&lda, &xx[1], &incx);
} else if (packed) {
if (*trace) {
io___241.ciunit = *ntra;
s_wsfe(&io___241);
do_fio(&c__1, (char *)&nc, (ftnlen)
sizeof(integer));
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&incx, (ftnlen)
sizeof(integer));
e_wsfe();
}
if (*rewi) {
al__1.aerr = 0;
al__1.aunit = *ntra;
f_rew(&al__1);
}
stpmv_(uplo, trans, diag, &n, &aa[1], &xx[
1], &incx);
}
} else if (s_cmp(sname + 3, "SV", (ftnlen)2, (
ftnlen)2) == 0) {
if (full) {
if (*trace) {
io___242.ciunit = *ntra;
s_wsfe(&io___242);
do_fio(&c__1, (char *)&nc, (ftnlen)
sizeof(integer));
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&lda, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&incx, (ftnlen)
sizeof(integer));
e_wsfe();
}
if (*rewi) {
al__1.aerr = 0;
al__1.aunit = *ntra;
f_rew(&al__1);
}
strsv_(uplo, trans, diag, &n, &aa[1], &
lda, &xx[1], &incx);
} else if (banded) {
if (*trace) {
io___243.ciunit = *ntra;
s_wsfe(&io___243);
do_fio(&c__1, (char *)&nc, (ftnlen)
sizeof(integer));
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&lda, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&incx, (ftnlen)
sizeof(integer));
e_wsfe();
}
if (*rewi) {
al__1.aerr = 0;
al__1.aunit = *ntra;
f_rew(&al__1);
}
stbsv_(uplo, trans, diag, &n, &k, &aa[1],
&lda, &xx[1], &incx);
} else if (packed) {
if (*trace) {
io___244.ciunit = *ntra;
s_wsfe(&io___244);
do_fio(&c__1, (char *)&nc, (ftnlen)
sizeof(integer));
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&incx, (ftnlen)
sizeof(integer));
e_wsfe();
}
if (*rewi) {
al__1.aerr = 0;
al__1.aunit = *ntra;
f_rew(&al__1);
}
stpsv_(uplo, trans, diag, &n, &aa[1], &xx[
1], &incx);
}
}
/* Check if error-exit was taken incorrectly. */
if (! infoc_1.ok) {
io___245.ciunit = *nout;
s_wsfe(&io___245);
e_wsfe();
*fatal = TRUE_;
goto L120;
}
/* See what data changed inside subroutines. */
isame[0] = *(unsigned char *)uplo == *(unsigned
char *)uplos;
isame[1] = *(unsigned char *)trans == *(unsigned
char *)transs;
isame[2] = *(unsigned char *)diag == *(unsigned
char *)diags;
isame[3] = ns == n;
if (full) {
isame[4] = lse_(&as[1], &aa[1], &laa);
isame[5] = ldas == lda;
if (null) {
isame[6] = lse_(&xs[1], &xx[1], &lx);
} else {
i__4 = abs(incx);
isame[6] = lseres_("GE", " ", &c__1, &n, &
xs[1], &xx[1], &i__4, (ftnlen)2, (
ftnlen)1);
}
isame[7] = incxs == incx;
} else if (banded) {
isame[4] = ks == k;
isame[5] = lse_(&as[1], &aa[1], &laa);
isame[6] = ldas == lda;
if (null) {
isame[7] = lse_(&xs[1], &xx[1], &lx);
} else {
i__4 = abs(incx);
isame[7] = lseres_("GE", " ", &c__1, &n, &
xs[1], &xx[1], &i__4, (ftnlen)2, (
ftnlen)1);
}
isame[8] = incxs == incx;
} else if (packed) {
isame[4] = lse_(&as[1], &aa[1], &laa);
if (null) {
isame[5] = lse_(&xs[1], &xx[1], &lx);
} else {
i__4 = abs(incx);
isame[5] = lseres_("GE", " ", &c__1, &n, &
xs[1], &xx[1], &i__4, (ftnlen)2, (
ftnlen)1);
}
isame[6] = incxs == incx;
}
/* If data was incorrectly changed, report and */
/* return. */
same = TRUE_;
i__4 = nargs;
for (i__ = 1; i__ <= i__4; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
io___248.ciunit = *nout;
s_wsfe(&io___248);
do_fio(&c__1, (char *)&i__, (ftnlen)
sizeof(integer));
e_wsfe();
}
/* L40: */
}
if (! same) {
*fatal = TRUE_;
goto L120;
}
if (! null) {
if (s_cmp(sname + 3, "MV", (ftnlen)2, (ftnlen)
2) == 0) {
/* Check the result. */
smvch_(trans, &n, &n, &c_b121, &a[
a_offset], nmax, &x[1], &incx, &
c_b133, &z__[1], &incx, &xt[1], &
g[1], &xx[1], eps, &err, fatal,
nout, &c_true, (ftnlen)1);
} else if (s_cmp(sname + 3, "SV", (ftnlen)2, (
ftnlen)2) == 0) {
/* Compute approximation to original vector. */
i__4 = n;
for (i__ = 1; i__ <= i__4; ++i__) {
z__[i__] = xx[(i__ - 1) * abs(incx) +
1];
xx[(i__ - 1) * abs(incx) + 1] = x[i__]
;
/* L50: */
}
smvch_(trans, &n, &n, &c_b121, &a[
a_offset], nmax, &z__[1], &incx, &
c_b133, &x[1], &incx, &xt[1], &g[
1], &xx[1], eps, &err, fatal,
nout, &c_false, (ftnlen)1);
}
errmax = dmax(errmax,err);
/* If got really bad answer, report and return. */
if (*fatal) {
goto L120;
}
} else {
/* Avoid repeating tests with N.le.0. */
goto L110;
}
/* L60: */
}
/* L70: */
}
/* L80: */
}
/* L90: */
}
L100:
;
}
L110:
;
}
/* Report result. */
if (errmax < *thresh) {
io___250.ciunit = *nout;
s_wsfe(&io___250);
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___251.ciunit = *nout;
s_wsfe(&io___251);
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
e_wsfe();
}
goto L130;
L120:
io___252.ciunit = *nout;
s_wsfe(&io___252);
do_fio(&c__1, sname, (ftnlen)6);
e_wsfe();
if (full) {
io___253.ciunit = *nout;
s_wsfe(&io___253);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
e_wsfe();
} else if (banded) {
io___254.ciunit = *nout;
s_wsfe(&io___254);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
e_wsfe();
} else if (packed) {
io___255.ciunit = *nout;
s_wsfe(&io___255);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
e_wsfe();
}
L130:
return 0;
/* End of SCHK3. */
} /* schk3_ */
/* Subroutine */ int schk4_(char *sname, real *eps, real *thresh, integer *
nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
integer *nidim, integer *idim, integer *nalf, real *alf, integer *
ninc, integer *inc, integer *nmax, integer *incmax, real *a, real *aa,
real *as, real *x, real *xx, real *xs, real *y, real *yy, real *ys,
real *yt, real *g, real *z__, ftnlen sname_len)
{
/* Format strings */
static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002(\002,2(i3,\002,\002)"
",f4.1,\002, X,\002,i2,\002, Y,\002,i2,\002, A,\002,i3,\002) "
" .\002)";
static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
"N VALID CALL *\002,\002******\002)";
static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
" \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
"STS (\002,i6,\002 CALL\002,\002S)\002)";
static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
" TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
"MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
" \002,i3)";
static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
"ER:\002)";
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
alist al__1;
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
f_rew(alist *);
/* Local variables */
integer i__, j, m, n;
real w[1];
integer ia, nc, nd, im, in, ms, ix, iy, ns, lx, ly, laa, lda;
real als;
extern logical lse_(real *, real *, integer *);
real err;
integer ldas;
logical same;
extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
integer *, real *, integer *, real *, integer *);
integer incx, incy;
logical null;
real alpha;
logical isame[13];
extern /* Subroutine */ int smake_(char *, char *, char *, integer *,
integer *, real *, integer *, real *, integer *, integer *,
integer *, logical *, real *, ftnlen, ftnlen, ftnlen);
integer nargs;
extern /* Subroutine */ int smvch_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *,
real *, real *, real *, real *, real *, logical *, integer *,
logical *, ftnlen);
logical reset;
integer incxs, incys;
real errmax;
extern logical lseres_(char *, char *, integer *, integer *, real *, real
*, integer *, ftnlen, ftnlen);
real transl;
/* Fortran I/O blocks */
static cilist io___284 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___285 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___288 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___292 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___293 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___294 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___295 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___296 = { 0, 0, 0, fmt_9994, 0 };
/* Tests SGER. */
/* Auxiliary routine for test program for Level 2 Blas. */
/* -- Written on 10-August-1987. */
/* Richard Hanson, Sandia National Labs. */
/* Jeremy Du Croz, NAG Central Office. */
/* .. Parameters .. */
/* .. Scalar Arguments .. */
/* .. Array Arguments .. */
/* .. Local Scalars .. */
/* .. Local Arrays .. */
/* .. External Functions .. */
/* .. External Subroutines .. */
/* .. Intrinsic Functions .. */
/* .. Scalars in Common .. */
/* .. Common blocks .. */
/* .. Executable Statements .. */
/* Define the number of arguments. */
/* Parameter adjustments */
--idim;
--alf;
--inc;
--z__;
--g;
--yt;
--y;
--x;
--as;
--aa;
a_dim1 = *nmax;
a_offset = 1 + a_dim1;
a -= a_offset;
--ys;
--yy;
--xs;
--xx;
/* Function Body */
nargs = 9;
nc = 0;
reset = TRUE_;
errmax = 0.f;
i__1 = *nidim;
for (in = 1; in <= i__1; ++in) {
n = idim[in];
nd = n / 2 + 1;
for (im = 1; im <= 2; ++im) {
if (im == 1) {
/* Computing MAX */
i__2 = n - nd;
m = max(i__2,0);
}
if (im == 2) {
/* Computing MIN */
i__2 = n + nd;
m = min(i__2,*nmax);
}
/* Set LDA to 1 more than minimum value if room. */
lda = m;
if (lda < *nmax) {
++lda;
}
/* Skip tests if not enough room. */
if (lda > *nmax) {
goto L110;
}
laa = lda * n;
null = n <= 0 || m <= 0;
i__2 = *ninc;
for (ix = 1; ix <= i__2; ++ix) {
incx = inc[ix];
lx = abs(incx) * m;
/* Generate the vector X. */
transl = .5f;
i__3 = abs(incx);
i__4 = m - 1;
smake_("GE", " ", " ", &c__1, &m, &x[1], &c__1, &xx[1], &i__3,
&c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1,
(ftnlen)1);
if (m > 1) {
x[m / 2] = 0.f;
xx[abs(incx) * (m / 2 - 1) + 1] = 0.f;
}
i__3 = *ninc;
for (iy = 1; iy <= i__3; ++iy) {
incy = inc[iy];
ly = abs(incy) * n;
/* Generate the vector Y. */
transl = 0.f;
i__4 = abs(incy);
i__5 = n - 1;
smake_("GE", " ", " ", &c__1, &n, &y[1], &c__1, &yy[1], &
i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, (
ftnlen)1, (ftnlen)1);
if (n > 1) {
y[n / 2] = 0.f;
yy[abs(incy) * (n / 2 - 1) + 1] = 0.f;
}
i__4 = *nalf;
for (ia = 1; ia <= i__4; ++ia) {
alpha = alf[ia];
/* Generate the matrix A. */
transl = 0.f;
i__5 = m - 1;
i__6 = n - 1;
smake_(sname + 1, " ", " ", &m, &n, &a[a_offset],
nmax, &aa[1], &lda, &i__5, &i__6, &reset, &
transl, (ftnlen)2, (ftnlen)1, (ftnlen)1);
++nc;
/* Save every datum before calling the subroutine. */
ms = m;
ns = n;
als = alpha;
i__5 = laa;
for (i__ = 1; i__ <= i__5; ++i__) {
as[i__] = aa[i__];
/* L10: */
}
ldas = lda;
i__5 = lx;
for (i__ = 1; i__ <= i__5; ++i__) {
xs[i__] = xx[i__];
/* L20: */
}
incxs = incx;
i__5 = ly;
for (i__ = 1; i__ <= i__5; ++i__) {
ys[i__] = yy[i__];
/* L30: */
}
incys = incy;
/* Call the subroutine. */
if (*trace) {
io___284.ciunit = *ntra;
s_wsfe(&io___284);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)
);
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real)
);
do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
integer));
e_wsfe();
}
if (*rewi) {
al__1.aerr = 0;
al__1.aunit = *ntra;
f_rew(&al__1);
}
sger_(&m, &n, &alpha, &xx[1], &incx, &yy[1], &incy, &
aa[1], &lda);
/* Check if error-exit was taken incorrectly. */
if (! infoc_1.ok) {
io___285.ciunit = *nout;
s_wsfe(&io___285);
e_wsfe();
*fatal = TRUE_;
goto L140;
}
/* See what data changed inside subroutine. */
isame[0] = ms == m;
isame[1] = ns == n;
isame[2] = als == alpha;
isame[3] = lse_(&xs[1], &xx[1], &lx);
isame[4] = incxs == incx;
isame[5] = lse_(&ys[1], &yy[1], &ly);
isame[6] = incys == incy;
if (null) {
isame[7] = lse_(&as[1], &aa[1], &laa);
} else {
isame[7] = lseres_("GE", " ", &m, &n, &as[1], &aa[
1], &lda, (ftnlen)2, (ftnlen)1);
}
isame[8] = ldas == lda;
/* If data was incorrectly changed, report and return. */
same = TRUE_;
i__5 = nargs;
for (i__ = 1; i__ <= i__5; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
io___288.ciunit = *nout;
s_wsfe(&io___288);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
integer));
e_wsfe();
}
/* L40: */
}
if (! same) {
*fatal = TRUE_;
goto L140;
}
if (! null) {
/* Check the result column by column. */
if (incx > 0) {
i__5 = m;
for (i__ = 1; i__ <= i__5; ++i__) {
z__[i__] = x[i__];
/* L50: */
}
} else {
i__5 = m;
for (i__ = 1; i__ <= i__5; ++i__) {
z__[i__] = x[m - i__ + 1];
/* L60: */
}
}
i__5 = n;
for (j = 1; j <= i__5; ++j) {
if (incy > 0) {
w[0] = y[j];
} else {
w[0] = y[n - j + 1];
}
smvch_("N", &m, &c__1, &alpha, &z__[1], nmax,
w, &c__1, &c_b121, &a[j * a_dim1 + 1],
&c__1, &yt[1], &g[1], &aa[(j - 1) *
lda + 1], eps, &err, fatal, nout, &
c_true, (ftnlen)1);
errmax = dmax(errmax,err);
/* If got really bad answer, report and return. */
if (*fatal) {
goto L130;
}
/* L70: */
}
} else {
/* Avoid repeating tests with M.le.0 or N.le.0. */
goto L110;
}
/* L80: */
}
/* L90: */
}
/* L100: */
}
L110:
;
}
/* L120: */
}
/* Report result. */
if (errmax < *thresh) {
io___292.ciunit = *nout;
s_wsfe(&io___292);
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___293.ciunit = *nout;
s_wsfe(&io___293);
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
e_wsfe();
}
goto L150;
L130:
io___294.ciunit = *nout;
s_wsfe(&io___294);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
e_wsfe();
L140:
io___295.ciunit = *nout;
s_wsfe(&io___295);
do_fio(&c__1, sname, (ftnlen)6);
e_wsfe();
io___296.ciunit = *nout;
s_wsfe(&io___296);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
e_wsfe();
L150:
return 0;
/* End of SCHK4. */
} /* schk4_ */
/* Subroutine */ int schk5_(char *sname, real *eps, real *thresh, integer *
nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
integer *nidim, integer *idim, integer *nalf, real *alf, integer *
ninc, integer *inc, integer *nmax, integer *incmax, real *a, real *aa,
real *as, real *x, real *xx, real *xs, real *y, real *yy, real *ys,
real *yt, real *g, real *z__, ftnlen sname_len)
{
/* Initialized data */
static char ich[2] = "UL";
/* Format strings */
static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
"i3,\002,\002,f4.1,\002, X,\002,i2,\002, A,\002,i3,\002) "
" .\002)";
static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
"i3,\002,\002,f4.1,\002, X,\002,i2,\002, AP) "
" .\002)";
static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
"N VALID CALL *\002,\002******\002)";
static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
" \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
"STS (\002,i6,\002 CALL\002,\002S)\002)";
static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
" TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
"MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
" \002,i3)";
static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
"ER:\002)";
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
alist al__1;
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
f_rew(alist *);
/* Local variables */
integer i__, j, n;
real w[1];
integer ia, ja, ic, nc, jj, lj, in, ix, ns, lx, laa, lda;
real als;
extern logical lse_(real *, real *, integer *);
real err;
integer ldas;
logical same;
integer incx;
logical full, null;
char uplo[1];
extern /* Subroutine */ int sspr_(char *, integer *, real *, real *,
integer *, real *), ssyr_(char *, integer *, real *, real
*, integer *, real *, integer *);
real alpha;
logical isame[13];
extern /* Subroutine */ int smake_(char *, char *, char *, integer *,
integer *, real *, integer *, real *, integer *, integer *,
integer *, logical *, real *, ftnlen, ftnlen, ftnlen);
integer nargs;
extern /* Subroutine */ int smvch_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *,
real *, real *, real *, real *, real *, logical *, integer *,
logical *, ftnlen);
logical reset;
integer incxs;
logical upper;
char uplos[1];
logical packed;
real errmax;
extern logical lseres_(char *, char *, integer *, integer *, real *, real
*, integer *, ftnlen, ftnlen);
real transl;
/* Fortran I/O blocks */
static cilist io___324 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___325 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___326 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___329 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___336 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___337 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___338 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___339 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___340 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___341 = { 0, 0, 0, fmt_9994, 0 };
/* Tests SSYR and SSPR. */
/* Auxiliary routine for test program for Level 2 Blas. */
/* -- Written on 10-August-1987. */
/* Richard Hanson, Sandia National Labs. */
/* Jeremy Du Croz, NAG Central Office. */
/* .. Parameters .. */
/* .. Scalar Arguments .. */
/* .. Array Arguments .. */
/* .. Local Scalars .. */
/* .. Local Arrays .. */
/* .. External Functions .. */
/* .. External Subroutines .. */
/* .. Intrinsic Functions .. */
/* .. Scalars in Common .. */
/* .. Common blocks .. */
/* .. Data statements .. */
/* Parameter adjustments */
--idim;
--alf;
--inc;
--z__;
--g;
--yt;
--y;
--x;
--as;
--aa;
a_dim1 = *nmax;
a_offset = 1 + a_dim1;
a -= a_offset;
--ys;
--yy;
--xs;
--xx;
/* Function Body */
/* .. Executable Statements .. */
full = *(unsigned char *)&sname[2] == 'Y';
packed = *(unsigned char *)&sname[2] == 'P';
/* Define the number of arguments. */
if (full) {
nargs = 7;
} else if (packed) {
nargs = 6;
}
nc = 0;
reset = TRUE_;
errmax = 0.f;
i__1 = *nidim;
for (in = 1; in <= i__1; ++in) {
n = idim[in];
/* Set LDA to 1 more than minimum value if room. */
lda = n;
if (lda < *nmax) {
++lda;
}
/* Skip tests if not enough room. */
if (lda > *nmax) {
goto L100;
}
if (packed) {
laa = n * (n + 1) / 2;
} else {
laa = lda * n;
}
for (ic = 1; ic <= 2; ++ic) {
*(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1];
upper = *(unsigned char *)uplo == 'U';
i__2 = *ninc;
for (ix = 1; ix <= i__2; ++ix) {
incx = inc[ix];
lx = abs(incx) * n;
/* Generate the vector X. */
transl = .5f;
i__3 = abs(incx);
i__4 = n - 1;
smake_("GE", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &i__3,
&c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1,
(ftnlen)1);
if (n > 1) {
x[n / 2] = 0.f;
xx[abs(incx) * (n / 2 - 1) + 1] = 0.f;
}
i__3 = *nalf;
for (ia = 1; ia <= i__3; ++ia) {
alpha = alf[ia];
null = n <= 0 || alpha == 0.f;
/* Generate the matrix A. */
transl = 0.f;
i__4 = n - 1;
i__5 = n - 1;
smake_(sname + 1, uplo, " ", &n, &n, &a[a_offset], nmax, &
aa[1], &lda, &i__4, &i__5, &reset, &transl, (
ftnlen)2, (ftnlen)1, (ftnlen)1);
++nc;
/* Save every datum before calling the subroutine. */
*(unsigned char *)uplos = *(unsigned char *)uplo;
ns = n;
als = alpha;
i__4 = laa;
for (i__ = 1; i__ <= i__4; ++i__) {
as[i__] = aa[i__];
/* L10: */
}
ldas = lda;
i__4 = lx;
for (i__ = 1; i__ <= i__4; ++i__) {
xs[i__] = xx[i__];
/* L20: */
}
incxs = incx;
/* Call the subroutine. */
if (full) {
if (*trace) {
io___324.ciunit = *ntra;
s_wsfe(&io___324);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)
);
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real)
);
do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
integer));
e_wsfe();
}
if (*rewi) {
al__1.aerr = 0;
al__1.aunit = *ntra;
f_rew(&al__1);
}
ssyr_(uplo, &n, &alpha, &xx[1], &incx, &aa[1], &lda);
} else if (packed) {
if (*trace) {
io___325.ciunit = *ntra;
s_wsfe(&io___325);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)
);
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real)
);
do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
integer));
e_wsfe();
}
if (*rewi) {
al__1.aerr = 0;
al__1.aunit = *ntra;
f_rew(&al__1);
}
sspr_(uplo, &n, &alpha, &xx[1], &incx, &aa[1]);
}
/* Check if error-exit was taken incorrectly. */
if (! infoc_1.ok) {
io___326.ciunit = *nout;
s_wsfe(&io___326);
e_wsfe();
*fatal = TRUE_;
goto L120;
}
/* See what data changed inside subroutines. */
isame[0] = *(unsigned char *)uplo == *(unsigned char *)
uplos;
isame[1] = ns == n;
isame[2] = als == alpha;
isame[3] = lse_(&xs[1], &xx[1], &lx);
isame[4] = incxs == incx;
if (null) {
isame[5] = lse_(&as[1], &aa[1], &laa);
} else {
isame[5] = lseres_(sname + 1, uplo, &n, &n, &as[1], &
aa[1], &lda, (ftnlen)2, (ftnlen)1);
}
if (! packed) {
isame[6] = ldas == lda;
}
/* If data was incorrectly changed, report and return. */
same = TRUE_;
i__4 = nargs;
for (i__ = 1; i__ <= i__4; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
io___329.ciunit = *nout;
s_wsfe(&io___329);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
integer));
e_wsfe();
}
/* L30: */
}
if (! same) {
*fatal = TRUE_;
goto L120;
}
if (! null) {
/* Check the result column by column. */
if (incx > 0) {
i__4 = n;
for (i__ = 1; i__ <= i__4; ++i__) {
z__[i__] = x[i__];
/* L40: */
}
} else {
i__4 = n;
for (i__ = 1; i__ <= i__4; ++i__) {
z__[i__] = x[n - i__ + 1];
/* L50: */
}
}
ja = 1;
i__4 = n;
for (j = 1; j <= i__4; ++j) {
w[0] = z__[j];
if (upper) {
jj = 1;
lj = j;
} else {
jj = j;
lj = n - j + 1;
}
smvch_("N", &lj, &c__1, &alpha, &z__[jj], &lj, w,
&c__1, &c_b121, &a[jj + j * a_dim1], &
c__1, &yt[1], &g[1], &aa[ja], eps, &err,
fatal, nout, &c_true, (ftnlen)1);
if (full) {
if (upper) {
ja += lda;
} else {
ja = ja + lda + 1;
}
} else {
ja += lj;
}
errmax = dmax(errmax,err);
/* If got really bad answer, report and return. */
if (*fatal) {
goto L110;
}
/* L60: */
}
} else {
/* Avoid repeating tests if N.le.0. */
if (n <= 0) {
goto L100;
}
}
/* L70: */
}
/* L80: */
}
/* L90: */
}
L100:
;
}
/* Report result. */
if (errmax < *thresh) {
io___336.ciunit = *nout;
s_wsfe(&io___336);
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___337.ciunit = *nout;
s_wsfe(&io___337);
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
e_wsfe();
}
goto L130;
L110:
io___338.ciunit = *nout;
s_wsfe(&io___338);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
e_wsfe();
L120:
io___339.ciunit = *nout;
s_wsfe(&io___339);
do_fio(&c__1, sname, (ftnlen)6);
e_wsfe();
if (full) {
io___340.ciunit = *nout;
s_wsfe(&io___340);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
e_wsfe();
} else if (packed) {
io___341.ciunit = *nout;
s_wsfe(&io___341);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
e_wsfe();
}
L130:
return 0;
/* End of SCHK5. */
} /* schk5_ */
/* Subroutine */ int schk6_(char *sname, real *eps, real *thresh, integer *
nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
integer *nidim, integer *idim, integer *nalf, real *alf, integer *
ninc, integer *inc, integer *nmax, integer *incmax, real *a, real *aa,
real *as, real *x, real *xx, real *xs, real *y, real *yy, real *ys,
real *yt, real *g, real *z__, ftnlen sname_len)
{
/* Initialized data */
static char ich[2] = "UL";
/* Format strings */
static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
"i3,\002,\002,f4.1,\002, X,\002,i2,\002, Y,\002,i2,\002, A,\002,i"
"3,\002) .\002)";
static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
"i3,\002,\002,f4.1,\002, X,\002,i2,\002, Y,\002,i2,\002, AP) "
" .\002)";
static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
"N VALID CALL *\002,\002******\002)";
static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
" \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
"STS (\002,i6,\002 CALL\002,\002S)\002)";
static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
" TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
"MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
" \002,i3)";
static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
"ER:\002)";
/* System generated locals */
integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5,
i__6;
alist al__1;
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
f_rew(alist *);
/* Local variables */
integer i__, j, n;
real w[2];
integer ia, ja, ic, nc, jj, lj, in, ix, iy, ns, lx, ly, laa, lda;
real als;
extern logical lse_(real *, real *, integer *);
real err;
integer ldas;
logical same;
integer incx, incy;
logical full, null;
char uplo[1];
extern /* Subroutine */ int sspr2_(char *, integer *, real *, real *,
integer *, real *, integer *, real *), ssyr2_(char *,
integer *, real *, real *, integer *, real *, integer *, real *,
integer *);
real alpha;
logical isame[13];
extern /* Subroutine */ int smake_(char *, char *, char *, integer *,
integer *, real *, integer *, real *, integer *, integer *,
integer *, logical *, real *, ftnlen, ftnlen, ftnlen);
integer nargs;
extern /* Subroutine */ int smvch_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *,
real *, real *, real *, real *, real *, logical *, integer *,
logical *, ftnlen);
logical reset;
integer incxs, incys;
logical upper;
char uplos[1];
logical packed;
real errmax;
extern logical lseres_(char *, char *, integer *, integer *, real *, real
*, integer *, ftnlen, ftnlen);
real transl;
/* Fortran I/O blocks */
static cilist io___373 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___374 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___375 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___378 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___385 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___386 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___387 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___388 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___389 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___390 = { 0, 0, 0, fmt_9994, 0 };
/* Tests SSYR2 and SSPR2. */
/* Auxiliary routine for test program for Level 2 Blas. */
/* -- Written on 10-August-1987. */
/* Richard Hanson, Sandia National Labs. */
/* Jeremy Du Croz, NAG Central Office. */
/* .. Parameters .. */
/* .. Scalar Arguments .. */
/* .. Array Arguments .. */
/* .. Local Scalars .. */
/* .. Local Arrays .. */
/* .. External Functions .. */
/* .. External Subroutines .. */
/* .. Intrinsic Functions .. */
/* .. Scalars in Common .. */
/* .. Common blocks .. */
/* .. Data statements .. */
/* Parameter adjustments */
--idim;
--alf;
--inc;
z_dim1 = *nmax;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--g;
--yt;
--y;
--x;
--as;
--aa;
a_dim1 = *nmax;
a_offset = 1 + a_dim1;
a -= a_offset;
--ys;
--yy;
--xs;
--xx;
/* Function Body */
/* .. Executable Statements .. */
full = *(unsigned char *)&sname[2] == 'Y';
packed = *(unsigned char *)&sname[2] == 'P';
/* Define the number of arguments. */
if (full) {
nargs = 9;
} else if (packed) {
nargs = 8;
}
nc = 0;
reset = TRUE_;
errmax = 0.f;
i__1 = *nidim;
for (in = 1; in <= i__1; ++in) {
n = idim[in];
/* Set LDA to 1 more than minimum value if room. */
lda = n;
if (lda < *nmax) {
++lda;
}
/* Skip tests if not enough room. */
if (lda > *nmax) {
goto L140;
}
if (packed) {
laa = n * (n + 1) / 2;
} else {
laa = lda * n;
}
for (ic = 1; ic <= 2; ++ic) {
*(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1];
upper = *(unsigned char *)uplo == 'U';
i__2 = *ninc;
for (ix = 1; ix <= i__2; ++ix) {
incx = inc[ix];
lx = abs(incx) * n;
/* Generate the vector X. */
transl = .5f;
i__3 = abs(incx);
i__4 = n - 1;
smake_("GE", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &i__3,
&c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1,
(ftnlen)1);
if (n > 1) {
x[n / 2] = 0.f;
xx[abs(incx) * (n / 2 - 1) + 1] = 0.f;
}
i__3 = *ninc;
for (iy = 1; iy <= i__3; ++iy) {
incy = inc[iy];
ly = abs(incy) * n;
/* Generate the vector Y. */
transl = 0.f;
i__4 = abs(incy);
i__5 = n - 1;
smake_("GE", " ", " ", &c__1, &n, &y[1], &c__1, &yy[1], &
i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, (
ftnlen)1, (ftnlen)1);
if (n > 1) {
y[n / 2] = 0.f;
yy[abs(incy) * (n / 2 - 1) + 1] = 0.f;
}
i__4 = *nalf;
for (ia = 1; ia <= i__4; ++ia) {
alpha = alf[ia];
null = n <= 0 || alpha == 0.f;
/* Generate the matrix A. */
transl = 0.f;
i__5 = n - 1;
i__6 = n - 1;
smake_(sname + 1, uplo, " ", &n, &n, &a[a_offset],
nmax, &aa[1], &lda, &i__5, &i__6, &reset, &
transl, (ftnlen)2, (ftnlen)1, (ftnlen)1);
++nc;
/* Save every datum before calling the subroutine. */
*(unsigned char *)uplos = *(unsigned char *)uplo;
ns = n;
als = alpha;
i__5 = laa;
for (i__ = 1; i__ <= i__5; ++i__) {
as[i__] = aa[i__];
/* L10: */
}
ldas = lda;
i__5 = lx;
for (i__ = 1; i__ <= i__5; ++i__) {
xs[i__] = xx[i__];
/* L20: */
}
incxs = incx;
i__5 = ly;
for (i__ = 1; i__ <= i__5; ++i__) {
ys[i__] = yy[i__];
/* L30: */
}
incys = incy;
/* Call the subroutine. */
if (full) {
if (*trace) {
io___373.ciunit = *ntra;
s_wsfe(&io___373);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
integer));
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(
real));
do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
integer));
e_wsfe();
}
if (*rewi) {
al__1.aerr = 0;
al__1.aunit = *ntra;
f_rew(&al__1);
}
ssyr2_(uplo, &n, &alpha, &xx[1], &incx, &yy[1], &
incy, &aa[1], &lda);
} else if (packed) {
if (*trace) {
io___374.ciunit = *ntra;
s_wsfe(&io___374);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
integer));
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(
real));
do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(
integer));
e_wsfe();
}
if (*rewi) {
al__1.aerr = 0;
al__1.aunit = *ntra;
f_rew(&al__1);
}
sspr2_(uplo, &n, &alpha, &xx[1], &incx, &yy[1], &
incy, &aa[1]);
}
/* Check if error-exit was taken incorrectly. */
if (! infoc_1.ok) {
io___375.ciunit = *nout;
s_wsfe(&io___375);
e_wsfe();
*fatal = TRUE_;
goto L160;
}
/* See what data changed inside subroutines. */
isame[0] = *(unsigned char *)uplo == *(unsigned char *
)uplos;
isame[1] = ns == n;
isame[2] = als == alpha;
isame[3] = lse_(&xs[1], &xx[1], &lx);
isame[4] = incxs == incx;
isame[5] = lse_(&ys[1], &yy[1], &ly);
isame[6] = incys == incy;
if (null) {
isame[7] = lse_(&as[1], &aa[1], &laa);
} else {
isame[7] = lseres_(sname + 1, uplo, &n, &n, &as[1]
, &aa[1], &lda, (ftnlen)2, (ftnlen)1);
}
if (! packed) {
isame[8] = ldas == lda;
}
/* If data was incorrectly changed, report and return. */
same = TRUE_;
i__5 = nargs;
for (i__ = 1; i__ <= i__5; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
io___378.ciunit = *nout;
s_wsfe(&io___378);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
integer));
e_wsfe();
}
/* L40: */
}
if (! same) {
*fatal = TRUE_;
goto L160;
}
if (! null) {
/* Check the result column by column. */
if (incx > 0) {
i__5 = n;
for (i__ = 1; i__ <= i__5; ++i__) {
z__[i__ + z_dim1] = x[i__];
/* L50: */
}
} else {
i__5 = n;
for (i__ = 1; i__ <= i__5; ++i__) {
z__[i__ + z_dim1] = x[n - i__ + 1];
/* L60: */
}
}
if (incy > 0) {
i__5 = n;
for (i__ = 1; i__ <= i__5; ++i__) {
z__[i__ + (z_dim1 << 1)] = y[i__];
/* L70: */
}
} else {
i__5 = n;
for (i__ = 1; i__ <= i__5; ++i__) {
z__[i__ + (z_dim1 << 1)] = y[n - i__ + 1];
/* L80: */
}
}
ja = 1;
i__5 = n;
for (j = 1; j <= i__5; ++j) {
w[0] = z__[j + (z_dim1 << 1)];
w[1] = z__[j + z_dim1];
if (upper) {
jj = 1;
lj = j;
} else {
jj = j;
lj = n - j + 1;
}
smvch_("N", &lj, &c__2, &alpha, &z__[jj +
z_dim1], nmax, w, &c__1, &c_b121, &a[
jj + j * a_dim1], &c__1, &yt[1], &g[1]
, &aa[ja], eps, &err, fatal, nout, &
c_true, (ftnlen)1);
if (full) {
if (upper) {
ja += lda;
} else {
ja = ja + lda + 1;
}
} else {
ja += lj;
}
errmax = dmax(errmax,err);
/* If got really bad answer, report and return. */
if (*fatal) {
goto L150;
}
/* L90: */
}
} else {
/* Avoid repeating tests with N.le.0. */
if (n <= 0) {
goto L140;
}
}
/* L100: */
}
/* L110: */
}
/* L120: */
}
/* L130: */
}
L140:
;
}
/* Report result. */
if (errmax < *thresh) {
io___385.ciunit = *nout;
s_wsfe(&io___385);
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___386.ciunit = *nout;
s_wsfe(&io___386);
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
e_wsfe();
}
goto L170;
L150:
io___387.ciunit = *nout;
s_wsfe(&io___387);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
e_wsfe();
L160:
io___388.ciunit = *nout;
s_wsfe(&io___388);
do_fio(&c__1, sname, (ftnlen)6);
e_wsfe();
if (full) {
io___389.ciunit = *nout;
s_wsfe(&io___389);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
e_wsfe();
} else if (packed) {
io___390.ciunit = *nout;
s_wsfe(&io___390);
do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
do_fio(&c__1, sname, (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
e_wsfe();
}
L170:
return 0;
/* End of SCHK6. */
} /* schk6_ */
/* Subroutine */ int schke_(integer *isnum, char *srnamt, integer *nout,
ftnlen srnamt_len)
{
/* Format strings */
static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE TESTS OF ERROR-E"
"XITS\002)";
static char fmt_9998[] = "(\002 ******* \002,a6,\002 FAILED THE TESTS OF"
" ERROR-EXITS *****\002,\002**\002)";
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
real a[1] /* was [1][1] */, x[1], y[1], beta;
extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
integer *, real *, integer *, real *, integer *), sspr_(char *,
integer *, real *, real *, integer *, real *), ssyr_(char
*, integer *, real *, real *, integer *, real *, integer *), sspr2_(char *, integer *, real *, real *, integer *,
real *, integer *, real *), ssyr2_(char *, integer *,
real *, real *, integer *, real *, integer *, real *, integer *);
real alpha;
extern /* Subroutine */ int sgbmv_(char *, integer *, integer *, integer *
, integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *), sgemv_(char *, integer *, integer *,
real *, real *, integer *, real *, integer *, real *, real *,
integer *), ssbmv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *), stbmv_(char *, char *, char *, integer *, integer *,
real *, integer *, real *, integer *),
stbsv_(char *, char *, char *, integer *, integer *, real *,
integer *, real *, integer *), sspmv_(
char *, integer *, real *, real *, real *, integer *, real *,
real *, integer *), stpmv_(char *, char *, char *,
integer *, real *, real *, integer *),
strmv_(char *, char *, char *, integer *, real *, integer *, real
*, integer *), stpsv_(char *, char *,
char *, integer *, real *, real *, integer *), ssymv_(char *, integer *, real *, real *, integer *,
real *, integer *, real *, real *, integer *), strsv_(
char *, char *, char *, integer *, real *, integer *, real *,
integer *), chkxer_(char *, integer *,
integer *, logical *, logical *);
/* Fortran I/O blocks */
static cilist io___396 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___397 = { 0, 0, 0, fmt_9998, 0 };
/* Tests the error exits from the Level 2 Blas. */
/* Requires a special version of the error-handling routine XERBLA. */
/* ALPHA, BETA, A, X and Y should not need to be defined. */
/* Auxiliary routine for test program for Level 2 Blas. */
/* -- Written on 10-August-1987. */
/* Richard Hanson, Sandia National Labs. */
/* Jeremy Du Croz, NAG Central Office. */
/* .. Scalar Arguments .. */
/* .. Scalars in Common .. */
/* .. Local Scalars .. */
/* .. Local Arrays .. */
/* .. External Subroutines .. */
/* .. Common blocks .. */
/* .. Executable Statements .. */
/* OK is set to .FALSE. by the special version of XERBLA or by CHKXER */
/* if anything is wrong. */
infoc_1.ok = TRUE_;
/* LERR is set to .TRUE. by the special version of XERBLA each time */
/* it is called, and is then tested and re-set by CHKXER. */
infoc_1.lerr = FALSE_;
switch (*isnum) {
case 1: goto L10;
case 2: goto L20;
case 3: goto L30;
case 4: goto L40;
case 5: goto L50;
case 6: goto L60;
case 7: goto L70;
case 8: goto L80;
case 9: goto L90;
case 10: goto L100;
case 11: goto L110;
case 12: goto L120;
case 13: goto L130;
case 14: goto L140;
case 15: goto L150;
case 16: goto L160;
}
L10:
infoc_1.infot = 1;
sgemv_("/", &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 2;
sgemv_("N", &c_n1, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 3;
sgemv_("N", &c__0, &c_n1, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 6;
sgemv_("N", &c__2, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 8;
sgemv_("N", &c__0, &c__0, &alpha, a, &c__1, x, &c__0, &beta, y, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 11;
sgemv_("N", &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__0);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
goto L170;
L20:
infoc_1.infot = 1;
sgbmv_("/", &c__0, &c__0, &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
y, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 2;
sgbmv_("N", &c_n1, &c__0, &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
y, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 3;
sgbmv_("N", &c__0, &c_n1, &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
y, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 4;
sgbmv_("N", &c__0, &c__0, &c_n1, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
y, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 5;
sgbmv_("N", &c__2, &c__0, &c__0, &c_n1, &alpha, a, &c__1, x, &c__1, &beta,
y, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 8;
sgbmv_("N", &c__0, &c__0, &c__1, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
y, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 10;
sgbmv_("N", &c__0, &c__0, &c__0, &c__0, &alpha, a, &c__1, x, &c__0, &beta,
y, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 13;
sgbmv_("N", &c__0, &c__0, &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
y, &c__0);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
goto L170;
L30:
infoc_1.infot = 1;
ssymv_("/", &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1)
;
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 2;
ssymv_("U", &c_n1, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1)
;
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 5;
ssymv_("U", &c__2, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1)
;
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 7;
ssymv_("U", &c__0, &alpha, a, &c__1, x, &c__0, &beta, y, &c__1)
;
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 10;
ssymv_("U", &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__0)
;
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
goto L170;
L40:
infoc_1.infot = 1;
ssbmv_("/", &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 2;
ssbmv_("U", &c_n1, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 3;
ssbmv_("U", &c__0, &c_n1, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 6;
ssbmv_("U", &c__0, &c__1, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 8;
ssbmv_("U", &c__0, &c__0, &alpha, a, &c__1, x, &c__0, &beta, y, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 11;
ssbmv_("U", &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__0);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
goto L170;
L50:
infoc_1.infot = 1;
sspmv_("/", &c__0, &alpha, a, x, &c__1, &beta, y, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 2;
sspmv_("U", &c_n1, &alpha, a, x, &c__1, &beta, y, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 6;
sspmv_("U", &c__0, &alpha, a, x, &c__0, &beta, y, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 9;
sspmv_("U", &c__0, &alpha, a, x, &c__1, &beta, y, &c__0);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
goto L170;
L60:
infoc_1.infot = 1;
strmv_("/", "N", "N", &c__0, a, &c__1, x, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 2;
strmv_("U", "/", "N", &c__0, a, &c__1, x, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 3;
strmv_("U", "N", "/", &c__0, a, &c__1, x, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 4;
strmv_("U", "N", "N", &c_n1, a, &c__1, x, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 6;
strmv_("U", "N", "N", &c__2, a, &c__1, x, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 8;
strmv_("U", "N", "N", &c__0, a, &c__1, x, &c__0);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
goto L170;
L70:
infoc_1.infot = 1;
stbmv_("/", "N", "N", &c__0, &c__0, a, &c__1, x, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 2;
stbmv_("U", "/", "N", &c__0, &c__0, a, &c__1, x, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 3;
stbmv_("U", "N", "/", &c__0, &c__0, a, &c__1, x, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 4;
stbmv_("U", "N", "N", &c_n1, &c__0, a, &c__1, x, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 5;
stbmv_("U", "N", "N", &c__0, &c_n1, a, &c__1, x, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 7;
stbmv_("U", "N", "N", &c__0, &c__1, a, &c__1, x, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 9;
stbmv_("U", "N", "N", &c__0, &c__0, a, &c__1, x, &c__0);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
goto L170;
L80:
infoc_1.infot = 1;
stpmv_("/", "N", "N", &c__0, a, x, &c__1)
;
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 2;
stpmv_("U", "/", "N", &c__0, a, x, &c__1)
;
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 3;
stpmv_("U", "N", "/", &c__0, a, x, &c__1)
;
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 4;
stpmv_("U", "N", "N", &c_n1, a, x, &c__1)
;
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 7;
stpmv_("U", "N", "N", &c__0, a, x, &c__0)
;
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
goto L170;
L90:
infoc_1.infot = 1;
strsv_("/", "N", "N", &c__0, a, &c__1, x, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 2;
strsv_("U", "/", "N", &c__0, a, &c__1, x, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 3;
strsv_("U", "N", "/", &c__0, a, &c__1, x, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 4;
strsv_("U", "N", "N", &c_n1, a, &c__1, x, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 6;
strsv_("U", "N", "N", &c__2, a, &c__1, x, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 8;
strsv_("U", "N", "N", &c__0, a, &c__1, x, &c__0);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
goto L170;
L100:
infoc_1.infot = 1;
stbsv_("/", "N", "N", &c__0, &c__0, a, &c__1, x, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 2;
stbsv_("U", "/", "N", &c__0, &c__0, a, &c__1, x, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 3;
stbsv_("U", "N", "/", &c__0, &c__0, a, &c__1, x, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 4;
stbsv_("U", "N", "N", &c_n1, &c__0, a, &c__1, x, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 5;
stbsv_("U", "N", "N", &c__0, &c_n1, a, &c__1, x, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 7;
stbsv_("U", "N", "N", &c__0, &c__1, a, &c__1, x, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 9;
stbsv_("U", "N", "N", &c__0, &c__0, a, &c__1, x, &c__0);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
goto L170;
L110:
infoc_1.infot = 1;
stpsv_("/", "N", "N", &c__0, a, x, &c__1)
;
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 2;
stpsv_("U", "/", "N", &c__0, a, x, &c__1)
;
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 3;
stpsv_("U", "N", "/", &c__0, a, x, &c__1)
;
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 4;
stpsv_("U", "N", "N", &c_n1, a, x, &c__1)
;
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 7;
stpsv_("U", "N", "N", &c__0, a, x, &c__0)
;
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
goto L170;
L120:
infoc_1.infot = 1;
sger_(&c_n1, &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 2;
sger_(&c__0, &c_n1, &alpha, x, &c__1, y, &c__1, a, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 5;
sger_(&c__0, &c__0, &alpha, x, &c__0, y, &c__1, a, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 7;
sger_(&c__0, &c__0, &alpha, x, &c__1, y, &c__0, a, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 9;
sger_(&c__2, &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
goto L170;
L130:
infoc_1.infot = 1;
ssyr_("/", &c__0, &alpha, x, &c__1, a, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 2;
ssyr_("U", &c_n1, &alpha, x, &c__1, a, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 5;
ssyr_("U", &c__0, &alpha, x, &c__0, a, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 7;
ssyr_("U", &c__2, &alpha, x, &c__1, a, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
goto L170;
L140:
infoc_1.infot = 1;
sspr_("/", &c__0, &alpha, x, &c__1, a);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 2;
sspr_("U", &c_n1, &alpha, x, &c__1, a);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 5;
sspr_("U", &c__0, &alpha, x, &c__0, a);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
goto L170;
L150:
infoc_1.infot = 1;
ssyr2_("/", &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 2;
ssyr2_("U", &c_n1, &alpha, x, &c__1, y, &c__1, a, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 5;
ssyr2_("U", &c__0, &alpha, x, &c__0, y, &c__1, a, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 7;
ssyr2_("U", &c__0, &alpha, x, &c__1, y, &c__0, a, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 9;
ssyr2_("U", &c__2, &alpha, x, &c__1, y, &c__1, a, &c__1);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
goto L170;
L160:
infoc_1.infot = 1;
sspr2_("/", &c__0, &alpha, x, &c__1, y, &c__1, a);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 2;
sspr2_("U", &c_n1, &alpha, x, &c__1, y, &c__1, a);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 5;
sspr2_("U", &c__0, &alpha, x, &c__0, y, &c__1, a);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
infoc_1.infot = 7;
sspr2_("U", &c__0, &alpha, x, &c__1, y, &c__0, a);
chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
L170:
if (infoc_1.ok) {
io___396.ciunit = *nout;
s_wsfe(&io___396);
do_fio(&c__1, srnamt, (ftnlen)6);
e_wsfe();
} else {
io___397.ciunit = *nout;
s_wsfe(&io___397);
do_fio(&c__1, srnamt, (ftnlen)6);
e_wsfe();
}
return 0;
/* End of SCHKE. */
} /* schke_ */
/* Subroutine */ int smake_(char *type__, char *uplo, char *diag, integer *m,
integer *n, real *a, integer *nmax, real *aa, integer *lda, integer *
kl, integer *ku, logical *reset, real *transl, ftnlen type_len,
ftnlen uplo_len, ftnlen diag_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer i__, j, i1, i2, i3, kk;
logical gen, tri, sym;
integer ibeg, iend;
extern doublereal sbeg_(logical *);
integer ioff;
logical unit, lower, upper;
/* Generates values for an M by N matrix A within the bandwidth */
/* defined by KL and KU. */
/* Stores the values in the array AA in the data structure required */
/* by the routine, with unwanted elements set to rogue value. */
/* TYPE is 'GE', 'GB', 'SY', 'SB', 'SP', 'TR', 'TB' OR 'TP'. */
/* Auxiliary routine for test program for Level 2 Blas. */
/* -- Written on 10-August-1987. */
/* Richard Hanson, Sandia National Labs. */
/* Jeremy Du Croz, NAG Central Office. */
/* .. Parameters .. */
/* .. Scalar Arguments .. */
/* .. Array Arguments .. */
/* .. Local Scalars .. */
/* .. External Functions .. */
/* .. Intrinsic Functions .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *nmax;
a_offset = 1 + a_dim1;
a -= a_offset;
--aa;
/* Function Body */
gen = *(unsigned char *)type__ == 'G';
sym = *(unsigned char *)type__ == 'S';
tri = *(unsigned char *)type__ == 'T';
upper = (sym || tri) && *(unsigned char *)uplo == 'U';
lower = (sym || tri) && *(unsigned char *)uplo == 'L';
unit = tri && *(unsigned char *)diag == 'U';
/* Generate data in array A. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
if (gen || upper && i__ <= j || lower && i__ >= j) {
if (i__ <= j && j - i__ <= *ku || i__ >= j && i__ - j <= *kl)
{
a[i__ + j * a_dim1] = sbeg_(reset) + *transl;
} else {
a[i__ + j * a_dim1] = 0.f;
}
if (i__ != j) {
if (sym) {
a[j + i__ * a_dim1] = a[i__ + j * a_dim1];
} else if (tri) {
a[j + i__ * a_dim1] = 0.f;
}
}
}
/* L10: */
}
if (tri) {
a[j + j * a_dim1] += 1.f;
}
if (unit) {
a[j + j * a_dim1] = 1.f;
}
/* L20: */
}
/* Store elements in array AS in data structure required by routine. */
if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
aa[i__ + (j - 1) * *lda] = a[i__ + j * a_dim1];
/* L30: */
}
i__2 = *lda;
for (i__ = *m + 1; i__ <= i__2; ++i__) {
aa[i__ + (j - 1) * *lda] = -1e10f;
/* L40: */
}
/* L50: */
}
} else if (s_cmp(type__, "GB", (ftnlen)2, (ftnlen)2) == 0) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *ku + 1 - j;
for (i1 = 1; i1 <= i__2; ++i1) {
aa[i1 + (j - 1) * *lda] = -1e10f;
/* L60: */
}
/* Computing MIN */
i__3 = *kl + *ku + 1, i__4 = *ku + 1 + *m - j;
i__2 = min(i__3,i__4);
for (i2 = i1; i2 <= i__2; ++i2) {
aa[i2 + (j - 1) * *lda] = a[i2 + j - *ku - 1 + j * a_dim1];
/* L70: */
}
i__2 = *lda;
for (i3 = i2; i3 <= i__2; ++i3) {
aa[i3 + (j - 1) * *lda] = -1e10f;
/* L80: */
}
/* L90: */
}
} else if (s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
"TR", (ftnlen)2, (ftnlen)2) == 0) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (upper) {
ibeg = 1;
if (unit) {
iend = j - 1;
} else {
iend = j;
}
} else {
if (unit) {
ibeg = j + 1;
} else {
ibeg = j;
}
iend = *n;
}
i__2 = ibeg - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
aa[i__ + (j - 1) * *lda] = -1e10f;
/* L100: */
}
i__2 = iend;
for (i__ = ibeg; i__ <= i__2; ++i__) {
aa[i__ + (j - 1) * *lda] = a[i__ + j * a_dim1];
/* L110: */
}
i__2 = *lda;
for (i__ = iend + 1; i__ <= i__2; ++i__) {
aa[i__ + (j - 1) * *lda] = -1e10f;
/* L120: */
}
/* L130: */
}
} else if (s_cmp(type__, "SB", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
"TB", (ftnlen)2, (ftnlen)2) == 0) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (upper) {
kk = *kl + 1;
/* Computing MAX */
i__2 = 1, i__3 = *kl + 2 - j;
ibeg = max(i__2,i__3);
if (unit) {
iend = *kl;
} else {
iend = *kl + 1;
}
} else {
kk = 1;
if (unit) {
ibeg = 2;
} else {
ibeg = 1;
}
/* Computing MIN */
i__2 = *kl + 1, i__3 = *m + 1 - j;
iend = min(i__2,i__3);
}
i__2 = ibeg - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
aa[i__ + (j - 1) * *lda] = -1e10f;
/* L140: */
}
i__2 = iend;
for (i__ = ibeg; i__ <= i__2; ++i__) {
aa[i__ + (j - 1) * *lda] = a[i__ + j - kk + j * a_dim1];
/* L150: */
}
i__2 = *lda;
for (i__ = iend + 1; i__ <= i__2; ++i__) {
aa[i__ + (j - 1) * *lda] = -1e10f;
/* L160: */
}
/* L170: */
}
} else if (s_cmp(type__, "SP", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
"TP", (ftnlen)2, (ftnlen)2) == 0) {
ioff = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (upper) {
ibeg = 1;
iend = j;
} else {
ibeg = j;
iend = *n;
}
i__2 = iend;
for (i__ = ibeg; i__ <= i__2; ++i__) {
++ioff;
aa[ioff] = a[i__ + j * a_dim1];
if (i__ == j) {
if (unit) {
aa[ioff] = -1e10f;
}
}
/* L180: */
}
/* L190: */
}
}
return 0;
/* End of SMAKE. */
} /* smake_ */
/* Subroutine */ int smvch_(char *trans, integer *m, integer *n, real *alpha,
real *a, integer *nmax, real *x, integer *incx, real *beta, real *y,
integer *incy, real *yt, real *g, real *yy, real *eps, real *err,
logical *fatal, integer *nout, logical *mv, ftnlen trans_len)
{
/* Format strings */
static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS"
" LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 EX"
"PECTED RESULT COMPU\002,\002TED RESULT\002)";
static char fmt_9998[] = "(1x,i7,2g18.6)";
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
/* Local variables */
integer i__, j, ml, nl, iy, jx, kx, ky;
real erri;
logical tran;
integer incxl, incyl;
/* Fortran I/O blocks */
static cilist io___425 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___426 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___427 = { 0, 0, 0, fmt_9998, 0 };
/* Checks the results of the computational tests. */
/* Auxiliary routine for test program for Level 2 Blas. */
/* -- Written on 10-August-1987. */
/* Richard Hanson, Sandia National Labs. */
/* Jeremy Du Croz, NAG Central Office. */
/* .. Parameters .. */
/* .. Scalar Arguments .. */
/* .. Array Arguments .. */
/* .. Local Scalars .. */
/* .. Intrinsic Functions .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *nmax;
a_offset = 1 + a_dim1;
a -= a_offset;
--x;
--y;
--yt;
--g;
--yy;
/* Function Body */
tran = *(unsigned char *)trans == 'T' || *(unsigned char *)trans == 'C';
if (tran) {
ml = *n;
nl = *m;
} else {
ml = *m;
nl = *n;
}
if (*incx < 0) {
kx = nl;
incxl = -1;
} else {
kx = 1;
incxl = 1;
}
if (*incy < 0) {
ky = ml;
incyl = -1;
} else {
ky = 1;
incyl = 1;
}
/* Compute expected result in YT using data in A, X and Y. */
/* Compute gauges in G. */
iy = ky;
i__1 = ml;
for (i__ = 1; i__ <= i__1; ++i__) {
yt[iy] = 0.f;
g[iy] = 0.f;
jx = kx;
if (tran) {
i__2 = nl;
for (j = 1; j <= i__2; ++j) {
yt[iy] += a[j + i__ * a_dim1] * x[jx];
g[iy] += (r__1 = a[j + i__ * a_dim1] * x[jx], dabs(r__1));
jx += incxl;
/* L10: */
}
} else {
i__2 = nl;
for (j = 1; j <= i__2; ++j) {
yt[iy] += a[i__ + j * a_dim1] * x[jx];
g[iy] += (r__1 = a[i__ + j * a_dim1] * x[jx], dabs(r__1));
jx += incxl;
/* L20: */
}
}
yt[iy] = *alpha * yt[iy] + *beta * y[iy];
g[iy] = dabs(*alpha) * g[iy] + (r__1 = *beta * y[iy], dabs(r__1));
iy += incyl;
/* L30: */
}
/* Compute the error ratio for this result. */
*err = 0.f;
i__1 = ml;
for (i__ = 1; i__ <= i__1; ++i__) {
erri = (r__1 = yt[i__] - yy[(i__ - 1) * abs(*incy) + 1], dabs(r__1)) /
*eps;
if (g[i__] != 0.f) {
erri /= g[i__];
}
*err = dmax(*err,erri);
if (*err * sqrt(*eps) >= 1.f) {
goto L50;
}
/* L40: */
}
/* If the loop completes, all results are at least half accurate. */
goto L70;
/* Report fatal error. */
L50:
*fatal = TRUE_;
io___425.ciunit = *nout;
s_wsfe(&io___425);
e_wsfe();
i__1 = ml;
for (i__ = 1; i__ <= i__1; ++i__) {
if (*mv) {
io___426.ciunit = *nout;
s_wsfe(&io___426);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&yt[i__], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&yy[(i__ - 1) * abs(*incy) + 1], (ftnlen)
sizeof(real));
e_wsfe();
} else {
io___427.ciunit = *nout;
s_wsfe(&io___427);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&yy[(i__ - 1) * abs(*incy) + 1], (ftnlen)
sizeof(real));
do_fio(&c__1, (char *)&yt[i__], (ftnlen)sizeof(real));
e_wsfe();
}
/* L60: */
}
L70:
return 0;
/* End of SMVCH. */
} /* smvch_ */
logical lse_(real *ri, real *rj, integer *lr)
{
/* System generated locals */
integer i__1;
logical ret_val;
/* Local variables */
integer i__;
/* Tests if two arrays are identical. */
/* Auxiliary routine for test program for Level 2 Blas. */
/* -- Written on 10-August-1987. */
/* Richard Hanson, Sandia National Labs. */
/* Jeremy Du Croz, NAG Central Office. */
/* .. Scalar Arguments .. */
/* .. Array Arguments .. */
/* .. Local Scalars .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--rj;
--ri;
/* Function Body */
i__1 = *lr;
for (i__ = 1; i__ <= i__1; ++i__) {
if (ri[i__] != rj[i__]) {
goto L20;
}
/* L10: */
}
ret_val = TRUE_;
goto L30;
L20:
ret_val = FALSE_;
L30:
return ret_val;
/* End of LSE. */
} /* lse_ */
logical lseres_(char *type__, char *uplo, integer *m, integer *n, real *aa,
real *as, integer *lda, ftnlen type_len, ftnlen uplo_len)
{
/* System generated locals */
integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2;
logical ret_val;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer i__, j, ibeg, iend;
logical upper;
/* Tests if selected elements in two arrays are equal. */
/* TYPE is 'GE', 'SY' or 'SP'. */
/* Auxiliary routine for test program for Level 2 Blas. */
/* -- Written on 10-August-1987. */
/* Richard Hanson, Sandia National Labs. */
/* Jeremy Du Croz, NAG Central Office. */
/* .. Scalar Arguments .. */
/* .. Array Arguments .. */
/* .. Local Scalars .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
as_dim1 = *lda;
as_offset = 1 + as_dim1;
as -= as_offset;
aa_dim1 = *lda;
aa_offset = 1 + aa_dim1;
aa -= aa_offset;
/* Function Body */
upper = *(unsigned char *)uplo == 'U';
if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *lda;
for (i__ = *m + 1; i__ <= i__2; ++i__) {
if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) {
goto L70;
}
/* L10: */
}
/* L20: */
}
} else if (s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (upper) {
ibeg = 1;
iend = j;
} else {
ibeg = j;
iend = *n;
}
i__2 = ibeg - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) {
goto L70;
}
/* L30: */
}
i__2 = *lda;
for (i__ = iend + 1; i__ <= i__2; ++i__) {
if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) {
goto L70;
}
/* L40: */
}
/* L50: */
}
}
/* L60: */
ret_val = TRUE_;
goto L80;
L70:
ret_val = FALSE_;
L80:
return ret_val;
/* End of LSERES. */
} /* lseres_ */
doublereal sbeg_(logical *reset)
{
/* System generated locals */
real ret_val;
/* Local variables */
static integer i__, ic, mi;
/* Generates random numbers uniformly distributed between -0.5 and 0.5. */
/* Auxiliary routine for test program for Level 2 Blas. */
/* -- Written on 10-August-1987. */
/* Richard Hanson, Sandia National Labs. */
/* Jeremy Du Croz, NAG Central Office. */
/* .. Scalar Arguments .. */
/* .. Local Scalars .. */
/* .. Save statement .. */
/* .. Intrinsic Functions .. */
/* .. Executable Statements .. */
if (*reset) {
/* Initialize local variables. */
mi = 891;
i__ = 7;
ic = 0;
*reset = FALSE_;
}
/* The sequence of values of I is bounded between 1 and 999. */
/* If initial I = 1,2,3,6,7 or 9, the period will be 50. */
/* If initial I = 4 or 8, the period will be 25. */
/* If initial I = 5, the period will be 10. */
/* IC is used to break up the period by skipping 1 value of I in 6. */
++ic;
L10:
i__ *= mi;
i__ -= i__ / 1000 * 1000;
if (ic >= 5) {
ic = 0;
goto L10;
}
ret_val = (real) (i__ - 500) / 1001.f;
return ret_val;
/* End of SBEG. */
} /* sbeg_ */
doublereal sdiff_(real *x, real *y)
{
/* System generated locals */
real ret_val;
/* Auxiliary routine for test program for Level 2 Blas. */
/* -- Written on 10-August-1987. */
/* Richard Hanson, Sandia National Labs. */
/* .. Scalar Arguments .. */
/* .. Executable Statements .. */
ret_val = *x - *y;
return ret_val;
/* End of SDIFF. */
} /* sdiff_ */
/* Subroutine */ int chkxer_(char *srnamt, integer *infot, integer *nout,
logical *lerr, logical *ok)
{
/* Format strings */
static char fmt_9999[] = "(\002 ***** ILLEGAL VALUE OF PARAMETER NUMBER"
" \002,i2,\002 NOT D\002,\002ETECTED BY \002,a6,\002 *****\002)";
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Fortran I/O blocks */
static cilist io___437 = { 0, 0, 0, fmt_9999, 0 };
/* Tests whether XERBLA has detected an error when it should. */
/* Auxiliary routine for test program for Level 2 Blas. */
/* -- Written on 10-August-1987. */
/* Richard Hanson, Sandia National Labs. */
/* Jeremy Du Croz, NAG Central Office. */
/* .. Scalar Arguments .. */
/* .. Executable Statements .. */
if (! (*lerr)) {
io___437.ciunit = *nout;
s_wsfe(&io___437);
do_fio(&c__1, (char *)&(*infot), (ftnlen)sizeof(integer));
do_fio(&c__1, srnamt, (ftnlen)6);
e_wsfe();
*ok = FALSE_;
}
*lerr = FALSE_;
return 0;
/* End of CHKXER. */
} /* chkxer_ */
/* Subroutine */ int xerbla_(char *srname, integer *info)
{
/* Format strings */
static char fmt_9999[] = "(\002 ******* XERBLA WAS CALLED WITH INFO ="
" \002,i6,\002 INSTEAD\002,\002 OF \002,i2,\002 *******\002)";
static char fmt_9997[] = "(\002 ******* XERBLA WAS CALLED WITH INFO ="
" \002,i6,\002 *******\002)";
static char fmt_9998[] = "(\002 ******* XERBLA WAS CALLED WITH SRNAME ="
" \002,a6,\002 INSTE\002,\002AD OF \002,a6,\002 *******\002)";
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_cmp(char *, char *, ftnlen, ftnlen);
/* Fortran I/O blocks */
static cilist io___438 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___439 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___440 = { 0, 0, 0, fmt_9998, 0 };
/* This is a special version of XERBLA to be used only as part of */
/* the test program for testing error exits from the Level 2 BLAS */
/* routines. */
/* XERBLA is an error handler for the Level 2 BLAS routines. */
/* It is called by the Level 2 BLAS routines if an input parameter is */
/* invalid. */
/* Auxiliary routine for test program for Level 2 Blas. */
/* -- Written on 10-August-1987. */
/* Richard Hanson, Sandia National Labs. */
/* Jeremy Du Croz, NAG Central Office. */
/* .. Scalar Arguments .. */
/* .. Scalars in Common .. */
/* .. Common blocks .. */
/* .. Executable Statements .. */
infoc_2.lerr = TRUE_;
if (*info != infoc_2.infot) {
if (infoc_2.infot != 0) {
io___438.ciunit = infoc_2.nout;
s_wsfe(&io___438);
do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&infoc_2.infot, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___439.ciunit = infoc_2.nout;
s_wsfe(&io___439);
do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
e_wsfe();
}
infoc_2.ok = FALSE_;
}
if (s_cmp(srname, srnamc_1.srnamt, (ftnlen)6, (ftnlen)6) != 0) {
io___440.ciunit = infoc_2.nout;
s_wsfe(&io___440);
do_fio(&c__1, srname, (ftnlen)6);
do_fio(&c__1, srnamc_1.srnamt, (ftnlen)6);
e_wsfe();
infoc_2.ok = FALSE_;
}
return 0;
/* End of XERBLA */
} /* xerbla_ */
/* Main program alias */ int sblat2_ () { MAIN__ (); return 0; }