/* f06sbce.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 #include #define NSUBS 17 #define RZERO 0.0 #define NMAX 20 #define INCMAX 2 #define NINMAX 7 #define NIDMAX 9 #define NKBMAX 7 #define NALMAX 7 #define NBEMAX 7 static void cchk1(const char sname[], double eps, double thresh, int trace, int rewi, int *fatal, Integer nidim, Integer idim[], Integer nkb, Integer kb[], Integer nalf, Complex alf[], Integer nbet, Complex bet[], Integer ninc, Integer inc[], Integer nmax, Integer incmax, Complex a[], Complex aa[], Complex as[], Complex x[], Complex xx[], Complex xs[], Complex y[], Complex yy[], Complex ys[], Complex yt[], double g[]); static void cchk2(const char sname[], double eps, double thresh, int trace, int rewi, int *fatal, Integer nidim, Integer idim[], Integer nkb, Integer kb[], Integer nalf, Complex alf[], Integer nbet, Complex bet[], Integer ninc, Integer inc[], Integer nmax, Integer incmax, Complex a[], Complex aa[], Complex as[], Complex x[], Complex xx[], Complex xs[], Complex y[], Complex yy[], Complex ys[], Complex yt[], double g[]); static void cchk3(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, Complex a[], Complex aa[], Complex as[], Complex x[], Complex xx[], Complex xs[], Complex xt[], double g[], Complex z[]); static void cchk4(const char sname[], double eps, double thresh, int trace, int rewi, int *fatal, Integer nidim, Integer idim[], Integer nalf, Complex alf[], Integer ninc, Integer inc[], Integer nmax, Integer incmax, Complex a[], Complex aa[], Complex as[], Complex x[], Complex xx[], Complex xs[], Complex y[], Complex yy[], Complex ys[], Complex yt[], double g[], Complex z[]); static void cchk5(const char sname[], double eps, double thresh, int trace, int rewi, int *fatal, Integer nidim, Integer idim[], Integer nalf, Complex alf[], Integer ninc, Integer inc[], Integer nmax, Integer incmax, Complex a[], Complex aa[], Complex as[], Complex x[], Complex xx[], Complex xs[], Complex y[], Complex yy[], Complex ys[], Complex yt[], double g[], Complex z[]); static void cchk6(const char sname[], double eps, double thresh, int trace, int rewi, int *fatal, Integer nidim, Integer idim[], Integer nalf, Complex alf[], Integer ninc, Integer inc[], Integer nmax, Integer incmax, Complex a[], Complex aa[], Complex as[], Complex x[], Complex xx[], Complex xs[], Complex y[], Complex yy[], Complex ys[], Complex yt[], double g[], Complex z[]); static void cchke(Integer isnum, const char srnamt[]); static void cmake(const char *type, char uplo, char diag, Integer m, Integer n, Complex *a, Integer nmax, Complex *aa, Integer tda, Integer kl, Integer ku, int *reset, Complex transl); static void cmvch(char trans, Integer m, Integer n, Complex alpha, Complex *a, Integer nmax, Complex *x, Integer incx, Complex beta, Complex *y, Integer incy, Complex *yt, double *g, Complex *yy, double eps, double *err, int *fatal, int mv); static int lce(Complex *ri, Complex *rj, Integer lr); static int lceres(const char *type, char uplo, Integer m, Integer n, Complex *aa, Complex *as, Integer tda); static void chkxer(const char srnamt[], Integer infot, int *lerr, int *ok); static Complex cbeg(int *reset); static void pack_vector (MatrixTriangle UpperLower, Integer n, Complex array_f[], Complex 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, Complex array_f[], Complex 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 */ struct { Integer infot, noutc; int ok, lerr; } infoc; #define nmax_2 NAMX *2 #define nmax_nmax NMAX * NMAX struct { char srnamt[14]; } srnamc; /* Table of constant values */ static Complex cmplx_0_0 = {0.0, 0.0}; static Complex cmplx_1_0 = {1.0, 0.0}; static Complex rogue = {-1.0e10, 1.0e10}; static Complex transpose_aa [nmax_nmax]; /* Test program for the COMPLEX Level 2 Blas. */ int main(void) { /* Initialized data */ static const char *snames[NSUBS] = {"f06sac/zgemv", "f06sbc/zgbmv", "f06scc/zhemv", "f06sdc/zhbmv", "f06sec/zhpmv", "f06sfc/ztrmv", "f06sgc/ztbmv", "f06shc/ztpmv", "f06sjc/ztrsv", "f06skc/ztbsv", "f06slc/ztpsv", "f06snc/zgerc", "f06smc/zgeru", "f06spc/zher", "f06sqc/zhpr", "f06src/zher2", "f06ssc/zhpr2" }; /* Local variables */ static Integer idim[NIDMAX]; int same; Integer ninc, nbet, nalf; int rewi; static Complex a[NMAX*NMAX]; static double g[NMAX]; Integer i, j; Integer n; int fatal; static Complex x[NMAX], y[NMAX], z[2*NMAX]; int trace; Integer nidim; char trans; Integer isnum; static int ltest[NSUBS]; static Complex aa[NMAX*NMAX]; static Integer kb[NKBMAX]; static Complex as[NMAX*NMAX]; int sfatal; static Complex xs[NMAX*INCMAX], ys[NMAX*INCMAX], yt[NMAX], xx[NMAX*INCMAX], yy[NMAX*INCMAX]; static char snamet[7]; double thresh; int ltestt, tsterr; static Complex alf[NALMAX]; static Integer inc[NINMAX], nkb; static Complex bet[NBEMAX]; double eps, err; Vprintf("f06sbc 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 , %lf ) ", &alf[i-1].re, &alf[i-1].im); 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 L420; } for (i = 1; i <= nbet; ++i) Vscanf(" ( %lf , %lf ) ", &bet[i-1].re, &bet[i-1].im); Vscanf("%*[^\n] "); /* Report values of parameters. */ Vprintf("Tests of the complex 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, %6.1f)%c", alf[i-1].re, alf[i-1].im, (! i%7 || i==nalf) ? '\n' : ' '); } Vprintf(" For beta "); for (i = 1; i <= nbet; ++i) { Vprintf("(%6.1f, %6.1f)%c", bet[i-1].re, bet[i-1].im, (! 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 CMVCH 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] = a02bac((double) MAX(i-j+1,0), 0.0); x[j-1] = a02bac((double) j, 0.0); y[j-1] = cmplx_0_0; } for (j = 1; j <= n; ++j) yy[ j-1] = a02bac((double)(j*((j+1)*j)/2-(j+1)*j*(j-1)/3), 0.0); /* YY holds the exact result. On exit from CMVCH YT holds */ /* the result computed by CMVCH. */ trans = 'n'; cmvch(trans, n, n, cmplx_1_0, a, (Integer)NMAX, x, (Integer)1, cmplx_0_0, y, (Integer)1, yt, g, yy, eps, &err, &fatal, 1); same = lce(yy, yt, n); if (! same || err != 0.0) { Vprintf("Error in cmvch - in-line dot products are being " "evaluated wrongly.\ncmvch 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'; cmvch(trans, n, n, cmplx_1_0, a, (Integer)NMAX, x, (Integer)-1, cmplx_0_0, y, (Integer)-1, yt, g, yy, eps, &err, &fatal, 1); same = lce(yy, yt, n); if (! same || err != 0.0) { Vprintf("Error in cmvch - in-line dot products are being " "evaluated wrongly.\ncmvch 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]) { /* Function is not to be tested. */ Vprintf("%6s was not tested\n", snames[isnum - 1]); } else { (void)strcpy(srnamc.srnamt, snames[isnum - 1]); /* Test error exits. */ if (tsterr) { Vprintf("\n"); cchke(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 L300; case 14: goto L320; case 15: goto L320; case 16: goto L340; case 17: goto L340; } /* Test f06sac, 01, and f06sbc, 02. */ L240: cchk1(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 f06scc, 03, f06sdc, 04, and f06sec, 05. */ L260: cchk2(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 f06sfc, 06, f06sgc, 07, f06shc, 08, */ /* f06sjc, 09, f06skc, 10, and f06slc, 11. */ L280: cchk3(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 f06snc, 12, f06smc, 13. */ L300: cchk4(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 f06spc, 14, and f06sqc, 15. */ L320: cchk5(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 f06src, 16, and f06ssc, 17. */ L340: cchk6(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 cchk1(const char sname[], double eps, double thresh, int trace, int rewi, int *fatal, Integer nidim, Integer idim[], Integer nkb, Integer kb[], Integer nalf, Complex alf[], Integer nbet, Complex bet[], Integer ninc, Integer inc[], Integer nmax, Integer incmax, Complex a[], Complex aa[], Complex as[], Complex x[], Complex xx[], Complex xs[], Complex y[], Complex yy[], Complex ys[], Complex yt[], double g[]) { /* Initialized data */ static char ich[3+1] = "ntc"; /* Local variables */ Complex beta; Integer tdas; int same; Integer incx, incy; int full, tran, null; Integer i, j, k, m, n; Complex 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; Complex transl; Integer laa, tda; Complex als, bls; double err; Integer iku, kls, kus; MatrixTranspose trans_c, transs_c; /* Tests f06sac and f06sbc. */ /* Auxiliary routine for test program for Level 2 Blas. */ /* Parameter adjustments */ #define YS(I) ys[(I)-1] #define YY(I) yy[(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'; /* Define the number of arguments. */ if (full) nargs = 11; else nargs = 13; if (trace) { Vprintf("\nComputational tests : \n"); if (full) Vprintf("\nf06sac tested with : \n"); if (banded) Vprintf("\nf06sbc tested with : \n"); Vprintf("(Transpose (t),.........)\n"); Vprintf("(ConjugateTranspose (c),.........)\n"); Vprintf("(Notranspose (n),.........)\n\n"); } 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 tda to 1 more than minimum value if room. */ if (banded) tda = kl + ku + 1; else tda = m; if (tda < nmax) ++tda; tda = nmax; /* George Levy */ /* Skip tests if not enough room. */ if (tda > nmax) goto L200; laa = tda * n; null = n <= 0 || m <= 0; /* Generate the matrix A. */ transl = cmplx_0_0; cmake(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(trans == 't') trans_c = Transpose; else if(trans == 'n') trans_c = NoTranspose; else trans_c = ConjugateTranspose; if (tran) { ml = n; nl = m; } else { ml = m; nl = n; } for (ix = 1; ix <= ninc; ++ix) { incx = INC(ix); lx = ABS(incx) * nl; /* Generate the vector X. */ transl = a02bac(0.5, 0.0); cmake("ge", ' ', ' ', (Integer)1, nl, x, (Integer)1, xx, ABS(incx), (Integer)0, nl - 1, &reset, transl); if (nl > 1) { X(nl / 2) = cmplx_0_0; XX(ABS(incx)*(nl/2-1)+1) = cmplx_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 = cmplx_0_0; cmake("ge", ' ', ' ', (Integer)1, ml, y, (Integer)1, yy, ABS(incy), (Integer)0, ml-1, &reset, transl) ; ++nc; /* * Save every datum before calling the * function. */ 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 function. */ if (full) { if (trace) { Vprintf("%6ld: %6s(%c,%3ld,%3ld," " (%4.1f,%4.1f), A,%3ld, X,%2ld, (%4.1f,%4.1f), Y,%2ld).\n", nc, sname, trans, m, n, alpha.re, alpha.im, tda, incx, beta.re, beta.im, incy); } for (j =0; j < n; ++j) { for (i = 0; i < m; ++i) { transpose_aa[i * tda + j] = aa[i + j * tda]; } } f06sac(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[i + j * tda] = transpose_aa[i * tda + j]; } } else if (banded) { if (trace) { Vprintf("%4ld: %6s(%c,%3ld,%3ld," "%3ld,%3ld, (%4.1f,%4.1f), A,%3ld, X,%2ld, (%4.1f, %4.1f), Y,%2ld).\n", nc, sname, trans, m, n, kl, ku, alpha.re, alpha.im, tda, incx, beta.re, beta.im, incy); } /* set transpose_aa to rogue values */ for (i=0; i < nmax_nmax - 1; ++i) transpose_aa[i] = rogue; /* 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)]; } f06sbc(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 functions. */ isame[0] = trans_c == transs_c; isame[1] = ms == m; isame[2] = ns == n; if (full) { isame[3] = als.re == alpha.re && als.im == alpha.im; isame[4] = lce(as, aa, laa); isame[5] = tdas == tda; isame[6] = lce(xs, xx, lx); isame[7] = incxs == incx; isame[8] = bls.re == beta.re && bls.im == beta.im; if (null) { isame[9] = lce(ys, yy, ly); } else { isame[9] = lceres("ge", ' ', (Integer)1, ml, ys, yy, ABS(incy)); } isame[10] = incys == incy; } else if (banded) { isame[3] = kls == kl; isame[4] = kus == ku; isame[5] = als.re == alpha.re && als.im == alpha.im; isame[6] = lce(as, aa, laa); isame[7] = tdas == tda; isame[8] = lce(xs, xx, lx); isame[9] = incxs == incx; isame[10] = bls.re == beta.re && bls.im == beta.im; if (null) { isame[11] = lce(ys, yy, ly); } else { isame[11] = lceres("ge", ' ', (Integer)1, ml, ys, yy, 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. */ cmvch(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.le.0 or N.le.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,%4.1f), A,%3ld, X,%2ld, (%4.1f,%4.1f), Y,%2ld).\n", nc, sname, trans, m, n, alpha.re, alpha.im, tda, incx, beta.re, beta.im, incy); } else if (banded) { Vprintf("%4ld: %6s(%c,%3ld,%3ld," "%3ld,%3ld, (%4.1f,%4.1f), A,%3ld, X,%2ld, (%4.1f, %4.1f), Y,%2ld).\n", nc, sname, trans, m, n, kl, ku, alpha.re, alpha.im, tda, incx, beta.re, beta.im, incy); } L280: ; } /* cchk1 */ /* --------------------------------------------------------------------- */ static void cchk2(const char sname[], double eps, double thresh, int trace, int rewi, int *fatal, Integer nidim, Integer idim[], Integer nkb, Integer kb[], Integer nalf, Complex alf[], Integer nbet, Complex bet[], Integer ninc, Integer inc[], Integer nmax, Integer incmax, Complex a[], Complex aa[], Complex as[], Complex x[], Complex xx[], Complex xs[], Complex y[], Complex yy[], Complex ys[], Complex yt[], double g[]) { /* Initialized data */ static char ich[3] = "ul"; /* System generated locals */ Integer a_dim1, a_offset; /* Local variables */ Complex beta; Integer tdas; int same; Integer incx, incy; int full, null; char uplo; Integer i, j, k, m, n; Complex 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; Complex transl; Integer laa, tda; Complex als, bls; double err; MatrixTriangle uplo_c, uplos_c; /* Tests f06scc, f06sdc and f06sec. */ /* 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 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] a_dim1 = nmax; a_offset = a_dim1 + 1; a -= a_offset; #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'; 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("\nf06scc tested with : \n"); if (banded) Vprintf("\nf06sdc tested with : \n"); if (packed) Vprintf("\nf06sec 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; /* 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 = cmplx_0_0; cmake(sname + 8, uplo, ' ', n, n, &a[a_offset], 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 = a02bac(0.5, 0.0); cmake("ge", ' ', ' ', (Integer)1, n, x, (Integer)1, xx, ABS(incx), (Integer)0, n - 1, &reset, transl); if (n > 1) { X(n/2) = cmplx_0_0; XX(ABS(incx)*(n/2-1)+1) = cmplx_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 = cmplx_0_0; cmake("ge", ' ', ' ', (Integer)1, n, y, (Integer)1, yy, ABS(incy), (Integer)0, n-1, &reset, transl); ++nc; /* Save every datum before calling the function. */ 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 function. */ if (full) { if (trace) { Vprintf("%6ld: %6s(%c,%3ld," " (%4.1f,%4.1f), A,%3ld, X,%2ld, (%4.1f, %4.1f), Y,%2ld).\n", nc, sname, uplo, n,alpha.re, alpha.im, tda, incx, beta.re, beta.im, incy); } for (j =0; j < n; ++j) { for (i = 0; i < n; ++i) transpose_aa[i * tda + j] = aa[i + j * tda]; } f06scc(uplo_c, n, alpha, transpose_aa, tda, xx, incx, beta, yy, incy); } else if (banded) { if (trace) { Vprintf("%6ld: %6s(%c,%3ld,%3ld," " (%4.1f,%4.1f), A,%3ld, X,%2ld, (%4.1f,%4.1f), Y,%2ld).\n", nc,sname,uplo,n,k,alpha.re, alpha.im, tda,incx,beta.re,beta.im,incy); } /* set transpose_aa to rogue values */ for (i=0; i < nmax_nmax - 1; ++i) transpose_aa[i] = rogue; /* 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)+a_offset]; } } 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)+a_offset]; } } f06sdc(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,%4.1f), AP, X,%2ld,(%4.1f,%4.1f), Y,%2ld).\n", nc,sname,uplo,n, alpha.re, alpha.im, incx, beta.re,beta.im,incy); } pack_vector (uplo_c, n, aa, transpose_aa); f06sec(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"); goto L240; } /* See what data changed inside functions. */ isame[0] = uplo_c == uplos_c; isame[1] = ns == n; if (full) { isame[2] = als.re == alpha.re && als.im == alpha.im; isame[3] = lce(as, aa, laa); isame[4] = tdas == tda; isame[5] = lce(xs, xx, lx); isame[6] = incxs == incx; isame[7] = bls.re == beta.re && bls.im == beta.im; if (null) isame[8] = lce(ys, yy, ly); else { isame[8] = lceres("ge", ' ', (Integer)1, n, ys, yy, ABS(incy)); } isame[9] = incys == incy; } else if (banded) { isame[2] = ks == k; isame[3] = als.re == alpha.re && als.im == alpha.im; isame[4] = lce(as, aa, laa); isame[5] = tdas == tda; isame[6] = lce(xs, xx, lx); isame[7] = incxs == incx; isame[8] = bls.re == beta.re && bls.im == beta.im; if (null) isame[9] = lce(ys, yy, ly); else { isame[9] = lceres("ge", ' ', (Integer)1, n, ys, yy, ABS(incy)); } isame[10] = incys == incy; } else if (packed) { isame[2] = als.re == alpha.re && als.im == alpha.im; isame[3] = lce(as, aa, laa); isame[4] = lce(xs, xx, lx); isame[5] = incxs == incx; isame[6] = bls.re == beta.re && bls.im == beta.im; if (null) isame[7] = lce(ys, yy, ly); else { isame[7] = lceres("ge", ' ', (Integer)1, n, ys, yy, 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. */ cmvch('n', n, n, alpha, &a[a_offset], 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 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,%4.1f), A,%3ld, X,%2ld, (%4.1f, %4.1f), Y,%2ld).\n", nc, sname, uplo, n,alpha.re, alpha.im, tda, incx, beta.re, beta.im, incy); } else if (banded) { Vprintf("%6ld: %6s(%c,%3ld,%3ld," " (%4.1f,%4.1f), A,%3ld, X,%2ld, (%4.1f,%4.1f), Y,%2ld).\n", nc,sname,uplo,n,k,alpha.re, alpha.im, tda,incx,beta.re,beta.im,incy); } else if (packed) { Vprintf("%6ld: %6s(%c,%3ld," " (%4.1f,%4.1f), AP, X,%2ld,(%4.1f,%4.1f), Y,%2ld).\n", nc,sname,uplo,n, alpha.re, alpha.im, incx, beta.re,beta.im,incy); } L260: ; } /* cchk2 */ /* --------------------------------------------------------------------- */ static void cchk3(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, Complex a[], Complex aa[], Complex as[], Complex x[], Complex xx[], Complex xs[], Complex xt[], double g[], Complex 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; int isame[13]; Integer nargs; int reset; Integer incxs; char trans; int banded; Integer nc, ik, in; int packed; Integer nk, ks, ix, ns, lx; double errmax; Complex transl; Integer laa, icd, tda; Integer ict, icu; double err; MatrixTranspose trans_c, transs_c; MatrixTriangle uplo_c, uplos_c; MatrixUnitTriangular diag_c, diags_c; /* Tests f06sfc, f06sgc, f06shc, f06sjc, f06skc and f06slc. */ /* Auxiliary routine for test program for Level 2 Blas. */ /* 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, "mv")) { if (full) Vprintf("\nf06sfc tested with : \n"); if (banded) Vprintf("\nf06sgc tested with : \n"); if (packed) Vprintf("\nf06shc tested with : \n"); } else { if (full) Vprintf("\nf06sjc tested with : \n"); if (banded) Vprintf("\nf06skc tested with : \n"); if (packed) Vprintf("\nf06slc 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 CMVCH. */ for (i = 1; i <= nmax; ++i) Z(i) = cmplx_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; tda = nmax; if (tda < nmax) ++tda; /* 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 = cmplx_0_0; cmake(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 = a02bac(0.5, 0.0); cmake("ge", ' ', ' ', (Integer)1, n, x, (Integer)1, xx, ABS(incx), (Integer)0, n-1, &reset, transl); if (n > 1) { X(n/2) = cmplx_0_0; XX(ABS(incx)*(n/2-1)+1) = cmplx_0_0; } ++nc; /* Save every datum before calling the function. */ uplos_c = uplo_c; transs_c = trans_c; diags_c = diag_c; 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 function. */ 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[i + j * tda]; } f06sfc(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[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] = rogue; /* 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)]; } } f06sgc(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); f06shc(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[i + j * tda]; } f06sjc(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[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] = rogue; /* 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)]; } } f06skc(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); f06slc(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 inside functions. */ isame[0] = uplo_c == uplos_c; isame[1] = trans_c == transs_c; isame[2] = diag_c == diags_c; isame[3] = ns == n; if (full) { isame[4] = lce(as, aa, laa); isame[5] = tdas == tda; if (null) isame[6] = lce(xs, xx, lx); else { isame[6] = lceres("ge", ' ', (Integer)1, n, xs, xx, ABS(incx)); } isame[7] = incxs == incx; } else if (banded) { isame[4] = ks == k; isame[5] = lce(as, aa, laa); isame[6] = tdas == tda; if (null) isame[7] = lce(xs, xx, lx); else { isame[7] = lceres("ge", ' ', (Integer)1, n, xs, xx, ABS(incx)); } isame[8] = incxs == incx; } else if (packed) { isame[4] = lce(as, aa, laa); if (null) isame[5] = lce(xs, xx, lx); else { isame[5] = lceres("ge", ' ', (Integer)1, n, xs, xx, ABS(incx)); } isame[6] = incxs == incx; } /* * 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) { if (strstr(sname, "mv")) { /* Check the result. */ cmvch(trans, n, n, cmplx_1_0, a, nmax, x, incx, cmplx_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); } cmvch(trans, n, n, cmplx_1_0, a, nmax, z, incx, cmplx_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 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: ; } /* cchk3 */ /* --------------------------------------------------------------------- */ static void cchk4(const char sname[], double eps, double thresh, int trace, int rewi, int *fatal, Integer nidim, Integer idim[], Integer nalf, Complex alf[], Integer ninc, Integer inc[], Integer nmax, Integer incmax, Complex a[], Complex aa[], Complex as[], Complex x[], Complex xx[], Complex xs[], Complex y[], Complex yy[], Complex ys[], Complex yt[], double g[], Complex z[]) { /* Local variables */ Integer tdas; int same, conj; Integer incx, incy; int null; Integer i, j, m, n; Complex 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; Complex transl; Integer laa, tda; Complex als; double err; /* Tests f06snc and F06SMC. */ /* Auxiliary routine for test program for Level 2 Blas. */ /* 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 */ conj = sname[11] == 'c'; /* Define the number of arguments. */ 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; /* 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 = a02bac(0.5, 0.0); cmake("ge", ' ', ' ', (Integer)1, m, x, (Integer)1, xx, ABS(incx), (Integer)0, m-1, &reset, transl); if (m > 1) { X(m/2) = cmplx_0_0; XX(ABS(incx)*(m/2-1)+1) = cmplx_0_0; } for (iy = 1; iy <= ninc; ++iy) { incy = INC(iy); ly = ABS(incy) * n; /* Generate the vector Y. */ transl = cmplx_0_0; cmake("ge", ' ', ' ', (Integer)1, n, y, (Integer)1, yy, ABS(incy), (Integer)0, n-1, &reset, transl); if (n > 1) { Y(n/2) = cmplx_0_0; YY(ABS(incy)*(n/2-1)+1) = cmplx_0_0; } for (ia = 1; ia <= nalf; ++ia) { alpha = ALF(ia); /* Generate the matrix A. */ transl = cmplx_0_0; cmake(sname + 8, ' ', ' ', m, n, a, nmax, aa, tda, m-1, n-1, &reset, transl); ++nc; /* Save every datum before calling the function. */ 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 function. */ if (trace) { Vprintf("%6ld: %6s(%3ld,%3ld," " (%4.1f,%4.1f), X,%2ld, Y,%2ld, A, %3ld).\n", nc,sname,m,n,alpha.re,alpha.im, incx,incy,tda); } for (j =0; j < n; ++j) { for (i = 0; i < m; ++i) transpose_aa[i * tda + j] = aa[i + j * tda]; } if (conj) { f06snc(m, n, alpha, xx, incx, yy, incy, transpose_aa, tda); } else { f06smc(m, n, alpha, xx, incx, yy, incy, transpose_aa, tda); } for (j =0; j < n; ++j) { for (i = 0; i < m; ++i) aa[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.re == alpha.re && als.im == alpha.im; isame[3] = lce(xs, xx, lx); isame[4] = incxs == incx; isame[5] = lce(ys, yy, ly); isame[6] = incys == incy; if (null) isame[7] = lce(as, aa, laa); else isame[7] = lceres("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); w[0].im = Y(n-j+1).im; } if (conj) w[0] = a02cfc(w[0]); cmvch('n', m, (Integer)1, alpha, z, nmax, w, (Integer)1, cmplx_1_0, &a[(j-1)*nmax], (Integer)1, yt, g, &aa[(j - 1)*tda], eps, &err, fatal, 1); errmax = MAX(errmax,err); /* If got really bad answer, report and return. */ if (*fatal) goto L260; } } else 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,%4.1f), X,%2ld, Y,%2ld, A, %3ld).\n", nc,sname,m,n,alpha.re,alpha.im, incx,incy,tda); L300: ; } /* cchk4 */ /* --------------------------------------------------------------------- */ static void cchk5(const char sname[], double eps, double thresh, int trace, int rewi, int *fatal, Integer nidim, Integer idim[], Integer nalf, Complex alf[], Integer ninc, Integer inc[], Integer nmax, Integer incmax, Complex a[], Complex aa[], Complex as[], Complex x[], Complex xx[], Complex xs[], Complex y[], Complex yy[], Complex ys[], Complex yt[], double g[], Complex z[]) { /* Initialized data */ static char ich[2+1] = "ul"; /* Local variables */ Integer tdas; int same; Integer incx; int full, null; char uplo; Integer i, j, n; Complex 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 ralpha, rals; double errmax; Complex transl; Integer laa, tda; double err; MatrixTriangle uplo_c, uplos_c; /* Tests f06spc and f06sqc. */ /* Auxiliary routine for test program for Level 2 Blas. */ /* 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] == 'e'; packed = sname[9] == 'p'; /* Define the number of arguments. */ if (full) nargs = 7; else nargs = 6; if (trace) { Vprintf("\nComputational tests : \n"); if (full) Vprintf("\nf06spc tested with : \n"); if (packed) Vprintf("\nf06sqc 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 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 = a02bac(0.5, 0.0); cmake("ge", ' ', ' ', (Integer)1, n, x, (Integer)1, xx, ABS(incx), (Integer)0, n-1, &reset, transl); if (n > 1) { X(n/2) = cmplx_0_0; XX(ABS(incx)*(n/2-1)+1) = cmplx_0_0; } for (ia = 1; ia <= nalf; ++ia) { ralpha = a02bbc(ALF(ia)); alpha = a02bac(ralpha, RZERO); null = (n <= 0 || ralpha == RZERO); /* Generate the matrix A. */ transl = cmplx_0_0; cmake(sname + 8, uplo, ' ', n, n, a, nmax, aa, tda, n-1, n-1, &reset, transl); ++nc; /* Save every datum before calling the function. */ uplos_c = uplo_c; ns = n; rals = ralpha; 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 function. */ if (full) { if (trace) { Vprintf("%6ld: %6s(%c,%3ld," "%4.1f, X,%2ld, A,%3ld).\n", nc,sname,uplo,n,ralpha,incx,tda); } for (j =0; j < n; ++j) { for (i = 0; i < n; ++i) transpose_aa[i * tda + j] = aa[i + j * tda]; } f06spc(uplo_c, n, ralpha, xx, incx, transpose_aa, tda); for (j =0; j < n; ++j) { for (i = 0; i < n; ++i) aa[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,ralpha,incx); } pack_vector (uplo_c, n, aa, transpose_aa); f06sqc(uplo_c, n, ralpha, 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"); goto L240; } /* See what data changed inside functions. */ isame[0] = uplo_c == uplos_c; isame[1] = ns == n; isame[2] = (rals == ralpha); isame[3] = lce(xs, xx, lx); isame[4] = incxs == incx; if (null) isame[5] = lce(as, aa, laa); else isame[5] = lceres(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] = a02cfc(Z(j)); if (upper) { jj = 1; lj = j; } else { jj = j; lj = n - j + 1; } cmvch('n', lj, (Integer)1, alpha, &Z(jj), lj, w, (Integer)1, cmplx_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 { 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,ralpha,incx,tda); } else if (packed) { Vprintf("%6ld: %6s(%c,%3ld," "%4.1f, X,%2ld, AP).\n", nc,sname,uplo,n,ralpha,incx); } L260: ; } /* cchk5 */ /* --------------------------------------------------------------------- */ static void cchk6(const char sname[], double eps, double thresh, int trace, int rewi, int *fatal, Integer nidim, Integer idim[], Integer nalf, Complex alf[], Integer ninc, Integer inc[], Integer nmax, Integer incmax, Complex a[], Complex aa[], Complex as[], Complex x[], Complex xx[], Complex xs[], Complex y[], Complex yy[], Complex ys[], Complex yt[], double g[], Complex 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; Complex 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; Complex transl; Integer laa, tda; Complex als; double err; MatrixTriangle uplo_c, uplos_c; /* Tests f06src and f06ssc. */ /* 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 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] == 'e'; packed = sname[9] == 'p'; /* Define the number of arguments. */ if (full) nargs = 9; else nargs = 8; if (trace) { Vprintf("\nComputational tests : \n"); if (full) Vprintf("\nf06src tested with : \n"); if (packed) Vprintf("\nf06ssc 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; tda = nmax; if (tda < nmax) ++tda; /* 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 = a02bac(0.5, 0.0); cmake("ge", ' ', ' ', (Integer)1, n, x, (Integer)1, xx, ABS(incx), (Integer)0, n-1, &reset, transl); if (n > 1) { X(n/2) = cmplx_0_0; XX(ABS(incx)*(n/2-1)+1) = cmplx_0_0; } for (iy = 1; iy <= ninc; ++iy) { incy = INC(iy); ly = ABS(incy) * n; /* Generate the vector Y. */ transl = cmplx_0_0; cmake("ge", ' ', ' ', (Integer)1, n, y, (Integer)1, yy, ABS(incy), (Integer)0, n-1, &reset, transl); if (n > 1) { Y(n/2) = cmplx_0_0; YY(ABS(incy)*(n/2-1)+1) = cmplx_0_0; } for (ia = 1; ia <= nalf; ++ia) { alpha = ALF(ia); null = n <= 0 || (alpha.re == 0.0 && alpha.im == 0.0); /* Generate the matrix A. */ transl = cmplx_0_0; cmake(sname + 8, uplo, ' ', n, n, a, nmax, aa, tda, n - 1, n - 1, &reset, transl); ++nc; /* Save every datum before calling the function. */ 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 function. */ if (full) { if (trace) { Vprintf("%6ld: %6s(%c,%3ld," " (%4.1f,%4.1f), X,%2ld, Y,%2ld, A, %3ld).\n", nc,sname,uplo,n,alpha.re,alpha.im, incx,incy,tda); } for (j =0; j < n; ++j) { for (i = 0; i < n; ++i) { transpose_aa[i * tda + j] = aa[i + j * tda]; } } f06src(uplo_c, n, alpha, xx, incx, yy, incy, transpose_aa, tda); for (j =0; j < n; ++j) { for (i = 0; i < n; ++i) { aa[i + j * tda] = transpose_aa[i * tda + j]; } } } else if (packed) { if (trace) { Vprintf("%6ld: %6s(%c,%3ld," " (%4.1f,%4.1f), X,%2ld, Y,%2ld, AP).\n", nc,sname,uplo,n,alpha.re,alpha.im, incx,incy); } pack_vector (uplo_c, n, aa, transpose_aa); f06ssc(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 functions. */ isame[0] = uplo_c == uplos_c; isame[1] = ns == n; isame[2] = als.re == alpha.re && als.im == alpha.im; isame[3] = lce(xs, xx, lx); isame[4] = incxs == incx; isame[5] = lce(ys, yy, ly); isame[6] = incys == incy; if (null) isame[7] = lce(as, aa, laa); else isame[7] = lceres(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] = a02ccc(alpha, a02cfc(z[j+nmax-1])); w[1] = a02ccc(a02cfc(alpha), a02cfc(z[j-1])); if (upper) { jj = 1; lj = j; } else { jj = j; lj = n - j + 1; } cmvch('n', lj, (Integer)2, cmplx_1_0, &z[jj-1], nmax, w, (Integer)1, cmplx_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 { 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,%4.1f), X,%2ld, Y,%2ld, A, %3ld).\n", nc,sname,uplo,n,alpha.re,alpha.im, incx,incy,tda); } else if (packed) { Vprintf("%6ld: %6s(%c,%3ld," " (%4.1f,%4.1f), X,%2ld, Y,%2ld, AP).\n", nc,sname,uplo,n,alpha.re,alpha.im, incx,incy); } L340: ; } /* cchk6 */ /* --------------------------------------------------------------------- */ static void cchke(Integer isnum, const char srnamt[]) { /* Local variables */ double ralpha = 0; Integer zero = 0; Integer one = 1; Integer m_one = -1; Integer two = 2; Complex beta={0.0,0.0}, a[1] /* was [1][1] */, alpha = {0.0,0.0}; Complex 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; case 17: goto L340; } L20: infoc.infot = 1; f06sac((MatrixTranspose)999, zero, zero, alpha, a, one, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06sac(NoTranspose, m_one, zero, alpha, a, one, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06sac(NoTranspose, zero, m_one, alpha, a, one, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 6; f06sac(NoTranspose, zero, two, alpha, a, one, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 8; f06sac(NoTranspose, zero, zero, alpha, a, one, x, zero, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 11; f06sac(NoTranspose, zero, zero, alpha, a, one, x, one, beta, y, zero); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L360; L40: infoc.infot = 1; f06sbc((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; f06sbc(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; f06sbc(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; f06sbc(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; f06sbc(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; f06sbc(NoTranspose, zero, zero, one, zero, alpha, a, one, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 10; f06sbc(NoTranspose, zero, zero, zero, zero, alpha, a, one, x, zero, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 13; f06sbc(NoTranspose, zero, zero, zero, zero, alpha, a, one, x, one, beta, y, zero); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L360; L60: infoc.infot = 1; f06scc((MatrixTriangle)999, zero, alpha, a, one, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06scc(UpperTriangle, m_one, alpha, a, one, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06scc(UpperTriangle, two, alpha, a, one, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06scc(UpperTriangle, zero, alpha, a, one, x, zero, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 10; f06scc(UpperTriangle, zero, alpha, a, one, x, one, beta, y, zero); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L360; L80: infoc.infot = 1; f06sdc((MatrixTriangle)999, zero, zero, alpha, a, one, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06sdc(UpperTriangle, m_one, zero, alpha, a, one, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06sdc(UpperTriangle, zero, m_one, alpha, a, one, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 6; f06sdc(UpperTriangle, zero, one, alpha, a, one, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 8; f06sdc(UpperTriangle, zero, zero, alpha, a, one, x, zero, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 11; f06sdc(UpperTriangle, zero, zero, alpha, a, one, x, one, beta, y, zero); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L360; L100: infoc.infot = 1; f06sec((MatrixTriangle)999, zero, alpha, a, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06sec(UpperTriangle, m_one, alpha, a, x, one, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 6; f06sec(UpperTriangle, zero, alpha, a, x, zero, beta, y, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06sec(UpperTriangle, zero, alpha, a, x, one, beta, y, zero); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L360; L120: infoc.infot = 1; f06sfc((MatrixTriangle)999, NoTranspose, NotUnitTriangular, zero, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06sfc(UpperTriangle, (MatrixTranspose)999, NotUnitTriangular, zero, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06sfc(UpperTriangle, NoTranspose, (MatrixUnitTriangular)999, zero, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06sfc(UpperTriangle, NoTranspose, NotUnitTriangular, m_one, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 6; f06sfc(UpperTriangle, NoTranspose, NotUnitTriangular, two, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 8; f06sfc(UpperTriangle, NoTranspose, NotUnitTriangular, zero, a, one, x, zero); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L360; L140: infoc.infot = 1; f06sgc((MatrixTriangle)999, NoTranspose, NotUnitTriangular, zero, zero, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06sgc(UpperTriangle, (MatrixTranspose)999, NotUnitTriangular, zero, zero, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06sgc(UpperTriangle, NoTranspose, (MatrixUnitTriangular)999, zero, zero, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06sgc(UpperTriangle, NoTranspose, NotUnitTriangular, m_one, zero, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06sgc(UpperTriangle, NoTranspose, NotUnitTriangular, zero, m_one, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06sgc(UpperTriangle, NoTranspose, NotUnitTriangular, zero, one, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06sgc(UpperTriangle, NoTranspose, NotUnitTriangular, zero, zero, a, one, x, zero); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L360; L160: infoc.infot = 1; f06shc((MatrixTriangle)999, NoTranspose, NotUnitTriangular, zero, a, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06shc(UpperTriangle, (MatrixTranspose)999, NotUnitTriangular, zero, a, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06shc(UpperTriangle, NoTranspose, (MatrixUnitTriangular)999, zero, a, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06shc(UpperTriangle, NoTranspose, NotUnitTriangular, m_one, a, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06shc(UpperTriangle, NoTranspose, NotUnitTriangular, zero, a, x, zero); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L360; L180: infoc.infot = 1; f06sjc((MatrixTriangle)999, NoTranspose, NotUnitTriangular, zero, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06sjc(UpperTriangle, (MatrixTranspose)999, NotUnitTriangular, zero, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06sjc(UpperTriangle, NoTranspose, (MatrixUnitTriangular)999, zero, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06sjc(UpperTriangle, NoTranspose, NotUnitTriangular, m_one, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 6; f06sjc(UpperTriangle, NoTranspose, NotUnitTriangular, two, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 8; f06sjc(UpperTriangle, NoTranspose, NotUnitTriangular, zero, a, one, x, zero); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L360; L200: infoc.infot = 1; f06skc((MatrixTriangle)999, NoTranspose, NotUnitTriangular, zero, zero, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06skc(UpperTriangle, (MatrixTranspose)999, NotUnitTriangular, zero, zero, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06skc(UpperTriangle, NoTranspose, (MatrixUnitTriangular)999, zero, zero, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06skc(UpperTriangle, NoTranspose, NotUnitTriangular, m_one, zero, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06skc(UpperTriangle, NoTranspose, NotUnitTriangular, zero, m_one, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06skc(UpperTriangle, NoTranspose, NotUnitTriangular, zero, one, a, one, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06skc(UpperTriangle, NoTranspose, NotUnitTriangular, zero, zero, a, one, x, zero); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L360; L220: infoc.infot = 1; f06slc((MatrixTriangle)999, NoTranspose, NotUnitTriangular, zero, a, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06slc(UpperTriangle, (MatrixTranspose)999, NotUnitTriangular, zero, a, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 3; f06slc(UpperTriangle, NoTranspose, (MatrixUnitTriangular)999, zero, a, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 4; f06slc(UpperTriangle, NoTranspose, NotUnitTriangular, m_one, a, x, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06slc(UpperTriangle, NoTranspose, NotUnitTriangular, zero, a, x, zero); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L360; L240: infoc.infot = 1; f06snc(m_one, zero, alpha, x, one, y, one, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06snc(zero, m_one, alpha, x, one, y, one, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06snc(zero, zero, alpha, x, zero, y, one, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06snc(zero, zero, alpha, x, one, y, zero, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06snc(zero, two, alpha, x, one, y, one, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L360; L260: infoc.infot = 1; f06smc(m_one, zero, alpha, x, one, y, one, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06smc(zero, m_one, alpha, x, one, y, one, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06smc(zero, zero, alpha, x, zero, y, one, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06smc(zero, zero, alpha, x, one, y, zero, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06smc(zero, two, alpha, x, one, y, one, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L360; L280: infoc.infot = 1; f06spc((MatrixTriangle)999, zero, ralpha, x, one, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06spc(UpperTriangle, m_one, ralpha, x, one, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06spc(UpperTriangle, zero, ralpha, x, zero, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06spc(UpperTriangle, two, ralpha, x, one, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L360; L300: infoc.infot = 1; f06sqc((MatrixTriangle)999, zero, ralpha, x, one, a); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06sqc(UpperTriangle, m_one, ralpha, x, one, a); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06sqc(UpperTriangle, zero, ralpha, x, zero, a); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L360; L320: infoc.infot = 1; f06src((MatrixTriangle)999, zero, alpha, x, one, y, one, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06src(UpperTriangle, m_one, alpha, x, one, y, one, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06src(UpperTriangle, zero, alpha, x, zero, y, one, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06src(UpperTriangle, zero, alpha, x, one, y, zero, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 9; f06src(UpperTriangle, two, alpha, x, one, y, one, a, one); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); goto L360; L340: infoc.infot = 1; f06ssc((MatrixTriangle)999, zero, alpha, x, one, y, one, a); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 2; f06ssc(UpperTriangle, m_one, alpha, x, one, y, one, a); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 5; f06ssc(UpperTriangle, zero, alpha, x, zero, y, one, a); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); infoc.infot = 7; f06ssc(UpperTriangle, zero, alpha, x, one, y, zero, a); chkxer(srnamt, infoc.infot, &infoc.lerr, &infoc.ok); L360: if (infoc.ok) Vprintf("%.6s passed the tests of error-exits\n", srnamt); else Vprintf(" ******* %.6s failed the tests of error-exits *******\n", srnamt); } /* cchke */ /* --------------------------------------------------------------------- */ static void cmake(const char *type, char uplo, char diag, Integer m, Integer n, Complex *a, Integer nmax, Complex *aa, Integer tda, Integer kl, Integer ku, int *reset, Complex transl) { double rrogue = -1.0e10; /* Local variables */ Integer ibeg, iend, ioff; int unit; Integer i, j; int lower; Integer i1, i2, i3; int upper; Integer jj, 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', 'he', 'hb', 'hp', 'tr', 'tb' or 'tp'. * Auxiliary routine for test program for Level 2 Blas. */ /* Parameter adjustments */ #define AA(I) aa[(I)-1] /* Function Body */ gen = *type == 'g'; sym = *type == 'h'; 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] = a02cac(cbeg(reset), transl); else a[i-1+(j-1)*nmax] = cmplx_0_0; if (i != j) { if (sym) a[j-1+(i-1)*nmax] = a02cfc(a[i-1+(j-1)*nmax]); else if (tri) a[j-1+(i-1)*nmax] = cmplx_0_0; } } } if (sym) a[j-1+(j-1)*nmax] = a02bac(a02bbc(a[j-1+(j-1)*nmax]), 0.0); if (tri) a[j-1+(j-1)*nmax] = a02cac(a[j-1+(j-1)*nmax], cmplx_1_0); if (unit) a[j-1+(j-1)*nmax] = cmplx_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] = rogue; } } else if ( ! strncmp(type, "gb", 2)) { for (j = 1; j <= n; ++j) { for (i1 = 1; i1 <= ku+1-j; ++i1) aa[i1-1+(j-1)*tda] = rogue; for (i2 = i1; i2 <= MIN(kl+ku+1, ku+1+m-j); ++i2) aa[i2-1+(j-1)*tda] = a[i2+j-ku-2+(j-1)*nmax]; for (i3 = i2; i3 <= tda; ++i3) aa[i3-1+(j-1)*tda] = rogue; } } else if (! strncmp(type, "he", 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] = rogue; 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] = rogue; if (sym) { jj = j + (j - 1) * tda; AA(jj) = a02bac(a02bbc(AA(jj)), rrogue); } } } else if ( ! strncmp(type, "hb", 2) || ! strncmp(type, "tb", 2)) { for (j = 1; j <= n; ++j) { if (upper) { kk = kl + 1; ibeg = MAX((Integer)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-1+(j-1)*tda] = rogue; for (i = ibeg; i <= iend; ++i) aa[i-1+(j-1)*tda] = a[i+j-kk-1+(j-1)*nmax]; for (i = iend + 1; i <= tda; ++i) aa[i-1+(j-1)*tda] = rogue; if (sym) { jj = kk + (j - 1) * tda; AA(jj) = a02bac(a02bbc(AA(jj)), rrogue); } } } else if (! strncmp(type, "hp", 2) || ! strncmp(type, "tp", 2)) { 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) = rogue; if (sym) AA(ioff) = a02bac(a02bbc(AA(ioff)), rrogue); } } } } } /* cmake */ /* --------------------------------------------------------------------- */ static void cmvch(char trans, Integer m, Integer n, Complex alpha, Complex *a, Integer nmax, Complex *x, Integer incx, Complex beta, Complex *y, Integer incy, Complex *yt, double *g, Complex *yy, double eps, double *err, int *fatal, int mv) { /* Local variables */ double erri; int tran; Integer i, j; int ctran; Integer incxl, incyl, ml, nl, iy, jx, kx, ky; /* * Checks the results of the computational tests. * Auxiliary routine for test program for Level 2 Blas. */ /* .. Executable Statements .. */ /* 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'; ctran = trans == 'c'; if (tran || ctran) { 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) = cmplx_0_0; G(iy) = 0.0; jx = kx; if (tran) { for (j = 1; j <= nl; ++j) { YT(iy) = a02cac(YT(iy), a02ccc(a[j-1+(i-1)*nmax] , X(jx))); G(iy) += (FABS(a02bbc(a[j-1+(i-1)*nmax])) + FABS(a02bcc(a[j-1+(i-1)*nmax]))) * (FABS(a02bbc(X(jx))) + FABS(a02bcc(X(jx)))); jx += incxl; } } else if (ctran) { for (j = 1; j <= nl; ++j) { YT(iy) = a02cac(YT(iy), a02ccc(a02cfc(a[j-1+(i-1)*nmax]), X(jx))); G(iy) += (FABS(a02bbc(a[j-1+(i-1)*nmax])) + FABS(a02bcc(a[j-1+(i-1)*nmax]))) * (FABS(a02bbc(X(jx))) + FABS(a02bcc(X(jx)))); jx += incxl; } } else { for (j = 1; j <= nl; ++j) { YT(iy) = a02cac(YT(iy), a02ccc(a[i-1+(j-1)*nmax], X(jx))); G(iy) += (FABS(a02bbc(a[i-1+(j-1)*nmax])) + FABS(a02bcc(a[i-1+(j-1)*nmax]))) * (FABS(a02bbc(X(jx))) + FABS(a02bcc(X(jx)))); jx += incxl; } } YT(iy) = a02cac(a02ccc(alpha, YT(iy)), a02ccc(beta, Y(iy))); G(iy) = G(iy) * (FABS(a02bbc(alpha)) + FABS(a02bcc(alpha))) + (FABS(a02bbc(beta)) + FABS(a02bcc(beta))) * (FABS(a02bbc(Y(iy))) + FABS(a02bcc(Y(iy)))); iy += incyl; } /* Compute the error ratio for this result. */ *err = 0.0; for (i = 1; i <= ml; ++i) { erri = (FABS(a02bbc(a02cbc(YT(i), YY((i-1)*ABS(incy)+1)))) + FABS(a02bcc(a02cbc(YT(i), YY((i-1)*ABS(incy)+1)))))/ eps; if (G(i) != 0.0) erri /= G(i); *err = MAX(*err,erri); if (*err * sqrt(eps) >= 1.0) goto L120; } /* If the loop completes, all results are at least half accurate. */ goto L160; /* Report fatal error. */ L120: *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("%4ld (%15.6g,%15.6g) (%15.6g,%15.6g)\n",i, YT(i).re, YT(i).im, YY((i - 1) * ABS(incy) + 1).re, YY((i - 1) * ABS(incy) + 1).im); } else { Vprintf("%4ld (%15.6g,%15.6g) (%15.6g,%15.6g)\n",i, YT(i).re, YY((i-1)*ABS(incy)+1).re, YY((i-1)*ABS(incy)+1).im, YT(i).im); } } L160:; } /* cmvch */ /* --------------------------------------------------------------------- */ static int lce(Complex *ri, Complex *rj, Integer lr) { /* System generated locals */ int ret_val; /* Local variables */ Integer i; /* Tests if two arrays are identical. */ /* Auxiliary routine for test program for Level 2 Blas. */ /* 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).re != RJ(i).re || RI(i).im != RJ(i).im) goto L40; } ret_val = TRUE; goto L60; L40: ret_val = FALSE; L60: return ret_val; } /* lce */ /* --------------------------------------------------------------------- */ static int lceres(const char *type, char uplo, Integer m, Integer n, Complex *aa, Complex *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', 'he' or 'hp'. * Auxiliary routine for test program for Level 2 Blas. */ /* Function Body */ 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].re != as[i-1+(j-1)*tda].re || aa[i-1+(j-1)*tda].im != as[i-1+(j-1)*tda].im) goto L120; } } } else if (! strncmp(type, "he", 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].re != as[i-1+(j-1)*tda].re || aa[i-1+(j-1)*tda].im != as[i-1+(j-1)*tda].im) goto L120; } for (i = iend + 1; i <= tda; ++i) { if (aa[i-1+(j-1)*tda].re != as[i-1+(j-1)*tda].re || aa[i-1+(j-1)*tda].im != as[i-1+(j-1)*tda].im) goto L120; } } } ret_val = TRUE; goto L140; L120: ret_val = FALSE; L140: return ret_val; } /* lceres */ /* --------------------------------------------------------------------- */ static Complex cbeg(int *reset) { /* Local variables */ static Integer i, j, ic, mi, mj; /* * Generates complex numbers as pairs of random numbers uniformly * distributed between -0.5 and 0.5. * Auxiliary routine for test program for Level 2 Blas. */ /* .. Executable Statements .. */ if (*reset) { /* Initialize local variables. */ mi = 891; mj = 457; i = 7; j = 7; ic = 0; *reset = FALSE; } /* * The sequence of values of I or J is bounded between 1 and 999. * If initial I or J = 1,2,3,6,7 or 9, the period will be 50. * If initial I or J = 4 or 8, the period will be 25. * If initial I or J = 5, the period will be 10. * IC is used to break up the period by skipping 1 value of I or J * in 6. */ ++ic; L20: i *= mi; j *= mj; i -= i / 1000 * 1000; j -= j / 1000 * 1000; if (ic >= 5) { ic = 0; goto L20; } return a02bac((i-500)/1001.0, (j-500)/1001.0); } /* cbeg */ /* --------------------------------------------------------------------- */ 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; } /* 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; }