From cf4c5a6d89e13656fea12b4a10448c0ebcea4893 Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Thu, 20 Mar 2025 20:20:41 +0100 Subject: [PATCH] Update f2c-translated stand-ins to include GEMMTR --- ctest/c_cblat3c.c | 3895 +++----------------------------------------- ctest/c_dblat3c.c | 3284 +++---------------------------------- ctest/c_sblat3c.c | 3296 +++---------------------------------- ctest/c_zblat3c.c | 3930 +++------------------------------------------ 4 files changed, 942 insertions(+), 13463 deletions(-) diff --git a/ctest/c_cblat3c.c b/ctest/c_cblat3c.c index 5ad9b8bd8..447b23014 100644 --- a/ctest/c_cblat3c.c +++ b/ctest/c_cblat3c.c @@ -10,7 +10,25 @@ #undef I #endif -#include "common.h" +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif typedef blasint integer; @@ -229,6 +247,7 @@ typedef struct Namelist Namelist; #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } #define sig_die(s, kill) { exit(1); } #define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; #define z_abs(z) (cabs(Cd(z))) #define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} #define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} @@ -242,3701 +261,251 @@ typedef struct Namelist Namelist; /* procedure parameter types for -A and -C++ */ #define F2C_proc_par_types 1 - - -/* Common Block Declarations */ - -struct { - integer infot, noutc; - logical ok, lerr; -} infoc_; - -#define infoc_1 infoc_ - -struct { - char srnamt[12]; -} srnamc_; - -#define srnamc_1 srnamc_ - -/* Table of constant values */ - -static complex c_b1 = {0.f,0.f}; -static complex c_b2 = {1.f,0.f}; -static integer c__1 = 1; -static integer c__65 = 65; -static integer c__6 = 6; -static real c_b91 = 1.f; -static logical c_true = TRUE_; -static integer c__0 = 0; -static logical c_false = FALSE_; - -int /* Main program */ main(void) -{ - /* Initialized data */ - - static char snames[9][13] = {"cblas_cgemm ", "cblas_chemm ", "cblas_csymm ", - "cblas_ctrmm ", "cblas_ctrsm ", "cblas_cherk ", "cblas_csyrk ", - "cblas_cher2k", "cblas_csyr2k"}; - - /* System generated locals */ - integer i__1, i__2, i__3, i__4, i__5; - real r__1; - - /* Local variables */ - integer nalf, idim[9]; - logical same; - integer nbet, ntra; - logical rewi; - extern /* Subroutine */ int cchk1_(char *, real *, real *, integer *, - integer *, logical *, logical *, logical *, integer *, integer *, - integer *, complex *, integer *, complex *, integer *, complex *, - complex *, complex *, complex *, complex *, complex *, complex *, - complex *, complex *, complex *, real *, integer *), - cchk2_(char *, real *, real *, integer *, integer *, logical *, - logical *, logical *, integer *, integer *, integer *, complex *, - integer *, complex *, integer *, complex *, complex *, complex *, - complex *, complex *, complex *, complex *, complex *, complex *, - complex *, real *, integer *), cchk3_(char *, real *, - real *, integer *, integer *, logical *, logical *, logical *, - integer *, integer *, integer *, complex *, integer *, complex *, - complex *, complex *, complex *, complex *, complex *, complex *, - real *, complex *, integer *), cchk4_(char *, real *, - real *, integer *, integer *, logical *, logical *, logical *, - integer *, integer *, integer *, complex *, integer *, complex *, - integer *, complex *, complex *, complex *, complex *, complex *, - complex *, complex *, complex *, complex *, complex *, real *, - integer *), cchk5_(char *, real *, real *, integer *, - integer *, logical *, logical *, logical *, integer *, integer *, - integer *, complex *, integer *, complex *, integer *, complex *, - complex *, complex *, complex *, complex *, complex *, complex *, - complex *, complex *, real *, complex *, integer *); - complex c__[4225] /* was [65][65] */; - real g[65]; - integer i__, j, n; - logical fatal; - complex w[130]; - extern /* Subroutine */ int cmmch_(char *, char *, integer *, integer *, - integer *, complex *, complex *, integer *, complex *, integer *, - complex *, complex *, integer *, complex *, real *, complex *, - integer *, real *, real *, logical *, integer *, logical *); - extern real sdiff_(real *, real *); - logical trace; - integer nidim; - char snaps[32]; - integer isnum; - logical ltest[9]; - complex aa[4225], ab[8450] /* was [65][130] */, bb[4225], cc[4225], as[ - 4225], bs[4225], cs[4225], ct[65]; - logical sfatal, corder; - char snamet[12], transa[1], transb[1]; - real thresh; - logical rorder; - extern /* Subroutine */ int cc3chke_(char *); - integer layout; - logical ltestt, tsterr; - complex alf[7]; - extern logical lce_(complex *, complex *, integer *); - complex bet[7]; - real eps, err; - char tmpchar; - -/* Test program for the COMPLEX Level 3 Blas. */ - -/* The program must be driven by a short data file. The first 13 records */ -/* of the file are read using list-directed input, the last 9 records */ -/* are read using the format ( A12, L2 ). An annotated example of a data */ -/* file can be obtained by deleting the first 3 characters from the */ -/* following 22 lines: */ -/* 'CBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE */ -/* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) */ -/* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. */ -/* F LOGICAL FLAG, T TO STOP ON FAILURES. */ -/* T LOGICAL FLAG, T TO TEST ERROR CALL MYEXITS. */ -/* 2 0 TO TEST COLUMN-MAJOR, 1 TO TEST ROW-MAJOR, 2 TO TEST BOTH */ -/* 16.0 THRESHOLD VALUE OF TEST RATIO */ -/* 6 NUMBER OF VALUES OF N */ -/* 0 1 2 3 5 9 VALUES OF N */ -/* 3 NUMBER OF VALUES OF ALPHA */ -/* (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA */ -/* 3 NUMBER OF VALUES OF BETA */ -/* (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA */ -/* cblas_cgemm T PUT F FOR NO TEST. SAME COLUMNS. */ -/* cblas_chemm T PUT F FOR NO TEST. SAME COLUMNS. */ -/* cblas_csymm T PUT F FOR NO TEST. SAME COLUMNS. */ -/* cblas_ctrmm T PUT F FOR NO TEST. SAME COLUMNS. */ -/* cblas_ctrsm T PUT F FOR NO TEST. SAME COLUMNS. */ -/* cblas_cherk T PUT F FOR NO TEST. SAME COLUMNS. */ -/* cblas_csyrk T PUT F FOR NO TEST. SAME COLUMNS. */ -/* cblas_cher2k T PUT F FOR NO TEST. SAME COLUMNS. */ -/* cblas_csyr2k T PUT F FOR NO TEST. SAME COLUMNS. */ - -/* See: */ - -/* Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. */ -/* A Set of Level 3 Basic Linear Algebra Subprograms. */ - -/* Technical Memorandum No.88 (Revision 1), Mathematics and */ -/* Computer Science Division, Argonne National Laboratory, 9700 */ -/* South Cass Avenue, Argonne, Illinois 60439, US. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - - - infoc_1.noutc = 6; - -/* Read name and unit number for snapshot output file and open file. */ - char line[80]; - - fgets(line,80,stdin); - sscanf(line,"'%s'",snaps); - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&ntra); -#else - sscanf(line,"%d",&ntra); -#endif - trace = ntra >= 0; - if (trace) { -/* o__1.oerr = 0; - o__1.ounit = ntra; - o__1.ofnmlen = 32; - o__1.ofnm = snaps; - o__1.orl = 0; - o__1.osta = 0; - o__1.oacc = 0; - o__1.ofm = 0; - o__1.oblnk = 0; - f_open(&o__1);*/ - } -/* Read the flag that directs rewinding of the snapshot file. */ - fgets(line,80,stdin); - sscanf(line,"%d",&rewi); - rewi = rewi && trace; -/* Read the flag that directs stopping on any failure. */ - fgets(line,80,stdin); - sscanf(line,"%c",&tmpchar); - sfatal=FALSE_; - if (tmpchar=='T')sfatal=TRUE_; - fgets(line,80,stdin); - sscanf(line,"%c",&tmpchar); - tsterr=FALSE_; - if (tmpchar=='T')tsterr=TRUE_; - fgets(line,80,stdin); - sscanf(line,"%d",&layout); - fgets(line,80,stdin); - sscanf(line,"%f",&thresh); - - -/* Read and check the parameter values for the tests. */ - -/* Values of N */ - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&nidim); +#ifdef __cplusplus +typedef logical (*L_fp)(...); #else - sscanf(line,"%d",&nidim); +typedef logical (*L_fp)(); #endif - if (nidim < 1 || nidim > 9) { - fprintf(stderr,"NUMBER OF VALUES OF N IS LESS THAN 1 OR GREATER THAN 9"); - goto L220; - } - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld %ld %ld %ld %ld %ld %ld %ld %ld",&idim[0],&idim[1],&idim[2], - &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]); -#else - sscanf(line,"%d %d %d %d %d %d %d %d %d",&idim[0],&idim[1],&idim[2], - &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]); -#endif - i__1 = nidim; - for (i__ = 1; i__ <= i__1; ++i__) { - if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) { - fprintf(stderr,"VALUE OF N IS LESS THAN 0 OR GREATER THAN 65\n"); - goto L220; - } -/* L10: */ - } -/* Values of ALPHA */ - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&nalf); +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} #else - sscanf(line,"%d",&nalf); +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} #endif - if (nalf < 1 || nalf > 7) { - fprintf(stderr,"VALUE OF ALPHA IS LESS THAN 0 OR GREATER THAN 7\n"); - goto L220; - } - fgets(line,80,stdin); - sscanf(line,"(%f,%f) (%f,%f) (%f,%f) (%f,%f) (%f,%f) (%f,%f) (%f,%f)",&alf[0].r,&alf[0].i,&alf[1].r,&alf[1].i,&alf[2].r,&alf[2].i,&alf[3].r,&alf[3].i, - &alf[4].r,&alf[4].i,&alf[5].r,&alf[5].i,&alf[6].r,&alf[6].i); - -// i__1 = nalf; -// for (i__ = 1; i__ <= i__1; ++i__) { -// do_lio(&c__6, &c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(complex)); -// } -/* Values of BETA */ - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&nbet); +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} #else - sscanf(line,"%d",&nbet); +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} #endif - if (nalf < 1 || nbet > 7) { - fprintf(stderr,"VALUE OF BETA IS LESS THAN 0 OR GREATER THAN 7\n"); - goto L220; - } - fgets(line,80,stdin); - sscanf(line,"(%f,%f) (%f,%f) (%f,%f) (%f,%f) (%f,%f) (%f,%f) (%f,%f)",&bet[0].r,&bet[0].i,&bet[1].r,&bet[1].i,&bet[2].r,&bet[2].i,&bet[3].r,&bet[3].i, - &bet[4].r,&bet[4].i,&bet[5].r,&bet[5].i,&bet[6].r,&bet[6].i); - - -/* Report values of parameters. */ - - printf("TESTS OF THE COMPLEX LEVEL 3 BLAS\nTHE FOLLOWING PARAMETER VALUES WILL BE USED:\n"); - printf(" FOR N"); - for (i__ =1; i__ <=nidim;++i__) printf(" %d",idim[i__-1]); - printf("\n"); - printf(" FOR ALPHA"); - for (i__ =1; i__ <=nalf;++i__) printf(" (%f,%f)",alf[i__-1].r,alf[i__-1].i); - printf("\n"); - printf(" FOR BETA"); - for (i__ =1; i__ <=nbet;++i__) printf(" (%f,%f)",bet[i__-1].r,bet[i__-1].i); - printf("\n"); - - if (! tsterr) { - printf(" ERROR-EXITS WILL NOT BE TESTED\n"); - } - printf("ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LESS THAN %f\n",thresh); - rorder = FALSE_; - corder = FALSE_; - if (layout == 2) { - rorder = TRUE_; - corder = TRUE_; - printf("COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED\n"); - } else if (layout == 1) { - rorder = TRUE_; - printf("ROW-MAJOR DATA LAYOUT IS TESTED\n"); - } else if (layout == 0) { - corder = TRUE_; - printf("COLUMN-MAJOR DATA LAYOUT IS TESTED\n"); - } - -/* Read names of subroutines and flags which indicate */ -/* whether they are to be tested. */ - - for (i__ = 1; i__ <= 9; ++i__) { - ltest[i__ - 1] = FALSE_; -/* L20: */ - } -L30: - if (! fgets(line,80,stdin)) { - goto L60; - } - i__1 = sscanf(line,"%12c %c",snamet,&tmpchar); - ltestt=FALSE_; - if (tmpchar=='T')ltestt=TRUE_; - if (i__1 < 2) { - goto L60; - } - for (i__ = 1; i__ <= 9; ++i__) { - if (s_cmp(snamet, snames[i__ - 1] , (ftnlen)12, (ftnlen)12) == - 0) { - goto L50; - } -/* L40: */ - } - printf("SUBPROGRAM NAME %s NOT RECOGNIZED\n****** TESTS ABANDONED ******\n",snamet); - exit(1); -L50: - ltest[i__ - 1] = ltestt; - goto L30; - -L60: -/* cl__1.cerr = 0; - cl__1.cunit = 5; - cl__1.csta = 0; - f_clos(&cl__1);*/ - -/* Compute EPS (the machine precision). */ - - eps = 1.f; -L70: - r__1 = eps + 1.f; - if (sdiff_(&r__1, &c_b91) == 0.f) { - goto L80; - } - eps *= .5f; - goto L70; -L80: - eps += eps; - printf("RELATIVE MACHINE PRECISION IS TAKEN TO BE %9.1g\n",eps); - -/* Check the reliability of CMMCH using exact data. */ - - n = 32; - i__1 = n; - for (j = 1; j <= i__1; ++j) { - i__2 = n; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * 65 - 66; -/* Computing MAX */ - i__5 = i__ - j + 1; - i__4 = f2cmax(i__5,0); - ab[i__3].r = (real) i__4, ab[i__3].i = 0.f; -/* L90: */ - } - i__2 = j + 4224; - ab[i__2].r = (real) j, ab[i__2].i = 0.f; - i__2 = (j + 65) * 65 - 65; - ab[i__2].r = (real) j, ab[i__2].i = 0.f; - i__2 = j - 1; - c__[i__2].r = 0.f, c__[i__2].i = 0.f; -/* L100: */ - } - i__1 = n; - for (j = 1; j <= i__1; ++j) { - i__2 = j - 1; - i__3 = j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3; - cc[i__2].r = (real) i__3, cc[i__2].i = 0.f; -/* L110: */ - } -/* CC holds the exact result. On exit from CMMCH CT holds */ -/* the result computed by CMMCH. */ - *(unsigned char *)transa = 'N'; - *(unsigned char *)transb = 'N'; - cmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], & - c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal, - &c__6, &c_true); - same = lce_(cc, ct, &n); - if (! same || err != 0.f) { - printf("ERROR IN CMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); - printf("CMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); - printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); - printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); - printf("****** TESTS ABANDONED ******\n"); - exit(1); - } - *(unsigned char *)transb = 'C'; - cmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], & - c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal, - &c__6, &c_true); - same = lce_(cc, ct, &n); - if (! same || err != 0.f) { - printf("ERROR IN CMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); - printf("CMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); - printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); - printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); - printf("****** TESTS ABANDONED ******\n"); - exit(1); - } - i__1 = n; - for (j = 1; j <= i__1; ++j) { - i__2 = j + 4224; - i__3 = n - j + 1; - ab[i__2].r = (real) i__3, ab[i__2].i = 0.f; - i__2 = (j + 65) * 65 - 65; - i__3 = n - j + 1; - ab[i__2].r = (real) i__3, ab[i__2].i = 0.f; -/* L120: */ - } - i__1 = n; - for (j = 1; j <= i__1; ++j) { - i__2 = n - j; - i__3 = j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3; - cc[i__2].r = (real) i__3, cc[i__2].i = 0.f; -/* L130: */ - } - *(unsigned char *)transa = 'C'; - *(unsigned char *)transb = 'N'; - cmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], & - c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal, - &c__6, &c_true); - same = lce_(cc, ct, &n); - if (! same || err != 0.f) { - printf("ERROR IN CMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); - printf("CMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); - printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); - printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); - printf("****** TESTS ABANDONED ******\n"); - exit(1); - } - *(unsigned char *)transb = 'C'; - cmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], & - c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal, - &c__6, &c_true); - same = lce_(cc, ct, &n); - if (! same || err != 0.f) { - printf("ERROR IN CMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); - printf("CMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); - printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); - printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); - printf("****** TESTS ABANDONED ******\n"); - exit(1); - } - -/* Test each subroutine in turn. */ - - for (isnum = 1; isnum <= 9; ++isnum) { - if (! ltest[isnum - 1]) { -/* Subprogram is not to be tested. */ - printf("%12s WAS NOT TESTED\n",snames[isnum-1]); - } else { - s_copy(srnamc_1.srnamt, snames[isnum - 1], (ftnlen)12, ( - ftnlen)12); -/* Test error exits. */ - if (tsterr) { - cc3chke_(snames[isnum - 1]); - } -/* Test computations. */ - infoc_1.infot = 0; - infoc_1.ok = TRUE_; - fatal = FALSE_; - switch (isnum) { - case 1: goto L140; - case 2: goto L150; - case 3: goto L150; - case 4: goto L160; - case 5: goto L160; - case 6: goto L170; - case 7: goto L170; - case 8: goto L180; - case 9: goto L180; - } -/* Test CGEMM, 01. */ -L140: - if (corder) { - cchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__0); - } - if (rorder) { - cchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__1); - } - goto L190; -/* Test CHEMM, 02, CSYMM, 03. */ -L150: - if (corder) { - cchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__0); - } - if (rorder) { - cchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__1); - } - goto L190; -/* Test CTRMM, 04, CTRSM, 05. */ -L160: - if (corder) { - cchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, & - c__0); - } - if (rorder) { - cchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, & - c__1); - } - goto L190; -/* Test CHERK, 06, CSYRK, 07. */ -L170: - if (corder) { - cchk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__0); - } - if (rorder) { - cchk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__1); - } - goto L190; -/* Test CHER2K, 08, CSYR2K, 09. */ -L180: - if (corder) { - cchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, - ct, g, w, &c__0); - } - if (rorder) { - cchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, - ct, g, w, &c__1); - } - goto L190; - -L190: - if (fatal && sfatal) { - goto L210; - } - } -/* L200: */ - } - printf("\nEND OF TESTS\n"); - goto L230; - -L210: - printf("\n****** FATAL ERROR - TESTS ABANDONED ******\n"); - goto L230; - -L220: - printf("AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM\n"); - printf("****** TESTS ABANDONED ******\n"); -L230: - if (trace) { -/* cl__1.cerr = 0; - cl__1.cunit = ntra; - cl__1.csta = 0; - f_clos(&cl__1);*/ - } -/* cl__1.cerr = 0; - cl__1.cunit = 6; - cl__1.csta = 0; - f_clos(&cl__1); - s_stop("", (ftnlen)0);*/ - exit(0); - -/* End of CBLAT3. */ - - return 0; -} /* MAIN__ */ - -/* Subroutine */ int cchk1_(char *sname, real *eps, real *thresh, integer * - nout, integer *ntra, logical *trace, logical *rewi, logical *fatal, - integer *nidim, integer *idim, integer *nalf, complex *alf, integer * - nbet, complex *bet, integer *nmax, complex *a, complex *aa, complex * - as, complex *b, complex *bb, complex *bs, complex *c__, complex *cc, - complex *cs, complex *ct, real *g, integer *iorder) -{ - /* Initialized data */ - - static char ich[3] = "NTC"; - - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3, i__4, i__5, i__6, i__7, i__8; - - /* Local variables */ - complex beta; - integer ldas, ldbs, ldcs; - logical same, null; - integer i__, k, m, n; - extern /* Subroutine */ int cmake_(char *, char *, char *, integer *, - integer *, complex *, integer *, complex *, integer *, logical *, - complex *); - complex alpha; - extern /* Subroutine */ int cmmch_(char *, char *, integer *, integer *, - integer *, complex *, complex *, integer *, complex *, integer *, - complex *, complex *, integer *, complex *, real *, complex *, - integer *, real *, real *, logical *, integer *, logical *); - logical isame[13], trana, tranb; - integer nargs; - logical reset; - extern /* Subroutine */ int cprcn1_(integer *, integer *, char *, integer - *, char *, char *, integer *, integer *, integer *, complex *, - integer *, integer *, complex *, integer *); - integer ia, ib, ma, mb, na, nb, nc, ik, im, in; - extern /* Subroutine */ int ccgemm_(integer *, char *, char *, integer *, - integer *, integer *, complex *, complex *, integer *, complex *, - integer *, complex *, complex *, integer *); - integer ks, ms, ns; - extern logical lceres_(char *, char *, integer *, integer *, complex *, - complex *, integer *); - char tranas[1], tranbs[1], transa[1], transb[1]; - real errmax; - integer ica, icb, laa, lbb, lda, lcc, ldb, ldc; - extern logical lce_(complex *, complex *, integer *); - complex als, bls; - real err; - -/* Tests CGEMM. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - - /* Parameter adjustments */ - --idim; - --alf; - --bet; - --g; - --ct; - --cs; - --cc; - c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - --bs; - --bb; - b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; - b -= b_offset; - --as; - --aa; - a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - - /* Function Body */ - - nargs = 13; - nc = 0; - reset = TRUE_; - errmax = 0.f; - - i__1 = *nidim; - for (im = 1; im <= i__1; ++im) { - m = idim[im]; - - i__2 = *nidim; - for (in = 1; in <= i__2; ++in) { - n = idim[in]; -/* Set LDC to 1 more than minimum value if room. */ - ldc = m; - if (ldc < *nmax) { - ++ldc; - } -/* Skip tests if not enough room. */ - if (ldc > *nmax) { - goto L100; - } - lcc = ldc * n; - null = n <= 0 || m <= 0; - - i__3 = *nidim; - for (ik = 1; ik <= i__3; ++ik) { - k = idim[ik]; - - for (ica = 1; ica <= 3; ++ica) { - *(unsigned char *)transa = *(unsigned char *)&ich[ica - 1] - ; - trana = *(unsigned char *)transa == 'T' || *(unsigned - char *)transa == 'C'; - - if (trana) { - ma = k; - na = m; - } else { - ma = m; - na = k; - } -/* Set LDA to 1 more than minimum value if room. */ - lda = ma; - if (lda < *nmax) { - ++lda; - } -/* Skip tests if not enough room. */ - if (lda > *nmax) { - goto L80; - } - laa = lda * na; - -/* Generate the matrix A. */ - - cmake_("ge", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[ - 1], &lda, &reset, &c_b1); - - for (icb = 1; icb <= 3; ++icb) { - *(unsigned char *)transb = *(unsigned char *)&ich[icb - - 1]; - tranb = *(unsigned char *)transb == 'T' || *(unsigned - char *)transb == 'C'; - - if (tranb) { - mb = n; - nb = k; - } else { - mb = k; - nb = n; - } -/* Set LDB to 1 more than minimum value if room. */ - ldb = mb; - if (ldb < *nmax) { - ++ldb; - } -/* Skip tests if not enough room. */ - if (ldb > *nmax) { - goto L70; - } - lbb = ldb * nb; - -/* Generate the matrix B. */ - - cmake_("ge", " ", " ", &mb, &nb, &b[b_offset], nmax, & - bb[1], &ldb, &reset, &c_b1); - - i__4 = *nalf; - for (ia = 1; ia <= i__4; ++ia) { - i__5 = ia; - alpha.r = alf[i__5].r, alpha.i = alf[i__5].i; - - i__5 = *nbet; - for (ib = 1; ib <= i__5; ++ib) { - i__6 = ib; - beta.r = bet[i__6].r, beta.i = bet[i__6].i; - -/* Generate the matrix C. */ - - cmake_("ge", " ", " ", &m, &n, &c__[c_offset], - nmax, &cc[1], &ldc, &reset, &c_b1); - - ++nc; - -/* Save every datum before calling the */ -/* subroutine. */ - - *(unsigned char *)tranas = *(unsigned char *) - transa; - *(unsigned char *)tranbs = *(unsigned char *) - transb; - ms = m; - ns = n; - ks = k; - als.r = alpha.r, als.i = alpha.i; - i__6 = laa; - for (i__ = 1; i__ <= i__6; ++i__) { - i__7 = i__; - i__8 = i__; - as[i__7].r = aa[i__8].r, as[i__7].i = aa[ - i__8].i; -/* L10: */ - } - ldas = lda; - i__6 = lbb; - for (i__ = 1; i__ <= i__6; ++i__) { - i__7 = i__; - i__8 = i__; - bs[i__7].r = bb[i__8].r, bs[i__7].i = bb[ - i__8].i; -/* L20: */ - } - ldbs = ldb; - bls.r = beta.r, bls.i = beta.i; - i__6 = lcc; - for (i__ = 1; i__ <= i__6; ++i__) { - i__7 = i__; - i__8 = i__; - cs[i__7].r = cc[i__8].r, cs[i__7].i = cc[ - i__8].i; -/* L30: */ - } - ldcs = ldc; - -/* Call the subroutine. */ - - if (*trace) { - cprcn1_(ntra, &nc, sname, iorder, transa, - transb, &m, &n, &k, &alpha, &lda, - &ldb, &beta, &ldc); - } - if (*rewi) { -/* al__1.aerr = 0; - al__1.aunit = *ntra; - f_rew(&al__1); */ - } - ccgemm_(iorder, transa, transb, &m, &n, &k, & - alpha, &aa[1], &lda, &bb[1], &ldb, & - beta, &cc[1], &ldc); - -/* Check if error-exit was taken incorrectly. */ - - if (! infoc_1.ok) { -// io___128.ciunit = *nout; -// s_wsfe(&io___128); -// e_wsfe(); - printf(" *** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); - *fatal = TRUE_; - goto L120; - } - -/* See what data changed inside subroutines. */ - - isame[0] = *(unsigned char *)transa == *( - unsigned char *)tranas; - isame[1] = *(unsigned char *)transb == *( - unsigned char *)tranbs; - isame[2] = ms == m; - isame[3] = ns == n; - isame[4] = ks == k; - isame[5] = als.r == alpha.r && als.i == - alpha.i; - isame[6] = lce_(&as[1], &aa[1], &laa); - isame[7] = ldas == lda; - isame[8] = lce_(&bs[1], &bb[1], &lbb); - isame[9] = ldbs == ldb; - isame[10] = bls.r == beta.r && bls.i == - beta.i; - if (null) { - isame[11] = lce_(&cs[1], &cc[1], &lcc); - } else { - isame[11] = lceres_("ge", " ", &m, &n, & - cs[1], &cc[1], &ldc); - } - isame[12] = ldcs == ldc; - -/* If data was incorrectly changed, report */ -/* and return. */ - - same = TRUE_; - i__6 = nargs; - for (i__ = 1; i__ <= i__6; ++i__) { - same = same && isame[i__ - 1]; - if (! isame[i__ - 1]) { - printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);; - } -/* L40: */ - } - if (! same) { - *fatal = TRUE_; - goto L120; - } - - if (! null) { - -/* Check the result. */ - - cmmch_(transa, transb, &m, &n, &k, &alpha, - &a[a_offset], nmax, &b[b_offset], - nmax, &beta, &c__[c_offset], - nmax, &ct[1], &g[1], &cc[1], &ldc, - eps, &err, fatal, nout, &c_true); - errmax = f2cmax(errmax,err); -/* If got really bad answer, report and */ -/* return. */ - if (*fatal) { - goto L120; - } - } - -/* L50: */ - } - -/* L60: */ - } - -L70: - ; - } - -L80: - ; - } - -/* L90: */ - } - -L100: - ; - } - -/* L110: */ - } - -/* Report result. */ - - if (errmax < *thresh) { - if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); - } - if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); - } - } else { - if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); - } - if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); - } - } - goto L130; - -L120: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); - cprcn1_(nout, &nc, sname, iorder, transa, transb, &m, &n, &k, &alpha, & - lda, &ldb, &beta, &ldc); - -L130: - return 0; - -/* 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',', */ -/* $ 3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, */ -/* $ ',(', F4.1, ',', F4.1, '), C,', I3, ').' ) */ - -/* End of CCHK1. */ - -} /* cchk1_ */ - - -/* Subroutine */ int cprcn1_(integer *nout, integer *nc, char *sname, integer - *iorder, char *transa, char *transb, integer *m, integer *n, integer * - k, complex *alpha, integer *lda, integer *ldb, complex *beta, integer - *ldc) +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) { - /* Local variables */ - char crc[14], cta[14], ctb[14]; - - if (*(unsigned char *)transa == 'N') { - s_copy(cta, " CblasNoTrans", (ftnlen)14, (ftnlen)14); - } else if (*(unsigned char *)transa == 'T') { - s_copy(cta, " CblasTrans", (ftnlen)14, (ftnlen)14); - } else { - s_copy(cta, "CblasConjTrans", (ftnlen)14, (ftnlen)14); - } - if (*(unsigned char *)transb == 'N') { - s_copy(ctb, " CblasNoTrans", (ftnlen)14, (ftnlen)14); - } else if (*(unsigned char *)transb == 'T') { - s_copy(ctb, " CblasTrans", (ftnlen)14, (ftnlen)14); - } else { - s_copy(ctb, "CblasConjTrans", (ftnlen)14, (ftnlen)14); - } - if (*iorder == 1) { - s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); - } else { - s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); - } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cta,ctb); - printf("%d %d %d (%4.1f,%4.1f) , A, %d, B, %d, (%4.1f,%4.1f) , C, %d.\n",*m,*n,*k,alpha->r,alpha->i,*lda,*ldb,beta->r,beta->i,*ldc); - return 0; -} /* cprcn1_ */ - - -/* Subroutine */ int cchk2_(char *sname, real *eps, real *thresh, integer * - nout, integer *ntra, logical *trace, logical *rewi, logical *fatal, - integer *nidim, integer *idim, integer *nalf, complex *alf, integer * - nbet, complex *bet, integer *nmax, complex *a, complex *aa, complex * - as, complex *b, complex *bb, complex *bs, complex *c__, complex *cc, - complex *cs, complex *ct, real *g, integer *iorder) + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) { - /* Initialized data */ - - static char ichs[2] = "LR"; - static char ichu[2] = "UL"; - - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3, i__4, i__5, i__6, i__7; - - /* Local variables */ - complex beta; - integer ldas, ldbs, ldcs; - logical same; - char side[1]; - logical conj, left, null; - char uplo[1]; - integer i__, m, n; - extern /* Subroutine */ int cmake_(char *, char *, char *, integer *, - integer *, complex *, integer *, complex *, integer *, logical *, - complex *); - complex alpha; - extern /* Subroutine */ int cmmch_(char *, char *, integer *, integer *, - integer *, complex *, complex *, integer *, complex *, integer *, - complex *, complex *, integer *, complex *, real *, complex *, - integer *, real *, real *, logical *, integer *, logical *); - logical isame[13]; - char sides[1]; - integer nargs; - logical reset; - char uplos[1]; - extern /* Subroutine */ int cprcn2_(integer *, integer *, char *, integer - *, char *, char *, integer *, integer *, complex *, integer *, - integer *, complex *, integer *); - integer ia, ib, na, nc, im, in; - extern /* Subroutine */ int cchemm_(integer *, char *, char *, integer *, - integer *, complex *, complex *, integer *, complex *, integer *, - complex *, complex *, integer *); - integer ms, ns; - extern logical lceres_(char *, char *, integer *, integer *, complex *, - complex *, integer *); - extern /* Subroutine */ int ccsymm_(integer *, char *, char *, integer *, - integer *, complex *, complex *, integer *, complex *, integer *, - complex *, complex *, integer *); - real errmax; - integer laa, lbb, lda, lcc, ldb, ldc; - extern logical lce_(complex *, complex *, integer *); - integer ics; - complex als, bls; - integer icu; - real err; - -/* Tests CHEMM and CSYMM. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - - /* Parameter adjustments */ - --idim; - --alf; - --bet; - --g; - --ct; - --cs; - --cc; - c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - --bs; - --bb; - b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; - b -= b_offset; - --as; - --aa; - a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - - /* Function Body */ - conj = s_cmp(sname + 7, "he", (ftnlen)2, (ftnlen)2) == 0; - - nargs = 12; - nc = 0; - reset = TRUE_; - errmax = 0.f; - - i__1 = *nidim; - for (im = 1; im <= i__1; ++im) { - m = idim[im]; - - i__2 = *nidim; - for (in = 1; in <= i__2; ++in) { - n = idim[in]; -/* Set LDC to 1 more than minimum value if room. */ - ldc = m; - if (ldc < *nmax) { - ++ldc; - } -/* Skip tests if not enough room. */ - if (ldc > *nmax) { - goto L90; - } - lcc = ldc * n; - null = n <= 0 || m <= 0; -/* Set LDB to 1 more than minimum value if room. */ - ldb = m; - if (ldb < *nmax) { - ++ldb; - } -/* Skip tests if not enough room. */ - if (ldb > *nmax) { - goto L90; - } - lbb = ldb * n; - -/* Generate the matrix B. */ - - cmake_("ge", " ", " ", &m, &n, &b[b_offset], nmax, &bb[1], &ldb, & - reset, &c_b1); - - for (ics = 1; ics <= 2; ++ics) { - *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1]; - left = *(unsigned char *)side == 'L'; - - if (left) { - na = m; - } else { - na = n; - } -/* Set LDA to 1 more than minimum value if room. */ - lda = na; - if (lda < *nmax) { - ++lda; - } -/* Skip tests if not enough room. */ - if (lda > *nmax) { - goto L80; + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;ir,alpha->i,*lda,*ldb,beta->r,beta->i,*ldc); - return 0; -} /* cprcn2_ */ - - -/* Subroutine */ int cchk3_(char *sname, real *eps, real *thresh, integer * - nout, integer *ntra, logical *trace, logical *rewi, logical *fatal, - integer *nidim, integer *idim, integer *nalf, complex *alf, integer * - nmax, complex *a, complex *aa, complex *as, complex *b, complex *bb, - complex *bs, complex *ct, real *g, complex *c__, integer *iorder) -{ - /* Initialized data */ - - static char ichu[2] = "UL"; - static char icht[3] = "NTC"; - static char ichd[2] = "UN"; - static char ichs[2] = "LR"; - - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3, i__4, i__5, i__6, i__7; - complex q__1; - - /* Local variables */ - char diag[1]; - integer ldas, ldbs; - logical same; - char side[1]; - logical left, null; - char uplo[1]; - integer i__, j, m, n; - extern /* Subroutine */ int cmake_(char *, char *, char *, integer *, - integer *, complex *, integer *, complex *, integer *, logical *, - complex *); - complex alpha; - char diags[1]; - extern /* Subroutine */ int cmmch_(char *, char *, integer *, integer *, - integer *, complex *, complex *, integer *, complex *, integer *, - complex *, complex *, integer *, complex *, real *, complex *, - integer *, real *, real *, logical *, integer *, logical *); - logical isame[13]; - char sides[1]; - integer nargs; - logical reset; - char uplos[1]; - extern /* Subroutine */ int cprcn3_(integer *, integer *, char *, integer - *, char *, char *, char *, char *, integer *, integer *, complex * - , integer *, integer *); - integer ia, na, nc, im, in, ms, ns; - extern logical lceres_(char *, char *, integer *, integer *, complex *, - complex *, integer *); - extern /* Subroutine */ int cctrmm_(integer *, char *, char *, char *, - char *, integer *, integer *, complex *, complex *, integer *, - complex *, integer *); - char tranas[1], transa[1]; - extern /* Subroutine */ int cctrsm_(integer *, char *, char *, char *, - char *, integer *, integer *, complex *, complex *, integer *, - complex *, integer *); - real errmax; - integer laa, icd, lbb, lda, ldb; - extern logical lce_(complex *, complex *, integer *); - integer ics; - complex als; - integer ict, icu; - real err; - -/* Tests CTRMM and CTRSM. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - - /* Parameter adjustments */ - --idim; - --alf; - c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - --g; - --ct; - --bs; - --bb; - b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; - b -= b_offset; - --as; - --aa; - a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - - /* Function Body */ - - nargs = 11; - nc = 0; - reset = TRUE_; - errmax = 0.f; -/* Set up zero matrix for CMMCH. */ - i__1 = *nmax; - for (j = 1; j <= i__1; ++j) { - i__2 = *nmax; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * c_dim1; - c__[i__3].r = 0.f, c__[i__3].i = 0.f; -/* L10: */ } -/* L20: */ - } - - i__1 = *nidim; - for (im = 1; im <= i__1; ++im) { - m = idim[im]; - - i__2 = *nidim; - for (in = 1; in <= i__2; ++in) { - n = idim[in]; -/* Set LDB to 1 more than minimum value if room. */ - ldb = m; - if (ldb < *nmax) { - ++ldb; - } -/* Skip tests if not enough room. */ - if (ldb > *nmax) { - goto L130; - } - lbb = ldb * n; - null = m <= 0 || n <= 0; - - for (ics = 1; ics <= 2; ++ics) { - *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1]; - left = *(unsigned char *)side == 'L'; - if (left) { - na = m; - } else { - na = n; - } -/* Set LDA to 1 more than minimum value if room. */ - lda = na; - if (lda < *nmax) { - ++lda; - } -/* Skip tests if not enough room. */ - if (lda > *nmax) { - goto L130; + pCf(z) = zdotc; +} +#else + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;ir,alpha->i,*lda,*ldb); - - return 0; -} /* cprcn3_ */ - - -/* Subroutine */ int cchk4_(char *sname, real *eps, real *thresh, integer * - nout, integer *ntra, logical *trace, logical *rewi, logical *fatal, - integer *nidim, integer *idim, integer *nalf, complex *alf, integer * - nbet, complex *bet, integer *nmax, complex *a, complex *aa, complex * - as, complex *b, complex *bb, complex *bs, complex *c__, complex *cc, - complex *cs, complex *ct, real *g, integer *iorder) -{ - /* Initialized data */ - - static char icht[2] = "NC"; - static char ichu[2] = "UL"; - - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3, i__4, i__5, i__6, i__7; - complex q__1; - - /* Local variables */ - complex beta; - integer ldas, ldcs; - logical same, conj; - complex bets; - real rals; - logical tran, null; - char uplo[1]; - integer i__, j, k, n; - extern /* Subroutine */ int cmake_(char *, char *, char *, integer *, - integer *, complex *, integer *, complex *, integer *, logical *, - complex *); - complex alpha; - extern /* Subroutine */ int cmmch_(char *, char *, integer *, integer *, - integer *, complex *, complex *, integer *, complex *, integer *, - complex *, complex *, integer *, complex *, real *, complex *, - integer *, real *, real *, logical *, integer *, logical *); - real rbeta; - logical isame[13]; - integer nargs; - real rbets; - logical reset; - char trans[1]; - logical upper; - char uplos[1]; - extern /* Subroutine */ int cprcn4_(integer *, integer *, char *, integer - *, char *, char *, integer *, integer *, complex *, integer *, - complex *, integer *), cprcn6_(integer *, - integer *, char *, integer *, char *, char *, integer *, integer * - , real *, integer *, real *, integer *); - integer ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks; - extern /* Subroutine */ int ccherk_(integer *, char *, char *, integer *, - integer *, real *, complex *, integer *, real *, complex *, - integer *); - integer ns; - real ralpha; - extern logical lceres_(char *, char *, integer *, integer *, complex *, - complex *, integer *); - real errmax; - extern /* Subroutine */ int ccsyrk_(integer *, char *, char *, integer *, - integer *, complex *, complex *, integer *, complex *, complex *, - integer *); - char transs[1], transt[1]; - integer laa, lda, lcc, ldc; - extern logical lce_(complex *, complex *, integer *); - complex als; - integer ict, icu; - real err; - -/* Tests CHERK and CSYRK. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - - /* Parameter adjustments */ - --idim; - --alf; - --bet; - --g; - --ct; - --cs; - --cc; - c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - --bs; - --bb; - b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; - b -= b_offset; - --as; - --aa; - a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - - /* Function Body */ - conj = s_cmp(sname + 7, "he", (ftnlen)2, (ftnlen)2) == 0; - - nargs = 10; - nc = 0; - reset = TRUE_; - errmax = 0.f; - rals = 1.f; - rbets = 1.f; - - i__1 = *nidim; - for (in = 1; in <= i__1; ++in) { - n = idim[in]; -/* Set LDC to 1 more than minimum value if room. */ - ldc = n; - if (ldc < *nmax) { - ++ldc; - } -/* Skip tests if not enough room. */ - if (ldc > *nmax) { - goto L100; - } - lcc = ldc * n; - - i__2 = *nidim; - for (ik = 1; ik <= i__2; ++ik) { - k = idim[ik]; - - for (ict = 1; ict <= 2; ++ict) { - *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1]; - tran = *(unsigned char *)trans == 'C'; - if (tran && ! conj) { - *(unsigned char *)trans = 'T'; - } - if (tran) { - ma = k; - na = n; - } else { - ma = n; - na = k; - } -/* Set LDA to 1 more than minimum value if room. */ - lda = ma; - if (lda < *nmax) { - ++lda; - } -/* Skip tests if not enough room. */ - if (lda > *nmax) { - goto L80; + pCf(z) = zdotc; +} +#endif +static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Dcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i 1) { - printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j); - } - -L120: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); - if (conj) { - cprcn6_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &ralpha, &lda, - &rbeta, &ldc); - } else { - cprcn4_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, & - beta, &ldc); - } - -L130: - return 0; - -/* 9994 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ -/* $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') ', */ -/* $ ' .' ) */ -/* 9993 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ -/* $ '(', F4.1, ',', F4.1, ') , A,', I3, ',(', F4.1, ',', F4.1, */ -/* $ '), C,', I3, ') .' ) */ - -/* End of CCHK4. */ - -} /* cchk4_ */ - - -/* Subroutine */ int cprcn4_(integer *nout, integer *nc, char *sname, integer - *iorder, char *uplo, char *transa, integer *n, integer *k, complex * - alpha, integer *lda, complex *beta, integer *ldc) -{ - /* Local variables */ - char ca[14], cu[14], crc[14]; - - if (*(unsigned char *)uplo == 'U') { - s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); - } else { - s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); - } - if (*(unsigned char *)transa == 'N') { - s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); - } else if (*(unsigned char *)transa == 'T') { - s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); - } else { - s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); - } - if (*iorder == 1) { - s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); - } else { - s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); - } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); - printf("( %d %d (%4.1f,%4.1f) A %d (%4.1f,%4.1f) C %d\n",*n,*k,alpha->r,alpha->i,*lda,beta->r,beta->i,*ldc); - return 0; -} /* cprcn4_ */ - - - -/* Subroutine */ int cprcn6_(integer *nout, integer *nc, char *sname, integer - *iorder, char *uplo, char *transa, integer *n, integer *k, real * - alpha, integer *lda, real *beta, integer *ldc) -{ - /* Local variables */ - char ca[14], cu[14], crc[14]; - - if (*(unsigned char *)uplo == 'U') { - s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); - } else { - s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); - } - if (*(unsigned char *)transa == 'N') { - s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); - } else if (*(unsigned char *)transa == 'T') { - s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); - } else { - s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); - } - if (*iorder == 1) { - s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); - } else { - s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); - } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); - printf("( %d %d %4.1f A %d %4.1f C %d\n",*n,*k,*alpha,*lda,*beta,*ldc); - return 0; -} /* cprcn6_ */ - - -/* Subroutine */ int cchk5_(char *sname, real *eps, real *thresh, integer * - nout, integer *ntra, logical *trace, logical *rewi, logical *fatal, - integer *nidim, integer *idim, integer *nalf, complex *alf, integer * - nbet, complex *bet, integer *nmax, complex *ab, complex *aa, complex * - as, complex *bb, complex *bs, complex *c__, complex *cc, complex *cs, - complex *ct, real *g, complex *w, integer *iorder) -{ - /* Initialized data */ - - static char icht[2] = "NC"; - static char ichu[2] = "UL"; - - - /* System generated locals */ - integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8; - complex q__1, q__2; - - /* Local variables */ - integer jjab; - complex beta; - integer ldas, ldbs, ldcs; - logical same, conj; - complex bets; - logical tran, null; - char uplo[1]; - integer i__, j, k, n; - extern /* Subroutine */ int cmake_(char *, char *, char *, integer *, - integer *, complex *, integer *, complex *, integer *, logical *, - complex *); - complex alpha; - extern /* Subroutine */ int cmmch_(char *, char *, integer *, integer *, - integer *, complex *, complex *, integer *, complex *, integer *, - complex *, complex *, integer *, complex *, real *, complex *, - integer *, real *, real *, logical *, integer *, logical *); - real rbeta; - logical isame[13]; - integer nargs; - real rbets; - logical reset; - char trans[1]; - logical upper; - char uplos[1]; - extern /* Subroutine */ int cprcn5_(integer *, integer *, char *, integer - *, char *, char *, integer *, integer *, complex *, integer *, - integer *, complex *, integer *), cprcn7_( - integer *, integer *, char *, integer *, char *, char *, integer * - , integer *, complex *, integer *, integer *, real *, integer *); - integer ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns; - extern logical lceres_(char *, char *, integer *, integer *, complex *, - complex *, integer *); - real errmax; - char transs[1], transt[1]; - extern /* Subroutine */ int ccher2k_(integer *, char *, char *, integer *, - integer *, complex *, complex *, integer *, complex *, integer *, - real *, complex *, integer *); - integer laa, lbb, lda, lcc, ldb, ldc; - extern logical lce_(complex *, complex *, integer *); - extern /* Subroutine */ int ccsyr2k_(integer *, char *, char *, integer *, - integer *, complex *, complex *, integer *, complex *, integer *, - complex *, complex *, integer *); - complex als; - integer ict, icu; - real err; - -/* Tests CHER2K and CSYR2K. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - - /* Parameter adjustments */ - --idim; - --alf; - --bet; - --w; - --g; - --ct; - --cs; - --cc; - c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - --bs; - --bb; - --as; - --aa; - --ab; - - /* Function Body */ - conj = s_cmp(sname + 7, "he", (ftnlen)2, (ftnlen)2) == 0; - - nargs = 12; - nc = 0; - reset = TRUE_; - errmax = 0.f; - - i__1 = *nidim; - for (in = 1; in <= i__1; ++in) { - n = idim[in]; -/* Set LDC to 1 more than minimum value if room. */ - ldc = n; - if (ldc < *nmax) { - ++ldc; } -/* Skip tests if not enough room. */ - if (ldc > *nmax) { - goto L130; - } - lcc = ldc * n; - - i__2 = *nidim; - for (ik = 1; ik <= i__2; ++ik) { - k = idim[ik]; - - for (ict = 1; ict <= 2; ++ict) { - *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1]; - tran = *(unsigned char *)trans == 'C'; - if (tran && ! conj) { - *(unsigned char *)trans = 'T'; - } - if (tran) { - ma = k; - na = n; - } else { - ma = n; - na = k; - } -/* Set LDA to 1 more than minimum value if room. */ - lda = ma; - if (lda < *nmax) { - ++lda; - } -/* Skip tests if not enough room. */ - if (lda > *nmax) { - goto L110; - } - laa = lda * na; - -/* Generate the matrix A. */ - - if (tran) { - i__3 = *nmax << 1; - cmake_("ge", " ", " ", &ma, &na, &ab[1], &i__3, &aa[1], & - lda, &reset, &c_b1); - } else { - cmake_("ge", " ", " ", &ma, &na, &ab[1], nmax, &aa[1], & - lda, &reset, &c_b1); - } - -/* Generate the matrix B. */ - - ldb = lda; - lbb = laa; - if (tran) { - i__3 = *nmax << 1; - cmake_("ge", " ", " ", &ma, &na, &ab[k + 1], &i__3, &bb[1] - , &ldb, &reset, &c_b1); - } else { - cmake_("ge", " ", " ", &ma, &na, &ab[k * *nmax + 1], nmax, - &bb[1], &ldb, &reset, &c_b1); - } - - for (icu = 1; icu <= 2; ++icu) { - *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; - upper = *(unsigned char *)uplo == 'U'; - - i__3 = *nalf; - for (ia = 1; ia <= i__3; ++ia) { - i__4 = ia; - alpha.r = alf[i__4].r, alpha.i = alf[i__4].i; - - i__4 = *nbet; - for (ib = 1; ib <= i__4; ++ib) { - i__5 = ib; - beta.r = bet[i__5].r, beta.i = bet[i__5].i; - if (conj) { - rbeta = beta.r; - q__1.r = rbeta, q__1.i = 0.f; - beta.r = q__1.r, beta.i = q__1.i; - } - null = n <= 0; - if (conj) { - null = null || ((k <= 0 || (alpha.r == 0.f && - alpha.i == 0.f)) && rbeta == 1.f); - } - -/* Generate the matrix C. */ - - cmake_(sname + 7, uplo, " ", &n, &n, &c__[ - c_offset], nmax, &cc[1], &ldc, &reset, & - c_b1); - - ++nc; - -/* Save every datum before calling the subroutine. */ - - *(unsigned char *)uplos = *(unsigned char *)uplo; - *(unsigned char *)transs = *(unsigned char *) - trans; - ns = n; - ks = k; - als.r = alpha.r, als.i = alpha.i; - i__5 = laa; - for (i__ = 1; i__ <= i__5; ++i__) { - i__6 = i__; - i__7 = i__; - as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7] - .i; -/* L10: */ - } - ldas = lda; - i__5 = lbb; - for (i__ = 1; i__ <= i__5; ++i__) { - i__6 = i__; - i__7 = i__; - bs[i__6].r = bb[i__7].r, bs[i__6].i = bb[i__7] - .i; -/* L20: */ - } - ldbs = ldb; - if (conj) { - rbets = rbeta; - } else { - bets.r = beta.r, bets.i = beta.i; - } - i__5 = lcc; - for (i__ = 1; i__ <= i__5; ++i__) { - i__6 = i__; - i__7 = i__; - cs[i__6].r = cc[i__7].r, cs[i__6].i = cc[i__7] - .i; -/* L30: */ - } - ldcs = ldc; - -/* Call the subroutine. */ - - if (conj) { - if (*trace) { - cprcn7_(ntra, &nc, sname, iorder, uplo, - trans, &n, &k, &alpha, &lda, &ldb, - &rbeta, &ldc); - } - if (*rewi) { -/* al__1.aerr = 0; - al__1.aunit = *ntra; - f_rew(&al__1);*/ - } - ccher2k_(iorder, uplo, trans, &n, &k, &alpha, - &aa[1], &lda, &bb[1], &ldb, &rbeta, & - cc[1], &ldc); - } else { - if (*trace) { - cprcn5_(ntra, &nc, sname, iorder, uplo, - trans, &n, &k, &alpha, &lda, &ldb, - &beta, &ldc); - } - if (*rewi) { -/* al__1.aerr = 0; - al__1.aunit = *ntra; - f_rew(&al__1);*/ - } - ccsyr2k_(iorder, uplo, trans, &n, &k, &alpha, - &aa[1], &lda, &bb[1], &ldb, &beta, & - cc[1], &ldc); - } - -/* Check if error-exit was taken incorrectly. */ - - if (! infoc_1.ok) { - printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); - *fatal = TRUE_; - goto L150; - } - -/* See what data changed inside subroutines. */ - - isame[0] = *(unsigned char *)uplos == *(unsigned - char *)uplo; - isame[1] = *(unsigned char *)transs == *(unsigned - char *)trans; - isame[2] = ns == n; - isame[3] = ks == k; - isame[4] = als.r == alpha.r && als.i == alpha.i; - isame[5] = lce_(&as[1], &aa[1], &laa); - isame[6] = ldas == lda; - isame[7] = lce_(&bs[1], &bb[1], &lbb); - isame[8] = ldbs == ldb; - if (conj) { - isame[9] = rbets == rbeta; - } else { - isame[9] = bets.r == beta.r && bets.i == - beta.i; - } - if (null) { - isame[10] = lce_(&cs[1], &cc[1], &lcc); - } else { - isame[10] = lceres_("he", uplo, &n, &n, &cs[1] - , &cc[1], &ldc); - } - isame[11] = ldcs == ldc; - -/* If data was incorrectly changed, report and */ -/* return. */ - - same = TRUE_; - i__5 = nargs; - for (i__ = 1; i__ <= i__5; ++i__) { - same = same && isame[i__ - 1]; - if (! isame[i__ - 1]) { - printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); - } -/* L40: */ - } - if (! same) { - *fatal = TRUE_; - goto L150; - } - - if (! null) { - -/* Check the result column by column. */ - - if (conj) { - *(unsigned char *)transt = 'C'; - } else { - *(unsigned char *)transt = 'T'; - } - jjab = 1; - jc = 1; - i__5 = n; - for (j = 1; j <= i__5; ++j) { - if (upper) { - jj = 1; - lj = j; - } else { - jj = j; - lj = n - j + 1; - } - if (tran) { - i__6 = k; - for (i__ = 1; i__ <= i__6; ++i__) { - i__7 = i__; - i__8 = ((j - 1) << 1) * *nmax + k + - i__; - q__1.r = alpha.r * ab[i__8].r - - alpha.i * ab[i__8].i, - q__1.i = alpha.r * ab[ - i__8].i + alpha.i * ab[ - i__8].r; - w[i__7].r = q__1.r, w[i__7].i = - q__1.i; - if (conj) { - i__7 = k + i__; - r_cnjg(&q__2, &alpha); - i__8 = ((j - 1) << 1) * *nmax + i__; - q__1.r = q__2.r * ab[i__8].r - q__2.i * ab[i__8].i, - q__1.i = q__2.r * ab[i__8].i + q__2.i * ab[ - i__8].r; - w[i__7].r = q__1.r, w[i__7].i = q__1.i; - } else { - i__7 = k + i__; - i__8 = ((j - 1) << 1) * *nmax + i__; - q__1.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8] - .i, q__1.i = alpha.r * ab[i__8].i + alpha.i - * ab[i__8].r; - w[i__7].r = q__1.r, w[i__7].i = q__1.i; - } -/* L50: */ - } - i__6 = k << 1; - i__7 = *nmax << 1; - i__8 = *nmax << 1; - cmmch_(transt, "N", &lj, &c__1, &i__6, - &c_b2, &ab[jjab], &i__7, &w[ - 1], &i__8, &beta, &c__[jj + j - * c_dim1], nmax, &ct[1], &g[1] - , &cc[jc], &ldc, eps, &err, - fatal, nout, &c_true); - } else { - i__6 = k; - for (i__ = 1; i__ <= i__6; ++i__) { - if (conj) { - i__7 = i__; - r_cnjg(&q__2, &ab[(k + i__ - 1) * *nmax + j]); - q__1.r = alpha.r * q__2.r - alpha.i * q__2.i, - q__1.i = alpha.r * q__2.i + alpha.i * - q__2.r; - w[i__7].r = q__1.r, w[i__7].i = q__1.i; - i__7 = k + i__; - i__8 = (i__ - 1) * *nmax + j; - q__2.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8] - .i, q__2.i = alpha.r * ab[i__8].i + alpha.i - * ab[i__8].r; - r_cnjg(&q__1, &q__2); - w[i__7].r = q__1.r, w[i__7].i = q__1.i; - } else { - i__7 = i__; - i__8 = (k + i__ - 1) * *nmax + j; - q__1.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8] - .i, q__1.i = alpha.r * ab[i__8].i + alpha.i - * ab[i__8].r; - w[i__7].r = q__1.r, w[i__7].i = q__1.i; - i__7 = k + i__; - i__8 = (i__ - 1) * *nmax + j; - q__1.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8] - .i, q__1.i = alpha.r * ab[i__8].i + alpha.i - * ab[i__8].r; - w[i__7].r = q__1.r, w[i__7].i = q__1.i; - } -/* L60: */ - } - i__6 = k << 1; - i__7 = *nmax << 1; - cmmch_("N", "N", &lj, &c__1, &i__6, & - c_b2, &ab[jj], nmax, &w[1], & - i__7, &beta, &c__[jj + j * - c_dim1], nmax, &ct[1], &g[1], - &cc[jc], &ldc, eps, &err, - fatal, nout, &c_true); - } - if (upper) { - jc += ldc; - } else { - jc = jc + ldc + 1; - if (tran) { - jjab += *nmax << 1; - } - } - errmax = f2cmax(errmax,err); -/* If got really bad answer, report and */ -/* return. */ - if (*fatal) { - goto L140; - } -/* L70: */ - } - } - -/* L80: */ - } - -/* L90: */ - } - -/* L100: */ + pCd(z) = zdotc; +} +#else + _Complex double zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i 1) { - printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j); - } - -L150: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); - if (conj) { - cprcn7_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, & - ldb, &rbeta, &ldc); - } else { - cprcn5_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, & - ldb, &beta, &ldc); - } - -L160: - return 0; - -/* 9994 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ -/* $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',', F4.1, */ -/* $ ', C,', I3, ') .' ) */ -/* 9993 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ -/* $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1, */ -/* $ ',', F4.1, '), C,', I3, ') .' ) */ - -/* End of CCHK5. */ - -} /* cchk5_ */ - - -/* Subroutine */ int cprcn5_(integer *nout, integer *nc, char *sname, integer - *iorder, char *uplo, char *transa, integer *n, integer *k, complex * - alpha, integer *lda, integer *ldb, complex *beta, integer *ldc) -{ - - /* Local variables */ - char ca[14], cu[14], crc[14]; - - if (*(unsigned char *)uplo == 'U') { - s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); - } else { - s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); - } - if (*(unsigned char *)transa == 'N') { - s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); - } else if (*(unsigned char *)transa == 'T') { - s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); - } else { - s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); - } - if (*iorder == 1) { - s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); - } else { - s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); - } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); - printf("%d %d (%4.1f,%4.1f) , A, %d, B, %d, (%4.1f,%4.1f) , C, %d.\n",*n,*k,alpha->r,alpha->i,*lda,*ldb,beta->r,beta->i,*ldc); - return 0; -} /* cprcn5_ */ - - - -/* Subroutine */ int cprcn7_(integer *nout, integer *nc, char *sname, integer - *iorder, char *uplo, char *transa, integer *n, integer *k, complex * - alpha, integer *lda, integer *ldb, real *beta, integer *ldc) -{ - - /* Local variables */ - char ca[14], cu[14], crc[14]; - - if (*(unsigned char *)uplo == 'U') { - s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); - } else { - s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); - } - if (*(unsigned char *)transa == 'N') { - s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); - } else if (*(unsigned char *)transa == 'T') { - s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); - } else { - s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); - } - if (*iorder == 1) { - s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); - } else { - s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); - } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); - printf("%d %d (%4.1f,%4.1f), A, %d, B, %d, %4.1f, C, %d.\n",*n,*k,alpha->r,alpha->i,*lda,*ldb,*beta,*ldc); - return 0; -} /* cprcn7_ */ - - -/* Subroutine */ int cmake_(char *type__, char *uplo, char *diag, integer *m, - integer *n, complex *a, integer *nmax, complex *aa, integer *lda, - logical *reset, complex *transl) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - real r__1; - complex q__1, q__2; - - /* Local variables */ - extern /* Complex */ VOID cbeg_(complex *, logical *); - integer ibeg, iend; - logical unit; - integer i__, j; - logical lower, upper; - integer jj; - logical gen, her, tri, sym; - - -/* Generates values for an M by N matrix A. */ -/* Stores the values in the array AA in the data structure required */ -/* by the routine, with unwanted elements set to rogue value. */ - -/* TYPE is 'ge', 'he', 'sy' or 'tr'. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - - /* Parameter adjustments */ - a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --aa; - - /* Function Body */ - gen = s_cmp(type__, "ge", (ftnlen)2, (ftnlen)2) == 0; - her = s_cmp(type__, "he", (ftnlen)2, (ftnlen)2) == 0; - sym = s_cmp(type__, "sy", (ftnlen)2, (ftnlen)2) == 0; - tri = s_cmp(type__, "tr", (ftnlen)2, (ftnlen)2) == 0; - upper = (her || sym || tri) && *(unsigned char *)uplo == 'U'; - lower = (her || sym || tri) && *(unsigned char *)uplo == 'L'; - unit = tri && *(unsigned char *)diag == 'U'; - -/* Generate data in array A. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - if (gen || (upper && i__ <= j) || (lower && i__ >= j)) { - i__3 = i__ + j * a_dim1; - cbeg_(&q__2, reset); - q__1.r = q__2.r + transl->r, q__1.i = q__2.i + transl->i; - a[i__3].r = q__1.r, a[i__3].i = q__1.i; - if (i__ != j) { -/* Set some elements to zero */ - if (*n > 3 && j == *n / 2) { - i__3 = i__ + j * a_dim1; - a[i__3].r = 0.f, a[i__3].i = 0.f; - } - if (her) { - i__3 = j + i__ * a_dim1; - r_cnjg(&q__1, &a[i__ + j * a_dim1]); - a[i__3].r = q__1.r, a[i__3].i = q__1.i; - } else if (sym) { - i__3 = j + i__ * a_dim1; - i__4 = i__ + j * a_dim1; - a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i; - } else if (tri) { - i__3 = j + i__ * a_dim1; - a[i__3].r = 0.f, a[i__3].i = 0.f; - } + } else { + for (i=0;ir * ct[i__4].r - alpha->i * ct[i__4].i, q__2.i = - alpha->r * ct[i__4].i + alpha->i * ct[i__4].r; - i__5 = i__ + j * c_dim1; - q__3.r = beta->r * c__[i__5].r - beta->i * c__[i__5].i, q__3.i = - beta->r * c__[i__5].i + beta->i * c__[i__5].r; - q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; - ct[i__3].r = q__1.r, ct[i__3].i = q__1.i; - i__3 = i__ + j * c_dim1; - g[i__] = ((r__1 = alpha->r, abs(r__1)) + (r__2 = r_imag(alpha), - abs(r__2))) * g[i__] + ((r__3 = beta->r, abs(r__3)) + ( - r__4 = r_imag(beta), abs(r__4))) * ((r__5 = c__[i__3].r, - abs(r__5)) + (r__6 = r_imag(&c__[i__ + j * c_dim1]), abs( - r__6))); -/* L200: */ - } - -/* Compute the error ratio for this result. */ - - *err = 0.f; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__; - i__4 = i__ + j * cc_dim1; - q__2.r = ct[i__3].r - cc[i__4].r, q__2.i = ct[i__3].i - cc[i__4] - .i; - q__1.r = q__2.r, q__1.i = q__2.i; - erri = ((r__1 = q__1.r, abs(r__1)) + (r__2 = r_imag(&q__1), abs( - r__2))) / *eps; - if (g[i__] != 0.f) { - erri /= g[i__]; - } - *err = f2cmax(*err,erri); - if (*err * sqrt(*eps) >= 1.f) { - goto L230; - } -/* L210: */ } - -/* L220: */ - } - -/* If the loop completes, all results are at least half accurate. */ - goto L250; - -/* Report fatal error. */ - -L230: - *fatal = TRUE_; - printf(" ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HALF ACCURATE *******\n"); - printf(" EXPECTED RESULT COMPUTED RESULT\n"); - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - if (*mv) { - printf("%7d (%15.6g,%15.6g) (%15.6g,%15.6g)\n",i__,ct[i__].r,ct[i__].i,cc[i__+j*cc_dim1].r,cc[i__+j*cc_dim1].i); + pCf(z) = zdotc; +} +#endif +static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Dcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i 1) { - printf(" THESE ARE THE RESULTS FOR COLUMN %d\n",j); - } - -L250: - return 0; - - -/* End of CMMCH. */ - -} /* cmmch_ */ - -logical lce_(complex *ri, complex *rj, integer *lr) -{ - /* System generated locals */ - integer i__1, i__2, i__3; - logical ret_val; - - /* Local variables */ - integer i__; - - -/* Tests if two arrays are identical. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - - /* Parameter adjustments */ - --rj; - --ri; - - /* Function Body */ - i__1 = *lr; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__; - i__3 = i__; - if (ri[i__2].r != rj[i__3].r || ri[i__2].i != rj[i__3].i) { - goto L20; - } -/* L10: */ - } - ret_val = TRUE_; - goto L30; -L20: - ret_val = FALSE_; -L30: - return ret_val; - -/* End of LCE. */ - -} /* lce_ */ - -logical lceres_(char *type__, char *uplo, integer *m, integer *n, complex *aa, - complex *as, integer *lda) -{ - /* System generated locals */ - integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2, i__3, i__4; - logical ret_val; - - /* Local variables */ - integer ibeg, iend, i__, j; - logical upper; - - -/* Tests if selected elements in two arrays are equal. */ - -/* TYPE is 'ge' or 'he' or 'sy'. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - - /* Parameter adjustments */ - as_dim1 = *lda; - as_offset = 1 + as_dim1 * 1; - as -= as_offset; - aa_dim1 = *lda; - aa_offset = 1 + aa_dim1 * 1; - aa -= aa_offset; - - /* Function Body */ - upper = *(unsigned char *)uplo == 'U'; - if (s_cmp(type__, "ge", (ftnlen)2, (ftnlen)2) == 0) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *lda; - for (i__ = *m + 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * aa_dim1; - i__4 = i__ + j * as_dim1; - if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) { - goto L70; + for (i=0;i= 5) { - ic = 0; - goto L10; - } - r__1 = (i__ - 500) / 1001.f; - r__2 = (j - 500) / 1001.f; - q__1.r = r__1, q__1.i = r__2; - ret_val->r = q__1.r, ret_val->i = q__1.i; - return ; - -/* End of CBEG. */ - -} /* cbeg_ */ - -real sdiff_(real *x, real *y) -{ - /* System generated locals */ - real ret_val; - - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - - ret_val = *x - *y; - return ret_val; + pCd(z) = zdotc; +} +#endif +/* -- translated by f2c (version 20000121). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ -/* End of SDIFF. */ -} /* sdiff_ */ -/* Main program alias */ /*int cblat3_ () { MAIN__ (); return 0; }*/ diff --git a/ctest/c_dblat3c.c b/ctest/c_dblat3c.c index dc3d6f9e7..447b23014 100644 --- a/ctest/c_dblat3c.c +++ b/ctest/c_dblat3c.c @@ -10,7 +10,25 @@ #undef I #endif -#include "common.h" +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif typedef blasint integer; @@ -229,6 +247,7 @@ typedef struct Namelist Namelist; #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } #define sig_die(s, kill) { exit(1); } #define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; #define z_abs(z) (cabs(Cd(z))) #define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} #define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} @@ -242,3098 +261,251 @@ typedef struct Namelist Namelist; /* procedure parameter types for -A and -C++ */ #define F2C_proc_par_types 1 - - -/* Common Block Declarations */ - -struct { - integer infot, noutc; - logical ok; -} infoc_; - -#define infoc_1 infoc_ - -struct { - char srnamt[12]; -} srnamc_; - -#define srnamc_1 srnamc_ - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c__65 = 65; -static doublereal c_b90 = 1.; -static doublereal c_b104 = 0.; -static integer c__6 = 6; -static logical c_true = TRUE_; -static integer c__0 = 0; -static logical c_false = FALSE_; - -/* Main program MAIN__() */ int main(void) -{ - /* Initialized data */ - - static char snames[6][13] = {"cblas_dgemm ", "cblas_dsymm ", "cblas_dtrmm ", "cblas_dtrsm ", "cblas_dsyrk ", "cblas_dsyr2k"}; - - /* System generated locals */ - integer i__1, i__2, i__3; - doublereal d__1; - - - /* Local variables */ - static integer nalf, idim[9]; - static logical same; - static integer nbet, ntra; - static logical rewi; - extern /* Subroutine */ int dchk1_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, integer*, ftnlen); - extern /* Subroutine */ int dchk2_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, integer*, ftnlen); - extern /* Subroutine */ int dchk3_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, integer*, ftnlen); - extern /* Subroutine */ int dchk4_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, integer*, ftnlen); -/* Subroutine */ int dchk5_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublereal* alf, integer* nbet, doublereal* bet, integer* nmax, doublereal* ab, doublereal* aa, doublereal* as, doublereal* bb, doublereal* bs, doublereal* c__, doublereal* cc, doublereal* cs, doublereal* ct, doublereal* g, doublereal* w, integer* iorder, ftnlen sname_len); - static doublereal c__[4225] /* was [65][65] */, g[65]; - static integer i__, j; - extern doublereal ddiff_(doublereal*, doublereal*); - static integer n; - static logical fatal; - static doublereal w[130]; - extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); - static logical trace; - static integer nidim; - static char snaps[32]; - static integer isnum; - static logical ltest[6]; - static doublereal aa[4225], ab[8450] /* was [65][130] */, bb[4225], - cc[4225], as[4225], bs[4225], cs[4225], ct[65]; - static logical sfatal, corder; - static char snamet[12], transa[1], transb[1]; - static doublereal thresh; - static logical rorder; - extern /* Subroutine */ void cd3chke_(char*, ftnlen); - static integer layout; - static logical ltestt, tsterr; - static doublereal alf[7]; - extern logical lde_(doublereal*, doublereal*, integer*); - static doublereal bet[7], eps, err; - char tmpchar; - -/* Test program for the DOUBLE PRECISION Level 3 Blas. */ - -/* The program must be driven by a short data file. The first 13 records */ -/* of the file are read using list-directed input, the last 6 records */ -/* are read using the format ( A12, L2 ). An annotated example of a data */ -/* file can be obtained by deleting the first 3 characters from the */ -/* following 19 lines: */ -/* 'DBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE */ -/* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) */ -/* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. */ -/* F LOGICAL FLAG, T TO STOP ON FAILURES. */ -/* T LOGICAL FLAG, T TO TEST ERROR EXITS. */ -/* 2 0 TO TEST COLUMN-MAJOR, 1 TO TEST ROW-MAJOR, 2 TO TEST BOTH */ -/* 16.0 THRESHOLD VALUE OF TEST RATIO */ -/* 6 NUMBER OF VALUES OF N */ -/* 0 1 2 3 5 9 VALUES OF N */ -/* 3 NUMBER OF VALUES OF ALPHA */ -/* 0.0 1.0 0.7 VALUES OF ALPHA */ -/* 3 NUMBER OF VALUES OF BETA */ -/* 0.0 1.0 1.3 VALUES OF BETA */ -/* cblas_dgemm T PUT F FOR NO TEST. SAME COLUMNS. */ -/* cblas_dsymm T PUT F FOR NO TEST. SAME COLUMNS. */ -/* cblas_dtrmm T PUT F FOR NO TEST. SAME COLUMNS. */ -/* cblas_dtrsm T PUT F FOR NO TEST. SAME COLUMNS. */ -/* cblas_dsyrk T PUT F FOR NO TEST. SAME COLUMNS. */ -/* cblas_dsyr2k T PUT F FOR NO TEST. SAME COLUMNS. */ - -/* See: */ - -/* Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. */ -/* A Set of Level 3 Basic Linear Algebra Subprograms. */ - -/* Technical Memorandum No.88 (Revision 1), Mathematics and */ -/* Computer Science Division, Argonne National Laboratory, 9700 */ -/* South Cass Avenue, Argonne, Illinois 60439, US. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Parameters .. */ -/* .. Local Scalars .. */ -/* .. Local Arrays .. */ -/* .. External Functions .. */ -/* .. External Subroutines .. */ -/* .. Intrinsic Functions .. */ -/* .. Scalars in Common .. */ -/* .. Common blocks .. */ -/* .. Data statements .. */ -/* .. Executable Statements .. */ - -/* Read name and unit number for summary output file and open file. */ - - infoc_1.noutc = 6; -/* Read name and unit number for snapshot output file and open file. */ - - char line[80]; - - fgets(line,80,stdin); - sscanf(line,"'%s'",snaps); - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&ntra); -#else - sscanf(line,"%d",&ntra); -#endif - trace = ntra >= 0; - if (trace) { -/* o__1.oerr = 0; - o__1.ounit = ntra; - o__1.ofnmlen = 32; - o__1.ofnm = snaps; - o__1.orl = 0; - o__1.osta = "NEW"; - o__1.oacc = 0; - o__1.ofm = 0; - o__1.oblnk = 0; - f_open(&o__1);*/ - } -/* Read the flag that directs rewinding of the snapshot file. */ - fgets(line,80,stdin); - sscanf(line,"%d",&rewi); - rewi = rewi && trace; -/* Read the flag that directs stopping on any failure. */ - fgets(line,80,stdin); - sscanf(line,"%c",&tmpchar); -/* Read the flag that indicates whether error exits are to be tested. */ - sfatal=FALSE_; - if (tmpchar=='T')sfatal=TRUE_; - fgets(line,80,stdin); - sscanf(line,"%c",&tmpchar); -/* Read the flag that indicates whether error exits are to be tested. */ - tsterr=FALSE_; - if (tmpchar=='T')tsterr=TRUE_; -/* Read the flag that indicates whether row-major data layout to be tested. */ - fgets(line,80,stdin); - sscanf(line,"%d",&layout); -/* Read the threshold value of the test ratio */ - fgets(line,80,stdin); - sscanf(line,"%lf",&thresh); -/* Read and check the parameter values for the tests. */ - -/* Values of N */ - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&nidim); -#else - sscanf(line,"%d",&nidim); -#endif - - if (nidim < 1 || nidim > 9) { - fprintf(stderr,"NUMBER OF VALUES OF N IS LESS THAN 1 OR GREATER THAN 9"); - goto L220; - } - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld %ld %ld %ld %ld %ld %ld %ld %ld",&idim[0],&idim[1],&idim[2], - &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]); -#else - sscanf(line,"%d %d %d %d %d %d %d %d %d",&idim[0],&idim[1],&idim[2], - &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]); -#endif - i__1 = nidim; - for (i__ = 1; i__ <= i__1; ++i__) { - if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) { - fprintf(stderr,"VALUE OF N IS LESS THAN 0 OR GREATER THAN 65\n"); - goto L220; - } -/* L10: */ - } -/* Values of ALPHA */ - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&nalf); -#else - sscanf(line,"%d",&nalf); -#endif - if (nalf < 1 || nalf > 7) { - fprintf(stderr,"VALUE OF ALPHA IS LESS THAN 0 OR GREATER THAN 7\n"); - goto L220; - } - fgets(line,80,stdin); - sscanf(line,"%lf %lf %lf %lf %lf %lf %lf",&alf[0],&alf[1],&alf[2],&alf[3],&alf[4],&alf[5],&alf[6]); - -/* Values of BETA */ - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&nbet); +#ifdef __cplusplus +typedef logical (*L_fp)(...); #else - sscanf(line,"%d",&nbet); +typedef logical (*L_fp)(); #endif - if (nalf < 1 || nbet > 7) { - fprintf(stderr,"VALUE OF BETA IS LESS THAN 0 OR GREATER THAN 7\n"); - goto L220; - } - fgets(line,80,stdin); - sscanf(line,"%lf %lf %lf %lf %lf %lf %lf",&bet[0],&bet[1],&bet[2],&bet[3],&bet[4],&bet[5],&bet[6]); - -/* Report values of parameters. */ - - printf("TESTS OF THE DOUBLE PRECISION LEVEL 3 BLAS\nTHE FOLLOWING PARAMETER VALUES WILL BE USED:\n"); - printf(" FOR N"); - for (i__ =1; i__ <=nidim;++i__) printf(" %d",idim[i__-1]); - printf("\n"); - printf(" FOR ALPHA"); - for (i__ =1; i__ <=nalf;++i__) printf(" %f",alf[i__-1]); - printf("\n"); - printf(" FOR BETA"); - for (i__ =1; i__ <=nbet;++i__) printf(" %f",bet[i__-1]); - printf("\n"); - - if (! tsterr) { - printf(" ERROR-EXITS WILL NOT BE TESTED\n"); - } - printf("ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LESS THAN %f\n",thresh); - - rorder = FALSE_; - corder = FALSE_; - if (layout == 2) { - rorder = TRUE_; - corder = TRUE_; - printf("COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED\n"); - } else if (layout == 1) { - rorder = TRUE_; - printf("ROW-MAJOR DATA LAYOUT IS TESTED\n"); - } else if (layout == 0) { - corder = TRUE_; - printf("COLUMN-MAJOR DATA LAYOUT IS TESTED\n"); - } - -/* Read names of subroutines and flags which indicate */ -/* whether they are to be tested. */ - - for (i__ = 1; i__ <= 6; ++i__) { - ltest[i__ - 1] = FALSE_; -/* L20: */ - } -L30: - if (! fgets(line,80,stdin)) { - goto L60; - } - i__1 = sscanf(line,"%12c %c",snamet,&tmpchar); - ltestt=FALSE_; - if (tmpchar=='T')ltestt=TRUE_; - if (i__1 < 2) { - goto L60; - } - for (i__ = 1; i__ <= 6; ++i__) { - if (s_cmp(snamet, snames[i__ - 1] , (ftnlen)12, (ftnlen)12) == - 0) { - goto L50; - } -/* L40: */ - } - printf("SUBPROGRAM NAME %s NOT RECOGNIZED\n****** TESTS ABANDONED ******\n",snamet); - exit(1); - - -L50: - ltest[i__ - 1] = ltestt; - goto L30; - -L60: -/* cl__1.cerr = 0; - cl__1.cunit = 5; - cl__1.csta = 0; - f_clos(&cl__1);*/ - -/* Compute EPS (the machine precision). */ - - eps = 1.; -L70: - d__1 = eps + 1.; - if (ddiff_(&d__1, &c_b90) == 0.) { - goto L80; - } - eps *= .5; - goto L70; -L80: - eps += eps; - printf("RELATIVE MACHINE PRECISION IS TAKEN TO BE %9.1g\n",eps); - -/* Check the reliability of DMMCH using exact data. */ - - n = 32; - i__1 = n; - for (j = 1; j <= i__1; ++j) { - i__2 = n; - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - i__3 = i__ - j + 1; - ab[i__ + j * 65 - 66] = (doublereal) f2cmax(i__3,0); -/* L90: */ - } - ab[j + 4224] = (doublereal) j; - ab[(j + 65) * 65 - 65] = (doublereal) j; - c__[j - 1] = 0.; -/* L100: */ - } - i__1 = n; - for (j = 1; j <= i__1; ++j) { - cc[j - 1] = (doublereal) (j * ((j + 1) * j) / 2 - (j + 1) * j * (j - - 1) / 3); -/* L110: */ - } -/* CC holds the exact result. On exit from DMMCH CT holds */ -/* the result computed by DMMCH. */ - *(unsigned char *)transa = 'N'; - *(unsigned char *)transb = 'N'; - dmmch_(transa, transb, &n, &c__1, &n, &c_b90, ab, &c__65, &ab[4225], & - c__65, &c_b104, c__, &c__65, ct, g, cc, &c__65, &eps, &err, & - fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1); - same = lde_(cc, ct, &n); - if (! same || err != 0.) { - printf("ERROR IN DMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); - printf("DMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); - printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); - printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); - printf("****** TESTS ABANDONED ******\n"); - exit(1); - } - *(unsigned char *)transb = 'T'; - dmmch_(transa, transb, &n, &c__1, &n, &c_b90, ab, &c__65, &ab[4225], & - c__65, &c_b104, c__, &c__65, ct, g, cc, &c__65, &eps, &err, & - fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1); - same = lde_(cc, ct, &n); - if (! same || err != 0.) { - printf("ERROR IN DMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); - printf("DMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); - printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); - printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); - printf("****** TESTS ABANDONED ******\n"); - exit(1); - } - i__1 = n; - for (j = 1; j <= i__1; ++j) { - ab[j + 4224] = (doublereal) (n - j + 1); - ab[(j + 65) * 65 - 65] = (doublereal) (n - j + 1); -/* L120: */ - } - i__1 = n; - for (j = 1; j <= i__1; ++j) { - cc[n - j] = (doublereal) (j * ((j + 1) * j) / 2 - (j + 1) * j * (j - - 1) / 3); -/* L130: */ - } - *(unsigned char *)transa = 'T'; - *(unsigned char *)transb = 'N'; - dmmch_(transa, transb, &n, &c__1, &n, &c_b90, ab, &c__65, &ab[4225], & - c__65, &c_b104, c__, &c__65, ct, g, cc, &c__65, &eps, &err, & - fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1); - same = lde_(cc, ct, &n); - if (! same || err != 0.) { - printf("ERROR IN DMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); - printf("DMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); - printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); - printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); - printf("****** TESTS ABANDONED ******\n"); - exit(1); - } - *(unsigned char *)transb = 'T'; - dmmch_(transa, transb, &n, &c__1, &n, &c_b90, ab, &c__65, &ab[4225], & - c__65, &c_b104, c__, &c__65, ct, g, cc, &c__65, &eps, &err, & - fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1); - same = lde_(cc, ct, &n); - if (! same || err != 0.) { - } - -/* Test each subroutine in turn. */ - - for (isnum = 1; isnum <= 6; ++isnum) { - if (! ltest[isnum - 1]) { -/* Subprogram is not to be tested. */ - printf("%12s WAS NOT TESTED\n",snames[isnum-1]); - } else { - s_copy(srnamc_1.srnamt, snames[isnum - 1], (ftnlen)12, ( - ftnlen)12); -/* Test error exits. */ - if (tsterr) { - cd3chke_(snames[isnum - 1], (ftnlen)12); - } -/* Test computations. */ - infoc_1.infot = 0; - infoc_1.ok = TRUE_; - fatal = FALSE_; - switch ((int)isnum) { - case 1: goto L140; - case 2: goto L150; - case 3: goto L160; - case 4: goto L160; - case 5: goto L170; - case 6: goto L180; - } -/* Test DGEMM, 01. */ -L140: - if (corder) { - dchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__0, (ftnlen)12); - } - if (rorder) { - dchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__1, (ftnlen)12); - } - goto L190; -/* Test DSYMM, 02. */ -L150: - if (corder) { - dchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__0, (ftnlen)12); - } - if (rorder) { - dchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__1, (ftnlen)12); - } - goto L190; -/* Test DTRMM, 03, DTRSM, 04. */ -L160: - if (corder) { - dchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, & - c__0, (ftnlen)12); - } - if (rorder) { - dchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, & - c__1, (ftnlen)12); - } - goto L190; -/* Test DSYRK, 05. */ -L170: - if (corder) { - dchk4_(snames[isnum -1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__0, (ftnlen)12); - } - if (rorder) { - dchk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__1, (ftnlen)12); - } - goto L190; -/* Test DSYR2K, 06. */ -L180: - if (corder) { - dchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, - ct, g, w, &c__0, (ftnlen)12); - } - if (rorder) { - dchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, - ct, g, w, &c__1, (ftnlen)12); - } - goto L190; - -L190: - if (fatal && sfatal) { - goto L210; - } - } -/* L200: */ - } - printf("\nEND OF TESTS\n"); - goto L230; - -L210: - printf("\n****** FATAL ERROR - TESTS ABANDONED ******\n"); - goto L230; - -L220: - printf("AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM\n"); - printf("****** TESTS ABANDONED ******\n"); - -L230: - if (trace) { -/* cl__1.cerr = 0; - cl__1.cunit = ntra; - cl__1.csta = 0; - f_clos(&cl__1);*/ - } -/* cl__1.cerr = 0; - cl__1.cunit = 6; - cl__1.csta = 0; - f_clos(&cl__1);*/ - exit(0); -/* End of DBLAT3. */ - -} /* MAIN__ */ - -/* Subroutine */ int dchk1_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublereal* alf, integer* nbet, doublereal* bet, integer* nmax, doublereal* a, doublereal* aa, doublereal* as, doublereal* b, doublereal* bb, doublereal* bs, doublereal* c__, doublereal* cc, doublereal* cs, doublereal* ct, doublereal* g, integer* iorder, ftnlen sname_len) -{ - /* Initialized data */ - - static char ich[3+1] = "NTC"; - - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3, i__4, i__5, i__6; - - - /* Local variables */ - static doublereal beta; - static integer ldas, ldbs, ldcs; - static logical same, null; - static integer i__, k, m, n; - extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*, ftnlen, ftnlen, ftnlen); - static doublereal alpha; - extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); - static logical isame[13], trana, tranb; - static integer nargs; - static logical reset; - extern /* Subroutine */ void dprcn1_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, integer*, doublereal*, integer*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen); - static integer ia, ib, ma, mb, na, nb, nc, ik, im, in; - extern /* Subroutine */ void cdgemm_(integer*, char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen); - static integer ks, ms, ns; - extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen); - static char tranas[1], tranbs[1], transa[1], transb[1]; - static doublereal errmax; - static integer ica, icb, laa, lbb, lda, lcc, ldb, ldc; - extern logical lde_(doublereal*, doublereal*, integer*); - static doublereal als, bls, err; - -/* Tests DGEMM. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Parameters .. */ -/* .. Scalar Arguments .. */ -/* .. Array Arguments .. */ -/* .. Local Scalars .. */ -/* .. Local Arrays .. */ -/* .. External Functions .. */ -/* .. External Subroutines .. */ -/* .. Intrinsic Functions .. */ -/* .. Scalars in Common .. */ -/* .. Common blocks .. */ -/* .. Data statements .. */ - /* Parameter adjustments */ - --idim; - --alf; - --bet; - --g; - --ct; - --cs; - --cc; - c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - --bs; - --bb; - b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; - b -= b_offset; - --as; - --aa; - a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - - /* Function Body */ -/* .. Executable Statements .. */ - - nargs = 13; - nc = 0; - reset = TRUE_; - errmax = 0.; - - i__1 = *nidim; - for (im = 1; im <= i__1; ++im) { - m = idim[im]; - - i__2 = *nidim; - for (in = 1; in <= i__2; ++in) { - n = idim[in]; -/* Set LDC to 1 more than minimum value if room. */ - ldc = m; - if (ldc < *nmax) { - ++ldc; - } -/* Skip tests if not enough room. */ - if (ldc > *nmax) { - goto L100; - } - lcc = ldc * n; - null = n <= 0 || m <= 0; - - i__3 = *nidim; - for (ik = 1; ik <= i__3; ++ik) { - k = idim[ik]; - - for (ica = 1; ica <= 3; ++ica) { - *(unsigned char *)transa = *(unsigned char *)&ich[ica - 1] - ; - trana = *(unsigned char *)transa == 'T' || *(unsigned - char *)transa == 'C'; - - if (trana) { - ma = k; - na = m; - } else { - ma = m; - na = k; - } -/* Set LDA to 1 more than minimum value if room. */ - lda = ma; - if (lda < *nmax) { - ++lda; - } -/* Skip tests if not enough room. */ - if (lda > *nmax) { - goto L80; - } - laa = lda * na; - -/* Generate the matrix A. */ - - dmake_("GE", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[ - 1], &lda, &reset, &c_b104, (ftnlen)2, (ftnlen)1, ( - ftnlen)1); - - for (icb = 1; icb <= 3; ++icb) { - *(unsigned char *)transb = *(unsigned char *)&ich[icb - - 1]; - tranb = *(unsigned char *)transb == 'T' || *(unsigned - char *)transb == 'C'; - - if (tranb) { - mb = n; - nb = k; - } else { - mb = k; - nb = n; - } -/* Set LDB to 1 more than minimum value if room. */ - ldb = mb; - if (ldb < *nmax) { - ++ldb; - } -/* Skip tests if not enough room. */ - if (ldb > *nmax) { - goto L70; - } - lbb = ldb * nb; - -/* Generate the matrix B. */ - - dmake_("GE", " ", " ", &mb, &nb, &b[b_offset], nmax, & - bb[1], &ldb, &reset, &c_b104, (ftnlen)2, ( - ftnlen)1, (ftnlen)1); - - i__4 = *nalf; - for (ia = 1; ia <= i__4; ++ia) { - alpha = alf[ia]; - - i__5 = *nbet; - for (ib = 1; ib <= i__5; ++ib) { - beta = bet[ib]; - -/* Generate the matrix C. */ - - dmake_("GE", " ", " ", &m, &n, &c__[c_offset], - nmax, &cc[1], &ldc, &reset, &c_b104, - (ftnlen)2, (ftnlen)1, (ftnlen)1); - - ++nc; - -/* Save every datum before calling the */ -/* subroutine. */ - - *(unsigned char *)tranas = *(unsigned char *) - transa; - *(unsigned char *)tranbs = *(unsigned char *) - transb; - ms = m; - ns = n; - ks = k; - als = alpha; - i__6 = laa; - for (i__ = 1; i__ <= i__6; ++i__) { - as[i__] = aa[i__]; -/* L10: */ - } - ldas = lda; - i__6 = lbb; - for (i__ = 1; i__ <= i__6; ++i__) { - bs[i__] = bb[i__]; -/* L20: */ - } - ldbs = ldb; - bls = beta; - i__6 = lcc; - for (i__ = 1; i__ <= i__6; ++i__) { - cs[i__] = cc[i__]; -/* L30: */ - } - ldcs = ldc; - -/* Call the subroutine. */ - - if (*trace) { - dprcn1_(ntra, &nc, sname, iorder, transa, - transb, &m, &n, &k, &alpha, &lda, - &ldb, &beta, &ldc, (ftnlen)12, ( - ftnlen)1, (ftnlen)1); - } - if (*rewi) { -/* al__1.aerr = 0; - al__1.aunit = *ntra; - f_rew(&al__1);*/ - } - cdgemm_(iorder, transa, transb, &m, &n, &k, & - alpha, &aa[1], &lda, &bb[1], &ldb, & - beta, &cc[1], &ldc, (ftnlen)1, ( - ftnlen)1); - -/* Check if error-exit was taken incorrectly. */ - - if (! infoc_1.ok) { - printf(" *** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); - *fatal = TRUE_; - goto L120; - } - -/* See what data changed inside subroutines. */ - - isame[0] = *(unsigned char *)transa == *( - unsigned char *)tranas; - isame[1] = *(unsigned char *)transb == *( - unsigned char *)tranbs; - isame[2] = ms == m; - isame[3] = ns == n; - isame[4] = ks == k; - isame[5] = als == alpha; - isame[6] = lde_(&as[1], &aa[1], &laa); - isame[7] = ldas == lda; - isame[8] = lde_(&bs[1], &bb[1], &lbb); - isame[9] = ldbs == ldb; - isame[10] = bls == beta; - if (null) { - isame[11] = lde_(&cs[1], &cc[1], &lcc); - } else { - isame[11] = lderes_("GE", " ", &m, &n, & - cs[1], &cc[1], &ldc, (ftnlen)2, ( - ftnlen)1); - } - isame[12] = ldcs == ldc; - -/* If data was incorrectly changed, report */ -/* and return. */ - - same = TRUE_; - i__6 = nargs; - for (i__ = 1; i__ <= i__6; ++i__) { - same = same && isame[i__ - 1]; - if (! isame[i__ - 1]) { - printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); - } -/* L40: */ - } - if (! same) { - *fatal = TRUE_; - goto L120; - } - - if (! null) { - -/* Check the result. */ - - dmmch_(transa, transb, &m, &n, &k, &alpha, - &a[a_offset], nmax, &b[b_offset], - nmax, &beta, &c__[c_offset], - nmax, &ct[1], &g[1], &cc[1], &ldc, - eps, &err, fatal, nout, &c_true, - (ftnlen)1, (ftnlen)1); - errmax = f2cmax(errmax,err); -/* If got really bad answer, report and */ -/* return. */ - if (*fatal) { - goto L120; - } - } - -/* L50: */ - } - -/* L60: */ - } - -L70: - ; - } - -L80: - ; +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; } - -/* L90: */ - } - -L100: - ; } - -/* L110: */ - } - -/* Report result. */ - - if (errmax < *thresh) { - if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); - } - if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); - } - } else { - if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); - } - if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); - } - } - goto L130; - -L120: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); - dprcn1_(nout, &nc, sname, iorder, transa, transb, &m, &n, &k, &alpha, & - lda, &ldb, &beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); - -L130: - return 0; - -/* 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',', */ -/* $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ', */ -/* $ 'C,', I3, ').' ) */ - -/* End of DCHK1. */ - -} /* dchk1_ */ - -/* Subroutine */ void dprcn1_(integer* nout, integer* nc, char* sname, integer* iorder, char* transa, char* transb, integer* m, integer* n, integer* k, doublereal* alpha, integer* lda, integer* ldb, doublereal* beta, integer* ldc, ftnlen sname_len, ftnlen transa_len, ftnlen transb_len) -{ - - /* Local variables */ - static char crc[14], cta[14], ctb[14]; - - if (*(unsigned char *)transa == 'N') { - s_copy(cta, " CblasNoTrans", (ftnlen)14, (ftnlen)14); - } else if (*(unsigned char *)transa == 'T') { - s_copy(cta, " CblasTrans", (ftnlen)14, (ftnlen)14); - } else { - s_copy(cta, "CblasConjTrans", (ftnlen)14, (ftnlen)14); - } - if (*(unsigned char *)transb == 'N') { - s_copy(ctb, " CblasNoTrans", (ftnlen)14, (ftnlen)14); - } else if (*(unsigned char *)transb == 'T') { - s_copy(ctb, " CblasTrans", (ftnlen)14, (ftnlen)14); - } else { - s_copy(ctb, "CblasConjTrans", (ftnlen)14, (ftnlen)14); - } - if (*iorder == 1) { - s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); - } else { - s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); - } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cta,ctb); - printf("%d %d %d %4.1f A, %d, B, %d, %4.1f, C, %d.\n",*m,*n,*k,*alpha,*lda,*ldb,*beta,*ldc); -} /* dprcn1_ */ - - -/* Subroutine */ int dchk2_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublereal* alf, integer* nbet, doublereal* bet, integer* nmax, doublereal* a, doublereal* aa, doublereal* as, doublereal* b, doublereal* bb, doublereal* bs, doublereal* c__, doublereal* cc, doublereal* cs, doublereal* ct, doublereal* g, integer* iorder, ftnlen sname_len) -{ - /* Initialized data */ - - static char ichs[2+1] = "LR"; - static char ichu[2+1] = "UL"; - - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3, i__4, i__5; - - - /* Local variables */ - static doublereal beta; - static integer ldas, ldbs, ldcs; - static logical same; - static char side[1]; - static logical left, null; - static char uplo[1]; - static integer i__, m, n; - extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*, ftnlen, ftnlen, ftnlen); - static doublereal alpha; - extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); - static logical isame[13]; - static char sides[1]; - static integer nargs; - static logical reset; - static char uplos[1]; - extern /* Subroutine */ void dprcn2_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublereal*, integer*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen); - static integer ia, ib, na, nc, im, in, ms, ns; - extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen); - extern /* Subroutine */ void cdsymm_(integer*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen); - static doublereal errmax; - static integer laa, lbb, lda, lcc, ldb, ldc; - extern logical lde_(doublereal*, doublereal*, integer*); - static integer ics; - static doublereal als, bls; - static integer icu; - static doublereal err; - -/* Tests DSYMM. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Parameters .. */ -/* .. Scalar Arguments .. */ -/* .. Array Arguments .. */ -/* .. Local Scalars .. */ -/* .. Local Arrays .. */ -/* .. External Functions .. */ -/* .. External Subroutines .. */ -/* .. Intrinsic Functions .. */ -/* .. Scalars in Common .. */ -/* .. Common blocks .. */ -/* .. Data statements .. */ - /* Parameter adjustments */ - --idim; - --alf; - --bet; - --g; - --ct; - --cs; - --cc; - c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - --bs; - --bb; - b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; - b -= b_offset; - --as; - --aa; - a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - - /* Function Body */ -/* .. Executable Statements .. */ - - nargs = 12; - nc = 0; - reset = TRUE_; - errmax = 0.; - - i__1 = *nidim; - for (im = 1; im <= i__1; ++im) { - m = idim[im]; - - i__2 = *nidim; - for (in = 1; in <= i__2; ++in) { - n = idim[in]; -/* Set LDC to 1 more than minimum value if room. */ - ldc = m; - if (ldc < *nmax) { - ++ldc; - } -/* Skip tests if not enough room. */ - if (ldc > *nmax) { - goto L90; - } - lcc = ldc * n; - null = n <= 0 || m <= 0; - -/* Set LDB to 1 more than minimum value if room. */ - ldb = m; - if (ldb < *nmax) { - ++ldb; - } -/* Skip tests if not enough room. */ - if (ldb > *nmax) { - goto L90; - } - lbb = ldb * n; - -/* Generate the matrix B. */ - - dmake_("GE", " ", " ", &m, &n, &b[b_offset], nmax, &bb[1], &ldb, & - reset, &c_b104, (ftnlen)2, (ftnlen)1, (ftnlen)1); - - for (ics = 1; ics <= 2; ++ics) { - *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1]; - left = *(unsigned char *)side == 'L'; - - if (left) { - na = m; - } else { - na = n; - } -/* Set LDA to 1 more than minimum value if room. */ - lda = na; - if (lda < *nmax) { - ++lda; - } -/* Skip tests if not enough room. */ - if (lda > *nmax) { - goto L80; - } - laa = lda * na; - - for (icu = 1; icu <= 2; ++icu) { - *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; - -/* Generate the symmetric matrix A. */ - - dmake_("SY", uplo, " ", &na, &na, &a[a_offset], nmax, &aa[ - 1], &lda, &reset, &c_b104, (ftnlen)2, (ftnlen)1, ( - ftnlen)1); - - i__3 = *nalf; - for (ia = 1; ia <= i__3; ++ia) { - alpha = alf[ia]; - - i__4 = *nbet; - for (ib = 1; ib <= i__4; ++ib) { - beta = bet[ib]; - -/* Generate the matrix C. */ - - dmake_("GE", " ", " ", &m, &n, &c__[c_offset], - nmax, &cc[1], &ldc, &reset, &c_b104, ( - ftnlen)2, (ftnlen)1, (ftnlen)1); - - ++nc; - -/* Save every datum before calling the */ -/* subroutine. */ - - *(unsigned char *)sides = *(unsigned char *)side; - *(unsigned char *)uplos = *(unsigned char *)uplo; - ms = m; - ns = n; - als = alpha; - i__5 = laa; - for (i__ = 1; i__ <= i__5; ++i__) { - as[i__] = aa[i__]; -/* L10: */ - } - ldas = lda; - i__5 = lbb; - for (i__ = 1; i__ <= i__5; ++i__) { - bs[i__] = bb[i__]; -/* L20: */ - } - ldbs = ldb; - bls = beta; - i__5 = lcc; - for (i__ = 1; i__ <= i__5; ++i__) { - cs[i__] = cc[i__]; -/* L30: */ - } - ldcs = ldc; - -/* Call the subroutine. */ - - if (*trace) { - dprcn2_(ntra, &nc, sname, iorder, side, uplo, - &m, &n, &alpha, &lda, &ldb, &beta, & - ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1) - ; - } - if (*rewi) { -/* al__1.aerr = 0; - al__1.aunit = *ntra; - f_rew(&al__1);*/ - } - cdsymm_(iorder, side, uplo, &m, &n, &alpha, &aa[1] - , &lda, &bb[1], &ldb, &beta, &cc[1], &ldc, - (ftnlen)1, (ftnlen)1); - -/* Check if error-exit was taken incorrectly. */ - - if (! infoc_1.ok) { - printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); - *fatal = TRUE_; - goto L110; - } - -/* See what data changed inside subroutines. */ - - isame[0] = *(unsigned char *)sides == *(unsigned - char *)side; - isame[1] = *(unsigned char *)uplos == *(unsigned - char *)uplo; - isame[2] = ms == m; - isame[3] = ns == n; - isame[4] = als == alpha; - isame[5] = lde_(&as[1], &aa[1], &laa); - isame[6] = ldas == lda; - isame[7] = lde_(&bs[1], &bb[1], &lbb); - isame[8] = ldbs == ldb; - isame[9] = bls == beta; - if (null) { - isame[10] = lde_(&cs[1], &cc[1], &lcc); - } else { - isame[10] = lderes_("GE", " ", &m, &n, &cs[1], - &cc[1], &ldc, (ftnlen)2, (ftnlen)1); - } - isame[11] = ldcs == ldc; - -/* If data was incorrectly changed, report and */ -/* return. */ - - same = TRUE_; - i__5 = nargs; - for (i__ = 1; i__ <= i__5; ++i__) { - same = same && isame[i__ - 1]; - if (! isame[i__ - 1]) { - printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); - } -/* L40: */ - } - if (! same) { - *fatal = TRUE_; - goto L110; - } - - if (! null) { - -/* Check the result. */ - - if (left) { - dmmch_("N", "N", &m, &n, &m, &alpha, &a[ - a_offset], nmax, &b[b_offset], - nmax, &beta, &c__[c_offset], nmax, - &ct[1], &g[1], &cc[1], &ldc, eps, - &err, fatal, nout, &c_true, ( - ftnlen)1, (ftnlen)1); - } else { - dmmch_("N", "N", &m, &n, &n, &alpha, &b[ - b_offset], nmax, &a[a_offset], - nmax, &beta, &c__[c_offset], nmax, - &ct[1], &g[1], &cc[1], &ldc, eps, - &err, fatal, nout, &c_true, ( - ftnlen)1, (ftnlen)1); - } - errmax = f2cmax(errmax,err); -/* If got really bad answer, report and */ -/* return. */ - if (*fatal) { - goto L110; - } - } - -/* L50: */ - } - -/* L60: */ - } - -/* L70: */ + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; } - -L80: - ; - } - -L90: - ; - } - -/* L100: */ - } - -/* Report result. */ - - if (errmax < *thresh) { - if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); - } - if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); - } - } else { - if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); } - if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); - } - } - goto L120; - -L110: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); - dprcn2_(nout, &nc, sname, iorder, side, uplo, &m, &n, &alpha, &lda, &ldb, - &beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); - -L120: - return 0; - -/* 9995 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ -/* $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', */ -/* $ ' .' ) */ - -/* End of DCHK2. */ - -} /* dchk2_ */ - - -/* Subroutine */ void dprcn2_(integer* nout, integer* nc, char* sname, integer* iorder, char* side, char* uplo, integer* m, integer* n, doublereal* alpha, integer* lda, integer* ldb, doublereal* beta, integer* ldc, ftnlen sname_len, ftnlen side_len, ftnlen uplo_len) -{ - - /* Local variables */ - static char cs[14], cu[14], crc[14]; - - if (*(unsigned char *)side == 'L') { - s_copy(cs, " CblasLeft", (ftnlen)14, (ftnlen)14); - } else { - s_copy(cs, " CblasRight", (ftnlen)14, (ftnlen)14); - } - if (*(unsigned char *)uplo == 'U') { - s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); - } else { - s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); - } - if (*iorder == 1) { - s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); - } else { - s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); - } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cs,cu); - printf("%d %d %4.1f A, %d, B, %d, %4.1f C, %d.\n",*m,*n,*alpha,*lda,*ldb,*beta,*ldc); -} /* dprcn2_ */ - - -/* Subroutine */ int dchk3_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublereal* alf, integer* nmax, doublereal* a, doublereal* aa, doublereal* as, doublereal* b, doublereal* bb, doublereal* bs, doublereal* ct, doublereal* g, doublereal* c__, integer* iorder, ftnlen sname_len) -{ - /* Initialized data */ - - static char ichu[2+1] = "UL"; - static char icht[3+1] = "NTC"; - static char ichd[2+1] = "UN"; - static char ichs[2+1] = "LR"; - - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3, i__4, i__5; - - /* Local variables */ - static char diag[1]; - static integer ldas, ldbs; - static logical same; - static char side[1]; - static logical left, null; - static char uplo[1]; - static integer i__, j, m, n; - extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*, ftnlen, ftnlen, ftnlen); - static doublereal alpha; - static char diags[1]; - extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); - static logical isame[13]; - static char sides[1]; - static integer nargs; - static logical reset; - static char uplos[1]; - extern /* Subroutine */ void dprcn3_(integer*, integer*, char*, integer*, char*, char*, char*, char*, integer*, integer*, doublereal*, integer*, integer*, ftnlen, ftnlen, ftnlen, ftnlen, ftnlen); - static integer ia, na, nc, im, in, ms, ns; - extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen); - extern /* Subroutine */ void cdtrmm_(integer*, char*, char*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen, ftnlen); - static char tranas[1], transa[1]; - extern /* Subroutine */ void cdtrsm_(integer*, char*, char*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen, ftnlen); - static doublereal errmax; - static integer laa, icd, lbb, lda, ldb; - extern logical lde_(doublereal*, doublereal*, integer*); - static integer ics; - static doublereal als; - static integer ict, icu; - static doublereal err; - -/* Tests DTRMM and DTRSM. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Parameters .. */ -/* .. Scalar Arguments .. */ -/* .. Array Arguments .. */ -/* .. Local Scalars .. */ -/* .. Local Arrays .. */ -/* .. External Functions .. */ -/* .. External Subroutines .. */ -/* .. Intrinsic Functions .. */ -/* .. Scalars in Common .. */ -/* .. Common blocks .. */ -/* .. Data statements .. */ - /* Parameter adjustments */ - --idim; - --alf; - c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - --g; - --ct; - --bs; - --bb; - b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; - b -= b_offset; - --as; - --aa; - a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - - /* Function Body */ -/* .. Executable Statements .. */ - - nargs = 11; - nc = 0; - reset = TRUE_; - errmax = 0.; -/* Set up zero matrix for DMMCH. */ - i__1 = *nmax; - for (j = 1; j <= i__1; ++j) { - i__2 = *nmax; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; -/* L10: */ - } -/* L20: */ - } - - i__1 = *nidim; - for (im = 1; im <= i__1; ++im) { - m = idim[im]; - - i__2 = *nidim; - for (in = 1; in <= i__2; ++in) { - n = idim[in]; -/* Set LDB to 1 more than minimum value if room. */ - ldb = m; - if (ldb < *nmax) { - ++ldb; - } -/* Skip tests if not enough room. */ - if (ldb > *nmax) { - goto L130; - } - lbb = ldb * n; - null = m <= 0 || n <= 0; - - for (ics = 1; ics <= 2; ++ics) { - *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1]; - left = *(unsigned char *)side == 'L'; - if (left) { - na = m; - } else { - na = n; - } -/* Set LDA to 1 more than minimum value if room. */ - lda = na; - if (lda < *nmax) { - ++lda; - } -/* Skip tests if not enough room. */ - if (lda > *nmax) { - goto L130; - } - laa = lda * na; - - for (icu = 1; icu <= 2; ++icu) { - *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; - - for (ict = 1; ict <= 3; ++ict) { - *(unsigned char *)transa = *(unsigned char *)&icht[ - ict - 1]; - - for (icd = 1; icd <= 2; ++icd) { - *(unsigned char *)diag = *(unsigned char *)&ichd[ - icd - 1]; - - i__3 = *nalf; - for (ia = 1; ia <= i__3; ++ia) { - alpha = alf[ia]; - -/* Generate the matrix A. */ - - dmake_("TR", uplo, diag, &na, &na, &a[ - a_offset], nmax, &aa[1], &lda, &reset, - &c_b104, (ftnlen)2, (ftnlen)1, ( - ftnlen)1); - -/* Generate the matrix B. */ - - dmake_("GE", " ", " ", &m, &n, &b[b_offset], - nmax, &bb[1], &ldb, &reset, &c_b104, ( - ftnlen)2, (ftnlen)1, (ftnlen)1); - - ++nc; - -/* Save every datum before calling the */ -/* subroutine. */ - - *(unsigned char *)sides = *(unsigned char *) - side; - *(unsigned char *)uplos = *(unsigned char *) - uplo; - *(unsigned char *)tranas = *(unsigned char *) - transa; - *(unsigned char *)diags = *(unsigned char *) - diag; - ms = m; - ns = n; - als = alpha; - i__4 = laa; - for (i__ = 1; i__ <= i__4; ++i__) { - as[i__] = aa[i__]; -/* L30: */ - } - ldas = lda; - i__4 = lbb; - for (i__ = 1; i__ <= i__4; ++i__) { - bs[i__] = bb[i__]; -/* L40: */ - } - ldbs = ldb; - -/* Call the subroutine. */ - - if (s_cmp(sname + 9, "mm", (ftnlen)2, (ftnlen) - 2) == 0) { - if (*trace) { - dprcn3_(ntra, &nc, sname, iorder, - side, uplo, transa, diag, &m, - &n, &alpha, &lda, &ldb, ( - ftnlen)12, (ftnlen)1, (ftnlen) - 1, (ftnlen)1, (ftnlen)1); - } - if (*rewi) { -/* al__1.aerr = 0; - al__1.aunit = *ntra; - f_rew(&al__1);*/ - } - cdtrmm_(iorder, side, uplo, transa, diag, - &m, &n, &alpha, &aa[1], &lda, &bb[ - 1], &ldb, (ftnlen)1, (ftnlen)1, ( - ftnlen)1, (ftnlen)1); - } else if (s_cmp(sname + 9, "sm", (ftnlen)2, ( - ftnlen)2) == 0) { - if (*trace) { - dprcn3_(ntra, &nc, sname, iorder, - side, uplo, transa, diag, &m, - &n, &alpha, &lda, &ldb, ( - ftnlen)12, (ftnlen)1, (ftnlen) - 1, (ftnlen)1, (ftnlen)1); - } - if (*rewi) { -/* al__1.aerr = 0; - al__1.aunit = *ntra; - f_rew(&al__1);*/ - } - cdtrsm_(iorder, side, uplo, transa, diag, - &m, &n, &alpha, &aa[1], &lda, &bb[ - 1], &ldb, (ftnlen)1, (ftnlen)1, ( - ftnlen)1, (ftnlen)1); - } - -/* Check if error-exit was taken incorrectly. */ - - if (! infoc_1.ok) { - printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); - *fatal = TRUE_; - goto L150; - } - -/* See what data changed inside subroutines. */ - - isame[0] = *(unsigned char *)sides == *( - unsigned char *)side; - isame[1] = *(unsigned char *)uplos == *( - unsigned char *)uplo; - isame[2] = *(unsigned char *)tranas == *( - unsigned char *)transa; - isame[3] = *(unsigned char *)diags == *( - unsigned char *)diag; - isame[4] = ms == m; - isame[5] = ns == n; - isame[6] = als == alpha; - isame[7] = lde_(&as[1], &aa[1], &laa); - isame[8] = ldas == lda; - if (null) { - isame[9] = lde_(&bs[1], &bb[1], &lbb); - } else { - isame[9] = lderes_("GE", " ", &m, &n, &bs[ - 1], &bb[1], &ldb, (ftnlen)2, ( - ftnlen)1); - } - isame[10] = ldbs == ldb; - -/* If data was incorrectly changed, report and */ -/* return. */ - - same = TRUE_; - i__4 = nargs; - for (i__ = 1; i__ <= i__4; ++i__) { - same = same && isame[i__ - 1]; - if (! isame[i__ - 1]) { - printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); - } -/* L50: */ - } - if (! same) { - *fatal = TRUE_; - goto L150; - } - - if (! null) { - if (s_cmp(sname + 9, "mm", (ftnlen)2, ( - ftnlen)2) == 0) { - -/* Check the result. */ - - if (left) { - dmmch_(transa, "N", &m, &n, &m, & - alpha, &a[a_offset], nmax, - &b[b_offset], nmax, & - c_b104, &c__[c_offset], - nmax, &ct[1], &g[1], &bb[ - 1], &ldb, eps, &err, - fatal, nout, &c_true, ( - ftnlen)1, (ftnlen)1); - } else { - dmmch_("N", transa, &m, &n, &n, & - alpha, &b[b_offset], nmax, - &a[a_offset], nmax, & - c_b104, &c__[c_offset], - nmax, &ct[1], &g[1], &bb[ - 1], &ldb, eps, &err, - fatal, nout, &c_true, ( - ftnlen)1, (ftnlen)1); - } - } else if (s_cmp(sname + 9, "sm", (ftnlen) - 2, (ftnlen)2) == 0) { - -/* Compute approximation to original */ -/* matrix. */ - - i__4 = n; - for (j = 1; j <= i__4; ++j) { - i__5 = m; - for (i__ = 1; i__ <= i__5; ++i__) - { - c__[i__ + j * c_dim1] = bb[i__ + (j - 1) * ldb]; - bb[i__ + (j - 1) * ldb] = alpha * b[i__ + j * - b_dim1]; -/* L60: */ - } -/* L70: */ - } - - if (left) { - dmmch_(transa, "N", &m, &n, &m, & - c_b90, &a[a_offset], nmax, - &c__[c_offset], nmax, & - c_b104, &b[b_offset], - nmax, &ct[1], &g[1], &bb[ - 1], &ldb, eps, &err, - fatal, nout, &c_false, ( - ftnlen)1, (ftnlen)1); - } else { - dmmch_("N", transa, &m, &n, &n, & - c_b90, &c__[c_offset], - nmax, &a[a_offset], nmax, - &c_b104, &b[b_offset], - nmax, &ct[1], &g[1], &bb[ - 1], &ldb, eps, &err, - fatal, nout, &c_false, ( - ftnlen)1, (ftnlen)1); - } - } - errmax = f2cmax(errmax,err); -/* If got really bad answer, report and */ -/* return. */ - if (*fatal) { - goto L150; - } - } - -/* L80: */ - } - -/* L90: */ - } - -/* L100: */ - } - -/* L110: */ + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; } - -/* L120: */ - } - -L130: - ; } - -/* L140: */ - } - -/* Report result. */ - - if (errmax < *thresh) { - if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); - } - if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); - } - } else { - if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); - } - if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); - } - } - goto L160; - -L150: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); - if (*trace) { - dprcn3_(ntra, &nc, sname, iorder, side, uplo, transa, diag, &m, &n, & - alpha, &lda, &ldb, (ftnlen)12, (ftnlen)1, (ftnlen)1, (ftnlen) - 1, (ftnlen)1); - } - -L160: - return 0; - -/* 9995 FORMAT( 1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( I3, ',' ), */ -/* $ F4.1, ', A,', I3, ', B,', I3, ') .' ) */ - -/* End of DCHK3. */ - -} /* dchk3_ */ - - -/* Subroutine */ void dprcn3_(integer* nout, integer* nc, char* sname, integer* iorder, char* side, char* uplo, char* transa, char* diag, integer* m, integer* n, doublereal* alpha, integer* lda, integer* ldb, ftnlen sname_len, ftnlen side_len, ftnlen uplo_len, ftnlen transa_len, ftnlen diag_len) -{ - - /* Local variables */ - static char ca[14], cd[14], cs[14], cu[14], crc[14]; - - if (*(unsigned char *)side == 'L') { - s_copy(cs, " CblasLeft", (ftnlen)14, (ftnlen)14); - } else { - s_copy(cs, " CblasRight", (ftnlen)14, (ftnlen)14); - } - if (*(unsigned char *)uplo == 'U') { - s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); - } else { - s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); - } - if (*(unsigned char *)transa == 'N') { - s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); - } else if (*(unsigned char *)transa == 'T') { - s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); - } else { - s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); - } - if (*(unsigned char *)diag == 'N') { - s_copy(cd, " CblasNonUnit", (ftnlen)14, (ftnlen)14); - } else { - s_copy(cd, " CblasUnit", (ftnlen)14, (ftnlen)14); - } - if (*iorder == 1) { - s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); - } else { - s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); - } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cs,cu); - printf(" %s %s %d %d %4.1f A %d B %d\n",ca,cd,*m,*n,*alpha,*lda,*ldb); -} /* dprcn3_ */ - - -/* Subroutine */ int dchk4_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublereal* alf, integer* nbet, doublereal* bet, integer* nmax, doublereal* a, doublereal* aa, doublereal* as, doublereal* b, doublereal* bb, doublereal* bs, doublereal* c__, doublereal* cc, doublereal* cs, doublereal* ct, doublereal* g, integer* iorder, ftnlen sname_len) -{ - /* Initialized data */ - - static char icht[3+1] = "NTC"; - static char ichu[2+1] = "UL"; - - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3, i__4, i__5; - - - /* Local variables */ - static doublereal beta; - static integer ldas, ldcs; - static logical same; - static doublereal bets; - static logical tran, null; - static char uplo[1]; - static integer i__, j, k, n; - extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*, ftnlen, ftnlen, ftnlen); - static doublereal alpha; - extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); - static logical isame[13]; - static integer nargs; - static logical reset; - static char trans[1]; - static logical upper; - static char uplos[1]; - extern /* Subroutine */ void dprcn4_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen); - static integer ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns; - extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen); - static doublereal errmax; - extern /* Subroutine */ void cdsyrk_(integer*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen); - static char transs[1]; - static integer laa, lda, lcc, ldc; - extern logical lde_(doublereal*, doublereal*, integer*); - static doublereal als; - static integer ict, icu; - static doublereal err; - -/* Tests DSYRK. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Parameters .. */ -/* .. Scalar Arguments .. */ -/* .. Array Arguments .. */ -/* .. Local Scalars .. */ -/* .. Local Arrays .. */ -/* .. External Functions .. */ -/* .. External Subroutines .. */ -/* .. Intrinsic Functions .. */ -/* .. Scalars in Common .. */ -/* .. Common blocks .. */ -/* .. Data statements .. */ - /* Parameter adjustments */ - --idim; - --alf; - --bet; - --g; - --ct; - --cs; - --cc; - c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - --bs; - --bb; - b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; - b -= b_offset; - --as; - --aa; - a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - - /* Function Body */ -/* .. Executable Statements .. */ - - nargs = 10; - nc = 0; - reset = TRUE_; - errmax = 0.; - - i__1 = *nidim; - for (in = 1; in <= i__1; ++in) { - n = idim[in]; -/* Set LDC to 1 more than minimum value if room. */ - ldc = n; - if (ldc < *nmax) { - ++ldc; - } -/* Skip tests if not enough room. */ - if (ldc > *nmax) { - goto L100; - } - lcc = ldc * n; - null = n <= 0; - - i__2 = *nidim; - for (ik = 1; ik <= i__2; ++ik) { - k = idim[ik]; - - for (ict = 1; ict <= 3; ++ict) { - *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1]; - tran = *(unsigned char *)trans == 'T' || *(unsigned char *) - trans == 'C'; - if (tran) { - ma = k; - na = n; - } else { - ma = n; - na = k; - } -/* Set LDA to 1 more than minimum value if room. */ - lda = ma; - if (lda < *nmax) { - ++lda; - } -/* Skip tests if not enough room. */ - if (lda > *nmax) { - goto L80; - } - laa = lda * na; - -/* Generate the matrix A. */ - - dmake_("GE", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[1], & - lda, &reset, &c_b104, (ftnlen)2, (ftnlen)1, (ftnlen)1) - ; - - for (icu = 1; icu <= 2; ++icu) { - *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; - upper = *(unsigned char *)uplo == 'U'; - - i__3 = *nalf; - for (ia = 1; ia <= i__3; ++ia) { - alpha = alf[ia]; - - i__4 = *nbet; - for (ib = 1; ib <= i__4; ++ib) { - beta = bet[ib]; - -/* Generate the matrix C. */ - - dmake_("SY", uplo, " ", &n, &n, &c__[c_offset], - nmax, &cc[1], &ldc, &reset, &c_b104, ( - ftnlen)2, (ftnlen)1, (ftnlen)1); - - ++nc; - -/* Save every datum before calling the subroutine. */ - - *(unsigned char *)uplos = *(unsigned char *)uplo; - *(unsigned char *)transs = *(unsigned char *) - trans; - ns = n; - ks = k; - als = alpha; - i__5 = laa; - for (i__ = 1; i__ <= i__5; ++i__) { - as[i__] = aa[i__]; -/* L10: */ - } - ldas = lda; - bets = beta; - i__5 = lcc; - for (i__ = 1; i__ <= i__5; ++i__) { - cs[i__] = cc[i__]; -/* L20: */ - } - ldcs = ldc; - -/* Call the subroutine. */ - - if (*trace) { - dprcn4_(ntra, &nc, sname, iorder, uplo, trans, - &n, &k, &alpha, &lda, &beta, &ldc, ( - ftnlen)12, (ftnlen)1, (ftnlen)1); - } - if (*rewi) { -/* al__1.aerr = 0; - al__1.aunit = *ntra; - f_rew(&al__1);*/ - } - cdsyrk_(iorder, uplo, trans, &n, &k, &alpha, &aa[ - 1], &lda, &beta, &cc[1], &ldc, (ftnlen)1, - (ftnlen)1); - -/* Check if error-exit was taken incorrectly. */ - - if (! infoc_1.ok) { - printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); - *fatal = TRUE_; - goto L120; - } - -/* See what data changed inside subroutines. */ - - isame[0] = *(unsigned char *)uplos == *(unsigned - char *)uplo; - isame[1] = *(unsigned char *)transs == *(unsigned - char *)trans; - isame[2] = ns == n; - isame[3] = ks == k; - isame[4] = als == alpha; - isame[5] = lde_(&as[1], &aa[1], &laa); - isame[6] = ldas == lda; - isame[7] = bets == beta; - if (null) { - isame[8] = lde_(&cs[1], &cc[1], &lcc); - } else { - isame[8] = lderes_("SY", uplo, &n, &n, &cs[1], - &cc[1], &ldc, (ftnlen)2, (ftnlen)1); - } - isame[9] = ldcs == ldc; - -/* If data was incorrectly changed, report and */ -/* return. */ - - same = TRUE_; - i__5 = nargs; - for (i__ = 1; i__ <= i__5; ++i__) { - same = same && isame[i__ - 1]; - if (! isame[i__ - 1]) { - printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); - } -/* L30: */ - } - if (! same) { - *fatal = TRUE_; - goto L120; - } - - if (! null) { - -/* Check the result column by column. */ - - jc = 1; - i__5 = n; - for (j = 1; j <= i__5; ++j) { - if (upper) { - jj = 1; - lj = j; - } else { - jj = j; - lj = n - j + 1; - } - if (tran) { - dmmch_("T", "N", &lj, &c__1, &k, & - alpha, &a[jj * a_dim1 + 1], - nmax, &a[j * a_dim1 + 1], - nmax, &beta, &c__[jj + j * - c_dim1], nmax, &ct[1], &g[1], - &cc[jc], &ldc, eps, &err, - fatal, nout, &c_true, (ftnlen) - 1, (ftnlen)1); - } else { - dmmch_("N", "T", &lj, &c__1, &k, & - alpha, &a[jj + a_dim1], nmax, - &a[j + a_dim1], nmax, &beta, & - c__[jj + j * c_dim1], nmax, & - ct[1], &g[1], &cc[jc], &ldc, - eps, &err, fatal, nout, & - c_true, (ftnlen)1, (ftnlen)1); - } - if (upper) { - jc += ldc; - } else { - jc = jc + ldc + 1; - } - errmax = f2cmax(errmax,err); -/* If got really bad answer, report and */ -/* return. */ - if (*fatal) { - goto L110; - } -/* L40: */ - } - } - -/* L50: */ - } - -/* L60: */ - } - -/* L70: */ + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; } - -L80: - ; - } - -/* L90: */ } - -L100: - ; - } - -/* Report result. */ - - if (errmax < *thresh) { - if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); - } - if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } } - } else { - if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } } - if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } } - } - goto L130; - -L110: - if (n > 1) { - printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j); - } - -L120: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); - dprcn4_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, & - beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); - -L130: - return 0; - -/* 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ -/* $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' ) */ - -/* End of DCHK4. */ - -} /* dchk4_ */ - - -/* Subroutine */ void dprcn4_(integer* nout, integer* nc, char* sname, integer* iorder, char* uplo, char* transa, integer* n, integer* k, doublereal* alpha, integer* lda, doublereal* beta, integer* ldc, ftnlen sname_len, ftnlen uplo_len, ftnlen transa_len) + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) { - - /* Local variables */ - static char ca[14], cu[14], crc[14]; - - if (*(unsigned char *)uplo == 'U') { - s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); - } else { - s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); - } - if (*(unsigned char *)transa == 'N') { - s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); - } else if (*(unsigned char *)transa == 'T') { - s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); - } else { - s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); - } - if (*iorder == 1) { - s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); - } else { - s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); - } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); - printf("( %d %d %4.1f A %d %4.1f C %d\n",*n,*k,*alpha,*lda,*beta,*ldc); -} /* dprcn4_ */ - - -/* Subroutine */ int dchk5_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublereal* alf, integer* nbet, doublereal* bet, integer* nmax, doublereal* ab, doublereal* aa, doublereal* as, doublereal* bb, doublereal* bs, doublereal* c__, doublereal* cc, doublereal* cs, doublereal* ct, doublereal* g, doublereal* w, integer* iorder, ftnlen sname_len) + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) { - /* Initialized data */ - - static char icht[3+1] = "NTC"; - static char ichu[2+1] = "UL"; - - /* System generated locals */ - integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8; - - - /* Local variables */ - static integer jjab; - static doublereal beta; - static integer ldas, ldbs, ldcs; - static logical same; - static doublereal bets; - static logical tran, null; - static char uplo[1]; - static integer i__, j, k, n; - extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*, ftnlen, ftnlen, ftnlen); - static doublereal alpha; - extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); - static logical isame[13]; - static integer nargs; - static logical reset; - static char trans[1]; - static logical upper; - static char uplos[1]; - extern /* Subroutine */ void dprcn5_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublereal*, integer*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen); - static integer ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns; - extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen); - static doublereal errmax; - static char transs[1]; - static integer laa, lbb, lda, lcc, ldb, ldc; - extern logical lde_(doublereal*, doublereal*, integer*); - extern /* Subroutine */ void cdsyr2k_(integer*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen); - static doublereal als; - static integer ict, icu; - static doublereal err; - -/* Tests DSYR2K. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Parameters .. */ -/* .. Scalar Arguments .. */ -/* .. Array Arguments .. */ -/* .. Local Scalars .. */ -/* .. Local Arrays .. */ -/* .. External Functions .. */ -/* .. External Subroutines .. */ -/* .. Intrinsic Functions .. */ -/* .. Scalars in Common .. */ -/* .. Common blocks .. */ -/* .. Data statements .. */ - /* Parameter adjustments */ - --idim; - --alf; - --bet; - --w; - --g; - --ct; - --cs; - --cc; - c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - --bs; - --bb; - --as; - --aa; - --ab; - - /* Function Body */ -/* .. Executable Statements .. */ - - nargs = 12; - nc = 0; - reset = TRUE_; - errmax = 0.; - - i__1 = *nidim; - for (in = 1; in <= i__1; ++in) { - n = idim[in]; -/* Set LDC to 1 more than minimum value if room. */ - ldc = n; - if (ldc < *nmax) { - ++ldc; - } -/* Skip tests if not enough room. */ - if (ldc > *nmax) { - goto L130; - } - lcc = ldc * n; - null = n <= 0; - - i__2 = *nidim; - for (ik = 1; ik <= i__2; ++ik) { - k = idim[ik]; - - for (ict = 1; ict <= 3; ++ict) { - *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1]; - tran = *(unsigned char *)trans == 'T' || *(unsigned char *) - trans == 'C'; - if (tran) { - ma = k; - na = n; - } else { - ma = n; - na = k; - } -/* Set LDA to 1 more than minimum value if room. */ - lda = ma; - if (lda < *nmax) { - ++lda; - } -/* Skip tests if not enough room. */ - if (lda > *nmax) { - goto L110; + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i 1) { - printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j); - } - -L150: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); - dprcn5_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &ldb, - &beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); - -L160: - return 0; - -/* 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ -/* $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', */ -/* $ ' .' ) */ - -/* End of DCHK5. */ - -} /* dchk5_ */ - - -/* Subroutine */ void dprcn5_(integer* nout, integer* nc, char* sname, integer* iorder, char* uplo, char* transa, integer* n, integer* k, doublereal* alpha, integer* lda, integer* ldb, doublereal* beta, integer* ldc, ftnlen sname_len, ftnlen uplo_len, ftnlen transa_len) -{ - - /* Local variables */ - static char ca[14], cu[14], crc[14]; - - if (*(unsigned char *)uplo == 'U') { - s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); - } else { - s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); - } - if (*(unsigned char *)transa == 'N') { - s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); - } else if (*(unsigned char *)transa == 'T') { - s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); - } else { - s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); - } - if (*iorder == 1) { - s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); - } else { - s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); - } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); - printf("%d %d %4.1f , A, %d, B, %d, %4.1f , C, %d.\n",*n,*k,*alpha,*lda,*ldb,*beta,*ldc); -} /* dprcn5_ */ - - -/* Subroutine */ int dmake_(char* type__, char* uplo, char* diag, integer* m, integer* n, doublereal* a, integer* nmax, doublereal* aa, integer* lda, logical* reset, doublereal* transl, ftnlen type_len, ftnlen uplo_len, ftnlen diag_len) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - extern doublereal dbeg_(logical*); - static integer ibeg, iend; - static logical unit; - static integer i__, j; - static logical lower, upper, gen, tri, sym; - - -/* Generates values for an M by N matrix A. */ -/* Stores the values in the array AA in the data structure required */ -/* by the routine, with unwanted elements set to rogue value. */ - -/* TYPE is 'GE', 'SY' or 'TR'. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Parameters .. */ -/* .. Scalar Arguments .. */ -/* .. Array Arguments .. */ -/* .. Local Scalars .. */ -/* .. External Functions .. */ -/* .. Executable Statements .. */ - /* Parameter adjustments */ - a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --aa; - - /* Function Body */ - gen = s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0; - sym = s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0; - tri = s_cmp(type__, "TR", (ftnlen)2, (ftnlen)2) == 0; - upper = (sym || tri) && *(unsigned char *)uplo == 'U'; - lower = (sym || tri) && *(unsigned char *)uplo == 'L'; - unit = tri && *(unsigned char *)diag == 'U'; - -/* Generate data in array A. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - if (gen || (upper && i__ <= j) || (lower && i__ >= j)) { - a[i__ + j * a_dim1] = dbeg_(reset) + *transl; - if (i__ != j) { -/* Set some elements to zero */ - if (*n > 3 && j == *n / 2) { - a[i__ + j * a_dim1] = 0.; - } - if (sym) { - a[j + i__ * a_dim1] = a[i__ + j * a_dim1]; - } else if (tri) { - a[j + i__ * a_dim1] = 0.; - } + pCf(z) = zdotc; +} +#endif +static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Dcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i= 1.) { - goto L130; - } -/* L110: */ } - -/* L120: */ - } - -/* If the loop completes, all results are at least half accurate. */ - goto L150; - -/* Report fatal error. */ - -L130: - *fatal = TRUE_; - printf(" ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HALF ACCURATE *******\n"); - printf(" EXPECTED RESULT COMPUTED RESULT\n"); - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - if (*mv) { - printf("%7d %15.6g %15.6g\n",i__,ct[i__],cc[i__+j*cc_dim1]); + pCf(z) = zdotc; +} +#endif +static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Dcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i 1) { - printf(" THESE ARE THE RESULTS FOR COLUMN %d\n",j); - } - -L150: - return 0; - - -/* End of DMMCH. */ - -} /* dmmch_ */ - -logical lde_(doublereal* ri, doublereal* rj, integer* lr) -{ - /* System generated locals */ - integer i__1; - logical ret_val; - - /* Local variables */ - static integer i__; - - -/* Tests if two arrays are identical. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Scalar Arguments .. */ -/* .. Array Arguments .. */ -/* .. Local Scalars .. */ -/* .. Executable Statements .. */ - /* Parameter adjustments */ - --rj; - --ri; - - /* Function Body */ - i__1 = *lr; - for (i__ = 1; i__ <= i__1; ++i__) { - if (ri[i__] != rj[i__]) { - goto L20; - } -/* L10: */ - } - ret_val = TRUE_; - goto L30; -L20: - ret_val = FALSE_; -L30: - return ret_val; - -/* End of LDE. */ - -} /* lde_ */ - -logical lderes_(char* type__, char* uplo, integer* m, integer* n, doublereal* aa, doublereal* as, integer* lda, ftnlen type_len, ftnlen uplo_len) -{ - /* System generated locals */ - integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2; - logical ret_val; - - /* Local variables */ - static integer ibeg, iend, i__, j; - static logical upper; - - -/* Tests if selected elements in two arrays are equal. */ - -/* TYPE is 'GE' or 'SY'. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Scalar Arguments .. */ -/* .. Array Arguments .. */ -/* .. Local Scalars .. */ -/* .. Executable Statements .. */ - /* Parameter adjustments */ - as_dim1 = *lda; - as_offset = 1 + as_dim1 * 1; - as -= as_offset; - aa_dim1 = *lda; - aa_offset = 1 + aa_dim1 * 1; - aa -= aa_offset; - - /* Function Body */ - upper = *(unsigned char *)uplo == 'U'; - if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *lda; - for (i__ = *m + 1; i__ <= i__2; ++i__) { - if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) { - goto L70; + for (i=0;i= 5) { - ic = 0; - goto L10; - } - ret_val = (i__ - 500) / 1001.; - return ret_val; - -/* End of DBEG. */ - -} /* dbeg_ */ - -doublereal ddiff_(doublereal* x, doublereal* y) -{ - /* System generated locals */ - doublereal ret_val; - - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Scalar Arguments .. */ -/* .. Executable Statements .. */ - ret_val = *x - *y; - return ret_val; + pCd(z) = zdotc; +} +#endif +/* -- translated by f2c (version 20000121). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ -/* End of DDIFF. */ -} /* ddiff_ */ -/* Main program alias */ /*int dblat3_ () { MAIN__ (); }*/ diff --git a/ctest/c_sblat3c.c b/ctest/c_sblat3c.c index 402c58c8b..447b23014 100644 --- a/ctest/c_sblat3c.c +++ b/ctest/c_sblat3c.c @@ -10,7 +10,25 @@ #undef I #endif -#include "common.h" +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif typedef blasint integer; @@ -229,6 +247,7 @@ typedef struct Namelist Namelist; #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } #define sig_die(s, kill) { exit(1); } #define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; #define z_abs(z) (cabs(Cd(z))) #define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} #define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} @@ -242,3092 +261,251 @@ typedef struct Namelist Namelist; /* procedure parameter types for -A and -C++ */ #define F2C_proc_par_types 1 - - -/* Common Block Declarations */ - -struct { - integer infot, noutc; - logical ok; -} infoc_; - -#define infoc_1 infoc_ - -struct { - char srnamt[12]; -} srnamc_; - -#define srnamc_1 srnamc_ - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c__65 = 65; -static real c_b89 = (float)1.; -static real c_b103 = (float)0.; -static integer c__6 = 6; -static logical c_true = TRUE_; -static integer c__0 = 0; -static logical c_false = FALSE_; - -/* Main program MAIN__() */ int main(void) -{ - /* Initialized data */ - - static char snames[6][13] = {"cblas_sgemm ", "cblas_ssymm ", "cblas_strmm ", "cblas_strsm ", "cblas_ssyrk ", "cblas_ssyr2k"}; - - /* System generated locals */ - integer i__1, i__2, i__3; - real r__1; - - /* Local variables */ - static integer nalf, idim[9]; - static logical same; - static integer nbet, ntra; - static logical rewi; - extern /* Subroutine */ int schk1_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, real*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*, ftnlen); - extern /* Subroutine */ int schk2_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, real*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*, ftnlen); - extern /* Subroutine */ int schk3_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*, ftnlen); - extern /* Subroutine */ int schk4_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, real*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*, ftnlen); - extern /* Subroutine */ int schk5_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, real*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*, ftnlen); - static real c__[4225] /* was [65][65] */, g[65]; - static integer i__, j, n; - static logical fatal; - static real w[130]; - extern doublereal sdiff_(real*, real*); - static logical trace; - static integer nidim; - extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*, ftnlen, ftnlen); - static char snaps[32]; - static integer isnum; - static logical ltest[6]; - static real aa[4225], ab[8450] /* was [65][130] */, bb[4225], cc[ - 4225], as[4225], bs[4225], cs[4225], ct[65]; - static logical sfatal, corder; - static char snamet[12], transa[1], transb[1]; - static real thresh; - static logical rorder; - static integer layout; - static logical ltestt, tsterr; - extern /* Subroutine */ void cs3chke_(char*, ftnlen); - static real alf[7], bet[7]; - extern logical lse_(real*, real*, integer*); - static real eps, err; - char tmpchar; - -/* Test program for the REAL Level 3 Blas. */ - -/* The program must be driven by a short data file. The first 13 records */ -/* of the file are read using list-directed input, the last 6 records */ -/* are read using the format ( A12, L2 ). An annotated example of a data */ -/* file can be obtained by deleting the first 3 characters from the */ -/* following 19 lines: */ -/* 'SBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE */ -/* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) */ -/* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. */ -/* F LOGICAL FLAG, T TO STOP ON FAILURES. */ -/* T LOGICAL FLAG, T TO TEST ERROR EXITS. */ -/* 2 0 TO TEST COLUMN-MAJOR, 1 TO TEST ROW-MAJOR, 2 TO TEST BOTH */ -/* 16.0 THRESHOLD VALUE OF TEST RATIO */ -/* 6 NUMBER OF VALUES OF N */ -/* 0 1 2 3 5 9 VALUES OF N */ -/* 3 NUMBER OF VALUES OF ALPHA */ -/* 0.0 1.0 0.7 VALUES OF ALPHA */ -/* 3 NUMBER OF VALUES OF BETA */ -/* 0.0 1.0 1.3 VALUES OF BETA */ -/* cblas_sgemm T PUT F FOR NO TEST. SAME COLUMNS. */ -/* cblas_ssymm T PUT F FOR NO TEST. SAME COLUMNS. */ -/* cblas_strmm T PUT F FOR NO TEST. SAME COLUMNS. */ -/* cblas_strsm T PUT F FOR NO TEST. SAME COLUMNS. */ -/* cblas_ssyrk T PUT F FOR NO TEST. SAME COLUMNS. */ -/* cblas_ssyr2k T PUT F FOR NO TEST. SAME COLUMNS. */ - -/* See: */ - -/* Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. */ -/* A Set of Level 3 Basic Linear Algebra Subprograms. */ - -/* Technical Memorandum No.88 (Revision 1), Mathematics and */ -/* Computer Science Division, Argonne National Laboratory, 9700 */ -/* South Cass Avenue, Argonne, Illinois 60439, US. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Parameters .. */ -/* .. Local Scalars .. */ -/* .. Local Arrays .. */ -/* .. External Functions .. */ -/* .. External Subroutines .. */ -/* .. Intrinsic Functions .. */ -/* .. Scalars in Common .. */ -/* .. Common blocks .. */ -/* .. Data statements .. */ -/* .. Executable Statements .. */ - - infoc_1.noutc = 6; -/* Read name and unit number for summary output file and open file. */ - - char line[80]; - - fgets(line,80,stdin); - sscanf(line,"'%s'",snaps); - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&ntra); -#else - sscanf(line,"%d",&ntra); -#endif - trace = ntra >= 0; - if (trace) { -/* OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' ) */ -/* o__1.ounit = ntra; - o__1.ofnmlen = 32; - o__1.ofnm = snaps; - o__1.orl = 0; - o__1.osta = 0; - o__1.oacc = 0; - o__1.ofm = 0; - o__1.oblnk = 0; - f_open(&o__1);*/ - } -/* Read the flag that directs rewinding of the snapshot file. */ - fgets(line,80,stdin); - sscanf(line,"%d",&rewi); - rewi = rewi && trace; -/* Read the flag that directs stopping on any failure. */ - fgets(line,80,stdin); - sscanf(line,"%c",&tmpchar); -/* Read the flag that indicates whether error exits are to be tested. */ - sfatal=FALSE_; - if (tmpchar=='T')sfatal=TRUE_; - fgets(line,80,stdin); - sscanf(line,"%c",&tmpchar); -/* Read the flag that indicates whether error exits are to be tested. */ - tsterr=FALSE_; - if (tmpchar=='T')tsterr=TRUE_; -/* Read the flag that indicates whether row-major data layout to be tested. */ - fgets(line,80,stdin); - sscanf(line,"%d",&layout); -/* Read the threshold value of the test ratio */ - fgets(line,80,stdin); - sscanf(line,"%f",&thresh); - -/* Read and check the parameter values for the tests. */ - -/* Values of N */ - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&nidim); -#else - sscanf(line,"%d",&nidim); -#endif - - if (nidim < 1 || nidim > 9) { - fprintf(stderr,"NUMBER OF VALUES OF N IS LESS THAN 1 OR GREATER THAN 9"); - goto L220; - } - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld %ld %ld %ld %ld %ld %ld %ld %ld",&idim[0],&idim[1],&idim[2], - &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]); -#else - sscanf(line,"%d %d %d %d %d %d %d %d %d",&idim[0],&idim[1],&idim[2], - &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]); -#endif - i__1 = nidim; - for (i__ = 1; i__ <= i__1; ++i__) { - if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) { - fprintf(stderr,"VALUE OF N IS LESS THAN 0 OR GREATER THAN 65\n"); - goto L220; - } -/* L10: */ - } -/* Values of ALPHA */ - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&nalf); -#else - sscanf(line,"%d",&nalf); -#endif - if (nalf < 1 || nalf > 7) { - fprintf(stderr,"VALUE OF ALPHA IS LESS THAN 0 OR GREATER THAN 7\n"); - goto L220; - } - fgets(line,80,stdin); - sscanf(line,"%f %f %f %f %f %f %f",&alf[0],&alf[1],&alf[2],&alf[3],&alf[4],&alf[5],&alf[6]); - -/* Values of BETA */ - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&nbet); +#ifdef __cplusplus +typedef logical (*L_fp)(...); #else - sscanf(line,"%d",&nbet); +typedef logical (*L_fp)(); #endif - if (nalf < 1 || nbet > 7) { - fprintf(stderr,"VALUE OF BETA IS LESS THAN 0 OR GREATER THAN 7\n"); - goto L220; - } - fgets(line,80,stdin); - sscanf(line,"%f %f %f %f %f %f %f",&bet[0],&bet[1],&bet[2],&bet[3],&bet[4],&bet[5],&bet[6]); - -/* Report values of parameters. */ - printf("TESTS OF THE REAL LEVEL 3 BLAS\nTHE FOLLOWING PARAMETER VALUES WILL BE USED:\n"); - printf(" FOR N"); - for (i__ =1; i__ <=nidim;++i__) printf(" %d",idim[i__-1]); - printf("\n"); - printf(" FOR ALPHA"); - for (i__ =1; i__ <=nalf;++i__) printf(" %f",alf[i__-1]); - printf("\n"); - printf(" FOR BETA"); - for (i__ =1; i__ <=nbet;++i__) printf(" %f",bet[i__-1]); - printf("\n"); - - if (! tsterr) { - printf(" ERROR-EXITS WILL NOT BE TESTED\n"); - } - printf("ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LESS THAN %f\n",thresh); - rorder = FALSE_; - corder = FALSE_; - if (layout == 2) { - rorder = TRUE_; - corder = TRUE_; - printf("COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED\n"); - } else if (layout == 1) { - rorder = TRUE_; - printf("ROW-MAJOR DATA LAYOUT IS TESTED\n"); - } else if (layout == 0) { - corder = TRUE_; - printf("COLUMN-MAJOR DATA LAYOUT IS TESTED\n"); - } - - -/* Read names of subroutines and flags which indicate */ -/* whether they are to be tested. */ - - for (i__ = 1; i__ <= 6; ++i__) { - ltest[i__ - 1] = FALSE_; -/* L20: */ - } -L30: - if (! fgets(line,80,stdin)) { - goto L60; - } - i__1 = sscanf(line,"%12c %c",snamet,&tmpchar); - ltestt=FALSE_; - if (tmpchar=='T')ltestt=TRUE_; - if (i__1 < 2) { - goto L60; - } - for (i__ = 1; i__ <= 9; ++i__) { - if (s_cmp(snamet, snames[i__ - 1] , (ftnlen)12, (ftnlen)12) == - 0) { - goto L50; - } -/* L40: */ - } - printf("SUBPROGRAM NAME %s NOT RECOGNIZED\n****** TESTS ABANDONED ******\n",snamet); - exit(1); - -L50: - ltest[i__ - 1] = ltestt; - goto L30; - -L60: -// f_clos(&cl__1); -/* Compute EPS (the machine precision). */ - - eps = (float)1.; -L70: - r__1 = eps + (float)1.; - if (sdiff_(&r__1, &c_b89) == (float)0.) { - goto L80; - } - eps *= (float).5; - goto L70; -L80: - eps += eps; - printf("RELATIVE MACHINE PRECISION IS TAKEN TO BE %9.1g\n",eps); - -/* Check the reliability of SMMCH using exact data. */ - - n = 32; - i__1 = n; - for (j = 1; j <= i__1; ++j) { - i__2 = n; - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - i__3 = i__ - j + 1; - ab[i__ + j * 65 - 66] = (real) f2cmax(i__3,0); -/* L90: */ +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } } - ab[j + 4224] = (real) j; - ab[(j + 65) * 65 - 65] = (real) j; - c__[j - 1] = (float)0.; -/* L100: */ - } - i__1 = n; - for (j = 1; j <= i__1; ++j) { - cc[j - 1] = (real) (j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3) - ; -/* L110: */ - } -/* CC holds the exact result. On exit from SMMCH CT holds */ -/* the result computed by SMMCH. */ - *(unsigned char *)transa = 'N'; - *(unsigned char *)transb = 'N'; - smmch_(transa, transb, &n, &c__1, &n, &c_b89, ab, &c__65, &ab[4225], & - c__65, &c_b103, c__, &c__65, ct, g, cc, &c__65, &eps, &err, & - fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1); - same = lse_(cc, ct, &n); - if (! same || err != (float)0.) { - printf("ERROR IN SMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); - printf("SMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); - printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); - printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); - printf("****** TESTS ABANDONED ******\n"); - exit(1); - } - *(unsigned char *)transb = 'T'; - smmch_(transa, transb, &n, &c__1, &n, &c_b89, ab, &c__65, &ab[4225], & - c__65, &c_b103, c__, &c__65, ct, g, cc, &c__65, &eps, &err, & - fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1); - same = lse_(cc, ct, &n); - if (! same || err != (float)0.) { - printf("ERROR IN SMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); - printf("SMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); - printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); - printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); - printf("****** TESTS ABANDONED ******\n"); - exit(1); - } - i__1 = n; - for (j = 1; j <= i__1; ++j) { - ab[j + 4224] = (real) (n - j + 1); - ab[(j + 65) * 65 - 65] = (real) (n - j + 1); -/* L120: */ - } - i__1 = n; - for (j = 1; j <= i__1; ++j) { - cc[n - j] = (real) (j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3) - ; -/* L130: */ - } - *(unsigned char *)transa = 'T'; - *(unsigned char *)transb = 'N'; - smmch_(transa, transb, &n, &c__1, &n, &c_b89, ab, &c__65, &ab[4225], & - c__65, &c_b103, c__, &c__65, ct, g, cc, &c__65, &eps, &err, & - fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1); - same = lse_(cc, ct, &n); - if (! same || err != (float)0.) { - printf("ERROR IN SMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); - printf("SMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); - printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); - printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); - printf("****** TESTS ABANDONED ******\n"); - exit(1); - } - *(unsigned char *)transb = 'T'; - smmch_(transa, transb, &n, &c__1, &n, &c_b89, ab, &c__65, &ab[4225], & - c__65, &c_b103, c__, &c__65, ct, g, cc, &c__65, &eps, &err, & - fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1); - same = lse_(cc, ct, &n); - if (! same || err != (float)0.) { - printf("ERROR IN SMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); - printf("SMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); - printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); - printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); - printf("****** TESTS ABANDONED ******\n"); - exit(1); - } - -/* Test each subroutine in turn. */ - - for (isnum = 1; isnum <= 6; ++isnum) { - if (! ltest[isnum - 1]) { -/* Subprogram is not to be tested. */ - printf("%12s WAS NOT TESTED\n",snames[isnum-1]); - } else { - s_copy(srnamc_1.srnamt, snames[isnum - 1], (ftnlen)12, ( - ftnlen)12); -/* Test error exits. */ - if (tsterr) { - cs3chke_(snames[isnum - 1], (ftnlen)12); - } -/* Test computations. */ - infoc_1.infot = 0; - infoc_1.ok = TRUE_; - fatal = FALSE_; - switch ((int)isnum) { - case 1: goto L140; - case 2: goto L150; - case 3: goto L160; - case 4: goto L160; - case 5: goto L170; - case 6: goto L180; - } -/* Test SGEMM, 01. */ -L140: - if (corder) { - schk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__0, (ftnlen)12); - } - if (rorder) { - schk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__1, (ftnlen)12); - } - goto L190; -/* Test SSYMM, 02. */ -L150: - if (corder) { - schk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__0, (ftnlen)12); - } - if (rorder) { - schk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__1, (ftnlen)12); - } - goto L190; -/* Test STRMM, 03, STRSM, 04. */ -L160: - if (corder) { - schk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, & - c__0, (ftnlen)12); - } - if (rorder) { - schk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, & - c__1, (ftnlen)12); - } - goto L190; -/* Test SSYRK, 05. */ -L170: - if (corder) { - schk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__0, (ftnlen)12); - } - if (rorder) { - schk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__1, (ftnlen)12); - } - goto L190; -/* Test SSYR2K, 06. */ -L180: - if (corder) { - schk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, - ct, g, w, &c__0, (ftnlen)12); - } - if (rorder) { - schk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, - ct, g, w, &c__1, (ftnlen)12); - } - goto L190; - -L190: - if (fatal && sfatal) { - goto L210; - } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } } -/* L200: */ - } - printf("\nEND OF TESTS\n"); - goto L230; - -L210: - printf("\n****** FATAL ERROR - TESTS ABANDONED ******\n"); - goto L230; - -L220: - printf("AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM\n"); - printf("****** TESTS ABANDONED ******\n"); - -L230: - if (trace) { -// f_clos(&cl__1); - } -// f_clos(&cl__1); - exit(0); - -/* End of SBLAT3. */ - -} /* MAIN__ */ - -/* Subroutine */ int schk1_(char* sname, real* eps, real* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, real* alf, integer* nbet, real* bet, integer* nmax, real* a, real* aa, real* as, real* b, real* bb, real* bs, real* c__, real* cc, real* cs, real* ct, real* g, integer* iorder, ftnlen sname_len) -{ - /* Initialized data */ - - static char ich[3+1] = "NTC"; - - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3, i__4, i__5, i__6; - - - /* Local variables */ - static real beta; - static integer ldas, ldbs, ldcs; - static logical same, null; - static integer i__, k, m, n; - static real alpha; - static logical isame[13]; - static logical trana, tranb; - static integer nargs; - static logical reset; - extern /* Subroutine */ void sprcn1_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, integer*, real*, integer*, integer*, real*, integer*, ftnlen, ftnlen, ftnlen); - extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, logical*, real*, ftnlen, ftnlen, ftnlen); - extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*, ftnlen, ftnlen); - static integer ia, ib, ma, mb, na, nb, nc, ik, im, in, ks, ms, ns; - extern /* Subroutine */ void csgemm_(integer*, char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, ftnlen, ftnlen); - static char tranas[1], tranbs[1], transa[1], transb[1]; - static real errmax; - extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*, ftnlen, ftnlen); - extern logical lse_(real*, real*, integer*); - static integer ica, icb, laa, lbb, lda, lcc, ldb, ldc; - static real als, bls; - static real err; - -/* Tests SGEMM. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Parameters .. */ -/* .. Scalar Arguments .. */ -/* .. Array Arguments .. */ -/* .. Local Scalars .. */ -/* .. Local Arrays .. */ -/* .. External Functions .. */ -/* .. External Subroutines .. */ -/* .. Intrinsic Functions .. */ -/* .. Scalars in Common .. */ -/* .. Common blocks .. */ -/* .. Data statements .. */ - /* Parameter adjustments */ - --idim; - --alf; - --bet; - --g; - --ct; - --cs; - --cc; - c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - --bs; - --bb; - b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; - b -= b_offset; - --as; - --aa; - a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - - /* Function Body */ -/* .. Executable Statements .. */ - - nargs = 13; - nc = 0; - reset = TRUE_; - errmax = (float)0.; - - i__1 = *nidim; - for (im = 1; im <= i__1; ++im) { - m = idim[im]; - - i__2 = *nidim; - for (in = 1; in <= i__2; ++in) { - n = idim[in]; -/* Set LDC to 1 more than minimum value if room. */ - ldc = m; - if (ldc < *nmax) { - ++ldc; - } -/* Skip tests if not enough room. */ - if (ldc > *nmax) { - goto L100; - } - lcc = ldc * n; - null = n <= 0 || m <= 0; - - i__3 = *nidim; - for (ik = 1; ik <= i__3; ++ik) { - k = idim[ik]; - - for (ica = 1; ica <= 3; ++ica) { - *(unsigned char *)transa = *(unsigned char *)&ich[ica - 1] - ; - trana = *(unsigned char *)transa == 'T' || *(unsigned - char *)transa == 'C'; - - if (trana) { - ma = k; - na = m; - } else { - ma = m; - na = k; - } -/* Set LDA to 1 more than minimum value if room. */ - lda = ma; - if (lda < *nmax) { - ++lda; - } -/* Skip tests if not enough room. */ - if (lda > *nmax) { - goto L80; - } - laa = lda * na; - -/* Generate the matrix A. */ - - smake_("GE", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[ - 1], &lda, &reset, &c_b103, (ftnlen)2, (ftnlen)1, ( - ftnlen)1); - - for (icb = 1; icb <= 3; ++icb) { - *(unsigned char *)transb = *(unsigned char *)&ich[icb - - 1]; - tranb = *(unsigned char *)transb == 'T' || *(unsigned - char *)transb == 'C'; - - if (tranb) { - mb = n; - nb = k; - } else { - mb = k; - nb = n; - } -/* Set LDB to 1 more than minimum value if room. */ - ldb = mb; - if (ldb < *nmax) { - ++ldb; - } -/* Skip tests if not enough room. */ - if (ldb > *nmax) { - goto L70; - } - lbb = ldb * nb; - -/* Generate the matrix B. */ - - smake_("GE", " ", " ", &mb, &nb, &b[b_offset], nmax, & - bb[1], &ldb, &reset, &c_b103, (ftnlen)2, ( - ftnlen)1, (ftnlen)1); - - i__4 = *nalf; - for (ia = 1; ia <= i__4; ++ia) { - alpha = alf[ia]; - - i__5 = *nbet; - for (ib = 1; ib <= i__5; ++ib) { - beta = bet[ib]; - -/* Generate the matrix C. */ - - smake_("GE", " ", " ", &m, &n, &c__[c_offset], - nmax, &cc[1], &ldc, &reset, &c_b103, - (ftnlen)2, (ftnlen)1, (ftnlen)1); - - ++nc; - -/* Save every datum before calling the */ -/* subroutine. */ - - *(unsigned char *)tranas = *(unsigned char *) - transa; - *(unsigned char *)tranbs = *(unsigned char *) - transb; - ms = m; - ns = n; - ks = k; - als = alpha; - i__6 = laa; - for (i__ = 1; i__ <= i__6; ++i__) { - as[i__] = aa[i__]; -/* L10: */ - } - ldas = lda; - i__6 = lbb; - for (i__ = 1; i__ <= i__6; ++i__) { - bs[i__] = bb[i__]; -/* L20: */ - } - ldbs = ldb; - bls = beta; - i__6 = lcc; - for (i__ = 1; i__ <= i__6; ++i__) { - cs[i__] = cc[i__]; -/* L30: */ - } - ldcs = ldc; - -/* Call the subroutine. */ - - if (*trace) { - sprcn1_(ntra, &nc, sname, iorder, transa, - transb, &m, &n, &k, &alpha, &lda, - &ldb, &beta, &ldc, (ftnlen)12, ( - ftnlen)1, (ftnlen)1); - } - if (*rewi) { -// f_rew(&al__1); - } - csgemm_(iorder, transa, transb, &m, &n, &k, & - alpha, &aa[1], &lda, &bb[1], &ldb, & - beta, &cc[1], &ldc, (ftnlen)1, ( - ftnlen)1); - -/* Check if error-exit was taken incorrectly. */ - - if (! infoc_1.ok) { - printf(" *** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); - *fatal = TRUE_; - goto L120; - } - -/* See what data changed inside subroutines. */ - - isame[0] = *(unsigned char *)transa == *( - unsigned char *)tranas; - isame[1] = *(unsigned char *)transb == *( - unsigned char *)tranbs; - isame[2] = ms == m; - isame[3] = ns == n; - isame[4] = ks == k; - isame[5] = als == alpha; - isame[6] = lse_(&as[1], &aa[1], &laa); - isame[7] = ldas == lda; - isame[8] = lse_(&bs[1], &bb[1], &lbb); - isame[9] = ldbs == ldb; - isame[10] = bls == beta; - if (null) { - isame[11] = lse_(&cs[1], &cc[1], &lcc); - } else { - isame[11] = lseres_("GE", " ", &m, &n, & - cs[1], &cc[1], &ldc, (ftnlen)2, ( - ftnlen)1); - } - isame[12] = ldcs == ldc; - -/* If data was incorrectly changed, report */ -/* and return. */ - - same = TRUE_; - i__6 = nargs; - for (i__ = 1; i__ <= i__6; ++i__) { - same = same && isame[i__ - 1]; - if (! isame[i__ - 1]) { - printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); - } -/* L40: */ - } - if (! same) { - *fatal = TRUE_; - goto L120; - } - - if (! null) { - -/* Check the result. */ - - smmch_(transa, transb, &m, &n, &k, &alpha, - &a[a_offset], nmax, &b[b_offset], - nmax, &beta, &c__[c_offset], - nmax, &ct[1], &g[1], &cc[1], &ldc, - eps, &err, fatal, nout, &c_true, - (ftnlen)1, (ftnlen)1); - errmax = dmax(errmax,err); -/* If got really bad answer, report and */ -/* return. */ - if (*fatal) { - goto L120; - } - } - -/* L50: */ - } - -/* L60: */ - } - -L70: - ; - } - -L80: - ; + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; } - -/* L90: */ - } - -L100: - ; } - -/* L110: */ - } - -/* Report result. */ - - if (errmax < *thresh) { - if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } } - if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } } - } else { - if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } } - if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } } - } - goto L130; - -L120: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); - sprcn1_(nout, &nc, sname, iorder, transa, transb, &m, &n, &k, &alpha, & - lda, &ldb, &beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); - -L130: - return 0; - -/* 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',', */ -/* $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ', */ -/* $ 'C,', I3, ').' ) */ - -/* End of SCHK1. */ - -} /* schk1_ */ - - - - -/* Subroutine */ void sprcn1_(integer* nout, integer* nc, char* sname, integer* iorder, char* transa, char* transb, integer* m, integer* n, integer* k, real* alpha, integer* lda, integer* ldb, real* beta, integer* ldc, ftnlen sname_len, ftnlen transa_len, ftnlen transb_len) + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) { - - /* Local variables */ - static char crc[14], cta[14], ctb[14]; - - if (*(unsigned char *)transa == 'N') { - s_copy(cta, " CblasNoTrans", (ftnlen)14, (ftnlen)14); - } else if (*(unsigned char *)transa == 'T') { - s_copy(cta, " CblasTrans", (ftnlen)14, (ftnlen)14); - } else { - s_copy(cta, "CblasConjTrans", (ftnlen)14, (ftnlen)14); - } - if (*(unsigned char *)transb == 'N') { - s_copy(ctb, " CblasNoTrans", (ftnlen)14, (ftnlen)14); - } else if (*(unsigned char *)transb == 'T') { - s_copy(ctb, " CblasTrans", (ftnlen)14, (ftnlen)14); - } else { - s_copy(ctb, "CblasConjTrans", (ftnlen)14, (ftnlen)14); - } - if (*iorder == 1) { - s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); - } else { - s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); - } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cta,ctb); - printf("%d %d %d %4.1f A, %d, B, %d, %4.1f, C, %d.\n",*m,*n,*k,*alpha,*lda,*ldb,*beta,*ldc); - -} /* sprcn1_ */ - - -/* Subroutine */ int schk2_(char* sname, real* eps, real* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, real* alf, integer* nbet, real* bet, integer* nmax, real* a, real* aa, real* as, real* b, real* bb, real* bs, real* c__, real* cc, real* cs, real* ct, real* g, integer* iorder, ftnlen sname_len) + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) { - /* Initialized data */ - - static char ichs[2+1] = "LR"; - static char ichu[2+1] = "UL"; - - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3, i__4, i__5; - - - /* Local variables */ - static real beta; - static integer ldas, ldbs, ldcs; - static logical same; - static char side[1]; - static logical left, null; - static char uplo[1]; - static integer i__, m, n; - static real alpha; - static logical isame[13]; - static char sides[1]; - static integer nargs; - static logical reset; - static char uplos[1]; - static integer ia, ib, na, nc, im, in, ms, ns; - static real errmax; - extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*, ftnlen, ftnlen); - extern /* Subroutine */ void cssymm_(integer*, char*, char*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, ftnlen, ftnlen); - extern void sprcn2_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, real*, integer*, integer*, real*, integer*, ftnlen, ftnlen, ftnlen); - extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, logical*, real*, ftnlen, ftnlen, ftnlen); - extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*, ftnlen, ftnlen); - static integer laa, lbb, lda, lcc, ldb, ldc, ics; - static real als, bls; - static integer icu; - extern logical lse_(real*, real*, integer*); - static real err; - -/* Tests SSYMM. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Parameters .. */ -/* .. Scalar Arguments .. */ -/* .. Array Arguments .. */ -/* .. Local Scalars .. */ -/* .. Local Arrays .. */ -/* .. External Functions .. */ -/* .. External Subroutines .. */ -/* .. Intrinsic Functions .. */ -/* .. Scalars in Common .. */ -/* .. Common blocks .. */ -/* .. Data statements .. */ - /* Parameter adjustments */ - --idim; - --alf; - --bet; - --g; - --ct; - --cs; - --cc; - c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - --bs; - --bb; - b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; - b -= b_offset; - --as; - --aa; - a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - - /* Function Body */ -/* .. Executable Statements .. */ - - nargs = 12; - nc = 0; - reset = TRUE_; - errmax = (float)0.; - - i__1 = *nidim; - for (im = 1; im <= i__1; ++im) { - m = idim[im]; - - i__2 = *nidim; - for (in = 1; in <= i__2; ++in) { - n = idim[in]; -/* Set LDC to 1 more than minimum value if room. */ - ldc = m; - if (ldc < *nmax) { - ++ldc; - } -/* Skip tests if not enough room. */ - if (ldc > *nmax) { - goto L90; - } - lcc = ldc * n; - null = n <= 0 || m <= 0; - -/* Set LDB to 1 more than minimum value if room. */ - ldb = m; - if (ldb < *nmax) { - ++ldb; - } -/* Skip tests if not enough room. */ - if (ldb > *nmax) { - goto L90; - } - lbb = ldb * n; - -/* Generate the matrix B. */ - - smake_("GE", " ", " ", &m, &n, &b[b_offset], nmax, &bb[1], &ldb, & - reset, &c_b103, (ftnlen)2, (ftnlen)1, (ftnlen)1); - - for (ics = 1; ics <= 2; ++ics) { - *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1]; - left = *(unsigned char *)side == 'L'; - - if (left) { - na = m; - } else { - na = n; + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i *nmax) { - goto L80; + } + pCf(z) = zdotc; +} +#else + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i *nmax) { - goto L130; - } - lbb = ldb * n; - null = m <= 0 || n <= 0; - - for (ics = 1; ics <= 2; ++ics) { - *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1]; - left = *(unsigned char *)side == 'L'; - if (left) { - na = m; - } else { - na = n; + pCf(z) = zdotc; +} +#endif +static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Dcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i *nmax) { - goto L130; + } + pCd(z) = zdotc; +} +#else + _Complex double zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i *nmax) { - goto L100; - } - lcc = ldc * n; - null = n <= 0; - - i__2 = *nidim; - for (ik = 1; ik <= i__2; ++ik) { - k = idim[ik]; - - for (ict = 1; ict <= 3; ++ict) { - *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1]; - tran = *(unsigned char *)trans == 'T' || *(unsigned char *) - trans == 'C'; - if (tran) { - ma = k; - na = n; - } else { - ma = n; - na = k; - } -/* Set LDA to 1 more than minimum value if room. */ - lda = ma; - if (lda < *nmax) { - ++lda; - } -/* Skip tests if not enough room. */ - if (lda > *nmax) { - goto L80; - } - laa = lda * na; - -/* Generate the matrix A. */ - - smake_("GE", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[1], & - lda, &reset, &c_b103, (ftnlen)2, (ftnlen)1, (ftnlen)1) - ; - - for (icu = 1; icu <= 2; ++icu) { - *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; - upper = *(unsigned char *)uplo == 'U'; - - i__3 = *nalf; - for (ia = 1; ia <= i__3; ++ia) { - alpha = alf[ia]; - - i__4 = *nbet; - for (ib = 1; ib <= i__4; ++ib) { - beta = bet[ib]; - -/* Generate the matrix C. */ - - smake_("SY", uplo, " ", &n, &n, &c__[c_offset], - nmax, &cc[1], &ldc, &reset, &c_b103, ( - ftnlen)2, (ftnlen)1, (ftnlen)1); - - ++nc; - -/* Save every datum before calling the subroutine. */ - - *(unsigned char *)uplos = *(unsigned char *)uplo; - *(unsigned char *)transs = *(unsigned char *) - trans; - ns = n; - ks = k; - als = alpha; - i__5 = laa; - for (i__ = 1; i__ <= i__5; ++i__) { - as[i__] = aa[i__]; -/* L10: */ - } - ldas = lda; - bets = beta; - i__5 = lcc; - for (i__ = 1; i__ <= i__5; ++i__) { - cs[i__] = cc[i__]; -/* L20: */ - } - ldcs = ldc; - -/* Call the subroutine. */ - - if (*trace) { - sprcn4_(ntra, &nc, sname, iorder, uplo, trans, - &n, &k, &alpha, &lda, &beta, &ldc, ( - ftnlen)12, (ftnlen)1, (ftnlen)1); - } - if (*rewi) { -// f_rew(&al__1); - } - cssyrk_(iorder, uplo, trans, &n, &k, &alpha, &aa[ - 1], &lda, &beta, &cc[1], &ldc, (ftnlen)1, - (ftnlen)1); - -/* Check if error-exit was taken incorrectly. */ - - if (! infoc_1.ok) { - printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); - *fatal = TRUE_; - goto L120; - } - -/* See what data changed inside subroutines. */ - - isame[0] = *(unsigned char *)uplos == *(unsigned - char *)uplo; - isame[1] = *(unsigned char *)transs == *(unsigned - char *)trans; - isame[2] = ns == n; - isame[3] = ks == k; - isame[4] = als == alpha; - isame[5] = lse_(&as[1], &aa[1], &laa); - isame[6] = ldas == lda; - isame[7] = bets == beta; - if (null) { - isame[8] = lse_(&cs[1], &cc[1], &lcc); - } else { - isame[8] = lseres_("SY", uplo, &n, &n, &cs[1], - &cc[1], &ldc, (ftnlen)2, (ftnlen)1); - } - isame[9] = ldcs == ldc; - -/* If data was incorrectly changed, report and */ -/* return. */ - - same = TRUE_; - i__5 = nargs; - for (i__ = 1; i__ <= i__5; ++i__) { - same = same && isame[i__ - 1]; - if (! isame[i__ - 1]) { - printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); - } -/* L30: */ - } - if (! same) { - *fatal = TRUE_; - goto L120; - } - - if (! null) { - -/* Check the result column by column. */ - - jc = 1; - i__5 = n; - for (j = 1; j <= i__5; ++j) { - if (upper) { - jj = 1; - lj = j; - } else { - jj = j; - lj = n - j + 1; - } - if (tran) { - smmch_("T", "N", &lj, &c__1, &k, & - alpha, &a[jj * a_dim1 + 1], - nmax, &a[j * a_dim1 + 1], - nmax, &beta, &c__[jj + j * - c_dim1], nmax, &ct[1], &g[1], - &cc[jc], &ldc, eps, &err, - fatal, nout, &c_true, (ftnlen) - 1, (ftnlen)1); - } else { - smmch_("N", "T", &lj, &c__1, &k, & - alpha, &a[jj + a_dim1], nmax, - &a[j + a_dim1], nmax, &beta, & - c__[jj + j * c_dim1], nmax, & - ct[1], &g[1], &cc[jc], &ldc, - eps, &err, fatal, nout, & - c_true, (ftnlen)1, (ftnlen)1); - } - if (upper) { - jc += ldc; - } else { - jc = jc + ldc + 1; - } - errmax = dmax(errmax,err); -/* If got really bad answer, report and */ -/* return. */ - if (*fatal) { - goto L110; - } -/* L40: */ - } - } - -/* L50: */ - } - -/* L60: */ - } - -/* L70: */ - } - -L80: - ; - } - -/* L90: */ - } - -L100: - ; - } - -/* Report result. */ - - if (errmax < *thresh) { - if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); - } - if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); - } - } else { - if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); - } - if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); - } - } - goto L130; - -L110: - if (n > 1) { - printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j); - } - -L120: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); - sprcn4_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, & - beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); - -L130: - return 0; - -/* 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ -/* $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' ) */ - -/* End of SCHK4. */ - -} /* schk4_ */ - - -/* Subroutine */ void sprcn4_(integer* nout, integer* nc, char* sname, integer* iorder, char* uplo, char* transa, integer* n, integer* k, real* alpha, integer* lda, real* beta, integer* ldc, ftnlen sname_len, ftnlen uplo_len, ftnlen transa_len) -{ - - /* Local variables */ - static char ca[14], cu[14], crc[14]; - - if (*(unsigned char *)uplo == 'U') { - s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); - } else { - s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); - } - if (*(unsigned char *)transa == 'N') { - s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); - } else if (*(unsigned char *)transa == 'T') { - s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); - } else { - s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); - } - if (*iorder == 1) { - s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); - } else { - s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); - } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); - printf("( %d %d %4.1f A %d %4.1f C %d\n",*n,*k,*alpha,*lda,*beta,*ldc); - -} /* sprcn4_ */ - - -/* Subroutine */ int schk5_(char* sname, real* eps, real* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, real* alf, integer* nbet, real* bet, integer* nmax, real* ab, real* aa, real* as, real* bb, real* bs, real* c__, real* cc, real* cs, real* ct, real* g, real* w, integer* iorder, ftnlen sname_len) -{ - /* Initialized data */ - - static char icht[3+1] = "NTC"; - static char ichu[2+1] = "UL"; - - /* System generated locals */ - integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8; - - - /* Local variables */ - static integer jjab; - static real beta; - static integer ldas, ldbs, ldcs; - static logical same; - static real bets; - static logical tran, null; - static char uplo[1]; - static integer i__, j, k, n; - static real alpha; - static logical isame[13]; - static integer nargs; - static logical reset; - static char trans[1]; - static logical upper; - static char uplos[1]; - static integer ia, ib; - extern /* Subroutine */ void sprcn5_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, real*, integer*, integer*, real*, integer*, ftnlen, ftnlen, ftnlen); - static integer jc, ma, na, nc, ik, in, jj, lj, ks, ns; - static real errmax; - extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*, ftnlen, ftnlen); - extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, logical*, real*, ftnlen, ftnlen, ftnlen); - static char transs[1]; - static integer laa, lbb, lda, lcc, ldb, ldc; - static real als; - static integer ict, icu; - extern /* Subroutine */ void cssyr2k_(integer*, char*, char*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, ftnlen, ftnlen); - extern logical lse_(real*, real*, integer*); - extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*, ftnlen, ftnlen); - static real err; - -/* Tests SSYR2K. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Parameters .. */ -/* .. Scalar Arguments .. */ -/* .. Array Arguments .. */ -/* .. Local Scalars .. */ -/* .. Local Arrays .. */ -/* .. External Functions .. */ -/* .. External Subroutines .. */ -/* .. Intrinsic Functions .. */ -/* .. Scalars in Common .. */ -/* .. Common blocks .. */ -/* .. Data statements .. */ - /* Parameter adjustments */ - --idim; - --alf; - --bet; - --w; - --g; - --ct; - --cs; - --cc; - c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - --bs; - --bb; - --as; - --aa; - --ab; - - /* Function Body */ -/* .. Executable Statements .. */ - - nargs = 12; - nc = 0; - reset = TRUE_; - errmax = (float)0.; - - i__1 = *nidim; - for (in = 1; in <= i__1; ++in) { - n = idim[in]; -/* Set LDC to 1 more than minimum value if room. */ - ldc = n; - if (ldc < *nmax) { - ++ldc; - } -/* Skip tests if not enough room. */ - if (ldc > *nmax) { - goto L130; - } - lcc = ldc * n; - null = n <= 0; - - i__2 = *nidim; - for (ik = 1; ik <= i__2; ++ik) { - k = idim[ik]; - - for (ict = 1; ict <= 3; ++ict) { - *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1]; - tran = *(unsigned char *)trans == 'T' || *(unsigned char *) - trans == 'C'; - if (tran) { - ma = k; - na = n; - } else { - ma = n; - na = k; - } -/* Set LDA to 1 more than minimum value if room. */ - lda = ma; - if (lda < *nmax) { - ++lda; - } -/* Skip tests if not enough room. */ - if (lda > *nmax) { - goto L110; - } - laa = lda * na; - -/* Generate the matrix A. */ - - if (tran) { - i__3 = *nmax << 1; - smake_("GE", " ", " ", &ma, &na, &ab[1], &i__3, &aa[1], & - lda, &reset, &c_b103, (ftnlen)2, (ftnlen)1, ( - ftnlen)1); - } else { - smake_("GE", " ", " ", &ma, &na, &ab[1], nmax, &aa[1], & - lda, &reset, &c_b103, (ftnlen)2, (ftnlen)1, ( - ftnlen)1); - } - -/* Generate the matrix B. */ - - ldb = lda; - lbb = laa; - if (tran) { - i__3 = *nmax << 1; - smake_("GE", " ", " ", &ma, &na, &ab[k + 1], &i__3, &bb[1] - , &ldb, &reset, &c_b103, (ftnlen)2, (ftnlen)1, ( - ftnlen)1); - } else { - smake_("GE", " ", " ", &ma, &na, &ab[k * *nmax + 1], nmax, - &bb[1], &ldb, &reset, &c_b103, (ftnlen)2, ( - ftnlen)1, (ftnlen)1); - } - - for (icu = 1; icu <= 2; ++icu) { - *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; - upper = *(unsigned char *)uplo == 'U'; - - i__3 = *nalf; - for (ia = 1; ia <= i__3; ++ia) { - alpha = alf[ia]; - - i__4 = *nbet; - for (ib = 1; ib <= i__4; ++ib) { - beta = bet[ib]; - -/* Generate the matrix C. */ - - smake_("SY", uplo, " ", &n, &n, &c__[c_offset], - nmax, &cc[1], &ldc, &reset, &c_b103, ( - ftnlen)2, (ftnlen)1, (ftnlen)1); - - ++nc; - -/* Save every datum before calling the subroutine. */ - - *(unsigned char *)uplos = *(unsigned char *)uplo; - *(unsigned char *)transs = *(unsigned char *) - trans; - ns = n; - ks = k; - als = alpha; - i__5 = laa; - for (i__ = 1; i__ <= i__5; ++i__) { - as[i__] = aa[i__]; -/* L10: */ - } - ldas = lda; - i__5 = lbb; - for (i__ = 1; i__ <= i__5; ++i__) { - bs[i__] = bb[i__]; -/* L20: */ - } - ldbs = ldb; - bets = beta; - i__5 = lcc; - for (i__ = 1; i__ <= i__5; ++i__) { - cs[i__] = cc[i__]; -/* L30: */ - } - ldcs = ldc; - -/* Call the subroutine. */ - - if (*trace) { - sprcn5_(ntra, &nc, sname, iorder, uplo, trans, - &n, &k, &alpha, &lda, &ldb, &beta, & - ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1) - ; - } - if (*rewi) { -// f_rew(&al__1); - } - cssyr2k_(iorder, uplo, trans, &n, &k, &alpha, &aa[ - 1], &lda, &bb[1], &ldb, &beta, &cc[1], & - ldc, (ftnlen)1, (ftnlen)1); - -/* Check if error-exit was taken incorrectly. */ - - if (! infoc_1.ok) { - printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); - *fatal = TRUE_; - goto L150; - } - -/* See what data changed inside subroutines. */ - - isame[0] = *(unsigned char *)uplos == *(unsigned - char *)uplo; - isame[1] = *(unsigned char *)transs == *(unsigned - char *)trans; - isame[2] = ns == n; - isame[3] = ks == k; - isame[4] = als == alpha; - isame[5] = lse_(&as[1], &aa[1], &laa); - isame[6] = ldas == lda; - isame[7] = lse_(&bs[1], &bb[1], &lbb); - isame[8] = ldbs == ldb; - isame[9] = bets == beta; - if (null) { - isame[10] = lse_(&cs[1], &cc[1], &lcc); - } else { - isame[10] = lseres_("SY", uplo, &n, &n, &cs[1] - , &cc[1], &ldc, (ftnlen)2, (ftnlen)1); - } - isame[11] = ldcs == ldc; - -/* If data was incorrectly changed, report and */ -/* return. */ - - same = TRUE_; - i__5 = nargs; - for (i__ = 1; i__ <= i__5; ++i__) { - same = same && isame[i__ - 1]; - if (! isame[i__ - 1]) { - printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); - } -/* L40: */ - } - if (! same) { - *fatal = TRUE_; - goto L150; - } - - if (! null) { - -/* Check the result column by column. */ - - jjab = 1; - jc = 1; - i__5 = n; - for (j = 1; j <= i__5; ++j) { - if (upper) { - jj = 1; - lj = j; - } else { - jj = j; - lj = n - j + 1; - } - if (tran) { - i__6 = k; - for (i__ = 1; i__ <= i__6; ++i__) { - w[i__] = ab[((j - 1) << 1) * *nmax - + k + i__]; - w[k + i__] = ab[((j - 1) << 1) * * - nmax + i__]; -/* L50: */ - } - i__6 = k << 1; - i__7 = *nmax << 1; - i__8 = *nmax << 1; - smmch_("T", "N", &lj, &c__1, &i__6, & - alpha, &ab[jjab], &i__7, &w[1] - , &i__8, &beta, &c__[jj + j * - c_dim1], nmax, &ct[1], &g[1], - &cc[jc], &ldc, eps, &err, - fatal, nout, &c_true, (ftnlen) - 1, (ftnlen)1); - } else { - i__6 = k; - for (i__ = 1; i__ <= i__6; ++i__) { - w[i__] = ab[(k + i__ - 1) * *nmax - + j]; - w[k + i__] = ab[(i__ - 1) * *nmax - + j]; -/* L60: */ - } - i__6 = k << 1; - i__7 = *nmax << 1; - smmch_("N", "N", &lj, &c__1, &i__6, & - alpha, &ab[jj], nmax, &w[1], & - i__7, &beta, &c__[jj + j * - c_dim1], nmax, &ct[1], &g[1], - &cc[jc], &ldc, eps, &err, - fatal, nout, &c_true, (ftnlen) - 1, (ftnlen)1); - } - if (upper) { - jc += ldc; - } else { - jc = jc + ldc + 1; - if (tran) { - jjab += *nmax << 1; - } - } - errmax = dmax(errmax,err); -/* If got really bad answer, report and */ -/* return. */ - if (*fatal) { - goto L140; - } -/* L70: */ - } - } - -/* L80: */ - } - -/* L90: */ - } - -/* L100: */ - } - -L110: - ; - } - -/* L120: */ - } - -L130: - ; - } - -/* Report result. */ - - if (errmax < *thresh) { - if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); - } - if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); - } - } else { - if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); - } - if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); - } - } - goto L160; - -L140: - if (n > 1) { - printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j); - } - -L150: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); - sprcn5_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &ldb, - &beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); - -L160: - return 0; - -/* 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ -/* $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', */ -/* $ ' .' ) */ - -/* End of SCHK5. */ - -} /* schk5_ */ - - -/* Subroutine */ void sprcn5_(integer* nout, integer* nc, char* sname, integer* iorder, char* uplo, char* transa, integer* n, integer* k, real* alpha, integer* lda, integer* ldb, real* beta, integer* ldc, ftnlen sname_len, ftnlen uplo_len, ftnlen transa_len) -{ - - /* Local variables */ - static char ca[14], cu[14], crc[14]; - - if (*(unsigned char *)uplo == 'U') { - s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); - } else { - s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); - } - if (*(unsigned char *)transa == 'N') { - s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); - } else if (*(unsigned char *)transa == 'T') { - s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); - } else { - s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); - } - if (*iorder == 1) { - s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); - } else { - s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); - } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); - printf("%d %d %4.1f , A, %d, B, %d, %4.1f , C, %d.\n",*n,*k,*alpha,*lda,*ldb,*beta,*ldc); - -} /* sprcn5_ */ - - -/* Subroutine */ int smake_(char* type__, char* uplo, char* diag, integer* m, integer* n, real* a, integer* nmax, real* aa, integer* lda, logical* reset, real* transl, ftnlen type_len, ftnlen uplo_len, ftnlen diag_len) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Builtin functions */ - - /* Local variables */ - static integer ibeg, iend; - extern doublereal sbeg_(logical*); - static logical unit; - static integer i__, j; - static logical lower, upper, gen, tri, sym; - - -/* Generates values for an M by N matrix A. */ -/* Stores the values in the array AA in the data structure required */ -/* by the routine, with unwanted elements set to rogue value. */ - -/* TYPE is 'GE', 'SY' or 'TR'. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Parameters .. */ -/* .. Scalar Arguments .. */ -/* .. Array Arguments .. */ -/* .. Local Scalars .. */ -/* .. External Functions .. */ -/* .. Executable Statements .. */ - /* Parameter adjustments */ - a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --aa; - - /* Function Body */ - gen = s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0; - sym = s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0; - tri = s_cmp(type__, "TR", (ftnlen)2, (ftnlen)2) == 0; - upper = (sym || tri) && *(unsigned char *)uplo == 'U'; - lower = (sym || tri) && *(unsigned char *)uplo == 'L'; - unit = tri && *(unsigned char *)diag == 'U'; - -/* Generate data in array A. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - if (gen || (upper && i__ <= j) || (lower && i__ >= j)) { - a[i__ + j * a_dim1] = sbeg_(reset) + *transl; - if (i__ != j) { -/* Set some elements to zero */ - if (*n > 3 && j == *n / 2) { - a[i__ + j * a_dim1] = (float)0.; - } - if (sym) { - a[j + i__ * a_dim1] = a[i__ + j * a_dim1]; - } else if (tri) { - a[j + i__ * a_dim1] = (float)0.; - } - } - } -/* L10: */ - } - if (tri) { - a[j + j * a_dim1] += (float)1.; - } - if (unit) { - a[j + j * a_dim1] = (float)1.; - } -/* L20: */ - } - -/* Store elements in array AS in data structure required by routine. */ - - if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - aa[i__ + (j - 1) * *lda] = a[i__ + j * a_dim1]; -/* L30: */ - } - i__2 = *lda; - for (i__ = *m + 1; i__ <= i__2; ++i__) { - aa[i__ + (j - 1) * *lda] = (float)-1e10; -/* L40: */ - } -/* L50: */ - } - } else if (s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__, - "TR", (ftnlen)2, (ftnlen)2) == 0) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (upper) { - ibeg = 1; - if (unit) { - iend = j - 1; - } else { - iend = j; - } - } else { - if (unit) { - ibeg = j + 1; - } else { - ibeg = j; - } - iend = *n; - } - i__2 = ibeg - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - aa[i__ + (j - 1) * *lda] = (float)-1e10; -/* L60: */ - } - i__2 = iend; - for (i__ = ibeg; i__ <= i__2; ++i__) { - aa[i__ + (j - 1) * *lda] = a[i__ + j * a_dim1]; -/* L70: */ - } - i__2 = *lda; - for (i__ = iend + 1; i__ <= i__2; ++i__) { - aa[i__ + (j - 1) * *lda] = (float)-1e10; -/* L80: */ - } -/* L90: */ - } - } - return 0; - -/* End of SMAKE. */ - -} /* smake_ */ - -/* Subroutine */ int smmch_(char* transa, char* transb, integer* m, integer* n, integer* kk, real* alpha, real* a, integer* lda, real* b, integer* ldb, real* beta, real* c__, integer* ldc, real* ct, real* g, real* cc, integer* ldcc, real* eps, real* err, logical* fatal, integer* nout, logical* mv, ftnlen transa_len, ftnlen transb_len) -{ - - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, cc_dim1, - cc_offset, i__1, i__2, i__3; - real r__1, r__2; - - /* Builtin functions */ - double sqrt(double); - - /* Local variables */ - static real erri; - static integer i__, j, k; - static logical trana, tranb; - -/* Checks the results of the computational tests. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Parameters .. */ -/* .. Scalar Arguments .. */ -/* .. Array Arguments .. */ -/* .. Local Scalars .. */ -/* .. Intrinsic Functions .. */ -/* .. Executable Statements .. */ - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1 * 1; - b -= b_offset; - c_dim1 = *ldc; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - --ct; - --g; - cc_dim1 = *ldcc; - cc_offset = 1 + cc_dim1 * 1; - cc -= cc_offset; - - /* Function Body */ - trana = *(unsigned char *)transa == 'T' || *(unsigned char *)transa == - 'C'; - tranb = *(unsigned char *)transb == 'T' || *(unsigned char *)transb == - 'C'; - -/* Compute expected result, one column at a time, in CT using data */ -/* in A, B and C. */ -/* Compute gauges in G. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - ct[i__] = (float)0.; - g[i__] = (float)0.; -/* L10: */ - } - if (! trana && ! tranb) { - i__2 = *kk; - for (k = 1; k <= i__2; ++k) { - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - ct[i__] += a[i__ + k * a_dim1] * b[k + j * b_dim1]; - g[i__] += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) * ( - r__2 = b[k + j * b_dim1], dabs(r__2)); -/* L20: */ - } -/* L30: */ - } - } else if (trana && ! tranb) { - i__2 = *kk; - for (k = 1; k <= i__2; ++k) { - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - ct[i__] += a[k + i__ * a_dim1] * b[k + j * b_dim1]; - g[i__] += (r__1 = a[k + i__ * a_dim1], dabs(r__1)) * ( - r__2 = b[k + j * b_dim1], dabs(r__2)); -/* L40: */ - } -/* L50: */ - } - } else if (! trana && tranb) { - i__2 = *kk; - for (k = 1; k <= i__2; ++k) { - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - ct[i__] += a[i__ + k * a_dim1] * b[j + k * b_dim1]; - g[i__] += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) * ( - r__2 = b[j + k * b_dim1], dabs(r__2)); -/* L60: */ - } -/* L70: */ - } - } else if (trana && tranb) { - i__2 = *kk; - for (k = 1; k <= i__2; ++k) { - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - ct[i__] += a[k + i__ * a_dim1] * b[j + k * b_dim1]; - g[i__] += (r__1 = a[k + i__ * a_dim1], dabs(r__1)) * ( - r__2 = b[j + k * b_dim1], dabs(r__2)); -/* L80: */ - } -/* L90: */ - } - } - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - ct[i__] = *alpha * ct[i__] + *beta * c__[i__ + j * c_dim1]; - g[i__] = dabs(*alpha) * g[i__] + dabs(*beta) * (r__1 = c__[i__ + - j * c_dim1], dabs(r__1)); -/* L100: */ - } - -/* Compute the error ratio for this result. */ - - *err = (float)0.; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - erri = (r__1 = ct[i__] - cc[i__ + j * cc_dim1], dabs(r__1)) / * - eps; - if (g[i__] != (float)0.) { - erri /= g[i__]; - } - *err = dmax(*err,erri); - if (*err * sqrt(*eps) >= (float)1.) { - goto L130; - } -/* L110: */ - } - -/* L120: */ - } - -/* If the loop completes, all results are at least half accurate. */ - goto L150; - -/* Report fatal error. */ - -L130: - *fatal = TRUE_; - printf(" ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HALF ACCURATE *******\n"); - printf(" EXPECTED RESULT COMPUTED RESULT\n"); - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - if (*mv) { - printf("%7d %15.6g %15.6g\n",i__,ct[i__],cc[i__+j*cc_dim1]); } else { - printf("%7d %15.6g %15.6g\n",i__,cc[i__+j*cc_dim1],ct[i__]); - } -/* L140: */ - } - if (*n > 1) { - printf(" THESE ARE THE RESULTS FOR COLUMN %d\n",j); - } - -L150: - return 0; - - -/* End of SMMCH. */ - -} /* smmch_ */ - -logical lse_(real* ri, real* rj, integer* lr) -{ - /* System generated locals */ - integer i__1; - logical ret_val; - - /* Local variables */ - static integer i__; - - -/* Tests if two arrays are identical. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Scalar Arguments .. */ -/* .. Array Arguments .. */ -/* .. Local Scalars .. */ -/* .. Executable Statements .. */ - /* Parameter adjustments */ - --rj; - --ri; - - /* Function Body */ - i__1 = *lr; - for (i__ = 1; i__ <= i__1; ++i__) { - if (ri[i__] != rj[i__]) { - goto L20; - } -/* L10: */ - } - ret_val = TRUE_; - goto L30; -L20: - ret_val = FALSE_; -L30: - return ret_val; - -/* End of LSE. */ - -} /* lse_ */ - -logical lseres_(char* type__, char* uplo, integer* m, integer* n, real* aa, real* as, integer* lda, ftnlen type_len, ftnlen uplo_len) -{ - /* System generated locals */ - integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2; - logical ret_val; - - /* Builtin functions */ - - /* Local variables */ - static integer ibeg, iend, i__, j; - static logical upper; - - -/* Tests if selected elements in two arrays are equal. */ - -/* TYPE is 'GE' or 'SY'. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Scalar Arguments .. */ -/* .. Array Arguments .. */ -/* .. Local Scalars .. */ -/* .. Executable Statements .. */ - /* Parameter adjustments */ - as_dim1 = *lda; - as_offset = 1 + as_dim1 * 1; - as -= as_offset; - aa_dim1 = *lda; - aa_offset = 1 + aa_dim1 * 1; - aa -= aa_offset; - - /* Function Body */ - upper = *(unsigned char *)uplo == 'U'; - if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *lda; - for (i__ = *m + 1; i__ <= i__2; ++i__) { - if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) { - goto L70; + for (i=0;i= 5) { - ic = 0; - goto L10; - } - ret_val = (i__ - 500) / (float)1001.; - return ret_val; - -/* End of SBEG. */ - -} /* sbeg_ */ - -doublereal sdiff_(real* x, real* y) -{ - /* System generated locals */ - real ret_val; - - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Scalar Arguments .. */ -/* .. Executable Statements .. */ - ret_val = *x - *y; - return ret_val; + pCd(z) = zdotc; +} +#endif +/* -- translated by f2c (version 20000121). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ -/* End of SDIFF. */ -} /* sdiff_ */ -/* Main program alias */ /*int sblat3_ () { MAIN__ (); }*/ diff --git a/ctest/c_zblat3c.c b/ctest/c_zblat3c.c index 6025c0052..447b23014 100644 --- a/ctest/c_zblat3c.c +++ b/ctest/c_zblat3c.c @@ -10,7 +10,25 @@ #undef I #endif -#include "common.h" +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif typedef blasint integer; @@ -22,11 +40,14 @@ typedef double doublereal; typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; #ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} #else static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} #endif #define pCf(z) (*_pCf(z)) @@ -226,6 +247,7 @@ typedef struct Namelist Namelist; #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } #define sig_die(s, kill) { exit(1); } #define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; #define z_abs(z) (cabs(Cd(z))) #define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} #define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} @@ -239,3713 +261,251 @@ typedef struct Namelist Namelist; /* procedure parameter types for -A and -C++ */ #define F2C_proc_par_types 1 - - -/* Common Block Declarations */ - -struct { - integer infot, noutc; - logical ok, lerr; -} infoc_; - -#define infoc_1 infoc_ - -struct { - char srnamt[12]; -} srnamc_; - -#define srnamc_1 srnamc_ - -/* Table of constant values */ - -static doublecomplex c_b1 = {0.,0.}; -static doublecomplex c_b2 = {1.,0.}; -static integer c__1 = 1; -static integer c__65 = 65; -static doublereal c_b92 = 1.; -static integer c__6 = 6; -static logical c_true = TRUE_; -static integer c__0 = 0; -static logical c_false = FALSE_; - -/* Main program MAIN__() */ int main(void) -{ - /* Initialized data */ - - static char snames[9][13] = { "cblas_zgemm ", "cblas_zhemm ", "cblas_zsymm ", "cblas_ztrmm ", - "cblas_ztrsm ", "cblas_zherk ", "cblas_zsyrk ", "cblas_zher2k", "cblas_zsyr2k"}; - - /* System generated locals */ - integer i__1, i__2, i__3, i__4, i__5; - doublereal d__1; - - /* Builtin functions */ - integer s_rsle(void), do_lio(void), e_rsle(void), f_open(void), s_wsfe(void), do_fio(void), - e_wsfe(void), s_wsle(void), e_wsle(void), s_rsfe(void), e_rsfe(void); - - /* Local variables */ - static integer nalf, idim[9]; - static logical same; - static integer nbet, ntra; - static logical rewi; - extern /* Subroutine */ int zchk1_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublereal*, integer*, ftnlen); - extern /* Subroutine */ int zchk2_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublereal*, integer*, ftnlen); - extern /* Subroutine */ int zchk3_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublereal*, doublecomplex*, integer*, ftnlen); - extern /* Subroutine */ int zchk4_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublereal*, integer*, ftnlen); - extern /* Subroutine */ int zchk5_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublereal*, doublecomplex*, integer*, ftnlen); - static doublecomplex c__[4225] /* was [65][65] */; - static doublereal g[65]; - static integer i__, j; - extern doublereal ddiff_(doublereal*, doublereal*); - static integer n; - static logical fatal; - static doublecomplex w[130]; - static logical trace; - static integer nidim; - extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); - static char snaps[32]; - static integer isnum; - static logical ltest[9]; - static doublecomplex aa[4225], ab[8450] /* was [65][130] */, bb[4225], - cc[4225], as[4225], bs[4225], cs[4225], ct[65]; - static logical sfatal, corder; - static char snamet[12], transa[1], transb[1]; - static doublereal thresh; - static logical rorder; - static integer layout; - static logical ltestt, tsterr; - extern /* Subroutine */ int cz3chke_(char*, ftnlen); - static doublecomplex alf[7], bet[7]; - static doublereal eps, err; - extern logical lze_(doublecomplex*, doublecomplex*, integer*); - char tmpchar; - -/* Test program for the COMPLEX*16 Level 3 Blas. */ - -/* The program must be driven by a short data file. The first 13 records */ -/* of the file are read using list-directed input, the last 9 records */ -/* are read using the format ( A12,L2 ). An annotated example of a data */ -/* file can be obtained by deleting the first 3 characters from the */ -/* following 22 lines: */ -/* 'CBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE */ -/* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) */ -/* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. */ -/* F LOGICAL FLAG, T TO STOP ON FAILURES. */ -/* T LOGICAL FLAG, T TO TEST ERROR EXITS. */ -/* 2 0 TO TEST COLUMN-MAJOR, 1 TO TEST ROW-MAJOR, 2 TO TEST BOTH */ -/* 16.0 THRESHOLD VALUE OF TEST RATIO */ -/* 6 NUMBER OF VALUES OF N */ -/* 0 1 2 3 5 9 VALUES OF N */ -/* 3 NUMBER OF VALUES OF ALPHA */ -/* (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA */ -/* 3 NUMBER OF VALUES OF BETA */ -/* (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA */ -/* ZGEMM T PUT F FOR NO TEST. SAME COLUMNS. */ -/* ZHEMM T PUT F FOR NO TEST. SAME COLUMNS. */ -/* ZSYMM T PUT F FOR NO TEST. SAME COLUMNS. */ -/* ZTRMM T PUT F FOR NO TEST. SAME COLUMNS. */ -/* ZTRSM T PUT F FOR NO TEST. SAME COLUMNS. */ -/* ZHERK T PUT F FOR NO TEST. SAME COLUMNS. */ -/* ZSYRK T PUT F FOR NO TEST. SAME COLUMNS. */ -/* ZHER2K T PUT F FOR NO TEST. SAME COLUMNS. */ -/* ZSYR2K T PUT F FOR NO TEST. SAME COLUMNS. */ - -/* See: */ - -/* Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. */ -/* A Set of Level 3 Basic Linear Algebra Subprograms. */ - -/* Technical Memorandum No.88 (Revision 1), Mathematics and */ -/* Computer Science Division, Argonne National Laboratory, 9700 */ -/* South Cass Avenue, Argonne, Illinois 60439, US. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Parameters .. */ -/* .. Local Scalars .. */ -/* .. Local Arrays .. */ -/* .. External Functions .. */ -/* .. External Subroutines .. */ -/* .. Intrinsic Functions .. */ -/* .. Scalars in Common .. */ -/* .. Common blocks .. */ -/* .. Data statements .. */ -/* .. Executable Statements .. */ - - infoc_1.noutc = 6; - -/* Read name and unit number for snapshot output file and open file. */ - - char line[80]; - - fgets(line,80,stdin); - sscanf(line,"'%s'",snaps); - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&ntra); +#ifdef __cplusplus +typedef logical (*L_fp)(...); #else - sscanf(line,"%d",&ntra); +typedef logical (*L_fp)(); #endif - trace = ntra >= 0; - if (trace) { -/* o__1.oerr = 0; - o__1.ounit = ntra; - o__1.ofnmlen = 32; - o__1.ofnm = snaps; - o__1.orl = 0; - o__1.osta = "NEW"; - o__1.oacc = 0; - o__1.ofm = 0; - o__1.oblnk = 0; - f_open(&o__1);*/ - } -/* Read the flag that directs rewinding of the snapshot file. */ - fgets(line,80,stdin); - sscanf(line,"%d",&rewi); - rewi = rewi && trace; -/* Read the flag that directs stopping on any failure. */ - fgets(line,80,stdin); - sscanf(line,"%c",&tmpchar); - sfatal=FALSE_; - if (tmpchar=='T')sfatal=TRUE_; -/* Read the flag that indicates whether error exits are to be tested. */ - fgets(line,80,stdin); - sscanf(line,"%c",&tmpchar); - tsterr=FALSE_; - if (tmpchar=='T')tsterr=TRUE_; -/* Read the flag that indicates whether row-major data layout to be tested. */ - fgets(line,80,stdin); - sscanf(line,"%d",&layout); -/* Read the threshold value of the test ratio */ - fgets(line,80,stdin); - sscanf(line,"%lf",&thresh); -/* Read and check the parameter values for the tests. */ - -/* Values of N */ - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%d",&nidim); -#else - sscanf(line,"%d",&nidim); -#endif - if (nidim < 1 || nidim > 9) { - fprintf(stderr,"NUMBER OF VALUES OF N IS LESS THAN 1 OR GREATER THAN 9"); - goto L220; - } - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld %ld %ld %ld %ld %ld %ld %ld %ld",&idim[0],&idim[1],&idim[2], - &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]); -#else - sscanf(line,"%d %d %d %d %d %d %d %d %d",&idim[0],&idim[1],&idim[2], - &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]); -#endif - i__1 = nidim; - for (i__ = 1; i__ <= i__1; ++i__) { - if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) { - fprintf(stderr,"VALUE OF N IS LESS THAN 0 OR GREATER THAN 65\n"); - goto L220; - } -/* L10: */ - } -/* Values of ALPHA */ - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&nalf); +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} #else - sscanf(line,"%d",&nalf); +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} #endif - if (nalf < 1 || nalf > 7) { - fprintf(stderr,"VALUE OF ALPHA IS LESS THAN 0 OR GREATER THAN 7\n"); - goto L220; - } - fgets(line,80,stdin); - sscanf(line,"(%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf)",&alf[0].r,&alf[0].i,&alf[1].r,&alf[1].i,&alf[2].r,&alf[2].i,&alf[3].r,&alf[3].i, - &alf[4].r,&alf[4].i,&alf[5].r,&alf[5].i,&alf[6].r,&alf[6].i); - -/* Values of BETA */ - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&nbet); +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} #else - sscanf(line,"%d",&nbet); +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} #endif - if (nalf < 1 || nbet > 7) { - fprintf(stderr,"VALUE OF BETA IS LESS THAN 0 OR GREATER THAN 7\n"); - goto L220; - } - fgets(line,80,stdin); - sscanf(line,"(%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf)",&bet[0].r,&bet[0].i,&bet[1].r,&bet[1].i,&bet[2].r,&bet[2].i,&bet[3].r,&bet[3].i, - &bet[4].r,&bet[4].i,&bet[5].r,&bet[5].i,&bet[6].r,&bet[6].i); - -/* Report values of parameters. */ - - printf("TESTS OF THE DOUBLE PRECISION COMPLEX LEVEL 3 BLAS\nTHE FOLLOWING PARAMETER VALUES WILL BE USED:\n"); - printf(" FOR N"); - for (i__ =1; i__ <=nidim;++i__) printf(" %d",idim[i__-1]); - printf("\n"); - printf(" FOR ALPHA"); - for (i__ =1; i__ <=nalf;++i__) printf(" (%lf,%lf)",alf[i__-1].r,alf[i__-1].i); - printf("\n"); - printf(" FOR BETA"); - for (i__ =1; i__ <=nbet;++i__) printf(" (%lf,%lf)",bet[i__-1].r,bet[i__-1].i); - printf("\n"); - - if (! tsterr) { - printf(" ERROR-EXITS WILL NOT BE TESTED\n"); - } - - printf("ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LESS THAN %lf\n",thresh); - rorder = FALSE_; - corder = FALSE_; - if (layout == 2) { - rorder = TRUE_; - corder = TRUE_; - printf("COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED\n"); - } else if (layout == 1) { - rorder = TRUE_; - printf("ROW-MAJOR DATA LAYOUT IS TESTED\n"); - } else if (layout == 0) { - corder = TRUE_; - printf("COLUMN-MAJOR DATA LAYOUT IS TESTED\n"); - } - -/* Read names of subroutines and flags which indicate */ -/* whether they are to be tested. */ - - for (i__ = 1; i__ <= 9; ++i__) { - ltest[i__ - 1] = FALSE_; -/* L20: */ - } -L30: - if (! fgets(line,80,stdin)) { - goto L60; - } - i__1 = sscanf(line,"%12c %c",snamet,&tmpchar); - ltestt=FALSE_; - if (tmpchar=='T')ltestt=TRUE_; - if (i__1 < 2) { - goto L60; - } - for (i__ = 1; i__ <= 9; ++i__) { - if (s_cmp(snamet, snames[i__ - 1] , (ftnlen)12, (ftnlen)12) == - 0) { - goto L50; - } -/* L40: */ - } - printf("SUBPROGRAM NAME %s NOT RECOGNIZED\n****** TESTS ABANDONED ******\n",snamet); - exit(1); -L50: - ltest[i__ - 1] = ltestt; - goto L30; - -L60: -/* cl__1.cerr = 0; - cl__1.cunit = 5; - cl__1.csta = 0; - f_clos(&cl__1);*/ - -/* Compute EPS (the machine precision). */ - - eps = 1.; -L70: - d__1 = eps + 1.; - if (ddiff_(&d__1, &c_b92) == 0.) { - goto L80; - } - eps *= .5; - goto L70; -L80: - eps += eps; - printf("RELATIVE MACHINE PRECISION IS TAKEN TO BE %9.1g\n",eps); - -/* Check the reliability of ZMMCH using exact data. */ - - n = 32; - i__1 = n; - for (j = 1; j <= i__1; ++j) { - i__2 = n; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * 65 - 66; -/* Computing MAX */ - i__5 = i__ - j + 1; - i__4 = f2cmax(i__5,0); - ab[i__3].r = (doublereal) i__4, ab[i__3].i = 0.; -/* L90: */ - } - i__2 = j + 4224; - ab[i__2].r = (doublereal) j, ab[i__2].i = 0.; - i__2 = (j + 65) * 65 - 65; - ab[i__2].r = (doublereal) j, ab[i__2].i = 0.; - i__2 = j - 1; - c__[i__2].r = 0., c__[i__2].i = 0.; -/* L100: */ - } - i__1 = n; - for (j = 1; j <= i__1; ++j) { - i__2 = j - 1; - i__3 = j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3; - cc[i__2].r = (doublereal) i__3, cc[i__2].i = 0.; -/* L110: */ - } -/* CC holds the exact result. On exit from ZMMCH CT holds */ -/* the result computed by ZMMCH. */ - *(unsigned char *)transa = 'N'; - *(unsigned char *)transb = 'N'; - zmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], & - c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal, - &c__6, &c_true, (ftnlen)1, (ftnlen)1); - same = lze_(cc, ct, &n); - if (! same || err != 0.) { - printf("ERROR IN ZMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); - printf("ZMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); - printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); - printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); - printf("****** TESTS ABANDONED ******\n"); - exit(1); - } - *(unsigned char *)transb = 'C'; - zmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], & - c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal, - &c__6, &c_true, (ftnlen)1, (ftnlen)1); - same = lze_(cc, ct, &n); - if (! same || err != 0.) { - printf("ERROR IN ZMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); - printf("ZMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); - printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); - printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); - printf("****** TESTS ABANDONED ******\n"); - exit(1); - } - i__1 = n; - for (j = 1; j <= i__1; ++j) { - i__2 = j + 4224; - i__3 = n - j + 1; - ab[i__2].r = (doublereal) i__3, ab[i__2].i = 0.; - i__2 = (j + 65) * 65 - 65; - i__3 = n - j + 1; - ab[i__2].r = (doublereal) i__3, ab[i__2].i = 0.; -/* L120: */ - } - i__1 = n; - for (j = 1; j <= i__1; ++j) { - i__2 = n - j; - i__3 = j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3; - cc[i__2].r = (doublereal) i__3, cc[i__2].i = 0.; -/* L130: */ - } - *(unsigned char *)transa = 'C'; - *(unsigned char *)transb = 'N'; - zmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], & - c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal, - &c__6, &c_true, (ftnlen)1, (ftnlen)1); - same = lze_(cc, ct, &n); - if (! same || err != 0.) { - printf("ERROR IN ZMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); - printf("ZMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); - printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); - printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); - printf("****** TESTS ABANDONED ******\n"); - exit(1); - } - *(unsigned char *)transb = 'C'; - zmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], & - c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal, - &c__6, &c_true, (ftnlen)1, (ftnlen)1); - same = lze_(cc, ct, &n); - if (! same || err != 0.) { - printf("ERROR IN ZMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); - printf("ZMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); - printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); - printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); - printf("****** TESTS ABANDONED ******\n"); - exit(1); - } - -/* Test each subroutine in turn. */ - - for (isnum = 1; isnum <= 9; ++isnum) { - if (! ltest[isnum - 1]) { -/* Subprogram is not to be tested. */ - printf("%12s WAS NOT TESTED\n",snames[isnum-1]); - } else { - s_copy(srnamc_1.srnamt, snames[isnum - 1], (ftnlen)12, ( - ftnlen)12); -/* Test error exits. */ - if (tsterr) { - cz3chke_(snames[isnum - 1], (ftnlen)12); - } -/* Test computations. */ - infoc_1.infot = 0; - infoc_1.ok = TRUE_; - fatal = FALSE_; - switch ((int)isnum) { - case 1: goto L140; - case 2: goto L150; - case 3: goto L150; - case 4: goto L160; - case 5: goto L160; - case 6: goto L170; - case 7: goto L170; - case 8: goto L180; - case 9: goto L180; - } -/* Test ZGEMM, 01. */ -L140: - if (corder) { - zchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__0, (ftnlen)12); - } - if (rorder) { - zchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__1, (ftnlen)12); - } - goto L190; -/* Test ZHEMM, 02, ZSYMM, 03. */ -L150: - if (corder) { - zchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__0, (ftnlen)12); - } - if (rorder) { - zchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__1, (ftnlen)12); - } - goto L190; -/* Test ZTRMM, 04, ZTRSM, 05. */ -L160: - if (corder) { - zchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, & - c__0, (ftnlen)12); - } - if (rorder) { - zchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, & - c__1, (ftnlen)12); - } - goto L190; -/* Test ZHERK, 06, ZSYRK, 07. */ -L170: - if (corder) { - zchk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__0, (ftnlen)12); - } - if (rorder) { - zchk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__1, (ftnlen)12); - } - goto L190; -/* Test ZHER2K, 08, ZSYR2K, 09. */ -L180: - if (corder) { - zchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, - ct, g, w, &c__0, (ftnlen)12); - } - if (rorder) { - zchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, - &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & - nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, - ct, g, w, &c__1, (ftnlen)12); - } - goto L190; - -L190: - if (fatal && sfatal) { - goto L210; - } - } -/* L200: */ - } - printf("\nEND OF TESTS\n"); - goto L230; - -L210: - printf("\n****** FATAL ERROR - TESTS ABANDONED ******\n"); - goto L230; - -L220: - printf("AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM\n"); - printf("****** TESTS ABANDONED ******\n"); - -L230: - if (trace) { -/* cl__1.cerr = 0; - cl__1.cunit = ntra; - cl__1.csta = 0; - f_clos(&cl__1);*/ - } -/* cl__1.cerr = 0; - cl__1.cunit = 6; - cl__1.csta = 0; - f_clos(&cl__1);*/ - exit(0); - -/* End of ZBLAT3. */ - -} /* MAIN__ */ - -/* Subroutine */ int zchk1_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublecomplex* alf, integer* nbet, doublecomplex* bet, integer* nmax, doublecomplex* a, doublecomplex* aa, doublecomplex* as, doublecomplex* b, doublecomplex* bb, doublecomplex* bs, doublecomplex* c__, doublecomplex* cc, doublecomplex* cs, doublecomplex* ct, doublereal* g, integer* iorder, ftnlen sname_len) -{ - /* Initialized data */ - - static char ich[3+1] = "NTC"; - - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3, i__4, i__5, i__6, i__7, i__8; - - /* Local variables */ - static doublecomplex beta; - static integer ldas, ldbs, ldcs; - static logical same, null; - static integer i__, k, m, n; - static doublecomplex alpha; - static logical isame[13], trana, tranb; - extern /* Subroutine */ int zmake_(char*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, logical*, doublecomplex*, ftnlen, ftnlen, ftnlen); - static integer nargs; - extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); - static logical reset; - static integer ia, ib; - extern /* Subroutine */ int zprcn1_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, integer*, doublecomplex*, integer*, integer*, doublecomplex*, integer*, ftnlen, ftnlen, ftnlen); - static integer ma, mb, na, nb, nc, ik, im, in, ks, ms, ns; - extern /* Subroutine */ void czgemm_(integer*, char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); - static char tranas[1], tranbs[1], transa[1], transb[1]; - static doublereal errmax; - extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); - static integer ica, icb, laa, lbb, lda, lcc, ldb, ldc; - static doublecomplex als, bls; - static doublereal err; - extern logical lze_(doublecomplex*, doublecomplex*, integer*); - -/* Tests ZGEMM. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Parameters .. */ -/* .. Scalar Arguments .. */ -/* .. Array Arguments .. */ -/* .. Local Scalars .. */ -/* .. Local Arrays .. */ -/* .. External Functions .. */ -/* .. External Subroutines .. */ -/* .. Intrinsic Functions .. */ -/* .. Scalars in Common .. */ -/* .. Common blocks .. */ -/* .. Data statements .. */ - /* Parameter adjustments */ - --idim; - --alf; - --bet; - --g; - --ct; - --cs; - --cc; - c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - --bs; - --bb; - b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; - b -= b_offset; - --as; - --aa; - a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - - /* Function Body */ -/* .. Executable Statements .. */ - - nargs = 13; - nc = 0; - reset = TRUE_; - errmax = 0.; - - i__1 = *nidim; - for (im = 1; im <= i__1; ++im) { - m = idim[im]; - - i__2 = *nidim; - for (in = 1; in <= i__2; ++in) { - n = idim[in]; -/* Set LDC to 1 more than minimum value if room. */ - ldc = m; - if (ldc < *nmax) { - ++ldc; - } -/* Skip tests if not enough room. */ - if (ldc > *nmax) { - goto L100; - } - lcc = ldc * n; - null = n <= 0 || m <= 0; - - i__3 = *nidim; - for (ik = 1; ik <= i__3; ++ik) { - k = idim[ik]; - - for (ica = 1; ica <= 3; ++ica) { - *(unsigned char *)transa = *(unsigned char *)&ich[ica - 1] - ; - trana = *(unsigned char *)transa == 'T' || *(unsigned - char *)transa == 'C'; - - if (trana) { - ma = k; - na = m; - } else { - ma = m; - na = k; - } -/* Set LDA to 1 more than minimum value if room. */ - lda = ma; - if (lda < *nmax) { - ++lda; - } -/* Skip tests if not enough room. */ - if (lda > *nmax) { - goto L80; - } - laa = lda * na; - -/* Generate the matrix A. */ - - zmake_("ge", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[ - 1], &lda, &reset, &c_b1, (ftnlen)2, (ftnlen)1, ( - ftnlen)1); - - for (icb = 1; icb <= 3; ++icb) { - *(unsigned char *)transb = *(unsigned char *)&ich[icb - - 1]; - tranb = *(unsigned char *)transb == 'T' || *(unsigned - char *)transb == 'C'; - - if (tranb) { - mb = n; - nb = k; - } else { - mb = k; - nb = n; - } -/* Set LDB to 1 more than minimum value if room. */ - ldb = mb; - if (ldb < *nmax) { - ++ldb; - } -/* Skip tests if not enough room. */ - if (ldb > *nmax) { - goto L70; - } - lbb = ldb * nb; - -/* Generate the matrix B. */ - - zmake_("ge", " ", " ", &mb, &nb, &b[b_offset], nmax, & - bb[1], &ldb, &reset, &c_b1, (ftnlen)2, ( - ftnlen)1, (ftnlen)1); - - i__4 = *nalf; - for (ia = 1; ia <= i__4; ++ia) { - i__5 = ia; - alpha.r = alf[i__5].r, alpha.i = alf[i__5].i; - - i__5 = *nbet; - for (ib = 1; ib <= i__5; ++ib) { - i__6 = ib; - beta.r = bet[i__6].r, beta.i = bet[i__6].i; - -/* Generate the matrix C. */ - - zmake_("ge", " ", " ", &m, &n, &c__[c_offset], - nmax, &cc[1], &ldc, &reset, &c_b1, ( - ftnlen)2, (ftnlen)1, (ftnlen)1); - - ++nc; - -/* Save every datum before calling the */ -/* subroutine. */ - - *(unsigned char *)tranas = *(unsigned char *) - transa; - *(unsigned char *)tranbs = *(unsigned char *) - transb; - ms = m; - ns = n; - ks = k; - als.r = alpha.r, als.i = alpha.i; - i__6 = laa; - for (i__ = 1; i__ <= i__6; ++i__) { - i__7 = i__; - i__8 = i__; - as[i__7].r = aa[i__8].r, as[i__7].i = aa[ - i__8].i; -/* L10: */ - } - ldas = lda; - i__6 = lbb; - for (i__ = 1; i__ <= i__6; ++i__) { - i__7 = i__; - i__8 = i__; - bs[i__7].r = bb[i__8].r, bs[i__7].i = bb[ - i__8].i; -/* L20: */ - } - ldbs = ldb; - bls.r = beta.r, bls.i = beta.i; - i__6 = lcc; - for (i__ = 1; i__ <= i__6; ++i__) { - i__7 = i__; - i__8 = i__; - cs[i__7].r = cc[i__8].r, cs[i__7].i = cc[ - i__8].i; -/* L30: */ - } - ldcs = ldc; - -/* Call the subroutine. */ - - if (*trace) { - zprcn1_(ntra, &nc, sname, iorder, transa, - transb, &m, &n, &k, &alpha, &lda, - &ldb, &beta, &ldc, (ftnlen)12, ( - ftnlen)1, (ftnlen)1); - } - if (*rewi) { -/* al__1.aerr = 0; - al__1.aunit = *ntra; - f_rew(&al__1);*/ - } - czgemm_(iorder, transa, transb, &m, &n, &k, & - alpha, &aa[1], &lda, &bb[1], &ldb, & - beta, &cc[1], &ldc, (ftnlen)1, ( - ftnlen)1); - -/* Check if error-exit was taken incorrectly. */ - - if (! infoc_1.ok) { - printf(" *** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); - *fatal = TRUE_; - goto L120; - } - -/* See what data changed inside subroutines. */ - - isame[0] = *(unsigned char *)transa == *( - unsigned char *)tranas; - isame[1] = *(unsigned char *)transb == *( - unsigned char *)tranbs; - isame[2] = ms == m; - isame[3] = ns == n; - isame[4] = ks == k; - isame[5] = als.r == alpha.r && als.i == - alpha.i; - isame[6] = lze_(&as[1], &aa[1], &laa); - isame[7] = ldas == lda; - isame[8] = lze_(&bs[1], &bb[1], &lbb); - isame[9] = ldbs == ldb; - isame[10] = bls.r == beta.r && bls.i == - beta.i; - if (null) { - isame[11] = lze_(&cs[1], &cc[1], &lcc); - } else { - isame[11] = lzeres_("ge", " ", &m, &n, & - cs[1], &cc[1], &ldc, (ftnlen)2, ( - ftnlen)1); - } - isame[12] = ldcs == ldc; - -/* If data was incorrectly changed, report */ -/* and return. */ - - same = TRUE_; - i__6 = nargs; - for (i__ = 1; i__ <= i__6; ++i__) { - same = same && isame[i__ - 1]; - if (! isame[i__ - 1]) { - printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); - } -/* L40: */ - } - if (! same) { - *fatal = TRUE_; - goto L120; - } - - if (! null) { - -/* Check the result. */ - - zmmch_(transa, transb, &m, &n, &k, &alpha, - &a[a_offset], nmax, &b[b_offset], - nmax, &beta, &c__[c_offset], - nmax, &ct[1], &g[1], &cc[1], &ldc, - eps, &err, fatal, nout, &c_true, - (ftnlen)1, (ftnlen)1); - errmax = f2cmax(errmax,err); -/* If got really bad answer, report and */ -/* return. */ - if (*fatal) { - goto L120; - } - } - -/* L50: */ - } - -/* L60: */ - } - -L70: - ; - } - -L80: - ; - } - -/* L90: */ - } - -L100: - ; - } - -/* L110: */ - } - -/* Report result. */ - - if (errmax < *thresh) { - if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); - } - if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); - } - } else { - if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); - } - if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); - } - } - goto L130; - -L120: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); - zprcn1_(nout, &nc, sname, iorder, transa, transb, &m, &n, &k, &alpha, & - lda, &ldb, &beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); - -L130: - return 0; - -/* 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',', */ -/* $ 3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, */ -/* $ ',(', F4.1, ',', F4.1, '), C,', I3, ').' ) */ - -/* End of ZCHK1. */ - -} /* zchk1_ */ - - -/* Subroutine */ int zprcn1_(integer* nout, integer* nc, char* sname, integer* iorder, char* transa, char* transb, integer* m, integer* n, integer* k, doublecomplex* alpha, integer* lda, integer* ldb, doublecomplex* beta, integer* ldc, ftnlen sname_len, ftnlen transa_len, ftnlen transb_len) +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) { - /* Local variables */ - static char crc[14], cta[14], ctb[14]; - - if (*(unsigned char *)transa == 'N') { - s_copy(cta, " CblasNoTrans", (ftnlen)14, (ftnlen)14); - } else if (*(unsigned char *)transa == 'T') { - s_copy(cta, " CblasTrans", (ftnlen)14, (ftnlen)14); - } else { - s_copy(cta, "CblasConjTrans", (ftnlen)14, (ftnlen)14); - } - if (*(unsigned char *)transb == 'N') { - s_copy(ctb, " CblasNoTrans", (ftnlen)14, (ftnlen)14); - } else if (*(unsigned char *)transb == 'T') { - s_copy(ctb, " CblasTrans", (ftnlen)14, (ftnlen)14); - } else { - s_copy(ctb, "CblasConjTrans", (ftnlen)14, (ftnlen)14); - } - if (*iorder == 1) { - s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); - } else { - s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); - } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cta,ctb); - printf("%d %d %d (%4.1lf,%4.1lf) , A, %d, B, %d, (%4.1lf,%4.1lf) , C, %d.\n",*m,*n,*k,alpha->r,alpha->i,*lda,*ldb,beta->r,beta->i,*ldc); - -return 0; -} /* zprcn1_ */ - - -/* Subroutine */ int zchk2_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublecomplex* alf, integer* nbet, doublecomplex* bet, integer* nmax, doublecomplex* a, doublecomplex* aa, doublecomplex* as, doublecomplex* b, doublecomplex* bb, doublecomplex* bs, doublecomplex* c__, doublecomplex* cc, doublecomplex* cs, doublecomplex* ct, doublereal* g, integer* iorder, ftnlen sname_len) + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) { - /* Initialized data */ - - static char ichs[2+1] = "LR"; - static char ichu[2+1] = "UL"; - - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3, i__4, i__5, i__6, i__7; - - /* Local variables */ - static doublecomplex beta; - static integer ldas, ldbs, ldcs; - static logical same; - static char side[1]; - static logical isconj, left, null; - static char uplo[1]; - static integer i__, m, n; - static doublecomplex alpha; - static logical isame[13]; - static char sides[1]; - extern /* Subroutine */ int zmake_(char*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, logical*, doublecomplex*, ftnlen, ftnlen, ftnlen); - static integer nargs; - extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); - static logical reset; - static char uplos[1]; - static integer ia, ib; - extern /* Subroutine */ int zprcn2_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublecomplex*, integer*, integer*, doublecomplex*, integer*, ftnlen, ftnlen, ftnlen); - static integer na, nc, im, in, ms, ns; - extern /* Subroutine */ void czhemm_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); - static doublereal errmax; - extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); - extern /* Subroutine */ void czsymm_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); - static integer laa, lbb, lda, lcc, ldb, ldc, ics; - static doublecomplex als, bls; - static integer icu; - static doublereal err; - extern logical lze_(doublecomplex*, doublecomplex*, integer*); - -/* Tests ZHEMM and ZSYMM. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Parameters .. */ -/* .. Scalar Arguments .. */ -/* .. Array Arguments .. */ -/* .. Local Scalars .. */ -/* .. Local Arrays .. */ -/* .. External Functions .. */ -/* .. External Subroutines .. */ -/* .. Intrinsic Functions .. */ -/* .. Scalars in Common .. */ -/* .. Common blocks .. */ -/* .. Data statements .. */ - /* Parameter adjustments */ - --idim; - --alf; - --bet; - --g; - --ct; - --cs; - --cc; - c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - --bs; - --bb; - b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; - b -= b_offset; - --as; - --aa; - a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - - /* Function Body */ -/* .. Executable Statements .. */ - isconj = s_cmp(sname + 7, "he", (ftnlen)2, (ftnlen)2) == 0; - - nargs = 12; - nc = 0; - reset = TRUE_; - errmax = 0.; - - i__1 = *nidim; - for (im = 1; im <= i__1; ++im) { - m = idim[im]; - - i__2 = *nidim; - for (in = 1; in <= i__2; ++in) { - n = idim[in]; -/* Set LDC to 1 more than minimum value if room. */ - ldc = m; - if (ldc < *nmax) { - ++ldc; - } -/* Skip tests if not enough room. */ - if (ldc > *nmax) { - goto L90; - } - lcc = ldc * n; - null = n <= 0 || m <= 0; -/* Set LDB to 1 more than minimum value if room. */ - ldb = m; - if (ldb < *nmax) { - ++ldb; - } -/* Skip tests if not enough room. */ - if (ldb > *nmax) { - goto L90; - } - lbb = ldb * n; - -/* Generate the matrix B. */ - - zmake_("ge", " ", " ", &m, &n, &b[b_offset], nmax, &bb[1], &ldb, & - reset, &c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)1); - - for (ics = 1; ics <= 2; ++ics) { - *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1]; - left = *(unsigned char *)side == 'L'; - - if (left) { - na = m; - } else { - na = n; + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i *nmax) { - goto L80; + } + pCf(z) = zdotc; +} +#else + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;ir,alpha->i,*lda,*ldb,beta->r,beta->i,*ldc); - -return 0; -} /* zprcn2_ */ - - -/* Subroutine */ int zchk3_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublecomplex* alf, integer* nmax, doublecomplex* a, doublecomplex* aa, doublecomplex* as, doublecomplex* b, doublecomplex* bb, doublecomplex* bs, doublecomplex* ct, doublereal* g, doublecomplex* c__, integer* iorder, ftnlen sname_len) -{ - /* Initialized data */ - - static char ichu[2+1] = "UL"; - static char icht[3+1] = "NTC"; - static char ichd[2+1] = "UN"; - static char ichs[2+1] = "LR"; - - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3, i__4, i__5, i__6, i__7; - doublecomplex z__1; - - /* Local variables */ - static char diag[1]; - static integer ldas, ldbs; - static logical same; - static char side[1]; - static logical left, null; - static char uplo[1]; - static integer i__, j, m, n; - static doublecomplex alpha; - static char diags[1]; - static logical isame[13]; - static char sides[1]; - extern /* Subroutine */ int zmake_(char*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, logical*, doublecomplex*, ftnlen, ftnlen, ftnlen); - static integer nargs; - extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); - static logical reset; - static char uplos[1]; - static integer ia, na; - extern /* Subroutine */ int zprcn3_(integer*, integer*, char*, integer*, char*, char*, char*, char*, integer*, integer*, doublecomplex*, integer*, integer*, ftnlen, ftnlen, ftnlen, ftnlen, ftnlen); - static integer nc, im, in, ms, ns; - static char tranas[1], transa[1]; - static doublereal errmax; - extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); - extern /* Subroutine */ void cztrmm_(integer*, char*, char*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, ftnlen, ftnlen, ftnlen, ftnlen); - extern /* Subroutine */ void cztrsm_(integer*, char*, char*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, ftnlen, ftnlen, ftnlen, ftnlen); - static integer laa, icd, lbb, lda, ldb, ics; - static doublecomplex als; - static integer ict, icu; - static doublereal err; - extern logical lze_(doublecomplex*, doublecomplex*, integer*); - -/* Tests ZTRMM and ZTRSM. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Parameters .. */ -/* .. Scalar Arguments .. */ -/* .. Array Arguments .. */ -/* .. Local Scalars .. */ -/* .. Local Arrays .. */ -/* .. External Functions .. */ -/* .. External Subroutines .. */ -/* .. Intrinsic Functions .. */ -/* .. Scalars in Common .. */ -/* .. Common blocks .. */ -/* .. Data statements .. */ - /* Parameter adjustments */ - --idim; - --alf; - c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - --g; - --ct; - --bs; - --bb; - b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; - b -= b_offset; - --as; - --aa; - a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - - /* Function Body */ -/* .. Executable Statements .. */ - - nargs = 11; - nc = 0; - reset = TRUE_; - errmax = 0.; -/* Set up zero matrix for ZMMCH. */ - i__1 = *nmax; - for (j = 1; j <= i__1; ++j) { - i__2 = *nmax; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * c_dim1; - c__[i__3].r = 0., c__[i__3].i = 0.; -/* L10: */ + pCf(z) = zdotc; +} +#else + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i *nmax) { - goto L130; - } - lbb = ldb * n; - null = m <= 0 || n <= 0; - - for (ics = 1; ics <= 2; ++ics) { - *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1]; - left = *(unsigned char *)side == 'L'; - if (left) { - na = m; - } else { - na = n; + pCf(z) = zdotc; +} +#endif +static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Dcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i *nmax) { - goto L130; + } + pCd(z) = zdotc; +} +#else + _Complex double zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;ir,alpha->i,*lda,*ldb); - -return 0; -} /* zprcn3_ */ - - -/* Subroutine */ int zchk4_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublecomplex* alf, integer* nbet, doublecomplex* bet, integer* nmax, doublecomplex* a, doublecomplex* aa, doublecomplex* as, doublecomplex* b, doublecomplex* bb, doublecomplex* bs, doublecomplex* c__, doublecomplex* cc, doublecomplex* cs, doublecomplex* ct, doublereal* g, integer* iorder, ftnlen sname_len) -{ - /* Initialized data */ - - static char icht[2+1] = "NC"; - static char ichu[2+1] = "UL"; - - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3, i__4, i__5, i__6, i__7; - doublecomplex z__1; - - /* Local variables */ - static doublecomplex beta; - static integer ldas, ldcs; - static logical same, isconj; - static doublecomplex bets; - static doublereal rals; - static logical tran, null; - static char uplo[1]; - static integer i__, j, k, n; - static doublecomplex alpha; - static doublereal rbeta; - static logical isame[13]; - extern /* Subroutine */ int zmake_(char*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, logical*, doublecomplex*, ftnlen, ftnlen, ftnlen); - static integer nargs; - extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); - static doublereal rbets; - static logical reset; - static char trans[1]; - static logical upper; - static char uplos[1]; - static integer ia, ib, jc, ma, na; - extern /* Subroutine */ int zprcn4_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, ftnlen, ftnlen, ftnlen); - static integer nc; - extern /* Subroutine */ int zprcn6_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen); - static integer ik, in, jj, lj, ks, ns; - static doublereal ralpha; - extern /* Subroutine */ int czherk_(integer*, char*, char*, integer*, integer*, doublereal*, doublecomplex*, integer*, doublereal*, doublecomplex*, integer*, ftnlen, ftnlen); - static doublereal errmax; - extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); - static char transs[1], transt[1]; - extern /* Subroutine */ int czsyrk_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); - static integer laa, lda, lcc, ldc; - static doublecomplex als; - static integer ict, icu; - static doublereal err; - extern logical lze_(doublecomplex*, doublecomplex*, integer*); - -/* Tests ZHERK and ZSYRK. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Parameters .. */ -/* .. Scalar Arguments .. */ -/* .. Array Arguments .. */ -/* .. Local Scalars .. */ -/* .. Local Arrays .. */ -/* .. External Functions .. */ -/* .. External Subroutines .. */ -/* .. Intrinsic Functions .. */ -/* .. Scalars in Common .. */ -/* .. Common blocks .. */ -/* .. Data statements .. */ - /* Parameter adjustments */ - --idim; - --alf; - --bet; - --g; - --ct; - --cs; - --cc; - c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - --bs; - --bb; - b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; - b -= b_offset; - --as; - --aa; - a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - - /* Function Body */ -/* .. Executable Statements .. */ - isconj = s_cmp(sname + 7, "he", (ftnlen)2, (ftnlen)2) == 0; - - nargs = 10; - nc = 0; - reset = TRUE_; - errmax = 0.; - rals = 1.; - rbets = 1.; - - i__1 = *nidim; - for (in = 1; in <= i__1; ++in) { - n = idim[in]; -/* Set LDC to 1 more than minimum value if room. */ - ldc = n; - if (ldc < *nmax) { - ++ldc; - } -/* Skip tests if not enough room. */ - if (ldc > *nmax) { - goto L100; - } - lcc = ldc * n; - - i__2 = *nidim; - for (ik = 1; ik <= i__2; ++ik) { - k = idim[ik]; - - for (ict = 1; ict <= 2; ++ict) { - *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1]; - tran = *(unsigned char *)trans == 'C'; - if (tran && ! isconj) { - *(unsigned char *)trans = 'T'; - } - if (tran) { - ma = k; - na = n; - } else { - ma = n; - na = k; - } -/* Set LDA to 1 more than minimum value if room. */ - lda = ma; - if (lda < *nmax) { - ++lda; - } -/* Skip tests if not enough room. */ - if (lda > *nmax) { - goto L80; - } - laa = lda * na; - -/* Generate the matrix A. */ - - zmake_("ge", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[1], & - lda, &reset, &c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)1); - - for (icu = 1; icu <= 2; ++icu) { - *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; - upper = *(unsigned char *)uplo == 'U'; - - i__3 = *nalf; - for (ia = 1; ia <= i__3; ++ia) { - i__4 = ia; - alpha.r = alf[i__4].r, alpha.i = alf[i__4].i; - if (isconj) { - ralpha = alpha.r; - z__1.r = ralpha, z__1.i = 0.; - alpha.r = z__1.r, alpha.i = z__1.i; - } - - i__4 = *nbet; - for (ib = 1; ib <= i__4; ++ib) { - i__5 = ib; - beta.r = bet[i__5].r, beta.i = bet[i__5].i; - if (isconj) { - rbeta = beta.r; - z__1.r = rbeta, z__1.i = 0.; - beta.r = z__1.r, beta.i = z__1.i; - } - null = n <= 0; - if (isconj) { - null = null ||( (k <= 0 || ralpha == 0.) && - rbeta == 1.); - } - -/* Generate the matrix C. */ - - zmake_(sname + 7, uplo, " ", &n, &n, &c__[ - c_offset], nmax, &cc[1], &ldc, &reset, & - c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)1); - - ++nc; - -/* Save every datum before calling the subroutine. */ - - *(unsigned char *)uplos = *(unsigned char *)uplo; - *(unsigned char *)transs = *(unsigned char *) - trans; - ns = n; - ks = k; - if (isconj) { - rals = ralpha; - } else { - als.r = alpha.r, als.i = alpha.i; - } - i__5 = laa; - for (i__ = 1; i__ <= i__5; ++i__) { - i__6 = i__; - i__7 = i__; - as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7] - .i; -/* L10: */ - } - ldas = lda; - if (isconj) { - rbets = rbeta; - } else { - bets.r = beta.r, bets.i = beta.i; - } - i__5 = lcc; - for (i__ = 1; i__ <= i__5; ++i__) { - i__6 = i__; - i__7 = i__; - cs[i__6].r = cc[i__7].r, cs[i__6].i = cc[i__7] - .i; -/* L20: */ - } - ldcs = ldc; - -/* Call the subroutine. */ - - if (isconj) { - if (*trace) { - zprcn6_(ntra, &nc, sname, iorder, uplo, - trans, &n, &k, &ralpha, &lda, & - rbeta, &ldc, (ftnlen)12, (ftnlen) - 1, (ftnlen)1); - } - if (*rewi) { -/* al__1.aerr = 0; - al__1.aunit = *ntra; - f_rew(&al__1);*/ - } - czherk_(iorder, uplo, trans, &n, &k, &ralpha, - &aa[1], &lda, &rbeta, &cc[1], &ldc, ( - ftnlen)1, (ftnlen)1); - } else { - if (*trace) { - zprcn4_(ntra, &nc, sname, iorder, uplo, - trans, &n, &k, &alpha, &lda, & - beta, &ldc, (ftnlen)12, (ftnlen)1, - (ftnlen)1); - } - if (*rewi) { -/* al__1.aerr = 0; - al__1.aunit = *ntra; - f_rew(&al__1);*/ - } - czsyrk_(iorder, uplo, trans, &n, &k, &alpha, & - aa[1], &lda, &beta, &cc[1], &ldc, ( - ftnlen)1, (ftnlen)1); - } - -/* Check if error-exit was taken incorrectly. */ - - if (! infoc_1.ok) { - printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); - *fatal = TRUE_; - goto L120; - } - -/* See what data changed inside subroutines. */ - - isame[0] = *(unsigned char *)uplos == *(unsigned - char *)uplo; - isame[1] = *(unsigned char *)transs == *(unsigned - char *)trans; - isame[2] = ns == n; - isame[3] = ks == k; - if (isconj) { - isame[4] = rals == ralpha; - } else { - isame[4] = als.r == alpha.r && als.i == - alpha.i; - } - isame[5] = lze_(&as[1], &aa[1], &laa); - isame[6] = ldas == lda; - if (isconj) { - isame[7] = rbets == rbeta; - } else { - isame[7] = bets.r == beta.r && bets.i == - beta.i; - } - if (null) { - isame[8] = lze_(&cs[1], &cc[1], &lcc); - } else { - isame[8] = lzeres_(sname + 7, uplo, &n, &n, & - cs[1], &cc[1], &ldc, (ftnlen)2, ( - ftnlen)1); - } - isame[9] = ldcs == ldc; - -/* If data was incorrectly changed, report and */ -/* return. */ - - same = TRUE_; - i__5 = nargs; - for (i__ = 1; i__ <= i__5; ++i__) { - same = same && isame[i__ - 1]; - if (! isame[i__ - 1]) { - printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); - } -/* L30: */ - } - if (! same) { - *fatal = TRUE_; - goto L120; - } - - if (! null) { - -/* Check the result column by column. */ - - if (isconj) { - *(unsigned char *)transt = 'C'; - } else { - *(unsigned char *)transt = 'T'; - } - jc = 1; - i__5 = n; - for (j = 1; j <= i__5; ++j) { - if (upper) { - jj = 1; - lj = j; - } else { - jj = j; - lj = n - j + 1; - } - if (tran) { - zmmch_(transt, "N", &lj, &c__1, &k, & - alpha, &a[jj * a_dim1 + 1], - nmax, &a[j * a_dim1 + 1], - nmax, &beta, &c__[jj + j * - c_dim1], nmax, &ct[1], &g[1], - &cc[jc], &ldc, eps, &err, - fatal, nout, &c_true, (ftnlen) - 1, (ftnlen)1); - } else { - zmmch_("N", transt, &lj, &c__1, &k, & - alpha, &a[jj + a_dim1], nmax, - &a[j + a_dim1], nmax, &beta, & - c__[jj + j * c_dim1], nmax, & - ct[1], &g[1], &cc[jc], &ldc, - eps, &err, fatal, nout, & - c_true, (ftnlen)1, (ftnlen)1); - } - if (upper) { - jc += ldc; - } else { - jc = jc + ldc + 1; - } - errmax = f2cmax(errmax,err); -/* If got really bad answer, report and */ -/* return. */ - if (*fatal) { - goto L110; - } -/* L40: */ - } - } - -/* L50: */ - } - -/* L60: */ - } - -/* L70: */ - } - -L80: - ; - } - -/* L90: */ - } - -L100: - ; - } - -/* Report result. */ - - if (errmax < *thresh) { - if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); - } - if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); - } - } else { - if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); - } - if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); - } - } - goto L130; - -L110: - if (n > 1) { - printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j); - } - -L120: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); - if (isconj) { - zprcn6_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &ralpha, &lda, - &rbeta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); - } else { - zprcn4_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, & - beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); - } - -L130: - return 0; - -/* 9994 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ -/* $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') ', */ -/* $ ' .' ) */ -/* 9993 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ -/* $ '(', F4.1, ',', F4.1, ') , A,', I3, ',(', F4.1, ',', F4.1, */ -/* $ '), C,', I3, ') .' ) */ - -/* End of CCHK4. */ - -} /* zchk4_ */ - - -/* Subroutine */ int zprcn4_(integer* nout, integer* nc, char* sname, integer* iorder, char* uplo, char* transa, integer* n, integer* k, doublecomplex* alpha, integer* lda, doublecomplex* beta, integer* ldc, ftnlen sname_len, ftnlen uplo_len, ftnlen transa_len) -{ - /* Local variables */ - static char ca[14], cu[14], crc[14]; - - if (*(unsigned char *)uplo == 'U') { - s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); - } else { - s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); - } - if (*(unsigned char *)transa == 'N') { - s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); - } else if (*(unsigned char *)transa == 'T') { - s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); - } else { - s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); - } - if (*iorder == 1) { - s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); - } else { - s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); - } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); - printf("( %d %d (%4.1lf,%4.1lf) A %d (%4.1lf,%4.1lf) C %d\n",*n,*k,alpha->r,alpha->i,*lda,beta->r,beta->i,*ldc); - -return 0; -} /* zprcn4_ */ - - - -/* Subroutine */ int zprcn6_(integer* nout, integer* nc, char* sname, integer* iorder, char* uplo, char* transa, integer* n, integer* k, doublereal* alpha, integer* lda, doublereal* beta, integer* ldc, ftnlen sname_len, ftnlen uplo_len, ftnlen transa_len) -{ - - /* Local variables */ - static char ca[14], cu[14], crc[14]; - - if (*(unsigned char *)uplo == 'U') { - s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); - } else { - s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); - } - if (*(unsigned char *)transa == 'N') { - s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); - } else if (*(unsigned char *)transa == 'T') { - s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); - } else { - s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); - } - if (*iorder == 1) { - s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); - } else { - s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); - } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); - printf("( %d %d %4.1lf A %d %4.1lf C %d\n",*n,*k,*alpha,*lda,*beta,*ldc); - -return 0; -} /* zprcn6_ */ - - -/* Subroutine */ int zchk5_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublecomplex* alf, integer* nbet, doublecomplex* bet, integer* nmax, doublecomplex* ab, doublecomplex* aa, doublecomplex* as, doublecomplex* bb, doublecomplex* bs, doublecomplex* c__, doublecomplex* cc, doublecomplex* cs, doublecomplex* ct, doublereal* g, doublecomplex* w, integer* iorder, ftnlen sname_len) -{ - /* Initialized data */ - - static char icht[2+1] = "NC"; - static char ichu[2+1] = "UL"; - - /* System generated locals */ - integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8; - doublecomplex z__1, z__2; - - /* Local variables */ - static integer jjab; - static doublecomplex beta; - static integer ldas, ldbs, ldcs; - static logical same, isconj; - static doublecomplex bets; - static logical tran, null; - static char uplo[1]; - static integer i__, j, k, n; - static doublecomplex alpha; - static doublereal rbeta; - static logical isame[13]; - extern /* Subroutine */ int zmake_(char*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, logical*, doublecomplex*, ftnlen, ftnlen, ftnlen); - static integer nargs; - extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); - static doublereal rbets; - static logical reset; - static char trans[1]; - static logical upper; - static char uplos[1]; - static integer ia, ib, jc, ma, na, nc; - extern /* Subroutine */ int zprcn5_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublecomplex*, integer*, integer*, doublecomplex*, integer*, ftnlen, ftnlen, ftnlen); - extern /* Subroutine */ int zprcn7_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublecomplex*, integer*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen); - static integer ik, in, jj, lj, ks, ns; - static doublereal errmax; - extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); - static char transs[1], transt[1]; - extern /* Subroutine */ int czher2k_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublereal*, doublecomplex*, integer*, ftnlen, ftnlen); - static integer laa, lbb, lda, lcc, ldb, ldc; - static doublecomplex als; - static integer ict, icu; - extern /* Subroutine */ int czsyr2k_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); - static doublereal err; - extern logical lze_(doublecomplex*, doublecomplex*, integer*); - -/* Tests ZHER2K and ZSYR2K. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Parameters .. */ -/* .. Scalar Arguments .. */ -/* .. Array Arguments .. */ -/* .. Local Scalars .. */ -/* .. Local Arrays .. */ -/* .. External Functions .. */ -/* .. External Subroutines .. */ -/* .. Intrinsic Functions .. */ -/* .. Scalars in Common .. */ -/* .. Common blocks .. */ -/* .. Data statements .. */ - /* Parameter adjustments */ - --idim; - --alf; - --bet; - --w; - --g; - --ct; - --cs; - --cc; - c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - --bs; - --bb; - --as; - --aa; - --ab; - - /* Function Body */ -/* .. Executable Statements .. */ - isconj = s_cmp(sname + 7, "he", (ftnlen)2, (ftnlen)2) == 0; - - nargs = 12; - nc = 0; - reset = TRUE_; - errmax = 0.; - - i__1 = *nidim; - for (in = 1; in <= i__1; ++in) { - n = idim[in]; -/* Set LDC to 1 more than minimum value if room. */ - ldc = n; - if (ldc < *nmax) { - ++ldc; - } -/* Skip tests if not enough room. */ - if (ldc > *nmax) { - goto L130; - } - lcc = ldc * n; - - i__2 = *nidim; - for (ik = 1; ik <= i__2; ++ik) { - k = idim[ik]; - - for (ict = 1; ict <= 2; ++ict) { - *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1]; - tran = *(unsigned char *)trans == 'C'; - if (tran && ! isconj) { - *(unsigned char *)trans = 'T'; - } - if (tran) { - ma = k; - na = n; - } else { - ma = n; - na = k; - } -/* Set LDA to 1 more than minimum value if room. */ - lda = ma; - if (lda < *nmax) { - ++lda; - } -/* Skip tests if not enough room. */ - if (lda > *nmax) { - goto L110; - } - laa = lda * na; - -/* Generate the matrix A. */ - - if (tran) { - i__3 = *nmax << 1; - zmake_("ge", " ", " ", &ma, &na, &ab[1], &i__3, &aa[1], & - lda, &reset, &c_b1, (ftnlen)2, (ftnlen)1, (ftnlen) - 1); - } else { - zmake_("ge", " ", " ", &ma, &na, &ab[1], nmax, &aa[1], & - lda, &reset, &c_b1, (ftnlen)2, (ftnlen)1, (ftnlen) - 1); - } - -/* Generate the matrix B. */ - - ldb = lda; - lbb = laa; - if (tran) { - i__3 = *nmax << 1; - zmake_("ge", " ", " ", &ma, &na, &ab[k + 1], &i__3, &bb[1] - , &ldb, &reset, &c_b1, (ftnlen)2, (ftnlen)1, ( - ftnlen)1); - } else { - zmake_("ge", " ", " ", &ma, &na, &ab[k * *nmax + 1], nmax, - &bb[1], &ldb, &reset, &c_b1, (ftnlen)2, (ftnlen) - 1, (ftnlen)1); - } - - for (icu = 1; icu <= 2; ++icu) { - *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; - upper = *(unsigned char *)uplo == 'U'; - - i__3 = *nalf; - for (ia = 1; ia <= i__3; ++ia) { - i__4 = ia; - alpha.r = alf[i__4].r, alpha.i = alf[i__4].i; - - i__4 = *nbet; - for (ib = 1; ib <= i__4; ++ib) { - i__5 = ib; - beta.r = bet[i__5].r, beta.i = bet[i__5].i; - if (isconj) { - rbeta = beta.r; - z__1.r = rbeta, z__1.i = 0.; - beta.r = z__1.r, beta.i = z__1.i; - } - null = n <= 0; - if (isconj) { - null = null ||( (k <= 0 || (alpha.r == 0. && - alpha.i == 0.)) && rbeta == 1.); - } - -/* Generate the matrix C. */ - - zmake_(sname + 7, uplo, " ", &n, &n, &c__[ - c_offset], nmax, &cc[1], &ldc, &reset, & - c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)1); - - ++nc; - -/* Save every datum before calling the subroutine. */ - - *(unsigned char *)uplos = *(unsigned char *)uplo; - *(unsigned char *)transs = *(unsigned char *) - trans; - ns = n; - ks = k; - als.r = alpha.r, als.i = alpha.i; - i__5 = laa; - for (i__ = 1; i__ <= i__5; ++i__) { - i__6 = i__; - i__7 = i__; - as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7] - .i; -/* L10: */ - } - ldas = lda; - i__5 = lbb; - for (i__ = 1; i__ <= i__5; ++i__) { - i__6 = i__; - i__7 = i__; - bs[i__6].r = bb[i__7].r, bs[i__6].i = bb[i__7] - .i; -/* L20: */ - } - ldbs = ldb; - if (isconj) { - rbets = rbeta; - } else { - bets.r = beta.r, bets.i = beta.i; - } - i__5 = lcc; - for (i__ = 1; i__ <= i__5; ++i__) { - i__6 = i__; - i__7 = i__; - cs[i__6].r = cc[i__7].r, cs[i__6].i = cc[i__7] - .i; -/* L30: */ - } - ldcs = ldc; - -/* Call the subroutine. */ - - if (isconj) { - if (*trace) { - zprcn7_(ntra, &nc, sname, iorder, uplo, - trans, &n, &k, &alpha, &lda, &ldb, - &rbeta, &ldc, (ftnlen)12, ( - ftnlen)1, (ftnlen)1); - } - if (*rewi) { -/* al__1.aerr = 0; - al__1.aunit = *ntra; - f_rew(&al__1);*/ - } - czher2k_(iorder, uplo, trans, &n, &k, &alpha, - &aa[1], &lda, &bb[1], &ldb, &rbeta, & - cc[1], &ldc, (ftnlen)1, (ftnlen)1); - } else { - if (*trace) { - zprcn5_(ntra, &nc, sname, iorder, uplo, - trans, &n, &k, &alpha, &lda, &ldb, - &beta, &ldc, (ftnlen)12, (ftnlen) - 1, (ftnlen)1); - } - if (*rewi) { -/* al__1.aerr = 0; - al__1.aunit = *ntra; - f_rew(&al__1);*/ - } - czsyr2k_(iorder, uplo, trans, &n, &k, &alpha, - &aa[1], &lda, &bb[1], &ldb, &beta, & - cc[1], &ldc, (ftnlen)1, (ftnlen)1); - } - -/* Check if error-exit was taken incorrectly. */ - - if (! infoc_1.ok) { - printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); - *fatal = TRUE_; - goto L150; - } - -/* See what data changed inside subroutines. */ - - isame[0] = *(unsigned char *)uplos == *(unsigned - char *)uplo; - isame[1] = *(unsigned char *)transs == *(unsigned - char *)trans; - isame[2] = ns == n; - isame[3] = ks == k; - isame[4] = als.r == alpha.r && als.i == alpha.i; - isame[5] = lze_(&as[1], &aa[1], &laa); - isame[6] = ldas == lda; - isame[7] = lze_(&bs[1], &bb[1], &lbb); - isame[8] = ldbs == ldb; - if (isconj) { - isame[9] = rbets == rbeta; - } else { - isame[9] = bets.r == beta.r && bets.i == - beta.i; - } - if (null) { - isame[10] = lze_(&cs[1], &cc[1], &lcc); - } else { - isame[10] = lzeres_("he", uplo, &n, &n, &cs[1] - , &cc[1], &ldc, (ftnlen)2, (ftnlen)1); - } - isame[11] = ldcs == ldc; - -/* If data was incorrectly changed, report and */ -/* return. */ - - same = TRUE_; - i__5 = nargs; - for (i__ = 1; i__ <= i__5; ++i__) { - same = same && isame[i__ - 1]; - if (! isame[i__ - 1]) { - printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); - } -/* L40: */ - } - if (! same) { - *fatal = TRUE_; - goto L150; - } - - if (! null) { - -/* Check the result column by column. */ - - if (isconj) { - *(unsigned char *)transt = 'C'; - } else { - *(unsigned char *)transt = 'T'; - } - jjab = 1; - jc = 1; - i__5 = n; - for (j = 1; j <= i__5; ++j) { - if (upper) { - jj = 1; - lj = j; - } else { - jj = j; - lj = n - j + 1; - } - if (tran) { - i__6 = k; - for (i__ = 1; i__ <= i__6; ++i__) { - i__7 = i__; - i__8 = ((j - 1) << 1) * *nmax + k + - i__; - z__1.r = alpha.r * ab[i__8].r - - alpha.i * ab[i__8].i, - z__1.i = alpha.r * ab[ - i__8].i + alpha.i * ab[ - i__8].r; - w[i__7].r = z__1.r, w[i__7].i = - z__1.i; - if (isconj) { - i__7 = k + i__; - d_cnjg(&z__2, &alpha); - i__8 = ((j - 1) << 1) * *nmax + i__; - z__1.r = z__2.r * ab[i__8].r - z__2.i * ab[i__8].i, - z__1.i = z__2.r * ab[i__8].i + z__2.i * ab[ - i__8].r; - w[i__7].r = z__1.r, w[i__7].i = z__1.i; - } else { - i__7 = k + i__; - i__8 = ((j - 1) << 1) * *nmax + i__; - z__1.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8] - .i, z__1.i = alpha.r * ab[i__8].i + alpha.i - * ab[i__8].r; - w[i__7].r = z__1.r, w[i__7].i = z__1.i; - } -/* L50: */ - } - i__6 = k << 1; - i__7 = *nmax << 1; - i__8 = *nmax << 1; - zmmch_(transt, "N", &lj, &c__1, &i__6, - &c_b2, &ab[jjab], &i__7, &w[ - 1], &i__8, &beta, &c__[jj + j - * c_dim1], nmax, &ct[1], &g[1] - , &cc[jc], &ldc, eps, &err, - fatal, nout, &c_true, (ftnlen) - 1, (ftnlen)1); - } else { - i__6 = k; - for (i__ = 1; i__ <= i__6; ++i__) { - if (isconj) { - i__7 = i__; - d_cnjg(&z__2, &ab[(k + i__ - 1) * *nmax + j]); - z__1.r = alpha.r * z__2.r - alpha.i * z__2.i, - z__1.i = alpha.r * z__2.i + alpha.i * - z__2.r; - w[i__7].r = z__1.r, w[i__7].i = z__1.i; - i__7 = k + i__; - i__8 = (i__ - 1) * *nmax + j; - z__2.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8] - .i, z__2.i = alpha.r * ab[i__8].i + alpha.i - * ab[i__8].r; - d_cnjg(&z__1, &z__2); - w[i__7].r = z__1.r, w[i__7].i = z__1.i; - } else { - i__7 = i__; - i__8 = (k + i__ - 1) * *nmax + j; - z__1.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8] - .i, z__1.i = alpha.r * ab[i__8].i + alpha.i - * ab[i__8].r; - w[i__7].r = z__1.r, w[i__7].i = z__1.i; - i__7 = k + i__; - i__8 = (i__ - 1) * *nmax + j; - z__1.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8] - .i, z__1.i = alpha.r * ab[i__8].i + alpha.i - * ab[i__8].r; - w[i__7].r = z__1.r, w[i__7].i = z__1.i; - } -/* L60: */ - } - i__6 = k << 1; - i__7 = *nmax << 1; - zmmch_("N", "N", &lj, &c__1, &i__6, & - c_b2, &ab[jj], nmax, &w[1], & - i__7, &beta, &c__[jj + j * - c_dim1], nmax, &ct[1], &g[1], - &cc[jc], &ldc, eps, &err, - fatal, nout, &c_true, (ftnlen) - 1, (ftnlen)1); - } - if (upper) { - jc += ldc; - } else { - jc = jc + ldc + 1; - if (tran) { - jjab += *nmax << 1; - } - } - errmax = f2cmax(errmax,err); -/* If got really bad answer, report and */ -/* return. */ - if (*fatal) { - goto L140; - } -/* L70: */ - } - } - -/* L80: */ - } - -/* L90: */ - } - -/* L100: */ - } - -L110: - ; - } - -/* L120: */ - } - -L130: - ; - } - -/* Report result. */ - - if (errmax < *thresh) { - if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); - } - if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); - } - } else { - if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); - } - if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); - } - } - goto L160; - -L140: - if (n > 1) { - printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j); - } - -L150: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); - if (isconj) { - zprcn7_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, & - ldb, &rbeta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); - } else { - zprcn5_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, & - ldb, &beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); - } - -L160: - return 0; - -/* 9994 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ -/* $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',', F4.1, */ -/* $ ', C,', I3, ') .' ) */ -/* 9993 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ -/* $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1, */ -/* $ ',', F4.1, '), C,', I3, ') .' ) */ - -/* End of ZCHK5. */ - -} /* zchk5_ */ - - -/* Subroutine */ int zprcn5_(integer* nout, integer* nc, char* sname, integer* iorder, char* uplo, char* transa, integer* n, integer* k, doublecomplex* alpha, integer* lda, integer* ldb, doublecomplex* beta, integer* ldc, ftnlen sname_len, ftnlen uplo_len, ftnlen transa_len) -{ - /* Local variables */ - static char ca[14], cu[14], crc[14]; - - if (*(unsigned char *)uplo == 'U') { - s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); - } else { - s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); - } - if (*(unsigned char *)transa == 'N') { - s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); - } else if (*(unsigned char *)transa == 'T') { - s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); - } else { - s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); - } - if (*iorder == 1) { - s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); - } else { - s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); - } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); - printf("%d %d (%4.1lf,%4.1lf) , A, %d, B, %d, (%4.1lf,%4.1lf) , C, %d.\n",*n,*k,alpha->r,alpha->i,*lda,*ldb,beta->r,beta->i,*ldc); - -return 0; -} /* zprcn5_ */ - - - -/* Subroutine */ int zprcn7_(integer* nout, integer* nc, char* sname, integer* iorder, char* uplo, char* transa, integer* n, integer* k, doublecomplex* alpha, integer* lda, integer* ldb, doublereal* beta, integer* ldc, ftnlen sname_len, ftnlen uplo_len, ftnlen transa_len) -{ - - /* Local variables */ - static char ca[14], cu[14], crc[14]; - - if (*(unsigned char *)uplo == 'U') { - s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); - } else { - s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); - } - if (*(unsigned char *)transa == 'N') { - s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); - } else if (*(unsigned char *)transa == 'T') { - s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); - } else { - s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); - } - if (*iorder == 1) { - s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); - } else { - s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); - } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); - printf("%d %d (%4.1lf,%4.1lf), A, %d, B, %d, %4.1lf, C, %d.\n",*n,*k,alpha->r,alpha->i,*lda,*ldb,*beta,*ldc); - -return 0; -} /* zprcn7_ */ - - -/* Subroutine */ int zmake_(char* type__, char* uplo, char* diag, integer* m, integer* n, doublecomplex* a, integer* nmax, doublecomplex* aa, integer* lda, logical* reset, doublecomplex* transl, ftnlen type_len, ftnlen uplo_len, ftnlen diag_len) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - doublereal d__1; - doublecomplex z__1, z__2; - - /* Local variables */ - static integer ibeg, iend; - extern /* Double Complex */ VOID zbeg_(doublecomplex*, logical*); - static logical unit; - static integer i__, j; - static logical lower, upper; - static integer jj; - static logical gen, her, tri, sym; - - -/* Generates values for an M by N matrix A. */ -/* Stores the values in the array AA in the data structure required */ -/* by the routine, with unwanted elements set to rogue value. */ - -/* TYPE is 'ge', 'he', 'sy' or 'tr'. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Parameters .. */ -/* .. Scalar Arguments .. */ -/* .. Array Arguments .. */ -/* .. Local Scalars .. */ -/* .. External Functions .. */ -/* .. Intrinsic Functions .. */ -/* .. Executable Statements .. */ - /* Parameter adjustments */ - a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --aa; - - /* Function Body */ - gen = s_cmp(type__, "ge", (ftnlen)2, (ftnlen)2) == 0; - her = s_cmp(type__, "he", (ftnlen)2, (ftnlen)2) == 0; - sym = s_cmp(type__, "sy", (ftnlen)2, (ftnlen)2) == 0; - tri = s_cmp(type__, "tr", (ftnlen)2, (ftnlen)2) == 0; - upper = (her || sym || tri) && *(unsigned char *)uplo == 'U'; - lower = (her || sym || tri) && *(unsigned char *)uplo == 'L'; - unit = tri && *(unsigned char *)diag == 'U'; - -/* Generate data in array A. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - if (gen || (upper && i__ <= j) || (lower && i__ >= j)) { - i__3 = i__ + j * a_dim1; - zbeg_(&z__2, reset); - z__1.r = z__2.r + transl->r, z__1.i = z__2.i + transl->i; - a[i__3].r = z__1.r, a[i__3].i = z__1.i; - if (i__ != j) { -/* Set some elements to zero */ - if (*n > 3 && j == *n / 2) { - i__3 = i__ + j * a_dim1; - a[i__3].r = 0., a[i__3].i = 0.; - } - if (her) { - i__3 = j + i__ * a_dim1; - d_cnjg(&z__1, &a[i__ + j * a_dim1]); - a[i__3].r = z__1.r, a[i__3].i = z__1.i; - } else if (sym) { - i__3 = j + i__ * a_dim1; - i__4 = i__ + j * a_dim1; - a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i; - } else if (tri) { - i__3 = j + i__ * a_dim1; - a[i__3].r = 0., a[i__3].i = 0.; - } - } - } -/* L10: */ - } - if (her) { - i__2 = j + j * a_dim1; - i__3 = j + j * a_dim1; - d__1 = a[i__3].r; - z__1.r = d__1, z__1.i = 0.; - a[i__2].r = z__1.r, a[i__2].i = z__1.i; - } - if (tri) { - i__2 = j + j * a_dim1; - i__3 = j + j * a_dim1; - z__1.r = a[i__3].r + 1., z__1.i = a[i__3].i + 0.; - a[i__2].r = z__1.r, a[i__2].i = z__1.i; - } - if (unit) { - i__2 = j + j * a_dim1; - a[i__2].r = 1., a[i__2].i = 0.; - } -/* L20: */ - } - -/* Store elements in array AS in data structure required by routine. */ - - if (s_cmp(type__, "ge", (ftnlen)2, (ftnlen)2) == 0) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + (j - 1) * *lda; - i__4 = i__ + j * a_dim1; - aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i; -/* L30: */ - } - i__2 = *lda; - for (i__ = *m + 1; i__ <= i__2; ++i__) { - i__3 = i__ + (j - 1) * *lda; - aa[i__3].r = -1e10, aa[i__3].i = 1e10; -/* L40: */ - } -/* L50: */ - } - } else if (s_cmp(type__, "he", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__, - "sy", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__, "tr", (ftnlen) - 2, (ftnlen)2) == 0) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (upper) { - ibeg = 1; - if (unit) { - iend = j - 1; - } else { - iend = j; - } - } else { - if (unit) { - ibeg = j + 1; - } else { - ibeg = j; - } - iend = *n; - } - i__2 = ibeg - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + (j - 1) * *lda; - aa[i__3].r = -1e10, aa[i__3].i = 1e10; -/* L60: */ - } - i__2 = iend; - for (i__ = ibeg; i__ <= i__2; ++i__) { - i__3 = i__ + (j - 1) * *lda; - i__4 = i__ + j * a_dim1; - aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i; -/* L70: */ - } - i__2 = *lda; - for (i__ = iend + 1; i__ <= i__2; ++i__) { - i__3 = i__ + (j - 1) * *lda; - aa[i__3].r = -1e10, aa[i__3].i = 1e10; -/* L80: */ - } - if (her) { - jj = j + (j - 1) * *lda; - i__2 = jj; - i__3 = jj; - d__1 = aa[i__3].r; - z__1.r = d__1, z__1.i = -1e10; - aa[i__2].r = z__1.r, aa[i__2].i = z__1.i; - } -/* L90: */ - } - } - return 0; - -/* End of ZMAKE. */ - -} /* zmake_ */ - -/* Subroutine */ int zmmch_(char* transa, char* transb, integer* m, integer* n, integer* kk, doublecomplex* alpha, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* beta, doublecomplex* c__, integer* ldc, doublecomplex* ct, doublereal* g, doublecomplex* cc, integer* ldcc, doublereal* eps, doublereal* err, logical* fatal, integer* nout, logical* mv, ftnlen transa_len, ftnlen transb_len) -{ - - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, cc_dim1, - cc_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7; - doublereal d__1, d__2, d__3, d__4, d__5, d__6; - doublecomplex z__1, z__2, z__3, z__4; - - double sqrt(double); - /* Local variables */ - static doublereal erri; - static integer i__, j, k; - static logical trana, tranb, ctrana, ctranb; - -/* Checks the results of the computational tests. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Parameters .. */ -/* .. Scalar Arguments .. */ -/* .. Array Arguments .. */ -/* .. Local Scalars .. */ -/* .. Intrinsic Functions .. */ -/* .. Statement Functions .. */ -/* .. Statement Function definitions .. */ -/* .. Executable Statements .. */ - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1 * 1; - b -= b_offset; - c_dim1 = *ldc; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - --ct; - --g; - cc_dim1 = *ldcc; - cc_offset = 1 + cc_dim1 * 1; - cc -= cc_offset; - - /* Function Body */ - trana = *(unsigned char *)transa == 'T' || *(unsigned char *)transa == - 'C'; - tranb = *(unsigned char *)transb == 'T' || *(unsigned char *)transb == - 'C'; - ctrana = *(unsigned char *)transa == 'C'; - ctranb = *(unsigned char *)transb == 'C'; - -/* Compute expected result, one column at a time, in CT using data */ -/* in A, B and C. */ -/* Compute gauges in G. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__; - ct[i__3].r = 0., ct[i__3].i = 0.; - g[i__] = 0.; -/* L10: */ - } - if (! trana && ! tranb) { - i__2 = *kk; - for (k = 1; k <= i__2; ++k) { - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - i__4 = i__; - i__5 = i__; - i__6 = i__ + k * a_dim1; - i__7 = k + j * b_dim1; - z__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[i__7].i, - z__2.i = a[i__6].r * b[i__7].i + a[i__6].i * b[ - i__7].r; - z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i + - z__2.i; - ct[i__4].r = z__1.r, ct[i__4].i = z__1.i; - i__4 = i__ + k * a_dim1; - i__5 = k + j * b_dim1; - g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag( - &a[i__ + k * a_dim1]), abs(d__2))) * ((d__3 = b[ - i__5].r, abs(d__3)) + (d__4 = d_imag(&b[k + j * - b_dim1]), abs(d__4))); -/* L20: */ - } -/* L30: */ - } - } else if (trana && ! tranb) { - if (ctrana) { - i__2 = *kk; - for (k = 1; k <= i__2; ++k) { - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - i__4 = i__; - i__5 = i__; - d_cnjg(&z__3, &a[k + i__ * a_dim1]); - i__6 = k + j * b_dim1; - z__2.r = z__3.r * b[i__6].r - z__3.i * b[i__6].i, - z__2.i = z__3.r * b[i__6].i + z__3.i * b[i__6] - .r; - z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i + - z__2.i; - ct[i__4].r = z__1.r, ct[i__4].i = z__1.i; - i__4 = k + i__ * a_dim1; - i__5 = k + j * b_dim1; - g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = - d_imag(&a[k + i__ * a_dim1]), abs(d__2))) * (( - d__3 = b[i__5].r, abs(d__3)) + (d__4 = d_imag( - &b[k + j * b_dim1]), abs(d__4))); -/* L40: */ - } -/* L50: */ - } - } else { - i__2 = *kk; - for (k = 1; k <= i__2; ++k) { - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - i__4 = i__; - i__5 = i__; - i__6 = k + i__ * a_dim1; - i__7 = k + j * b_dim1; - z__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[i__7] - .i, z__2.i = a[i__6].r * b[i__7].i + a[i__6] - .i * b[i__7].r; - z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i + - z__2.i; - ct[i__4].r = z__1.r, ct[i__4].i = z__1.i; - i__4 = k + i__ * a_dim1; - i__5 = k + j * b_dim1; - g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = - d_imag(&a[k + i__ * a_dim1]), abs(d__2))) * (( - d__3 = b[i__5].r, abs(d__3)) + (d__4 = d_imag( - &b[k + j * b_dim1]), abs(d__4))); -/* L60: */ - } -/* L70: */ - } - } - } else if (! trana && tranb) { - if (ctranb) { - i__2 = *kk; - for (k = 1; k <= i__2; ++k) { - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - i__4 = i__; - i__5 = i__; - i__6 = i__ + k * a_dim1; - d_cnjg(&z__3, &b[j + k * b_dim1]); - z__2.r = a[i__6].r * z__3.r - a[i__6].i * z__3.i, - z__2.i = a[i__6].r * z__3.i + a[i__6].i * - z__3.r; - z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i + - z__2.i; - ct[i__4].r = z__1.r, ct[i__4].i = z__1.i; - i__4 = i__ + k * a_dim1; - i__5 = j + k * b_dim1; - g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = - d_imag(&a[i__ + k * a_dim1]), abs(d__2))) * (( - d__3 = b[i__5].r, abs(d__3)) + (d__4 = d_imag( - &b[j + k * b_dim1]), abs(d__4))); -/* L80: */ - } -/* L90: */ - } - } else { - i__2 = *kk; - for (k = 1; k <= i__2; ++k) { - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - i__4 = i__; - i__5 = i__; - i__6 = i__ + k * a_dim1; - i__7 = j + k * b_dim1; - z__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[i__7] - .i, z__2.i = a[i__6].r * b[i__7].i + a[i__6] - .i * b[i__7].r; - z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i + - z__2.i; - ct[i__4].r = z__1.r, ct[i__4].i = z__1.i; - i__4 = i__ + k * a_dim1; - i__5 = j + k * b_dim1; - g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = - d_imag(&a[i__ + k * a_dim1]), abs(d__2))) * (( - d__3 = b[i__5].r, abs(d__3)) + (d__4 = d_imag( - &b[j + k * b_dim1]), abs(d__4))); -/* L100: */ - } -/* L110: */ - } - } - } else if (trana && tranb) { - if (ctrana) { - if (ctranb) { - i__2 = *kk; - for (k = 1; k <= i__2; ++k) { - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - i__4 = i__; - i__5 = i__; - d_cnjg(&z__3, &a[k + i__ * a_dim1]); - d_cnjg(&z__4, &b[j + k * b_dim1]); - z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, - z__2.i = z__3.r * z__4.i + z__3.i * - z__4.r; - z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i - + z__2.i; - ct[i__4].r = z__1.r, ct[i__4].i = z__1.i; - i__4 = k + i__ * a_dim1; - i__5 = j + k * b_dim1; - g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = - d_imag(&a[k + i__ * a_dim1]), abs(d__2))) - * ((d__3 = b[i__5].r, abs(d__3)) + (d__4 - = d_imag(&b[j + k * b_dim1]), abs(d__4))); -/* L120: */ - } -/* L130: */ - } - } else { - i__2 = *kk; - for (k = 1; k <= i__2; ++k) { - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - i__4 = i__; - i__5 = i__; - d_cnjg(&z__3, &a[k + i__ * a_dim1]); - i__6 = j + k * b_dim1; - z__2.r = z__3.r * b[i__6].r - z__3.i * b[i__6].i, - z__2.i = z__3.r * b[i__6].i + z__3.i * b[ - i__6].r; - z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i - + z__2.i; - ct[i__4].r = z__1.r, ct[i__4].i = z__1.i; - i__4 = k + i__ * a_dim1; - i__5 = j + k * b_dim1; - g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = - d_imag(&a[k + i__ * a_dim1]), abs(d__2))) - * ((d__3 = b[i__5].r, abs(d__3)) + (d__4 - = d_imag(&b[j + k * b_dim1]), abs(d__4))); -/* L140: */ - } -/* L150: */ - } - } - } else { - if (ctranb) { - i__2 = *kk; - for (k = 1; k <= i__2; ++k) { - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - i__4 = i__; - i__5 = i__; - i__6 = k + i__ * a_dim1; - d_cnjg(&z__3, &b[j + k * b_dim1]); - z__2.r = a[i__6].r * z__3.r - a[i__6].i * z__3.i, - z__2.i = a[i__6].r * z__3.i + a[i__6].i * - z__3.r; - z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i - + z__2.i; - ct[i__4].r = z__1.r, ct[i__4].i = z__1.i; - i__4 = k + i__ * a_dim1; - i__5 = j + k * b_dim1; - g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = - d_imag(&a[k + i__ * a_dim1]), abs(d__2))) - * ((d__3 = b[i__5].r, abs(d__3)) + (d__4 - = d_imag(&b[j + k * b_dim1]), abs(d__4))); -/* L160: */ - } -/* L170: */ - } - } else { - i__2 = *kk; - for (k = 1; k <= i__2; ++k) { - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - i__4 = i__; - i__5 = i__; - i__6 = k + i__ * a_dim1; - i__7 = j + k * b_dim1; - z__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[ - i__7].i, z__2.i = a[i__6].r * b[i__7].i + - a[i__6].i * b[i__7].r; - z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i - + z__2.i; - ct[i__4].r = z__1.r, ct[i__4].i = z__1.i; - i__4 = k + i__ * a_dim1; - i__5 = j + k * b_dim1; - g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = - d_imag(&a[k + i__ * a_dim1]), abs(d__2))) - * ((d__3 = b[i__5].r, abs(d__3)) + (d__4 - = d_imag(&b[j + k * b_dim1]), abs(d__4))); -/* L180: */ - } -/* L190: */ - } - } - } - } - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__; - i__4 = i__; - z__2.r = alpha->r * ct[i__4].r - alpha->i * ct[i__4].i, z__2.i = - alpha->r * ct[i__4].i + alpha->i * ct[i__4].r; - i__5 = i__ + j * c_dim1; - z__3.r = beta->r * c__[i__5].r - beta->i * c__[i__5].i, z__3.i = - beta->r * c__[i__5].i + beta->i * c__[i__5].r; - z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; - ct[i__3].r = z__1.r, ct[i__3].i = z__1.i; - i__3 = i__ + j * c_dim1; - g[i__] = ((d__1 = alpha->r, abs(d__1)) + (d__2 = d_imag(alpha), - abs(d__2))) * g[i__] + ((d__3 = beta->r, abs(d__3)) + ( - d__4 = d_imag(beta), abs(d__4))) * ((d__5 = c__[i__3].r, - abs(d__5)) + (d__6 = d_imag(&c__[i__ + j * c_dim1]), abs( - d__6))); -/* L200: */ - } - -/* Compute the error ratio for this result. */ - - *err = 0.; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__; - i__4 = i__ + j * cc_dim1; - z__2.r = ct[i__3].r - cc[i__4].r, z__2.i = ct[i__3].i - cc[i__4] - .i; - z__1.r = z__2.r, z__1.i = z__2.i; - erri = ((d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), abs( - d__2))) / *eps; - if (g[i__] != 0.) { - erri /= g[i__]; - } - *err = f2cmax(*err,erri); - if (*err * sqrt(*eps) >= 1.) { - goto L230; - } -/* L210: */ - } - -/* L220: */ - } - -/* If the loop completes, all results are at least half accurate. */ - goto L250; - -/* Report fatal error. */ - -L230: - *fatal = TRUE_; - printf(" ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HALF ACCURATE *******\n"); - printf(" EXPECTED RESULT COMPUTED RESULT\n"); - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - if (*mv) { - printf("%7d (%15.6g,%15.6g) (%15.6g,%15.6g)\n",i__,ct[i__].r,ct[i__].i,cc[i__+j*cc_dim1].r,cc[i__+j*cc_dim1].i); - } else { - printf("%7d (%15.6g,%15.6g) (%15.6g,%15.6g)\n",i__,cc[i__+j*cc_dim1].r,cc[i__+j*cc_dim1].i,ct[i__].r,ct[i__].i); - } -/* L240: */ - } - if (*n > 1) { - printf(" THESE ARE THE RESULTS FOR COLUMN %d\n",j); - } - -L250: - return 0; - - -/* End of ZMMCH. */ - -} /* zmmch_ */ - -logical lze_(doublecomplex* ri, doublecomplex* rj, integer* lr) -{ - /* System generated locals */ - integer i__1, i__2, i__3; - logical ret_val; - - /* Local variables */ - static integer i__; - - -/* Tests if two arrays are identical. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Scalar Arguments .. */ -/* .. Array Arguments .. */ -/* .. Local Scalars .. */ -/* .. Executable Statements .. */ - /* Parameter adjustments */ - --rj; - --ri; - - /* Function Body */ - i__1 = *lr; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__; - i__3 = i__; - if (ri[i__2].r != rj[i__3].r || ri[i__2].i != rj[i__3].i) { - goto L20; - } -/* L10: */ - } - ret_val = TRUE_; - goto L30; -L20: - ret_val = FALSE_; -L30: - return ret_val; - -/* End of LZE. */ - -} /* lze_ */ - -logical lzeres_(char* type__, char* uplo, integer* m, integer* n, doublecomplex *aa, doublecomplex* as, integer* lda, ftnlen type_len, ftnlen uplo_len) -{ - /* System generated locals */ - integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2, i__3, i__4; - logical ret_val; - - /* Local variables */ - static integer ibeg, iend, i__, j; - static logical upper; - - -/* Tests if selected elements in two arrays are equal. */ - -/* TYPE is 'ge' or 'he' or 'sy'. */ - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Scalar Arguments .. */ -/* .. Array Arguments .. */ -/* .. Local Scalars .. */ -/* .. Executable Statements .. */ - /* Parameter adjustments */ - as_dim1 = *lda; - as_offset = 1 + as_dim1 * 1; - as -= as_offset; - aa_dim1 = *lda; - aa_offset = 1 + aa_dim1 * 1; - aa -= aa_offset; - - /* Function Body */ - upper = *(unsigned char *)uplo == 'U'; - if (s_cmp(type__, "ge", (ftnlen)2, (ftnlen)2) == 0) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *lda; - for (i__ = *m + 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * aa_dim1; - i__4 = i__ + j * as_dim1; - if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) { - goto L70; - } -/* L10: */ - } -/* L20: */ - } - } else if (s_cmp(type__, "he", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__, - "sy", (ftnlen)2, (ftnlen)2) == 0) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (upper) { - ibeg = 1; - iend = j; - } else { - ibeg = j; - iend = *n; - } - i__2 = ibeg - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * aa_dim1; - i__4 = i__ + j * as_dim1; - if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) { - goto L70; - } -/* L30: */ - } - i__2 = *lda; - for (i__ = iend + 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * aa_dim1; - i__4 = i__ + j * as_dim1; - if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) { - goto L70; - } -/* L40: */ - } -/* L50: */ - } - } - -/* 60 CONTINUE */ - ret_val = TRUE_; - goto L80; -L70: - ret_val = FALSE_; -L80: - return ret_val; - -/* End of LZERES. */ - -} /* lzeres_ */ - -/* Double Complex */ VOID zbeg_(doublecomplex* ret_val, logical* reset) -{ - /* System generated locals */ - doublereal d__1, d__2; - doublecomplex z__1; - - /* 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 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Scalar Arguments .. */ -/* .. Local Scalars .. */ -/* .. Save statement .. */ -/* .. Intrinsic Functions .. */ -/* .. 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; -L10: - i__ *= mi; - j *= mj; - i__ -= i__ / 1000 * 1000; - j -= j / 1000 * 1000; - if (ic >= 5) { - ic = 0; - goto L10; - } - d__1 = (i__ - 500) / 1001.; - d__2 = (j - 500) / 1001.; - z__1.r = d__1, z__1.i = d__2; - ret_val->r = z__1.r, ret_val->i = z__1.i; - return ; - -/* End of ZBEG. */ - -} /* zbeg_ */ - -doublereal ddiff_(doublereal* x, doublereal* y) -{ - /* System generated locals */ - doublereal ret_val; - - -/* Auxiliary routine for test program for Level 3 Blas. */ - -/* -- Written on 8-February-1989. */ -/* Jack Dongarra, Argonne National Laboratory. */ -/* Iain Duff, AERE Harwell. */ -/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ -/* Sven Hammarling, Numerical Algorithms Group Ltd. */ - -/* .. Scalar Arguments .. */ -/* .. Executable Statements .. */ - ret_val = *x - *y; - return ret_val; - -/* End of DDIFF. */ -} /* ddiff_ */ -/* Main program alias */ /*int zblat3_ () { MAIN__ (); }*/