/* f06pbce.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 #define NSUBS 16 #define ZERO 0.0 #define ONE 1.0 #define NMAX 20 #define INCMAX 2 #define NINMAX 7 #define NIDMAX 9 #define NKBMAX 7 #define NALMAX 7 #define NBEMAX 7 static void schk1(const char sname[], double eps, double thresh, int trace, int rewi, int *fatal, Integer nidim, Integer idim[], Integer nkb, Integer kb[], Integer nalf, double alf[], Integer nbet, double bet[], Integer ninc, Integer inc[], Integer nmax, Integer incmax, double a[], double aa[], double as[], double x[], double xx[], double xs[], double y[], double yy[], double ys[], double yt[], double g[]); static void schk2(const char sname[], double eps, double thresh, int trace, int rewi, int *fatal, Integer nidim, Integer idim[], Integer nkb, Integer kb[], Integer nalf, double alf[], Integer nbet, double bet[], Integer ninc, Integer inc[], Integer nmax, Integer incmax, double a[], double aa[], double as[], double x[], double xx[], double xs[], double y[], double yy[], double ys[], double yt[], double g[]); static void schk3(const char sname[], double eps, double thresh, int trace, int rewi, int *fatal, Integer nidim, Integer idim[], Integer nkb, Integer kb[], Integer ninc, Integer inc[], Integer nmax, Integer incmax, double a[], double aa[], double as[], double x[], double xx[], double xs[], double xt[], double g[], double z[]); 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 ninc, Integer inc[], Integer nmax, Integer incmax, double a[], double aa[], double as[], double x[], double xx[], double xs[], double y[], double yy[], double ys[], double yt[], double g[], double z[]); 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 ninc, Integer inc[], Integer nmax, Integer incmax, double a[], double aa[], double as[], double x[], double xx[], double xs[], double y[], double yy[], double ys[], double yt[], double g[], double z[]); static void schk6(const char sname[], double eps, double thresh, int trace, int rewi, int *fatal, Integer nidim, Integer idim[], Integer nalf, double alf[], Integer ninc, Integer inc[], Integer nmax, Integer incmax, double a[], double aa[], double as[], double x[], double xx[], double xs[], double y[], double yy[], double ys[], double yt[], double g[], double z[]); 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, Integer kl, Integer ku, int *reset, double transl); static void smvch(char trans, Integer m, Integer n, double alpha, double a[], Integer nmax, double x[], Integer incx, double beta, double y[], Integer incy, double yt[], double g[], double yy[], 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); static void pack_vector(MatrixTriangle UpperLower, Integer n, double array_f[], double array_c[]) { Integer i, j, k, kk, p; if (UpperLower == UpperTriangle) { /* * change from column packing to row * packing -- for Upper Triangle */ kk = 0; k = 0; p = 0; for (i=0; i < n; ++i) { k = kk; for (j = i; j < n; ++j) { array_c[p] = array_f[k]; k = k + j + 1; p = p + 1; } kk = kk + i + 2; } } if (UpperLower == LowerTriangle) { /* * change from column packing to row * packing -- for Lower Triangle */ kk = 0; k = 0; p = 0; for (i=0; i < n; ++i) { k = i; for (j = 0; j <= i; ++j) { array_c[p] = array_f[k]; k = k + (n-j)-1; p = p + 1; } } } } /* end of pack_vector */ /* --------------------------------------------------------- */ static void unpack_vector(MatrixTriangle UpperLower, Integer n, double array_f[], double array_c[]) { Integer i, j, k, kk, p; if (UpperLower == UpperTriangle) { /* * change from row packing to column * packing -- for Upper Triangle */ kk = 0; k = 0; p = 0; for (i=0; i < n; ++i) { k = kk; for (j = i; j < n; ++j) { array_f[k] = array_c[p]; k = k + j + 1; p = p + 1; } kk = kk + i + 2; } } if (UpperLower == LowerTriangle) { /* * change from row packing to column * packing -- for Lower Triangle */ kk = 0; k = 0; p = 0; for (i=0; i < n; ++i) { k = i; for (j = 0; j <= i; ++j) { array_f[k] = array_c[p]; k = k + (n-j)-1; p = p + 1; } } } } /* end of unpack_vector */ /* ------------------------------------------------------- */ /* Static structure for internal communication */ static struct { Integer infot, noutc; int ok, lerr; } infoc; #define nmax_2 NMAX *2 #define nmax_nmax NMAX * NMAX static struct { char srnamt[14]; } srnamc; static double transpose_aa [nmax_nmax]; int main(void) { /* Initialized data */ static const char *snames[NSUBS] = {"f06pac/dgemv","f06pbc/dgbmv","f06pcc/dsymv", "f06pdc/dsbmv","f06pec/dspmv","f06pfc/dtrmv", "f06pgc/dtbmv","f06phc/dtpmv","f06pjc/dtrsv", "f06pkc/dtbsv","f06plc/dtpsv","f06pmc/dger", "f06ppc/dsyr", "f06pqc/dspr", "f06prc/dsyr2", "f06psc/dspr2" }; /* Local variables */ static Integer idim[NIDMAX]; int same; Integer ninc, nbet, nalf; int rewi; static double a[NMAX*NMAX], g[NMAX]; Integer i, j, n; int fatal; static double x[NMAX], y[NMAX], z[2*NMAX]; int trace; Integer nidim; char trans; Integer isnum; static int ltest[NSUBS]; static double aa[NMAX*NMAX]; static Integer kb[NKBMAX]; static double as[NMAX*NMAX]; int sfatal; static double xs[NMAX*INCMAX], ys[NMAX*INCMAX], yt[NMAX], xx[NMAX*INCMAX], yy[NMAX*INCMAX]; char snamet[7]; double thresh; int ltestt, tsterr; static double alf[NALMAX]; static Integer inc[NINMAX], nkb; static double bet[NBEMAX]; double eps, err; /* .. Executable Statements .. */ Vprintf("f06pbc Example Program Results\n\n"); Vscanf("%*[^\n]"); infoc.noutc = 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 L420; } 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 L420; } } /* Values of k */ Vscanf("%ld%*[^\n]", &nkb); if (nkb < 1 || nkb > NKBMAX) { Vprintf("Number of values of K is less than 1 or greater than %2d\n", NKBMAX); goto L420; } for (i = 1; i <= nkb; ++i) Vscanf("%ld", &kb[i-1]); Vscanf("%*[^\n]"); for (i = 1; i <= nkb; ++i) { if (kb[i-1] < 0) { Vprintf("Value of k is less than 0\n"); goto L420; } } /* Values of incx and incy */ Vscanf("%ld%*[^\n]", &ninc); if (ninc < 1 || ninc > NINMAX) { Vprintf("Number of values of incx and incy is less than 1 or greater than, %2d\n", NINMAX); goto L420; } for (i = 1; i <= ninc; ++i) Vscanf("%ld", &inc[i-1]); Vscanf("%*[^\n]"); for (i = 1; i <= ninc; ++i) { if (inc[i-1] == 0 || ABS(inc[i-1]) > INCMAX) { Vprintf("Absolute value of incx or incy is 0 or greater than %2d\n", INCMAX); goto L420; } } /* 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 L420; } for (i = 1; i <= nalf; ++i) Vscanf("%lf", &alf[i-1]); Vscanf("%*[^\n]"); /* Values of beta */ Vscanf("%ld%*[^\n]", &nbet); Vscanf("%*[^\n]"); if (nbet < 1 || nbet > NBEMAX) { Vprintf("Number of values of beta is less than 1 or greater than, %2d\n", NBEMAX); goto L420; } for (i = 1; i <= nbet; ++i) { Vscanf("%lf", &bet[i-1]); } Vscanf("%*[^\n]"); /* Report values of parameters. */ Vprintf("Tests of the real level 2 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%9 || i==nidim) ? '\n' : ' '); Vprintf(" For k "); for (i = 1; i <= nkb; ++i) Vprintf("%ld%c", kb[i-1], (! i%7 || i==nkb) ? '\n' : ' '); Vprintf(" For incx and incy "); for (i = 1; i <= ninc; ++i) Vprintf("%ld%c", inc[i-1], (! i%7 || i==ninc) ? '\n' : ' '); Vprintf(" For alpha "); for (i = 1; i <= nalf; ++i) Vprintf("%6.1f%c", alf[i-1], (! i%7 || i==nalf) ? '\n' : ' '); Vprintf(" For beta "); for (i = 1; i <= nbet; ++i) Vprintf("%6.1f%c", bet[i-1], (! i%7 || 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 L140; } Vprintf("Function name %s not recognized \n" "******* Tests abandoned *******\n", snamet); return EXIT_FAILURE; L140: 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 smvch using exact data. */ n = MIN(32, NMAX); for (j = 1; j <= n; ++j) { for (i = 1; i <= n; ++i) a[i + (j-1) * NMAX - 1] = (double) MAX(i-j+1, 0); x[j-1] = (double) j; y[j-1] = 0.0; } for (j = 1; j <= n; ++j) yy[j-1] = (double) (j*((j+1)*j)/2 - (j+1)*j*(j-1)/3); /* yy holds the exact result. On exit from smvch yt holds */ /* the result computed by smvch. */ trans = 'n'; smvch(trans, n, n, 1.0, a, (Integer)NMAX, x, (Integer)1, 0.0, y, (Integer)1, yt, g, yy, eps, &err, &fatal, 1); same = lse(yy, yt, n); if (! same || err != 0.0) { Vprintf("Error in smvch - in-line dot products are being " "evaluated wrongly.\nsmvch was called with trans = %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", trans, same, err); return EXIT_FAILURE; } trans = 't'; smvch(trans, n, n, 1.0, a, (Integer)NMAX, x, (Integer)-1, 0.0, y, (Integer)-1, yt, g, yy, eps, &err, &fatal, 1); same = lse(yy, yt, n); if (! same || err != 0.0) { Vprintf("Error in smvch - in-line dot products are being " "evaluated wrongly.\nsmvch was called with trans = %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", trans, same, err); return EXIT_FAILURE; } /* Test each subroutine in turn. */ for (isnum = 1; isnum <= NSUBS; ++isnum) { 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]); } /* Test computations. */ infoc.infot = 0; infoc.ok = TRUE; fatal = FALSE; switch ((int)isnum) { case 1: goto L240; case 2: goto L240; case 3: goto L260; case 4: goto L260; case 5: goto L260; case 6: goto L280; case 7: goto L280; case 8: goto L280; case 9: goto L280; case 10: goto L280; case 11: goto L280; case 12: goto L300; case 13: goto L320; case 14: goto L320; case 15: goto L340; case 16: goto L340; } /* Test f06pac, 01, and f06pbc, 02. */ L240: schk1(snames[isnum-1], eps, thresh, trace, rewi, &fatal, nidim, idim, nkb, kb, nalf, alf, nbet, bet, ninc, inc, (Integer)NMAX, (Integer)INCMAX, a, aa, as, x, xx, xs, y, yy, ys, yt, g); goto L360; /* Test f06pcc, 03, f06pdc, 04, and f06pec, 05. */ L260: schk2(snames[isnum-1], eps, thresh, trace, rewi, &fatal, nidim, idim, nkb, kb, nalf, alf, nbet, bet, ninc, inc, (Integer)NMAX, (Integer)INCMAX, a, aa, as, x, xx, xs, y, yy, ys, yt, g); goto L360; /* Test f06pfc, 06, f06pgc, 07, f06phc, 08, */ /* f06pjc, 09, f06pkc, 10, and f06plc, 11. */ L280: schk3(snames[isnum-1], eps, thresh, trace, rewi, &fatal, nidim, idim, nkb, kb, ninc, inc, (Integer)NMAX, (Integer)INCMAX, a, aa, as, y, yy, ys, yt, g, z); goto L360; /* Test f06pmc, 12. */ L300: schk4(snames[isnum-1], eps, thresh, trace, rewi, &fatal, nidim, idim, nalf, alf, ninc, inc, (Integer)NMAX, (Integer)INCMAX, a, aa, as, x, xx, xs, y, yy, ys, yt, g, z); goto L360; /* Test f06ppc, 13, and f06pqc, 14. */ L320: schk5(snames[isnum-1], eps, thresh, trace, rewi, &fatal, nidim, idim, nalf, alf, ninc, inc, (Integer)NMAX, (Integer)INCMAX, a, aa, as, x, xx, xs, y, yy, ys, yt, g, z); goto L360; /* Test f06prc, 15, and f06psc, 16. */ L340: schk6(snames[isnum-1], eps, thresh, trace, rewi, &fatal, nidim, idim, nalf, alf, ninc, inc, (Integer)NMAX, (Integer)INCMAX, a, aa, as, x, xx, xs, y, yy, ys, yt, g, z); L360: if (fatal && sfatal) goto L400; } } Vprintf("End of tests\n"); return EXIT_SUCCESS; L400: Vprintf("******* Fatal error - Tests abandoned *******\n"); goto L440; L420: Vprintf("Amend data file or increase array sizes in program\n" "******* Tests abandoned *******\n"); L440: return EXIT_FAILURE; } static void schk1(const char sname[], double eps, double thresh, int trace, int rewi, int *fatal, Integer nidim, Integer idim[], Integer nkb, Integer kb[], Integer nalf, double alf[], Integer nbet, double bet[], Integer ninc, Integer inc[], Integer nmax, Integer incmax, double a[], double aa[], double as[], double x[], double xx[], double xs[], double y[], double yy[], double ys[], double yt[], double g[]) { /* Initialized data */ static char ich[4] = "ntc"; /* Local variables */ double beta; Integer tdas; int same; Integer incx, incy; int full, tran, null; Integer i, m, n; double alpha; int isame[13]; Integer nargs; int reset; Integer incxs, incys; char trans; Integer ia, ib, ic; int banded; Integer nc, nd, im, in, kl, ml, nk, nl, ku, ix, iy, ms, lx, ly, ns; double errmax; double transl; Integer laa, tda; double als, bls; double err; Integer iku, kls, kus; MatrixTranspose trans_c, transs_c; Integer j, k; /* Tests f06pac and f06pbc. */ /* Auxiliary routine for test program for Level 2 Blas. */ /* Parameter adjustments */ #define YS(I) ys[(I) -1] #define YY(I) yy[(I) -1] #define Y(I) y[(I) -1] #define XS(I) xs[(I) -1] #define XX(I) xx[(I) -1] #define X(I) x[(I) -1] #define AS(I) as[(I) -1] #define AA(I) aa[(I) -1] #define INC(I) inc[(I) -1] #define BET(I) bet[(I) -1] #define ALF(I) alf[(I) -1] #define KB(I) kb[(I) -1] #define IDIM(I) idim[(I) -1] /* Function Body */ /* .. Executable Statements .. */ full = sname[9] == 'e'; banded = sname[9] == 'b'; if (trace) { Vprintf("\nComputational tests : \n"); if (full) Vprintf("\nf06pac tested with : \n"); if (banded) Vprintf("\nf06pbc tested with : \n"); Vprintf("(Transpose (t),.........)\n"); Vprintf("(ConjugateTranspose (c),.........)\n"); Vprintf("(Notranspose (n),.........)\n\n"); } /* Define the number of arguments. */ if (full) nargs = 11; else nargs = 13; nc = 0; reset = TRUE; errmax = 0.0; for (in = 1; in <= nidim; ++in) { n = IDIM(in); nd = n / 2 + 1; for (im = 1; im <= 2; ++im) { if (im == 1) m = MAX(n - nd,0); else m = MIN(n + nd,nmax); if (banded) nk = nkb; else nk = 1; for (iku = 1; iku <= nk; ++iku) { if (banded) { ku = KB(iku); kl = MAX(ku - 1,0); } else { ku = n - 1; kl = m - 1; } /* Set LDA to 1 more than minimum value if room. */ if (banded) tda = kl + ku + 1; else tda = m; if (tda < nmax) ++tda; /* Skip tests if not enough room. */ if (tda > nmax) goto L200; laa = tda * n; null = n <= 0 || m <= 0; tda = nmax; /* George Levy */ /* Generate the matrix A. */ transl = 0.0; smake(sname + 8, ' ', ' ', m, n, a, nmax, aa, tda, kl, ku, &reset, transl); for (ic = 1; ic <= 3; ++ic) { trans = ich[ic - 1]; tran = trans == 't' || trans == 'c'; if (tran) { trans_c = Transpose; ml = n; nl = m; } else { trans_c = NoTranspose; ml = m; nl = n; } for (ix = 1; ix <= ninc; ++ix) { incx = INC(ix); lx = ABS(incx) * nl; /* Generate the vector x. */ transl = 0.5; smake("ge", ' ', ' ', (Integer)1, nl, x, (Integer)1, xx, (Integer)ABS(incx), (Integer)0, nl-1, &reset, transl); if (nl > 1) { X(nl/2) = 0.0; XX(ABS(incx)*(nl/2-1)+1) = 0.0; } for (iy = 1; iy <= ninc; ++iy) { incy = INC(iy); ly = ABS(incy) * ml; for (ia = 1; ia <= nalf; ++ia) { alpha = ALF(ia); for (ib = 1; ib <= nbet; ++ib) { beta = BET(ib); /* Generate the vector y. */ transl = 0.0; smake("ge", ' ', ' ', (Integer)1, ml, y, (Integer)1, yy, (Integer)ABS(incy), (Integer)0, ml-1, &reset, transl); ++nc; /* Save every datum before calling the subroutine. */ transs_c = trans_c; ms = m; ns = n; kls = kl; kus = ku; als = alpha; for (i = 1; i <= laa; ++i) AS(i) = AA(i); tdas = tda; for (i = 1; i <= lx; ++i) XS(i) = XX(i); incxs = incx; bls = beta; for (i = 1; i <= ly; ++i) YS(i) = YY(i); incys = incy; /* Call the subroutine. */ if (full) { if (trace) Vprintf("%6ld: %6s(%c,%3ld,%3ld," "%4.1f, A,%3ld, X,%2ld,%4.1f, Y,%2ld).\n", nc, sname, trans, m, n, alpha, tda, incx, beta, incy); for (j =0; j < n; ++j) { for (i = 0; i < m; ++i) transpose_aa[i * tda + j] = AA(1 + i + j * tda); } f06pac(trans_c, m, n, alpha, transpose_aa, tda, xx, incx, beta, yy, incy); for (j =0; j < n; ++j) { for (i = 0; i < m; ++i) AA(1 + i + j * tda) = transpose_aa[i * tda + j]; } } else if (banded) { if (trace) { Vprintf("%6ld: %6s(%c,%3ld,%3ld," "%3ld,%3ld,%4.1f, A,%3ld, X,%2ld,%4.1f, Y,%2ld).\n", nc, sname, trans, m, n, kl, ku, alpha, tda, incx, beta, incy); } /* set transpose_aa to rogue values */ for (i=0; i < nmax_nmax - 1; ++i) transpose_aa[i] = 1.12E10; /* pack matrix in C order */ for (i = 0; i <= m; ++i) { k = kl - i; for (j = MAX(0,i-kl); j <= MIN(n-1,i+ku); ++j) transpose_aa[(i*tda)+k+j] = a[i+(j*tda)]; } f06pbc(trans_c, m, n, kl, ku, alpha, transpose_aa, tda, xx, incx, beta, yy, incy); } /* Check if error-exit was taken incorrectly. */ if (! infoc.ok) { Vprintf(" ******* Fatal error - " "error-exit taken on valid call ******\n"); *fatal = TRUE; goto L260; } /* See what data changed inside subroutines. */ isame[0] = trans_c == transs_c; isame[1] = ms == m; isame[2] = ns == n; if (full) { isame[3] = als == alpha; isame[4] = lse(as, aa, laa); isame[5] = tdas == tda; isame[6] = lse(xs, xx, lx); isame[7] = incxs == incx; isame[8] = bls == beta; if (null) isame[9] = lse(ys, yy, ly); else isame[9] = lseres("ge", ' ', (Integer)1, ml, ys, yy, (Integer)ABS(incy)); isame[10] = incys == incy; } else if (banded) { isame[3] = kls == kl; isame[4] = kus == ku; isame[5] = als == alpha; isame[6] = lse(as, aa, laa); isame[7] = tdas == tda; isame[8] = lse(xs, xx, lx); isame[9] = incxs == incx; isame[10] = bls == beta; if (null) { isame[11] = lse(ys, yy, ly); } else { isame[11] = lseres("ge", ' ', (Integer)1, ml, ys, yy, (Integer)ABS(incy)); } isame[12] = incys == incy; } /* 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 L260; } if (! null) { /* Check the result. */ smvch(trans, m, n, alpha, a, nmax, x, incx, beta, y, incy, yt, g, yy, eps, &err, fatal, 1); errmax = MAX(errmax,err); /* If got really bad answer, report and */ /* return. */ if (*fatal) goto L260; } else { /* Avoid repeating tests with m 0 or */ /* n <= .0. */ goto L220; } } } } } } L200: ; } L220: ; } } /* 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 L280; L260: Vprintf("******* %.6s failed on call number:\n", sname); if (full) { Vprintf("%6ld: %6s('%c',%3ld, %3ld," " %4.1f, A, %3ld, X ,%2ld, %4.1f, Y ,%2ld) .\n", nc, sname, trans, m, n, alpha, tda, incx, beta, incy); } else if (banded) { Vprintf("%6ld: %6s(%c,%3ld,%3ld," "%3ld,%3ld,%4.1f, A,%3ld, X,%2ld,%4.1f, Y,%2ld).\n", nc, sname, trans, m, n,kl,ku,alpha,tda, incx, beta, incy); } L280:; } /* End of schk1. */ /* ----------------------------------------------------------- */ static void schk2(const char sname[], double eps, double thresh, int trace, int rewi, int *fatal, Integer nidim, Integer idim[], Integer nkb, Integer kb[], Integer nalf, double alf[], Integer nbet, double bet[], Integer ninc, Integer inc[], Integer nmax, Integer incmax, double a[], double aa[], double as[], double x[], double xx[], double xs[], double y[], double yy[], double ys[], double yt[], double g[]) { /* Initialized data */ static char ich[3] = "ul"; /* Local variables */ double beta; Integer tdas; int same; Integer incx, incy; int full, null; char uplo; Integer i, j, k, m, n; double alpha; int isame[13]; Integer nargs; int reset; Integer incxs, incys; Integer ia, ib, ic; int banded; Integer nc, ik, in; int packed; Integer nk, ks, ix, iy, ns, lx, ly; double errmax; double transl; Integer laa, tda; double als, bls; double err; MatrixTriangle uplo_c, uplos_c; /* Tests f06pcc, f06pdc and f06pec. */ /* Auxiliary routine for test program for Level 2 Blas. */ /* Parameter adjustments */ #define G(I) g[(I) -1] #define YT(I) yt[(I) -1] #define YS(I) ys[(I) -1] #define YY(I) yy[(I) -1] #define Y(I) y[(I) -1] #define Y(I) y[(I) -1] #define XS(I) xs[(I) -1] #define XX(I) xx[(I) -1] #define X(I) x[(I) -1] #define AS(I) as[(I) -1] #define AA(I) aa[(I) -1] #define INC(I) inc[(I) -1] #define BET(I) bet[(I) -1] #define ALF(I) alf[(I) -1] #define KB(I) kb[(I) -1] #define IDIM(I) idim[(I) -1] /* Function Body */ /* .. Executable Statements .. */ full = sname[9] == 'y'; banded = sname[9] == 'b'; packed = sname[9] == 'p'; /* define the number of arguments. */ if (full) nargs = 10; else if (banded) nargs = 11; else nargs = 9; if (trace) { Vprintf("\nComputational tests : \n"); if (full) Vprintf("\nf06pcc tested with : \n"); if (banded) Vprintf("\nf06pdc tested with : \n"); if (packed) Vprintf("\nf06pec tested with : \n"); Vprintf("(UpperTriangle (u),.........)\n"); Vprintf("(LowerTriangle (l),.........)\n\n"); } nc = 0; reset = TRUE; errmax = 0.0; for (in = 1; in <= nidim; ++in) { n = IDIM(in); if (banded) nk = nkb; else nk = 1; for (ik = 1; ik <= nk; ++ik) { if (banded) k = KB(ik); else k = n - 1; /* Set tda to 1 more than minimum value if room. */ if (banded) tda = k + 1; else tda = n; if (tda < nmax) ++tda; tda = nmax; /* George Levy */ /* Skip tests if not enough room. */ if (tda > nmax) goto L200; if (packed) laa = n * (n + 1) / 2; else laa = tda * n; null = n <= 0; for (ic = 1; ic <= 2; ++ic) { uplo = ich[ic - 1]; if (uplo == 'u') uplo_c = UpperTriangle; else uplo_c = LowerTriangle; /* Generate the matrix A. */ transl = 0.0; smake(sname + 8, uplo, ' ', n, n, a, nmax, aa, tda, k, k, &reset, transl); for (ix = 1; ix <= ninc; ++ix) { incx = INC(ix); lx = ABS(incx) * n; /* Generate the vector x. */ transl = 0.5; smake("ge", ' ', ' ', (Integer)1, n, x, (Integer)1, xx, (Integer)ABS(incx), (Integer)0, n - 1, &reset, transl); if (n > 1) { X(n/2) = 0.0; XX(ABS(incx)*(n/2-1)+1) = 0.0; } for (iy = 1; iy <= ninc; ++iy) { incy = INC(iy); ly = ABS(incy) * n; for (ia = 1; ia <= nalf; ++ia) { alpha = ALF(ia); for (ib = 1; ib <= nbet; ++ib) { beta = BET(ib); /* Generate the vector y. */ transl = 0.0; smake("ge", ' ', ' ', (Integer)1, n, y, (Integer)1, yy, (Integer)ABS(incy), (Integer)0, n - 1, &reset, transl); ++nc; /* Save every datum before calling the subroutine. */ uplos_c = uplo_c; ns = n; ks = k; als = alpha; for (i = 1; i <= laa; ++i) AS(i) = AA(i); tdas = tda; for (i = 1; i <= lx; ++i) XS(i) = XX(i); incxs = incx; bls = beta; for (i = 1; i <= ly; ++i) YS(i) = YY(i); incys = incy; /* Call the subroutine. */ if (full) { if (trace) { Vprintf("%6ld: %6s(%c,%3ld," "%4.1f, A,%3ld, X,%2ld,%4.1f, Y,%2ld).\n", nc, sname, uplo, n,alpha,tda, incx, beta, incy); } for (j =0; j < n; ++j) { for (i = 0; i < n; ++i) transpose_aa[i * tda + j] = AA(1+i+j*tda); } f06pcc(uplo_c, n, alpha, transpose_aa, tda, xx, incx, beta, yy, incy); for (j =0; j < n; ++j) { for (i = 0; i < n; ++i) AA(1+i+j*tda) = transpose_aa[i * tda + j]; } } else if (banded) { if (trace) { Vprintf("%6ld: %6s(%c,%3ld,%3ld," "%4.1f, A,%3ld, X,%2ld,%4.1f, Y,%2ld).\n", nc,sname,uplo,n,k,alpha,tda,incx,beta,incy); } /* set transpose_aa to rogue values */ for (i=0; i < nmax_nmax - 1; ++i) transpose_aa[i] = 1.12E10; /* pack matrix in C order */ if (uplo_c == UpperTriangle) { for (i = 0; i < n; ++i) { m = - i; for (j = i; j <= MIN(n-1,i+k); ++j) transpose_aa[(i*tda)+m+j] = a[i+(j*tda)]; } } else { for (i = 0; i < n; ++i) { m = k - i; for (j = MAX(0,i-k); j <= i; ++j) transpose_aa[(i*tda)+m+j] = a[i+(j*tda)]; } } f06pdc(uplo_c, n, k, alpha, transpose_aa, tda, xx, incx, beta, yy, incy); } else if (packed) { if (trace) { Vprintf("%6ld: %6s(%c,%3ld," "%4.1f, AP, X,%2ld,%4.1f, Y,%2ld).\n", nc,sname,uplo,n,alpha,incx, beta,incy); } pack_vector (uplo_c, n, aa, transpose_aa); f06pec(uplo_c, n, alpha, transpose_aa, xx, incx, beta, yy, incy); unpack_vector (uplo_c, n, aa, transpose_aa); } /* 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] = uplo_c == uplos_c; isame[1] = ns == n; if (full) { isame[2] = als == alpha; isame[3] = lse(as, aa, laa); isame[4] = tdas == tda; isame[5] = lse(xs, xx, lx); isame[6] = incxs == incx; isame[7] = bls == beta; if (null) isame[8] = lse(ys, yy, ly); else { isame[8] = lseres("ge", ' ', (Integer)1, n, ys, yy, (Integer)ABS(incy)); } isame[9] = incys == incy; } else if (banded) { isame[2] = ks == k; isame[3] = als == alpha; isame[4] = lse(as, aa, laa); isame[5] = tdas == tda; isame[6] = lse(xs, xx, lx); isame[7] = incxs == incx; isame[8] = bls == beta; if (null) isame[9] = lse(ys, yy, ly); else { isame[9] = lseres("ge", ' ', (Integer)1, n, ys, yy, (Integer)ABS(incy)); } isame[10] = incys == incy; } else if (packed) { isame[2] = als == alpha; isame[3] = lse(as, aa, laa); isame[4] = lse(xs, xx, lx); isame[5] = incxs == incx; isame[6] = bls == beta; if (null) isame[7] = lse(ys, yy, ly); else { isame[7] = lseres("ge", ' ', (Integer)1, n, ys, yy, (Integer)ABS(incy)); } isame[8] = incys == incy; } /* 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. */ smvch('n', n, n, alpha, a, nmax, x, incx, beta, y, incy, yt, g, yy, eps, &err, fatal, 1); errmax = MAX(errmax,err); /* If got really bad answer, report and */ /* return. */ if (*fatal) goto L240; } else { /* Avoid repeating tests with n<=0 */ goto L220; } } } } } } L200: ; } L220: ; } /* 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; L240: Vprintf(" ******* %.6s failed on call number:\n", sname); if (full) { Vprintf("%6ld: %6s(%c,%3ld," "%4.1f, A,%3ld, X,%2ld,%4.1f, Y,%2ld).\n", nc, sname, uplo, n,alpha,tda, incx, beta, incy); } else if (banded) { Vprintf("%6ld: %6s(%c,%3ld,%3ld," "%4.1f, A,%3ld, X,%2ld,%4.1f, Y,%2ld).\n", nc,sname,uplo,n,k,alpha,tda,incx,beta,incy); } else if (packed) { Vprintf("%6ld: %6s(%c,%3ld," "%4.1f, AP, X,%2ld,%4.1f, Y,%2ld).\n", nc,sname,uplo,n,alpha,incx, beta,incy); } L260: return; } /* End of schk2. */ /* ----------------------------------------------------------- */ static void schk3(const char sname[], double eps, double thresh, int trace, int rewi, int *fatal, Integer nidim, Integer idim[], Integer nkb, Integer kb[], Integer ninc, Integer inc[], Integer nmax, Integer incmax, double a[], double aa[], double as[], double x[], double xx[], double xs[], double xt[], double g[], double z[]) { /* Initialized data */ static char ichu[3] = "ul"; static char icht[4] = "ntc"; static char ichd[3] = "un"; /* Local variables */ char diag; Integer tdas; int same; Integer incx; int full, null; char uplo; Integer i, j, k, m, n; char diags; int isame[13]; Integer nargs; int reset; Integer incxs; char trans, uplos; int banded; Integer nc, ik, in; int packed; Integer nk, ks, ix, ns, lx; double errmax; double transl; char transs; Integer laa, icd, tda, ict, icu; double err; MatrixTranspose trans_c; MatrixTriangle uplo_c; MatrixUnitTriangular diag_c; /* Parameter adjustments */ #define Z(I) z[(I) -1] #define G(I) g[(I) -1] #define XT(I) xt[(I) -1] #define XS(I) xs[(I) -1] #define XX(I) xx[(I) -1] #define X(I) x[(I) -1] #define AS(I) as[(I) -1] #define AA(I) aa[(I) -1] #define INC(I) inc[(I) -1] #define KB(I) kb[(I) -1] #define IDIM(I) idim[(I) -1] /* Function Body */ /* .. Executable Statements .. */ full = sname[9] == 'r'; banded = sname[9] == 'b'; packed = sname[9] == 'p'; /* Define the number of arguments. */ if (full) nargs = 8; else if (banded) nargs = 9; else nargs = 7; if (trace) { Vprintf("\nComputational tests : \n"); if (strstr(sname, "sv")) { if (full) Vprintf("\nf06pfc tested with : \n"); if (banded) Vprintf("\nf06pgc tested with : \n"); if (packed) Vprintf("\nf06phc tested with : \n"); } else { if (full) Vprintf("\nf06pjc tested with : \n"); if (banded) Vprintf("\nf06pkc tested with : \n"); if (packed) Vprintf("\nf06plc tested with : \n"); } Vprintf("(UpperTriangle (u), Transpose (t), UnitTriangular (u),..)\n"); Vprintf("(LowerTriangle (l), NoTranspose (n), NotUnitTriangular (n),.)\n"); Vprintf("(................., ConjugateTranspose (c),...............)\n\n"); } nc = 0; reset = TRUE; errmax = 0.0; /* Set up zero vector for smvch. */ for (i = 1; i <= nmax; ++i) Z(i) = 0.0; for (in = 1; in <= nidim; ++in) { n = IDIM(in); if (banded) nk = nkb; else nk = 1; for (ik = 1; ik <= nk; ++ik) { if (banded) k = KB(ik); else k = n - 1; /* Set tda to 1 more than minimum value if room. */ if (banded) tda = k + 1; else tda = n; if (tda < nmax) ++tda; tda = nmax; /* George Levy */ /* Skip tests if not enough room. */ if (tda > nmax) goto L200; if (packed) laa = n * (n + 1) / 2; else laa = tda * n; null = n <= 0; 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) { trans = icht[ict - 1]; if (trans == 'n') trans_c = NoTranspose; else if (trans == 't') trans_c = Transpose; else trans_c = ConjugateTranspose; for (icd = 1; icd <= 2; ++icd) { diag = ichd[icd - 1]; if (diag == 'u') diag_c = UnitTriangular; else diag_c = NotUnitTriangular; /* Generate the matrix A. */ transl = 0.0; smake(sname + 8, uplo, diag, n, n, a, nmax, aa, tda, k, k, &reset, transl); for (ix = 1; ix <= ninc; ++ix) { incx = INC(ix); lx = ABS(incx) * n; /* Generate the vector x. */ transl = 0.5; smake("ge", ' ', ' ', (Integer)1, n, x, (Integer)1, xx, (Integer)ABS(incx), (Integer)0, n - 1, &reset, transl); if (n > 1) { X(n/2) = 0.0; XX(ABS(incx)*(n/2-1)+1) = 0.0; } ++nc; /* Save every datum before calling the subroutine. */ uplos = uplo; transs = trans; diags = diag; ns = n; ks = k; for (i = 1; i <= laa; ++i) AS(i) = AA(i); tdas = tda; for (i = 1; i <= lx; ++i) XS(i) = XX(i); incxs = incx; /* Call the subroutine. */ if (strstr(sname,"mv")) { if (full) { if (trace) { Vprintf("%6ld: %6s(%c,%c,%c,%3ld," " A,%3ld, X,%2ld).\n", nc,sname,uplo,trans,diag,n, tda,incx); } for (j =0; j < n; ++j) { for (i = 0; i < n; ++i) transpose_aa[i * tda + j] = AA(1+i+j*tda); } f06pfc(uplo_c, trans_c, diag_c, n, transpose_aa, tda, xx, incx); for (j =0; j < n; ++j) { for (i = 0; i < n; ++i) AA(1+i+j*tda) = transpose_aa[i * tda + j]; } } else if (banded) { if (trace) { Vprintf("%6ld: %6s(%c,%c,%c,%3ld," "%3ld, A,%3ld, X,%2ld).\n", nc,sname,uplo,trans,diag,n,k,tda,incx); } /* set transpose_aa to rogue values */ for (i=0; i < nmax_nmax - 1; ++i) transpose_aa[i] = 1.12E10; /* pack matrix in C order */ if (uplo_c == UpperTriangle) { for (i = 0; i < n; ++i) { m = - i; for (j = i; j <= MIN(n-1,i+k); ++j) transpose_aa[(i*tda)+m+j] = a[i+(j*tda)]; } } else { for (i = 0; i < n; ++i) { m = k - i; for (j = MAX(0,i-k); j <= i; ++j) transpose_aa[(i*tda)+m+j] = a[i+(j*tda)]; } } f06pgc(uplo_c, trans_c, diag_c, n, k, transpose_aa, tda, xx, incx); } else if (packed) { if (trace) { Vprintf("%6ld: %6s(%c,%c,%c,%3ld," " AP, X,%2ld).\n", nc,sname,uplo,trans,diag,n,incx); } pack_vector (uplo_c, n, aa, transpose_aa); f06phc(uplo_c, trans_c, diag_c, n, transpose_aa, xx, incx); unpack_vector (uplo_c, n, aa, transpose_aa); } } else if (strstr(sname, "sv")) { if (full) { if (trace) { Vprintf("%6ld: %6s(%c,%c,%c,%3ld," " A,%3ld, X,%2ld).\n", nc,sname,uplo,trans,diag,n,tda,incx); } for (j =0; j < n; ++j) { for (i = 0; i < n; ++i) transpose_aa[i * tda + j] = AA(1+i+j*tda); } f06pjc(uplo_c, trans_c, diag_c, n, transpose_aa, tda, xx, incx); for (j =0; j < n; ++j) { for (i = 0; i < n; ++i) AA(1+i+j*tda) = transpose_aa[i * tda + j]; } } else if (banded) { if (trace) { Vprintf("%6ld: %6s(%c,%c,%c,%3ld," "%3ld, A,%3ld, X,%2ld).\n", nc,sname,uplo,trans,diag,n,k,tda,incx); } /* set transpose_aa to rogue values */ for (i=0; i < nmax_nmax - 1; ++i) transpose_aa[i] = 1.12E10; /* pack matrix in C order */ if (uplo_c == UpperTriangle) { for (i = 0; i < n; ++i) { m = - i; for (j = i; j <= MIN(n-1,i+k); ++j) transpose_aa[(i*tda)+m+j] = a[i+(j*tda)]; } } else { for (i = 0; i < n; ++i) { m = k - i; for (j = MAX(0,i-k); j <= i; ++j) transpose_aa[(i*tda)+m+j] = a[i+(j*tda)]; } } f06pkc(uplo_c, trans_c, diag_c, n, k, transpose_aa, tda, xx, incx); } else if (packed) { if (trace) { Vprintf("%6ld: %6s(%c,%c,%c,%3ld," " AP, X,%2ld).\n", nc,sname,uplo,trans,diag,n,incx); } pack_vector (uplo_c, n, aa, transpose_aa); f06plc(uplo_c, trans_c, diag_c, n, transpose_aa, xx, incx); unpack_vector (uplo_c, n, aa, transpose_aa); } } /* 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 ins ide subroutines. */ isame[0] = uplo == uplos; isame[1] = trans == transs; isame[2] = diag == diags; isame[3] = ns == n; if (full) { isame[4] = lse(as, aa, laa); isame[5] = tdas == tda; if (null) isame[6] = lse(xs, xx, lx); else isame[6] = lseres("ge", ' ', (Integer)1, n, xs, xx, (Integer)ABS(incx)); isame[7] = incxs == incx; } else if (banded) { isame[4] = ks == k; isame[5] = lse(as, aa, laa); isame[6] = tdas == tda; if (null) isame[7] = lse(xs, xx, lx); else { isame[7] = lseres("ge", ' ', (Integer)1, n, xs, xx, (Integer)ABS(incx)); } isame[8] = incxs == incx; } else if (packed) { isame[4] = lse(as, aa, laa); if (null) isame[5] = lse(xs, xx, lx); else { isame[5] = lseres("ge", ' ', (Integer)1, n, xs, xx, (Integer)ABS(incx)); } isame[6] = incxs == incx; } /* If data was incorrectly c hanged, 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) { if (strstr(sname, "mv")) { /* Check the result. */ smvch(trans, n, n, 1.0, a, nmax, x, incx, 0.0, z, incx, xt, g, xx, eps, &err, fatal, 1); } else if (strstr(sname,"sv")) { /* Compute approximation to original vector. */ for (i = 1; i <= n; ++i) { Z(i) = XX((i - 1)*ABS(incx)+1); XX((i-1)*ABS(incx)+1) = X(i); } smvch(trans, n, n, 1.0, a, nmax, z, incx, 0.0, x, incx, xt, g, xx, eps, &err, fatal, 0); } errmax = MAX(errmax,err); /* If got really bad answer, report and return. */ if (*fatal) goto L240; } else { /* Avoid repeating tests with n<=0. */ goto L220; } } } } } L200: ; } L220: ; } /* 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; L240: Vprintf(" ******* %.6s failed on call number:)\n",sname); if (full) { Vprintf("%6ld: %6s(%c,%c,%c,%3ld," " A,%3ld, X,%2ld).\n", nc,sname,uplo,trans,diag,n,tda,incx); } else if (banded) { Vprintf("%6ld: %6s(%c,%c,%c,%3ld," "%3ld, A,%3ld, X,%2ld).\n", nc, sname,uplo,trans,diag,n,k,tda,incx); } else if (packed) { Vprintf("%6ld: %6s(%c,%c,%c,%3ld," " AP, X,%2ld).\n", nc,sname,uplo,trans,diag,n,incx); } L260: return; } /* End of 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 ninc, Integer inc[], Integer nmax, Integer incmax, double a[], double aa[], double as[], double x[], double xx[], double xs[], double y[], double yy[], double ys[], double yt[], double g[], double z[]) { /* Local variables */ Integer tdas; int same; Integer incx, incy; int null; Integer i, j, m, n; double alpha, w[1]; int isame[13]; Integer nargs; int reset; Integer incxs, incys, ia, nc, nd, im, in, ms, ix, iy, ns, lx, ly; double errmax; double transl; Integer laa, tda; double als; double err; /* Parameter adjustments */ #define Z(I) z[(I) -1] #define G(I) g[(I) -1] #define YT(I) yt[(I) -1] #define YS(I) ys[(I) -1] #define YY(I) yy[(I) -1] #define Y(I) y[(I) -1] #define XS(I) xs[(I) -1] #define XX(I) xx[(I) -1] #define X(I) x[(I) -1] #define AS(I) as[(I) -1] #define AA(I) aa[(I) -1] #define INC(I) inc[(I) -1] #define ALF(I) alf[(I) -1] #define IDIM(I) idim[(I) -1] /* Function Body */ nargs = 9; nc = 0; reset = TRUE; errmax = 0.0; for (in = 1; in <= nidim; ++in) { n = IDIM(in); nd = n / 2 + 1; for (im = 1; im <= 2; ++im) { if (im == 1) m = MAX( n - nd,0); else m = MIN( n + nd,nmax); /* Set tda to 1 more than minimum value if room. */ tda = m; if (tda < nmax) ++tda; tda = nmax; /* George Levy */ /* Skip tests if not enough room. */ if (tda > nmax) goto L220; laa = tda * n; null = n <= 0 || m <= 0; for (ix = 1; ix <= ninc; ++ix) { incx = INC(ix); lx = ABS(incx) * m; /* Generate the vector x. */ transl = 0.5; smake("ge", ' ', ' ', (Integer)1, m, x, (Integer)1, xx, (Integer)ABS(incx), (Integer)0, m - 1, &reset, transl); if (m > 1) { X(m / 2) = 0.0; XX(ABS(incx)*(m/2-1)+1) = 0.0; } for (iy = 1; iy <= ninc; ++iy) { incy = INC(iy); ly = ABS(incy) * n; /* Generate the vector y. */ transl = 0.0; smake("ge", ' ', ' ', (Integer)1, n, y, (Integer)1, yy, (Integer)ABS(incy), (Integer)0, n - 1, &reset, transl); if (n > 1) { Y(n/2) = 0.0; YY(ABS(incy)*(n/2-1)+1) = 0.0; } for (ia = 1; ia <= nalf; ++ia) { alpha = ALF(ia); /* Generate the matrix A. */ transl = 0.0; smake(sname + 8, ' ', ' ', m, n, a, nmax, aa, tda, m - 1, n - 1, &reset, transl); ++nc; /* Save every datum before calling the subroutine. */ ms = m; ns = n; als = alpha; for (i = 1; i <= laa; ++i) AS(i) = AA(i); tdas = tda; for (i = 1; i <= lx; ++i) XS(i) = XX(i); incxs = incx; for (i = 1; i <= ly; ++i) YS(i) = YY(i); incys = incy; /* Call the subroutine. */ if (trace) { Vprintf("%6ld: %6s(%3ld,%3ld," "%4.1f, X,%2ld, Y,%2ld, A, %3ld).\n", nc,sname,m,n,alpha,incx,incy,tda); } for (j =0; j < n; ++j) { for (i = 0; i < m; ++i) transpose_aa[i * tda + j] = AA(1 + i + j * tda); } f06pmc(m, n, alpha, xx, incx, yy, incy, transpose_aa, tda); for (j =0; j < n; ++j) { for (i = 0; i < m; ++i) AA(1 + i + j * tda) = transpose_aa[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 L280; } /* See what data changed inside subroutine. */ isame[0] = ms == m; isame[1] = ns == n; isame[2] = als == alpha; isame[3] = lse(xs, xx, lx); isame[4] = incxs == incx; isame[5] = lse(ys, yy, ly); isame[6] = incys == incy; if (null) isame[7] = lse(as, aa, laa); else isame[7] = lseres("ge", ' ', m, n, as, aa, tda); isame[8] = tdas == tda; /* 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 L280; } if (! null) { /* Check the result column by column. */ if (incx > 0) { for (i = 1; i <= m; ++i) Z(i) = X(i); } else { for (i = 1; i <= m; ++i) Z(i) = X(m - i + 1); } for (j = 1; j <= n; ++j) { if (incy > 0) w[0] = Y(j); else w[0] = Y(n - j + 1); smvch('n', m, (Integer)1, alpha, z, nmax, w, (Integer)1, 1.0, &a[j*nmax+1-nmax-1], (Integer)1, yt, g, &AA((j - 1)*tda+1), eps, &err, fatal, 1); errmax = MAX(errmax,err); /* If got really bad answer, report and return. */ if (*fatal) goto L260; } } else { /* Avoid repeating tests with M<=0 or n<=0. */ goto L220; } } } } L220: ; } } /* 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 L300; L260: Vprintf(" These are the results for column %3ld).\n", j); L280: Vprintf(" ******* %.6s Failed on call number: \n",sname); Vprintf("%6ld: %6s(%3ld,%3ld," "%4.1f, X,%2ld, Y,%2ld, A, %3ld).\n", nc,sname,m,n,alpha,incx,incy,tda); L300: return; } /* End of 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 ninc, Integer inc[], Integer nmax, Integer incmax, double a[], double aa[], double as[], double x[], double xx[], double xs[], double y[], double yy[], double ys[], double yt[], double g[], double z[]) { /* Initialized data */ static char ich[3] = "ul"; /* Local variables */ Integer tdas; int same; Integer incx; int full, null; char uplo; Integer i, j, n; double alpha, w[1]; int isame[13]; Integer nargs; int reset; Integer incxs; int upper; Integer ia, ja, ic, nc, jj, lj, in; int packed; Integer ix, ns, lx; double errmax; double transl; Integer laa, tda; double als; double err; MatrixTriangle uplo_c, uplos_c; /* Parameter adjustments */ #define Z(I) z[(I) -1] #define G(I) g[(I) -1] #define YT(I) yt[(I) -1] #define YS(I) ys[(I) -1] #define YY(I) yy[(I) -1] #define Y(I) y[(I) -1] #define XS(I) xs[(I) -1] #define XX(I) xx[(I) -1] #define X(I) x[(I) -1] #define AS(I) as[(I) -1] #define AA(I) aa[(I) -1] #define INC(I) inc[(I) -1] #define ALF(I) alf[(I) -1] #define IDIM(I) idim[(I) -1] /* Function Body */ /* .. Executable Statements .. */ full = sname[9] == 'y'; packed = sname[9] == 'p'; /* Define the number of arguments. */ if (full) nargs = 7; else nargs = 6; if (trace) { if (full) Vprintf("\nf06ppc tested with : \n"); if (packed) Vprintf("\nf06pqc tested with : \n"); Vprintf("(UpperTriangle (u),.........)\n"); Vprintf("(LowerTriangle (l),.........)\n\n"); } nc = 0; reset = TRUE; errmax = 0.0; for (in = 1; in <= nidim; ++in) { n = IDIM(in); /* Set tda to 1 more than minimum value if room. */ tda = n; if (tda < nmax) ++tda; tda = nmax; /* George Levy */ /* Skip tests if not enough room. */ if (tda > nmax) goto L200; if (packed) laa = n * (n + 1) / 2; else laa = tda * n; for (ic = 1; ic <= 2; ++ic) { uplo = ich[ic - 1]; upper = uplo == 'u'; if (uplo == 'u') uplo_c = UpperTriangle; else uplo_c = LowerTriangle; for (ix = 1; ix <= ninc; ++ix) { incx = INC(ix); lx = ABS(incx) * n; /* Generate the vector x. */ transl = 0.5; smake("ge", ' ', ' ', (Integer)1, n, x, (Integer)1, xx, (Integer)ABS(incx), (Integer)0, n - 1, &reset, transl); if (n > 1) { X(n / 2) = 0.0; XX(ABS(incx) * (n / 2 - 1) + 1) = 0.0; } for (ia = 1; ia <= nalf; ++ia) { alpha = ALF(ia); null = n <= 0 || alpha == 0.0; /* Generate the matrix A. */ transl = 0.0; smake(sname + 8, uplo, ' ', n, n, a, nmax, aa, tda, n - 1, n - 1, &reset, transl); ++nc; /* Save every datum before calling the subroutine. */ uplos_c = uplo_c; ns = n; als = alpha; for (i = 1; i <= laa; ++i) AS(i) = AA(i); tdas = tda; for (i = 1; i <= lx; ++i) XS(i) = XX(i); incxs = incx; /* Call the subroutine. */ if (full) { if (trace) { Vprintf("%6ld: %6s(%c,%3ld," "%4.1f, X,%2ld, A,%3ld).\n", nc,sname,uplo,n,alpha,incx,tda); } for (j =0; j < n; ++j) { for (i = 0; i < n; ++i) transpose_aa[i * tda + j] = AA(1 + i + j * tda); } f06ppc(uplo_c, n, alpha, xx, incx, transpose_aa, tda); for (j =0; j < n; ++j) { for (i = 0; i < n; ++i) AA(1 + i + j * tda) = transpose_aa[i * tda + j]; } } else if (packed) { if (trace) { Vprintf("%6ld: %6s(%c,%3ld," "%4.1f, X,%2ld, AP).\n", nc,sname,uplo,n,alpha,incx); } pack_vector (uplo_c, n, aa, transpose_aa); f06pqc(uplo_c, n, alpha, xx, incx, transpose_aa); unpack_vector (uplo_c, n, aa, transpose_aa); } /* 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] = uplo_c == uplos_c; isame[1] = ns == n; isame[2] = als == alpha; isame[3] = lse(xs, xx, lx); isame[4] = incxs == incx; if (null) isame[5] = lse(as, aa, laa); else isame[5] = lseres(sname + 8, uplo, n, n, as, aa, tda); if (! packed) isame[6] = tdas == tda; /* 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. */ if (incx > 0) { for (i = 1; i <= n; ++i) Z(i) = X(i); } else { for (i = 1; i <= n; ++i) Z(i) = X(n - i + 1); } ja = 1; for (j = 1; j <= n; ++j) { w[0] = Z(j); if (upper) { jj = 1; lj = j; } else { jj = j; lj = n - j + 1; } smvch('n', lj, (Integer)1, alpha, &Z(jj), lj, w, (Integer)1, 1.0, &a[jj-1 + (j-1)*nmax], (Integer)1, yt, g, &AA(ja), eps, &err, fatal, 1); if (full) { if (upper) ja += tda; else ja = ja + tda + 1; } else ja += lj; errmax = MAX(errmax,err); /* If got really bad answer,report and return. */ if (*fatal) goto L220; } } else { /* Avoid repeating tests if N.le.0. */ if (n <= 0) goto L200; } } } } 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: Vprintf(" These are the results for column %3ld",j); L240: Vprintf(" ******* %.6s failed on call number:\n", sname); if (full) { Vprintf("%6ld: %6s(%c,%3ld," "%4.1f, X,%2ld, A,%3ld).\n", nc,sname,uplo,n,alpha,incx,tda); } else if (packed) { Vprintf("%6ld: %6s(%c,%3ld," "%4.1f, X,%2ld, AP).\n", nc,sname,uplo,n,alpha,incx); } L260: return; } /* End of schk5. */ /* ------------------------------------------------------- */ static void schk6(const char sname[], double eps, double thresh, int trace, int rewi, int *fatal, Integer nidim, Integer idim[], Integer nalf, double alf[], Integer ninc, Integer inc[], Integer nmax, Integer incmax, double a[], double aa[], double as[], double x[], double xx[], double xs[], double y[], double yy[], double ys[], double yt[], double g[], double z[]) { /* Initialized data */ static char ich[3] = "ul"; /* Local variables */ Integer tdas; int same; Integer incx, incy; int full, null; char uplo; Integer i, j, n; double alpha, w[2]; int isame[13]; Integer nargs; int reset; Integer incxs, incys; int upper; Integer ia, ja, ic, nc, jj, lj, in; int packed; Integer ix, iy, ns, lx, ly; double errmax; double transl; Integer laa, tda; double als; double err; MatrixTriangle uplo_c, uplos_c; /* Parameter adjustments */ #define G(I) g[(I) -1] #define YT(I) yt[(I) -1] #define YS(I) ys[(I) -1] #define YY(I) yy[(I) -1] #define Y(I) y[(I) -1] #define XS(I) xs[(I) -1] #define XX(I) xx[(I) -1] #define X(I) x[(I) -1] #define AS(I) as[(I) -1] #define AA(I) aa[(I) -1] #define INC(I) inc[(I) -1] #define ALF(I) alf[(I) -1] #define IDIM(I) idim[(I) -1] /* Function Body */ /* .. Executable Statements .. */ full = sname[9] == 'y'; packed = sname[9] == 'p'; /* Define the number of arguments. */ if (full) nargs = 9; else nargs = 8; if (trace) { if (full) Vprintf("\nf06ppc tested with : \n"); if (packed) Vprintf("\nf06pqc tested with : \n"); Vprintf("(UpperTriangle (u),.........)\n"); Vprintf("(LowerTriangle (l),.........)\n\n"); } nc = 0; reset = TRUE; errmax = 0.0; for (in = 1; in <= nidim; ++in) { n = IDIM(in); /* Set tda to 1 more than minimum value if room. */ tda = n; if (tda < nmax) ++tda; tda = nmax; /* Skip tests if not enough room. */ if (tda > nmax) goto L280; if (packed) laa = n * (n + 1) / 2; else laa = tda * n; for (ic = 1; ic <= 2; ++ic) { uplo = ich[ic - 1]; upper = uplo == 'u'; if (uplo == 'u') uplo_c = UpperTriangle; else uplo_c = LowerTriangle; for (ix = 1; ix <= ninc; ++ix) { incx = INC(ix); lx = ABS(incx) * n; /* Generate the vector x. */ transl = 0.5; smake("ge", ' ', ' ', (Integer)1, n, x, (Integer)1, xx, (Integer)ABS(incx), (Integer)0, n - 1, &reset, transl); if (n > 1) { X(n / 2) = 0.0; XX(ABS(incx) * (n / 2 - 1) + 1) = 0.0; } for (iy = 1; iy <= ninc; ++iy) { incy = INC(iy); ly = ABS(incy) * n; /* Generate the vector y. */ transl = 0.0; smake("ge", ' ', ' ', (Integer)1, n, y, (Integer)1, yy, (Integer)ABS(incy), (Integer)0, n - 1, &reset, transl); if (n > 1) { Y(n / 2) = 0.0; YY(ABS(incy) * (n / 2 - 1) + 1) = 0.0; } for (ia = 1; ia <= nalf; ++ia) { alpha = ALF(ia); null = n <= 0 || alpha == 0.0; /* Generate the matrix A. */ transl = 0.0; smake(sname + 8, uplo, ' ', n, n, a, nmax, aa, tda, n - 1, n - 1, &reset, transl); ++nc; /* Save every datum before calling the subroutine. */ uplos_c = uplo_c; ns = n; als = alpha; for (i = 1; i <= laa; ++i) AS(i) = AA(i); tdas = tda; for (i = 1; i <= lx; ++i) XS(i) = XX(i); incxs = incx; for (i = 1; i <= ly; ++i) YS(i) = YY(i); incys = incy; /* Call the subroutine. */ if (full) { if (trace) { Vprintf("%6ld: %6s(%c,%3ld," "%4.1f, X,%2ld, Y,%2ld, A, %3ld).\n", nc,sname,uplo,n,alpha,incx,incy,tda); } for (j =0; j < n; ++j) { for (i = 0; i < n; ++i) transpose_aa[i * tda + j] = AA(1 + i + j * tda); } f06prc(uplo_c, n, alpha, xx, incx, yy, incy, transpose_aa, tda); for (j =0; j < n; ++j) { for (i = 0; i < n; ++i) AA(1 + i + j * tda) = transpose_aa[i * tda + j]; } } else if (packed) { if (trace) { Vprintf("%6ld: %6s(%c,%3ld," "%4.1f, X,%2ld, Y,%2ld, AP).\n", nc,sname,uplo,n,alpha,incx,incy); } pack_vector (uplo_c, n, aa, transpose_aa); f06psc(uplo_c, n, alpha, xx, incx, yy, incy, transpose_aa); unpack_vector (uplo_c, n, aa, transpose_aa); } /* Check if error-exit was taken incorrectly. */ if (! infoc.ok) { Vprintf(" ******* Fatal error - error-exit taken on valid call *******\n"); *fatal = TRUE; goto L320; } /* See what data changed inside subroutines. */ isame[0] = uplo_c == uplos_c; isame[1] = ns == n; isame[2] = als == alpha; isame[3] = lse(xs, xx, lx); isame[4] = incxs == incx; isame[5] = lse(ys, yy, ly); isame[6] = incys == incy; if (null) isame[7] = lse(as, aa, laa); else { isame[7] = lseres(sname + 8, uplo, n, n, as , aa, tda); } if (! packed) isame[8] = tdas == tda; /* 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 L320; } if (! null) { /* Check the result column by column. */ if (incx > 0) { for (i = 1; i <= n; ++i) z[i -1] = X(i); } else { for (i = 1; i <= n; ++i) z[i -1] = X(n - i + 1); } if (incy > 0) { for (i = 1; i <= n; ++i) z[i + nmax -1] = Y(i); } else { for (i = 1; i <= n; ++i) z[i + nmax -1] = Y(n - i + 1); } ja = 1; for (j = 1; j <= n; ++j) { w[0] = z[j + nmax -1]; w[1] = z[j -1]; if (upper) { jj = 1; lj = j; } else { jj = j; lj = n - j + 1; } smvch('n', lj, (Integer)2, alpha, &z[jj -1], nmax, w, (Integer)1, 1.0, &a[jj-1 + (j-1)*nmax], (Integer)1, yt, g, &AA(ja), eps, &err, fatal, 1); if (full) { if (upper) ja += tda; else ja = ja + tda + 1; } else ja += lj; errmax = MAX(errmax,err); /* If got really bad answer, report and return. */ if (*fatal) goto L300; } } else { /* Avoid repeating tests wit h N.le.0. */ if (n <= 0) goto L280; } } } } } L280: ; } /* 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 L340; L300: Vprintf(" These are the results for column %3ld\n",j); L320: Vprintf(" ******* %.6s failed on call number:\n", sname); if (full) { Vprintf("%6ld: %6s(%c,%3ld," "%4.1f, X,%2ld, Y,%2ld, A, %3ld).\n", nc,sname,uplo,n,alpha,incx,incy,tda); } else if (packed) { Vprintf("%6ld: %6s(%c,%3ld," "%4.1f, X,%2ld, Y,%2ld, AP).\n", nc,sname,uplo,n,alpha,incx,incy); } L340: return; } /* End of schk6. */ /* ------------------------------------------------------------- */ static void schke(Integer isnum, const char srnamt[]) { /* Local variables */ Integer zero = 0; Integer one = 1; Integer m_one = -1; Integer two = 2; static double beta, a[1]; static double alpha; static double x[1], y[1]; /* Tests the error exits from the Level 2 Blas. Requires a special version of the error-handling routine f06aaz. alpha, beta, a, x and y should not need to be defined. Auxiliary routine for test program for Level 2 Blas. OK is set to .FALSE. by the special version of F06AAZ or by CHKXER 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; case 7: goto L140; case 8: goto L160; case 9: goto L180; case 10: goto L200; case 11: goto L220; case 12: goto L240; case 13: goto L260; case 14: goto L280; case 15: goto L300; case 16: goto L320; } L20: infoc.infot = 1; f06pac((MatrixTranspose)999, zero, zero, alpha, a, one, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06pac(NoTranspose, m_one, zero, alpha, a, one, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06pac(NoTranspose, zero, m_one, alpha, a, one, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 6; f06pac(NoTranspose, zero, two, alpha, a, one, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 8; f06pac(NoTranspose, zero, zero, alpha, a, one, x, zero, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 11; f06pac(NoTranspose, zero, zero, alpha, a, one, x, one, beta, y, zero); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L340; L40: infoc.infot = 1; f06pbc((MatrixTranspose)999, zero, zero, zero, zero, alpha, a, one, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06pbc(NoTranspose, m_one, zero, zero, zero, alpha, a, one, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06pbc(NoTranspose, zero, m_one, zero, zero, alpha, a, one, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06pbc(NoTranspose, zero, zero, m_one, zero, alpha, a, one, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06pbc(NoTranspose, two, zero, zero, m_one, alpha, a, one, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 8; f06pbc(NoTranspose, zero, zero, one, zero, alpha, a, one, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 10; f06pbc(NoTranspose, zero, zero, zero, zero, alpha, a, one, x, zero, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 13; f06pbc(NoTranspose, zero, zero, zero, zero, alpha, a, one, x, one, beta, y, zero); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L340; L60: infoc.infot = 1; f06pcc((MatrixTriangle)999, zero, alpha, a, one, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06pcc(UpperTriangle, m_one, alpha, a, one, x,one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06pcc(UpperTriangle, two, alpha, a, one, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06pcc(UpperTriangle, zero, alpha, a, one, x, zero, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 10; f06pcc(UpperTriangle, zero, alpha, a, one, x, one, beta, y, zero); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L340; L80: infoc.infot = 1; f06pdc((MatrixTriangle)999, zero, zero, alpha, a, one, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06pdc(UpperTriangle, m_one, zero, alpha, a, one, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06pdc(UpperTriangle, zero, m_one, alpha, a, one, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 6; f06pdc(UpperTriangle, zero, one, alpha, a, one, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 8; f06pdc(UpperTriangle, zero, zero, alpha, a, one, x, zero, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 11; f06pdc(UpperTriangle, zero, zero, alpha, a, one, x, one, beta, y, zero); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L340; L100: infoc.infot = 1; f06pec((MatrixTriangle)999, zero, alpha, a, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06pec(UpperTriangle, m_one, alpha, a, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 6; f06pec(UpperTriangle, zero, alpha, a, x, zero, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06pec(UpperTriangle, zero, alpha, a, x, one, beta, y, zero); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L340; L120: infoc.infot = 1; f06pfc((MatrixTriangle)999, NoTranspose, NotUnitTriangular, zero, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06pfc(UpperTriangle, (MatrixTranspose)999, NotUnitTriangular, zero, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06pfc(UpperTriangle, NoTranspose, (MatrixUnitTriangular)999, zero, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06pfc(UpperTriangle, NoTranspose, NotUnitTriangular, m_one, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 6; f06pfc(UpperTriangle, NoTranspose, NotUnitTriangular, two, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 8; f06pfc(UpperTriangle, NoTranspose, NotUnitTriangular, zero, a, one, x, zero); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L340; L140: infoc.infot = 1; f06pgc((MatrixTriangle)999, NoTranspose, NotUnitTriangular, zero, zero, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06pgc(UpperTriangle, (MatrixTranspose)999, NotUnitTriangular, zero, zero, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06pgc(UpperTriangle, NoTranspose, (MatrixUnitTriangular)999, zero, zero, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06pgc(UpperTriangle, NoTranspose, NotUnitTriangular, m_one, zero, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06pgc(UpperTriangle, NoTranspose, NotUnitTriangular, zero, m_one, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06pgc(UpperTriangle, NoTranspose, NotUnitTriangular, zero, one, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06pgc(UpperTriangle, NoTranspose, NotUnitTriangular, zero, zero, a, one, x, zero); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L340; L160: infoc.infot = 1; f06phc((MatrixTriangle)999, NoTranspose, NotUnitTriangular, zero, a, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06phc(UpperTriangle, (MatrixTranspose)999, NotUnitTriangular, zero, a, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06phc(UpperTriangle, NoTranspose, (MatrixUnitTriangular)999, zero, a, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06phc(UpperTriangle, NoTranspose, NotUnitTriangular, m_one, a, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06phc(UpperTriangle, NoTranspose, NotUnitTriangular, zero, a, x, zero); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L340; L180: infoc.infot = 1; f06pjc((MatrixTriangle)999, NoTranspose, NotUnitTriangular, zero, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06pjc(UpperTriangle, (MatrixTranspose)999, NotUnitTriangular, zero, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06pjc(UpperTriangle, NoTranspose, (MatrixUnitTriangular)999, zero, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06pjc(UpperTriangle, NoTranspose, NotUnitTriangular, m_one, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 6; f06pjc(UpperTriangle, NoTranspose, NotUnitTriangular, two, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 8; f06pjc(UpperTriangle, NoTranspose, NotUnitTriangular, zero, a, one, x, zero); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L340; L200: infoc.infot = 1; f06pkc((MatrixTriangle)999, NoTranspose, NotUnitTriangular, zero, zero, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06pkc(UpperTriangle, (MatrixTranspose)999, NotUnitTriangular, zero, zero, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06pkc(UpperTriangle, NoTranspose, (MatrixUnitTriangular)999, zero, zero, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06pkc(UpperTriangle, NoTranspose, NotUnitTriangular, m_one, zero, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06pkc(UpperTriangle, NoTranspose, NotUnitTriangular, zero, m_one, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06pkc(UpperTriangle, NoTranspose, NotUnitTriangular, zero, one, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06pkc(UpperTriangle, NoTranspose, NotUnitTriangular, zero, zero, a, one, x, zero); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L340; L220: infoc.infot = 1; f06plc((MatrixTriangle)999, NoTranspose, NotUnitTriangular, zero, a, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06plc(UpperTriangle, (MatrixTranspose)999, NotUnitTriangular, zero, a, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06plc(UpperTriangle, NoTranspose, (MatrixUnitTriangular)999, zero, a, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06plc(UpperTriangle, NoTranspose, NotUnitTriangular, m_one, a, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06plc(UpperTriangle, NoTranspose, NotUnitTriangular, zero, a, x, zero); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L340; L240: infoc.infot = 1; f06pmc(m_one, zero, alpha, x, one, y, one, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06pmc(zero, m_one, alpha, x, one, y, one, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06pmc(zero, zero, alpha, x, zero, y, one, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06pmc(zero, zero, alpha, x, one, y, zero, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06pmc(zero, two, alpha, x, one, y, one, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L340; L260: infoc.infot = 1; f06ppc((MatrixTriangle)999, zero, alpha, x, one, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06ppc(UpperTriangle, m_one, alpha, x, one, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06ppc(UpperTriangle, zero, alpha, x, zero, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06ppc(UpperTriangle, two, alpha, x, one, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L340; L280: infoc.infot = 1; f06pqc((MatrixTriangle)999, zero, alpha, x, one, a); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06pqc(UpperTriangle, m_one, alpha, x, one, a); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06pqc(UpperTriangle, zero, alpha, x, zero, a); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L340; L300: infoc.infot = 1; f06prc((MatrixTriangle)999, zero, alpha, x, one, y, one, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06prc(UpperTriangle, m_one, alpha, x, one, y, one, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06prc(UpperTriangle, zero, alpha, x, zero, y, one, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06prc(UpperTriangle, zero, alpha, x, one, y, zero, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06prc(UpperTriangle, two, alpha, x, one, y, one, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L340; L320: infoc.infot = 1; f06psc((MatrixTriangle)999, zero, alpha, x, one, y, one, a); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06psc(UpperTriangle, m_one, alpha, x, one, y, one, a); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06psc(UpperTriangle, zero, alpha, x, zero, y, one, a); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06psc(UpperTriangle, zero, alpha, x, one, y, zero, a); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); L340: if (infoc.ok) Vprintf("%.6s passed the tests of error-exits\n", srnamt); else Vprintf(" ******* %.6s failed the tests of error-exits *******\n", srnamt); } /* End of schke. */ /* ----------------------------------------------------- */ static void smake(const char *type, char uplo, char diag, Integer m, Integer n, double a[], Integer nmax, double aa[], Integer tda, Integer kl, Integer ku, int *reset, double transl) { /* Local variables */ Integer ibeg, iend; Integer ioff; int unit; Integer i, j; int lower; Integer i1, i2, i3; int upper; Integer kk; int gen, tri, sym; /* 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 C Blas. */ /* Parameter adjustments */ #define AA(I) aa[(I) -1] /* Function Body */ gen = *type == 'g'; sym = *type == 's'; tri = *type == 't'; 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)) { if ((i <= j && j - i <= ku) || (i >= j && i - j <= kl)) a[i-1 + (j-1)*nmax] = sbeg(reset) + transl; else a[i-1 + (j-1)*nmax] = 0.0; if (i != j) { 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 ( strstr(type, "ge")) { for (j = 1; j <= n; ++j) { for (i = 1; i <= m; ++i) AA(i + (j - 1) * tda) = a[i-1 + (j-1)*nmax]; for (i = m + 1; i <= tda; ++i) AA(i + (j - 1) * tda) = -1e10; } } else if (strstr(type, "gb")) { for (j = 1; j <= n; ++j) { for (i1 = 1; i1 <= ku + 1 - j; ++i1) AA(i1 + (j - 1) * tda) = -1e10; for (i2 = i1; i2 <= MIN( kl + ku + 1, ku + 1 + m - j); ++i2) AA(i2 + (j - 1) * tda) = a[i2 + j - ku - 1-1 + (j-1)*nmax]; for (i3 = i2; i3 <= tda; ++i3) AA(i3 + (j - 1) * tda) = -1e10; } } else if (strstr(type, "sy") || strstr(type, "tr")) { 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 + (j - 1) * tda) = -1e10; for (i = ibeg; i <= iend; ++i) AA(i + (j - 1) * tda) = a[i-1 + (j-1)*nmax]; for (i = iend + 1; i <= tda; ++i) AA(i + (j - 1) * tda) = -1e10; } } else if (strstr(type, "sb") || strstr(type, "tb")) { for (j = 1; j <= n; ++j) { if (upper) { kk = kl + 1; ibeg = MAX( 1, kl + 2 - j); if (unit) iend = kl; else iend = kl + 1; } else { kk = 1; if (unit) ibeg = 2; else ibeg = 1; iend = MIN( kl + 1, m + 1 - j); } for (i = 1; i <= ibeg - 1; ++i) AA(i + (j - 1) * tda) = -1e10; for (i = ibeg; i <= iend; ++i) AA(i + (j - 1) * tda) = a[i + j - kk-1 + (j-1)*nmax]; for (i = iend + 1; i <= tda; ++i) AA(i + (j - 1) * tda) = -1e10; } } else if (strstr(type, "sp") || strstr(type, "tp")) { ioff = 0; for (j = 1; j <= n; ++j) { if (upper) { ibeg = 1; iend = j; } else { ibeg = j; iend = n; } for (i = ibeg; i <= iend; ++i) { ++ioff; AA(ioff) = a[i-1 + (j-1)*nmax]; if (i == j) { if (unit) AA(ioff) = -1e10; } } } } } /* End of smake. */ /* ------------------------------------------------------------- */ static void smvch(char trans, Integer m, Integer n, double alpha, double a[], Integer nmax, double x[], Integer incx, double beta, double y[], Integer incy, double yt[], double g[], double yy[], double eps, double *err, int *fatal, int mv) { double d__1; /* Local variables */ double erri; int tran; Integer i, j, incxl, incyl, ml, nl, iy, jx, kx, ky; /* Checks the results of the computational tests. */ /* Parameter adjustments */ #define YY(I) yy[(I) -1] #define G(I) g[(I) -1] #define YT(I) yt[(I) -1] #define Y(I) y[(I) -1] #define X(I) x[(I) -1] /* Function Body */ tran = trans == 't' || 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; for (i = 1; i <= ml; ++i) { YT(iy) = 0.0; G(iy) = 0.0; jx = kx; if (tran) { for (j = 1; j <= nl; ++j) { YT(iy) += a[j-1 + (i-1)*nmax] * X(jx); G(iy) += (d__1 = a[j-1 + (i-1)*nmax] * X(jx), ABS(d__1)); jx += incxl; } } else { for (j = 1; j <= nl; ++j) { YT(iy) += a[i-1 + (j-1)*nmax] * X(jx); G(iy) += (d__1 = a[i-1 + (j-1)*nmax] * X(jx), ABS(d__1)); jx += incxl; } } YT(iy) = alpha * YT(iy) + beta * Y(iy); G(iy) = ABS(alpha) * G(iy) + (d__1 = beta * Y(iy), ABS(d__1)); iy += incyl; } /* Compute the error ratio for this result. */ *err = 0.0; for (i = 1; i <= ml; ++i) { erri = (d__1 = YT(i) - YY((i - 1) * ABS(incy) + 1), ABS(d__1)) / eps; if (G(i) != 0.0) erri /= G(i); *err = MAX(*err,erri); if (*err * sqrt(eps) >= 1.0) goto L100; } /* If the loop completes, all results are at least half accurate. */ goto L140; /* Report fatal error. */ L100: *fatal = TRUE; Vprintf(" ******* Fatal error - computed result is less than " "half accurate *******\n Expected result Computed result\n"); for (i = 1; i <= ml; ++i) { if (mv) Vprintf("%7ld%18.6g %18.6g\n", i,YT(i),YY((i - 1) * ABS(incy) + 1)); else Vprintf("%7ld%18.6g %18.6g\n", i, YY((i - 1) * ABS(incy) + 1), YT(i)); } L140: return; } /* End of smvch. */ /* ----------------------------------------------------------------- */ 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. */ /* Parameter adjustments */ #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; } /* End of 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', 'sy' or 'sp'. */ /* Function Body */ upper = uplo == 'u'; if (strstr(type, "ge")) { 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 L120; } } } else if (strstr(type, "sy")) { 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 L120; } for (i = iend + 1; i <= tda; ++i) { if (aa[i-1 + (j-1)*tda] != as[i-1 + (j-1)*tda]) goto L120; } } } ret_val = TRUE; goto L140; L120: ret_val = FALSE; L140: return ret_val; } /* End of lseres. */ /* -------------------------------------------------------------- */ static double sbeg(int *reset) { /* System generated locals */ double ret_val; /* Local variables */ static Integer i, ic, mi; /* Generates random numbers uniformly distributed between */ /* -0.5 and 0.5. */ 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 = (double) (i - 500) / 1001.0; return ret_val; } /* End of 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 2 Blas. */ if (! (*lerr)) { Vprintf("***** Illegal value of parameter number %1ld," "not detected by %6s *****\n", infot, srnamt); *ok = FALSE; } *lerr = FALSE; } /* End of 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; }