/* f06ycce.c * * Copyright 1992 Numerical Algorithms Group. * * Mark 3, 1992. * Mark 5 revised, 1998. * Mark 6 revised, 2000. * Mark 7 revised, 2001. * */ #include #include #include #include #include #include #include /* Common Block Declarations */ struct { Integer infot, nout; int ok, lerr; } infoc; #define NSUBS 6 #define ZERO 0.0 #define ONE 1.0 #define NMAX 20 #define NIDMAX 9 #define NALMAX 7 #define NBEMAX 7 #define nmax_2 NMAX *2 #define nmax_nmax NMAX * NMAX struct { char srnamt[14]; } srnamc; /* Table of constant values */ static Integer c__1 = 1; static double c_b88 = 1.0; static double c_b91 = 0.0; static double transpose_aa [nmax_nmax]; static double transpose_bb [nmax_nmax]; static double transpose_cc [nmax_nmax]; static void schk1(const char sname[], double eps, double thresh, int trace, int rewi, int *fatal, Integer nidim, Integer idim[], Integer nalf, double alf[], Integer nbet, double bet[], Integer nmax, double a[], double aa[], double as[], double b[], double bb[], double bs[], double c[], double cc[], double cs[], double ct[], double g[]); static void schk2(const char sname[], double eps, double thresh, int trace, int rewi, int *fatal, Integer nidim, Integer idim[], Integer nalf, double alf[], Integer nbet, double bet[], Integer nmax, double a[], double aa[], double as[], double b[], double bb[], double bs[], double c[], double cc[], double cs[], double ct[], double g[]); static void schk3(const char sname[], double eps, double thresh, int trace, int rewi, int *fatal, Integer nidim, Integer idim[], Integer nalf, double alf[], Integer nmax, double a[], double aa[], double as[], double b[], double bb[], double bs[], double ct[], double g[], double c[]); static void schk4(const char sname[], double eps, double thresh, int trace, int rewi, int *fatal, Integer nidim, Integer idim[], Integer nalf, double alf[], Integer nbet, double bet[], Integer nmax, double a[], double aa[], double as[], double b[], double bb[], double bs[], double c[], double cc[], double cs[], double ct[], double g[]); static void schk5(const char sname[], double eps, double thresh, int trace, int rewi, int *fatal, Integer nidim, Integer idim[], Integer nalf, double alf[], Integer nbet, double bet[], Integer nmax, double ab[], double aa[], double as[], double bb[], double bs[], double c[], double cc[], double cs[], double ct[], double g[], double w[]); static void schke(Integer isnum, const char srnamt[]); static void smake(const char type[], char uplo, char diag, Integer m, Integer n, double a[], Integer nmax, double aa[], Integer tda, int *reset, double transl); static void smmch(char transa, char transb, Integer m, Integer n, Integer kk, double alpha, double a[], Integer tda, double b[], Integer tdb, double beta, double c[], Integer tdc, double ct[], double g[], double cc[], Integer tdcc, double eps, double *err, int *fatal, int mv); static int lse(double ri[], double rj[], Integer lr); static int lseres(const char type[], char uplo, Integer m, Integer n, double aa[], double as[], Integer tda); static double sbeg(int *reset); static void chkxer(const char srnamt[], Integer infot, int *lerr, int *ok); int main(void) { /* Initialized data */ static const char *snames[NSUBS] = {"f06yac/dgemm", "f06ycc/dsymm", "f06yfc/dtrmm", "f06yjc/dtrsm", "f06ypc/dsyrk", "f06yrc/dsyr2k"}; /* Local variables */ Integer nalf, idim[NIDMAX]; int same; Integer nbet; int rewi; static double c[NMAX*NMAX], g[NMAX]; Integer i, j, n; int fatal; double w[2*NMAX]; int trace; Integer nidim; Integer isnum; int ltest[NSUBS]; static double aa[NMAX*NMAX], ab[2*NMAX*NMAX], bb[NMAX*NMAX], cc[NMAX*NMAX], as[NMAX*NMAX], bs[NMAX*NMAX], cs[NMAX*NMAX], ct[NMAX]; int sfatal; char snamet[7], transa, transb; double thresh; int ltestt, tsterr; static double alf[NALMAX], bet[NBEMAX]; double eps, err; Vprintf("f06ycc Example Program Results\n\n"); Vscanf("%*[^\n]"); infoc.nout = 6; rewi = FALSE; /* Read flags */ /* Read the flag that directs tracing of execution */ Vscanf("%d%*[^\n]", &trace); /* Read the flag that directs stopping on any failure. */ Vscanf("%d%*[^\n]", &sfatal); /* Read the flag that indicates whether error exits are to be tested. */ Vscanf("%d%*[^\n]", &tsterr); /* Read the threshold value of the test ratio */ Vscanf("%lf%*[^\n]", &thresh); /* Read and check the parameter values for the tests. */ /* Values of N */ Vscanf("%ld%*[^\n]", &nidim); if (nidim < 1 || nidim > NIDMAX) { Vprintf("Number of values of n is less than 1 or greater than %2d\n", NIDMAX); goto L400; } for (i = 1; i <= nidim; ++i) Vscanf("%ld", &idim[i-1]); Vscanf("%*[^\n]"); for (i = 1; i <= nidim; ++i) { if (idim[i - 1] < 0 || idim[i - 1] > NMAX) { Vprintf("Value of n is less than 0 or greater than %2d\n", NMAX); goto L400; } } /* Values of alpha */ Vscanf("%ld%*[^\n]", &nalf); if (nalf < 1 || nalf > NALMAX) { Vprintf("Number of values of alpha is less than 1 or greater than, %2d\n", NALMAX); goto L400; } for (i = 1; i <= nalf; ++i) Vscanf("%lf", &alf[i-1]); Vscanf("%*[^\n]"); /* Values of beta */ Vscanf("%ld%*[^\n]", &nbet); if (nbet < 1 || nbet > NBEMAX) { Vprintf("Number of values of beta is less than 1 or greater than, %2d\n", NBEMAX); goto L400; } for (i = 1; i <= nbet; ++i) Vscanf("%lf", &bet[i-1]); Vscanf("%*[^\n]"); /* Report values of parameters. */ Vprintf("Tests of the real level 3 BLAS\n" "The following parameter values will be used\n"); Vprintf(" For n "); for (i = 1; i <= nidim; ++i) Vprintf("%ld%c", idim[i-1], ( ! i%NIDMAX || i==nidim) ? '\n' : ' '); Vprintf(" For alpha "); for (i = 1; i <= nalf; ++i) Vprintf("%6.1f%c", alf[i-1], (! i%NALMAX || i==nalf) ? '\n' : ' '); Vprintf(" For beta "); for (i = 1; i <= nbet; ++i) Vprintf("%6.1f%c", bet[i-1], (! i%NBEMAX || i==nbet) ? '\n' : ' '); if (! tsterr) Vprintf("Error-exits will not be tested\n"); Vprintf("Functions pass computational tests if test ratio is" " less than %8.2f\n", thresh); /* Read names of subroutines and flags which indicate */ /* whether they are to be tested. */ for (i = 1; i <= NSUBS; ++i) ltest[i - 1] = FALSE; while (scanf("%s%d%*[^\n]", snamet, <estt) != EOF) { for (i = 1; i <= NSUBS; ++i) { if (! strncmp(snamet, snames[i-1], 6)) goto L100; } Vprintf("Function name %s not recognized \n" "******* Tests abandoned *******\n", snamet); return EXIT_FAILURE; L100: ltest[i - 1] = ltestt; } /* Compute eps (the machine precision). */ eps = X02AJC; Vprintf("Relative machine precision is taken to be %9.1e\n", eps); /* Check the reliability of SMMCH using exact data. */ n = MIN(32, NMAX); for (j = 1; j <= n; ++j) { for (i = 1; i <= n; ++i) ab[i + (j-1)*NMAX - 1] = (double) MAX(i-j+1,0); ab[j + NMAX*NMAX-1] = (double) j; ab[(j-1+NMAX)*NMAX] = (double) j; c[j - 1] = 0.0; } for (j = 1; j <= n; ++j) { cc[j - 1] = (double) (j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3); } /* CC holds the exact result. On exit from SMMCH CT holds */ /* the result computed by SMMCH. */ transa = 'n'; transb = 'n'; smmch(transa, transb, n, (Integer)1, n, c_b88, ab, (Integer)NMAX, &ab[NMAX*NMAX], (Integer)NMAX, c_b91, c, (Integer)NMAX, ct, g, cc, (Integer)NMAX, eps, &err, &fatal, 1); same = lse(cc, ct, n); if (! same || err != 0.0) { Vprintf("Error in smvch - in-line dot products are being " "evaluated wrongly.\nsmvch was called with transa = %c and transb = %c and " "returned same = %d and err = %12.3f.\nThis may be due to faults in the " "arithmetic or the compiler.\n******* Tests abandoned *******\n", transa, transb, same, err); return EXIT_FAILURE; } transb = 't'; smmch(transa, transb, n, (Integer)1, n, c_b88, ab, (Integer)NMAX, &ab[NMAX*NMAX], (Integer)NMAX, c_b91, c, (Integer)NMAX, ct, g, cc, (Integer)NMAX, eps, &err, &fatal, 1); same = lse(cc, ct, n); if (! same || err != 0.0) { Vprintf("Error in smvch - in-line dot products are being " "evaluated wrongly.\nsmvch was called with transa = %c and transb = %c and " "returned same = %d and err = %12.3f.\nThis may be due to faults in the " "arithmetic or the compiler.\n******* Tests abandoned *******\n", transa, transb, same, err); return EXIT_FAILURE; } for (j = 1; j <= n; ++j) { ab[j + nmax_nmax-1] = (double) (n - j + 1); ab[(j + NMAX) * NMAX - NMAX] = (double) (n - j + 1); } for (j = 1; j <= n; ++j) { cc[n - j] = (double) (j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3); } transa = 't'; transb = 'n'; smmch(transa, transb, n, (Integer)1, n, c_b88, ab, (Integer)NMAX, &ab[NMAX*NMAX], (Integer)NMAX, c_b91, c, (Integer)NMAX, ct, g, cc, (Integer)NMAX, eps, &err, &fatal, 1); same = lse(cc, ct, n); if (! same || err != 0.0) { Vprintf("Error in smvch - in-line dot products are being " "evaluated wrongly.\nsmvch was called with transa = %c and transb = %c and " "returned same = %d and err = %12.3f.\nThis may be due to faults in the " "arithmetic or the compiler.\n******* Tests abandoned *******\n", transa, transb, same, err); return EXIT_FAILURE; } transb = 't'; smmch(transa, transb, n, (Integer)1, n, c_b88, ab, (Integer)NMAX, &ab[NMAX*NMAX], (Integer)NMAX, c_b91, c, (Integer)NMAX, ct, g, cc, (Integer)NMAX, eps, &err, &fatal, 1); same = lse(cc, ct, n); if (! same || err != 0.0) { Vprintf("Error in smvch - in-line dot products are being " "evaluated wrongly.\nsmvch was called with transa = %c and transb = %c and " "returned same = %d and err = %12.3f.\nThis may be due to faults in the " "arithmetic or the compiler.\n******* Tests abandoned *******\n", transa, transb, same, err); return EXIT_FAILURE; } /* Test each subroutine in turn. */ for (isnum = 1; isnum <= 6; ++isnum) { Vprintf("\n"); if (! ltest[isnum - 1]) { /* Subprogram is not to be tested. */ Vprintf("%6s was not tested\n", snames[isnum - 1]); } else { strcpy(srnamc.srnamt, snames[isnum-1]); /* Test error exits. */ if (tsterr) { Vprintf("\n"); schke(isnum, snames[isnum-1]); Vprintf("\n"); } /* Test computations. */ infoc.infot = 0; infoc.ok = TRUE; fatal = FALSE; switch ((int)isnum) { case 1: goto L240; case 2: goto L260; case 3: goto L280; case 4: goto L280; case 5: goto L300; case 6: goto L320; } /* Test f06yac, 01. */ L240: schk1(snames[isnum - 1], eps, thresh, trace, rewi, &fatal, nidim, idim, nalf, alf, nbet, bet, (Integer)NMAX, ab, aa, as, &ab[NMAX*NMAX], bb, bs, c, cc, cs, ct, g); goto L340; /* Test f06ycc, 02. */ L260: schk2(snames[isnum-1], eps, thresh, trace, rewi, &fatal, nidim, idim, nalf, alf, nbet, bet, (Integer)NMAX, ab, aa, as, &ab[NMAX*NMAX], bb, bs, c, cc, cs, ct, g); goto L340; /* Test f06yfc, 03, f06yjc, 04. */ L280: schk3(snames[isnum-1], eps, thresh, trace, rewi, &fatal, nidim, idim, nalf, alf, (Integer)NMAX, ab, aa, as, &ab[NMAX*NMAX], bb, bs, ct, g, c); goto L340; /* Test f06ypc, 05. */ L300: schk4(snames[isnum-1], eps, thresh, trace, rewi, &fatal, nidim, idim, nalf, alf, nbet, bet, (Integer)NMAX, ab, aa, as, &ab[NMAX*NMAX], bb, bs, c, cc, cs, ct, g); goto L340; /* Test f06yrc, 06. */ L320: schk5(snames[isnum-1], eps, thresh, trace, rewi, &fatal, nidim, idim, nalf, alf, nbet, bet, (Integer)NMAX, ab, aa, as, bb, bs, c, cc, cs, ct, g, w) ; goto L340; L340: if (fatal && sfatal) goto L380; } } Vprintf("End of tests\n"); return EXIT_SUCCESS; L380: Vprintf("******* Fatal error - Tests abandoned *******\n"); goto L420; L400: Vprintf("Amend data file or increase array sizes in program\n" "******* Tests abandoned *******\n"); L420: return EXIT_FAILURE; } /* End of SBLAT3. */ /* ------------------------------------------------------------------------ */ static void schk1(const char sname[], double eps, double thresh, int trace, int rewi, int *fatal, Integer nidim, Integer idim[], Integer nalf, double alf[], Integer nbet, double bet[], Integer nmax, double a[], double aa[], double as[], double b[], double bb[], double bs[], double c[], double cc[], double cs[], double ct[], double g[]) { /* Initialized data */ static char ich[4] = "ntc"; /* Local variables */ double beta; Integer tdas, tdbs, ldcs; int same, null; Integer i, j, k, m, n; double alpha; int isame[13]; int trana, tranb; Integer nargs; int reset; Integer ia, ib, ma, mb, na, nb, nc, ik, im, in, ks, ms, ns; char transa, transb; double errmax; Integer ica, icb, laa, lbb, tda, lcc, tdb, ldc; double als, bls; double err; Integer max_d; MatrixTranspose transa_c, transb_c, tranas_c, tranbs_c; /* Auxiliary routine for test program for Level 3 Blas. */ #define G(I) g[(I)-1] #define CT(I) ct[(I)-1] #define CS(I) cs[(I)-1] #define CC(I) cc[(I)-1] #define BS(I) bs[(I)-1] #define BB(I) bb[(I)-1] #define AS(I) as[(I)-1] #define AA(I) aa[(I)-1] #define BET(I) bet[(I)-1] #define ALF(I) alf[(I)-1] #define IDIM(I) idim[(I)-1] /* .. Executable Statements .. */ if (trace) { Vprintf("\nComputational tests : \n"); Vprintf("\nf06yac tested with : \n"); Vprintf("(Transpose (t), Transpose (t),.........)\n"); Vprintf("(Notranspose (n), Transpose (t),.........)\n"); Vprintf("(ConjugateTranspose (c), ConjugateTranspose (c),.........)\n\n"); } nargs = 13; nc = 0; reset = TRUE; errmax = 0.0; for (im = 1; im <= nidim; ++im) { m = IDIM(im); for (in = 1; in <= nidim; ++in) { n = IDIM(in); /* Set LDC to 1 more than minimum value if room. */ ldc = m; ldc = nmax; /* if (ldc < nmax) { GL 24/6/1992 ++ldc; } */ /* Skip tests if not enough room. */ if (ldc > nmax) goto L200; lcc = ldc * n; null = n <= 0 || m <= 0; for (ik = 1; ik <= nidim; ++ik) { k = IDIM(ik); for (ica = 1; ica <= 3; ++ica) { transa = ich[ica - 1]; trana = transa == 't' || transa == 'c'; if (transa == 't') transa_c = Transpose; else if (transa == 'c') transa_c = ConjugateTranspose; else transa_c = NoTranspose; if (trana) { ma = k; na = m; } else { ma = m; na = k; } /* Set tda to 1 more than minimum value if room. */ tda = ma; tda = nmax; /* if (tda < nmax) { GL 24/6/1992 ++tda; } */ /* Skip tests if not enough room. */ if (tda > nmax) goto L160; laa = tda * na; /* Generate the matrix A. */ smake("ge", ' ', ' ', ma, na, a, nmax, aa, tda, &reset, c_b91); for (icb = 1; icb <= 3; ++icb) { transb = ich[icb - 1]; tranb = transb == 't' || transb == 'c'; transb_c = NoTranspose; if (transb == 't') transb_c = Transpose; else if (transb == 'c') transb_c = ConjugateTranspose; if (tranb) { mb = n; nb = k; } else { mb = k; nb = n; } /* Set tdb to 1 more than minimum value if room. */ tdb = mb; tdb = nmax; /* GL 24/6/1992 if (tdb < nmax) { ++tdb; } */ /* Skip tests if not enough room. */ if (tdb > nmax) goto L140; lbb = tdb * nb; /* Generate the matrix B. */ smake("ge", ' ', ' ', mb, nb, b, nmax, bb, tdb, &reset, c_b91); for (ia = 1; ia <= nalf; ++ia) { alpha = ALF(ia); for (ib = 1; ib <= nbet; ++ib) { beta = BET(ib); /* Generate the matrix C. */ smake("ge", ' ', ' ', m, n, c, nmax, cc, ldc, &reset, c_b91); ++nc; /* Save every datum before calling the subroutine. */ tranas_c = transa_c; tranbs_c = transb_c; ms = m; ns = n; ks = k; als = alpha; for (i = 1; i <= laa; ++i) AS(i) = AA(i); tdas = tda; for (i = 1; i <= lbb; ++i) BS(i) = BB(i); tdbs = tdb; bls = beta; for (i = 1; i <= lcc; ++i) CS(i) = CC(i); ldcs = ldc; /* Call the subroutine. */ if (trace) { Vprintf("%6ld: %6s(%c, %c,%3ld," "%3ld,%3ld,%4.1f, A,%3ld, B,%3ld,%4.1f, C,%3ld).\n", nc, sname, transa, transb, m, n, k, alpha, tda, tdb, beta, ldc); } max_d = MAX(m, k); if (n > max_d) max_d = n; for (j =0; j < max_d; ++j) { for (i = 0; i < max_d; ++i) { transpose_aa[i * tda + j] = aa[i + j * tda]; transpose_bb[i * tda + j] = bb[i + j * tda]; transpose_cc[i * tda + j] = cc[i + j * tda]; } } f06yac(transa_c, transb_c, m, n, k, alpha, transpose_aa, tda, transpose_bb, tdb, beta, transpose_cc, ldc); for (j =0; j < max_d; ++j) { for (i = 0; i < max_d; ++i) { aa[i + j * tda] = transpose_aa[i * tda + j]; bb[i + j * tda] = transpose_bb[i * tda + j]; cc[i + j * tda] = transpose_cc[i * tda + j]; } } /* Check if error-exit was taken incorrectly. */ if (! infoc.ok) { Vprintf(" ******* Fatal error - " "error-exit taken on valid call ******\n"); *fatal = TRUE; goto L240; } /* See what data changed inside subroutines. */ isame[0] = transa_c == tranas_c; isame[1] = transb_c == tranbs_c; isame[2] = ms == m; isame[3] = ns == n; isame[4] = ks == k; isame[5] = als == alpha; isame[6] = lse(as, aa, laa); isame[7] = tdas == tda; isame[8] = lse(bs, bb, lbb); isame[9] = tdbs == tdb; isame[10] = bls == beta; if (null) isame[11] = lse(cs, cc, lcc); else { isame[11] = lseres("ge", ' ', m, n, cs, cc, ldc); } isame[12] = ldcs == ldc; /* If data was incorrectly changed, report and return. */ same = TRUE; for (i = 1; i <= nargs; ++i) { same = same && isame[i - 1]; if (! isame[i - 1]) { Vprintf(" ******* Fatal error - " "parameter number %2ld was changed incorrectly *******\n", i); } } if (! same) { *fatal = TRUE; goto L240; } if (! null) { /* Check the result. */ smmch(transa, transb, m, n, k, alpha, a, nmax, b, nmax, beta, c, nmax, ct, g, cc, ldc, eps, &err, fatal, 1); errmax = MAX(errmax,err); /* If got really bad answer, report and return. */ if (*fatal) goto L240; } } } L140: ; } L160: ; } } L200: ; } } /* Report result. */ if (errmax < thresh) { Vprintf("%.6s passed the computational tests ( %6ld calls)\n", sname, nc); } else { Vprintf("%.6s completed the computational tests (%6ld calls)\n" "******* but with maximum test ratio ,%8.2f,- suspect *******\n", sname, nc, errmax); } goto L260; L240: Vprintf("******* %.6s failed on call number:\n", sname); Vprintf("%6ld: %6s(%c, %c,%3ld," "%3ld,%3ld,%4.1f, A,%3ld, B,%3ld,%4.1f, C,%3ld).\n", nc, sname, transa, transb, m, n, k, alpha, tda, tdb, beta, ldc); L260: ; } /* schk1 */ /* ---------------------------------------------------------------------- */ static void schk2(const char sname[], double eps, double thresh, int trace, int rewi, int *fatal, Integer nidim, Integer idim[], Integer nalf, double alf[], Integer nbet, double bet[], Integer nmax, double a[], double aa[], double as[], double b[], double bb[], double bs[], double c[], double cc[], double cs[], double ct[], double g[]) { /* Initialized data */ static char ichs[3] = "lr"; static char ichu[3] = "ul"; /* Local variables */ double beta; Integer tdas, tdbs, ldcs; int same; char side; int left, null; char uplo; Integer i, j, m, n; double alpha; int isame[13]; Integer nargs; int reset; Integer ia, max_d, ib, na, nc, im, in, ms, ns; double errmax; Integer laa, lbb, tda, lcc, tdb, ldc, ics; double als, bls; Integer icu; double err; MatrixTriangle uplo_c, uplos_c; OperationSide side_c, sides_c; /* Tests f06ycc. */ #define G(I) g[(I)-1] #define CT(I) ct[(I)-1] #define CS(I) cs[(I)-1] #define CC(I) cc[(I)-1] #define BS(I) bs[(I)-1] #define BB(I) bb[(I)-1] #define AS(I) as[(I)-1] #define AA(I) aa[(I)-1] #define BET(I) bet[(I)-1] #define ALF(I) alf[(I)-1] #define IDIM(I) idim[(I)-1] /* .. Executable Statements .. */ if (trace) { Vprintf("\nComputational tests : \n"); Vprintf("\nf06ycc tested with : \n"); Vprintf("(RightSide (r), UpperTriangle (u),.........)\n"); Vprintf("(LeftSide (l), LowerTriangle (l),....)\n\n"); } nargs = 12; nc = 0; reset = TRUE; errmax = 0.0; for (im = 1; im <= nidim; ++im) { m = IDIM(im); for (in = 1; in <= nidim; ++in) { n = IDIM(in); /* Set LDC to 1 more than minimum value if room. */ ldc = m; ldc = nmax; /* if (ldc < nmax) { ++ldc; } */ /* Skip tests if not enough room. */ if (ldc > nmax) goto L180; lcc = ldc * n; null = n <= 0 || m <= 0; /* Set tdb to 1 more than minimum value if room. */ tdb = m; tdb = nmax; /* if (tdb < nmax) { ++tdb; } */ /* Skip tests if not enough room. */ if (tdb > nmax) goto L180; lbb = tdb * n; /* Generate the matrix B. */ smake("ge", ' ', ' ', m, n, b, nmax, bb, tdb, & reset, c_b91); for (ics = 1; ics <= 2; ++ics) { side = ichs[ics - 1]; left = side == 'l'; if (left) { side_c = LeftSide; na = m; } else { side_c = RightSide; na = n; } /* Set LDA to 1 more than minimum value if room. */ tda = na; tda = nmax; /* if (tda < nmax) { ++tda; } */ /* Skip tests if not enough room. */ if (tda > nmax) goto L160; laa = tda * na; for (icu = 1; icu <= 2; ++icu) { uplo = ichu[icu - 1]; if(uplo == 'u') uplo_c = UpperTriangle; else uplo_c = LowerTriangle; /* Generate the symmetric matrix A. */ smake("sy", uplo, ' ', na, na, a, nmax, aa, tda, &reset, c_b91); for (ia = 1; ia <= nalf; ++ia) { alpha = ALF(ia); for (ib = 1; ib <= nbet; ++ib) { beta = BET(ib); /* Generate the matrix C. */ smake("ge", ' ', ' ', m, n, c, nmax, cc, ldc, &reset, c_b91) ; ++nc; /* Save every datum before calling the subroutine. */ sides_c = side_c; uplos_c = uplo_c; ms = m; ns = n; als = alpha; for (i = 1; i <= laa; ++i) AS(i) = AA(i); tdas = tda; for (i = 1; i <= lbb; ++i) BS(i) = BB(i); tdbs = tdb; bls = beta; for (i = 1; i <= lcc; ++i) CS(i) = CC(i); ldcs = ldc; /* Call the subroutine. */ if (trace) { Vprintf("%6ld: %6s(%c, %c,%3ld," "%3ld,%4.1f, A,%3ld, B,%3ld,%4.1f, C,%3ld).\n", nc, sname, side, uplo, m, n, alpha, tda, tdb, beta, ldc); } max_d = MAX(m, n); for (j =0; j < max_d; ++j) { for (i = 0; i < max_d; ++i) { transpose_aa[i * tda + j] = aa[i + j * tda]; transpose_bb[i * tda + j] = bb[i + j * tda]; transpose_cc[i * tda + j] = cc[i + j * tda]; } } f06ycc(side_c, uplo_c, m, n, alpha, transpose_aa, tda, transpose_bb, tdb, beta, transpose_cc, ldc); for (j =0; j < max_d; ++j) { for (i = 0; i < max_d; ++i) { aa[i + j * tda] = transpose_aa[i * tda + j]; bb[i + j * tda] = transpose_bb[i * tda + j]; cc[i + j * tda] = transpose_cc[i * tda + j]; } } /* Check if error-exit was taken incorrectly. */ if (! infoc.ok) { Vprintf(" ******* Fatal error - error-exit taken on valid call *******)\n"); *fatal = TRUE; goto L220; } /* See what data changed inside subroutines. */ isame[0] = sides_c == side_c; isame[1] = uplos_c == uplo_c; isame[2] = ms == m; isame[3] = ns == n; isame[4] = als == alpha; isame[5] = lse(as, aa, laa); isame[6] = tdas == tda; isame[7] = lse(bs, bb, lbb); isame[8] = tdbs == tdb; isame[9] = bls == beta; if (null) isame[10] = lse(cs, cc, lcc); else isame[10] = lseres("ge", ' ', m, n, cs, cc, ldc); isame[11] = ldcs == ldc; /* If data was incorrectly changed, report and return. */ same = TRUE; for (i = 1; i <= nargs; ++i) { same = same && isame[i - 1]; if (! isame[i - 1]) { Vprintf(" ******* Fatal error - " "parameter number %2ld was changed incorrectly *******\n", i); } } if (! same) { *fatal = TRUE; goto L220; } if (! null) { /* Check the result. */ if (left) { smmch('n', 'n', m, n, m, alpha, a, nmax, b, nmax, beta, c, nmax, ct, g, cc, ldc, eps, &err, fatal, 1); } else { smmch('n', 'n', m, n, n, alpha, b, nmax, a, nmax, beta, c, nmax, ct, g, cc, ldc, eps, & err, fatal, 1); } errmax = MAX(errmax,err); /* If got really bad answer, report and */ /* return. */ if (*fatal) goto L220; } } } } L160: ; } L180: ; } } /* Report result. */ if (errmax < thresh) { Vprintf("%.6s passed the computational tests ( %6ld calls)\n", sname, nc); } else { Vprintf("%.6s completed the computational tests ( %6ld calls)" "******* but with maximum test ratio %8.2f - suspect *******)\n", sname,nc,errmax); } goto L240; L220: Vprintf(" ******* %.6s failed on call number:\n", sname); Vprintf("%6ld: %6s(%c, %c,%3ld," "%3ld,%4.1f, A,%3ld, B,%3ld,%4.1f, C,%3ld).\n", nc, sname, side, uplo, m, n, alpha, tda, tdb, beta, ldc); L240:; } /* schk2 */ /* ----------------------------------------------------------------------- */ static void schk3(const char sname[], double eps, double thresh, int trace, int rewi, int *fatal, Integer nidim, Integer idim[], Integer nalf, double alf[], Integer nmax, double a[], double aa[], double as[], double b[], double bb[], double bs[], double ct[], double g[], double c[]) { /* Initialized data */ static char ichu[3] = "ul"; static char icht[4] = "ntc"; static char ichd[3] = "un"; static char ichs[3] = "lr"; /* Local variables */ char diag; Integer tdas, tdbs; int same; char side; int left, null; char uplo; Integer i, j, m, n; double alpha; int isame[13]; Integer nargs; int reset; Integer ia, na, nc, im, in, ms, ns; char transa; double errmax; Integer laa, icd, lbb, tda, tdb, ics; double als; Integer ict, icu; double err; MatrixTranspose transa_c, tranas_c; MatrixTriangle uplo_c, uplos_c; OperationSide side_c, sides_c; MatrixUnitTriangular diag_c, diags_c; Integer max_d; /* Tests f06yfc and f06yjc. */ /* Auxiliary routine for test program for Level 3 Blas. */ #define G(I) g[(I)-1] #define CT(I) ct[(I)-1] #define BS(I) bs[(I)-1] #define BB(I) bb[(I)-1] #define AS(I) as[(I)-1] #define AA(I) aa[(I)-1] #define ALF(I) alf[(I)-1] #define IDIM(I) idim[(I)-1] /* .. Executable Statements .. */ if (trace) { Vprintf("\nComputational tests : \n"); if (strstr(sname, "mm")) Vprintf("\nf06yfc tested with : \n"); else Vprintf("\nf06yjc tested with : \n"); Vprintf("(RightSide (r), UpperTriangle (u), Transpose (t), NotUnitTriangular (n),..)\n"); Vprintf("(LeftSide (l), LowerTriangle (l), NoTranspose (n), UnitTriangular (u),..)\n"); Vprintf("(LeftSide (l), LowerTriangle (l), ConjugateTranspose (c), UnitTriangular (u),..)\n\n"); } nargs = 11; nc = 0; reset = TRUE; errmax = 0.0; /* Set up zero matrix for SMMCH. */ for (j = 1; j <= nmax; ++j) { for (i = 1; i <= nmax; ++i) c[i-1+(j-1)*nmax] = 0.0; } for (im = 1; im <= nidim; ++im) { m = IDIM(im); for (in = 1; in <= nidim; ++in) { n = IDIM(in); /* Set tdb to 1 more than minimum value if room. */ tdb = m; tdb = nmax; /* if (tdb < nmax) { ++tdb; } */ /* Skip tests if not enough room. */ if (tdb > nmax) goto L260; lbb = tdb * n; null = m <= 0 || n <= 0; for (ics = 1; ics <= 2; ++ics) { side = ichs[ics - 1]; left = side == 'l'; if (left) { side_c = LeftSide; na = m; } else { side_c = RightSide; na = n; } /* Set LDA to 1 more than minimum value if room. */ tda = na; tda = nmax; /* if (tda < nmax) { ++tda; } */ /* Skip tests if not enough room. */ if (tda > nmax) goto L260; laa = tda * na; for (icu = 1; icu <= 2; ++icu) { uplo = ichu[icu - 1]; if (uplo == 'u') uplo_c = UpperTriangle; else uplo_c = LowerTriangle; for (ict = 1; ict <= 3; ++ict) { transa = icht[ict - 1]; if (transa == 't') transa_c = Transpose; else if (transa == 'c') transa_c = ConjugateTranspose; else transa_c = NoTranspose; for (icd = 1; icd <= 2; ++icd) { diag = ichd[icd - 1]; if (diag == 'n') diag_c = NotUnitTriangular; else diag_c = UnitTriangular; for (ia = 1; ia <= nalf; ++ia) { alpha = ALF(ia); /* Generate the matrix A. */ smake("tr", uplo, diag, na, na, a, nmax, aa, tda, &reset, c_b91); /* Generate the matrix B. */ smake("ge", ' ', ' ', m, n, b, nmax, bb, tdb, &reset, c_b91); ++nc; /* Save every datum before calling the subroutine. */ sides_c = side_c; uplos_c = uplo_c; tranas_c = transa_c; diags_c = diag_c; ms = m; ns = n; als = alpha; for (i = 1; i <= laa; ++i) AS(i) = AA(i); tdas = tda; for (i = 1; i <= lbb; ++i) BS(i) = BB(i); tdbs = tdb; /* Call the subroutine. */ if (! strncmp(sname+10, "mm", 2)) { if (trace) { Vprintf("%6ld: %6s(%c, %c, %c, %c, " "%3ld,%3ld,%4.1f, A,%3ld, B,%3ld).\n", nc, sname, side, uplo, transa, diag, m, n, alpha, tda, tdb); } max_d = MAX(m, n); for (j =0; j < max_d; ++j) { for (i = 0; i < max_d; ++i) { transpose_aa[i * tda + j] = aa[i + j * tda]; transpose_bb[i * tda + j] = bb[i + j * tda]; } } f06yfc (side_c, uplo_c, transa_c, diag_c, m, n, alpha, transpose_aa, tda, transpose_bb, tdb); for (j =0; j < max_d; ++j) { for (i = 0; i < max_d; ++i) { aa[i + j * tda] = transpose_aa[i * tda + j]; bb[i + j * tda] = transpose_bb[i * tda + j]; } } } else if (! strncmp(sname+10, "sm", 2)) { if (trace) { Vprintf("%6ld: %6s(%c, %c, %c, %c, " "%3ld,%3ld,%4.1f, A,%3ld, B,%3ld).\n", nc, sname, side, uplo, transa, diag, m, n, alpha, tda, tdb); } max_d = MAX(m, n); for (j =0; j < max_d; ++j) { for (i = 0; i < max_d; ++i) { transpose_aa[i * tda + j] = aa[i + j * tda]; transpose_bb[i * tda + j] = bb[i + j * tda]; } } f06yjc (side_c, uplo_c, transa_c, diag_c, m, n, alpha, transpose_aa, tda, transpose_bb, tdb); for (j =0; j < max_d; ++j) { for (i = 0; i < max_d; ++i) { aa[i + j * tda] = transpose_aa[i * tda + j]; bb[i + j * tda] = transpose_bb[i * tda + j]; } } } /* Check if error-exit was taken incorrectly. */ if (! infoc.ok) { Vprintf(" ******* fatal error - error-exit taken" " on valid call *******\n"); *fatal = TRUE; goto L300; } /* See what data changed inside subroutines. */ isame[0] = sides_c == side_c; isame[1] = uplos_c == uplo_c; isame[2] = tranas_c == transa_c; isame[3] = diags_c == diag_c; isame[4] = ms == m; isame[5] = ns == n; isame[6] = als == alpha; isame[7] = lse(as, aa, laa); isame[8] = tdas == tda; if (null) isame[9] = lse(bs, bb, lbb); else isame[9] = lseres("ge", ' ', m, n, bs, bb, tdb); isame[10] = tdbs == tdb; /* If data was incorrectly changed, report and return. */ same = TRUE; for (i = 1; i <= nargs; ++i) { same = same && isame[i - 1]; if (! isame[i - 1]) { Vprintf(" ******* Fatal error - parameter " "number %2ld was changed incorrectly *******)\n", i); } } if (! same) { *fatal = TRUE; goto L300; } if (! null) { if (! strncmp(sname+10, "mm", 2)) { /* Check the result. */ if (left) { smmch(transa, 'n', m, n, m, alpha, a, nmax, b, nmax, c_b91, c, nmax, ct, g, bb, tdb, eps, &err, fatal, 1); } else { smmch('n', transa, m, n, n, alpha, b, nmax, a, nmax, c_b91, c, nmax, ct, g, bb, tdb, eps, &err, fatal, 1); } } else if (! strncmp(sname+10, "sm", 2)) { /* Compute approximation to original matrix. */ for (j = 1; j <= n; ++j) { for (i = 1; i <= m; ++i) { c[i-1+(j-1)*nmax] = bb[i + (j - 1) * tdb-1]; bb[i + (j - 1) * tdb-1] = alpha * b[i-1+(j-1)*nmax]; } } if (left) { smmch(transa, 'n', m, n, m, c_b88, a, nmax, c, nmax, c_b91, b, nmax, ct, g, bb, tdb, eps, &err, fatal, 0); } else { smmch('n', transa, m, n, n, c_b88, c, nmax, a, nmax, c_b91, b, nmax, ct, g, bb, tdb, eps, &err, fatal, 0); } } errmax = MAX(errmax,err); /* If got real ly bad answer, report and */ /* return. */ if (*fatal) goto L300; } } } } } } L260: ; } } /* Report result. */ if (errmax < thresh) { Vprintf("%.6s passed the computational tests ( %6ld calls)\n", sname,nc); } else { Vprintf("%.6s completed the computational tests (%6ld calls) " " ******* but with maximum test ratio %8.2f - suspect *******)\n",sname,nc, errmax); } goto L320; L300: Vprintf("******* %.6s failed on call number:\n", sname); Vprintf("%6ld: %6s(%c, %c, %c, %c, " "%3ld,%3ld,%4.1f, A,%3ld, B,%3ld).\n", nc, sname, side, uplo, transa, diag, m, n, alpha, tda, tdb); L320:; } /* schk3 */ /* -------------------------------------------------------------------- */ static void schk4(const char sname[], double eps, double thresh, int trace, int rewi, int *fatal, Integer nidim, Integer idim[], Integer nalf, double alf[], Integer nbet, double bet[], Integer nmax, double a[], double aa[], double as[], double b[], double bb[], double bs[], double c[], double cc[], double cs[], double ct[], double g[]) { /* Initialized data */ static char icht[3+1] = "ntc"; static char ichu[2+1] = "ul"; /* Local variables */ double beta; Integer tdas, ldcs; int same; double bets; int tran, null; char uplo; Integer i, j, k, n; double alpha; int isame[13]; Integer nargs; int reset; char trans; int upper; Integer ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns; double errmax; Integer laa, tda, lcc, ldc; double als; Integer ict, icu; double err; Integer max_d; MatrixTriangle uplo_c, uplos_c; MatrixTranspose trans_c, transs_c; /* Tests F06YPC. */ /* Auxiliary routine for test program for Level 3 Blas. */ #define G(I) g[(I)-1] #define CT(I) ct[(I)-1] #define CS(I) cs[(I)-1] #define CC(I) cc[(I)-1] #define BS(I) bs[(I)-1] #define BB(I) bb[(I)-1] #define AS(I) as[(I)-1] #define AA(I) aa[(I)-1] #define BET(I) bet[(I)-1] #define ALF(I) alf[(I)-1] #define IDIM(I) idim[(I)-1] if (trace) { Vprintf("\nComputational tests : \n"); Vprintf("\nf06ypc tested with : \n"); Vprintf("(UpperTriangle (u), Transpose (t),..)\n"); Vprintf("(UpperTriangle (u), NoTranspose (n),..)\n"); Vprintf("(LowerTriangle (l), ConjugateTranspose (c),.....)\n\n"); } nargs = 10; nc = 0; reset = TRUE; errmax = 0.0; for (in = 1; in <= nidim; ++in) { n = IDIM(in); /* Set LDC to 1 more than minimum value if room. */ ldc = n; ldc = nmax; /* GL 25/6/1992 if (ldc < nmax) { ++ldc; } */ /* Skip tests if not enough room. */ if (ldc > nmax) goto L200; lcc = ldc * n; null = n <= 0; for (ik = 1; ik <= nidim; ++ik) { k = IDIM(ik); for (ict = 1; ict <= 3; ++ict) { trans = icht[ict - 1]; tran = trans == 't' || trans == 'c'; if (trans == 't') trans_c = Transpose; else if (trans == 'c') trans_c = ConjugateTranspose; else trans_c = NoTranspose; if (tran) { ma = k; na = n; } else { ma = n; na = k; } /* Set LDA to 1 more than minimum value if room. */ tda = ma; tda = nmax; /* GL 25/6/1992 if (tda < nmax) { ++tda; } */ /* Skip tests if not enough room. */ if (tda > nmax) goto L160; laa = tda * na; /* Generate the matrix A. */ smake("ge", ' ', ' ', ma, na, a, nmax, aa, tda, &reset, c_b91); for (icu = 1; icu <= 2; ++icu) { uplo = ichu[icu - 1]; if (uplo == 'u') uplo_c = UpperTriangle; else uplo_c = LowerTriangle; upper = uplo == 'u'; for (ia = 1; ia <= nalf; ++ia) { alpha = ALF(ia); for (ib = 1; ib <= nbet; ++ib) { beta = BET(ib); /* Generate the matrix C. */ smake("sy", uplo, ' ', n, n, c, nmax, cc, ldc, &reset, c_b91); ++nc; /* Save every datum before calling the subroutine. */ uplos_c = uplo_c; transs_c = trans_c; ns = n; ks = k; als = alpha; for (i = 1; i <= laa; ++i) AS(i) = AA(i); tdas = tda; bets = beta; for (i = 1; i <= lcc; ++i) CS(i) = CC(i); ldcs = ldc; /* Call the subroutine. */ if (trace) { Vprintf("%6ld: %6s(%c, %c,%3ld," "%3ld,%4.1f, A,%3ld, %4.1f, C,%3ld).\n", nc, sname, uplo, trans, n, k, alpha, tda, beta, ldc); } max_d = MAX(n, k); for (j =0; j < max_d; ++j) { for (i = 0; i < max_d; ++i) { transpose_aa[i * tda + j] = aa[i + j * tda]; transpose_cc[i * tda + j] = cc[i + j * tda]; } } f06ypc(uplo_c, trans_c, n, k, alpha, transpose_aa, tda, beta, transpose_cc, ldc); for (j =0; j < max_d; ++j) { for (i = 0; i < max_d; ++i) { aa[i + j * tda] = transpose_aa[i * tda + j]; cc[i + j * tda] = transpose_cc[i * tda + j]; } } /* Check if error-exit was taken incorrectly. */ if (! infoc.ok) { Vprintf(" ******* fatal error - error-exit taken" " on valid call *******\n"); *fatal = TRUE; goto L240; } /* See what data changed inside subroutines. */ isame[0] = uplos_c == uplo_c; isame[1] = transs_c == trans_c; isame[2] = ns == n; isame[3] = ks == k; isame[4] = als == alpha; isame[5] = lse(as, aa, laa); isame[6] = tdas == tda; isame[7] = bets == beta; if (null) isame[8] = lse(cs, cc, lcc); else { isame[8] = lseres("sy", uplo, n, n, cs, cc, ldc); } isame[9] = ldcs == ldc; /* If data was incorrectly changed, report and return. */ same = TRUE; for (i = 1; i <= nargs; ++i) { same = same && isame[i - 1]; if (! isame[i - 1]) { Vprintf(" ******* Fatal error - parameter " "number %2ld was changed incorrectly *******)\n", i); } } if (! same) { *fatal = TRUE; goto L240; } if (! null) { /* Check the result column by column. */ jc = 1; for (j = 1; j <= n; ++j) { if (upper) { jj = 1; lj = j; } else { jj = j; lj = n - j + 1; } if (tran) { smmch('t', 'n', lj, c__1, k, alpha, &a[(jj-1)*nmax], nmax, &a[(j-1)*nmax], nmax, beta, &c[jj-1+(j-1)*nmax], nmax, ct, g, &CC(jc), ldc, eps, &err, fatal, 1); } else { smmch('n', 't', lj, c__1, k, alpha, &a[jj-1], nmax, &a[j-1], nmax, beta, & c[jj-1+(j-1)*nmax], nmax, ct, g, &CC(jc), ldc, eps, &err, fatal, 1); } if (upper) jc += ldc; else jc = jc + ldc + 1; errmax = MAX(errmax,err); /* If got real ly bad answer, report and */ /* return. */ if (*fatal) goto L220; } } } } } L160: ; } } L200: ; } /* Report result. */ if (errmax < thresh) { Vprintf("%.6s passed the computational tests ( %6ld calls)\n", sname,nc); } else { Vprintf("%.6s completed the computational tests (%6ld calls) " " ******* but with maximum test ratio %8.2f - suspect *******)\n",sname,nc, errmax); } goto L260; L220: if (n > 1) Vprintf(" These are the results for column %3ld.\n", j); L240: Vprintf("******* %.6s failed on call number:\n", sname); Vprintf("%6ld: %6s(%c, %c,%3ld," "%3ld,%4.1f, A,%3ld, %4.1f, C,%3ld).\n", nc, sname, uplo, trans, n, k, alpha, tda, beta, ldc); L260: ; } /* schk4 */ /* ------------------------------------------------------------------- */ static void schk5(const char sname[], double eps, double thresh, int trace, int rewi, int *fatal, Integer nidim, Integer idim[], Integer nalf, double alf[], Integer nbet, double bet[], Integer nmax, double ab[], double aa[], double as[], double bb[], double bs[], double c[], double cc[], double cs[], double ct[], double g[], double w[]) { /* Initialized data */ static char icht[3+1] = "ntc"; static char ichu[2+1] = "ul"; /* Local variables */ Integer jjab; double beta; Integer tdas, tdbs, ldcs; int same; double bets; int tran, null; char uplo; Integer i, j, k, n; double alpha; int isame[13]; Integer nargs; int reset; char trans; int upper; Integer ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns; double errmax; Integer laa, lbb, tda, lcc, tdb, ldc; double als; Integer ict, icu, max_d; double err; MatrixTriangle uplo_c, uplos_c; MatrixTranspose trans_c, transs_c; /* Tests F06YRC. */ /* Auxiliary routine for test program for Level 3 Blas. */ #define W(I) w[(I)-1] #define G(I) g[(I)-1] #define CT(I) ct[(I)-1] #define CS(I) cs[(I)-1] #define CC(I) cc[(I)-1] #define BS(I) bs[(I)-1] #define BB(I) bb[(I)-1] #define AS(I) as[(I)-1] #define AA(I) aa[(I)-1] #define AB(I) ab[(I)-1] #define BET(I) bet[(I)-1] #define ALF(I) alf[(I)-1] #define IDIM(I) idim[(I)-1] if (trace) { Vprintf("\nComputational tests : \n"); Vprintf("\nf06yrc tested with : \n"); Vprintf("(UpperTriangle (u), Transpose (t),..)\n"); Vprintf("(UpperTriangle (u), NoTranspose (n),..)\n"); Vprintf("(LowerTriangle (l), ConjugateTranspose (c),.....)\n\n"); } nargs = 12; nc = 0; reset = TRUE; errmax = 0.0; for (in = 1; in <= nidim; ++in) { n = IDIM(in); /* Set LDC to 1 more than minimum value if room. */ ldc = n; ldc = nmax; /* if (ldc < nmax) { ++ldc; } */ /* Skip tests if not enough room. */ if (ldc > nmax) goto L260; lcc = ldc * n; null = n <= 0; for (ik = 1; ik <= nidim; ++ik) { k = IDIM(ik); for (ict = 1; ict <= 3; ++ict) { trans = icht[ict - 1]; tran = trans == 't' || trans == 'c'; if (trans == 't') trans_c = Transpose; else if (trans == 'c') trans_c = ConjugateTranspose; else trans_c = NoTranspose; if (tran) { ma = k; na = n; } else { ma = n; na = k; } /* Set tda to 1 more than minimum value if room. */ tda = ma; tda = nmax; /* if (tda < nmax) { ++tda; } */ /* Skip tests if not enough room. */ if (tda > nmax) goto L220; laa = tda * na; /* Generate the matrix A. */ if (tran) { smake("ge", ' ', ' ', ma, na, ab, nmax<<1, aa, tda, &reset, c_b91); } else { smake("ge", ' ', ' ', ma, na, ab, nmax, aa, tda, &reset, c_b91); } /* Generate the matrix B. */ tdb = tda; lbb = laa; if (tran) { smake("ge", ' ', ' ', ma, na, &ab[k], nmax<<1, bb , tdb, &reset, c_b91); } else { smake("ge", ' ', ' ', ma, na, &ab[k*nmax], nmax, bb, tdb, &reset, c_b91); } for (icu = 1; icu <= 2; ++icu) { uplo = ichu[icu - 1]; upper = uplo == 'u'; if (uplo == 'u') uplo_c = UpperTriangle; else uplo_c = LowerTriangle; for (ia = 1; ia <= nalf; ++ia) { alpha = ALF(ia); for (ib = 1; ib <= nbet; ++ib) { beta = BET(ib); /* Generate the matrix C. */ smake("sy", uplo, ' ', n, n, c, nmax, cc, ldc, &reset, c_b91); ++nc; /* Save every datum before calling the subroutine. */ uplos_c = uplo_c; transs_c = trans_c; ns = n; ks = k; als = alpha; for (i = 1; i <= laa; ++i) AS(i) = AA(i); tdas = tda; for (i = 1; i <= lbb; ++i) BS(i) = BB(i); tdbs = tdb; bets = beta; for (i = 1; i <= lcc; ++i) CS(i) = CC(i); ldcs = ldc; /* Call the subroutine. */ if (trace) { Vprintf("%6ld: %6s(%c, %c,%3ld," "%3ld,%4.1f, A,%3ld, B,%3ld,%4.1f, C,%3ld).\n", nc, sname, uplo, trans, n, k, alpha, tda, tdb, beta, ldc); } max_d = MAX(n, k); for (j =0; j < max_d; ++j) { for (i = 0; i < max_d; ++i) { transpose_aa[i * tda + j] = aa[i + j * tda]; transpose_bb[i * tda + j] = bb[i + j * tda]; transpose_cc[i * tda + j] = cc[i + j * tda]; } } f06yrc (uplo_c, trans_c, n, k, alpha, transpose_aa, tda, transpose_bb, tdb, beta, transpose_cc, ldc); for (j =0; j < max_d; ++j) { for (i = 0; i < max_d; ++i) { aa[i + j * tda] = transpose_aa[i * tda + j]; bb[i + j * tda] = transpose_bb[i * tda + j]; cc[i + j * tda] = transpose_cc[i * tda + j]; } } /* Check if error-exit was taken incorrectly. */ if (! infoc.ok) { Vprintf(" ******* fatal error - error-exit taken" " on valid call *******\n"); *fatal = TRUE; goto L300; } /* See what data changed inside subroutines. */ isame[0] = uplos_c == uplo_c; isame[1] = transs_c == trans_c; isame[2] = ns == n; isame[3] = ks == k; isame[4] = als == alpha; isame[5] = lse(as, aa, laa); isame[6] = tdas == tda; isame[7] = lse(bs, bb, lbb); isame[8] = tdbs == tdb; isame[9] = bets == beta; if (null) isame[10] = lse(cs, cc, lcc); else { isame[10] = lseres("sy", uplo, n, n, cs , cc, ldc); } isame[11] = ldcs == ldc; /* If data was incorrectly changed, report and return. */ same = TRUE; for (i = 1; i <= nargs; ++i) { same = same && isame[i - 1]; if (! isame[i - 1]) { Vprintf(" ******* Fatal error - parameter " "number %2ld was changed incorrectly *******)\n", i); } } if (! same) { *fatal = TRUE; goto L300; } if (! null) { /* Check the result column by column. */ jjab = 1; jc = 1; for (j = 1; j <= n; ++j) { if (upper) { jj = 1; lj = j; } else { jj = j; lj = n - j + 1; } if (tran) { for (i = 1; i <= k; ++i) { W(i) = AB(((j - 1)*2) * nmax + k + i); W(k + i) = AB(((j - 1)*2) * nmax + i); } smmch('t', 'n', lj, c__1, k<<1, alpha, &AB(jjab), nmax<<1, w, nmax<<1, beta, &c[jj-1+(j-1)*nmax], nmax, ct, g, &CC(jc), ldc, eps, &err, fatal, 1); } else { for (i = 1; i <= k; ++i) { W(i) = AB((k + i - 1) * nmax + j) ; W(k + i) = AB((i - 1) * nmax + j) ; } smmch('n', 'n', lj, c__1, k<<1, alpha, &AB(jj), nmax, w, nmax<<1, beta, &c[jj-1+(j-1)*nmax], nmax, ct, g, &CC(jc), ldc, eps, &err, fatal, 1); } if (upper) jc += ldc; else { jc = jc + ldc + 1; if (tran) jjab += nmax << 1; } errmax = MAX(errmax,err); /* If got real ly bad answer, report and */ /* return. */ if (*fatal) goto L280; } } } } } L220: ; } } L260: ; } /* Report result. */ if (errmax < thresh) { Vprintf("%.6s passed the computational tests ( %6ld calls)\n", sname,nc); } else { Vprintf("%.6s completed the computational tests (%6ld calls) " " ******* but with maximum test ratio %8.2f - suspect *******)\n", sname,nc,errmax); } goto L320; L280: if (n > 1) Vprintf(" These are the results for column %3ld.\n", j); L300: Vprintf("******* %.6s failed on call number:\n", sname); Vprintf("%6ld: %6s(%c, %c,%3ld," "%3ld,%4.1f, A,%3ld, B,%3ld,%4.1f, C,%3ld).\n", nc, sname, uplo, trans, n, k, alpha, tda, tdb, beta, ldc); L320: ; } /* schk5 */ /* ------------------------------------------------------------------- */ static void schke(Integer isnum, const char srnamt[]) { /* Local variables */ static double beta, a[2], b[2], c[2], alpha; Integer two = 2; Integer one = 1; Integer zero = 0; Integer m_one = -1; /* Tests the error exits from the Level 3 Blas. */ /* Requires a special version of the error-handling routine f06aaz. */ /* alpha, beta, A, B and C should not need to be defined. */ /* Auxiliary routine for test program for Level 3 Blas. */ /* if anything is wrong. */ infoc.ok = TRUE; /* LERR is set to TRUE by the special version of f06aaz each time */ /* it is called, and is then tested and re-set by CHKXER. */ infoc.lerr = FALSE; switch ((int)isnum) { case 1: goto L20; case 2: goto L40; case 3: goto L60; case 4: goto L80; case 5: goto L100; case 6: goto L120; } L20: infoc.infot = 1; f06yac((MatrixTranspose)999, NoTranspose, zero, zero, zero, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 1; f06yac((MatrixTranspose)999, Transpose, zero, zero, zero, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06yac(NoTranspose, (MatrixTranspose)999, zero, zero, zero, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06yac(Transpose, (MatrixTranspose)999, zero, zero, zero, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06yac(NoTranspose, NoTranspose, m_one, zero, zero, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06yac(NoTranspose, Transpose, m_one, zero, zero, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06yac(Transpose, NoTranspose, m_one, zero, zero, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06yac(Transpose, Transpose, m_one, zero, zero, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06yac(NoTranspose, NoTranspose, zero, m_one, zero, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06yac(NoTranspose, Transpose, zero, m_one, zero, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06yac(Transpose, NoTranspose, zero, m_one, zero, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06yac(Transpose, Transpose, zero, m_one, zero, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06yac(NoTranspose, NoTranspose, zero, zero, m_one, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06yac(NoTranspose, Transpose, zero, zero, m_one, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06yac(Transpose, NoTranspose, zero, zero, m_one, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06yac(Transpose, Transpose, zero, zero, m_one, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 8; f06yac(NoTranspose, NoTranspose, two, zero, two, alpha, a, one, b, two, beta, c, two); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 8; f06yac(NoTranspose, Transpose, two, zero, two, alpha, a, one, b, two, beta, c, two); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 8; f06yac(Transpose, NoTranspose, two, zero, two, alpha, a, one, b, two, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 8; f06yac(Transpose, Transpose, two, zero, two, alpha, a, one, b, two, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 10; f06yac(NoTranspose, NoTranspose, zero, two, two, alpha, a, two, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 10; f06yac(Transpose, NoTranspose, zero, two, two, alpha, a, two, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 10; f06yac(NoTranspose, Transpose, zero, two, two, alpha, a, two, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 10; f06yac(Transpose, Transpose, zero, two, two, alpha, a, two, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 13; f06yac(NoTranspose, NoTranspose, two, one, zero, alpha, a, two, b, two, beta, c, zero); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 13; f06yac(NoTranspose, Transpose, two, one, zero, alpha, a, two, b, two, beta, c, zero); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 13; f06yac(Transpose, NoTranspose, two, two, zero, alpha, a, two, b, two, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 13; f06yac(Transpose, Transpose, two, two, zero, alpha, a, two, b, two, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L140; L40: infoc.infot = 1; f06ycc((OperationSide)999, UpperTriangle, zero, zero, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06ycc(LeftSide, (MatrixTriangle)999, zero, zero, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06ycc(LeftSide, UpperTriangle, m_one, zero, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06ycc(RightSide, UpperTriangle, m_one, zero, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06ycc(LeftSide, LowerTriangle, m_one, zero, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06ycc(RightSide, LowerTriangle, m_one, zero, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06ycc(LeftSide, UpperTriangle, zero, m_one, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06ycc(RightSide, UpperTriangle, zero, m_one, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06ycc(LeftSide, LowerTriangle, zero, m_one, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06ycc(RightSide, LowerTriangle, zero, m_one, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06ycc(LeftSide, UpperTriangle, two, zero, alpha, a, one, b, two, beta, c, two); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06ycc(RightSide, UpperTriangle, zero, two, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06ycc(LeftSide, LowerTriangle, two, zero, alpha, a, one, b, two, beta, c, two); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06ycc(RightSide, LowerTriangle, zero, two, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06ycc(LeftSide, UpperTriangle, zero, two, alpha, a, two, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06ycc(RightSide, UpperTriangle, zero, two, alpha, a, two, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06ycc(LeftSide, LowerTriangle, zero, two, alpha, a, two, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06ycc(RightSide, LowerTriangle, zero, two, alpha, a, two, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 12; f06ycc(LeftSide, UpperTriangle, zero, two, alpha, a, two, b, two, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 12; f06ycc(RightSide, UpperTriangle, zero, two, alpha, a, two, b, two, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 12; f06ycc(LeftSide, LowerTriangle, zero, two, alpha, a, two, b, two, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 12; f06ycc(RightSide, LowerTriangle, zero, two, alpha, a, two, b, two, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L140; L60: infoc.infot = 1; f06yfc((OperationSide)999, UpperTriangle, NoTranspose, NotUnitTriangular, zero, zero, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06yfc(LeftSide, (MatrixTriangle)999, NoTranspose, NotUnitTriangular, zero, zero, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06yfc(LeftSide, UpperTriangle, (MatrixTranspose)999, NotUnitTriangular, zero, zero, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06yfc(LeftSide, UpperTriangle, NoTranspose, (MatrixUnitTriangular)999, zero, zero, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06yfc(LeftSide, UpperTriangle, NoTranspose, NotUnitTriangular, m_one, zero, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06yfc(LeftSide, UpperTriangle, Transpose, NotUnitTriangular, m_one, zero, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06yfc(RightSide, UpperTriangle, NoTranspose, NotUnitTriangular, m_one, zero, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06yfc(RightSide, UpperTriangle, Transpose, NotUnitTriangular, m_one, zero, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06yfc(LeftSide, LowerTriangle, NoTranspose, NotUnitTriangular, m_one, zero, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06yfc(LeftSide, LowerTriangle, Transpose, NotUnitTriangular, m_one, zero, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06yfc(RightSide, LowerTriangle, NoTranspose, NotUnitTriangular, m_one, zero, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06yfc(RightSide, LowerTriangle, Transpose, NotUnitTriangular, m_one, zero, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 6; f06yfc(LeftSide, UpperTriangle, NoTranspose, NotUnitTriangular, zero, m_one, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 6; f06yfc(LeftSide, UpperTriangle, Transpose, NotUnitTriangular, zero, m_one, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 6; f06yfc(RightSide, UpperTriangle, NoTranspose, NotUnitTriangular, zero, m_one, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 6; f06yfc(RightSide, UpperTriangle, Transpose, NotUnitTriangular, zero, m_one, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 6; f06yfc(LeftSide, LowerTriangle, NoTranspose, NotUnitTriangular, zero, m_one, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 6; f06yfc(LeftSide, LowerTriangle, Transpose, NotUnitTriangular, zero, m_one, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 6; f06yfc(RightSide, LowerTriangle, NoTranspose, NotUnitTriangular, zero, m_one, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 6; f06yfc(RightSide, LowerTriangle, Transpose, NotUnitTriangular, zero, m_one, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06yfc(LeftSide, UpperTriangle, NoTranspose, NotUnitTriangular, two, zero, alpha, a, one, b, two); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06yfc(LeftSide, UpperTriangle, Transpose, NotUnitTriangular, two, zero, alpha, a, one, b, two); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06yfc(RightSide, UpperTriangle, NoTranspose, NotUnitTriangular, zero, two, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06yfc(RightSide, UpperTriangle, Transpose, NotUnitTriangular, zero, two, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06yfc(LeftSide, LowerTriangle, NoTranspose, NotUnitTriangular, two, zero, alpha, a, one, b, two); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06yfc(LeftSide, LowerTriangle, Transpose, NotUnitTriangular, two, zero, alpha, a, one, b, two); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06yfc(RightSide, LowerTriangle, NoTranspose, NotUnitTriangular, zero, two, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06yfc(RightSide, LowerTriangle, Transpose, NotUnitTriangular, zero, two, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 11; f06yfc(LeftSide, UpperTriangle, NoTranspose, NotUnitTriangular, zero, two, alpha, a, two, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 11; f06yfc(LeftSide, UpperTriangle, Transpose, NotUnitTriangular, zero, two, alpha, a, two, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 11; f06yfc(RightSide, UpperTriangle, NoTranspose, NotUnitTriangular, zero, two, alpha, a, two, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 11; f06yfc(RightSide, UpperTriangle, Transpose, NotUnitTriangular, zero, two, alpha, a, two, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 11; f06yfc(LeftSide, LowerTriangle, NoTranspose, NotUnitTriangular, zero, two, alpha, a, two, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 11; f06yfc(LeftSide, LowerTriangle, Transpose, NotUnitTriangular, zero, two, alpha, a, two, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 11; f06yfc(RightSide, LowerTriangle, NoTranspose, NotUnitTriangular, zero, two, alpha, a, two, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 11; f06yfc(RightSide, LowerTriangle, Transpose, NotUnitTriangular, zero, two, alpha, a, two, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L140; L80: infoc.infot = 1; f06yjc((OperationSide)999, UpperTriangle, NoTranspose, NotUnitTriangular, zero, zero, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06yjc(LeftSide, (MatrixTriangle)999, NoTranspose, NotUnitTriangular, zero, zero, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06yjc(LeftSide, UpperTriangle, (MatrixTranspose)999, NotUnitTriangular, zero, zero, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06yjc(LeftSide, UpperTriangle, NoTranspose, (MatrixUnitTriangular)999, zero, zero, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06yjc(LeftSide, UpperTriangle, NoTranspose, NotUnitTriangular, m_one, zero, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06yjc(LeftSide, UpperTriangle, Transpose, NotUnitTriangular, m_one, zero, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06yjc(RightSide, UpperTriangle, NoTranspose, NotUnitTriangular, m_one, zero, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06yjc(RightSide, UpperTriangle, Transpose, NotUnitTriangular, m_one, zero, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06yjc(LeftSide, LowerTriangle, NoTranspose, NotUnitTriangular, m_one, zero, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06yjc(LeftSide, LowerTriangle, Transpose, NotUnitTriangular, m_one, zero, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06yjc(RightSide, LowerTriangle, NoTranspose, NotUnitTriangular, m_one, zero, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06yjc(RightSide, LowerTriangle, Transpose, NotUnitTriangular, m_one, zero, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 6; f06yjc(LeftSide, UpperTriangle, NoTranspose, NotUnitTriangular, zero, m_one, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 6; f06yjc(LeftSide, UpperTriangle, Transpose, NotUnitTriangular, zero, m_one, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 6; f06yjc(RightSide, UpperTriangle, NoTranspose, NotUnitTriangular, zero, m_one, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 6; f06yjc(RightSide, UpperTriangle, Transpose, NotUnitTriangular, zero, m_one, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 6; f06yjc(LeftSide, LowerTriangle, NoTranspose, NotUnitTriangular, zero, m_one, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 6; f06yjc(LeftSide, LowerTriangle, Transpose, NotUnitTriangular, zero, m_one, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 6; f06yjc(RightSide, LowerTriangle, NoTranspose, NotUnitTriangular, zero, m_one, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 6; f06yjc(RightSide, LowerTriangle, Transpose, NotUnitTriangular, zero, m_one, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06yjc(LeftSide, UpperTriangle, NoTranspose, NotUnitTriangular, two, zero, alpha, a, one, b, two); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06yjc(LeftSide, UpperTriangle, Transpose, NotUnitTriangular, two, zero, alpha, a, one, b, two); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06yjc(RightSide, UpperTriangle, NoTranspose, NotUnitTriangular, zero, two, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06yjc(RightSide, UpperTriangle, Transpose, NotUnitTriangular, zero, two, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06yjc(LeftSide, LowerTriangle, NoTranspose, NotUnitTriangular, two, zero, alpha, a, one, b, two); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06yjc(LeftSide, LowerTriangle, Transpose, NotUnitTriangular, two, zero, alpha, a, one, b, two); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06yjc(RightSide, LowerTriangle, NoTranspose, NotUnitTriangular, zero, two, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06yjc(RightSide, LowerTriangle, Transpose, NotUnitTriangular, zero, two, alpha, a, one, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 11; f06yjc(LeftSide, UpperTriangle, NoTranspose, NotUnitTriangular, zero, two, alpha, a, two, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 11; f06yjc(LeftSide, UpperTriangle, Transpose, NotUnitTriangular, zero, two, alpha, a, two, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 11; f06yjc(RightSide, UpperTriangle, NoTranspose, NotUnitTriangular, zero, two, alpha, a, two, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 11; f06yjc(RightSide, UpperTriangle, Transpose, NotUnitTriangular, zero, two, alpha, a, two, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 11; f06yjc(LeftSide, LowerTriangle, NoTranspose, NotUnitTriangular, zero, two, alpha, a, two, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 11; f06yjc(LeftSide, LowerTriangle, Transpose, NotUnitTriangular, zero, two, alpha, a, two, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 11; f06yjc(RightSide, LowerTriangle, NoTranspose, NotUnitTriangular, zero, two, alpha, a, two, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 11; f06yjc(RightSide, LowerTriangle, Transpose, NotUnitTriangular, zero, two, alpha, a, two, b, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L140; L100: infoc.infot = 1; f06ypc((MatrixTriangle)999, NoTranspose, zero, zero, alpha, a, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06ypc(UpperTriangle, (MatrixTranspose)999, zero, zero, alpha, a, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06ypc(UpperTriangle, NoTranspose, m_one, zero, alpha, a, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06ypc(UpperTriangle, Transpose, m_one, zero, alpha, a, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06ypc(LowerTriangle, NoTranspose, m_one, zero, alpha, a, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06ypc(LowerTriangle, Transpose, m_one, zero, alpha, a, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06ypc(UpperTriangle, NoTranspose, zero, m_one, alpha, a, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06ypc(UpperTriangle, Transpose, zero, m_one, alpha, a, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06ypc(LowerTriangle, NoTranspose, zero, m_one, alpha, a, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06ypc(LowerTriangle, Transpose, zero, m_one, alpha, a, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06ypc(UpperTriangle, NoTranspose, zero, two, alpha, a, one, beta, c, two); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06ypc(UpperTriangle, Transpose, two, zero, alpha, a, one, beta, c, two); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06ypc(LowerTriangle, NoTranspose, zero, two, alpha, a, one, beta, c, two); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06ypc(LowerTriangle, Transpose, two, zero, alpha, a, one, beta, c, two); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 10; f06ypc(UpperTriangle, NoTranspose, two, zero, alpha, a, two, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 10; f06ypc(UpperTriangle, Transpose, two, zero, alpha, a, two, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 10; f06ypc(LowerTriangle, NoTranspose, two, zero, alpha, a, two, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 10; f06ypc(LowerTriangle, Transpose, two, zero, alpha, a, two, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L140; L120: infoc.infot = 1; f06yrc((MatrixTriangle)999, NoTranspose, zero, zero, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06yrc(UpperTriangle, (MatrixTranspose)999, zero, zero, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06yrc(UpperTriangle, NoTranspose, m_one, zero, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06yrc(UpperTriangle, Transpose, m_one, zero, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06yrc(LowerTriangle, NoTranspose, m_one, zero, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06yrc(LowerTriangle, Transpose, m_one, zero, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06yrc(UpperTriangle, NoTranspose, zero, m_one, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06yrc(UpperTriangle, Transpose, zero, m_one, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06yrc(LowerTriangle, NoTranspose, zero, m_one, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06yrc(LowerTriangle, Transpose, zero, m_one, alpha, a, one, b, one, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06yrc(UpperTriangle, NoTranspose, zero, two, alpha, a, one, b, two, beta, c, two); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06yrc(UpperTriangle, Transpose, two, zero, alpha, a, one, b, two, beta, c, two); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06yrc(LowerTriangle, NoTranspose, zero, two, alpha, a, one, b, two, beta, c, two); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06yrc(LowerTriangle, Transpose, two, zero, alpha, a, one, b, two, beta, c, two); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06yrc(UpperTriangle, NoTranspose, zero, two, alpha, a, two, b, one, beta, c, two); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06yrc(UpperTriangle, Transpose, two, zero, alpha, a, two, b, one, beta, c, two); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06yrc(LowerTriangle, NoTranspose, zero, two, alpha, a, two, b, one, beta, c, two); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06yrc(LowerTriangle, Transpose, two, zero, alpha, a, two, b, one, beta, c, two); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 12; f06yrc(UpperTriangle, NoTranspose, two, zero, alpha, a, two, b, two, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 12; f06yrc(UpperTriangle, Transpose, two, zero, alpha, a, two, b, two, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 12; f06yrc(LowerTriangle, NoTranspose, two, zero, alpha, a, two, b, two, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 12; f06yrc(LowerTriangle, Transpose, two, zero, alpha, a, two, b, two, beta, c, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); L140: if (infoc.ok) Vprintf("%.6s passed the tests of error-exits\n", srnamt); else Vprintf(" ******* %.6s failed the tests of error-exits *******\n", srnamt); } /* schke */ /* --------------------------------------------------------------------- */ static void smake(const char type[], char uplo, char diag, Integer m, Integer n, double a[], Integer nmax, double aa[], Integer tda, int *reset, double transl) { /* Local variables */ Integer ibeg, iend; int unit; Integer i, j; int lower, upper, gen, tri, sym; /* Generates values for an M by N matrix A. */ /* 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', 'sy' or 'tr'. */ /* Auxiliary routine for test program for Level 3 Blas. */ /* .. Executable Statements .. */ #define AA(I) aa[(I)-1] gen = ! strncmp(type, "ge", 2); sym = ! strncmp(type, "sy", 2); tri = ! strncmp(type, "tr", 2); upper = (sym || tri) && uplo == 'u'; lower = (sym || tri) && uplo == 'l'; unit = tri && diag == 'u'; /* Generate data in array A. */ for (j = 1; j <= n; ++j) { for (i = 1; i <= m; ++i) { if (gen || (upper && i <= j) || (lower && i >= j)) { a[i-1+(j-1)*nmax] = sbeg(reset) + transl; if (i != j) { /* Set some elements to zero */ if (n > 3 && j == n / 2) a[i-1+(j-1)*nmax] = 0.0; if (sym) a[j-1+(i-1)*nmax] = a[i-1+(j-1)*nmax]; else if (tri) a[j-1+(i-1)*nmax] = 0.0; } } } if (tri) a[j-1+(j-1)*nmax] += 1.0; if (unit) a[j-1+(j-1)*nmax] = 1.0; } /* Store elements in array AS in data structure required by routine. */ if (! strncmp(type, "ge", 2)) { for (j = 1; j <= n; ++j) { for (i = 1; i <= m; ++i) aa[i-1 + (j - 1) * tda] = a[i-1+(j-1)*nmax]; for (i = m + 1; i <= tda; ++i) aa[i-1 + (j - 1) * tda] = -1e10; } } else if ( ! strncmp(type, "sy", 2) || ! strncmp(type, "tr", 2)) { for (j = 1; j <= n; ++j) { if (upper) { ibeg = 1; if (unit) iend = j - 1; else iend = j; } else { if (unit) ibeg = j + 1; else ibeg = j; iend = n; } for (i = 1; i <= ibeg-1; ++i) aa[i-1 + (j - 1) * tda] = -1e10; for (i = ibeg; i <= iend; ++i) aa[i-1 + (j - 1) * tda] = a[i-1+(j-1)*nmax]; for (i = iend + 1; i <= tda; ++i) aa[i-1 + (j - 1) * tda] = -1e10; } } } /* smake */ /* ------------------------------------------------------------------ */ static void smmch(char transa, char transb, Integer m, Integer n, Integer kk, double alpha, double a[], Integer tda, double b[], Integer tdb, double beta, double c[], Integer tdc, double ct[], double g[], double cc[], Integer tdcc, double eps, double *err, int *fatal, int mv) { double d__1, d__2; double erri; Integer i, j, k; int trana, tranb; /* Checks the results of the computational tests. */ /* Auxiliary routine for test program for Level 3 Blas. */ #define G(I) g[(I)-1] #define CT(I) ct[(I)-1] /* Function Body */ trana = transa == 't' || transa == 'c'; tranb = transb == 't' || transb == 'c'; /* Compute expected result, one column at a time, in CT using data */ /* in A, B and C. */ /* Compute gauges in G. */ for (j = 1; j <= n; ++j) { for (i = 1; i <= m; ++i) { CT(i) = 0.0; G(i) = 0.0; } if (! trana && ! tranb) { for (k = 1; k <= kk; ++k) { for (i = 1; i <= m; ++i) { CT(i) += a[i-1+(k-1)*tda] * b[k-1+(j-1)*tdb]; G(i) += (d__1 = a[i-1+(k-1)*tda], FABS(d__1)) * (d__2 = b[k-1+(j-1)*tdb], FABS(d__2)); } } } else if (trana && ! tranb) { for (k = 1; k <= kk; ++k) { for (i = 1; i <= m; ++i) { CT(i) += a[k-1+(i-1)*tda] * b[k-1+(j-1)*tdb]; G(i) += (d__1 = a[k-1+(i-1)*tda], FABS(d__1)) * (d__2 = b[k-1+(j-1)*tdb], FABS(d__2)); } } } else if (! trana && tranb) { for (k = 1; k <= kk; ++k) { for (i = 1; i <= m; ++i) { CT(i) += a[i-1+(k-1)*tda] * b[j-1+(k-1)*tdb]; G(i) += (d__1 = a[i-1+(k-1)*tda], FABS(d__1)) * (d__2 = b[j-1+(k-1)*tdb], FABS(d__2)); } } } else if (trana && tranb) { for (k = 1; k <= kk; ++k) { for (i = 1; i <= m; ++i) { CT(i) += a[k-1+(i-1)*tda] * b[j-1+(k-1)*tdb]; G(i) += (d__1 = a[k-1+(i-1)*tda], FABS(d__1)) * (d__2 = b[j-1+(k-1)*tdb], FABS(d__2)); } } } for (i = 1; i <= m; ++i) { CT(i) = alpha * CT(i) + beta * c[i-1+(j-1)*tdc]; G(i) = FABS(alpha) * G(i) + FABS(beta) * (d__1 = c[i-1+(j-1)*tdc] , FABS(d__1)); } /* Compute the error ratio for this result. */ *err = 0.0; for (i = 1; i <= m; ++i) { erri = (d__1 = CT(i) - cc[i-1+(j-1)*tdcc], FABS(d__1)) / eps; if (G(i) != 0.0) erri /= G(i); *err = MAX(*err,erri); if (*err * sqrt(eps) >= 1.0) goto L260; } } /* If the loop completes, all results are at least half accurate. */ goto L300; /* Report fatal error. */ L260: *fatal = TRUE; Vprintf(" ******* Fatal error - computed result is less than " "half accurate *******\n Expected result Computed result\n"); for (i = 1; i <= m; ++i) { if (mv) Vprintf("%7ld%18.6g %18.6g\n",i,CT(i),cc[i-1+(j-1)*tdcc]); else Vprintf("%7ld%18.6g %18.6g\n",i,cc[i-1+(j-1)*tdcc], CT(i)); } if (n > 1) Vprintf(" These are the results for column %3ld.\n", j); L300:; } /* smmch */ /* ---------------------------------------------------------------- */ static int lse(double ri[], double rj[], Integer lr) { /* System generated locals */ int ret_val; /* Local variables */ Integer i; /* Tests if two arrays are identical. */ #define RJ(I) rj[(I)-1] #define RI(I) ri[(I)-1] /* Function Body */ for (i = 1; i <= lr; ++i) { if (RI(i) != RJ(i)) goto L40; } ret_val = TRUE; goto L60; L40: ret_val = FALSE; L60: return ret_val; } /* lse */ /* ------------------------------------------------------------------ */ static int lseres(const char type[], char uplo, Integer m, Integer n, double aa[], double as[], Integer tda) { /* System generated locals */ int ret_val; /* Local variables */ Integer ibeg, iend, i, j; int upper; /* Tests if selected elements in two arrays are equal. */ /* TYPE is 'ge' or 'sy'. */ /* Auxiliary routine for test program for Level 3 Blas. */ upper = uplo == 'u'; if (! strncmp(type, "ge", 2)) { for (j = 1; j <= n; ++j) { for (i = m + 1; i <= tda; ++i) { if (aa[i-1+(j-1)*tda] != as[i-1+(j-1)*tda]) goto L140; } } } else if (! strncmp(type, "sy", 2)) { for (j = 1; j <= n; ++j) { if (upper) { ibeg = 1; iend = j; } else { ibeg = j; iend = n; } for (i = 1; i <= ibeg-1; ++i) { if (aa[i-1+(j-1)*tda] != as[i-1+(j-1)*tda]) goto L140; } for (i = iend + 1; i <= tda; ++i) { if (aa[i-1+(j-1)*tda] != as[i-1+(j-1)*tda]) goto L140; } } } ret_val = TRUE; goto L160; L140: ret_val = FALSE; L160: return ret_val; } /* lseres */ /* ------------------------------------------------------------------- */ static double sbeg(int *reset) { double 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 3 Blas. */ 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; L20: i *= mi; i -= i / 1000 * 1000; if (ic >= 5) { ic = 0; goto L20; } ret_val = (i - 500) / 1001.0; return ret_val; } /* sbeg */ /* -------------------------------------------------------------------- */ static void chkxer(const char srnamt[], Integer infot, int *lerr, int *ok) { /* Tests whether f06aaz has detected an error when it should. */ /* Auxiliary routine for test program for Level 3 Blas. */ if (! (*lerr)) { Vprintf("***** Illegal value of parameter number %1ld," "not detected by %6s *****\n", infot, srnamt); *ok = FALSE; } *lerr = FALSE; } /* chkxer */ /* ---------------------------------------------------------------------- */ void f06aaz(const char srname[], Integer info) { /* * This is a special version of F06AAZ to be used only as part of * the test program for testing error exits from the Level 2 BLAS * routines. * F06AAZ 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. */ infoc.lerr = TRUE; if (info != infoc.infot) { if (infoc.infot != 0) { Vprintf(" ******* f06aaz was called with info = %6ld " "instead of %2ld\n",info, infoc.infot); } else Vprintf("f06aaz was called with info = %6ld\n", info); infoc.ok = FALSE; } if (strncmp(srname, srnamc.srnamt, 6)) { Vprintf("f06aaz was called with srname %s instead of %s\n", srname, srnamc.srnamt); } } /* f06aaz_d.c * * Mark 7 Release. Copyright 2002 Numerical Algorithms Group. * * Modified for example program: * infoc.lerr = TRUE; * * NAG C Library * * Purpose * ======= * * f06aaz_d interprets an error from an f16 call in the manner * of the f06aaz handler. * */ #include #include #include #include void f06aaz_d(const char *srname, NagError *fail_f16) { char buf[NAG_ERROR_BUF_LEN]; infoc.lerr = TRUE; /* fail_f16->print = TRUE; */ Vsprintf(buf, nag_errlist[NE_F06_BAD_PARAM], - (1 + fail_f16->iflag)); p01acc(buf, NE_F06_BAD_PARAM, srname, fail_f16); return; }