diff options
| author | julie <julielangou@users.noreply.github.com> | 2014-08-15 20:14:26 +0000 |
|---|---|---|
| committer | julie <julielangou@users.noreply.github.com> | 2014-08-15 20:14:26 +0000 |
| commit | 91d9461d1a2cc1320177967ad2be279856cb8dbd (patch) | |
| tree | 820d1175cc4574e29bcb72aa48754c489e5e29ad | |
| parent | a00738d270f323fa43dd61a3c7e9ca5dd977d76c (diff) | |
| download | lapack-91d9461d1a2cc1320177967ad2be279856cb8dbd.tar.gz lapack-91d9461d1a2cc1320177967ad2be279856cb8dbd.tar.bz2 lapack-91d9461d1a2cc1320177967ad2be279856cb8dbd.zip | |
226 files changed, 55286 insertions, 0 deletions
diff --git a/cblas/CMakeLists.txt b/cblas/CMakeLists.txt new file mode 100644 index 00000000..c7d27220 --- /dev/null +++ b/cblas/CMakeLists.txt @@ -0,0 +1,7 @@ +cmake_minimum_required(VERSION 2.8.10) +project(CBLAS C) +enable_language(Fortran) + +include_directories( include ) +add_subdirectory(src) + diff --git a/cblas/Makefile b/cblas/Makefile new file mode 100644 index 00000000..d819280b --- /dev/null +++ b/cblas/Makefile @@ -0,0 +1,195 @@ +dlvl = ./. +include $(dlvl)/Makefile.in + +all: alllib alltst + +help: + @ echo "Make sure you are using correct Makefile.in for your system." + @ echo "At this level, assuming you have downloded all necessary " + @ echo "files and made an archive file of BLAS routines for your " + @ echo "system." + @ echo " " + @ echo "The Makefile compiles the routines of CBLAS (C interface of " + @ echo "BLAS) and testers for all the precisions. " + @ echo "If there is no directory for archives in CBLAS/lib, it " + @ echo "creates new directory with the name of the platform of your " + @ echo "machine." + @ echo " " + @ echo "To compile, you have to type as follows" + @ echo "make <target>" + @ echo " where <target> is one of:" + @ echo "slib1 --- make an archive of level 1 REAL." + @ echo "dlib1 --- make an archive of level 1 DOUBLE PRECISION." + @ echo "clib1 --- make an archive of level 1 COMPLEX." + @ echo "zlib1 --- make an archive of level 1 COMPLEX*16." + @ echo "alllib1 - make an archive of level 1 all precisions." + @ echo " " + @ echo "slib2 --- make an archive of level 2 REAL." + @ echo "dlib2 --- make an archive of level 2 DOUBLE PRECSION." + @ echo "clib2 --- make an archive of level 2 COMPLEX." + @ echo "zlib2 --- make an archive of level 2 COMPLEX*16." + @ echo "alllib2 - make an archive of level 2 all precisions." + @ echo " " + @ echo "slib3 --- make an archive of level 3 REAL." + @ echo "dlib3 --- make an archive of level 3 DOUBLE PRECISION ." + @ echo "clib3 --- make an archive of level 3 COMPLEX." + @ echo "zlib3 --- make an archive of level 3 COMPLEX*16." + @ echo "alllib3 - make an archive of level 3 all precisions." + @ echo " " + @ echo "alllib -- make an archive for all precisions." + @ echo " " + @ echo "stest1 -- Compiles the tester for level 1 REAL." + @ echo "dtest1 -- Compiles the tester for level 1 DOUBLE PRECISION. " + @ echo "ctest1 -- Compiles the tester for level 1 COMPLEX." + @ echo "ztest1 -- Compiles the tester for level 1 COMPLEX*16." + @ echo "alltst1 - Compiles testers for all precisions of level 1." + @ echo " " + @ echo "stest2 -- Compiles the tester for level 2 REAL." + @ echo "dtest2 -- Compiles the tester for level 2 DOUBLE PRECISION. " + @ echo "ctest2 -- Compiles the tester for level 2 COMPLEX." + @ echo "ztest2 -- Compiles the tester for level 2 COMPLEX*16." + @ echo "alltst2 - Compiles testers for all precisions of level 2." + @ echo " " + @ echo "stest3 -- Compiles the tester for level 3 REAL." + @ echo "dtest3 -- Compiles the tester for level 3 DOUBLE PRECISON. " + @ echo "ctest3 -- Compiles the tester for level 3 COMPLEX." + @ echo "ztest3 -- Compiles the tester for level 3 COMPLEX*16." + @ echo "alltst3 - Compiles testers for all precisions of level 3." + @ echo " " + @ echo "alltst -- Compiles testers for all CBLAS routines." + @ echo "runtst -- Execute testers for all CBLAS routines." + @ echo " " + @ echo "all ----- Creates a library and testers for ALL." + @ echo " " + @ echo "clean --- Erase all the .o and excutable files" + @ echo "cleanlib -- Erase all the .o files" + @ echo "cleanexe -- Erase all the excutable files" + @ echo "rmlib --- Remove a library file." + @ echo " " + @ echo "example -- Creates example1 and example2" + @ echo "example1 -- A small example to exercise the interface " + @ echo "example2 -- Test that cblas_xerbla() is working correctly" + @ echo " " + @ echo " ------- Warning ------- " + @ echo "If you want just to make a tester, make sure you have" + @ echo "already made an archive file out of CBLAS routines." + @ echo " " + @ echo "Written by Keita Teranishi" + @ echo "3/4/98 " + + +# In general, the Makefile call other Makefiles in the sub-directories. + + +clean: + ( cd testing && make clean ) + ( cd src && make clean ) + rm -f *.o cblas_ex1 cblas_ex2 + +cleanobj: + ( cd testing && make cleanobj ) + ( cd src && make clean ) + +cleanexe: + ( cd testing && make cleanexe ) + +rmlib: + ( rm -f $(CBLIB) ) +slib1: sreal1 +dlib1: dreal1 +clib1: scplx1 +zlib1: dcplx1 +slib2: sreal2 +dlib2: dreal2 +clib2: scplx2 +zlib2: dcplx2 +slib3: sreal3 +dlib3: dreal3 +clib3: scplx3 +zlib3: dcplx3 +alllib1: allprecision1 +alllib2: allprecision2 +alllib3: allprecision3 +alllib: allprecision + + +sreal1: + ( cd src && make slib1) +dreal1: + ( cd src && make dlib1) +scplx1: + ( cd src && make clib1) +dcplx1: + ( cd src && make zlib1) +allprecision1: + ( cd src && make all1) +sreal2: + ( cd src && make slib2) +dreal2: + ( cd src && make dlib2) +scplx2: + ( cd src && make clib2) +dcplx2: + ( cd src && make zlib2) +allprecision2: + ( cd src && make all2) +sreal3: + ( cd src && make slib3) +dreal3: + ( cd src && make dlib3) +scplx3: + ( cd src && make clib3) +dcplx3: + ( cd src && make zlib3) +allprecision3: + ( cd src && make all3) +allprecision: + ( cd src && make all) + +stest1: + ( cd testing && make stest1 ) +dtest1: + ( cd testing && make dtest1 ) +ctest1: + ( cd testing && make ctest1 ) +ztest1: + ( cd testing && make ztest1 ) +alltst1: + ( cd testing && make all1 ) +stest2: + ( cd testing && make stest2 ) +dtest2: + ( cd testing && make dtest2 ) +ctest2: + ( cd testing && make ctest2 ) +ztest2: + ( cd testing && make ztest2 ) +alltst2: + ( cd testing && make all2 ) +stest3: + ( cd testing && make stest3 ) +dtest3: + ( cd testing && make dtest3 ) +ctest3: + ( cd testing && make ctest3 ) +ztest3: + ( cd testing && make ztest3 ) +alltst3: + ( cd testing && make all3 ) +alltst: + ( cd testing && make all ) +runtst: + ( cd testing && make run ) + +example: alllib + ( cd examples && make all ) +example1: alllib + ( cd examples && make example1 ) +example2: alllib + ( cd examples && make example1 ) + + +cleanall: + ( cd src && rm -f a.out core *.o $(CBLIB) ) + ( cd testing && rm -f *.out core *.o x[sdcz]cblat[123] ) + ( cd examples && rm -f *.o cblas_ex1 cblas_ex2 ) diff --git a/cblas/Makefile.ALPHA b/cblas/Makefile.ALPHA new file mode 100644 index 00000000..9cf05f72 --- /dev/null +++ b/cblas/Makefile.ALPHA @@ -0,0 +1,50 @@ +# +# Makefile.ALPHA +# +# +# If you compile, change the name to Makefile.in. +# +# + +#----------------------------------------------------------------------------- +# Shell +#----------------------------------------------------------------------------- + +SHELL = /bin/sh + +#----------------------------------------------------------------------------- +# Platform +#----------------------------------------------------------------------------- + +PLAT = ALPHA + +#----------------------------------------------------------------------------- +# Libraries and includs +#----------------------------------------------------------------------------- + +BLLIB = libblas.a +CBLIB = ../lib/cblas_$(PLAT).a + +#----------------------------------------------------------------------------- +# Compilers +#----------------------------------------------------------------------------- + +CC = cc +FC = f77 +LOADER = $(FC) + +#----------------------------------------------------------------------------- +# Flags for Compilers +#----------------------------------------------------------------------------- + +CFLAGS = -std1 -I/usr/include -assume aligned_objects -DADD_ +FFLAGS = -f -u +LOADFLAGS = + +#----------------------------------------------------------------------------- +# Archive programs and flags +#----------------------------------------------------------------------------- + +ARCH = ar +ARCHFLAGS = r +RANLIB = ranlib diff --git a/cblas/Makefile.HPPA b/cblas/Makefile.HPPA new file mode 100644 index 00000000..b3ceb9bc --- /dev/null +++ b/cblas/Makefile.HPPA @@ -0,0 +1,50 @@ +# +# Makefile.ALPHA +# +# +# If you compile, change the name to Makefile.in. +# +# + +#----------------------------------------------------------------------------- +# Shell +#----------------------------------------------------------------------------- + +SHELL = /bin/sh + +#----------------------------------------------------------------------------- +# Platform +#----------------------------------------------------------------------------- + +PLAT = HPPA + +#----------------------------------------------------------------------------- +# Libraries and includs +#----------------------------------------------------------------------------- + +BLLIB = libblas.a +CBLIB = ../lib/cblas_$(PLAT).a + +#----------------------------------------------------------------------------- +# Compilers +#----------------------------------------------------------------------------- + +CC = cc +FC = f77 +LOADER = $(FC) + +#----------------------------------------------------------------------------- +# Flags for Compilers +#----------------------------------------------------------------------------- + +CFLAGS = +O4 -Aa -DNOCHANGE +e +FFLAGS = +O4 +LOADFLAGS = + +#----------------------------------------------------------------------------- +# Archive programs and flags +#----------------------------------------------------------------------------- + +ARCH = ar +ARCHFLAGS = r +RANLIB = echo diff --git a/cblas/Makefile.LINUX b/cblas/Makefile.LINUX new file mode 100644 index 00000000..9dcfbaa7 --- /dev/null +++ b/cblas/Makefile.LINUX @@ -0,0 +1,49 @@ +# +# Makefile.LINUX +# +# +# If you compile, change the name to Makefile.in. +# +# + +#----------------------------------------------------------------------------- +# Shell +#----------------------------------------------------------------------------- + +SHELL = /bin/sh + +#----------------------------------------------------------------------------- +# Platform +#----------------------------------------------------------------------------- + +PLAT = LINUX + +#----------------------------------------------------------------------------- +# Libraries and includs +#----------------------------------------------------------------------------- + +BLLIB = libblas.a +CBLIB = ../lib/cblas_$(PLAT).a + +#----------------------------------------------------------------------------- +# Compilers +#----------------------------------------------------------------------------- + +CC = gcc +FC = gfortran +LOADER = $(FC) + +#----------------------------------------------------------------------------- +# Flags for Compilers +#----------------------------------------------------------------------------- + +CFLAGS = -O3 -DADD_ +FFLAGS = -O3 + +#----------------------------------------------------------------------------- +# Archive programs and flags +#----------------------------------------------------------------------------- + +ARCH = ar +ARCHFLAGS = r +RANLIB = echo diff --git a/cblas/Makefile.SGI64 b/cblas/Makefile.SGI64 new file mode 100644 index 00000000..9790da6f --- /dev/null +++ b/cblas/Makefile.SGI64 @@ -0,0 +1,50 @@ +# +# Makefile.SGI64 +# +# +# If you compile, change the name to Makefile.in. +# +# + +#----------------------------------------------------------------------------- +# Shell +#----------------------------------------------------------------------------- + +SHELL = /bin/sh + +#----------------------------------------------------------------------------- +# Platform +#----------------------------------------------------------------------------- + +PLAT = SGI64 + +#----------------------------------------------------------------------------- +# Libraries and includs +#----------------------------------------------------------------------------- + +BLLIB = libblas.a +CBLIB = ../lib/cblas_$(PLAT).a + +#----------------------------------------------------------------------------- +# Compilers +#----------------------------------------------------------------------------- + +CC = cc +FC = f77 +LOADER = $(FC) + +#----------------------------------------------------------------------------- +# Flags for Compilers +#----------------------------------------------------------------------------- + +CFLAGS = -O3 -DADD_ -64 -mips4 -r10000 +FFLAGS = -O3 -64 -mips4 -r10000 +LOADFLAGS = -64 -mips4 -r10000 + +#----------------------------------------------------------------------------- +# Archive programs and flags +#----------------------------------------------------------------------------- + +ARCH = ar +ARCHFLAGS = cr +RANLIB = echo diff --git a/cblas/Makefile.SUN4 b/cblas/Makefile.SUN4 new file mode 100644 index 00000000..d7b48140 --- /dev/null +++ b/cblas/Makefile.SUN4 @@ -0,0 +1,50 @@ +# +# Makefile.SUN4 +# +# +# If you compile, change the name to Makefile.in. +# +# + +#----------------------------------------------------------------------------- +# Shell +#----------------------------------------------------------------------------- + +SHELL = /bin/sh + +#----------------------------------------------------------------------------- +# Platform +#----------------------------------------------------------------------------- + +PLAT = SUN4 + +#----------------------------------------------------------------------------- +# Libraries and includs +#----------------------------------------------------------------------------- + +BLLIB = libblas.a +CBLIB = ../lib/cblas_$(PLAT).a + +#----------------------------------------------------------------------------- +# Compilers +#----------------------------------------------------------------------------- + +CC = gcc +FC = f77 +LOADER = $(FC) + +#----------------------------------------------------------------------------- +# Flags for Compilers +#----------------------------------------------------------------------------- + +CFLAGS = -g -DADD_ +FFLAGS = -g -u +LOADFLAGS = + +#----------------------------------------------------------------------------- +# Archive programs and flags +#----------------------------------------------------------------------------- + +ARCH = ar +ARCHFLAGS = r +RANLIB = ranlib diff --git a/cblas/Makefile.SUN4SOL2 b/cblas/Makefile.SUN4SOL2 new file mode 100644 index 00000000..9897233a --- /dev/null +++ b/cblas/Makefile.SUN4SOL2 @@ -0,0 +1,50 @@ +# +# Makefile.SUN4SOL2 +# +# +# If you compile, change the name to Makefile.in. +# +# + +#----------------------------------------------------------------------------- +# Shell +#----------------------------------------------------------------------------- + +SHELL = /bin/sh + +#----------------------------------------------------------------------------- +# Platform +#----------------------------------------------------------------------------- + +PLAT = SUN4SOL2 + +#----------------------------------------------------------------------------- +# Libraries and includs +#----------------------------------------------------------------------------- + +BLLIB = libblas.a +CBLIB = ../lib/cblas_$(PLAT).a + +#----------------------------------------------------------------------------- +# Compilers +#----------------------------------------------------------------------------- + +CC = gcc +FC = f77 +LOADER = $(FC) + +#----------------------------------------------------------------------------- +# Flags for Compilers +#----------------------------------------------------------------------------- + +CFLAGS = -g -DADD_ -ansi -pedantic -Wall +FFLAGS = -g -u +LOADFLAGS = + +#----------------------------------------------------------------------------- +# Archive programs and flags +#----------------------------------------------------------------------------- + +ARCH = ar +ARCHFLAGS = r +RANLIB = echo diff --git a/cblas/Makefile.in b/cblas/Makefile.in new file mode 100644 index 00000000..fe014304 --- /dev/null +++ b/cblas/Makefile.in @@ -0,0 +1,49 @@ +# +# Makefile.LINUX +# +# +# If you compile, change the name to Makefile.in. +# +# + +#----------------------------------------------------------------------------- +# Shell +#----------------------------------------------------------------------------- + +SHELL = /bin/sh + +#----------------------------------------------------------------------------- +# Platform +#----------------------------------------------------------------------------- + +PLAT = LINUX + +#----------------------------------------------------------------------------- +# Libraries and includes +#----------------------------------------------------------------------------- + +BLLIB = $(home)/lib/librefblas.a +CBLIB = ../lib/libcblas.a + +#----------------------------------------------------------------------------- +# Compilers +#----------------------------------------------------------------------------- + +CC = gcc +FC = gfortran +LOADER = $(FC) + +#----------------------------------------------------------------------------- +# Flags for Compilers +#----------------------------------------------------------------------------- + +CFLAGS = -O3 -DADD_ +FFLAGS = -O3 + +#----------------------------------------------------------------------------- +# Archive programs and flags +#----------------------------------------------------------------------------- + +ARCH = ar +ARCHFLAGS = cr +RANLIB = ranlib diff --git a/cblas/README b/cblas/README new file mode 100644 index 00000000..25492793 --- /dev/null +++ b/cblas/README @@ -0,0 +1,62 @@ +INSTALLATION + + Please execute the following first: + + prompt> ln -s Makefile.ARCH Makefile.in + + where ARCH is one of ALPHA, HPPA, LINUX, SGI64, SUN4, SUN4SOL2, or + your own version (which should be trivial to do for other architectures). + Make sure to set these variables appropriately in your Makefile.ARCH: + + CBDIR is the directory where you unpacked the tar file + BLLIB is your Legacy BLAS library + + Then type: + + prompt> make help + + which will give you a detailed listing of targets to make. + +EXECUTING THE TESTERS + + Type: + +./testing/xscblat1 +./testing/xdcblat1 +./testing/xccblat1 +./testing/xzcblat1 +./testing/xscblat2 < testing/sin2 +./testing/xdcblat2 < testing/din2 +./testing/xccblat2 < testing/cin2 +./testing/xzcblat2 < testing/zin2 +./testing/xscblat3 < testing/sin3 +./testing/xdcblat3 < testing/din3 +./testing/xccblat3 < testing/cin3 +./testing/xzcblat3 < testing/zin3 +_______________________________________________________________________________ + + This package contains C interface to Legacy BLAS. + If you want to know how to use makefile, type 'make help.' + +Written by Keita Teranishi (5/20/98) +_______________________________________________________________________________ + + This release updates an inconsistency between the BLAST document and + the interface. According to the document, the enumerated types for + the C interface to the BLAS are not typedef'ed. + + It also updates the Level 2 and 3 testers which check for correct + exiting of routines when called with bad arguments. This is done by + overriding the Legacy BLAS library's implementation of xerbla(). If + this cannot be done ( for instance one cannot override some calls + to xerbla() in Sun's Performance library), then correct error + exiting cannot be checked. + +Updated by Jeff Horner (3/15/99) +_______________________________________________________________________________ + +Updated by R. Clint Whaley (2/23/03): + +Fixed the i?amax error that I reported three years ago: standard dictates +IAMAX return vals in range 0 <= iamax < N, but reference was mistakenly +returning like F77: 0 < iamax <= N. diff --git a/cblas/examples/Makefile b/cblas/examples/Makefile new file mode 100644 index 00000000..3c3cd3de --- /dev/null +++ b/cblas/examples/Makefile @@ -0,0 +1,15 @@ +dlvl = ./. +include $(dlvl)/../Makefile.in + +all: example1 example2 + +example1: + $(CC) -c $(CFLAGS) -I../include cblas_example1.c + $(LOADER) -o cblas_ex1 cblas_example1.o $(CBLIB) $(BLLIB) + +example2: + $(CC) -c $(CFLAGS) -I../include cblas_example2.c + $(LOADER) -o cblas_ex2 cblas_example2.o $(CBLIB) $(BLLIB) + +cleanall: + rm -f *.o cblas_ex1 cblas_ex2 diff --git a/cblas/examples/cblas_example1.c b/cblas/examples/cblas_example1.c new file mode 100644 index 00000000..cae03484 --- /dev/null +++ b/cblas/examples/cblas_example1.c @@ -0,0 +1,69 @@ +/* cblas_example.c */ + +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" + +int main ( ) +{ + CBLAS_LAYOUT Layout; + CBLAS_TRANSPOSE transa; + + double *a, *x, *y; + double alpha, beta; + int m, n, lda, incx, incy, i; + + Layout = CblasColMajor; + transa = CblasNoTrans; + + m = 4; /* Size of Column ( the number of rows ) */ + n = 4; /* Size of Row ( the number of columns ) */ + lda = 4; /* Leading dimension of 5 * 4 matrix is 5 */ + incx = 1; + incy = 1; + alpha = 1; + beta = 0; + + a = (double *)malloc(sizeof(double)*m*n); + x = (double *)malloc(sizeof(double)*n); + y = (double *)malloc(sizeof(double)*n); + /* The elements of the first column */ + a[0] = 1; + a[1] = 2; + a[2] = 3; + a[3] = 4; + /* The elements of the second column */ + a[m] = 1; + a[m+1] = 1; + a[m+2] = 1; + a[m+3] = 1; + /* The elements of the third column */ + a[m*2] = 3; + a[m*2+1] = 4; + a[m*2+2] = 5; + a[m*2+3] = 6; + /* The elements of the fourth column */ + a[m*3] = 5; + a[m*3+1] = 6; + a[m*3+2] = 7; + a[m*3+3] = 8; + /* The elemetns of x and y */ + x[0] = 1; + x[1] = 2; + x[2] = 1; + x[3] = 1; + y[0] = 0; + y[1] = 0; + y[2] = 0; + y[3] = 0; + + cblas_dgemv( Layout, transa, m, n, alpha, a, lda, x, incx, beta, + y, incy ); + /* Print y */ + for( i = 0; i < n; i++ ) + printf(" y%d = %f\n", i, y[i]); + free(a); + free(x); + free(y); + return 1; +} diff --git a/cblas/examples/cblas_example2.c b/cblas/examples/cblas_example2.c new file mode 100644 index 00000000..b5a464c0 --- /dev/null +++ b/cblas/examples/cblas_example2.c @@ -0,0 +1,72 @@ +/* cblas_example2.c */ + +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" + +#define INVALID -1 + +int main (int argc, char **argv ) +{ + int rout=-1,info=0,m,n,k,lda,ldb,ldc; + double A[2] = {0.0,0.0}, + B[2] = {0.0,0.0}, + C[2] = {0.0,0.0}, + ALPHA=0.0, BETA=0.0; + + if (argc > 2){ + rout = atoi(argv[1]); + info = atoi(argv[2]); + } + + if (rout == 1) { + if (info==0) { + printf("Checking if cblas_dgemm fails on parameter 4\n"); + cblas_dgemm( CblasRowMajor, CblasTrans, CblasNoTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + } + if (info==1) { + printf("Checking if cblas_dgemm fails on parameter 5\n"); + cblas_dgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + } + if (info==2) { + printf("Checking if cblas_dgemm fails on parameter 9\n"); + cblas_dgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + } + if (info==3) { + printf("Checking if cblas_dgemm fails on parameter 11\n"); + cblas_dgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, 2, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + } + } else { + if (info==0) { + printf("Checking if F77_dgemm fails on parameter 3\n"); + m=INVALID; n=0; k=0; lda=1; ldb=1; ldc=1; + F77_dgemm( "T", "N", &m, &n, &k, + &ALPHA, A, &lda, B, &ldb, &BETA, C, &ldc ); + } + if (info==1) { + m=0; n=INVALID; k=0; lda=1; ldb=1; ldc=1; + printf("Checking if F77_dgemm fails on parameter 4\n"); + F77_dgemm( "N", "T", &m, &n, &k, + &ALPHA, A, &lda, B, &ldb, &BETA, C, &ldc ); + } + if (info==2) { + printf("Checking if F77_dgemm fails on parameter 8\n"); + m=2; n=0; k=0; lda=1; ldb=1; ldc=2; + F77_dgemm( "N", "N" , &m, &n, &k, + &ALPHA, A, &lda, B, &ldb, &BETA, C, &ldc ); + } + if (info==3) { + printf("Checking if F77_dgemm fails on parameter 10\n"); + m=0; n=0; k=2; lda=1; ldb=1; ldc=1; + F77_dgemm( "N", "N" , &m, &n, &k, + &ALPHA, A, &lda, B, &ldb, &BETA, C, &ldc ); + } + } + + return 1; +} diff --git a/cblas/include/cblas.h b/cblas/include/cblas.h new file mode 100644 index 00000000..25104eed --- /dev/null +++ b/cblas/include/cblas.h @@ -0,0 +1,582 @@ +#ifndef CBLAS_H +#define CBLAS_H +#include <stddef.h> + + +#ifdef __cplusplus +extern "C" { /* Assume C declarations for C++ */ +#endif /* __cplusplus */ + +/* + * Enumerated and derived types + */ +#define CBLAS_INDEX size_t /* this may vary between platforms */ + +typedef enum {CblasRowMajor=101, CblasColMajor=102} CBLAS_LAYOUT; +typedef enum {CblasNoTrans=111, CblasTrans=112, CblasConjTrans=113} CBLAS_TRANSPOSE; +typedef enum {CblasUpper=121, CblasLower=122} CBLAS_UPLO; +typedef enum {CblasNonUnit=131, CblasUnit=132} CBLAS_DIAG; +typedef enum {CblasLeft=141, CblasRight=142} CBLAS_SIDE; + +typedef CBLAS_LAYOUT CBLAS_ORDER; /* this for backward compatibility with CBLAS_ORDER */ + +/* + * =========================================================================== + * Prototypes for level 1 BLAS functions (complex are recast as routines) + * =========================================================================== + */ + +double cblas_dcabs1(const void *z); +float cblas_scabs1(const void *c); + +float cblas_sdsdot(const int N, const float alpha, const float *X, + const int incX, const float *Y, const int incY); +double cblas_dsdot(const int N, const float *X, const int incX, const float *Y, + const int incY); +float cblas_sdot(const int N, const float *X, const int incX, + const float *Y, const int incY); +double cblas_ddot(const int N, const double *X, const int incX, + const double *Y, const int incY); + +/* + * Functions having prefixes Z and C only + */ +void cblas_cdotu_sub(const int N, const void *X, const int incX, + const void *Y, const int incY, void *dotu); +void cblas_cdotc_sub(const int N, const void *X, const int incX, + const void *Y, const int incY, void *dotc); + +void cblas_zdotu_sub(const int N, const void *X, const int incX, + const void *Y, const int incY, void *dotu); +void cblas_zdotc_sub(const int N, const void *X, const int incX, + const void *Y, const int incY, void *dotc); + + +/* + * Functions having prefixes S D SC DZ + */ +float cblas_snrm2(const int N, const float *X, const int incX); +float cblas_sasum(const int N, const float *X, const int incX); + +double cblas_dnrm2(const int N, const double *X, const int incX); +double cblas_dasum(const int N, const double *X, const int incX); + +float cblas_scnrm2(const int N, const void *X, const int incX); +float cblas_scasum(const int N, const void *X, const int incX); + +double cblas_dznrm2(const int N, const void *X, const int incX); +double cblas_dzasum(const int N, const void *X, const int incX); + + +/* + * Functions having standard 4 prefixes (S D C Z) + */ +CBLAS_INDEX cblas_isamax(const int N, const float *X, const int incX); +CBLAS_INDEX cblas_idamax(const int N, const double *X, const int incX); +CBLAS_INDEX cblas_icamax(const int N, const void *X, const int incX); +CBLAS_INDEX cblas_izamax(const int N, const void *X, const int incX); + +/* + * =========================================================================== + * Prototypes for level 1 BLAS routines + * =========================================================================== + */ + +/* + * Routines with standard 4 prefixes (s, d, c, z) + */ +void cblas_sswap(const int N, float *X, const int incX, + float *Y, const int incY); +void cblas_scopy(const int N, const float *X, const int incX, + float *Y, const int incY); +void cblas_saxpy(const int N, const float alpha, const float *X, + const int incX, float *Y, const int incY); + +void cblas_dswap(const int N, double *X, const int incX, + double *Y, const int incY); +void cblas_dcopy(const int N, const double *X, const int incX, + double *Y, const int incY); +void cblas_daxpy(const int N, const double alpha, const double *X, + const int incX, double *Y, const int incY); + +void cblas_cswap(const int N, void *X, const int incX, + void *Y, const int incY); +void cblas_ccopy(const int N, const void *X, const int incX, + void *Y, const int incY); +void cblas_caxpy(const int N, const void *alpha, const void *X, + const int incX, void *Y, const int incY); + +void cblas_zswap(const int N, void *X, const int incX, + void *Y, const int incY); +void cblas_zcopy(const int N, const void *X, const int incX, + void *Y, const int incY); +void cblas_zaxpy(const int N, const void *alpha, const void *X, + const int incX, void *Y, const int incY); + + +/* + * Routines with S and D prefix only + */ +void cblas_srotg(float *a, float *b, float *c, float *s); +void cblas_srotmg(float *d1, float *d2, float *b1, const float b2, float *P); +void cblas_srot(const int N, float *X, const int incX, + float *Y, const int incY, const float c, const float s); +void cblas_srotm(const int N, float *X, const int incX, + float *Y, const int incY, const float *P); + +void cblas_drotg(double *a, double *b, double *c, double *s); +void cblas_drotmg(double *d1, double *d2, double *b1, const double b2, double *P); +void cblas_drot(const int N, double *X, const int incX, + double *Y, const int incY, const double c, const double s); +void cblas_drotm(const int N, double *X, const int incX, + double *Y, const int incY, const double *P); + + +/* + * Routines with S D C Z CS and ZD prefixes + */ +void cblas_sscal(const int N, const float alpha, float *X, const int incX); +void cblas_dscal(const int N, const double alpha, double *X, const int incX); +void cblas_cscal(const int N, const void *alpha, void *X, const int incX); +void cblas_zscal(const int N, const void *alpha, void *X, const int incX); +void cblas_csscal(const int N, const float alpha, void *X, const int incX); +void cblas_zdscal(const int N, const double alpha, void *X, const int incX); + +/* + * =========================================================================== + * Prototypes for level 2 BLAS + * =========================================================================== + */ + +/* + * Routines with standard 4 prefixes (S, D, C, Z) + */ +void cblas_sgemv(const CBLAS_LAYOUT layout, + const CBLAS_TRANSPOSE TransA, const int M, const int N, + const float alpha, const float *A, const int lda, + const float *X, const int incX, const float beta, + float *Y, const int incY); +void cblas_sgbmv(CBLAS_LAYOUT layout, + CBLAS_TRANSPOSE TransA, const int M, const int N, + const int KL, const int KU, const float alpha, + const float *A, const int lda, const float *X, + const int incX, const float beta, float *Y, const int incY); +void cblas_strmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, + const int N, const float *A, const int lda, + float *X, const int incX); +void cblas_stbmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, + const int N, const int K, const float *A, const int lda, + float *X, const int incX); +void cblas_stpmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, + const int N, const float *Ap, float *X, const int incX); +void cblas_strsv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, + const int N, const float *A, const int lda, float *X, + const int incX); +void cblas_stbsv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, + const int N, const int K, const float *A, const int lda, + float *X, const int incX); +void cblas_stpsv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, + const int N, const float *Ap, float *X, const int incX); + +void cblas_dgemv(CBLAS_LAYOUT layout, + CBLAS_TRANSPOSE TransA, const int M, const int N, + const double alpha, const double *A, const int lda, + const double *X, const int incX, const double beta, + double *Y, const int incY); +void cblas_dgbmv(CBLAS_LAYOUT layout, + CBLAS_TRANSPOSE TransA, const int M, const int N, + const int KL, const int KU, const double alpha, + const double *A, const int lda, const double *X, + const int incX, const double beta, double *Y, const int incY); +void cblas_dtrmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, + const int N, const double *A, const int lda, + double *X, const int incX); +void cblas_dtbmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, + const int N, const int K, const double *A, const int lda, + double *X, const int incX); +void cblas_dtpmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, + const int N, const double *Ap, double *X, const int incX); +void cblas_dtrsv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, + const int N, const double *A, const int lda, double *X, + const int incX); +void cblas_dtbsv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, + const int N, const int K, const double *A, const int lda, + double *X, const int incX); +void cblas_dtpsv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, + const int N, const double *Ap, double *X, const int incX); + +void cblas_cgemv(CBLAS_LAYOUT layout, + CBLAS_TRANSPOSE TransA, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *X, const int incX, const void *beta, + void *Y, const int incY); +void cblas_cgbmv(CBLAS_LAYOUT layout, + CBLAS_TRANSPOSE TransA, const int M, const int N, + const int KL, const int KU, const void *alpha, + const void *A, const int lda, const void *X, + const int incX, const void *beta, void *Y, const int incY); +void cblas_ctrmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, + const int N, const void *A, const int lda, + void *X, const int incX); +void cblas_ctbmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, + const int N, const int K, const void *A, const int lda, + void *X, const int incX); +void cblas_ctpmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, + const int N, const void *Ap, void *X, const int incX); +void cblas_ctrsv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, + const int N, const void *A, const int lda, void *X, + const int incX); +void cblas_ctbsv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, + const int N, const int K, const void *A, const int lda, + void *X, const int incX); +void cblas_ctpsv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, + const int N, const void *Ap, void *X, const int incX); + +void cblas_zgemv(CBLAS_LAYOUT layout, + CBLAS_TRANSPOSE TransA, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *X, const int incX, const void *beta, + void *Y, const int incY); +void cblas_zgbmv(CBLAS_LAYOUT layout, + CBLAS_TRANSPOSE TransA, const int M, const int N, + const int KL, const int KU, const void *alpha, + const void *A, const int lda, const void *X, + const int incX, const void *beta, void *Y, const int incY); +void cblas_ztrmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, + const int N, const void *A, const int lda, + void *X, const int incX); +void cblas_ztbmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, + const int N, const int K, const void *A, const int lda, + void *X, const int incX); +void cblas_ztpmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, + const int N, const void *Ap, void *X, const int incX); +void cblas_ztrsv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, + const int N, const void *A, const int lda, void *X, + const int incX); +void cblas_ztbsv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, + const int N, const int K, const void *A, const int lda, + void *X, const int incX); +void cblas_ztpsv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, + const int N, const void *Ap, void *X, const int incX); + + +/* + * Routines with S and D prefixes only + */ +void cblas_ssymv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const int N, const float alpha, const float *A, + const int lda, const float *X, const int incX, + const float beta, float *Y, const int incY); +void cblas_ssbmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const int N, const int K, const float alpha, const float *A, + const int lda, const float *X, const int incX, + const float beta, float *Y, const int incY); +void cblas_sspmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const int N, const float alpha, const float *Ap, + const float *X, const int incX, + const float beta, float *Y, const int incY); +void cblas_sger(CBLAS_LAYOUT layout, const int M, const int N, + const float alpha, const float *X, const int incX, + const float *Y, const int incY, float *A, const int lda); +void cblas_ssyr(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const int N, const float alpha, const float *X, + const int incX, float *A, const int lda); +void cblas_sspr(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const int N, const float alpha, const float *X, + const int incX, float *Ap); +void cblas_ssyr2(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const int N, const float alpha, const float *X, + const int incX, const float *Y, const int incY, float *A, + const int lda); +void cblas_sspr2(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const int N, const float alpha, const float *X, + const int incX, const float *Y, const int incY, float *A); + +void cblas_dsymv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const int N, const double alpha, const double *A, + const int lda, const double *X, const int incX, + const double beta, double *Y, const int incY); +void cblas_dsbmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const int N, const int K, const double alpha, const double *A, + const int lda, const double *X, const int incX, + const double beta, double *Y, const int incY); +void cblas_dspmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const int N, const double alpha, const double *Ap, + const double *X, const int incX, + const double beta, double *Y, const int incY); +void cblas_dger(CBLAS_LAYOUT layout, const int M, const int N, + const double alpha, const double *X, const int incX, + const double *Y, const int incY, double *A, const int lda); +void cblas_dsyr(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const int N, const double alpha, const double *X, + const int incX, double *A, const int lda); +void cblas_dspr(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const int N, const double alpha, const double *X, + const int incX, double *Ap); +void cblas_dsyr2(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const int N, const double alpha, const double *X, + const int incX, const double *Y, const int incY, double *A, + const int lda); +void cblas_dspr2(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const int N, const double alpha, const double *X, + const int incX, const double *Y, const int incY, double *A); + + +/* + * Routines with C and Z prefixes only + */ +void cblas_chemv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const int N, const void *alpha, const void *A, + const int lda, const void *X, const int incX, + const void *beta, void *Y, const int incY); +void cblas_chbmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const int N, const int K, const void *alpha, const void *A, + const int lda, const void *X, const int incX, + const void *beta, void *Y, const int incY); +void cblas_chpmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const int N, const void *alpha, const void *Ap, + const void *X, const int incX, + const void *beta, void *Y, const int incY); +void cblas_cgeru(CBLAS_LAYOUT layout, const int M, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda); +void cblas_cgerc(CBLAS_LAYOUT layout, const int M, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda); +void cblas_cher(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const int N, const float alpha, const void *X, const int incX, + void *A, const int lda); +void cblas_chpr(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const int N, const float alpha, const void *X, + const int incX, void *A); +void cblas_cher2(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda); +void cblas_chpr2(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *Ap); + +void cblas_zhemv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const int N, const void *alpha, const void *A, + const int lda, const void *X, const int incX, + const void *beta, void *Y, const int incY); +void cblas_zhbmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const int N, const int K, const void *alpha, const void *A, + const int lda, const void *X, const int incX, + const void *beta, void *Y, const int incY); +void cblas_zhpmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const int N, const void *alpha, const void *Ap, + const void *X, const int incX, + const void *beta, void *Y, const int incY); +void cblas_zgeru(CBLAS_LAYOUT layout, const int M, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda); +void cblas_zgerc(CBLAS_LAYOUT layout, const int M, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda); +void cblas_zher(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const int N, const double alpha, const void *X, const int incX, + void *A, const int lda); +void cblas_zhpr(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const int N, const double alpha, const void *X, + const int incX, void *A); +void cblas_zher2(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda); +void cblas_zhpr2(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *Ap); + +/* + * =========================================================================== + * Prototypes for level 3 BLAS + * =========================================================================== + */ + +/* + * Routines with standard 4 prefixes (S, D, C, Z) + */ +void cblas_sgemm(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA, + CBLAS_TRANSPOSE TransB, const int M, const int N, + const int K, const float alpha, const float *A, + const int lda, const float *B, const int ldb, + const float beta, float *C, const int ldc); +void cblas_ssymm(CBLAS_LAYOUT layout, CBLAS_SIDE Side, + CBLAS_UPLO Uplo, const int M, const int N, + const float alpha, const float *A, const int lda, + const float *B, const int ldb, const float beta, + float *C, const int ldc); +void cblas_ssyrk(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE Trans, const int N, const int K, + const float alpha, const float *A, const int lda, + const float beta, float *C, const int ldc); +void cblas_ssyr2k(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE Trans, const int N, const int K, + const float alpha, const float *A, const int lda, + const float *B, const int ldb, const float beta, + float *C, const int ldc); +void cblas_strmm(CBLAS_LAYOUT layout, CBLAS_SIDE Side, + CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, + CBLAS_DIAG Diag, const int M, const int N, + const float alpha, const float *A, const int lda, + float *B, const int ldb); +void cblas_strsm(CBLAS_LAYOUT layout, CBLAS_SIDE Side, + CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, + CBLAS_DIAG Diag, const int M, const int N, + const float alpha, const float *A, const int lda, + float *B, const int ldb); + +void cblas_dgemm(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA, + CBLAS_TRANSPOSE TransB, const int M, const int N, + const int K, const double alpha, const double *A, + const int lda, const double *B, const int ldb, + const double beta, double *C, const int ldc); +void cblas_dsymm(CBLAS_LAYOUT layout, CBLAS_SIDE Side, + CBLAS_UPLO Uplo, const int M, const int N, + const double alpha, const double *A, const int lda, + const double *B, const int ldb, const double beta, + double *C, const int ldc); +void cblas_dsyrk(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE Trans, const int N, const int K, + const double alpha, const double *A, const int lda, + const double beta, double *C, const int ldc); +void cblas_dsyr2k(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE Trans, const int N, const int K, + const double alpha, const double *A, const int lda, + const double *B, const int ldb, const double beta, + double *C, const int ldc); +void cblas_dtrmm(CBLAS_LAYOUT layout, CBLAS_SIDE Side, + CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, + CBLAS_DIAG Diag, const int M, const int N, + const double alpha, const double *A, const int lda, + double *B, const int ldb); +void cblas_dtrsm(CBLAS_LAYOUT layout, CBLAS_SIDE Side, + CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, + CBLAS_DIAG Diag, const int M, const int N, + const double alpha, const double *A, const int lda, + double *B, const int ldb); + +void cblas_cgemm(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA, + CBLAS_TRANSPOSE TransB, const int M, const int N, + const int K, const void *alpha, const void *A, + const int lda, const void *B, const int ldb, + const void *beta, void *C, const int ldc); +void cblas_csymm(CBLAS_LAYOUT layout, CBLAS_SIDE Side, + CBLAS_UPLO Uplo, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc); +void cblas_csyrk(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *beta, void *C, const int ldc); +void cblas_csyr2k(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc); +void cblas_ctrmm(CBLAS_LAYOUT layout, CBLAS_SIDE Side, + CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, + CBLAS_DIAG Diag, const int M, const int N, + const void *alpha, const void *A, const int lda, + void *B, const int ldb); +void cblas_ctrsm(CBLAS_LAYOUT layout, CBLAS_SIDE Side, + CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, + CBLAS_DIAG Diag, const int M, const int N, + const void *alpha, const void *A, const int lda, + void *B, const int ldb); + +void cblas_zgemm(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA, + CBLAS_TRANSPOSE TransB, const int M, const int N, + const int K, const void *alpha, const void *A, + const int lda, const void *B, const int ldb, + const void *beta, void *C, const int ldc); +void cblas_zsymm(CBLAS_LAYOUT layout, CBLAS_SIDE Side, + CBLAS_UPLO Uplo, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc); +void cblas_zsyrk(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *beta, void *C, const int ldc); +void cblas_zsyr2k(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc); +void cblas_ztrmm(CBLAS_LAYOUT layout, CBLAS_SIDE Side, + CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, + CBLAS_DIAG Diag, const int M, const int N, + const void *alpha, const void *A, const int lda, + void *B, const int ldb); +void cblas_ztrsm(CBLAS_LAYOUT layout, CBLAS_SIDE Side, + CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, + CBLAS_DIAG Diag, const int M, const int N, + const void *alpha, const void *A, const int lda, + void *B, const int ldb); + + +/* + * Routines with prefixes C and Z only + */ +void cblas_chemm(CBLAS_LAYOUT layout, CBLAS_SIDE Side, + CBLAS_UPLO Uplo, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc); +void cblas_cherk(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE Trans, const int N, const int K, + const float alpha, const void *A, const int lda, + const float beta, void *C, const int ldc); +void cblas_cher2k(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const float beta, + void *C, const int ldc); + +void cblas_zhemm(CBLAS_LAYOUT layout, CBLAS_SIDE Side, + CBLAS_UPLO Uplo, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc); +void cblas_zherk(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE Trans, const int N, const int K, + const double alpha, const void *A, const int lda, + const double beta, void *C, const int ldc); +void cblas_zher2k(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const double beta, + void *C, const int ldc); + +void cblas_xerbla(int p, const char *rout, const char *form, ...); + +#ifdef __cplusplus +} +#endif +#endif diff --git a/cblas/include/cblas_f77.h b/cblas/include/cblas_f77.h new file mode 100644 index 00000000..18435cd3 --- /dev/null +++ b/cblas/include/cblas_f77.h @@ -0,0 +1,701 @@ +/* + * cblas_f77.h + * Written by Keita Teranishi + * + * Updated by Jeff Horner + * Merged cblas_f77.h and cblas_fortran_header.h + */ + +#ifndef CBLAS_F77_H +#define CBLAS_f77_H + +#ifdef CRAY + #include <fortran.h> + #define F77_CHAR _fcd + #define C2F_CHAR(a) ( _cptofcd( (a), 1 ) ) + #define C2F_STR(a, i) ( _cptofcd( (a), (i) ) ) + #define F77_STRLEN(a) (_fcdlen) +#endif + +#ifdef WeirdNEC + #define F77_INT long +#endif + +#ifdef F77_CHAR + #define FCHAR F77_CHAR +#else + #define FCHAR char * +#endif + +#ifdef F77_INT + #define FINT const F77_INT * + #define FINT2 F77_INT * +#else + #define FINT const int * + #define FINT2 int * +#endif + +#if defined(ADD_) +/* + * Level 1 BLAS + */ +#define F77_xerbla xerbla_ + #define F77_srotg srotg_ + #define F77_srotmg srotmg_ + #define F77_srot srot_ + #define F77_srotm srotm_ + #define F77_drotg drotg_ + #define F77_drotmg drotmg_ + #define F77_drot drot_ + #define F77_drotm drotm_ + #define F77_sswap sswap_ + #define F77_scopy scopy_ + #define F77_saxpy saxpy_ + #define F77_isamax_sub isamaxsub_ + #define F77_dswap dswap_ + #define F77_dcopy dcopy_ + #define F77_daxpy daxpy_ + #define F77_idamax_sub idamaxsub_ + #define F77_cswap cswap_ + #define F77_ccopy ccopy_ + #define F77_caxpy caxpy_ + #define F77_icamax_sub icamaxsub_ + #define F77_zswap zswap_ + #define F77_zcopy zcopy_ + #define F77_zaxpy zaxpy_ + #define F77_izamax_sub izamaxsub_ + #define F77_sdot_sub sdotsub_ + #define F77_ddot_sub ddotsub_ + #define F77_dsdot_sub dsdotsub_ + #define F77_sscal sscal_ + #define F77_dscal dscal_ + #define F77_cscal cscal_ + #define F77_zscal zscal_ + #define F77_csscal csscal_ + #define F77_zdscal zdscal_ + #define F77_cdotu_sub cdotusub_ + #define F77_cdotc_sub cdotcsub_ + #define F77_zdotu_sub zdotusub_ + #define F77_zdotc_sub zdotcsub_ + #define F77_snrm2_sub snrm2sub_ + #define F77_sasum_sub sasumsub_ + #define F77_dnrm2_sub dnrm2sub_ + #define F77_dasum_sub dasumsub_ + #define F77_scnrm2_sub scnrm2sub_ + #define F77_scasum_sub scasumsub_ + #define F77_dznrm2_sub dznrm2sub_ + #define F77_dzasum_sub dzasumsub_ + #define F77_sdsdot_sub sdsdotsub_ +/* + * Level 2 BLAS + */ + #define F77_ssymv ssymv_ + #define F77_ssbmv ssbmv_ + #define F77_sspmv sspmv_ + #define F77_sger sger_ + #define F77_ssyr ssyr_ + #define F77_sspr sspr_ + #define F77_ssyr2 ssyr2_ + #define F77_sspr2 sspr2_ + #define F77_dsymv dsymv_ + #define F77_dsbmv dsbmv_ + #define F77_dspmv dspmv_ + #define F77_dger dger_ + #define F77_dsyr dsyr_ + #define F77_dspr dspr_ + #define F77_dsyr2 dsyr2_ + #define F77_dspr2 dspr2_ + #define F77_chemv chemv_ + #define F77_chbmv chbmv_ + #define F77_chpmv chpmv_ + #define F77_cgeru cgeru_ + #define F77_cgerc cgerc_ + #define F77_cher cher_ + #define F77_chpr chpr_ + #define F77_cher2 cher2_ + #define F77_chpr2 chpr2_ + #define F77_zhemv zhemv_ + #define F77_zhbmv zhbmv_ + #define F77_zhpmv zhpmv_ + #define F77_zgeru zgeru_ + #define F77_zgerc zgerc_ + #define F77_zher zher_ + #define F77_zhpr zhpr_ + #define F77_zher2 zher2_ + #define F77_zhpr2 zhpr2_ + #define F77_sgemv sgemv_ + #define F77_sgbmv sgbmv_ + #define F77_strmv strmv_ + #define F77_stbmv stbmv_ + #define F77_stpmv stpmv_ + #define F77_strsv strsv_ + #define F77_stbsv stbsv_ + #define F77_stpsv stpsv_ + #define F77_dgemv dgemv_ + #define F77_dgbmv dgbmv_ + #define F77_dtrmv dtrmv_ + #define F77_dtbmv dtbmv_ + #define F77_dtpmv dtpmv_ + #define F77_dtrsv dtrsv_ + #define F77_dtbsv dtbsv_ + #define F77_dtpsv dtpsv_ + #define F77_cgemv cgemv_ + #define F77_cgbmv cgbmv_ + #define F77_ctrmv ctrmv_ + #define F77_ctbmv ctbmv_ + #define F77_ctpmv ctpmv_ + #define F77_ctrsv ctrsv_ + #define F77_ctbsv ctbsv_ + #define F77_ctpsv ctpsv_ + #define F77_zgemv zgemv_ + #define F77_zgbmv zgbmv_ + #define F77_ztrmv ztrmv_ + #define F77_ztbmv ztbmv_ + #define F77_ztpmv ztpmv_ + #define F77_ztrsv ztrsv_ + #define F77_ztbsv ztbsv_ + #define F77_ztpsv ztpsv_ +/* + * Level 3 BLAS + */ + #define F77_chemm chemm_ + #define F77_cherk cherk_ + #define F77_cher2k cher2k_ + #define F77_zhemm zhemm_ + #define F77_zherk zherk_ + #define F77_zher2k zher2k_ + #define F77_sgemm sgemm_ + #define F77_ssymm ssymm_ + #define F77_ssyrk ssyrk_ + #define F77_ssyr2k ssyr2k_ + #define F77_strmm strmm_ + #define F77_strsm strsm_ + #define F77_dgemm dgemm_ + #define F77_dsymm dsymm_ + #define F77_dsyrk dsyrk_ + #define F77_dsyr2k dsyr2k_ + #define F77_dtrmm dtrmm_ + #define F77_dtrsm dtrsm_ + #define F77_cgemm cgemm_ + #define F77_csymm csymm_ + #define F77_csyrk csyrk_ + #define F77_csyr2k csyr2k_ + #define F77_ctrmm ctrmm_ + #define F77_ctrsm ctrsm_ + #define F77_zgemm zgemm_ + #define F77_zsymm zsymm_ + #define F77_zsyrk zsyrk_ + #define F77_zsyr2k zsyr2k_ + #define F77_ztrmm ztrmm_ + #define F77_ztrsm ztrsm_ +#elif defined(UPCASE) +/* + * Level 1 BLAS + */ +#define F77_xerbla XERBLA + #define F77_srotg SROTG + #define F77_srotmg SROTMG + #define F77_srot SROT + #define F77_srotm SROTM + #define F77_drotg DROTG + #define F77_drotmg DROTMG + #define F77_drot DROT + #define F77_drotm DROTM + #define F77_sswap SSWAP + #define F77_scopy SCOPY + #define F77_saxpy SAXPY + #define F77_isamax_sub ISAMAXSUB + #define F77_dswap DSWAP + #define F77_dcopy DCOPY + #define F77_daxpy DAXPY + #define F77_idamax_sub IDAMAXSUB + #define F77_cswap CSWAP + #define F77_ccopy CCOPY + #define F77_caxpy CAXPY + #define F77_icamax_sub ICAMAXSUB + #define F77_zswap ZSWAP + #define F77_zcopy ZCOPY + #define F77_zaxpy ZAXPY + #define F77_izamax_sub IZAMAXSUB + #define F77_sdot_sub SDOTSUB + #define F77_ddot_sub DDOTSUB + #define F77_dsdot_sub DSDOTSUB + #define F77_sscal SSCAL + #define F77_dscal DSCAL + #define F77_cscal CSCAL + #define F77_zscal ZSCAL + #define F77_csscal CSSCAL + #define F77_zdscal ZDSCAL + #define F77_cdotu_sub CDOTUSUB + #define F77_cdotc_sub CDOTCSUB + #define F77_zdotu_sub ZDOTUSUB + #define F77_zdotc_sub ZDOTCSUB + #define F77_snrm2_sub SNRM2SUB + #define F77_sasum_sub SASUMSUB + #define F77_dnrm2_sub DNRM2SUB + #define F77_dasum_sub DASUMSUB + #define F77_scnrm2_sub SCNRM2SUB + #define F77_scasum_sub SCASUMSUB + #define F77_dznrm2_sub DZNRM2SUB + #define F77_dzasum_sub DZASUMSUB + #define F77_sdsdot_sub SDSDOTSUB +/* + * Level 2 BLAS + */ + #define F77_ssymv SSYMV + #define F77_ssbmv SSBMV + #define F77_sspmv SSPMV + #define F77_sger SGER + #define F77_ssyr SSYR + #define F77_sspr SSPR + #define F77_ssyr2 SSYR2 + #define F77_sspr2 SSPR2 + #define F77_dsymv DSYMV + #define F77_dsbmv DSBMV + #define F77_dspmv DSPMV + #define F77_dger DGER + #define F77_dsyr DSYR + #define F77_dspr DSPR + #define F77_dsyr2 DSYR2 + #define F77_dspr2 DSPR2 + #define F77_chemv CHEMV + #define F77_chbmv CHBMV + #define F77_chpmv CHPMV + #define F77_cgeru CGERU + #define F77_cgerc CGERC + #define F77_cher CHER + #define F77_chpr CHPR + #define F77_cher2 CHER2 + #define F77_chpr2 CHPR2 + #define F77_zhemv ZHEMV + #define F77_zhbmv ZHBMV + #define F77_zhpmv ZHPMV + #define F77_zgeru ZGERU + #define F77_zgerc ZGERC + #define F77_zher ZHER + #define F77_zhpr ZHPR + #define F77_zher2 ZHER2 + #define F77_zhpr2 ZHPR2 + #define F77_sgemv SGEMV + #define F77_sgbmv SGBMV + #define F77_strmv STRMV + #define F77_stbmv STBMV + #define F77_stpmv STPMV + #define F77_strsv STRSV + #define F77_stbsv STBSV + #define F77_stpsv STPSV + #define F77_dgemv DGEMV + #define F77_dgbmv DGBMV + #define F77_dtrmv DTRMV + #define F77_dtbmv DTBMV + #define F77_dtpmv DTPMV + #define F77_dtrsv DTRSV + #define F77_dtbsv DTBSV + #define F77_dtpsv DTPSV + #define F77_cgemv CGEMV + #define F77_cgbmv CGBMV + #define F77_ctrmv CTRMV + #define F77_ctbmv CTBMV + #define F77_ctpmv CTPMV + #define F77_ctrsv CTRSV + #define F77_ctbsv CTBSV + #define F77_ctpsv CTPSV + #define F77_zgemv ZGEMV + #define F77_zgbmv ZGBMV + #define F77_ztrmv ZTRMV + #define F77_ztbmv ZTBMV + #define F77_ztpmv ZTPMV + #define F77_ztrsv ZTRSV + #define F77_ztbsv ZTBSV + #define F77_ztpsv ZTPSV +/* + * Level 3 BLAS + */ + #define F77_chemm CHEMM + #define F77_cherk CHERK + #define F77_cher2k CHER2K + #define F77_zhemm ZHEMM + #define F77_zherk ZHERK + #define F77_zher2k ZHER2K + #define F77_sgemm SGEMM + #define F77_ssymm SSYMM + #define F77_ssyrk SSYRK + #define F77_ssyr2k SSYR2K + #define F77_strmm STRMM + #define F77_strsm STRSM + #define F77_dgemm DGEMM + #define F77_dsymm DSYMM + #define F77_dsyrk DSYRK + #define F77_dsyr2k DSYR2K + #define F77_dtrmm DTRMM + #define F77_dtrsm DTRSM + #define F77_cgemm CGEMM + #define F77_csymm CSYMM + #define F77_csyrk CSYRK + #define F77_csyr2k CSYR2K + #define F77_ctrmm CTRMM + #define F77_ctrsm CTRSM + #define F77_zgemm ZGEMM + #define F77_zsymm ZSYMM + #define F77_zsyrk ZSYRK + #define F77_zsyr2k ZSYR2K + #define F77_ztrmm ZTRMM + #define F77_ztrsm ZTRSM +#elif defined(NOCHANGE) +/* + * Level 1 BLAS + */ +#define F77_xerbla xerbla + #define F77_srotg srotg + #define F77_srotmg srotmg + #define F77_srot srot + #define F77_srotm srotm + #define F77_drotg drotg + #define F77_drotmg drotmg + #define F77_drot drot + #define F77_drotm drotm + #define F77_sswap sswap + #define F77_scopy scopy + #define F77_saxpy saxpy + #define F77_isamax_sub isamaxsub + #define F77_dswap dswap + #define F77_dcopy dcopy + #define F77_daxpy daxpy + #define F77_idamax_sub idamaxsub + #define F77_cswap cswap + #define F77_ccopy ccopy + #define F77_caxpy caxpy + #define F77_icamax_sub icamaxsub + #define F77_zswap zswap + #define F77_zcopy zcopy + #define F77_zaxpy zaxpy + #define F77_izamax_sub izamaxsub + #define F77_sdot_sub sdotsub + #define F77_ddot_sub ddotsub + #define F77_dsdot_sub dsdotsub + #define F77_sscal sscal + #define F77_dscal dscal + #define F77_cscal cscal + #define F77_zscal zscal + #define F77_csscal csscal + #define F77_zdscal zdscal + #define F77_cdotu_sub cdotusub + #define F77_cdotc_sub cdotcsub + #define F77_zdotu_sub zdotusub + #define F77_zdotc_sub zdotcsub + #define F77_snrm2_sub snrm2sub + #define F77_sasum_sub sasumsub + #define F77_dnrm2_sub dnrm2sub + #define F77_dasum_sub dasumsub + #define F77_scnrm2_sub scnrm2sub + #define F77_scasum_sub scasumsub + #define F77_dznrm2_sub dznrm2sub + #define F77_dzasum_sub dzasumsub + #define F77_sdsdot_sub sdsdotsub +/* + * Level 2 BLAS + */ + #define F77_ssymv ssymv + #define F77_ssbmv ssbmv + #define F77_sspmv sspmv + #define F77_sger sger + #define F77_ssyr ssyr + #define F77_sspr sspr + #define F77_ssyr2 ssyr2 + #define F77_sspr2 sspr2 + #define F77_dsymv dsymv + #define F77_dsbmv dsbmv + #define F77_dspmv dspmv + #define F77_dger dger + #define F77_dsyr dsyr + #define F77_dspr dspr + #define F77_dsyr2 dsyr2 + #define F77_dspr2 dspr2 + #define F77_chemv chemv + #define F77_chbmv chbmv + #define F77_chpmv chpmv + #define F77_cgeru cgeru + #define F77_cgerc cgerc + #define F77_cher cher + #define F77_chpr chpr + #define F77_cher2 cher2 + #define F77_chpr2 chpr2 + #define F77_zhemv zhemv + #define F77_zhbmv zhbmv + #define F77_zhpmv zhpmv + #define F77_zgeru zgeru + #define F77_zgerc zgerc + #define F77_zher zher + #define F77_zhpr zhpr + #define F77_zher2 zher2 + #define F77_zhpr2 zhpr2 + #define F77_sgemv sgemv + #define F77_sgbmv sgbmv + #define F77_strmv strmv + #define F77_stbmv stbmv + #define F77_stpmv stpmv + #define F77_strsv strsv + #define F77_stbsv stbsv + #define F77_stpsv stpsv + #define F77_dgemv dgemv + #define F77_dgbmv dgbmv + #define F77_dtrmv dtrmv + #define F77_dtbmv dtbmv + #define F77_dtpmv dtpmv + #define F77_dtrsv dtrsv + #define F77_dtbsv dtbsv + #define F77_dtpsv dtpsv + #define F77_cgemv cgemv + #define F77_cgbmv cgbmv + #define F77_ctrmv ctrmv + #define F77_ctbmv ctbmv + #define F77_ctpmv ctpmv + #define F77_ctrsv ctrsv + #define F77_ctbsv ctbsv + #define F77_ctpsv ctpsv + #define F77_zgemv zgemv + #define F77_zgbmv zgbmv + #define F77_ztrmv ztrmv + #define F77_ztbmv ztbmv + #define F77_ztpmv ztpmv + #define F77_ztrsv ztrsv + #define F77_ztbsv ztbsv + #define F77_ztpsv ztpsv +/* + * Level 3 BLAS + */ + #define F77_chemm chemm + #define F77_cherk cherk + #define F77_cher2k cher2k + #define F77_zhemm zhemm + #define F77_zherk zherk + #define F77_zher2k zher2k + #define F77_sgemm sgemm + #define F77_ssymm ssymm + #define F77_ssyrk ssyrk + #define F77_ssyr2k ssyr2k + #define F77_strmm strmm + #define F77_strsm strsm + #define F77_dgemm dgemm + #define F77_dsymm dsymm + #define F77_dsyrk dsyrk + #define F77_dsyr2k dsyr2k + #define F77_dtrmm dtrmm + #define F77_dtrsm dtrsm + #define F77_cgemm cgemm + #define F77_csymm csymm + #define F77_csyrk csyrk + #define F77_csyr2k csyr2k + #define F77_ctrmm ctrmm + #define F77_ctrsm ctrsm + #define F77_zgemm zgemm + #define F77_zsymm zsymm + #define F77_zsyrk zsyrk + #define F77_zsyr2k zsyr2k + #define F77_ztrmm ztrmm + #define F77_ztrsm ztrsm +#endif + +#ifdef __cplusplus +extern "C" { +#endif + + void F77_xerbla(FCHAR, void *); +/* + * Level 1 Fortran Prototypes + */ + +/* Single Precision */ + + void F77_srot(FINT, float *, FINT, float *, FINT, const float *, const float *); + void F77_srotg(float *,float *,float *,float *); + void F77_srotm( FINT, float *, FINT, float *, FINT, const float *); + void F77_srotmg(float *,float *,float *,const float *, float *); + void F77_sswap( FINT, float *, FINT, float *, FINT); + void F77_scopy( FINT, const float *, FINT, float *, FINT); + void F77_saxpy( FINT, const float *, const float *, FINT, float *, FINT); + void F77_sdot_sub(FINT, const float *, FINT, const float *, FINT, float *); + void F77_sdsdot_sub( FINT, const float *, const float *, FINT, const float *, FINT, float *); + void F77_sscal( FINT, const float *, float *, FINT); + void F77_snrm2_sub( FINT, const float *, FINT, float *); + void F77_sasum_sub( FINT, const float *, FINT, float *); + void F77_isamax_sub( FINT, const float * , FINT, FINT2); + +/* Double Precision */ + + void F77_drot(FINT, double *, FINT, double *, FINT, const double *, const double *); + void F77_drotg(double *,double *,double *,double *); + void F77_drotm( FINT, double *, FINT, double *, FINT, const double *); + void F77_drotmg(double *,double *,double *,const double *, double *); + void F77_dswap( FINT, double *, FINT, double *, FINT); + void F77_dcopy( FINT, const double *, FINT, double *, FINT); + void F77_daxpy( FINT, const double *, const double *, FINT, double *, FINT); + void F77_dswap( FINT, double *, FINT, double *, FINT); + void F77_dsdot_sub(FINT, const float *, FINT, const float *, FINT, double *); + void F77_ddot_sub( FINT, const double *, FINT, const double *, FINT, double *); + void F77_dscal( FINT, const double *, double *, FINT); + void F77_dnrm2_sub( FINT, const double *, FINT, double *); + void F77_dasum_sub( FINT, const double *, FINT, double *); + void F77_idamax_sub( FINT, const double * , FINT, FINT2); + +/* Single Complex Precision */ + + void F77_cswap( FINT, void *, FINT, void *, FINT); + void F77_ccopy( FINT, const void *, FINT, void *, FINT); + void F77_caxpy( FINT, const void *, const void *, FINT, void *, FINT); + void F77_cswap( FINT, void *, FINT, void *, FINT); + void F77_cdotc_sub( FINT, const void *, FINT, const void *, FINT, void *); + void F77_cdotu_sub( FINT, const void *, FINT, const void *, FINT, void *); + void F77_cscal( FINT, const void *, void *, FINT); + void F77_icamax_sub( FINT, const void *, FINT, FINT2); + void F77_csscal( FINT, const float *, void *, FINT); + void F77_scnrm2_sub( FINT, const void *, FINT, float *); + void F77_scasum_sub( FINT, const void *, FINT, float *); + +/* Double Complex Precision */ + + void F77_zswap( FINT, void *, FINT, void *, FINT); + void F77_zcopy( FINT, const void *, FINT, void *, FINT); + void F77_zaxpy( FINT, const void *, const void *, FINT, void *, FINT); + void F77_zswap( FINT, void *, FINT, void *, FINT); + void F77_zdotc_sub( FINT, const void *, FINT, const void *, FINT, void *); + void F77_zdotu_sub( FINT, const void *, FINT, const void *, FINT, void *); + void F77_zdscal( FINT, const double *, void *, FINT); + void F77_zscal( FINT, const void *, void *, FINT); + void F77_dznrm2_sub( FINT, const void *, FINT, double *); + void F77_dzasum_sub( FINT, const void *, FINT, double *); + void F77_izamax_sub( FINT, const void *, FINT, FINT2); + +/* + * Level 2 Fortran Prototypes + */ + +/* Single Precision */ + + void F77_sgemv(FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT); + void F77_sgbmv(FCHAR, FINT, FINT, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT); + void F77_ssymv(FCHAR, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT); + void F77_ssbmv(FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT); + void F77_sspmv(FCHAR, FINT, const float *, const float *, const float *, FINT, const float *, float *, FINT); + void F77_strmv( FCHAR, FCHAR, FCHAR, FINT, const float *, FINT, float *, FINT); + void F77_stbmv( FCHAR, FCHAR, FCHAR, FINT, FINT, const float *, FINT, float *, FINT); + void F77_strsv( FCHAR, FCHAR, FCHAR, FINT, const float *, FINT, float *, FINT); + void F77_stbsv( FCHAR, FCHAR, FCHAR, FINT, FINT, const float *, FINT, float *, FINT); + void F77_stpmv( FCHAR, FCHAR, FCHAR, FINT, const float *, float *, FINT); + void F77_stpsv( FCHAR, FCHAR, FCHAR, FINT, const float *, float *, FINT); + void F77_sger( FINT, FINT, const float *, const float *, FINT, const float *, FINT, float *, FINT); + void F77_ssyr(FCHAR, FINT, const float *, const float *, FINT, float *, FINT); + void F77_sspr(FCHAR, FINT, const float *, const float *, FINT, float *); + void F77_sspr2(FCHAR, FINT, const float *, const float *, FINT, const float *, FINT, float *); + void F77_ssyr2(FCHAR, FINT, const float *, const float *, FINT, const float *, FINT, float *, FINT); + +/* Double Precision */ + + void F77_dgemv(FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT); + void F77_dgbmv(FCHAR, FINT, FINT, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT); + void F77_dsymv(FCHAR, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT); + void F77_dsbmv(FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT); + void F77_dspmv(FCHAR, FINT, const double *, const double *, const double *, FINT, const double *, double *, FINT); + void F77_dtrmv( FCHAR, FCHAR, FCHAR, FINT, const double *, FINT, double *, FINT); + void F77_dtbmv( FCHAR, FCHAR, FCHAR, FINT, FINT, const double *, FINT, double *, FINT); + void F77_dtrsv( FCHAR, FCHAR, FCHAR, FINT, const double *, FINT, double *, FINT); + void F77_dtbsv( FCHAR, FCHAR, FCHAR, FINT, FINT, const double *, FINT, double *, FINT); + void F77_dtpmv( FCHAR, FCHAR, FCHAR, FINT, const double *, double *, FINT); + void F77_dtpsv( FCHAR, FCHAR, FCHAR, FINT, const double *, double *, FINT); + void F77_dger( FINT, FINT, const double *, const double *, FINT, const double *, FINT, double *, FINT); + void F77_dsyr(FCHAR, FINT, const double *, const double *, FINT, double *, FINT); + void F77_dspr(FCHAR, FINT, const double *, const double *, FINT, double *); + void F77_dspr2(FCHAR, FINT, const double *, const double *, FINT, const double *, FINT, double *); + void F77_dsyr2(FCHAR, FINT, const double *, const double *, FINT, const double *, FINT, double *, FINT); + +/* Single Complex Precision */ + + void F77_cgemv(FCHAR, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT); + void F77_cgbmv(FCHAR, FINT, FINT, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT); + void F77_chemv(FCHAR, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT); + void F77_chbmv(FCHAR, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT); + void F77_chpmv(FCHAR, FINT, const void *, const void *, const void *, FINT, const void *, void *, FINT); + void F77_ctrmv( FCHAR, FCHAR, FCHAR, FINT, const void *, FINT, void *, FINT); + void F77_ctbmv( FCHAR, FCHAR, FCHAR, FINT, FINT, const void *, FINT, void *, FINT); + void F77_ctpmv( FCHAR, FCHAR, FCHAR, FINT, const void *, void *, FINT); + void F77_ctrsv( FCHAR, FCHAR, FCHAR, FINT, const void *, FINT, void *, FINT); + void F77_ctbsv( FCHAR, FCHAR, FCHAR, FINT, FINT, const void *, FINT, void *, FINT); + void F77_ctpsv( FCHAR, FCHAR, FCHAR, FINT, const void *, void *,FINT); + void F77_cgerc( FINT, FINT, const void *, const void *, FINT, const void *, FINT, void *, FINT); + void F77_cgeru( FINT, FINT, const void *, const void *, FINT, const void *, FINT, void *, FINT); + void F77_cher(FCHAR, FINT, const float *, const void *, FINT, void *, FINT); + void F77_cher2(FCHAR, FINT, const void *, const void *, FINT, const void *, FINT, void *, FINT); + void F77_chpr(FCHAR, FINT, const float *, const void *, FINT, void *); + void F77_chpr2(FCHAR, FINT, const float *, const void *, FINT, const void *, FINT, void *); + +/* Double Complex Precision */ + + void F77_zgemv(FCHAR, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT); + void F77_zgbmv(FCHAR, FINT, FINT, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT); + void F77_zhemv(FCHAR, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT); + void F77_zhbmv(FCHAR, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT); + void F77_zhpmv(FCHAR, FINT, const void *, const void *, const void *, FINT, const void *, void *, FINT); + void F77_ztrmv( FCHAR, FCHAR, FCHAR, FINT, const void *, FINT, void *, FINT); + void F77_ztbmv( FCHAR, FCHAR, FCHAR, FINT, FINT, const void *, FINT, void *, FINT); + void F77_ztpmv( FCHAR, FCHAR, FCHAR, FINT, const void *, void *, FINT); + void F77_ztrsv( FCHAR, FCHAR, FCHAR, FINT, const void *, FINT, void *, FINT); + void F77_ztbsv( FCHAR, FCHAR, FCHAR, FINT, FINT, const void *, FINT, void *, FINT); + void F77_ztpsv( FCHAR, FCHAR, FCHAR, FINT, const void *, void *,FINT); + void F77_zgerc( FINT, FINT, const void *, const void *, FINT, const void *, FINT, void *, FINT); + void F77_zgeru( FINT, FINT, const void *, const void *, FINT, const void *, FINT, void *, FINT); + void F77_zher(FCHAR, FINT, const double *, const void *, FINT, void *, FINT); + void F77_zher2(FCHAR, FINT, const void *, const void *, FINT, const void *, FINT, void *, FINT); + void F77_zhpr(FCHAR, FINT, const double *, const void *, FINT, void *); + void F77_zhpr2(FCHAR, FINT, const double *, const void *, FINT, const void *, FINT, void *); + +/* + * Level 3 Fortran Prototypes + */ + +/* Single Precision */ + + void F77_sgemm(FCHAR, FCHAR, FINT, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT); + void F77_ssymm(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT); + void F77_ssyrk(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, float *, FINT); + void F77_ssyr2k(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT); + void F77_strmm(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, float *, FINT); + void F77_strsm(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, float *, FINT); + +/* Double Precision */ + + void F77_dgemm(FCHAR, FCHAR, FINT, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT); + void F77_dsymm(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT); + void F77_dsyrk(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, double *, FINT); + void F77_dsyr2k(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT); + void F77_dtrmm(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, double *, FINT); + void F77_dtrsm(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, double *, FINT); + +/* Single Complex Precision */ + + void F77_cgemm(FCHAR, FCHAR, FINT, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT); + void F77_csymm(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT); + void F77_chemm(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT); + void F77_csyrk(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, float *, FINT); + void F77_cherk(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, float *, FINT); + void F77_csyr2k(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT); + void F77_cher2k(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT); + void F77_ctrmm(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, float *, FINT); + void F77_ctrsm(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, float *, FINT); + +/* Double Complex Precision */ + + void F77_zgemm(FCHAR, FCHAR, FINT, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT); + void F77_zsymm(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT); + void F77_zhemm(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT); + void F77_zsyrk(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, double *, FINT); + void F77_zherk(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, double *, FINT); + void F77_zsyr2k(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT); + void F77_zher2k(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT); + void F77_ztrmm(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, double *, FINT); + void F77_ztrsm(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, double *, FINT); + +#ifdef __cplusplus +} +#endif + +#endif /* CBLAS_F77_H */ diff --git a/cblas/src/CMakeLists.txt b/cblas/src/CMakeLists.txt new file mode 100644 index 00000000..49bea90b --- /dev/null +++ b/cblas/src/CMakeLists.txt @@ -0,0 +1,172 @@ +# This Makefile compiles the CBLAS routines +# +# Error handling routines for level 2 & 3 + +set (ERRHAND cblas_globals.c cblas_xerbla.c xerbla.c) + +# +# +# CBLAS routines +# +# Level 1 +# +# + +# +# All object files for single real precision +# +set (SLEV1 cblas_srotg.c cblas_srotmg.c cblas_srot.c cblas_srotm.c + cblas_sswap.c cblas_sscal.c cblas_scopy.c cblas_saxpy.c + cblas_sdot.c cblas_sdsdot.c cblas_snrm2.c cblas_sasum.c + cblas_isamax.c sdotsub.f sdsdotsub.f snrm2sub.f sasumsub.f + isamaxsub.f) +# +# All object files for double real precision +# +set (DLEV1 cblas_drotg.c cblas_drotmg.c cblas_drot.c cblas_drotm.c + cblas_dswap.c cblas_dscal.c cblas_dcopy.c cblas_daxpy.c + cblas_ddot.c cblas_dsdot.c cblas_dnrm2.c cblas_dasum.c + cblas_idamax.c ddotsub.f dsdotsub.f dnrm2sub.f + dasumsub.f idamaxsub.f) + +# +# All object files for single complex precision +# +set (CLEV1 cblas_cswap.c cblas_cscal.c cblas_csscal.c cblas_ccopy.c + cblas_caxpy.c cblas_cdotu_sub.c cblas_cdotc_sub.c + cblas_icamax.c cdotcsub.f cdotusub.f icamaxsub.f) + +# +# All object files for double complex precision +# +set (ZLEV1 cblas_zswap.c cblas_zscal.c cblas_zdscal.c cblas_zcopy.c + cblas_zaxpy.c cblas_zdotu_sub.c cblas_zdotc_sub.c cblas_dznrm2.c + cblas_dzasum.c cblas_izamax.c zdotcsub.f zdotusub.f + dzasumsub.f dznrm2sub.f izamaxsub.f) + + +# +# Common files for single complex precision +# +set (SCLEV1 cblas_scasum.c scasumsub.f cblas_scnrm2.c scnrm2sub.f) + + +# +# All object files +# +set (ALEV1 ${slev1} ${dlev1} ${clev1} ${zlev1} ${sclev1}) + + +# +# +# CBLAS routines +# +# Level 2 +# +# + +# +# All object files for single real precision +# +set (SLEV2 cblas_sgemv.c cblas_sgbmv.c cblas_sger.c cblas_ssbmv.c cblas_sspmv.c + cblas_sspr.c cblas_sspr2.c cblas_ssymv.c cblas_ssyr.c cblas_ssyr2.c + cblas_stbmv.c cblas_stbsv.c cblas_stpmv.c cblas_stpsv.c cblas_strmv.c + cblas_strsv.c) + + +# +# All object files for double real precision +# +set (DLEV2 cblas_dgemv.c cblas_dgbmv.c cblas_dger.c cblas_dsbmv.c cblas_dspmv.c + cblas_dspr.c cblas_dspr2.c cblas_dsymv.c cblas_dsyr.c cblas_dsyr2.c + cblas_dtbmv.c cblas_dtbsv.c cblas_dtpmv.c cblas_dtpsv.c cblas_dtrmv.c + cblas_dtrsv.c) + +# +# All object files for single complex precision +# +set (CLEV2 cblas_cgemv.c cblas_cgbmv.c cblas_chemv.c cblas_chbmv.c cblas_chpmv.c + cblas_ctrmv.c cblas_ctbmv.c cblas_ctpmv.c cblas_ctrsv.c cblas_ctbsv.c + cblas_ctpsv.c cblas_cgeru.c cblas_cgerc.c cblas_cher.c cblas_cher2.c + cblas_chpr.c cblas_chpr2.c) + +# +# All object files for double complex precision +# +set (ZLEV2 cblas_zgemv.c cblas_zgbmv.c cblas_zhemv.c cblas_zhbmv.c cblas_zhpmv.c + cblas_ztrmv.c cblas_ztbmv.c cblas_ztpmv.c cblas_ztrsv.c cblas_ztbsv.c + cblas_ztpsv.c cblas_zgeru.c cblas_zgerc.c cblas_zher.c cblas_zher2.c + cblas_zhpr.c cblas_zhpr2.c) +# +# All object files +# +set (AVEL2 ${slev2} ${dlev2} ${clev2} ${zlev2}) + +# +# +# CBLAS routines +# +# Level 3 +# +# + +# +# All object files for single real precision +# +set (SLEV3 cblas_sgemm.c cblas_ssymm.c cblas_ssyrk.c cblas_ssyr2k.c cblas_strmm.c + cblas_strsm.c) +# +# All object files for double real precision +# +set (DLEV3 cblas_dgemm.c cblas_dsymm.c cblas_dsyrk.c cblas_dsyr2k.c cblas_dtrmm.c + cblas_dtrsm.c) +# +# All object files for single complex precision +# +set (CLEV3 cblas_cgemm.c cblas_csymm.c cblas_chemm.c cblas_cherk.c + cblas_cher2k.c cblas_ctrmm.c cblas_ctrsm.c cblas_csyrk.c + cblas_csyr2k.c) +# +# All object files for double complex precision +# +set (ZLEV3 cblas_zgemm.c cblas_zsymm.c cblas_zhemm.c cblas_zherk.c + cblas_zher2k.c cblas_ztrmm.c cblas_ztrsm.c cblas_zsyrk.c + cblas_zsyr2k.c) +# +# All object files +# +set (ALEV3 ${slev3} ${dlev3} ${clev3} ${zlev3}) + +# default build all of it +set(ALLOBJ ${SCLEV1} ${SLEV1} ${SLEV2} ${SLEV3} ${ERRHAND} + ${DLEV1} ${DLEV2} ${DLEV3} + ${CLEV1} ${CLEV2} ${CLEV3} + ${ZLEV1} ${ZLEV2} ${ZLEV3} ) + +# Single real precision +if(CBLAS_SINGLE) + set(ALLOBJ ${SCLEV1} ${SLEV1} ${SLEV2} ${SLEV3} ${ERRHAND}) +endif(CBLAS_SINGLE) + +# Double real precision +if(CBLAS_DOUBLE) + set(ALLOBJ ${DLEV1} ${DLEV2} ${DLEV3} ${ERRHAND}) +endif(CBLAS_DOUBLE) + +# Single complex precision +if (CBLAS_COMPLEX) + set(ALLOBJ ${CLEV1} ${SCLEV1} ${CLEV2} ${CLEV3} ${ERRHAND}) +endif(CBLAS_COMPLEX) + +# Double complex precision +if (CBLAS_COMPLEX16) + set(ALLOBJ ${ZLEV1} ${ZLEV2} ${ZLEV3} ${ERRHAND}) +endif(CBLAS_COMPLEX16) + + +add_library(cblas ${ALLOBJ}) +if(UNIX) + target_link_libraries(cblas m) +endif() +target_link_libraries(cblas) +install(TARGETS cblas DESTINATION lib)
\ No newline at end of file diff --git a/cblas/src/Makefile b/cblas/src/Makefile new file mode 100644 index 00000000..65f7cc60 --- /dev/null +++ b/cblas/src/Makefile @@ -0,0 +1,247 @@ +# This Makefile compiles the CBLAS routines +# +dlvl = ../. +include $(dlvl)/Makefile.in + +# +# Erase all object and archive files +# +clean: + rm -f *.o a.out core + +# Error handling routines for level 2 & 3 + +errhand = cblas_globals.o cblas_xerbla.o xerbla.o + +# Object files of all routines +alev = $(alev1) $(alev2) $(alev3) $(errhand) +# +# +# CBLAS routines +# +# Level 1 +# +# + +# +# All object files for single real precision +# +slev1 = cblas_srotg.o cblas_srotmg.o cblas_srot.o cblas_srotm.o \ + cblas_sswap.o cblas_sscal.o cblas_scopy.o cblas_saxpy.o \ + cblas_sdot.o cblas_sdsdot.o cblas_snrm2.o cblas_sasum.o \ + cblas_isamax.o sdotsub.o sdsdotsub.o snrm2sub.o sasumsub.o \ + isamaxsub.o +# +# All object files for double real precision +# +dlev1 = cblas_drotg.o cblas_drotmg.o cblas_drot.o cblas_drotm.o \ + cblas_dswap.o cblas_dscal.o cblas_dcopy.o cblas_daxpy.o \ + cblas_ddot.o cblas_dsdot.o cblas_dnrm2.o cblas_dasum.o \ + cblas_idamax.o ddotsub.o dsdotsub.o dnrm2sub.o \ + dasumsub.o idamaxsub.o + +# +# All object files for single complex precision +# +clev1 = cblas_cswap.o cblas_cscal.o cblas_csscal.o cblas_ccopy.o \ + cblas_caxpy.o cblas_cdotu_sub.o cblas_cdotc_sub.o \ + cblas_icamax.o cdotcsub.o cdotusub.o icamaxsub.o + +# +# All object files for double complex precision +# +zlev1 = cblas_zswap.o cblas_zscal.o cblas_zdscal.o cblas_zcopy.o \ + cblas_zaxpy.o cblas_zdotu_sub.o cblas_zdotc_sub.o cblas_dznrm2.o \ + cblas_dzasum.o cblas_izamax.o zdotcsub.o zdotusub.o \ + dzasumsub.o dznrm2sub.o izamaxsub.o + +# +# Common files for single / complex precision +# +sclev1 = cblas_scasum.o scasumsub.o cblas_scnrm2.o scnrm2sub.o + +# +# All object files +# +alev1 = $(slev1) $(dlev1) $(clev1) $(zlev1) $(sclev1) + + +# +# Make an archive file +# + +# Single real precision +slib1: $(slev1) $(sclev1) + $(ARCH) $(ARCHFLAGS) $(CBLIB) $(slev1) $(sclev1) + $(RANLIB) $(CBLIB) + +# Double real precision +dlib1: $(dlev1) + $(ARCH) $(ARCHFLAGS) $(CBLIB) $(dlev1) + $(RANLIB) $(CBLIB) + +# Single complex precision +clib1: $(clev1) $(sclev1) + $(ARCH) $(ARCHFLAGS) $(CBLIB) $(clev1) $(sclev1) + $(RANLIB) $(CBLIB) + +# Double complex precision +zlib1: $(zlev1) + $(ARCH) $(ARCHFLAGS) $(CBLIB) $(zlev1) + $(RANLIB) $(CBLIB) + +# All precisions +all1: $(alev1) + $(ARCH) $(ARCHFLAGS) $(CBLIB) $(alev1) + $(RANLIB) $(CBLIB) + +# +# +# CBLAS routines +# +# Level 2 +# +# + +# +# All object files for single real precision +# +slev2 = cblas_sgemv.o cblas_sgbmv.o cblas_sger.o cblas_ssbmv.o cblas_sspmv.o \ + cblas_sspr.o cblas_sspr2.o cblas_ssymv.o cblas_ssyr.o cblas_ssyr2.o \ + cblas_stbmv.o cblas_stbsv.o cblas_stpmv.o cblas_stpsv.o cblas_strmv.o \ + cblas_strsv.o + +# +# All object files for double real precision +# +dlev2 = cblas_dgemv.o cblas_dgbmv.o cblas_dger.o cblas_dsbmv.o cblas_dspmv.o \ + cblas_dspr.o cblas_dspr2.o cblas_dsymv.o cblas_dsyr.o cblas_dsyr2.o \ + cblas_dtbmv.o cblas_dtbsv.o cblas_dtpmv.o cblas_dtpsv.o cblas_dtrmv.o \ + cblas_dtrsv.o + +# +# All object files for single complex precision +# +clev2 = cblas_cgemv.o cblas_cgbmv.o cblas_chemv.o cblas_chbmv.o cblas_chpmv.o \ + cblas_ctrmv.o cblas_ctbmv.o cblas_ctpmv.o cblas_ctrsv.o cblas_ctbsv.o \ + cblas_ctpsv.o cblas_cgeru.o cblas_cgerc.o cblas_cher.o cblas_cher2.o \ + cblas_chpr.o cblas_chpr2.o + +# +# All object files for double complex precision +# +zlev2 = cblas_zgemv.o cblas_zgbmv.o cblas_zhemv.o cblas_zhbmv.o cblas_zhpmv.o \ + cblas_ztrmv.o cblas_ztbmv.o cblas_ztpmv.o cblas_ztrsv.o cblas_ztbsv.o \ + cblas_ztpsv.o cblas_zgeru.o cblas_zgerc.o cblas_zher.o cblas_zher2.o \ + cblas_zhpr.o cblas_zhpr2.o +# +# All object files +# +alev2 = $(slev2) $(dlev2) $(clev2) $(zlev2) + +# +# Make an archive file +# + +# Single real precision +slib2: $(slev2) $(errhand) + $(ARCH) $(ARCHFLAGS) $(CBLIB) $(slev2) $(errhand) + $(RANLIB) $(CBLIB) + +# Double real precision +dlib2: $(dlev2) $(errhand) + $(ARCH) $(ARCHFLAGS) $(CBLIB) $(dlev2) $(errhand) + $(RANLIB) $(CBLIB) + +# Single complex precision +clib2: $(clev2) $(errhand) + $(ARCH) $(ARCHFLAGS) $(CBLIB) $(clev2) $(errhand) + $(RANLIB) $(CBLIB) + +# Double complex precision +zlib2: $(zlev2) $(errhand) + $(ARCH) $(ARCHFLAGS) $(CBLIB) $(zlev2) $(errhand) + $(RANLIB) $(CBLIB) + +# All precisions +all2: $(alev2) $(errhand) + $(ARCH) $(ARCHFLAGS) $(CBLIB) $(alev2) $(errhand) + $(RANLIB) $(CBLIB) +# +# +# CBLAS routines +# +# Level 3 +# +# + +# +# All object files for single real precision +# +slev3 = cblas_sgemm.o cblas_ssymm.o cblas_ssyrk.o cblas_ssyr2k.o cblas_strmm.o\ + cblas_strsm.o + +# +# All object files for double real precision +# +dlev3 = cblas_dgemm.o cblas_dsymm.o cblas_dsyrk.o cblas_dsyr2k.o cblas_dtrmm.o\ + cblas_dtrsm.o + +# +# All object files for single complex precision +# +clev3 = cblas_cgemm.o cblas_csymm.o cblas_chemm.o cblas_cherk.o\ + cblas_cher2k.o cblas_ctrmm.o cblas_ctrsm.o cblas_csyrk.o\ + cblas_csyr2k.o +# +# All object files for double complex precision +# +zlev3 = cblas_zgemm.o cblas_zsymm.o cblas_zhemm.o cblas_zherk.o\ + cblas_zher2k.o cblas_ztrmm.o cblas_ztrsm.o cblas_zsyrk.o\ + cblas_zsyr2k.o +# +# All object files +# +alev3 = $(slev3) $(dlev3) $(clev3) $(zlev3) + +# +# Make an archive file +# + +# Single real precision +slib3: $(slev3) $(errhand) + $(ARCH) $(ARCHFLAGS) $(CBLIB) $(slev3) $(errhand) + $(RANLIB) $(CBLIB) + +# Double real precision +dlib3: $(dlev3) $(errhand) + $(ARCH) $(ARCHFLAGS) $(CBLIB) $(dlev3) $(errhand) + $(RANLIB) $(CBLIB) + +# Single complex precision +clib3: $(clev3) $(errhand) + $(ARCH) $(ARCHFLAGS) $(CBLIB) $(clev3) $(errhand) + $(RANLIB) $(CBLIB) + +# Single complex precision +zlib3: $(zlev3) $(errhand) + $(ARCH) $(ARCHFLAGS) $(CBLIB) $(zlev3) $(errhand) + $(RANLIB) $(CBLIB) + +# All precisions +all3: $(alev3) $(errhand) + $(ARCH) $(ARCHFLAGS) $(CBLIB) $(alev3) + $(RANLIB) $(CBLIB) + +# All levels and precisions +all: $(alev) + $(ARCH) $(ARCHFLAGS) $(CBLIB) $(alev) + $(RANLIB) $(CBLIB) + + +.SUFFIXES: .o .c .f + +.c.o: + $(CC) $(CFLAGS) -I../include -c $*.c +.f.o: + $(FC) $(FFLAGS) -c $*.f diff --git a/cblas/src/cblas_caxpy.c b/cblas/src/cblas_caxpy.c new file mode 100644 index 00000000..7579aa70 --- /dev/null +++ b/cblas/src/cblas_caxpy.c @@ -0,0 +1,22 @@ +/* + * cblas_caxpy.c + * + * The program is a C interface to caxpy. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_caxpy( const int N, const void *alpha, const void *X, + const int incX, void *Y, const int incY) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_caxpy( &F77_N, alpha, X, &F77_incX, Y, &F77_incY); +} diff --git a/cblas/src/cblas_ccopy.c b/cblas/src/cblas_ccopy.c new file mode 100644 index 00000000..b7bc4284 --- /dev/null +++ b/cblas/src/cblas_ccopy.c @@ -0,0 +1,22 @@ +/* + * cblas_ccopy.c + * + * The program is a C interface to ccopy. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ccopy( const int N, const void *X, + const int incX, void *Y, const int incY) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_ccopy( &F77_N, X, &F77_incX, Y, &F77_incY); +} diff --git a/cblas/src/cblas_cdotc_sub.c b/cblas/src/cblas_cdotc_sub.c new file mode 100644 index 00000000..d6086814 --- /dev/null +++ b/cblas/src/cblas_cdotc_sub.c @@ -0,0 +1,23 @@ +/* + * cblas_cdotc_sub.c + * + * The program is a C interface to cdotc. + * It calls the fortran wrapper before calling cdotc. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_cdotc_sub( const int N, const void *X, const int incX, + const void *Y, const int incY,void *dotc) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_cdotc_sub( &F77_N, X, &F77_incX, Y, &F77_incY, dotc); +} diff --git a/cblas/src/cblas_cdotu_sub.c b/cblas/src/cblas_cdotu_sub.c new file mode 100644 index 00000000..d06e4e5f --- /dev/null +++ b/cblas/src/cblas_cdotu_sub.c @@ -0,0 +1,23 @@ +/* + * cblas_cdotu_sub.f + * + * The program is a C interface to cdotu. + * It calls the forteran wrapper before calling cdotu. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_cdotu_sub( const int N, const void *X, + const int incX, const void *Y, const int incY,void *dotu) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_cdotu_sub( &F77_N, X, &F77_incX, Y, &F77_incY, dotu); +} diff --git a/cblas/src/cblas_cgbmv.c b/cblas/src/cblas_cgbmv.c new file mode 100644 index 00000000..1ad497a7 --- /dev/null +++ b/cblas/src/cblas_cgbmv.c @@ -0,0 +1,165 @@ +/* + * cblas_cgbmv.c + * The program is a C interface of cgbmv + * + * Keita Teranishi 5/20/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_cgbmv(const CBLAS_LAYOUT layout, + const CBLAS_TRANSPOSE TransA, const int M, const int N, + const int KL, const int KU, + const void *alpha, const void *A, const int lda, + const void *X, const int incX, const void *beta, + void *Y, const int incY) +{ + char TA; +#ifdef F77_CHAR + F77_CHAR F77_TA; +#else + #define F77_TA &TA +#endif +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; + F77_INT F77_KL=KL,F77_KU=KU; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_KL KL + #define F77_KU KU + #define F77_incX incx + #define F77_incY incY +#endif + int n=0, i=0, incx=incX; + const float *xx= (float *)X, *alp= (float *)alpha, *bet = (float *)beta; + float ALPHA[2],BETA[2]; + int tincY, tincx; + float *x=(float *)X, *y=(float *)Y, *st=0, *tx=0; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(2, "cblas_cgbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + F77_cgbmv(F77_TA, &F77_M, &F77_N, &F77_KL, &F77_KU, alpha, + A, &F77_lda, X, &F77_incX, beta, Y, &F77_incY); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + ALPHA[0]= *alp; + ALPHA[1]= -alp[1]; + BETA[0]= *bet; + BETA[1]= -bet[1]; + TA = 'N'; + if (M > 0) + { + n = M << 1; + x = malloc(n*sizeof(float)); + tx = x; + + if( incX > 0 ) { + i = incX << 1 ; + tincx = 2; + st= x+n; + } else { + i = incX *(-2); + tincx = -2; + st = x-2; + x +=(n-2); + } + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != st); + x=tx; + + #ifdef F77_INT + F77_incX = 1; + #else + incx = 1; + #endif + + if( incY > 0 ) + tincY = incY; + else + tincY = -incY; + + y++; + + if (N > 0) + { + i = tincY << 1; + n = i * N ; + st = y + n; + do { + *y = -(*y); + y += i; + } while(y != st); + y -= n; + } + } + else x = (float *) X; + + + } + else + { + cblas_xerbla(2, "cblas_cgbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + if (TransA == CblasConjTrans) + F77_cgbmv(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, ALPHA, + A ,&F77_lda, x,&F77_incX, BETA, Y, &F77_incY); + else + F77_cgbmv(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, alpha, + A ,&F77_lda, x,&F77_incX, beta, Y, &F77_incY); + if (TransA == CblasConjTrans) + { + if (x != X) free(x); + if (N > 0) + { + do + { + *y = -(*y); + y += i; + } + while (y != st); + } + } + } + else cblas_xerbla(1, "cblas_cgbmv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; +} diff --git a/cblas/src/cblas_cgemm.c b/cblas/src/cblas_cgemm.c new file mode 100644 index 00000000..d97d0330 --- /dev/null +++ b/cblas/src/cblas_cgemm.c @@ -0,0 +1,109 @@ +/* + * + * cblas_cgemm.c + * This program is a C interface to cgemm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_cgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, + const CBLAS_TRANSPOSE TransB, const int M, const int N, + const int K, const void *alpha, const void *A, + const int lda, const void *B, const int ldb, + const void *beta, void *C, const int ldc) +{ + char TA, TB; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_TB; +#else + #define F77_TA &TA + #define F77_TB &TB +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_M M + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + if(TransA == CblasTrans) TA='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(2, "cblas_cgemm", "Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if(TransB == CblasTrans) TB='T'; + else if ( TransB == CblasConjTrans ) TB='C'; + else if ( TransB == CblasNoTrans ) TB='N'; + else + { + cblas_xerbla(3, "cblas_cgemm", "Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + #endif + + F77_cgemm(F77_TA, F77_TB, &F77_M, &F77_N, &F77_K, alpha, A, + &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if(TransA == CblasTrans) TB='T'; + else if ( TransA == CblasConjTrans ) TB='C'; + else if ( TransA == CblasNoTrans ) TB='N'; + else + { + cblas_xerbla(2, "cblas_cgemm", "Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(TransB == CblasTrans) TA='T'; + else if ( TransB == CblasConjTrans ) TA='C'; + else if ( TransB == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(2, "cblas_cgemm", "Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + #endif + + F77_cgemm(F77_TA, F77_TB, &F77_N, &F77_M, &F77_K, alpha, B, + &F77_ldb, A, &F77_lda, beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_cgemm", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_cgemv.c b/cblas/src/cblas_cgemv.c new file mode 100644 index 00000000..5eb70dda --- /dev/null +++ b/cblas/src/cblas_cgemv.c @@ -0,0 +1,162 @@ +/* + * cblas_cgemv.c + * The program is a C interface of cgemv + * + * Keita Teranishi 5/20/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_cgemv(const CBLAS_LAYOUT layout, + const CBLAS_TRANSPOSE TransA, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *X, const int incX, const void *beta, + void *Y, const int incY) +{ + char TA; +#ifdef F77_CHAR + F77_CHAR F77_TA; +#else + #define F77_TA &TA +#endif +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_incX incx + #define F77_incY incY +#endif + + int n=0, i=0, incx=incX; + const float *xx= (const float *)X; + float ALPHA[2],BETA[2]; + int tincY, tincx; + float *x=(float *)X, *y=(float *)Y, *st=0, *tx=0; + const float *stx = x; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + + if (layout == CblasColMajor) + { + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(2, "cblas_cgemv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + F77_cgemv(F77_TA, &F77_M, &F77_N, alpha, A, &F77_lda, X, &F77_incX, + beta, Y, &F77_incY); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + ALPHA[0]= *( (const float *) alpha ); + ALPHA[1]= -( *( (const float *) alpha+1) ); + BETA[0]= *( (const float *) beta ); + BETA[1]= -( *( (const float *) beta+1 ) ); + TA = 'N'; + if (M > 0) + { + n = M << 1; + x = malloc(n*sizeof(float)); + tx = x; + if( incX > 0 ) { + i = incX << 1 ; + tincx = 2; + st= x+n; + } else { + i = incX *(-2); + tincx = -2; + st = x-2; + x +=(n-2); + } + + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != st); + x=tx; + + F77_incX = 1; + + if(incY > 0) + tincY = incY; + else + tincY = -incY; + + y++; + + if (N > 0) + { + i = tincY << 1; + n = i * N ; + st = y + n; + do { + *y = -(*y); + y += i; + } while(y != st); + y -= n; + } + stx = x; + } + else stx = (const float *)X; + } + else + { + cblas_xerbla(2, "cblas_cgemv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + if (TransA == CblasConjTrans) + F77_cgemv(F77_TA, &F77_N, &F77_M, ALPHA, A, &F77_lda, stx, + &F77_incX, BETA, Y, &F77_incY); + else + F77_cgemv(F77_TA, &F77_N, &F77_M, alpha, A, &F77_lda, x, + &F77_incX, beta, Y, &F77_incY); + + if (TransA == CblasConjTrans) + { + if (x != (const float *)X) free(x); + if (N > 0) + { + do + { + *y = -(*y); + y += i; + } + while (y != st); + } + } + } + else cblas_xerbla(1, "cblas_cgemv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_cgerc.c b/cblas/src/cblas_cgerc.c new file mode 100644 index 00000000..1c8d7775 --- /dev/null +++ b/cblas/src/cblas_cgerc.c @@ -0,0 +1,84 @@ +/* + * cblas_cgerc.c + * The program is a C interface to cgerc. + * + * Keita Teranishi 5/20/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_cgerc(const CBLAS_LAYOUT layout, const int M, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda) +{ +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_M M + #define F77_N N + #define F77_incX incX + #define F77_incY incy + #define F77_lda lda +#endif + + int n, i, tincy, incy=incY; + float *y=(float *)Y, *yy=(float *)Y, *ty, *st; + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + F77_cgerc( &F77_M, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, A, + &F77_lda); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (N > 0) + { + n = N << 1; + y = malloc(n*sizeof(float)); + + ty = y; + if( incY > 0 ) { + i = incY << 1; + tincy = 2; + st= y+n; + } else { + i = incY *(-2); + tincy = -2; + st = y-2; + y +=(n-2); + } + do + { + *y = *yy; + y[1] = -yy[1]; + y += tincy ; + yy += i; + } + while (y != st); + y = ty; + + #ifdef F77_INT + F77_incY = 1; + #else + incy = 1; + #endif + } + else y = (float *) Y; + + F77_cgeru( &F77_N, &F77_M, alpha, y, &F77_incY, X, &F77_incX, A, + &F77_lda); + if(Y!=y) + free(y); + + } else cblas_xerbla(1, "cblas_cgerc", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_cgeru.c b/cblas/src/cblas_cgeru.c new file mode 100644 index 00000000..b2a534fc --- /dev/null +++ b/cblas/src/cblas_cgeru.c @@ -0,0 +1,45 @@ +/* + * cblas_cgeru.c + * The program is a C interface to cgeru. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_cgeru(const CBLAS_LAYOUT layout, const int M, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda) +{ +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_M M + #define F77_N N + #define F77_incX incX + #define F77_incY incY + #define F77_lda lda +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + + if (layout == CblasColMajor) + { + F77_cgeru( &F77_M, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, A, + &F77_lda); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + F77_cgeru( &F77_N, &F77_M, alpha, Y, &F77_incY, X, &F77_incX, A, + &F77_lda); + } + else cblas_xerbla(1, "cblas_cgeru","Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_chbmv.c b/cblas/src/cblas_chbmv.c new file mode 100644 index 00000000..e5058f1e --- /dev/null +++ b/cblas/src/cblas_chbmv.c @@ -0,0 +1,159 @@ +/* + * cblas_chbmv.c + * The program is a C interface to chbmv + * + * Keita Teranishi 5/18/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +#include <stdio.h> +#include <stdlib.h> +void cblas_chbmv(const CBLAS_LAYOUT layout, + const CBLAS_UPLO Uplo,const int N,const int K, + const void *alpha, const void *A, const int lda, + const void *X, const int incX, const void *beta, + void *Y, const int incY) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_incX incx + #define F77_incY incY +#endif + int n, i=0, incx=incX; + const float *xx= (float *)X, *alp= (float *)alpha, *bet = (float *)beta; + float ALPHA[2],BETA[2]; + int tincY, tincx; + float *x=(float *)X, *y=(float *)Y, *st=0, *tx; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_chbmv","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_chbmv(F77_UL, &F77_N, &F77_K, alpha, A, &F77_lda, X, + &F77_incX, beta, Y, &F77_incY); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + ALPHA[0]= *alp; + ALPHA[1]= -alp[1]; + BETA[0]= *bet; + BETA[1]= -bet[1]; + + if (N > 0) + { + n = N << 1; + x = malloc(n*sizeof(float)); + + tx = x; + if( incX > 0 ) { + i = incX << 1 ; + tincx = 2; + st= x+n; + } else { + i = incX *(-2); + tincx = -2; + st = x-2; + x +=(n-2); + } + + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != st); + x=tx; + + + #ifdef F77_INT + F77_incX = 1; + #else + incx = 1; + #endif + + if(incY > 0) + tincY = incY; + else + tincY = -incY; + y++; + + i = tincY << 1; + n = i * N ; + st = y + n; + do { + *y = -(*y); + y += i; + } while(y != st); + y -= n; + } else + x = (float *) X; + + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_chbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_chbmv(F77_UL, &F77_N, &F77_K, ALPHA, + A ,&F77_lda, x,&F77_incX, BETA, Y, &F77_incY); + } + else + { + cblas_xerbla(1, "cblas_chbmv","Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if ( layout == CblasRowMajor ) + { + RowMajorStrg = 1; + if(X!=x) + free(x); + if (N > 0) + { + do + { + *y = -(*y); + y += i; + } + while (y != st); + } + } + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_chemm.c b/cblas/src/cblas_chemm.c new file mode 100644 index 00000000..91fbcbe4 --- /dev/null +++ b/cblas/src/cblas_chemm.c @@ -0,0 +1,106 @@ +/* + * + * cblas_chemm.c + * This program is a C interface to chemm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_chemm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc) +{ + char SD, UL; +#ifdef F77_CHAR + F77_CHAR F77_SD, F77_UL; +#else + #define F77_SD &SD + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + if( Side == CblasRight) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + cblas_xerbla(2, "cblas_chemm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(3, "cblas_chemm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_chemm(F77_SD, F77_UL, &F77_M, &F77_N, alpha, A, &F77_lda, + B, &F77_ldb, beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if( Side == CblasRight) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + cblas_xerbla(2, "cblas_chemm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_chemm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_chemm(F77_SD, F77_UL, &F77_N, &F77_M, alpha, A, + &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_chemm", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_chemv.c b/cblas/src/cblas_chemv.c new file mode 100644 index 00000000..878be7af --- /dev/null +++ b/cblas/src/cblas_chemv.c @@ -0,0 +1,160 @@ +/* + * cblas_chemv.c + * The program is a C interface to chemv + * + * Keita Teranishi 5/18/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_chemv(const CBLAS_LAYOUT layout, + const CBLAS_UPLO Uplo, const int N, + const void *alpha, const void *A, const int lda, + const void *X, const int incX, const void *beta, + void *Y, const int incY) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incx + #define F77_incY incY +#endif + int n=0, i=0, incx=incX; + const float *xx= (float *)X, *alp= (float *)alpha, *bet = (float *)beta; + float ALPHA[2],BETA[2]; + int tincY, tincx; + float *x=(float *)X, *y=(float *)Y, *st=0, *tx; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_chemv","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_chemv(F77_UL, &F77_N, alpha, A, &F77_lda, X, &F77_incX, + beta, Y, &F77_incY); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + ALPHA[0]= *alp; + ALPHA[1]= -alp[1]; + BETA[0]= *bet; + BETA[1]= -bet[1]; + + if (N > 0) + { + n = N << 1; + x = malloc(n*sizeof(float)); + + tx = x; + if( incX > 0 ) { + i = incX << 1 ; + tincx = 2; + st= x+n; + } else { + i = incX *(-2); + tincx = -2; + st = x-2; + x +=(n-2); + } + + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != st); + x=tx; + + + #ifdef F77_INT + F77_incX = 1; + #else + incx = 1; + #endif + + if(incY > 0) + tincY = incY; + else + tincY = -incY; + y++; + + i = tincY << 1; + n = i * N ; + st = y + n; + do { + *y = -(*y); + y += i; + } while(y != st); + y -= n; + } else + x = (float *) X; + + + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_chemv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_chemv(F77_UL, &F77_N, ALPHA, A, &F77_lda, x, &F77_incX, + BETA, Y, &F77_incY); + } + else + { + cblas_xerbla(1, "cblas_chemv","Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if ( layout == CblasRowMajor ) + { + RowMajorStrg = 1; + if ( X != x ) + free(x); + if (N > 0) + { + do + { + *y = -(*y); + y += i; + } + while (y != st); + } + } + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_cher.c b/cblas/src/cblas_cher.c new file mode 100644 index 00000000..245fe5b1 --- /dev/null +++ b/cblas/src/cblas_cher.c @@ -0,0 +1,116 @@ +/* + * cblas_cher.c + * The program is a C interface to cher. + * + * Keita Teranishi 5/20/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_cher(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const int N, const float alpha, const void *X, const int incX + ,void *A, const int lda) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incx +#endif + int n, i, tincx, incx=incX; + float *x=(float *)X, *xx=(float *)X, *tx, *st; + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_cher","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_cher(F77_UL, &F77_N, &alpha, X, &F77_incX, A, &F77_lda); + + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_cher","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + if (N > 0) + { + n = N << 1; + x = malloc(n*sizeof(float)); + tx = x; + if( incX > 0 ) { + i = incX << 1 ; + tincx = 2; + st= x+n; + } else { + i = incX *(-2); + tincx = -2; + st = x-2; + x +=(n-2); + } + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != st); + x=tx; + + #ifdef F77_INT + F77_incX = 1; + #else + incx = 1; + #endif + } + else x = (float *) X; + F77_cher(F77_UL, &F77_N, &alpha, x, &F77_incX, A, &F77_lda); + } else + { + cblas_xerbla(1, "cblas_cher","Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(X!=x) + free(x); + + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_cher2.c b/cblas/src/cblas_cher2.c new file mode 100644 index 00000000..bdded3e1 --- /dev/null +++ b/cblas/src/cblas_cher2.c @@ -0,0 +1,152 @@ +/* + * cblas_cher2.c + * The program is a C interface to cher2. + * + * Keita Teranishi 3/23/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_cher2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const int N, const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incx + #define F77_incY incy +#endif + int n, i, j, tincx, tincy, incx=incX, incy=incY; + float *x=(float *)X, *xx=(float *)X, *y=(float *)Y, + *yy=(float *)Y, *tx, *ty, *stx, *sty; + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_cher2","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_cher2(F77_UL, &F77_N, alpha, X, &F77_incX, + Y, &F77_incY, A, &F77_lda); + + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_cher2","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + if (N > 0) + { + n = N << 1; + x = malloc(n*sizeof(float)); + y = malloc(n*sizeof(float)); + tx = x; + ty = y; + if( incX > 0 ) { + i = incX << 1 ; + tincx = 2; + stx= x+n; + } else { + i = incX *(-2); + tincx = -2; + stx = x-2; + x +=(n-2); + } + + if( incY > 0 ) { + j = incY << 1; + tincy = 2; + sty= y+n; + } else { + j = incY *(-2); + tincy = -2; + sty = y-2; + y +=(n-2); + } + + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != stx); + + do + { + *y = *yy; + y[1] = -yy[1]; + y += tincy ; + yy += j; + } + while (y != sty); + + x=tx; + y=ty; + + #ifdef F77_INT + F77_incX = 1; + F77_incY = 1; + #else + incx = 1; + incy = 1; + #endif + } else + { + x = (float *) X; + y = (float *) Y; + } + F77_cher2(F77_UL, &F77_N, alpha, y, &F77_incY, x, + &F77_incX, A, &F77_lda); + } else + { + cblas_xerbla(1, "cblas_cher2","Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(X!=x) + free(x); + if(Y!=y) + free(y); + + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_cher2k.c b/cblas/src/cblas_cher2k.c new file mode 100644 index 00000000..2fc77009 --- /dev/null +++ b/cblas/src/cblas_cher2k.c @@ -0,0 +1,111 @@ +/* + * + * cblas_cher2k.c + * This program is a C interface to cher2k. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_cher2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const float beta, + void *C, const int ldc) +{ + char UL, TR; +#ifdef F77_CHAR + F77_CHAR F77_TR, F77_UL; +#else + #define F77_TR &TR + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + float ALPHA[2]; + const float *alp=(float *)alpha; + + CBLAS_CallFromC = 1; + RowMajorStrg = 0; + + if( layout == CblasColMajor ) + { + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(2, "cblas_cher2k", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Trans == CblasTrans) TR ='T'; + else if ( Trans == CblasConjTrans ) TR='C'; + else if ( Trans == CblasNoTrans ) TR='N'; + else + { + cblas_xerbla(3, "cblas_cher2k", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_cher2k(F77_UL, F77_TR, &F77_N, &F77_K, alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(2, "cblas_cher2k", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Trans == CblasTrans) TR ='N'; + else if ( Trans == CblasConjTrans ) TR='N'; + else if ( Trans == CblasNoTrans ) TR='C'; + else + { + cblas_xerbla(3, "cblas_cher2k", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + ALPHA[0]= *alp; + ALPHA[1]= -alp[1]; + F77_cher2k(F77_UL,F77_TR, &F77_N, &F77_K, ALPHA, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_cher2k", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_cherk.c b/cblas/src/cblas_cherk.c new file mode 100644 index 00000000..5157d7bb --- /dev/null +++ b/cblas/src/cblas_cherk.c @@ -0,0 +1,105 @@ +/* + * + * cblas_cherk.c + * This program is a C interface to cherk. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_cherk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE Trans, const int N, const int K, + const float alpha, const void *A, const int lda, + const float beta, void *C, const int ldc) +{ + char UL, TR; +#ifdef F77_CHAR + F77_CHAR F77_TR, F77_UL; +#else + #define F77_TR &TR + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(2, "cblas_cherk", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Trans == CblasTrans) TR ='T'; + else if ( Trans == CblasConjTrans ) TR='C'; + else if ( Trans == CblasNoTrans ) TR='N'; + else + { + cblas_xerbla(3, "cblas_cherk", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_cherk(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, + &beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_cherk", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Trans == CblasTrans) TR ='N'; + else if ( Trans == CblasConjTrans ) TR='N'; + else if ( Trans == CblasNoTrans ) TR='C'; + else + { + cblas_xerbla(3, "cblas_cherk", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_cherk(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, + &beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_cherk", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_chpmv.c b/cblas/src/cblas_chpmv.c new file mode 100644 index 00000000..2daf2f81 --- /dev/null +++ b/cblas/src/cblas_chpmv.c @@ -0,0 +1,160 @@ +/* + * cblas_chpmv.c + * The program is a C interface of chpmv + * + * Keita Teranishi 5/18/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_chpmv(const CBLAS_LAYOUT layout, + const CBLAS_UPLO Uplo,const int N, + const void *alpha, const void *AP, + const void *X, const int incX, const void *beta, + void *Y, const int incY) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incx + #define F77_incY incY +#endif + int n, i=0, incx=incX; + const float *xx= (float *)X, *alp= (float *)alpha, *bet = (float *)beta; + float ALPHA[2],BETA[2]; + int tincY, tincx; + float *x=(float *)X, *y=(float *)Y, *st=0, *tx; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_chpmv","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_chpmv(F77_UL, &F77_N, alpha, AP, X, + &F77_incX, beta, Y, &F77_incY); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + ALPHA[0]= *alp; + ALPHA[1]= -alp[1]; + BETA[0]= *bet; + BETA[1]= -bet[1]; + + if (N > 0) + { + n = N << 1; + x = malloc(n*sizeof(float)); + + tx = x; + if( incX > 0 ) { + i = incX << 1; + tincx = 2; + st= x+n; + } else { + i = incX *(-2); + tincx = -2; + st = x-2; + x +=(n-2); + } + + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != st); + x=tx; + + + #ifdef F77_INT + F77_incX = 1; + #else + incx = 1; + #endif + + if(incY > 0) + tincY = incY; + else + tincY = -incY; + y++; + + i = tincY << 1; + n = i * N ; + st = y + n; + do { + *y = -(*y); + y += i; + } while(y != st); + y -= n; + } else + x = (float *) X; + + + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_chpmv","Illegal Uplo setting, %d\n", Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_chpmv(F77_UL, &F77_N, ALPHA, + AP, x, &F77_incX, BETA, Y, &F77_incY); + } + else + { + cblas_xerbla(1, "cblas_chpmv","Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if ( layout == CblasRowMajor ) + { + RowMajorStrg = 1; + if(X!=x) + free(x); + if (N > 0) + { + do + { + *y = -(*y); + y += i; + } + while (y != st); + } + } + + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_chpr.c b/cblas/src/cblas_chpr.c new file mode 100644 index 00000000..1797a8fd --- /dev/null +++ b/cblas/src/cblas_chpr.c @@ -0,0 +1,115 @@ +/* + * cblas_chpr.c + * The program is a C interface to chpr. + * + * Keita Teranishi 3/23/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_chpr(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const int N, const float alpha, const void *X, + const int incX, void *A) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incx +#endif + int n, i, tincx, incx=incX; + float *x=(float *)X, *xx=(float *)X, *tx, *st; + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_chpr","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_chpr(F77_UL, &F77_N, &alpha, X, &F77_incX, A); + + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_chpr","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + if (N > 0) + { + n = N << 1; + x = malloc(n*sizeof(float)); + tx = x; + if( incX > 0 ) { + i = incX << 1; + tincx = 2; + st= x+n; + } else { + i = incX *(-2); + tincx = -2; + st = x-2; + x +=(n-2); + } + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != st); + x=tx; + #ifdef F77_INT + F77_incX = 1; + #else + incx = 1; + #endif + } + else x = (float *) X; + + F77_chpr(F77_UL, &F77_N, &alpha, x, &F77_incX, A); + + } else + { + cblas_xerbla(1, "cblas_chpr","Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(X!=x) + free(x); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_chpr2.c b/cblas/src/cblas_chpr2.c new file mode 100644 index 00000000..c73168c7 --- /dev/null +++ b/cblas/src/cblas_chpr2.c @@ -0,0 +1,149 @@ +/* + * cblas_chpr2.c + * The program is a C interface to chpr2. + * + * Keita Teranishi 5/20/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_chpr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const int N,const void *alpha, const void *X, + const int incX,const void *Y, const int incY, void *Ap) + +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incx + #define F77_incY incy +#endif + int n, i, j, tincx, tincy, incx=incX, incy=incY; + float *x=(float *)X, *xx=(float *)X, *y=(float *)Y, + *yy=(float *)Y, *tx, *ty, *stx, *sty; + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_chpr2","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_chpr2(F77_UL, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, Ap); + + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_chpr2","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + if (N > 0) + { + n = N << 1; + x = malloc(n*sizeof(float)); + y = malloc(n*sizeof(float)); + tx = x; + ty = y; + if( incX > 0 ) { + i = incX << 1 ; + tincx = 2; + stx= x+n; + } else { + i = incX *(-2); + tincx = -2; + stx = x-2; + x +=(n-2); + } + + if( incY > 0 ) { + j = incY << 1; + tincy = 2; + sty= y+n; + } else { + j = incY *(-2); + tincy = -2; + sty = y-2; + y +=(n-2); + } + + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != stx); + do + { + *y = *yy; + y[1] = -yy[1]; + y += tincy ; + yy += j; + } + while (y != sty); + + x=tx; + y=ty; + + #ifdef F77_INT + F77_incX = 1; + F77_incY = 1; + #else + incx = 1; + incy = 1; + #endif + + } else + { + x = (float *) X; + y = (void *) Y; + } + F77_chpr2(F77_UL, &F77_N, alpha, y, &F77_incY, x, &F77_incX, Ap); + } else + { + cblas_xerbla(1, "cblas_chpr2","Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(X!=x) + free(x); + if(Y!=y) + free(y); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_cscal.c b/cblas/src/cblas_cscal.c new file mode 100644 index 00000000..a23e6ee5 --- /dev/null +++ b/cblas/src/cblas_cscal.c @@ -0,0 +1,21 @@ +/* + * cblas_cscal.c + * + * The program is a C interface to cscal.f. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_cscal( const int N, const void *alpha, void *X, + const int incX) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_cscal( &F77_N, alpha, X, &F77_incX); +} diff --git a/cblas/src/cblas_csscal.c b/cblas/src/cblas_csscal.c new file mode 100644 index 00000000..39983fe0 --- /dev/null +++ b/cblas/src/cblas_csscal.c @@ -0,0 +1,21 @@ +/* + * cblas_csscal.c + * + * The program is a C interface to csscal. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_csscal( const int N, const float alpha, void *X, + const int incX) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_csscal( &F77_N, &alpha, X, &F77_incX); +} diff --git a/cblas/src/cblas_cswap.c b/cblas/src/cblas_cswap.c new file mode 100644 index 00000000..12728207 --- /dev/null +++ b/cblas/src/cblas_cswap.c @@ -0,0 +1,22 @@ +/* + * cblas_cswap.c + * + * The program is a C interface to cswap. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_cswap( const int N, void *X, const int incX, void *Y, + const int incY) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_cswap( &F77_N, X, &F77_incX, Y, &F77_incY); +} diff --git a/cblas/src/cblas_csymm.c b/cblas/src/cblas_csymm.c new file mode 100644 index 00000000..888b3253 --- /dev/null +++ b/cblas/src/cblas_csymm.c @@ -0,0 +1,106 @@ +/* + * + * cblas_csymm.c + * This program is a C interface to csymm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_csymm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc) +{ + char SD, UL; +#ifdef F77_CHAR + F77_CHAR F77_SD, F77_UL; +#else + #define F77_SD &SD + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + if( Side == CblasRight) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + cblas_xerbla(2, "cblas_csymm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(3, "cblas_csymm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_csymm(F77_SD, F77_UL, &F77_M, &F77_N, alpha, A, &F77_lda, + B, &F77_ldb, beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if( Side == CblasRight) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + cblas_xerbla(2, "cblas_csymm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_csymm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_csymm(F77_SD, F77_UL, &F77_N, &F77_M, alpha, A, &F77_lda, + B, &F77_ldb, beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_csymm", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_csyr2k.c b/cblas/src/cblas_csyr2k.c new file mode 100644 index 00000000..f99caab6 --- /dev/null +++ b/cblas/src/cblas_csyr2k.c @@ -0,0 +1,108 @@ +/* + * + * cblas_csyr2k.c + * This program is a C interface to csyr2k. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_csyr2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc) +{ + char UL, TR; +#ifdef F77_CHAR + F77_CHAR F77_TR, F77_UL; +#else + #define F77_TR &TR + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(2, "cblas_csyr2k", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Trans == CblasTrans) TR ='T'; + else if ( Trans == CblasConjTrans ) TR='C'; + else if ( Trans == CblasNoTrans ) TR='N'; + else + { + cblas_xerbla(3, "cblas_csyr2k", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_csyr2k(F77_UL, F77_TR, &F77_N, &F77_K, alpha, A, &F77_lda, + B, &F77_ldb, beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_csyr2k", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Trans == CblasTrans) TR ='N'; + else if ( Trans == CblasConjTrans ) TR='N'; + else if ( Trans == CblasNoTrans ) TR='T'; + else + { + cblas_xerbla(3, "cblas_csyr2k", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_csyr2k(F77_UL, F77_TR, &F77_N, &F77_K, alpha, A, &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_csyr2k", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_csyrk.c b/cblas/src/cblas_csyrk.c new file mode 100644 index 00000000..94809cec --- /dev/null +++ b/cblas/src/cblas_csyrk.c @@ -0,0 +1,108 @@ +/* + * + * cblas_csyrk.c + * This program is a C interface to csyrk. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_csyrk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *beta, void *C, const int ldc) +{ + char UL, TR; +#ifdef F77_CHAR + F77_CHAR F77_TR, F77_UL; +#else + #define F77_TR &TR + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(2, "cblas_csyrk", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Trans == CblasTrans) TR ='T'; + else if ( Trans == CblasConjTrans ) TR='C'; + else if ( Trans == CblasNoTrans ) TR='N'; + else + { + cblas_xerbla(3, "cblas_csyrk", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_csyrk(F77_UL, F77_TR, &F77_N, &F77_K, alpha, A, &F77_lda, + beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_csyrk", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Trans == CblasTrans) TR ='N'; + else if ( Trans == CblasConjTrans ) TR='N'; + else if ( Trans == CblasNoTrans ) TR='T'; + else + { + cblas_xerbla(3, "cblas_csyrk", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_csyrk(F77_UL, F77_TR, &F77_N, &F77_K, alpha, A, &F77_lda, + beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_csyrk", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} + diff --git a/cblas/src/cblas_ctbmv.c b/cblas/src/cblas_ctbmv.c new file mode 100644 index 00000000..f584bf6a --- /dev/null +++ b/cblas/src/cblas_ctbmv.c @@ -0,0 +1,158 @@ +/* + * cblas_ctbmv.c + * The program is a C interface to ctbmv. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ctbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const int K, const void *A, const int lda, + void *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_K=K, F77_incX=incX; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_incX incX +#endif + int n, i=0, tincX; + float *st=0, *x=(float *)X; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ctbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_ctbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ctbmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ctbmv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ctbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + TA = 'N'; + if ( N > 0) + { + if(incX > 0) + tincX = incX; + else + tincX = -incX; + i = tincX << 1; + n = i * N; + x++; + st = x + n; + do + { + *x = -(*x); + x+= i; + } + while (x != st); + x -= n; + } + } + else + { + cblas_xerbla(3, "cblas_ctbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ctbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_ctbmv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + + if (TransA == CblasConjTrans) + { + if (N > 0) + { + do + { + *x = -(*x); + x += i; + } + while (x != st); + } + } + } + else cblas_xerbla(1, "cblas_ctbmv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_ctbsv.c b/cblas/src/cblas_ctbsv.c new file mode 100644 index 00000000..97778f4c --- /dev/null +++ b/cblas/src/cblas_ctbsv.c @@ -0,0 +1,162 @@ +/* + * cblas_ctbsv.c + * The program is a C interface to ctbsv. + * + * Keita Teranishi 3/23/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ctbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const int K, const void *A, const int lda, + void *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_K=K, F77_incX=incX; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_incX incX +#endif + int n, i=0, tincX; + float *st=0,*x=(float *)X; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ctbsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_ctbsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ctbsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ctbsv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ctbsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + TA = 'N'; + if ( N > 0) + { + if ( incX > 0 ) + tincX = incX; + else + tincX = -incX; + + n = N*2*(tincX); + + x++; + + st=x+n; + + i = tincX << 1; + do + { + *x = -(*x); + x+=i; + } + while (x != st); + x -= n; + } + } + else + { + cblas_xerbla(3, "cblas_ctbsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ctbsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_ctbsv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + + if (TransA == CblasConjTrans) + { + if (N > 0) + { + do + { + *x = -(*x); + x+= i; + } + while (x != st); + } + } + } + else cblas_xerbla(1, "cblas_ctbsv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_ctpmv.c b/cblas/src/cblas_ctpmv.c new file mode 100644 index 00000000..6f12c96a --- /dev/null +++ b/cblas/src/cblas_ctpmv.c @@ -0,0 +1,152 @@ +/* + * cblas_ctpmv.c + * The program is a C interface to ctpmv. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ctpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const void *Ap, void *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + int n, i=0, tincX; + float *st=0,*x=(float *)X; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ctpmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_ctpmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ctpmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ctpmv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X, &F77_incX); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ctpmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + TA = 'N'; + if ( N > 0) + { + if(incX > 0) + tincX = incX; + else + tincX = -incX; + i = tincX << 1; + n = i * N; + x++; + st = x + n; + do + { + *x = -(*x); + x += i; + } + while (x != st); + x -= n; + } + } + else + { + cblas_xerbla(3, "cblas_ctpmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ctpmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_ctpmv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X,&F77_incX); + if (TransA == CblasConjTrans) + { + if (N > 0) + { + do + { + *x = -(*x); + x += i; + } + while (x != st); + } + } + } + else cblas_xerbla(1, "cblas_ctpmv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_ctpsv.c b/cblas/src/cblas_ctpsv.c new file mode 100644 index 00000000..808827e9 --- /dev/null +++ b/cblas/src/cblas_ctpsv.c @@ -0,0 +1,157 @@ +/* + * cblas_ctpsv.c + * The program is a C interface to ctpsv. + * + * Keita Teranishi 3/23/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ctpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const void *Ap, void *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + int n, i=0, tincX; + float *st=0, *x=(float*)X; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ctpsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_ctpsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ctpsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ctpsv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X, &F77_incX); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ctpsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + TA = 'N'; + if ( N > 0) + { + if ( incX > 0 ) + tincX = incX; + else + tincX = -incX; + + n = N*2*(tincX); + + x++; + + st=x+n; + + i = tincX << 1; + do + { + *x = -(*x); + x+=i; + } + while (x != st); + x -= n; + } + } + else + { + cblas_xerbla(3, "cblas_ctpsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ctpsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_ctpsv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X,&F77_incX); + + if (TransA == CblasConjTrans) + { + if (N > 0) + { + do + { + *x = -(*x); + x += i; + } + while (x != st); + } + } + } + else cblas_xerbla(1, "cblas_ctpsv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_ctrmm.c b/cblas/src/cblas_ctrmm.c new file mode 100644 index 00000000..0407a682 --- /dev/null +++ b/cblas/src/cblas_ctrmm.c @@ -0,0 +1,144 @@ +/* + * + * cblas_ctrmm.c + * This program is a C interface to ctrmm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ctrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, + const CBLAS_DIAG Diag, const int M, const int N, + const void *alpha, const void *A, const int lda, + void *B, const int ldb) +{ + char UL, TA, SD, DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_SD, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_SD &SD + #define F77_DI &DI +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + if( Side == CblasRight ) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + cblas_xerbla(2, "cblas_ctrmm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Uplo == CblasUpper ) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(3, "cblas_ctrmm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( TransA == CblasTrans ) TA ='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_ctrmm", "Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit ) DI='N'; + else cblas_xerbla(5, "cblas_ctrmm", + "Illegal Diag setting, %d\n", Diag); + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_ctrmm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_M, &F77_N, alpha, A, &F77_lda, B, &F77_ldb); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if( Side == CblasRight ) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + cblas_xerbla(2, "cblas_ctrmm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper ) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_ctrmm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( TransA == CblasTrans ) TA ='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_ctrmm", "Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit ) DI='N'; + else + { + cblas_xerbla(5, "cblas_ctrmm", "Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_ctrmm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_N, &F77_M, alpha, A, &F77_lda, B, &F77_ldb); + } + else cblas_xerbla(1, "cblas_ctrmm", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_ctrmv.c b/cblas/src/cblas_ctrmv.c new file mode 100644 index 00000000..cc87f754 --- /dev/null +++ b/cblas/src/cblas_ctrmv.c @@ -0,0 +1,155 @@ +/* + * cblas_ctrmv.c + * The program is a C interface to ctrmv. + * + * Keita Teranishi 3/23/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ctrmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const void *A, const int lda, + void *X, const int incX) + +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incX +#endif + int n, i=0, tincX; + float *st=0,*x=(float *)X; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ctrmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_ctrmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ctrmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ctrmv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ctrmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + TA = 'N'; + if ( N > 0) + { + if(incX > 0) + tincX = incX; + else + tincX = -incX; + i = tincX << 1; + n = i * N; + st = x + n; + do + { + x[1] = -x[1]; + x+= i; + } + while (x != st); + x -= n; + } + } + else + { + cblas_xerbla(3, "cblas_ctrmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ctrmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ctrmv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + if (TransA == CblasConjTrans) + { + if (N > 0) + { + do + { + x[1] = -x[1]; + x += i; + } + while (x != st); + } + } + } + else cblas_xerbla(1, "cblas_ctrmv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_ctrsm.c b/cblas/src/cblas_ctrsm.c new file mode 100644 index 00000000..51218832 --- /dev/null +++ b/cblas/src/cblas_ctrsm.c @@ -0,0 +1,155 @@ +/* + * + * cblas_ctrsm.c + * This program is a C interface to ctrsm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ctrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, + const CBLAS_DIAG Diag, const int M, const int N, + const void *alpha, const void *A, const int lda, + void *B, const int ldb) +{ + char UL, TA, SD, DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_SD, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_SD &SD + #define F77_DI &DI +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + + if( Side == CblasRight) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + cblas_xerbla(2, "cblas_ctrsm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(3, "cblas_ctrsm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( TransA == CblasTrans) TA ='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_ctrsm", "Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit ) DI='N'; + else + { + cblas_xerbla(5, "cblas_ctrsm", "Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_ctrsm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_M, &F77_N, alpha, A, + &F77_lda, B, &F77_ldb); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + + if( Side == CblasRight) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + cblas_xerbla(2, "cblas_ctrsm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_ctrsm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( TransA == CblasTrans) TA ='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_ctrsm", "Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit ) DI='N'; + else + { + cblas_xerbla(5, "cblas_ctrsm", "Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + + + F77_ctrsm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_N, &F77_M, alpha, A, + &F77_lda, B, &F77_ldb); + } + else cblas_xerbla(1, "cblas_ctrsm", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_ctrsv.c b/cblas/src/cblas_ctrsv.c new file mode 100644 index 00000000..fb3a8fc2 --- /dev/null +++ b/cblas/src/cblas_ctrsv.c @@ -0,0 +1,156 @@ +/* + * cblas_ctrsv.c + * The program is a C interface to ctrsv. + * + * Keita Teranishi 3/23/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ctrsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const void *A, const int lda, void *X, + const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incX +#endif + int n, i=0, tincX; + float *st=0,*x=(float *)X; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ctrsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_ctrsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ctrsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ctrsv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ctrsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + TA = 'N'; + if ( N > 0) + { + if ( incX > 0 ) + tincX = incX; + else + tincX = -incX; + + n = N*2*(tincX); + x++; + st=x+n; + i = tincX << 1; + do + { + *x = -(*x); + x+=i; + } + while (x != st); + x -= n; + } + } + else + { + cblas_xerbla(3, "cblas_ctrsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ctrsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ctrsv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + if (TransA == CblasConjTrans) + { + if (N > 0) + { + do + { + *x = -(*x); + x += i; + } + while (x != st); + } + } + } + else cblas_xerbla(1, "cblas_ctrsv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_dasum.c b/cblas/src/cblas_dasum.c new file mode 100644 index 00000000..1a3667f2 --- /dev/null +++ b/cblas/src/cblas_dasum.c @@ -0,0 +1,23 @@ +/* + * cblas_dasum.c + * + * The program is a C interface to dasum. + * It calls the fortran wrapper before calling dasum. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +double cblas_dasum( const int N, const double *X, const int incX) +{ + double asum; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_dasum_sub( &F77_N, X, &F77_incX, &asum); + return asum; +} diff --git a/cblas/src/cblas_daxpy.c b/cblas/src/cblas_daxpy.c new file mode 100644 index 00000000..3678137f --- /dev/null +++ b/cblas/src/cblas_daxpy.c @@ -0,0 +1,22 @@ +/* + * cblas_daxpy.c + * + * The program is a C interface to daxpy. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_daxpy( const int N, const double alpha, const double *X, + const int incX, double *Y, const int incY) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_daxpy( &F77_N, &alpha, X, &F77_incX, Y, &F77_incY); +} diff --git a/cblas/src/cblas_dcopy.c b/cblas/src/cblas_dcopy.c new file mode 100644 index 00000000..422a55e5 --- /dev/null +++ b/cblas/src/cblas_dcopy.c @@ -0,0 +1,22 @@ +/* + * cblas_dcopy.c + * + * The program is a C interface to dcopy. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dcopy( const int N, const double *X, + const int incX, double *Y, const int incY) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_dcopy( &F77_N, X, &F77_incX, Y, &F77_incY); +} diff --git a/cblas/src/cblas_ddot.c b/cblas/src/cblas_ddot.c new file mode 100644 index 00000000..d7734340 --- /dev/null +++ b/cblas/src/cblas_ddot.c @@ -0,0 +1,25 @@ +/* + * cblas_ddot.c + * + * The program is a C interface to ddot. + * It calls the fortran wrapper before calling ddot. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +double cblas_ddot( const int N, const double *X, + const int incX, const double *Y, const int incY) +{ + double dot; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_ddot_sub( &F77_N, X, &F77_incX, Y, &F77_incY, &dot); + return dot; +} diff --git a/cblas/src/cblas_dgbmv.c b/cblas/src/cblas_dgbmv.c new file mode 100644 index 00000000..1cc30541 --- /dev/null +++ b/cblas/src/cblas_dgbmv.c @@ -0,0 +1,81 @@ +/* + * + * cblas_dgbmv.c + * This program is a C interface to dgbmv. + * Written by Keita Teranishi + * 4/6/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dgbmv(const CBLAS_LAYOUT layout, + const CBLAS_TRANSPOSE TransA, const int M, const int N, + const int KL, const int KU, + const double alpha, const double *A, const int lda, + const double *X, const int incX, const double beta, + double *Y, const int incY) +{ + char TA; +#ifdef F77_CHAR + F77_CHAR F77_TA; +#else + #define F77_TA &TA +#endif +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; + F77_INT F77_KL=KL,F77_KU=KU; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_KL KL + #define F77_KU KU + #define F77_incX incX + #define F77_incY incY +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(2, "cblas_dgbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + F77_dgbmv(F77_TA, &F77_M, &F77_N, &F77_KL, &F77_KU, &alpha, + A, &F77_lda, X, &F77_incX, &beta, Y, &F77_incY); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(2, "cblas_dgbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + F77_dgbmv(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, &alpha, + A ,&F77_lda, X,&F77_incX, &beta, Y, &F77_incY); + } + else cblas_xerbla(1, "cblas_dgbmv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; +} diff --git a/cblas/src/cblas_dgemm.c b/cblas/src/cblas_dgemm.c new file mode 100644 index 00000000..e37f4092 --- /dev/null +++ b/cblas/src/cblas_dgemm.c @@ -0,0 +1,109 @@ +/* + * + * cblas_dgemm.c + * This program is a C interface to dgemm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, + const CBLAS_TRANSPOSE TransB, const int M, const int N, + const int K, const double alpha, const double *A, + const int lda, const double *B, const int ldb, + const double beta, double *C, const int ldc) +{ + char TA, TB; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_TB; +#else + #define F77_TA &TA + #define F77_TB &TB +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_M M + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + if(TransA == CblasTrans) TA='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(2, "cblas_dgemm","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if(TransB == CblasTrans) TB='T'; + else if ( TransB == CblasConjTrans ) TB='C'; + else if ( TransB == CblasNoTrans ) TB='N'; + else + { + cblas_xerbla(3, "cblas_dgemm","Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + #endif + + F77_dgemm(F77_TA, F77_TB, &F77_M, &F77_N, &F77_K, &alpha, A, + &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if(TransA == CblasTrans) TB='T'; + else if ( TransA == CblasConjTrans ) TB='C'; + else if ( TransA == CblasNoTrans ) TB='N'; + else + { + cblas_xerbla(2, "cblas_dgemm","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(TransB == CblasTrans) TA='T'; + else if ( TransB == CblasConjTrans ) TA='C'; + else if ( TransB == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(2, "cblas_dgemm","Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + #endif + + F77_dgemm(F77_TA, F77_TB, &F77_N, &F77_M, &F77_K, &alpha, B, + &F77_ldb, A, &F77_lda, &beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_dgemm", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_dgemv.c b/cblas/src/cblas_dgemv.c new file mode 100644 index 00000000..65968ace --- /dev/null +++ b/cblas/src/cblas_dgemv.c @@ -0,0 +1,78 @@ +/* + * + * cblas_dgemv.c + * This program is a C interface to dgemv. + * Written by Keita Teranishi + * 4/6/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dgemv(const CBLAS_LAYOUT layout, + const CBLAS_TRANSPOSE TransA, const int M, const int N, + const double alpha, const double *A, const int lda, + const double *X, const int incX, const double beta, + double *Y, const int incY) +{ + char TA; +#ifdef F77_CHAR + F77_CHAR F77_TA; +#else + #define F77_TA &TA +#endif +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_incX incX + #define F77_incY incY +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(2, "cblas_dgemv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + F77_dgemv(F77_TA, &F77_M, &F77_N, &alpha, A, &F77_lda, X, &F77_incX, + &beta, Y, &F77_incY); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(2, "cblas_dgemv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + F77_dgemv(F77_TA, &F77_N, &F77_M, &alpha, A, &F77_lda, X, + &F77_incX, &beta, Y, &F77_incY); + } + else cblas_xerbla(1, "cblas_dgemv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_dger.c b/cblas/src/cblas_dger.c new file mode 100644 index 00000000..3b89f67f --- /dev/null +++ b/cblas/src/cblas_dger.c @@ -0,0 +1,47 @@ +/* + * + * cblas_dger.c + * This program is a C interface to dger. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dger(const CBLAS_LAYOUT layout, const int M, const int N, + const double alpha, const double *X, const int incX, + const double *Y, const int incY, double *A, const int lda) +{ +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_M M + #define F77_N N + #define F77_incX incX + #define F77_incY incY + #define F77_lda lda +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + F77_dger( &F77_M, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, + &F77_lda); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + F77_dger( &F77_N, &F77_M ,&alpha, Y, &F77_incY, X, &F77_incX, A, + &F77_lda); + + } + else cblas_xerbla(1, "cblas_dger", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_dnrm2.c b/cblas/src/cblas_dnrm2.c new file mode 100644 index 00000000..fe46ad48 --- /dev/null +++ b/cblas/src/cblas_dnrm2.c @@ -0,0 +1,23 @@ +/* + * cblas_dnrm2.c + * + * The program is a C interface to dnrm2. + * It calls the fortranwrapper before calling dnrm2. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +double cblas_dnrm2( const int N, const double *X, const int incX) +{ + double nrm2; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_dnrm2_sub( &F77_N, X, &F77_incX, &nrm2); + return nrm2; +} diff --git a/cblas/src/cblas_drot.c b/cblas/src/cblas_drot.c new file mode 100644 index 00000000..51dc4ad5 --- /dev/null +++ b/cblas/src/cblas_drot.c @@ -0,0 +1,23 @@ +/* + * cblas_drot.c + * + * The program is a C interface to drot. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_drot(const int N, double *X, const int incX, + double *Y, const int incY, const double c, const double s) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_drot(&F77_N, X, &F77_incX, Y, &F77_incY, &c, &s); + return; +} diff --git a/cblas/src/cblas_drotg.c b/cblas/src/cblas_drotg.c new file mode 100644 index 00000000..0cbbd8bc --- /dev/null +++ b/cblas/src/cblas_drotg.c @@ -0,0 +1,14 @@ +/* + * cblas_drotg.c + * + * The program is a C interface to drotg. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_drotg( double *a, double *b, double *c, double *s) +{ + F77_drotg(a,b,c,s); +} diff --git a/cblas/src/cblas_drotm.c b/cblas/src/cblas_drotm.c new file mode 100644 index 00000000..ebe20ad6 --- /dev/null +++ b/cblas/src/cblas_drotm.c @@ -0,0 +1,14 @@ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_drotm( const int N, double *X, const int incX, double *Y, + const int incY, const double *P) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_drotm( &F77_N, X, &F77_incX, Y, &F77_incY, P); +} diff --git a/cblas/src/cblas_drotmg.c b/cblas/src/cblas_drotmg.c new file mode 100644 index 00000000..13a2208e --- /dev/null +++ b/cblas/src/cblas_drotmg.c @@ -0,0 +1,15 @@ +/* + * cblas_drotmg.c + * + * The program is a C interface to drotmg. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_drotmg( double *d1, double *d2, double *b1, + const double b2, double *p) +{ + F77_drotmg(d1,d2,b1,&b2,p); +} diff --git a/cblas/src/cblas_dsbmv.c b/cblas/src/cblas_dsbmv.c new file mode 100644 index 00000000..78f11422 --- /dev/null +++ b/cblas/src/cblas_dsbmv.c @@ -0,0 +1,77 @@ +/* + * + * cblas_dsbmv.c + * This program is a C interface to dsbmv. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dsbmv(const CBLAS_LAYOUT layout, + const CBLAS_UPLO Uplo, const int N, const int K, + const double alpha, const double *A, const int lda, + const double *X, const int incX, const double beta, + double *Y, const int incY) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_incX incX + #define F77_incY incY +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_dsbmv","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_dsbmv(F77_UL, &F77_N, &F77_K, &alpha, A, &F77_lda, X, + &F77_incX, &beta, Y, &F77_incY); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_dsbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_dsbmv(F77_UL, &F77_N, &F77_K, &alpha, + A ,&F77_lda, X,&F77_incX, &beta, Y, &F77_incY); + } + else cblas_xerbla(1, "cblas_dsbmv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_dscal.c b/cblas/src/cblas_dscal.c new file mode 100644 index 00000000..bd04de77 --- /dev/null +++ b/cblas/src/cblas_dscal.c @@ -0,0 +1,21 @@ +/* + * cblas_dscal.c + * + * The program is a C interface to dscal. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dscal( const int N, const double alpha, double *X, + const int incX) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_dscal( &F77_N, &alpha, X, &F77_incX); +} diff --git a/cblas/src/cblas_dsdot.c b/cblas/src/cblas_dsdot.c new file mode 100644 index 00000000..52cd877a --- /dev/null +++ b/cblas/src/cblas_dsdot.c @@ -0,0 +1,25 @@ +/* + * cblas_dsdot.c + * + * The program is a C interface to dsdot. + * It calls fthe fortran wrapper before calling dsdot. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +double cblas_dsdot( const int N, const float *X, + const int incX, const float *Y, const int incY) +{ + double dot; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_dsdot_sub( &F77_N, X, &F77_incX, Y, &F77_incY, &dot); + return dot; +} diff --git a/cblas/src/cblas_dspmv.c b/cblas/src/cblas_dspmv.c new file mode 100644 index 00000000..75128664 --- /dev/null +++ b/cblas/src/cblas_dspmv.c @@ -0,0 +1,76 @@ +/* + * + * cblas_dspmv.c + * This program is a C interface to dspmv. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dspmv(const CBLAS_LAYOUT layout, + const CBLAS_UPLO Uplo, const int N, + const double alpha, const double *AP, + const double *X, const int incX, const double beta, + double *Y, const int incY) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_dspmv","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_dspmv(F77_UL, &F77_N, &alpha, AP, X, + &F77_incX, &beta, Y, &F77_incY); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_dspmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_dspmv(F77_UL, &F77_N, &alpha, + AP, X,&F77_incX, &beta, Y, &F77_incY); + } + else cblas_xerbla(1, "cblas_dspmv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_dspr.c b/cblas/src/cblas_dspr.c new file mode 100644 index 00000000..fa1c4fbb --- /dev/null +++ b/cblas/src/cblas_dspr.c @@ -0,0 +1,70 @@ +/* + * + * cblas_dspr.c + * This program is a C interface to dspr. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dspr(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const int N, const double alpha, const double *X, + const int incX, double *Ap) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_dspr","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_dspr(F77_UL, &F77_N, &alpha, X, &F77_incX, Ap); + + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasLower) UL = 'U'; + else if (Uplo == CblasUpper) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_dspr","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_dspr(F77_UL, &F77_N, &alpha, X, &F77_incX, Ap); + } else cblas_xerbla(1, "cblas_dspr", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_dspr2.c b/cblas/src/cblas_dspr2.c new file mode 100644 index 00000000..36eeaf97 --- /dev/null +++ b/cblas/src/cblas_dspr2.c @@ -0,0 +1,70 @@ +/* + * cblas_dspr2.c + * The program is a C interface to dspr2. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dspr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const int N, const double alpha, const double *X, + const int incX, const double *Y, const int incY, double *A) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_dspr2","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_dspr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A); + + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasLower) UL = 'U'; + else if (Uplo == CblasUpper) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_dspr2","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_dspr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A); + } else cblas_xerbla(1, "cblas_dspr2", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_dswap.c b/cblas/src/cblas_dswap.c new file mode 100644 index 00000000..9ae5bb93 --- /dev/null +++ b/cblas/src/cblas_dswap.c @@ -0,0 +1,22 @@ +/* + * cblas_dswap.c + * + * The program is a C interface to dswap. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dswap( const int N, double *X, const int incX, double *Y, + const int incY) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_dswap( &F77_N, X, &F77_incX, Y, &F77_incY); +} diff --git a/cblas/src/cblas_dsymm.c b/cblas/src/cblas_dsymm.c new file mode 100644 index 00000000..03f65a89 --- /dev/null +++ b/cblas/src/cblas_dsymm.c @@ -0,0 +1,106 @@ +/* + * + * cblas_dsymm.c + * This program is a C interface to dsymm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dsymm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const int M, const int N, + const double alpha, const double *A, const int lda, + const double *B, const int ldb, const double beta, + double *C, const int ldc) +{ + char SD, UL; +#ifdef F77_CHAR + F77_CHAR F77_SD, F77_UL; +#else + #define F77_SD &SD + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + if( Side == CblasRight) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + cblas_xerbla(2, "cblas_dsymm","Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(3, "cblas_dsymm","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_dsymm(F77_SD, F77_UL, &F77_M, &F77_N, &alpha, A, &F77_lda, + B, &F77_ldb, &beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if( Side == CblasRight) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + cblas_xerbla(2, "cblas_dsymm","Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_dsymm","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_dsymm(F77_SD, F77_UL, &F77_N, &F77_M, &alpha, A, &F77_lda, B, + &F77_ldb, &beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_dsymm","Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_dsymv.c b/cblas/src/cblas_dsymv.c new file mode 100644 index 00000000..3bda0a17 --- /dev/null +++ b/cblas/src/cblas_dsymv.c @@ -0,0 +1,76 @@ +/* + * + * cblas_dsymv.c + * This program is a C interface to dsymv. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dsymv(const CBLAS_LAYOUT layout, + const CBLAS_UPLO Uplo, const int N, + const double alpha, const double *A, const int lda, + const double *X, const int incX, const double beta, + double *Y, const int incY) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incX + #define F77_incY incY +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_dsymv","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_dsymv(F77_UL, &F77_N, &alpha, A, &F77_lda, X, + &F77_incX, &beta, Y, &F77_incY); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_dsymv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_dsymv(F77_UL, &F77_N, &alpha, + A ,&F77_lda, X,&F77_incX, &beta, Y, &F77_incY); + } + else cblas_xerbla(1, "cblas_dsymv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_dsyr.c b/cblas/src/cblas_dsyr.c new file mode 100644 index 00000000..aa1e43c4 --- /dev/null +++ b/cblas/src/cblas_dsyr.c @@ -0,0 +1,71 @@ +/* + * + * cblas_dsyr.c + * This program is a C interface to dsyr. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dsyr(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const int N, const double alpha, const double *X, + const int incX, double *A, const int lda) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_lda=lda; +#else + #define F77_N N + #define F77_incX incX + #define F77_lda lda +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_dsyr","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_dsyr(F77_UL, &F77_N, &alpha, X, &F77_incX, A, &F77_lda); + + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasLower) UL = 'U'; + else if (Uplo == CblasUpper) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_dsyr","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_dsyr(F77_UL, &F77_N, &alpha, X, &F77_incX, A, &F77_lda); + } else cblas_xerbla(1, "cblas_dsyr", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_dsyr2.c b/cblas/src/cblas_dsyr2.c new file mode 100644 index 00000000..b26823a9 --- /dev/null +++ b/cblas/src/cblas_dsyr2.c @@ -0,0 +1,76 @@ +/* + * + * cblas_dsyr2.c + * This program is a C interface to dsyr2. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dsyr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const int N, const double alpha, const double *X, + const int incX, const double *Y, const int incY, double *A, + const int lda) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY, F77__lda=lda; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY + #define F77_lda lda +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_dsyr2","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_dsyr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, + &F77_lda); + + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasLower) UL = 'U'; + else if (Uplo == CblasUpper) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_dsyr2","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_dsyr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, + &F77_lda); + } else cblas_xerbla(1, "cblas_dsyr2", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_dsyr2k.c b/cblas/src/cblas_dsyr2k.c new file mode 100644 index 00000000..bf214deb --- /dev/null +++ b/cblas/src/cblas_dsyr2k.c @@ -0,0 +1,109 @@ +/* + * + * cblas_dsyr2k.c + * This program is a C interface to dsyr2k. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dsyr2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE Trans, const int N, const int K, + const double alpha, const double *A, const int lda, + const double *B, const int ldb, const double beta, + double *C, const int ldc) +{ + char UL, TR; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL; +#else + #define F77_TR &TR + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(2, "cblas_dsyr2k","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Trans == CblasTrans) TR ='T'; + else if ( Trans == CblasConjTrans ) TR='C'; + else if ( Trans == CblasNoTrans ) TR='N'; + else + { + cblas_xerbla(3, "cblas_dsyr2k","Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_dsyr2k(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, + B, &F77_ldb, &beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_dsyr2k","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Trans == CblasTrans) TR ='N'; + else if ( Trans == CblasConjTrans ) TR='N'; + else if ( Trans == CblasNoTrans ) TR='T'; + else + { + cblas_xerbla(3, "cblas_dsyr2k","Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_dsyr2k(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, B, + &F77_ldb, &beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_dsyr2k","Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_dsyrk.c b/cblas/src/cblas_dsyrk.c new file mode 100644 index 00000000..2d2dfe6a --- /dev/null +++ b/cblas/src/cblas_dsyrk.c @@ -0,0 +1,108 @@ +/* + * + * cblas_dsyrk.c + * This program is a C interface to dsyrk. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dsyrk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE Trans, const int N, const int K, + const double alpha, const double *A, const int lda, + const double beta, double *C, const int ldc) +{ + char UL, TR; +#ifdef F77_CHAR + F77_CHAR F77_TR, F77_UL; +#else + #define F77_TR &TR + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(2, "cblas_dsyrk","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Trans == CblasTrans) TR ='T'; + else if ( Trans == CblasConjTrans ) TR='C'; + else if ( Trans == CblasNoTrans ) TR='N'; + else + { + cblas_xerbla(3, "cblas_dsyrk","Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_dsyrk(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, + &beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_dsyrk","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Trans == CblasTrans) TR ='N'; + else if ( Trans == CblasConjTrans ) TR='N'; + else if ( Trans == CblasNoTrans ) TR='T'; + else + { + cblas_xerbla(3, "cblas_dsyrk","Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_dsyrk(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, + &beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_dsyrk","Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} + diff --git a/cblas/src/cblas_dtbmv.c b/cblas/src/cblas_dtbmv.c new file mode 100644 index 00000000..08caef47 --- /dev/null +++ b/cblas/src/cblas_dtbmv.c @@ -0,0 +1,122 @@ +/* + * cblas_dtbmv.c + * The program is a C interface to dtbmv. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dtbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const int K, const double *A, const int lda, + double *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_K=K, F77_incX=incX; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_incX incX +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_dtbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_dtbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_dtbmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_dtbmv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_dtbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(3, "cblas_dtbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_dtbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_dtbmv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + + } + else cblas_xerbla(1, "cblas_dtbmv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; +} diff --git a/cblas/src/cblas_dtbsv.c b/cblas/src/cblas_dtbsv.c new file mode 100644 index 00000000..275889c8 --- /dev/null +++ b/cblas/src/cblas_dtbsv.c @@ -0,0 +1,122 @@ +/* + * cblas_dtbsv.c + * The program is a C interface to dtbsv. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dtbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const int K, const double *A, const int lda, + double *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_K=K, F77_incX=incX; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_incX incX +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_dtbsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_dtbsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_dtbsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_dtbsv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_dtbsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(3, "cblas_dtbsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_dtbsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_dtbsv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + } + else cblas_xerbla(1, "cblas_dtbsv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_dtpmv.c b/cblas/src/cblas_dtpmv.c new file mode 100644 index 00000000..d18f7f35 --- /dev/null +++ b/cblas/src/cblas_dtpmv.c @@ -0,0 +1,117 @@ +/* + * cblas_dtpmv.c + * The program is a C interface to dtpmv. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dtpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const double *Ap, double *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_dtpmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_dtpmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_dtpmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_dtpmv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X, &F77_incX); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_dtpmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(3, "cblas_dtpmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_dtpmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_dtpmv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X,&F77_incX); + } + else cblas_xerbla(1, "cblas_dtpmv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_dtpsv.c b/cblas/src/cblas_dtpsv.c new file mode 100644 index 00000000..ef30807e --- /dev/null +++ b/cblas/src/cblas_dtpsv.c @@ -0,0 +1,118 @@ +/* + * cblas_dtpsv.c + * The program is a C interface to dtpsv. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dtpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const double *Ap, double *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_dtpsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_dtpsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_dtpsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_dtpsv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X, &F77_incX); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_dtpsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(3, "cblas_dtpsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_dtpsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_dtpsv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X,&F77_incX); + + } + else cblas_xerbla(1, "cblas_dtpsv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_dtrmm.c b/cblas/src/cblas_dtrmm.c new file mode 100644 index 00000000..76bba298 --- /dev/null +++ b/cblas/src/cblas_dtrmm.c @@ -0,0 +1,148 @@ +/* + * + * cblas_dtrmm.c + * This program is a C interface to dtrmm. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dtrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, + const CBLAS_DIAG Diag, const int M, const int N, + const double alpha, const double *A, const int lda, + double *B, const int ldb) +{ + char UL, TA, SD, DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_SD, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_SD &SD + #define F77_DI &DI +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + if( Side == CblasRight) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + cblas_xerbla(2, "cblas_dtrmm","Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(3, "cblas_dtrmm","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( TransA == CblasTrans) TA ='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_dtrmm","Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit ) DI='N'; + else + { + cblas_xerbla(5, "cblas_dtrmm","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_dtrmm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_M, &F77_N, &alpha, A, &F77_lda, B, &F77_ldb); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if( Side == CblasRight) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + cblas_xerbla(2, "cblas_dtrmm","Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_dtrmm","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( TransA == CblasTrans) TA ='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_dtrmm","Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit ) DI='N'; + else + { + cblas_xerbla(5, "cblas_dtrmm","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + F77_dtrmm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_N, &F77_M, &alpha, A, &F77_lda, B, &F77_ldb); + } + else cblas_xerbla(1, "cblas_dtrmm", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_dtrmv.c b/cblas/src/cblas_dtrmv.c new file mode 100644 index 00000000..1a6dc590 --- /dev/null +++ b/cblas/src/cblas_dtrmv.c @@ -0,0 +1,122 @@ +/* + * + * cblas_dtrmv.c + * This program is a C interface to sgemv. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dtrmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const double *A, const int lda, + double *X, const int incX) + +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incX +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_dtrmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_dtrmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_dtrmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_dtrmv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_dtrmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(3, "cblas_dtrmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_dtrmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_dtrmv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + } else cblas_xerbla(1, "cblas_dtrmv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_dtrsm.c b/cblas/src/cblas_dtrsm.c new file mode 100644 index 00000000..21f94476 --- /dev/null +++ b/cblas/src/cblas_dtrsm.c @@ -0,0 +1,153 @@ +/* + * + * cblas_dtrsm.c + * This program is a C interface to dtrsm. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dtrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, + const CBLAS_DIAG Diag, const int M, const int N, + const double alpha, const double *A, const int lda, + double *B, const int ldb) + +{ + char UL, TA, SD, DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_SD, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_SD &SD + #define F77_DI &DI +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + if ( Side == CblasRight) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + cblas_xerbla(2, "cblas_dtrsm","Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if ( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower) UL='L'; + else + { + cblas_xerbla(3, "cblas_dtrsm","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if ( TransA == CblasTrans ) TA='T'; + else if ( TransA == CblasConjTrans) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_dtrsm","Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if ( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit) DI='N'; + else + { + cblas_xerbla(5, "cblas_dtrsm","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_dtrsm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_M, &F77_N, &alpha, + A, &F77_lda, B, &F77_ldb); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if ( Side == CblasRight) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + cblas_xerbla(2, "cblas_dtrsm","Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if ( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower) UL='U'; + else + { + cblas_xerbla(3, "cblas_dtrsm","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if ( TransA == CblasTrans ) TA='T'; + else if ( TransA == CblasConjTrans) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_dtrsm","Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if ( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit) DI='N'; + else + { + cblas_xerbla(5, "cblas_dtrsm","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_dtrsm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_N, &F77_M, &alpha, A, + &F77_lda, B, &F77_ldb); + } + else cblas_xerbla(1, "cblas_dtrsm","Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_dtrsv.c b/cblas/src/cblas_dtrsv.c new file mode 100644 index 00000000..21c791fd --- /dev/null +++ b/cblas/src/cblas_dtrsv.c @@ -0,0 +1,121 @@ +/* + * cblas_dtrsv.c + * The program is a C interface to dtrsv. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dtrsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const double *A, const int lda, double *X, + const int incX) + +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incX +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_dtrsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_dtrsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_dtrsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_dtrsv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_dtrsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(3, "cblas_dtrsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_dtrsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_dtrsv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + } + else cblas_xerbla(1, "cblas_dtrsv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_dzasum.c b/cblas/src/cblas_dzasum.c new file mode 100644 index 00000000..b32f573e --- /dev/null +++ b/cblas/src/cblas_dzasum.c @@ -0,0 +1,23 @@ +/* + * cblas_dzasum.c + * + * The program is a C interface to dzasum. + * It calls the fortran wrapper before calling dzasum. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +double cblas_dzasum( const int N, const void *X, const int incX) +{ + double asum; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_dzasum_sub( &F77_N, X, &F77_incX, &asum); + return asum; +} diff --git a/cblas/src/cblas_dznrm2.c b/cblas/src/cblas_dznrm2.c new file mode 100644 index 00000000..dfa2bfc8 --- /dev/null +++ b/cblas/src/cblas_dznrm2.c @@ -0,0 +1,23 @@ +/* + * cblas_dznrm2.c + * + * The program is a C interface to dznrm2. + * It calls the fortran wrapper before calling dznrm2. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +double cblas_dznrm2( const int N, const void *X, const int incX) +{ + double nrm2; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_dznrm2_sub( &F77_N, X, &F77_incX, &nrm2); + return nrm2; +} diff --git a/cblas/src/cblas_globals.c b/cblas/src/cblas_globals.c new file mode 100644 index 00000000..ebcd74db --- /dev/null +++ b/cblas/src/cblas_globals.c @@ -0,0 +1,2 @@ +int CBLAS_CallFromC=0; +int RowMajorStrg=0; diff --git a/cblas/src/cblas_icamax.c b/cblas/src/cblas_icamax.c new file mode 100644 index 00000000..f0cdbdb3 --- /dev/null +++ b/cblas/src/cblas_icamax.c @@ -0,0 +1,23 @@ +/* + * cblas_icamax.c + * + * The program is a C interface to icamax. + * It calls the fortran wrapper before calling icamax. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +CBLAS_INDEX cblas_icamax( const int N, const void *X, const int incX) +{ + int iamax; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_icamax_sub( &F77_N, X, &F77_incX, &iamax); + return iamax ? iamax-1 : 0; +} diff --git a/cblas/src/cblas_idamax.c b/cblas/src/cblas_idamax.c new file mode 100644 index 00000000..abb70b53 --- /dev/null +++ b/cblas/src/cblas_idamax.c @@ -0,0 +1,23 @@ +/* + * cblas_idamax.c + * + * The program is a C interface to idamax. + * It calls the fortran wrapper before calling idamax. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +CBLAS_INDEX cblas_idamax( const int N, const double *X, const int incX) +{ + int iamax; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_idamax_sub( &F77_N, X, &F77_incX, &iamax); + return iamax ? iamax-1 : 0; +} diff --git a/cblas/src/cblas_isamax.c b/cblas/src/cblas_isamax.c new file mode 100644 index 00000000..bfd74e8f --- /dev/null +++ b/cblas/src/cblas_isamax.c @@ -0,0 +1,23 @@ +/* + * cblas_isamax.c + * + * The program is a C interface to isamax. + * It calls the fortran wrapper before calling isamax. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +CBLAS_INDEX cblas_isamax( const int N, const float *X, const int incX) +{ + int iamax; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_isamax_sub( &F77_N, X, &F77_incX, &iamax); + return iamax ? iamax-1 : 0; +} diff --git a/cblas/src/cblas_izamax.c b/cblas/src/cblas_izamax.c new file mode 100644 index 00000000..21fdc396 --- /dev/null +++ b/cblas/src/cblas_izamax.c @@ -0,0 +1,23 @@ +/* + * cblas_izamax.c + * + * The program is a C interface to izamax. + * It calls the fortran wrapper before calling izamax. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +CBLAS_INDEX cblas_izamax( const int N, const void *X, const int incX) +{ + int iamax; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_izamax_sub( &F77_N, X, &F77_incX, &iamax); + return (iamax ? iamax-1 : 0); +} diff --git a/cblas/src/cblas_sasum.c b/cblas/src/cblas_sasum.c new file mode 100644 index 00000000..7d4c32cf --- /dev/null +++ b/cblas/src/cblas_sasum.c @@ -0,0 +1,23 @@ +/* + * cblas_sasum.c + * + * The program is a C interface to sasum. + * It calls the fortran wrapper before calling sasum. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +float cblas_sasum( const int N, const float *X, const int incX) +{ + float asum; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_sasum_sub( &F77_N, X, &F77_incX, &asum); + return asum; +} diff --git a/cblas/src/cblas_saxpy.c b/cblas/src/cblas_saxpy.c new file mode 100644 index 00000000..2eee8e06 --- /dev/null +++ b/cblas/src/cblas_saxpy.c @@ -0,0 +1,23 @@ +/* + * cblas_saxpy.c + * + * The program is a C interface to saxpy. + * It calls the fortran wrapper before calling saxpy. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_saxpy( const int N, const float alpha, const float *X, + const int incX, float *Y, const int incY) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_saxpy( &F77_N, &alpha, X, &F77_incX, Y, &F77_incY); +} diff --git a/cblas/src/cblas_scasum.c b/cblas/src/cblas_scasum.c new file mode 100644 index 00000000..e1fa5309 --- /dev/null +++ b/cblas/src/cblas_scasum.c @@ -0,0 +1,23 @@ +/* + * cblas_scasum.c + * + * The program is a C interface to scasum. + * It calls the fortran wrapper before calling scasum. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +float cblas_scasum( const int N, const void *X, const int incX) +{ + float asum; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_scasum_sub( &F77_N, X, &F77_incX, &asum); + return asum; +} diff --git a/cblas/src/cblas_scnrm2.c b/cblas/src/cblas_scnrm2.c new file mode 100644 index 00000000..fa48454e --- /dev/null +++ b/cblas/src/cblas_scnrm2.c @@ -0,0 +1,23 @@ +/* + * cblas_scnrm2.c + * + * The program is a C interface to scnrm2. + * It calls the fortran wrapper before calling scnrm2. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +float cblas_scnrm2( const int N, const void *X, const int incX) +{ + float nrm2; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_scnrm2_sub( &F77_N, X, &F77_incX, &nrm2); + return nrm2; +} diff --git a/cblas/src/cblas_scopy.c b/cblas/src/cblas_scopy.c new file mode 100644 index 00000000..7796959f --- /dev/null +++ b/cblas/src/cblas_scopy.c @@ -0,0 +1,22 @@ +/* + * cblas_scopy.c + * + * The program is a C interface to scopy. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_scopy( const int N, const float *X, + const int incX, float *Y, const int incY) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_scopy( &F77_N, X, &F77_incX, Y, &F77_incY); +} diff --git a/cblas/src/cblas_sdot.c b/cblas/src/cblas_sdot.c new file mode 100644 index 00000000..baf85927 --- /dev/null +++ b/cblas/src/cblas_sdot.c @@ -0,0 +1,25 @@ +/* + * cblas_sdot.c + * + * The program is a C interface to sdot. + * It calls the fortran wrapper before calling sdot. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +float cblas_sdot( const int N, const float *X, + const int incX, const float *Y, const int incY) +{ + float dot; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_sdot_sub( &F77_N, X, &F77_incX, Y, &F77_incY, &dot); + return dot; +} diff --git a/cblas/src/cblas_sdsdot.c b/cblas/src/cblas_sdsdot.c new file mode 100644 index 00000000..b824849b --- /dev/null +++ b/cblas/src/cblas_sdsdot.c @@ -0,0 +1,25 @@ +/* + * cblas_sdsdot.c + * + * The program is a C interface to sdsdot. + * It calls the fortran wrapper before calling sdsdot. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +float cblas_sdsdot( const int N, const float alpha, const float *X, + const int incX, const float *Y, const int incY) +{ + float dot; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_sdsdot_sub( &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, &dot); + return dot; +} diff --git a/cblas/src/cblas_sgbmv.c b/cblas/src/cblas_sgbmv.c new file mode 100644 index 00000000..30f9311f --- /dev/null +++ b/cblas/src/cblas_sgbmv.c @@ -0,0 +1,83 @@ +/* + * + * cblas_sgbmv.c + * This program is a C interface to sgbmv. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_sgbmv(const CBLAS_LAYOUT layout, + const CBLAS_TRANSPOSE TransA, const int M, const int N, + const int KL, const int KU, + const float alpha, const float *A, const int lda, + const float *X, const int incX, const float beta, + float *Y, const int incY) +{ + char TA; +#ifdef F77_CHAR + F77_CHAR F77_TA; +#else + #define F77_TA &TA +#endif +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; + F77_INT F77_KL=KL,F77_KU=KU; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_KL KL + #define F77_KU KU + #define F77_incX incX + #define F77_incY incY +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(2, "cblas_sgbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + F77_sgbmv(F77_TA, &F77_M, &F77_N, &F77_KL, &F77_KU, &alpha, + A, &F77_lda, X, &F77_incX, &beta, Y, &F77_incY); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(2, "cblas_sgbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + F77_sgbmv(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, &alpha, + A ,&F77_lda, X, &F77_incX, &beta, Y, &F77_incY); + } + else cblas_xerbla(1, "cblas_sgbmv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_sgemm.c b/cblas/src/cblas_sgemm.c new file mode 100644 index 00000000..c7f7673c --- /dev/null +++ b/cblas/src/cblas_sgemm.c @@ -0,0 +1,110 @@ +/* + * + * cblas_sgemm.c + * This program is a C interface to sgemm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_sgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, + const CBLAS_TRANSPOSE TransB, const int M, const int N, + const int K, const float alpha, const float *A, + const int lda, const float *B, const int ldb, + const float beta, float *C, const int ldc) +{ + char TA, TB; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_TB; +#else + #define F77_TA &TA + #define F77_TB &TB +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_M M + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + if( layout == CblasColMajor ) + { + if(TransA == CblasTrans) TA='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(2, "cblas_sgemm", + "Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if(TransB == CblasTrans) TB='T'; + else if ( TransB == CblasConjTrans ) TB='C'; + else if ( TransB == CblasNoTrans ) TB='N'; + else + { + cblas_xerbla(3, "cblas_sgemm", + "Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + #endif + + F77_sgemm(F77_TA, F77_TB, &F77_M, &F77_N, &F77_K, &alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if(TransA == CblasTrans) TB='T'; + else if ( TransA == CblasConjTrans ) TB='C'; + else if ( TransA == CblasNoTrans ) TB='N'; + else + { + cblas_xerbla(2, "cblas_sgemm", + "Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(TransB == CblasTrans) TA='T'; + else if ( TransB == CblasConjTrans ) TA='C'; + else if ( TransB == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(2, "cblas_sgemm", + "Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + #endif + + F77_sgemm(F77_TA, F77_TB, &F77_N, &F77_M, &F77_K, &alpha, B, &F77_ldb, A, &F77_lda, &beta, C, &F77_ldc); + } else + cblas_xerbla(1, "cblas_sgemm", + "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; +} diff --git a/cblas/src/cblas_sgemv.c b/cblas/src/cblas_sgemv.c new file mode 100644 index 00000000..64a7c1e9 --- /dev/null +++ b/cblas/src/cblas_sgemv.c @@ -0,0 +1,78 @@ +/* + * + * cblas_sgemv.c + * This program is a C interface to sgemv. + * Written by Keita Teranishi + * 4/6/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_sgemv(const CBLAS_LAYOUT layout, + const CBLAS_TRANSPOSE TransA, const int M, const int N, + const float alpha, const float *A, const int lda, + const float *X, const int incX, const float beta, + float *Y, const int incY) +{ + char TA; +#ifdef F77_CHAR + F77_CHAR F77_TA; +#else + #define F77_TA &TA +#endif +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_incX incX + #define F77_incY incY +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(2, "cblas_sgemv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + F77_sgemv(F77_TA, &F77_M, &F77_N, &alpha, A, &F77_lda, X, &F77_incX, + &beta, Y, &F77_incY); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(2, "cblas_sgemv", "Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + F77_sgemv(F77_TA, &F77_N, &F77_M, &alpha, A, &F77_lda, X, + &F77_incX, &beta, Y, &F77_incY); + } + else cblas_xerbla(1, "cblas_sgemv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_sger.c b/cblas/src/cblas_sger.c new file mode 100644 index 00000000..40f09f92 --- /dev/null +++ b/cblas/src/cblas_sger.c @@ -0,0 +1,46 @@ +/* + * + * cblas_sger.c + * This program is a C interface to sger. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_sger(const CBLAS_LAYOUT layout, const int M, const int N, + const float alpha, const float *X, const int incX, + const float *Y, const int incY, float *A, const int lda) +{ +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_M M + #define F77_N N + #define F77_incX incX + #define F77_incY incY + #define F77_lda lda +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + F77_sger( &F77_M, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, + &F77_lda); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + F77_sger( &F77_N, &F77_M, &alpha, Y, &F77_incY, X, &F77_incX, A, + &F77_lda); + } + else cblas_xerbla(1, "cblas_sger", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_snrm2.c b/cblas/src/cblas_snrm2.c new file mode 100644 index 00000000..18161b4f --- /dev/null +++ b/cblas/src/cblas_snrm2.c @@ -0,0 +1,23 @@ +/* + * cblas_snrm2.c + * + * The program is a C interface to snrm2. + * It calls the fortran wrapper before calling snrm2. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +float cblas_snrm2( const int N, const float *X, const int incX) +{ + float nrm2; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_snrm2_sub( &F77_N, X, &F77_incX, &nrm2); + return nrm2; +} diff --git a/cblas/src/cblas_srot.c b/cblas/src/cblas_srot.c new file mode 100644 index 00000000..cbd1c8c9 --- /dev/null +++ b/cblas/src/cblas_srot.c @@ -0,0 +1,22 @@ +/* + * cblas_srot.c + * + * The program is a C interface to srot. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_srot( const int N, float *X, const int incX, float *Y, + const int incY, const float c, const float s) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_srot(&F77_N, X, &F77_incX, Y, &F77_incY, &c, &s); +} diff --git a/cblas/src/cblas_srotg.c b/cblas/src/cblas_srotg.c new file mode 100644 index 00000000..f6460048 --- /dev/null +++ b/cblas/src/cblas_srotg.c @@ -0,0 +1,14 @@ +/* + * cblas_srotg.c + * + * The program is a C interface to srotg. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_srotg( float *a, float *b, float *c, float *s) +{ + F77_srotg(a,b,c,s); +} diff --git a/cblas/src/cblas_srotm.c b/cblas/src/cblas_srotm.c new file mode 100644 index 00000000..49674645 --- /dev/null +++ b/cblas/src/cblas_srotm.c @@ -0,0 +1,22 @@ +/* + * cblas_srotm.c + * + * The program is a C interface to srotm. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_srotm( const int N, float *X, const int incX, float *Y, + const int incY, const float *P) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_srotm( &F77_N, X, &F77_incX, Y, &F77_incY, P); +} diff --git a/cblas/src/cblas_srotmg.c b/cblas/src/cblas_srotmg.c new file mode 100644 index 00000000..04f978b4 --- /dev/null +++ b/cblas/src/cblas_srotmg.c @@ -0,0 +1,15 @@ +/* + * cblas_srotmg.c + * + * The program is a C interface to srotmg. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_srotmg( float *d1, float *d2, float *b1, + const float b2, float *p) +{ + F77_srotmg(d1,d2,b1,&b2,p); +} diff --git a/cblas/src/cblas_ssbmv.c b/cblas/src/cblas_ssbmv.c new file mode 100644 index 00000000..055d94e9 --- /dev/null +++ b/cblas/src/cblas_ssbmv.c @@ -0,0 +1,76 @@ +/* + * + * cblas_ssbmv.c + * This program is a C interface to ssbmv. + * Written by Keita Teranishi + * 4/6/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ssbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const int N, const int K, const float alpha, const float *A, + const int lda, const float *X, const int incX, + const float beta, float *Y, const int incY) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_incX incX + #define F77_incY incY +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ssbmv","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_ssbmv(F77_UL, &F77_N, &F77_K, &alpha, A, &F77_lda, X, + &F77_incX, &beta, Y, &F77_incY); + }else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ssbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_ssbmv(F77_UL, &F77_N, &F77_K, &alpha, A, &F77_lda, X, + &F77_incX, &beta, Y, &F77_incY); + } + else cblas_xerbla(1, "cblas_ssbmv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_sscal.c b/cblas/src/cblas_sscal.c new file mode 100644 index 00000000..1f09abe7 --- /dev/null +++ b/cblas/src/cblas_sscal.c @@ -0,0 +1,21 @@ +/* + * cblas_sscal.c + * + * The program is a C interface to sscal. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_sscal( const int N, const float alpha, float *X, + const int incX) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_sscal( &F77_N, &alpha, X, &F77_incX); +} diff --git a/cblas/src/cblas_sspmv.c b/cblas/src/cblas_sspmv.c new file mode 100644 index 00000000..93ef0697 --- /dev/null +++ b/cblas/src/cblas_sspmv.c @@ -0,0 +1,73 @@ +/* + * + * cblas_sspmv.c + * This program is a C interface to sspmv. + * Written by Keita Teranishi + * 4/6/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_sspmv(const CBLAS_LAYOUT layout, + const CBLAS_UPLO Uplo, const int N, + const float alpha, const float *AP, + const float *X, const int incX, const float beta, + float *Y, const int incY) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_sspmv","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_sspmv(F77_UL, &F77_N, &alpha, AP, X, + &F77_incX, &beta, Y, &F77_incY); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_sspmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_sspmv(F77_UL, &F77_N, &alpha, + AP, X,&F77_incX, &beta, Y, &F77_incY); + } + else cblas_xerbla(1, "cblas_sspmv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; +} diff --git a/cblas/src/cblas_sspr.c b/cblas/src/cblas_sspr.c new file mode 100644 index 00000000..0464dcd6 --- /dev/null +++ b/cblas/src/cblas_sspr.c @@ -0,0 +1,72 @@ +/* + * + * cblas_sspr.c + * This program is a C interface to sspr. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_sspr(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const int N, const float alpha, const float *X, + const int incX, float *Ap) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_sspr","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_sspr(F77_UL, &F77_N, &alpha, X, &F77_incX, Ap); + + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasLower) UL = 'U'; + else if (Uplo == CblasUpper) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_sspr","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_sspr(F77_UL, &F77_N, &alpha, X, &F77_incX, Ap); + } else cblas_xerbla(1, "cblas_sspr", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_sspr2.c b/cblas/src/cblas_sspr2.c new file mode 100644 index 00000000..0bf5cc61 --- /dev/null +++ b/cblas/src/cblas_sspr2.c @@ -0,0 +1,71 @@ +/* + * + * cblas_sspr2.c + * This program is a C interface to sspr2. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_sspr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const int N, const float alpha, const float *X, + const int incX, const float *Y, const int incY, float *A) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_sspr2","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_sspr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A); + + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasLower) UL = 'U'; + else if (Uplo == CblasUpper) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_sspr2","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_sspr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A); + } else cblas_xerbla(1, "cblas_sspr2", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; +} diff --git a/cblas/src/cblas_sswap.c b/cblas/src/cblas_sswap.c new file mode 100644 index 00000000..b74d8469 --- /dev/null +++ b/cblas/src/cblas_sswap.c @@ -0,0 +1,22 @@ +/* + * cblas_sswap.c + * + * The program is a C interface to sswap. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_sswap( const int N, float *X, const int incX, float *Y, + const int incY) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_sswap( &F77_N, X, &F77_incX, Y, &F77_incY); +} diff --git a/cblas/src/cblas_ssymm.c b/cblas/src/cblas_ssymm.c new file mode 100644 index 00000000..1b0bd966 --- /dev/null +++ b/cblas/src/cblas_ssymm.c @@ -0,0 +1,108 @@ +/* + * + * cblas_ssymm.c + * This program is a C interface to ssymm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ssymm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const int M, const int N, + const float alpha, const float *A, const int lda, + const float *B, const int ldb, const float beta, + float *C, const int ldc) +{ + char SD, UL; +#ifdef F77_CHAR + F77_CHAR F77_SD, F77_UL; +#else + #define F77_SD &SD + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + if( Side == CblasRight) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + cblas_xerbla(2, "cblas_ssymm", + "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(3, "cblas_ssymm", + "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_ssymm(F77_SD, F77_UL, &F77_M, &F77_N, &alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if( Side == CblasRight) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + cblas_xerbla(2, "cblas_ssymm", + "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_ssymm", + "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_ssymm(F77_SD, F77_UL, &F77_N, &F77_M, &alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + } else cblas_xerbla(1, "cblas_ssymm", + "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_ssymv.c b/cblas/src/cblas_ssymv.c new file mode 100644 index 00000000..84b9eecb --- /dev/null +++ b/cblas/src/cblas_ssymv.c @@ -0,0 +1,76 @@ +/* + * + * cblas_ssymv.c + * This program is a C interface to ssymv. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ssymv(const CBLAS_LAYOUT layout, + const CBLAS_UPLO Uplo, const int N, + const float alpha, const float *A, const int lda, + const float *X, const int incX, const float beta, + float *Y, const int incY) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incX + #define F77_incY incY +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ssymv","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_ssymv(F77_UL, &F77_N, &alpha, A, &F77_lda, X, + &F77_incX, &beta, Y, &F77_incY); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ssymv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_ssymv(F77_UL, &F77_N, &alpha, + A ,&F77_lda, X,&F77_incX, &beta, Y, &F77_incY); + } + else cblas_xerbla(1, "cblas_ssymv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_ssyr.c b/cblas/src/cblas_ssyr.c new file mode 100644 index 00000000..d197fdcd --- /dev/null +++ b/cblas/src/cblas_ssyr.c @@ -0,0 +1,70 @@ +/* + * + * cblas_ssyr.c + * This program is a C interface to ssyr. + * Written by Keita Teranishi + * 4/6/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ssyr(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const int N, const float alpha, const float *X, + const int incX, float *A, const int lda) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_lda=lda; +#else + #define F77_N N + #define F77_incX incX + #define F77_lda lda +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ssyr","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_ssyr(F77_UL, &F77_N, &alpha, X, &F77_incX, A, &F77_lda); + + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasLower) UL = 'U'; + else if (Uplo == CblasUpper) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ssyr","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_ssyr(F77_UL, &F77_N, &alpha, X, &F77_incX, A, &F77_lda); + } else cblas_xerbla(1, "cblas_ssyr", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_ssyr2.c b/cblas/src/cblas_ssyr2.c new file mode 100644 index 00000000..bf2b5c88 --- /dev/null +++ b/cblas/src/cblas_ssyr2.c @@ -0,0 +1,76 @@ +/* + * + * cblas_ssyr2.c + * This program is a C interface to ssyr2. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ssyr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const int N, const float alpha, const float *X, + const int incX, const float *Y, const int incY, float *A, + const int lda) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY, F77__lda=lda; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY + #define F77_lda lda +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ssyr2","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_ssyr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, + &F77_lda); + + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasLower) UL = 'U'; + else if (Uplo == CblasUpper) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ssyr2","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_ssyr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, + &F77_lda); + } else cblas_xerbla(1, "cblas_ssyr2", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_ssyr2k.c b/cblas/src/cblas_ssyr2k.c new file mode 100644 index 00000000..d4371103 --- /dev/null +++ b/cblas/src/cblas_ssyr2k.c @@ -0,0 +1,111 @@ +/* + * + * cblas_ssyr2k.c + * This program is a C interface to ssyr2k. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ssyr2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE Trans, const int N, const int K, + const float alpha, const float *A, const int lda, + const float *B, const int ldb, const float beta, + float *C, const int ldc) +{ + char UL, TR; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL; +#else + #define F77_TR &TR + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(2, "cblas_ssyr2k", + "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Trans == CblasTrans) TR ='T'; + else if ( Trans == CblasConjTrans ) TR='C'; + else if ( Trans == CblasNoTrans ) TR='N'; + else + { + cblas_xerbla(3, "cblas_ssyr2k", + "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_ssyr2k(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_ssyr2k", + "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Trans == CblasTrans) TR ='N'; + else if ( Trans == CblasConjTrans ) TR='N'; + else if ( Trans == CblasNoTrans ) TR='T'; + else + { + cblas_xerbla(3, "cblas_ssyr2k", + "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_ssyr2k(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + } else cblas_xerbla(1, "cblas_ssyr2k", + "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_ssyrk.c b/cblas/src/cblas_ssyrk.c new file mode 100644 index 00000000..02960da8 --- /dev/null +++ b/cblas/src/cblas_ssyrk.c @@ -0,0 +1,110 @@ +/* + * + * cblas_ssyrk.c + * This program is a C interface to ssyrk. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ssyrk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE Trans, const int N, const int K, + const float alpha, const float *A, const int lda, + const float beta, float *C, const int ldc) +{ + char UL, TR; +#ifdef F77_CHAR + F77_CHAR F77_TR, F77_UL; +#else + #define F77_TR &TR + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(2, "cblas_ssyrk", + "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Trans == CblasTrans) TR ='T'; + else if ( Trans == CblasConjTrans ) TR='C'; + else if ( Trans == CblasNoTrans ) TR='N'; + else + { + cblas_xerbla(3, "cblas_ssyrk", + "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_ssyrk(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, &beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_ssyrk", + "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Trans == CblasTrans) TR ='N'; + else if ( Trans == CblasConjTrans ) TR='N'; + else if ( Trans == CblasNoTrans ) TR='T'; + else + { + cblas_xerbla(3, "cblas_ssyrk", + "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_ssyrk(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, &beta, C, &F77_ldc); + } else cblas_xerbla(1, "cblas_ssyrk", + "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} + diff --git a/cblas/src/cblas_stbmv.c b/cblas/src/cblas_stbmv.c new file mode 100644 index 00000000..80c18a26 --- /dev/null +++ b/cblas/src/cblas_stbmv.c @@ -0,0 +1,122 @@ +/* + * cblas_stbmv.c + * This program is a C interface to stbmv. + * Written by Keita Teranishi + * 3/3/1998 + */ +#include "cblas.h" +#include "cblas_f77.h" + +void cblas_stbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const int K, const float *A, const int lda, + float *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_K=K, F77_incX=incX; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_incX incX +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_stbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_stbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_stbmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_stbmv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_stbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(3, "cblas_stbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_stbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_stbmv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + } + else cblas_xerbla(1, "cblas_stbmv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_stbsv.c b/cblas/src/cblas_stbsv.c new file mode 100644 index 00000000..55850221 --- /dev/null +++ b/cblas/src/cblas_stbsv.c @@ -0,0 +1,122 @@ +/* + * cblas_stbsv.c + * The program is a C interface to stbsv. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_stbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const int K, const float *A, const int lda, + float *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_K=K, F77_incX=incX; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_incX incX +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_stbsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_stbsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_stbsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_stbsv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_stbsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(3, "cblas_stbsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_stbsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_stbsv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + } + else cblas_xerbla(1, "cblas_stbsv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_stpmv.c b/cblas/src/cblas_stpmv.c new file mode 100644 index 00000000..b8dfe896 --- /dev/null +++ b/cblas/src/cblas_stpmv.c @@ -0,0 +1,118 @@ +/* + * + * cblas_stpmv.c + * This program is a C interface to stpmv. + * Written by Keita Teranishi + * 4/6/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_stpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const float *Ap, float *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_stpmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_stpmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_stpmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_stpmv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X, &F77_incX); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_stpmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(3, "cblas_stpmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_stpmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_stpmv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X,&F77_incX); + } + else cblas_xerbla(1, "cblas_stpmv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_stpsv.c b/cblas/src/cblas_stpsv.c new file mode 100644 index 00000000..2073a2c7 --- /dev/null +++ b/cblas/src/cblas_stpsv.c @@ -0,0 +1,118 @@ +/* + * cblas_stpsv.c + * The program is a C interface to stpsv. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_stpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const float *Ap, float *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_stpsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_stpsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_stpsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_stpsv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X, &F77_incX); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_stpsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(3, "cblas_stpsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_stpsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_stpsv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X,&F77_incX); + + } + else cblas_xerbla(1, "cblas_stpsv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_strmm.c b/cblas/src/cblas_strmm.c new file mode 100644 index 00000000..6ed4a128 --- /dev/null +++ b/cblas/src/cblas_strmm.c @@ -0,0 +1,148 @@ +/* + * + * cblas_strmm.c + * This program is a C interface to strmm. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_strmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, + const CBLAS_DIAG Diag, const int M, const int N, + const float alpha, const float *A, const int lda, + float *B, const int ldb) +{ + char UL, TA, SD, DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_SD, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_SD &SD + #define F77_DI &DI +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + if( Side == CblasRight) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + cblas_xerbla(2, "cblas_strmm","Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(3, "cblas_strmm","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( TransA == CblasTrans) TA ='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_strmm","Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit ) DI='N'; + else + { + cblas_xerbla(5, "cblas_strmm", "Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_strmm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_M, &F77_N, &alpha, A, &F77_lda, B, &F77_ldb); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if( Side == CblasRight) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + cblas_xerbla(2, "cblas_strmm","Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_strmm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( TransA == CblasTrans) TA ='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_strmm", "Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit ) DI='N'; + else + { + cblas_xerbla(5, "cblas_strmm","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } +#ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); +#endif + F77_strmm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_N, &F77_M, &alpha, A, + &F77_lda, B, &F77_ldb); + } + else cblas_xerbla(1, "cblas_strmm", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_strmv.c b/cblas/src/cblas_strmv.c new file mode 100644 index 00000000..652659db --- /dev/null +++ b/cblas/src/cblas_strmv.c @@ -0,0 +1,122 @@ +/* + * + * cblas_strmv.c + * This program is a C interface to strmv. + * Written by Keita Teranishi + * 4/6/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_strmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const float *A, const int lda, + float *X, const int incX) + +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incX +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_strmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_strmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_strmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_strmv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_strmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(3, "cblas_strmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_strmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_strmv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + } + else cblas_xerbla(1, "cblas_strmv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_strsm.c b/cblas/src/cblas_strsm.c new file mode 100644 index 00000000..6199fcbe --- /dev/null +++ b/cblas/src/cblas_strsm.c @@ -0,0 +1,143 @@ +/* + * + * cblas_strsm.c + * This program is a C interface to strsm. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_strsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, + const CBLAS_DIAG Diag, const int M, const int N, + const float alpha, const float *A, const int lda, + float *B, const int ldb) + +{ + char UL, TA, SD, DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_SD, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_SD &SD + #define F77_DI &DI +#endif + +#ifdef F77_INT + F77_INT F77_N=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + if( Side == CblasRight) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + cblas_xerbla(2, "cblas_strsm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(3, "cblas_strsm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( TransA == CblasTrans) TA ='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_strsm", "Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit ) DI='N'; + else + { + cblas_xerbla(5, "cblas_strsm", "Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_strsm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_M, &F77_N, &alpha, A, &F77_lda, B, &F77_ldb); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if( Side == CblasRight) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + cblas_xerbla(2, "cblas_strsm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_strsm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( TransA == CblasTrans) TA ='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_strsm", "Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit ) DI='N'; + else + { + cblas_xerbla(5, "cblas_strsm", "Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_strsm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_N, &F77_M, &alpha, A, &F77_lda, B, &F77_ldb); + } + else cblas_xerbla(1, "cblas_strsm", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_strsv.c b/cblas/src/cblas_strsv.c new file mode 100644 index 00000000..6a2768b7 --- /dev/null +++ b/cblas/src/cblas_strsv.c @@ -0,0 +1,121 @@ +/* + * cblas_strsv.c + * The program is a C interface to strsv. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_strsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const float *A, const int lda, float *X, + const int incX) + +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incX +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_strsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_strsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_strsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_strsv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_strsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(3, "cblas_strsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_strsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_strsv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + } + else cblas_xerbla(1, "cblas_strsv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_xerbla.c b/cblas/src/cblas_xerbla.c new file mode 100644 index 00000000..3a2bfe6e --- /dev/null +++ b/cblas/src/cblas_xerbla.c @@ -0,0 +1,68 @@ +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include <stdarg.h> +#include "cblas.h" +#include "cblas_f77.h" + +void cblas_xerbla(int info, const char *rout, const char *form, ...) +{ + extern int RowMajorStrg; + char empty[1] = ""; + va_list argptr; + + va_start(argptr, form); + + if (RowMajorStrg) + { + if (strstr(rout,"gemm") != 0) + { + if (info == 5 ) info = 4; + else if (info == 4 ) info = 5; + else if (info == 11) info = 9; + else if (info == 9 ) info = 11; + } + else if (strstr(rout,"symm") != 0 || strstr(rout,"hemm") != 0) + { + if (info == 5 ) info = 4; + else if (info == 4 ) info = 5; + } + else if (strstr(rout,"trmm") != 0 || strstr(rout,"trsm") != 0) + { + if (info == 7 ) info = 6; + else if (info == 6 ) info = 7; + } + else if (strstr(rout,"gemv") != 0) + { + if (info == 4) info = 3; + else if (info == 3) info = 4; + } + else if (strstr(rout,"gbmv") != 0) + { + if (info == 4) info = 3; + else if (info == 3) info = 4; + else if (info == 6) info = 5; + else if (info == 5) info = 6; + } + else if (strstr(rout,"ger") != 0) + { + if (info == 3) info = 2; + else if (info == 2) info = 3; + else if (info == 8) info = 6; + else if (info == 6) info = 8; + } + else if ( (strstr(rout,"her2") != 0 || strstr(rout,"hpr2") != 0) + && strstr(rout,"her2k") == 0 ) + { + if (info == 8) info = 6; + else if (info == 6) info = 8; + } + } + if (info) + fprintf(stderr, "Parameter %d to routine %s was incorrect\n", info, rout); + vfprintf(stderr, form, argptr); + va_end(argptr); + if (info && !info) + F77_xerbla(empty, &info); /* Force link of our F77 error handler */ + exit(-1); +} diff --git a/cblas/src/cblas_zaxpy.c b/cblas/src/cblas_zaxpy.c new file mode 100644 index 00000000..f63c4c39 --- /dev/null +++ b/cblas/src/cblas_zaxpy.c @@ -0,0 +1,22 @@ +/* + * cblas_zaxpy.c + * + * The program is a C interface to zaxpy. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zaxpy( const int N, const void *alpha, const void *X, + const int incX, void *Y, const int incY) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_zaxpy( &F77_N, alpha, X, &F77_incX, Y, &F77_incY); +} diff --git a/cblas/src/cblas_zcopy.c b/cblas/src/cblas_zcopy.c new file mode 100644 index 00000000..a16be28e --- /dev/null +++ b/cblas/src/cblas_zcopy.c @@ -0,0 +1,22 @@ +/* + * cblas_zcopy.c + * + * The program is a C interface to zcopy. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zcopy( const int N, const void *X, + const int incX, void *Y, const int incY) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_zcopy( &F77_N, X, &F77_incX, Y, &F77_incY); +} diff --git a/cblas/src/cblas_zdotc_sub.c b/cblas/src/cblas_zdotc_sub.c new file mode 100644 index 00000000..29dec6c5 --- /dev/null +++ b/cblas/src/cblas_zdotc_sub.c @@ -0,0 +1,24 @@ +/* + * cblas_zdotc_sub.c + * + * The program is a C interface to zdotc. + * It calls the fortran wrapper before calling zdotc. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zdotc_sub( const int N, const void *X, const int incX, + const void *Y, const int incY, void *dotc) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_zdotc_sub( &F77_N, X, &F77_incX, Y, &F77_incY, dotc); + return; +} diff --git a/cblas/src/cblas_zdotu_sub.c b/cblas/src/cblas_zdotu_sub.c new file mode 100644 index 00000000..48a14bf3 --- /dev/null +++ b/cblas/src/cblas_zdotu_sub.c @@ -0,0 +1,24 @@ +/* + * cblas_zdotu_sub.c + * + * The program is a C interface to zdotu. + * It calls the fortran wrapper before calling zdotu. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zdotu_sub( const int N, const void *X, const int incX, + const void *Y, const int incY, void *dotu) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_zdotu_sub( &F77_N, X, &F77_incX, Y, &F77_incY, dotu); + return; +} diff --git a/cblas/src/cblas_zdscal.c b/cblas/src/cblas_zdscal.c new file mode 100644 index 00000000..788365be --- /dev/null +++ b/cblas/src/cblas_zdscal.c @@ -0,0 +1,21 @@ +/* + * cblas_zdscal.c + * + * The program is a C interface to zdscal. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zdscal( const int N, const double alpha, void *X, + const int incX) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_zdscal( &F77_N, &alpha, X, &F77_incX); +} diff --git a/cblas/src/cblas_zgbmv.c b/cblas/src/cblas_zgbmv.c new file mode 100644 index 00000000..f4dd485c --- /dev/null +++ b/cblas/src/cblas_zgbmv.c @@ -0,0 +1,166 @@ +/* + * cblas_zgbmv.c + * The program is a C interface of zgbmv + * + * Keita Teranishi 5/20/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zgbmv(const CBLAS_LAYOUT layout, + const CBLAS_TRANSPOSE TransA, const int M, const int N, + const int KL, const int KU, + const void *alpha, const void *A, const int lda, + const void *X, const int incX, const void *beta, + void *Y, const int incY) +{ + char TA; +#ifdef F77_CHAR + F77_CHAR F77_TA; +#else + #define F77_TA &TA +#endif +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; + F77_INT F77_KL=KL,F77_KU=KU; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_KL KL + #define F77_KU KU + #define F77_incX incx + #define F77_incY incY +#endif + int n, i=0, incx=incX; + const double *xx= (double *)X, *alp= (double *)alpha, *bet = (double *)beta; + double ALPHA[2],BETA[2]; + int tincY, tincx; + double *x=(double *)X, *y=(double *)Y, *st=0, *tx; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(2, "cblas_zgbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + F77_zgbmv(F77_TA, &F77_M, &F77_N, &F77_KL, &F77_KU, alpha, + A, &F77_lda, X, &F77_incX, beta, Y, &F77_incY); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + ALPHA[0]= *alp; + ALPHA[1]= -alp[1]; + BETA[0]= *bet; + BETA[1]= -bet[1]; + TA = 'N'; + if (M > 0) + { + n = M << 1; + x = malloc(n*sizeof(double)); + tx = x; + + if( incX > 0 ) { + i = incX << 1 ; + tincx = 2; + st= x+n; + } else { + i = incX *(-2); + tincx = -2; + st = x-2; + x +=(n-2); + } + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != st); + x=tx; + + #ifdef F77_INT + F77_incX = 1; + #else + incx = 1; + #endif + + if( incY > 0 ) + tincY = incY; + else + tincY = -incY; + + y++; + + if (N > 0) + { + i = tincY << 1; + n = i * N ; + st = y + n; + do { + *y = -(*y); + y += i; + } while(y != st); + y -= n; + } + } + else x = (double *) X; + + + } + else + { + cblas_xerbla(2, "cblas_zgbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + if (TransA == CblasConjTrans) + F77_zgbmv(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, ALPHA, + A ,&F77_lda, x,&F77_incX, BETA, Y, &F77_incY); + else + F77_zgbmv(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, alpha, + A ,&F77_lda, x,&F77_incX, beta, Y, &F77_incY); + if (TransA == CblasConjTrans) + { + if (x != X) free(x); + if (N > 0) + { + do + { + *y = -(*y); + y += i; + } + while (y != st); + } + } + } + else cblas_xerbla(1, "cblas_zgbmv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_zgemm.c b/cblas/src/cblas_zgemm.c new file mode 100644 index 00000000..7d4c3107 --- /dev/null +++ b/cblas/src/cblas_zgemm.c @@ -0,0 +1,109 @@ +/* + * + * cblas_zgemm.c + * This program is a C interface to zgemm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA, + const CBLAS_TRANSPOSE TransB, const int M, const int N, + const int K, const void *alpha, const void *A, + const int lda, const void *B, const int ldb, + const void *beta, void *C, const int ldc) +{ + char TA, TB; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_TB; +#else + #define F77_TA &TA + #define F77_TB &TB +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_M M + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + if(TransA == CblasTrans) TA='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(2, "cblas_zgemm","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if(TransB == CblasTrans) TB='T'; + else if ( TransB == CblasConjTrans ) TB='C'; + else if ( TransB == CblasNoTrans ) TB='N'; + else + { + cblas_xerbla(3, "cblas_zgemm","Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + #endif + + F77_zgemm(F77_TA, F77_TB, &F77_M, &F77_N, &F77_K, alpha, A, + &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if(TransA == CblasTrans) TB='T'; + else if ( TransA == CblasConjTrans ) TB='C'; + else if ( TransA == CblasNoTrans ) TB='N'; + else + { + cblas_xerbla(2, "cblas_zgemm","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(TransB == CblasTrans) TA='T'; + else if ( TransB == CblasConjTrans ) TA='C'; + else if ( TransB == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(2, "cblas_zgemm","Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + #endif + + F77_zgemm(F77_TA, F77_TB, &F77_N, &F77_M, &F77_K, alpha, B, + &F77_ldb, A, &F77_lda, beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_zgemm", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_zgemv.c b/cblas/src/cblas_zgemv.c new file mode 100644 index 00000000..e727380b --- /dev/null +++ b/cblas/src/cblas_zgemv.c @@ -0,0 +1,164 @@ +/* + * cblas_zgemv.c + * The program is a C interface of zgemv + * + * Keita Teranishi 5/20/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zgemv(const CBLAS_LAYOUT layout, + const CBLAS_TRANSPOSE TransA, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *X, const int incX, const void *beta, + void *Y, const int incY) +{ + char TA; +#ifdef F77_CHAR + F77_CHAR F77_TA; +#else + #define F77_TA &TA +#endif +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_incX incx + #define F77_incY incY +#endif + + int n, i=0, incx=incX; + const double *xx= (double *)X, *alp= (double *)alpha, *bet = (double *)beta; + double ALPHA[2],BETA[2]; + int tincY, tincx; + double *x=(double *)X, *y=(double *)Y, *st=0, *tx; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + + if (layout == CblasColMajor) + { + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(2, "cblas_zgemv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + F77_zgemv(F77_TA, &F77_M, &F77_N, alpha, A, &F77_lda, X, &F77_incX, + beta, Y, &F77_incY); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + ALPHA[0]= *alp; + ALPHA[1]= -alp[1]; + BETA[0]= *bet; + BETA[1]= -bet[1]; + TA = 'N'; + if (M > 0) + { + n = M << 1; + x = malloc(n*sizeof(double)); + tx = x; + if( incX > 0 ) { + i = incX << 1 ; + tincx = 2; + st= x+n; + } else { + i = incX *(-2); + tincx = -2; + st = x-2; + x +=(n-2); + } + + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != st); + x=tx; + + #ifdef F77_INT + F77_incX = 1; + #else + incx = 1; + #endif + + if(incY > 0) + tincY = incY; + else + tincY = -incY; + + y++; + + if (N > 0) + { + i = tincY << 1; + n = i * N ; + st = y + n; + do { + *y = -(*y); + y += i; + } while(y != st); + y -= n; + } + } + else x = (double *) X; + } + else + { + cblas_xerbla(2, "cblas_zgemv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + if (TransA == CblasConjTrans) + F77_zgemv(F77_TA, &F77_N, &F77_M, ALPHA, A, &F77_lda, x, + &F77_incX, BETA, Y, &F77_incY); + else + F77_zgemv(F77_TA, &F77_N, &F77_M, alpha, A, &F77_lda, x, + &F77_incX, beta, Y, &F77_incY); + + if (TransA == CblasConjTrans) + { + if (x != (double *)X) free(x); + if (N > 0) + { + do + { + *y = -(*y); + y += i; + } + while (y != st); + } + } + } + else cblas_xerbla(1, "cblas_zgemv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_zgerc.c b/cblas/src/cblas_zgerc.c new file mode 100644 index 00000000..7a4b4b02 --- /dev/null +++ b/cblas/src/cblas_zgerc.c @@ -0,0 +1,84 @@ +/* + * cblas_zgerc.c + * The program is a C interface to zgerc. + * + * Keita Teranishi 5/20/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zgerc(const CBLAS_LAYOUT layout, const int M, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda) +{ +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_M M + #define F77_N N + #define F77_incX incX + #define F77_incY incy + #define F77_lda lda +#endif + + int n, i, tincy, incy=incY; + double *y=(double *)Y, *yy=(double *)Y, *ty, *st; + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + F77_zgerc( &F77_M, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, A, + &F77_lda); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (N > 0) + { + n = N << 1; + y = malloc(n*sizeof(double)); + + ty = y; + if( incY > 0 ) { + i = incY << 1; + tincy = 2; + st= y+n; + } else { + i = incY *(-2); + tincy = -2; + st = y-2; + y +=(n-2); + } + do + { + *y = *yy; + y[1] = -yy[1]; + y += tincy ; + yy += i; + } + while (y != st); + y = ty; + + #ifdef F77_INT + F77_incY = 1; + #else + incy = 1; + #endif + } + else y = (double *) Y; + + F77_zgeru( &F77_N, &F77_M, alpha, y, &F77_incY, X, &F77_incX, A, + &F77_lda); + if(Y!=y) + free(y); + + } else cblas_xerbla(1, "cblas_zgerc", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_zgeru.c b/cblas/src/cblas_zgeru.c new file mode 100644 index 00000000..217acc0a --- /dev/null +++ b/cblas/src/cblas_zgeru.c @@ -0,0 +1,44 @@ +/* + * cblas_zgeru.c + * The program is a C interface to zgeru. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zgeru(const CBLAS_LAYOUT layout, const int M, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda) +{ +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_M M + #define F77_N N + #define F77_incX incX + #define F77_incY incY + #define F77_lda lda +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if (layout == CblasColMajor) + { + F77_zgeru( &F77_M, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, A, + &F77_lda); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + F77_zgeru( &F77_N, &F77_M, alpha, Y, &F77_incY, X, &F77_incX, A, + &F77_lda); + } + else cblas_xerbla(1, "cblas_zgeru", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_zhbmv.c b/cblas/src/cblas_zhbmv.c new file mode 100644 index 00000000..31c97801 --- /dev/null +++ b/cblas/src/cblas_zhbmv.c @@ -0,0 +1,159 @@ +/* + * cblas_zhbmv.c + * The program is a C interface to zhbmv + * + * Keita Teranishi 5/18/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +#include <stdio.h> +#include <stdlib.h> +void cblas_zhbmv(const CBLAS_LAYOUT layout, + const CBLAS_UPLO Uplo,const int N,const int K, + const void *alpha, const void *A, const int lda, + const void *X, const int incX, const void *beta, + void *Y, const int incY) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_incX incx + #define F77_incY incY +#endif + int n, i=0, incx=incX; + const double *xx= (double *)X, *alp= (double *)alpha, *bet = (double *)beta; + double ALPHA[2],BETA[2]; + int tincY, tincx; + double *x=(double *)X, *y=(double *)Y, *st=0, *tx; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_zhbmv","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_zhbmv(F77_UL, &F77_N, &F77_K, alpha, A, &F77_lda, X, + &F77_incX, beta, Y, &F77_incY); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + ALPHA[0]= *alp; + ALPHA[1]= -alp[1]; + BETA[0]= *bet; + BETA[1]= -bet[1]; + + if (N > 0) + { + n = N << 1; + x = malloc(n*sizeof(double)); + + tx = x; + if( incX > 0 ) { + i = incX << 1 ; + tincx = 2; + st= x+n; + } else { + i = incX *(-2); + tincx = -2; + st = x-2; + x +=(n-2); + } + + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != st); + x=tx; + + + #ifdef F77_INT + F77_incX = 1; + #else + incx = 1; + #endif + + if(incY > 0) + tincY = incY; + else + tincY = -incY; + y++; + + i = tincY << 1; + n = i * N ; + st = y + n; + do { + *y = -(*y); + y += i; + } while(y != st); + y -= n; + } else + x = (double *) X; + + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_zhbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_zhbmv(F77_UL, &F77_N, &F77_K, ALPHA, + A ,&F77_lda, x,&F77_incX, BETA, Y, &F77_incY); + } + else + { + cblas_xerbla(1, "cblas_zhbmv","Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if ( layout == CblasRowMajor ) + { + RowMajorStrg = 1; + if(X!=x) + free(x); + if (N > 0) + { + do + { + *y = -(*y); + y += i; + } + while (y != st); + } + } + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_zhemm.c b/cblas/src/cblas_zhemm.c new file mode 100644 index 00000000..43ed0ff8 --- /dev/null +++ b/cblas/src/cblas_zhemm.c @@ -0,0 +1,106 @@ +/* + * + * cblas_zhemm.c + * This program is a C interface to zhemm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zhemm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc) +{ + char SD, UL; +#ifdef F77_CHAR + F77_CHAR F77_SD, F77_UL; +#else + #define F77_SD &SD + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + if( Side == CblasRight) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + cblas_xerbla(2, "cblas_zhemm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(3, "cblas_zhemm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_zhemm(F77_SD, F77_UL, &F77_M, &F77_N, alpha, A, &F77_lda, + B, &F77_ldb, beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if( Side == CblasRight) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + cblas_xerbla(2, "cblas_zhemm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_zhemm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_zhemm(F77_SD, F77_UL, &F77_N, &F77_M, alpha, A, + &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_zhemm", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_zhemv.c b/cblas/src/cblas_zhemv.c new file mode 100644 index 00000000..436049e0 --- /dev/null +++ b/cblas/src/cblas_zhemv.c @@ -0,0 +1,160 @@ +/* + * cblas_zhemv.c + * The program is a C interface to zhemv + * + * Keita Teranishi 5/18/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zhemv(const CBLAS_LAYOUT layout, + const CBLAS_UPLO Uplo, const int N, + const void *alpha, const void *A, const int lda, + const void *X, const int incX, const void *beta, + void *Y, const int incY) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incx + #define F77_incY incY +#endif + int n, i=0, incx=incX; + const double *xx= (double *)X, *alp= (double *)alpha, *bet = (double *)beta; + double ALPHA[2],BETA[2]; + int tincY, tincx; + double *x=(double *)X, *y=(double *)Y, *st=0, *tx; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_zhemv","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_zhemv(F77_UL, &F77_N, alpha, A, &F77_lda, X, &F77_incX, + beta, Y, &F77_incY); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + ALPHA[0]= *alp; + ALPHA[1]= -alp[1]; + BETA[0]= *bet; + BETA[1]= -bet[1]; + + if (N > 0) + { + n = N << 1; + x = malloc(n*sizeof(double)); + + tx = x; + if( incX > 0 ) { + i = incX << 1 ; + tincx = 2; + st= x+n; + } else { + i = incX *(-2); + tincx = -2; + st = x-2; + x +=(n-2); + } + + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != st); + x=tx; + + + #ifdef F77_INT + F77_incX = 1; + #else + incx = 1; + #endif + + if(incY > 0) + tincY = incY; + else + tincY = -incY; + y++; + + i = tincY << 1; + n = i * N ; + st = y + n; + do { + *y = -(*y); + y += i; + } while(y != st); + y -= n; + } else + x = (double *) X; + + + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_zhemv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_zhemv(F77_UL, &F77_N, ALPHA, A, &F77_lda, x, &F77_incX, + BETA, Y, &F77_incY); + } + else + { + cblas_xerbla(1, "cblas_zhemv","Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if ( layout == CblasRowMajor ) + { + RowMajorStrg = 1; + if ( X != x ) + free(x); + if (N > 0) + { + do + { + *y = -(*y); + y += i; + } + while (y != st); + } + } + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_zher.c b/cblas/src/cblas_zher.c new file mode 100644 index 00000000..9ca09b09 --- /dev/null +++ b/cblas/src/cblas_zher.c @@ -0,0 +1,110 @@ +/* + * cblas_zher.c + * The program is a C interface to zher. + * + * Keita Teranishi 5/20/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zher(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const int N, const double alpha, const void *X, const int incX + ,void *A, const int lda) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incx +#endif + int n, i, tincx, incx=incX; + double *x=(double *)X, *xx=(double *)X, *tx, *st; + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_zher","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_zher(F77_UL, &F77_N, &alpha, X, &F77_incX, A, &F77_lda); + + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_zher","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + if (N > 0) + { + n = N << 1; + x = malloc(n*sizeof(double)); + tx = x; + if( incX > 0 ) { + i = incX << 1 ; + tincx = 2; + st= x+n; + } else { + i = incX *(-2); + tincx = -2; + st = x-2; + x +=(n-2); + } + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != st); + x=tx; + + #ifdef F77_INT + F77_incX = 1; + #else + incx = 1; + #endif + } + else x = (double *) X; + F77_zher(F77_UL, &F77_N, &alpha, x, &F77_incX, A, &F77_lda); + } else cblas_xerbla(1, "cblas_zher", "Illegal layout setting, %d\n", layout); + if(X!=x) + free(x); + + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_zher2.c b/cblas/src/cblas_zher2.c new file mode 100644 index 00000000..d575e9b2 --- /dev/null +++ b/cblas/src/cblas_zher2.c @@ -0,0 +1,153 @@ +/* + * cblas_zher2.c + * The program is a C interface to zher2. + * + * Keita Teranishi 3/23/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zher2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const int N, const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incx + #define F77_incY incy +#endif + int n, i, j, tincx, tincy, incx=incX, incy=incY; + double *x=(double *)X, *xx=(double *)X, *y=(double *)Y, + *yy=(double *)Y, *tx, *ty, *stx, *sty; + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_zher2", "Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_zher2(F77_UL, &F77_N, alpha, X, &F77_incX, + Y, &F77_incY, A, &F77_lda); + + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_zher2", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + if (N > 0) + { + n = N << 1; + x = malloc(n*sizeof(double)); + y = malloc(n*sizeof(double)); + tx = x; + ty = y; + if( incX > 0 ) { + i = incX << 1 ; + tincx = 2; + stx= x+n; + } else { + i = incX *(-2); + tincx = -2; + stx = x-2; + x +=(n-2); + } + + if( incY > 0 ) { + j = incY << 1; + tincy = 2; + sty= y+n; + } else { + j = incY *(-2); + tincy = -2; + sty = y-2; + y +=(n-2); + } + + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != stx); + + do + { + *y = *yy; + y[1] = -yy[1]; + y += tincy ; + yy += j; + } + while (y != sty); + + x=tx; + y=ty; + + #ifdef F77_INT + F77_incX = 1; + F77_incY = 1; + #else + incx = 1; + incy = 1; + #endif + } else + { + x = (double *) X; + y = (double *) Y; + } + F77_zher2(F77_UL, &F77_N, alpha, y, &F77_incY, x, + &F77_incX, A, &F77_lda); + } + else + { + cblas_xerbla(1, "cblas_zher2", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(X!=x) + free(x); + if(Y!=y) + free(y); + + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_zher2k.c b/cblas/src/cblas_zher2k.c new file mode 100644 index 00000000..482f8686 --- /dev/null +++ b/cblas/src/cblas_zher2k.c @@ -0,0 +1,110 @@ +/* + * + * cblas_zher2k.c + * This program is a C interface to zher2k. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zher2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const double beta, + void *C, const int ldc) +{ + char UL, TR; +#ifdef F77_CHAR + F77_CHAR F77_TR, F77_UL; +#else + #define F77_TR &TR + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + double ALPHA[2]; + const double *alp=(double *)alpha; + + CBLAS_CallFromC = 1; + RowMajorStrg = 0; + + if( layout == CblasColMajor ) + { + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(2, "cblas_zher2k", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Trans == CblasTrans) TR ='T'; + else if ( Trans == CblasConjTrans ) TR='C'; + else if ( Trans == CblasNoTrans ) TR='N'; + else + { + cblas_xerbla(3, "cblas_zher2k", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_zher2k(F77_UL, F77_TR, &F77_N, &F77_K, alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(2, "cblas_zher2k", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Trans == CblasTrans) TR ='N'; + else if ( Trans == CblasConjTrans ) TR='N'; + else if ( Trans == CblasNoTrans ) TR='C'; + else + { + cblas_xerbla(3, "cblas_zher2k", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + ALPHA[0]= *alp; + ALPHA[1]= -alp[1]; + F77_zher2k(F77_UL,F77_TR, &F77_N, &F77_K, ALPHA, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + } else cblas_xerbla(1, "cblas_zher2k", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_zherk.c b/cblas/src/cblas_zherk.c new file mode 100644 index 00000000..5a4171f2 --- /dev/null +++ b/cblas/src/cblas_zherk.c @@ -0,0 +1,105 @@ +/* + * + * cblas_zherk.c + * This program is a C interface to zherk. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zherk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE Trans, const int N, const int K, + const double alpha, const void *A, const int lda, + const double beta, void *C, const int ldc) +{ + char UL, TR; +#ifdef F77_CHAR + F77_CHAR F77_TR, F77_UL; +#else + #define F77_TR &TR + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(2, "cblas_zherk", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Trans == CblasTrans) TR ='T'; + else if ( Trans == CblasConjTrans ) TR='C'; + else if ( Trans == CblasNoTrans ) TR='N'; + else + { + cblas_xerbla(3, "cblas_zherk", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_zherk(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, + &beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_zherk", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Trans == CblasTrans) TR ='N'; + else if ( Trans == CblasConjTrans ) TR='N'; + else if ( Trans == CblasNoTrans ) TR='C'; + else + { + cblas_xerbla(3, "cblas_zherk", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_zherk(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, + &beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_zherk", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_zhpmv.c b/cblas/src/cblas_zhpmv.c new file mode 100644 index 00000000..80b3c4d3 --- /dev/null +++ b/cblas/src/cblas_zhpmv.c @@ -0,0 +1,160 @@ +/* + * cblas_zhpmv.c + * The program is a C interface of zhpmv + * + * Keita Teranishi 5/18/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zhpmv(const CBLAS_LAYOUT layout, + const CBLAS_UPLO Uplo,const int N, + const void *alpha, const void *AP, + const void *X, const int incX, const void *beta, + void *Y, const int incY) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incx + #define F77_incY incY +#endif + int n, i=0, incx=incX; + const double *xx= (double *)X, *alp= (double *)alpha, *bet = (double *)beta; + double ALPHA[2],BETA[2]; + int tincY, tincx; + double *x=(double *)X, *y=(double *)Y, *st=0, *tx; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_zhpmv","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_zhpmv(F77_UL, &F77_N, alpha, AP, X, + &F77_incX, beta, Y, &F77_incY); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + ALPHA[0]= *alp; + ALPHA[1]= -alp[1]; + BETA[0]= *bet; + BETA[1]= -bet[1]; + + if (N > 0) + { + n = N << 1; + x = malloc(n*sizeof(double)); + + tx = x; + if( incX > 0 ) { + i = incX << 1; + tincx = 2; + st= x+n; + } else { + i = incX *(-2); + tincx = -2; + st = x-2; + x +=(n-2); + } + + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != st); + x=tx; + + + #ifdef F77_INT + F77_incX = 1; + #else + incx = 1; + #endif + + if(incY > 0) + tincY = incY; + else + tincY = -incY; + y++; + + i = tincY << 1; + n = i * N ; + st = y + n; + do { + *y = -(*y); + y += i; + } while(y != st); + y -= n; + } else + x = (double *) X; + + + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_zhpmv","Illegal Uplo setting, %d\n", Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_zhpmv(F77_UL, &F77_N, ALPHA, + AP, x, &F77_incX, BETA, Y, &F77_incY); + } + else + { + cblas_xerbla(1, "cblas_zhpmv","Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if ( layout == CblasRowMajor ) + { + RowMajorStrg = 1; + if(X!=x) + free(x); + if (N > 0) + { + do + { + *y = -(*y); + y += i; + } + while (y != st); + } + } + + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_zhpr.c b/cblas/src/cblas_zhpr.c new file mode 100644 index 00000000..4037b7bf --- /dev/null +++ b/cblas/src/cblas_zhpr.c @@ -0,0 +1,115 @@ +/* + * cblas_zhpr.c + * The program is a C interface to zhpr. + * + * Keita Teranishi 3/23/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zhpr(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const int N, const double alpha, const void *X, + const int incX, void *A) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incx +#endif + int n, i, tincx, incx=incX; + double *x=(double *)X, *xx=(double *)X, *tx, *st; + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_zhpr","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_zhpr(F77_UL, &F77_N, &alpha, X, &F77_incX, A); + + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_zhpr","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + if (N > 0) + { + n = N << 1; + x = malloc(n*sizeof(double)); + tx = x; + if( incX > 0 ) { + i = incX << 1; + tincx = 2; + st= x+n; + } else { + i = incX *(-2); + tincx = -2; + st = x-2; + x +=(n-2); + } + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != st); + x=tx; + #ifdef F77_INT + F77_incX = 1; + #else + incx = 1; + #endif + } + else x = (double *) X; + + F77_zhpr(F77_UL, &F77_N, &alpha, x, &F77_incX, A); + + } else + { + cblas_xerbla(1, "cblas_zhpr","Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(X!=x) + free(x); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_zhpr2.c b/cblas/src/cblas_zhpr2.c new file mode 100644 index 00000000..a4349d3e --- /dev/null +++ b/cblas/src/cblas_zhpr2.c @@ -0,0 +1,150 @@ +/* + * cblas_zhpr2.c + * The program is a C interface to zhpr2. + * + * Keita Teranishi 5/20/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zhpr2(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const int N,const void *alpha, const void *X, + const int incX,const void *Y, const int incY, void *Ap) + +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incx + #define F77_incY incy +#endif + int n, i, j, incx=incX, incy=incY; + double *x=(double *)X, *xx=(double *)X, *y=(double *)Y, + *yy=(double *)Y, *stx, *sty; + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_zhpr2","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_zhpr2(F77_UL, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, Ap); + + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_zhpr2","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + if (N > 0) + { + n = N << 1; + x = malloc(n*sizeof(double)); + y = malloc(n*sizeof(double)); + stx = x + n; + sty = y + n; + if( incX > 0 ) + i = incX << 1; + else + i = incX *(-2); + + if( incY > 0 ) + j = incY << 1; + else + j = incY *(-2); + do + { + *x = *xx; + x[1] = -xx[1]; + x += 2; + xx += i; + } while (x != stx); + do + { + *y = *yy; + y[1] = -yy[1]; + y += 2; + yy += j; + } + while (y != sty); + x -= n; + y -= n; + + #ifdef F77_INT + if(incX > 0 ) + F77_incX = 1; + else + F77_incX = -1; + + if(incY > 0 ) + F77_incY = 1; + else + F77_incY = -1; + + #else + if(incX > 0 ) + incx = 1; + else + incx = -1; + + if(incY > 0 ) + incy = 1; + else + incy = -1; + #endif + + } else + { + x = (double *) X; + y = (void *) Y; + } + F77_zhpr2(F77_UL, &F77_N, alpha, y, &F77_incY, x, &F77_incX, Ap); + } + else + { + cblas_xerbla(1, "cblas_zhpr2","Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(X!=x) + free(x); + if(Y!=y) + free(y); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_zscal.c b/cblas/src/cblas_zscal.c new file mode 100644 index 00000000..37b319f3 --- /dev/null +++ b/cblas/src/cblas_zscal.c @@ -0,0 +1,21 @@ +/* + * cblas_zscal.c + * + * The program is a C interface to zscal. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zscal( const int N, const void *alpha, void *X, + const int incX) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_zscal( &F77_N, alpha, X, &F77_incX); +} diff --git a/cblas/src/cblas_zswap.c b/cblas/src/cblas_zswap.c new file mode 100644 index 00000000..dfde2cbd --- /dev/null +++ b/cblas/src/cblas_zswap.c @@ -0,0 +1,22 @@ +/* + * cblas_zswap.c + * + * The program is a C interface to zswap. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zswap( const int N, void *X, const int incX, void *Y, + const int incY) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_zswap( &F77_N, X, &F77_incX, Y, &F77_incY); +} diff --git a/cblas/src/cblas_zsymm.c b/cblas/src/cblas_zsymm.c new file mode 100644 index 00000000..fcedd048 --- /dev/null +++ b/cblas/src/cblas_zsymm.c @@ -0,0 +1,106 @@ +/* + * + * cblas_zsymm.c + * This program is a C interface to zsymm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zsymm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc) +{ + char SD, UL; +#ifdef F77_CHAR + F77_CHAR F77_SD, F77_UL; +#else + #define F77_SD &SD + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + if( Side == CblasRight) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + cblas_xerbla(2, "cblas_zsymm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(3, "cblas_zsymm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_zsymm(F77_SD, F77_UL, &F77_M, &F77_N, alpha, A, &F77_lda, + B, &F77_ldb, beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if( Side == CblasRight) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + cblas_xerbla(2, "cblas_zsymm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_zsymm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_zsymm(F77_SD, F77_UL, &F77_N, &F77_M, alpha, A, &F77_lda, + B, &F77_ldb, beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_zsymm", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_zsyr2k.c b/cblas/src/cblas_zsyr2k.c new file mode 100644 index 00000000..b1181884 --- /dev/null +++ b/cblas/src/cblas_zsyr2k.c @@ -0,0 +1,108 @@ +/* + * + * cblas_zsyr2k.c + * This program is a C interface to zsyr2k. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zsyr2k(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc) +{ + char UL, TR; +#ifdef F77_CHAR + F77_CHAR F77_TR, F77_UL; +#else + #define F77_TR &TR + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(2, "cblas_zsyr2k", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Trans == CblasTrans) TR ='T'; + else if ( Trans == CblasConjTrans ) TR='C'; + else if ( Trans == CblasNoTrans ) TR='N'; + else + { + cblas_xerbla(3, "cblas_zsyr2k", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_zsyr2k(F77_UL, F77_TR, &F77_N, &F77_K, alpha, A, &F77_lda, + B, &F77_ldb, beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_zsyr2k", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Trans == CblasTrans) TR ='N'; + else if ( Trans == CblasConjTrans ) TR='N'; + else if ( Trans == CblasNoTrans ) TR='T'; + else + { + cblas_xerbla(3, "cblas_zsyr2k", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_zsyr2k(F77_UL, F77_TR, &F77_N, &F77_K, alpha, A, &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_zsyr2k", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_zsyrk.c b/cblas/src/cblas_zsyrk.c new file mode 100644 index 00000000..d247f8df --- /dev/null +++ b/cblas/src/cblas_zsyrk.c @@ -0,0 +1,107 @@ +/* + * + * cblas_zsyrk.c + * This program is a C interface to zsyrk. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zsyrk(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *beta, void *C, const int ldc) +{ + char UL, TR; +#ifdef F77_CHAR + F77_CHAR F77_TR, F77_UL; +#else + #define F77_TR &TR + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(2, "cblas_zsyrk", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Trans == CblasTrans) TR ='T'; + else if ( Trans == CblasConjTrans ) TR='C'; + else if ( Trans == CblasNoTrans ) TR='N'; + else + { + cblas_xerbla(3, "cblas_zsyrk", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_zsyrk(F77_UL, F77_TR, &F77_N, &F77_K, alpha, A, &F77_lda, + beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_zsyrk", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Trans == CblasTrans) TR ='N'; + else if ( Trans == CblasConjTrans ) TR='N'; + else if ( Trans == CblasNoTrans ) TR='T'; + else + { + cblas_xerbla(3, "cblas_zsyrk", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_zsyrk(F77_UL, F77_TR, &F77_N, &F77_K, alpha, A, &F77_lda, + beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_zsyrk", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_ztbmv.c b/cblas/src/cblas_ztbmv.c new file mode 100644 index 00000000..84928ae2 --- /dev/null +++ b/cblas/src/cblas_ztbmv.c @@ -0,0 +1,158 @@ +/* + * cblas_ztbmv.c + * The program is a C interface to ztbmv. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ztbmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const int K, const void *A, const int lda, + void *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_K=K, F77_incX=incX; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_incX incX +#endif + int n, i=0, tincX; + double *st=0, *x=(double *)X; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ztbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_ztbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ztbmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ztbmv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ztbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + TA = 'N'; + if ( N > 0) + { + if(incX > 0) + tincX = incX; + else + tincX = -incX; + i = tincX << 1; + n = i * N; + x++; + st = x + n; + do + { + *x = -(*x); + x+= i; + } + while (x != st); + x -= n; + } + } + else + { + cblas_xerbla(3, "cblas_ztbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ztbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_ztbmv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + + if (TransA == CblasConjTrans) + { + if (N > 0) + { + do + { + *x = -(*x); + x += i; + } + while (x != st); + } + } + } + else cblas_xerbla(1, "cblas_ztbmv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_ztbsv.c b/cblas/src/cblas_ztbsv.c new file mode 100644 index 00000000..455cb454 --- /dev/null +++ b/cblas/src/cblas_ztbsv.c @@ -0,0 +1,162 @@ +/* + * cblas_ztbsv.c + * The program is a C interface to ztbsv. + * + * Keita Teranishi 3/23/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ztbsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const int K, const void *A, const int lda, + void *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_K=K, F77_incX=incX; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_incX incX +#endif + int n, i=0, tincX; + double *st=0,*x=(double *)X; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ztbsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_ztbsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ztbsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ztbsv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ztbsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + TA = 'N'; + if ( N > 0) + { + if ( incX > 0 ) + tincX = incX; + else + tincX = -incX; + + n = N*2*(tincX); + + x++; + + st=x+n; + + i = tincX << 1; + do + { + *x = -(*x); + x+=i; + } + while (x != st); + x -= n; + } + } + else + { + cblas_xerbla(3, "cblas_ztbsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ztbsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_ztbsv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + + if (TransA == CblasConjTrans) + { + if (N > 0) + { + do + { + *x = -(*x); + x+= i; + } + while (x != st); + } + } + } + else cblas_xerbla(1, "cblas_ztbsv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_ztpmv.c b/cblas/src/cblas_ztpmv.c new file mode 100644 index 00000000..db099d7c --- /dev/null +++ b/cblas/src/cblas_ztpmv.c @@ -0,0 +1,152 @@ +/* + * cblas_ztpmv.c + * The program is a C interface to ztpmv. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ztpmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const void *Ap, void *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + int n, i=0, tincX; + double *st=0,*x=(double *)X; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ztpmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_ztpmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ztpmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ztpmv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X, &F77_incX); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ztpmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + TA = 'N'; + if ( N > 0) + { + if(incX > 0) + tincX = incX; + else + tincX = -incX; + i = tincX << 1; + n = i * N; + x++; + st = x + n; + do + { + *x = -(*x); + x += i; + } + while (x != st); + x -= n; + } + } + else + { + cblas_xerbla(3, "cblas_ztpmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ztpmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_ztpmv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X,&F77_incX); + if (TransA == CblasConjTrans) + { + if (N > 0) + { + do + { + *x = -(*x); + x += i; + } + while (x != st); + } + } + } + else cblas_xerbla(1, "cblas_ztpmv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_ztpsv.c b/cblas/src/cblas_ztpsv.c new file mode 100644 index 00000000..a2df95c8 --- /dev/null +++ b/cblas/src/cblas_ztpsv.c @@ -0,0 +1,157 @@ +/* + * cblas_ztpsv.c + * The program is a C interface to ztpsv. + * + * Keita Teranishi 3/23/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ztpsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const void *Ap, void *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + int n, i=0, tincX; + double *st=0, *x=(double*)X; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ztpsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_ztpsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ztpsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ztpsv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X, &F77_incX); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ztpsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + TA = 'N'; + if ( N > 0) + { + if ( incX > 0 ) + tincX = incX; + else + tincX = -incX; + + n = N*2*(tincX); + + x++; + + st=x+n; + + i = tincX << 1; + do + { + *x = -(*x); + x+=i; + } + while (x != st); + x -= n; + } + } + else + { + cblas_xerbla(3, "cblas_ztpsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ztpsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_ztpsv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X,&F77_incX); + + if (TransA == CblasConjTrans) + { + if (N > 0) + { + do + { + *x = -(*x); + x += i; + } + while (x != st); + } + } + } + else cblas_xerbla(1, "cblas_ztpsv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_ztrmm.c b/cblas/src/cblas_ztrmm.c new file mode 100644 index 00000000..4fd86552 --- /dev/null +++ b/cblas/src/cblas_ztrmm.c @@ -0,0 +1,149 @@ +/* + * + * cblas_ztrmm.c + * This program is a C interface to ztrmm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ztrmm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, + const CBLAS_DIAG Diag, const int M, const int N, + const void *alpha, const void *A, const int lda, + void *B, const int ldb) +{ + char UL, TA, SD, DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_SD, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_SD &SD + #define F77_DI &DI +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + if( Side == CblasRight ) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + cblas_xerbla(2, "cblas_ztrmm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Uplo == CblasUpper ) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(3, "cblas_ztrmm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( TransA == CblasTrans ) TA ='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_ztrmm", "Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit ) DI='N'; + else + { + cblas_xerbla(5, "cblas_ztrmm", "Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_ztrmm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_M, &F77_N, alpha, A, &F77_lda, B, &F77_ldb); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if( Side == CblasRight ) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + cblas_xerbla(2, "cblas_ztrmm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper ) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_ztrmm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( TransA == CblasTrans ) TA ='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_ztrmm", "Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit ) DI='N'; + else + { + cblas_xerbla(5, "cblas_ztrmm", "Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_ztrmm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_N, &F77_M, alpha, A, &F77_lda, B, &F77_ldb); + } + else cblas_xerbla(1, "cblas_ztrmm", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_ztrmv.c b/cblas/src/cblas_ztrmv.c new file mode 100644 index 00000000..57fd2357 --- /dev/null +++ b/cblas/src/cblas_ztrmv.c @@ -0,0 +1,156 @@ +/* + * cblas_ztrmv.c + * The program is a C interface to ztrmv. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ztrmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const void *A, const int lda, + void *X, const int incX) + +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incX +#endif + int n, i=0, tincX; + double *st=0,*x=(double *)X; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ztrmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_ztrmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ztrmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ztrmv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ztrmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + TA = 'N'; + if ( N > 0) + { + if(incX > 0) + tincX = incX; + else + tincX = -incX; + i = tincX << 1; + n = i * N; + x++; + st = x + n; + do + { + *x = -(*x); + x += i; + } + while (x != st); + x -= n; + } + } + else + { + cblas_xerbla(3, "cblas_ztrmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ztrmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ztrmv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + if (TransA == CblasConjTrans) + { + if (N > 0) + { + do + { + *x = -(*x); + x += i; + } + while (x != st); + } + } + } + else cblas_xerbla(1, "cblas_ztrmv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_ztrsm.c b/cblas/src/cblas_ztrsm.c new file mode 100644 index 00000000..85ad8796 --- /dev/null +++ b/cblas/src/cblas_ztrsm.c @@ -0,0 +1,155 @@ +/* + * + * cblas_ztrsm.c + * This program is a C interface to ztrsm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ztrsm(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, + const CBLAS_DIAG Diag, const int M, const int N, + const void *alpha, const void *A, const int lda, + void *B, const int ldb) +{ + char UL, TA, SD, DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_SD, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_SD &SD + #define F77_DI &DI +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + + if( Side == CblasRight) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + cblas_xerbla(2, "cblas_ztrsm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(3, "cblas_ztrsm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( TransA == CblasTrans) TA ='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_ztrsm", "Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit ) DI='N'; + else + { + cblas_xerbla(5, "cblas_ztrsm", "Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_ztrsm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_M, &F77_N, alpha, A, + &F77_lda, B, &F77_ldb); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + + if( Side == CblasRight) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + cblas_xerbla(2, "cblas_ztrsm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_ztrsm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( TransA == CblasTrans) TA ='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_ztrsm", "Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit ) DI='N'; + else + { + cblas_xerbla(5, "cblas_ztrsm", "Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + + + F77_ztrsm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_N, &F77_M, alpha, A, + &F77_lda, B, &F77_ldb); + } + else cblas_xerbla(1, "cblas_ztrsm", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cblas_ztrsv.c b/cblas/src/cblas_ztrsv.c new file mode 100644 index 00000000..e685208c --- /dev/null +++ b/cblas/src/cblas_ztrsv.c @@ -0,0 +1,156 @@ +/* + * cblas_ztrsv.c + * The program is a C interface to ztrsv. + * + * Keita Teranishi 3/23/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ztrsv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const void *A, const int lda, void *X, + const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incX +#endif + int n, i=0, tincX; + double *st=0,*x=(double *)X; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ztrsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_ztrsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ztrsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ztrsv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ztrsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + TA = 'N'; + if ( N > 0) + { + if ( incX > 0 ) + tincX = incX; + else + tincX = -incX; + + n = N*2*(tincX); + x++; + st=x+n; + i = tincX << 1; + do + { + *x = -(*x); + x+=i; + } + while (x != st); + x -= n; + } + } + else + { + cblas_xerbla(3, "cblas_ztrsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ztrsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ztrsv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + if (TransA == CblasConjTrans) + { + if (N > 0) + { + do + { + *x = -(*x); + x += i; + } + while (x != st); + } + } + } + else cblas_xerbla(1, "cblas_ztrsv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/cblas/src/cdotcsub.f b/cblas/src/cdotcsub.f new file mode 100644 index 00000000..f97d7159 --- /dev/null +++ b/cblas/src/cdotcsub.f @@ -0,0 +1,15 @@ +c cdotcsub.f +c +c The program is a fortran wrapper for cdotc. +c Witten by Keita Teranishi. 2/11/1998 +c + subroutine cdotcsub(n,x,incx,y,incy,dotc) +c + external cdotc + complex cdotc,dotc + integer n,incx,incy + complex x(*),y(*) +c + dotc=cdotc(n,x,incx,y,incy) + return + end diff --git a/cblas/src/cdotusub.f b/cblas/src/cdotusub.f new file mode 100644 index 00000000..5107c040 --- /dev/null +++ b/cblas/src/cdotusub.f @@ -0,0 +1,15 @@ +c cdotusub.f +c +c The program is a fortran wrapper for cdotu. +c Witten by Keita Teranishi. 2/11/1998 +c + subroutine cdotusub(n,x,incx,y,incy,dotu) +c + external cdotu + complex cdotu,dotu + integer n,incx,incy + complex x(*),y(*) +c + dotu=cdotu(n,x,incx,y,incy) + return + end diff --git a/cblas/src/dasumsub.f b/cblas/src/dasumsub.f new file mode 100644 index 00000000..3d64d17e --- /dev/null +++ b/cblas/src/dasumsub.f @@ -0,0 +1,15 @@ +c dasumsun.f +c +c The program is a fortran wrapper for dasum.. +c Witten by Keita Teranishi. 2/11/1998 +c + subroutine dasumsub(n,x,incx,asum) +c + external dasum + double precision dasum,asum + integer n,incx + double precision x(*) +c + asum=dasum(n,x,incx) + return + end diff --git a/cblas/src/ddotsub.f b/cblas/src/ddotsub.f new file mode 100644 index 00000000..205f3b46 --- /dev/null +++ b/cblas/src/ddotsub.f @@ -0,0 +1,15 @@ +c ddotsub.f +c +c The program is a fortran wrapper for ddot. +c Witten by Keita Teranishi. 2/11/1998 +c + subroutine ddotsub(n,x,incx,y,incy,dot) +c + external ddot + double precision ddot + integer n,incx,incy + double precision x(*),y(*),dot +c + dot=ddot(n,x,incx,y,incy) + return + end diff --git a/cblas/src/dnrm2sub.f b/cblas/src/dnrm2sub.f new file mode 100644 index 00000000..88f17db8 --- /dev/null +++ b/cblas/src/dnrm2sub.f @@ -0,0 +1,15 @@ +c dnrm2sub.f +c +c The program is a fortran wrapper for dnrm2. +c Witten by Keita Teranishi. 2/11/1998 +c + subroutine dnrm2sub(n,x,incx,nrm2) +c + external dnrm2 + double precision dnrm2,nrm2 + integer n,incx + double precision x(*) +c + nrm2=dnrm2(n,x,incx) + return + end diff --git a/cblas/src/dsdotsub.f b/cblas/src/dsdotsub.f new file mode 100644 index 00000000..e7e872c9 --- /dev/null +++ b/cblas/src/dsdotsub.f @@ -0,0 +1,15 @@ +c dsdotsub.f +c +c The program is a fortran wrapper for dsdot. +c Witten by Keita Teranishi. 2/11/1998 +c + subroutine dsdotsub(n,x,incx,y,incy,dot) +c + external dsdot + double precision dsdot,dot + integer n,incx,incy + real x(*),y(*) +c + dot=dsdot(n,x,incx,y,incy) + return + end diff --git a/cblas/src/dzasumsub.f b/cblas/src/dzasumsub.f new file mode 100644 index 00000000..9aaf1638 --- /dev/null +++ b/cblas/src/dzasumsub.f @@ -0,0 +1,15 @@ +c dzasumsub.f +c +c The program is a fortran wrapper for dzasum. +c Witten by Keita Teranishi. 2/11/1998 +c + subroutine dzasumsub(n,x,incx,asum) +c + external dzasum + double precision dzasum,asum + integer n,incx + double complex x(*) +c + asum=dzasum(n,x,incx) + return + end diff --git a/cblas/src/dznrm2sub.f b/cblas/src/dznrm2sub.f new file mode 100644 index 00000000..45dc599f --- /dev/null +++ b/cblas/src/dznrm2sub.f @@ -0,0 +1,15 @@ +c dznrm2sub.f +c +c The program is a fortran wrapper for dznrm2. +c Witten by Keita Teranishi. 2/11/1998 +c + subroutine dznrm2sub(n,x,incx,nrm2) +c + external dznrm2 + double precision dznrm2,nrm2 + integer n,incx + double complex x(*) +c + nrm2=dznrm2(n,x,incx) + return + end diff --git a/cblas/src/icamaxsub.f b/cblas/src/icamaxsub.f new file mode 100644 index 00000000..3f47071e --- /dev/null +++ b/cblas/src/icamaxsub.f @@ -0,0 +1,15 @@ +c icamaxsub.f +c +c The program is a fortran wrapper for icamax. +c Witten by Keita Teranishi. 2/11/1998 +c + subroutine icamaxsub(n,x,incx,iamax) +c + external icamax + integer icamax,iamax + integer n,incx + complex x(*) +c + iamax=icamax(n,x,incx) + return + end diff --git a/cblas/src/idamaxsub.f b/cblas/src/idamaxsub.f new file mode 100644 index 00000000..3c1ee5c3 --- /dev/null +++ b/cblas/src/idamaxsub.f @@ -0,0 +1,15 @@ +c icamaxsub.f +c +c The program is a fortran wrapper for idamax. +c Witten by Keita Teranishi. 2/22/1998 +c + subroutine idamaxsub(n,x,incx,iamax) +c + external idamax + integer idamax,iamax + integer n,incx + double precision x(*) +c + iamax=idamax(n,x,incx) + return + end diff --git a/cblas/src/isamaxsub.f b/cblas/src/isamaxsub.f new file mode 100644 index 00000000..0faf42fd --- /dev/null +++ b/cblas/src/isamaxsub.f @@ -0,0 +1,15 @@ +c isamaxsub.f +c +c The program is a fortran wrapper for isamax. +c Witten by Keita Teranishi. 2/11/1998 +c + subroutine isamaxsub(n,x,incx,iamax) +c + external isamax + integer isamax,iamax + integer n,incx + real x(*) +c + iamax=isamax(n,x,incx) + return + end diff --git a/cblas/src/izamaxsub.f b/cblas/src/izamaxsub.f new file mode 100644 index 00000000..5b15855a --- /dev/null +++ b/cblas/src/izamaxsub.f @@ -0,0 +1,15 @@ +c izamaxsub.f +c +c The program is a fortran wrapper for izamax. +c Witten by Keita Teranishi. 2/11/1998 +c + subroutine izamaxsub(n,x,incx,iamax) +c + external izamax + integer izamax,iamax + integer n,incx + double complex x(*) +c + iamax=izamax(n,x,incx) + return + end diff --git a/cblas/src/sasumsub.f b/cblas/src/sasumsub.f new file mode 100644 index 00000000..955f11e8 --- /dev/null +++ b/cblas/src/sasumsub.f @@ -0,0 +1,15 @@ +c sasumsub.f +c +c The program is a fortran wrapper for sasum. +c Witten by Keita Teranishi. 2/11/1998 +c + subroutine sasumsub(n,x,incx,asum) +c + external sasum + real sasum,asum + integer n,incx + real x(*) +c + asum=sasum(n,x,incx) + return + end diff --git a/cblas/src/scasumsub.f b/cblas/src/scasumsub.f new file mode 100644 index 00000000..077ace67 --- /dev/null +++ b/cblas/src/scasumsub.f @@ -0,0 +1,15 @@ +c scasumsub.f +c +c The program is a fortran wrapper for scasum. +c Witten by Keita Teranishi. 2/11/1998 +c + subroutine scasumsub(n,x,incx,asum) +c + external scasum + real scasum,asum + integer n,incx + complex x(*) +c + asum=scasum(n,x,incx) + return + end diff --git a/cblas/src/scnrm2sub.f b/cblas/src/scnrm2sub.f new file mode 100644 index 00000000..7242c974 --- /dev/null +++ b/cblas/src/scnrm2sub.f @@ -0,0 +1,15 @@ +c scnrm2sub.f +c +c The program is a fortran wrapper for scnrm2. +c Witten by Keita Teranishi. 2/11/1998 +c + subroutine scnrm2sub(n,x,incx,nrm2) +c + external scnrm2 + real scnrm2,nrm2 + integer n,incx + complex x(*) +c + nrm2=scnrm2(n,x,incx) + return + end diff --git a/cblas/src/sdotsub.f b/cblas/src/sdotsub.f new file mode 100644 index 00000000..e1af3c97 --- /dev/null +++ b/cblas/src/sdotsub.f @@ -0,0 +1,15 @@ +c sdotsub.f +c +c The program is a fortran wrapper for sdot. +c Witten by Keita Teranishi. 2/11/1998 +c + subroutine sdotsub(n,x,incx,y,incy,dot) +c + external sdot + real sdot + integer n,incx,incy + real x(*),y(*),dot +c + dot=sdot(n,x,incx,y,incy) + return + end diff --git a/cblas/src/sdsdotsub.f b/cblas/src/sdsdotsub.f new file mode 100644 index 00000000..c6b8bb2e --- /dev/null +++ b/cblas/src/sdsdotsub.f @@ -0,0 +1,15 @@ +c sdsdotsub.f +c +c The program is a fortran wrapper for sdsdot. +c Witten by Keita Teranishi. 2/11/1998 +c + subroutine sdsdotsub(n,sb,x,incx,y,incy,dot) +c + external sdsdot + real sb,sdsdot,dot + integer n,incx,incy + real x(*),y(*) +c + dot=sdsdot(n,sb,x,incx,y,incy) + return + end diff --git a/cblas/src/snrm2sub.f b/cblas/src/snrm2sub.f new file mode 100644 index 00000000..871a6e49 --- /dev/null +++ b/cblas/src/snrm2sub.f @@ -0,0 +1,15 @@ +c snrm2sub.f +c +c The program is a fortran wrapper for snrm2. +c Witten by Keita Teranishi. 2/11/1998 +c + subroutine snrm2sub(n,x,incx,nrm2) +c + external snrm2 + real snrm2,nrm2 + integer n,incx + real x(*) +c + nrm2=snrm2(n,x,incx) + return + end diff --git a/cblas/src/xerbla.c b/cblas/src/xerbla.c new file mode 100644 index 00000000..5a7bcd8b --- /dev/null +++ b/cblas/src/xerbla.c @@ -0,0 +1,47 @@ +#include <stdio.h> +#include <ctype.h> +#include "cblas.h" +#include "cblas_f77.h" + +#define XerblaStrLen 6 +#define XerblaStrLen1 7 + +#ifdef F77_CHAR +void F77_xerbla(F77_CHAR F77_srname, void *vinfo) +#else +void F77_xerbla(char *srname, void *vinfo) +#endif + +{ +#ifdef F77_CHAR + char *srname; +#endif + + char rout[] = {'c','b','l','a','s','_','\0','\0','\0','\0','\0','\0','\0'}; + +#ifdef F77_INT + F77_INT *info=vinfo; + F77_INT i; +#else + int *info=vinfo; + int i; +#endif + + extern int CBLAS_CallFromC; + +#ifdef F77_CHAR + srname = F2C_STR(F77_srname, XerblaStrLen); +#endif + + if (CBLAS_CallFromC) + { + for(i=0; i != XerblaStrLen; i++) rout[i+6] = tolower(srname[i]); + rout[XerblaStrLen+6] = '\0'; + cblas_xerbla(*info+1,rout,""); + } + else + { + fprintf(stderr, "Parameter %d to routine %s was incorrect\n", + *info, srname); + } +} diff --git a/cblas/src/zdotcsub.f b/cblas/src/zdotcsub.f new file mode 100644 index 00000000..8d483c89 --- /dev/null +++ b/cblas/src/zdotcsub.f @@ -0,0 +1,15 @@ +c zdotcsub.f +c +c The program is a fortran wrapper for zdotc. +c Witten by Keita Teranishi. 2/11/1998 +c + subroutine zdotcsub(n,x,incx,y,incy,dotc) +c + external zdotc + double complex zdotc,dotc + integer n,incx,incy + double complex x(*),y(*) +c + dotc=zdotc(n,x,incx,y,incy) + return + end diff --git a/cblas/src/zdotusub.f b/cblas/src/zdotusub.f new file mode 100644 index 00000000..23f32dec --- /dev/null +++ b/cblas/src/zdotusub.f @@ -0,0 +1,15 @@ +c zdotusub.f +c +c The program is a fortran wrapper for zdotu. +c Witten by Keita Teranishi. 2/11/1998 +c + subroutine zdotusub(n,x,incx,y,incy,dotu) +c + external zdotu + double complex zdotu,dotu + integer n,incx,incy + double complex x(*),y(*) +c + dotu=zdotu(n,x,incx,y,incy) + return + end diff --git a/cblas/testing/Makefile b/cblas/testing/Makefile new file mode 100644 index 00000000..e58b002d --- /dev/null +++ b/cblas/testing/Makefile @@ -0,0 +1,134 @@ +# +# The Makefile compiles c wrappers and testers for CBLAS. +# + +dlvl = ../. +include $(dlvl)/Makefile.in + +# Archive files necessary to compile +LIB = $(CBLIB) $(BLLIB) + +# Object files for single real precision +stestl1o = c_sblas1.o + +stestl2o = c_sblas2.o c_s2chke.o auxiliary.o c_xerbla.o + +stestl3o = c_sblas3.o c_s3chke.o auxiliary.o c_xerbla.o + +# Object files for double real precision +dtestl1o = c_dblas1.o + +dtestl2o = c_dblas2.o c_d2chke.o auxiliary.o c_xerbla.o + +dtestl3o = c_dblas3.o c_d3chke.o auxiliary.o c_xerbla.o + +# Object files for single complex precision +ctestl1o = c_cblas1.o + +ctestl2o = c_cblas2.o c_c2chke.o auxiliary.o c_xerbla.o + +ctestl3o = c_cblas3.o c_c3chke.o auxiliary.o c_xerbla.o + +# Object files for double complex precision +ztestl1o = c_zblas1.o + +ztestl2o = c_zblas2.o c_z2chke.o auxiliary.o c_xerbla.o + +ztestl3o = c_zblas3.o c_z3chke.o auxiliary.o c_xerbla.o + +all: all1 all2 all3 +all1: stest1 dtest1 ctest1 ztest1 +all2: stest2 dtest2 ctest2 ztest2 +all3: stest3 dtest3 ctest3 ztest3 + +clean: + rm -f core *.o a.out x* +cleanobj: + rm -f core *.o a.out +cleanexe: + rm -f x* + +stest1: xscblat1 +dtest1: xdcblat1 +ctest1: xccblat1 +ztest1: xzcblat1 + +stest2: xscblat2 +dtest2: xdcblat2 +ctest2: xccblat2 +ztest2: xzcblat2 + +stest3: xscblat3 +dtest3: xdcblat3 +ctest3: xccblat3 +ztest3: xzcblat3 + +# +# Compile each precision +# + +# Single real +xscblat1: $(stestl1o) c_sblat1.o + $(LOADER) $(LOADFLAGS) -o xscblat1 c_sblat1.o $(stestl1o) $(LIB) +xscblat2: $(stestl2o) c_sblat2.o + $(LOADER) $(LOADFLAGS) -o xscblat2 c_sblat2.o $(stestl2o) $(LIB) +xscblat3: $(stestl3o) c_sblat3.o + $(LOADER) $(LOADFLAGS) -o xscblat3 c_sblat3.o $(stestl3o) $(LIB) +# Double real +xdcblat1: $(dtestl1o) c_dblat1.o + $(LOADER) $(LOADFLAGS) -o xdcblat1 c_dblat1.o $(dtestl1o) $(LIB) +xdcblat2: $(dtestl2o) c_dblat2.o + $(LOADER) $(LOADFLAGS) -o xdcblat2 c_dblat2.o $(dtestl2o) $(LIB) +xdcblat3: $(dtestl3o) c_dblat3.o + $(LOADER) $(LOADFLAGS) -o xdcblat3 c_dblat3.o $(dtestl3o) $(LIB) + +# Single complex +xccblat1: $(ctestl1o) c_cblat1.o + $(LOADER) $(LOADFLAGS) -o xccblat1 c_cblat1.o $(ctestl1o) $(LIB) +xccblat2: $(ctestl2o) c_cblat2.o + $(LOADER) $(LOADFLAGS) -o xccblat2 c_cblat2.o $(ctestl2o) $(LIB) +xccblat3: $(ctestl3o) c_cblat3.o + $(LOADER) $(LOADFLAGS) -o xccblat3 c_cblat3.o $(ctestl3o) $(LIB) + +# Double complex +xzcblat1: $(ztestl1o) c_zblat1.o + $(LOADER) $(LOADFLAGS) -o xzcblat1 c_zblat1.o $(ztestl1o) $(LIB) +xzcblat2: $(ztestl2o) c_zblat2.o + $(LOADER) $(LOADFLAGS) -o xzcblat2 c_zblat2.o $(ztestl2o) $(LIB) +xzcblat3: $(ztestl3o) c_zblat3.o + $(LOADER) $(LOADFLAGS) -o xzcblat3 c_zblat3.o $(ztestl3o) $(LIB) + + +# RUN TESTS +run: + @echo "--> TESTING BLAS 1 - SINGLE PRECISION <--" + @./xscblat1 > stest1.out + @echo "--> TESTING BLAS 1 - DOUBLE PRECISION <--" + @./xdcblat1 > dtest1.out + @echo "--> TESTING BLAS 1 - COMPLEX PRECISION <--" + @./xccblat1 > ctest1.out + @echo "--> TESTING BLAS 1 - DOUBLE COMPLEX PRECISION <--" + @./xzcblat1 > ztest1.out + @echo "--> TESTING BLAS 2 - SINGLE PRECISION <--" + @./xscblat2 < sin2 > stest2.out + @echo "--> TESTING BLAS 2 - DOUBLE PRECISION <--" + @./xdcblat2 < din2 > dtest2.out + @echo "--> TESTING BLAS 2 - COMPLEX PRECISION <--" + @./xccblat2 < cin2 > ctest2.out + @echo "--> TESTING BLAS 2 - DOUBLE COMPLEX PRECISION <--" + @./xzcblat2 < zin2 > ztest2.out + @echo "--> TESTING BLAS 3 - SINGLE PRECISION <--" + @./xscblat3 < sin3 > stest3.out + @echo "--> TESTING BLAS 3 - DOUBLE PRECISION <--" + @./xdcblat3 < din3 > dtest3.out + @echo "--> TESTING BLAS 3 - COMPLEX PRECISION <--" + @./xccblat3 < cin3 > ctest3.out + @echo "--> TESTING BLAS 3 - DOUBLE COMPLEX PRECISION <--" + @./xzcblat3 < zin3 > ztest3.out + +.SUFFIXES: .o .f .c + +.f.o: + $(FC) $(FFLAGS) -c $*.f +.c.o: + $(CC) -I../include $(CFLAGS) -c $*.c diff --git a/cblas/testing/auxiliary.c b/cblas/testing/auxiliary.c new file mode 100644 index 00000000..4449b33d --- /dev/null +++ b/cblas/testing/auxiliary.c @@ -0,0 +1,38 @@ +/* + * Written by T. H. Do, 1/23/98, SGI/CRAY Research. + */ +#include <string.h> +#include "cblas.h" +#include "cblas_test.h" + +void get_transpose_type(char *type, CBLAS_TRANSPOSE *trans) { + if( (strncmp( type,"n",1 )==0)||(strncmp( type,"N",1 )==0) ) + *trans = CblasNoTrans; + else if( (strncmp( type,"t",1 )==0)||(strncmp( type,"T",1 )==0) ) + *trans = CblasTrans; + else if( (strncmp( type,"c",1 )==0)||(strncmp( type,"C",1 )==0) ) + *trans = CblasConjTrans; + else *trans = UNDEFINED; +} + +void get_uplo_type(char *type, CBLAS_UPLO *uplo) { + if( (strncmp( type,"u",1 )==0)||(strncmp( type,"U",1 )==0) ) + *uplo = CblasUpper; + else if( (strncmp( type,"l",1 )==0)||(strncmp( type,"L",1 )==0) ) + *uplo = CblasLower; + else *uplo = UNDEFINED; +} +void get_diag_type(char *type, CBLAS_DIAG *diag) { + if( (strncmp( type,"u",1 )==0)||(strncmp( type,"U",1 )==0) ) + *diag = CblasUnit; + else if( (strncmp( type,"n",1 )==0)||(strncmp( type,"N",1 )==0) ) + *diag = CblasNonUnit; + else *diag = UNDEFINED; +} +void get_side_type(char *type, CBLAS_SIDE *side) { + if( (strncmp( type,"l",1 )==0)||(strncmp( type,"L",1 )==0) ) + *side = CblasLeft; + else if( (strncmp( type,"r",1 )==0)||(strncmp( type,"R",1 )==0) ) + *side = CblasRight; + else *side = UNDEFINED; +} diff --git a/cblas/testing/c_c2chke.c b/cblas/testing/c_c2chke.c new file mode 100644 index 00000000..18422831 --- /dev/null +++ b/cblas/testing/c_c2chke.c @@ -0,0 +1,826 @@ +#include <stdio.h> +#include <string.h> +#include "cblas.h" +#include "cblas_test.h" + +int cblas_ok, cblas_lerr, cblas_info; +int link_xerbla=TRUE; +char *cblas_rout; + +#ifdef F77_Char +void F77_xerbla(F77_Char F77_srname, void *vinfo); +#else +void F77_xerbla(char *srname, void *vinfo); +#endif + +void chkxer(void) { + extern int cblas_ok, cblas_lerr, cblas_info; + extern int link_xerbla; + extern char *cblas_rout; + if (cblas_lerr == 1 ) { + printf("***** ILLEGAL VALUE OF PARAMETER NUMBER %d NOT DETECTED BY %s *****\n", cblas_info, cblas_rout); + cblas_ok = 0 ; + } + cblas_lerr = 1 ; +} + +void F77_c2chke(char *rout) { + char *sf = ( rout ) ; + float A[2] = {0.0,0.0}, + X[2] = {0.0,0.0}, + Y[2] = {0.0,0.0}, + ALPHA[2] = {0.0,0.0}, + BETA[2] = {0.0,0.0}, + RALPHA = 0.0; + extern int cblas_info, cblas_lerr, cblas_ok; + extern int RowMajorStrg; + extern char *cblas_rout; + + if (link_xerbla) /* call these first to link */ + { + cblas_xerbla(cblas_info,cblas_rout,""); + F77_xerbla(cblas_rout,&cblas_info); + } + + cblas_ok = TRUE ; + cblas_lerr = PASSED ; + + if (strncmp( sf,"cblas_cgemv",11)==0) { + cblas_rout = "cblas_cgemv"; + cblas_info = 1; + cblas_cgemv(INVALID, CblasNoTrans, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_cgemv(CblasColMajor, INVALID, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_cgemv(CblasColMajor, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_cgemv(CblasColMajor, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_cgemv(CblasColMajor, CblasNoTrans, 2, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_cgemv(CblasColMajor, CblasNoTrans, 0, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_cgemv(CblasColMajor, CblasNoTrans, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + + cblas_info = 2; RowMajorStrg = TRUE; RowMajorStrg = TRUE; + cblas_cgemv(CblasRowMajor, INVALID, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_cgemv(CblasRowMajor, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_cgemv(CblasRowMajor, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_cgemv(CblasRowMajor, CblasNoTrans, 0, 2, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_cgemv(CblasRowMajor, CblasNoTrans, 0, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_cgemv(CblasRowMajor, CblasNoTrans, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_cgbmv",11)==0) { + cblas_rout = "cblas_cgbmv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_cgbmv(INVALID, CblasNoTrans, 0, 0, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_cgbmv(CblasColMajor, INVALID, 0, 0, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_cgbmv(CblasColMajor, CblasNoTrans, INVALID, 0, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_cgbmv(CblasColMajor, CblasNoTrans, 0, INVALID, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_cgbmv(CblasColMajor, CblasNoTrans, 0, 0, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_cgbmv(CblasColMajor, CblasNoTrans, 2, 0, 0, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_cgbmv(CblasColMajor, CblasNoTrans, 0, 0, 1, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_cgbmv(CblasColMajor, CblasNoTrans, 0, 0, 0, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_cgbmv(CblasColMajor, CblasNoTrans, 0, 0, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_cgbmv(CblasRowMajor, INVALID, 0, 0, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_cgbmv(CblasRowMajor, CblasNoTrans, INVALID, 0, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_cgbmv(CblasRowMajor, CblasNoTrans, 0, INVALID, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_cgbmv(CblasRowMajor, CblasNoTrans, 0, 0, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_cgbmv(CblasRowMajor, CblasNoTrans, 2, 0, 0, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_cgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 1, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_cgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 0, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_cgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_chemv",11)==0) { + cblas_rout = "cblas_chemv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_chemv(INVALID, CblasUpper, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_chemv(CblasColMajor, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_chemv(CblasColMajor, CblasUpper, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_chemv(CblasColMajor, CblasUpper, 2, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_chemv(CblasColMajor, CblasUpper, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_chemv(CblasColMajor, CblasUpper, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_chemv(CblasRowMajor, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_chemv(CblasRowMajor, CblasUpper, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_chemv(CblasRowMajor, CblasUpper, 2, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_chemv(CblasRowMajor, CblasUpper, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_chemv(CblasRowMajor, CblasUpper, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_chbmv",11)==0) { + cblas_rout = "cblas_chbmv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_chbmv(INVALID, CblasUpper, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_chbmv(CblasColMajor, INVALID, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_chbmv(CblasColMajor, CblasUpper, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_chbmv(CblasColMajor, CblasUpper, 0, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_chbmv(CblasColMajor, CblasUpper, 0, 1, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_chbmv(CblasColMajor, CblasUpper, 0, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_chbmv(CblasColMajor, CblasUpper, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_chbmv(CblasRowMajor, INVALID, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_chbmv(CblasRowMajor, CblasUpper, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_chbmv(CblasRowMajor, CblasUpper, 0, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_chbmv(CblasRowMajor, CblasUpper, 0, 1, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_chbmv(CblasRowMajor, CblasUpper, 0, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_chbmv(CblasRowMajor, CblasUpper, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_chpmv",11)==0) { + cblas_rout = "cblas_chpmv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_chpmv(INVALID, CblasUpper, 0, + ALPHA, A, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_chpmv(CblasColMajor, INVALID, 0, + ALPHA, A, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_chpmv(CblasColMajor, CblasUpper, INVALID, + ALPHA, A, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_chpmv(CblasColMajor, CblasUpper, 0, + ALPHA, A, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_chpmv(CblasColMajor, CblasUpper, 0, + ALPHA, A, X, 1, BETA, Y, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_chpmv(CblasRowMajor, INVALID, 0, + ALPHA, A, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_chpmv(CblasRowMajor, CblasUpper, INVALID, + ALPHA, A, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_chpmv(CblasRowMajor, CblasUpper, 0, + ALPHA, A, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_chpmv(CblasRowMajor, CblasUpper, 0, + ALPHA, A, X, 1, BETA, Y, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_ctrmv",11)==0) { + cblas_rout = "cblas_ctrmv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_ctrmv(INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_ctrmv(CblasColMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_ctrmv(CblasColMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ctrmv(CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_ctrmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ctrmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, A, 1, X, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_ctrmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_ctrmv(CblasRowMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_ctrmv(CblasRowMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_ctrmv(CblasRowMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_ctrmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ctrmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, A, 1, X, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_ctrmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_ctbmv",11)==0) { + cblas_rout = "cblas_ctbmv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_ctbmv(INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_ctbmv(CblasColMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_ctbmv(CblasColMajor, CblasUpper, INVALID, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ctbmv(CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_ctbmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ctbmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_ctbmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 1, A, 1, X, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ctbmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_ctbmv(CblasRowMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_ctbmv(CblasRowMajor, CblasUpper, INVALID, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_ctbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + INVALID, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_ctbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ctbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_ctbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 1, A, 1, X, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ctbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_ctpmv",11)==0) { + cblas_rout = "cblas_ctpmv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_ctpmv(INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_ctpmv(CblasColMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_ctpmv(CblasColMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ctpmv(CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_ctpmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_ctpmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, X, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_ctpmv(CblasRowMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_ctpmv(CblasRowMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_ctpmv(CblasRowMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_ctpmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_ctpmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, X, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_ctrsv",11)==0) { + cblas_rout = "cblas_ctrsv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_ctrsv(INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_ctrsv(CblasColMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_ctrsv(CblasColMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ctrsv(CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_ctrsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ctrsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, A, 1, X, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_ctrsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_ctrsv(CblasRowMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_ctrsv(CblasRowMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_ctrsv(CblasRowMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_ctrsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ctrsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, A, 1, X, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_ctrsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_ctbsv",11)==0) { + cblas_rout = "cblas_ctbsv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_ctbsv(INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_ctbsv(CblasColMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_ctbsv(CblasColMajor, CblasUpper, INVALID, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ctbsv(CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_ctbsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ctbsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_ctbsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 1, A, 1, X, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ctbsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_ctbsv(CblasRowMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_ctbsv(CblasRowMajor, CblasUpper, INVALID, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_ctbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + INVALID, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_ctbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ctbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_ctbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 1, A, 1, X, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ctbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_ctpsv",11)==0) { + cblas_rout = "cblas_ctpsv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_ctpsv(INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_ctpsv(CblasColMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_ctpsv(CblasColMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ctpsv(CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_ctpsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_ctpsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, X, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_ctpsv(CblasRowMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_ctpsv(CblasRowMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_ctpsv(CblasRowMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_ctpsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_ctpsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, X, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_cgeru",10)==0) { + cblas_rout = "cblas_cgeru"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_cgeru(INVALID, 0, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_cgeru(CblasColMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_cgeru(CblasColMajor, 0, INVALID, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_cgeru(CblasColMajor, 0, 0, ALPHA, X, 0, Y, 1, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_cgeru(CblasColMajor, 0, 0, ALPHA, X, 1, Y, 0, A, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_cgeru(CblasColMajor, 2, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_cgeru(CblasRowMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_cgeru(CblasRowMajor, 0, INVALID, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_cgeru(CblasRowMajor, 0, 0, ALPHA, X, 0, Y, 1, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_cgeru(CblasRowMajor, 0, 0, ALPHA, X, 1, Y, 0, A, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_cgeru(CblasRowMajor, 0, 2, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + } else if (strncmp( sf,"cblas_cgerc",10)==0) { + cblas_rout = "cblas_cgerc"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_cgerc(INVALID, 0, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_cgerc(CblasColMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_cgerc(CblasColMajor, 0, INVALID, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_cgerc(CblasColMajor, 0, 0, ALPHA, X, 0, Y, 1, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_cgerc(CblasColMajor, 0, 0, ALPHA, X, 1, Y, 0, A, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_cgerc(CblasColMajor, 2, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_cgerc(CblasRowMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_cgerc(CblasRowMajor, 0, INVALID, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_cgerc(CblasRowMajor, 0, 0, ALPHA, X, 0, Y, 1, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_cgerc(CblasRowMajor, 0, 0, ALPHA, X, 1, Y, 0, A, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_cgerc(CblasRowMajor, 0, 2, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + } else if (strncmp( sf,"cblas_cher2",11)==0) { + cblas_rout = "cblas_cher2"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_cher2(INVALID, CblasUpper, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_cher2(CblasColMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_cher2(CblasColMajor, CblasUpper, INVALID, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_cher2(CblasColMajor, CblasUpper, 0, ALPHA, X, 0, Y, 1, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_cher2(CblasColMajor, CblasUpper, 0, ALPHA, X, 1, Y, 0, A, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_cher2(CblasColMajor, CblasUpper, 2, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_cher2(CblasRowMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_cher2(CblasRowMajor, CblasUpper, INVALID, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_cher2(CblasRowMajor, CblasUpper, 0, ALPHA, X, 0, Y, 1, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_cher2(CblasRowMajor, CblasUpper, 0, ALPHA, X, 1, Y, 0, A, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_cher2(CblasRowMajor, CblasUpper, 2, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + } else if (strncmp( sf,"cblas_chpr2",11)==0) { + cblas_rout = "cblas_chpr2"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_chpr2(INVALID, CblasUpper, 0, ALPHA, X, 1, Y, 1, A ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_chpr2(CblasColMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_chpr2(CblasColMajor, CblasUpper, INVALID, ALPHA, X, 1, Y, 1, A ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_chpr2(CblasColMajor, CblasUpper, 0, ALPHA, X, 0, Y, 1, A ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_chpr2(CblasColMajor, CblasUpper, 0, ALPHA, X, 1, Y, 0, A ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_chpr2(CblasRowMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_chpr2(CblasRowMajor, CblasUpper, INVALID, ALPHA, X, 1, Y, 1, A ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_chpr2(CblasRowMajor, CblasUpper, 0, ALPHA, X, 0, Y, 1, A ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_chpr2(CblasRowMajor, CblasUpper, 0, ALPHA, X, 1, Y, 0, A ); + chkxer(); + } else if (strncmp( sf,"cblas_cher",10)==0) { + cblas_rout = "cblas_cher"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_cher(INVALID, CblasUpper, 0, RALPHA, X, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_cher(CblasColMajor, INVALID, 0, RALPHA, X, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_cher(CblasColMajor, CblasUpper, INVALID, RALPHA, X, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_cher(CblasColMajor, CblasUpper, 0, RALPHA, X, 0, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_cher(CblasColMajor, CblasUpper, 2, RALPHA, X, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_cher(CblasRowMajor, INVALID, 0, RALPHA, X, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_cher(CblasRowMajor, CblasUpper, INVALID, RALPHA, X, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_cher(CblasRowMajor, CblasUpper, 0, RALPHA, X, 0, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_cher(CblasRowMajor, CblasUpper, 2, RALPHA, X, 1, A, 1 ); + chkxer(); + } else if (strncmp( sf,"cblas_chpr",10)==0) { + cblas_rout = "cblas_chpr"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_chpr(INVALID, CblasUpper, 0, RALPHA, X, 1, A ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_chpr(CblasColMajor, INVALID, 0, RALPHA, X, 1, A ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_chpr(CblasColMajor, CblasUpper, INVALID, RALPHA, X, 1, A ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_chpr(CblasColMajor, CblasUpper, 0, RALPHA, X, 0, A ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_chpr(CblasColMajor, INVALID, 0, RALPHA, X, 1, A ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_chpr(CblasColMajor, CblasUpper, INVALID, RALPHA, X, 1, A ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_chpr(CblasColMajor, CblasUpper, 0, RALPHA, X, 0, A ); + chkxer(); + } + if (cblas_ok == TRUE) + printf(" %-12s PASSED THE TESTS OF ERROR-EXITS\n", cblas_rout); + else + printf("******* %s FAILED THE TESTS OF ERROR-EXITS *******\n",cblas_rout); +} diff --git a/cblas/testing/c_c3chke.c b/cblas/testing/c_c3chke.c new file mode 100644 index 00000000..67622435 --- /dev/null +++ b/cblas/testing/c_c3chke.c @@ -0,0 +1,1706 @@ +#include <stdio.h> +#include <string.h> +#include "cblas.h" +#include "cblas_test.h" + +int cblas_ok, cblas_lerr, cblas_info; +int link_xerbla=TRUE; +char *cblas_rout; + +#ifdef F77_Char +void F77_xerbla(F77_Char F77_srname, void *vinfo); +#else +void F77_xerbla(char *srname, void *vinfo); +#endif + +void chkxer(void) { + extern int cblas_ok, cblas_lerr, cblas_info; + extern int link_xerbla; + extern char *cblas_rout; + if (cblas_lerr == 1 ) { + printf("***** ILLEGAL VALUE OF PARAMETER NUMBER %d NOT DETECTED BY %s *****\n", cblas_info, cblas_rout); + cblas_ok = 0 ; + } + cblas_lerr = 1 ; +} + +void F77_c3chke(char * rout) { + char *sf = ( rout ) ; + float A[4] = {0.0,0.0,0.0,0.0}, + B[4] = {0.0,0.0,0.0,0.0}, + C[4] = {0.0,0.0,0.0,0.0}, + ALPHA[2] = {0.0,0.0}, + BETA[2] = {0.0,0.0}, + RALPHA = 0.0, RBETA = 0.0; + extern int cblas_info, cblas_lerr, cblas_ok; + extern int RowMajorStrg; + extern char *cblas_rout; + + cblas_ok = TRUE ; + cblas_lerr = PASSED ; + + if (link_xerbla) /* call these first to link */ + { + cblas_xerbla(cblas_info,cblas_rout,""); + F77_xerbla(cblas_rout,&cblas_info); + } + + if (strncmp( sf,"cblas_cgemm" ,11)==0) { + cblas_rout = "cblas_cgemm" ; + + cblas_info = 1; + cblas_cgemm( INVALID, CblasNoTrans, CblasNoTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_cgemm( INVALID, CblasNoTrans, CblasTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_cgemm( INVALID, CblasTrans, CblasNoTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_cgemm( INVALID, CblasTrans, CblasTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, INVALID, CblasNoTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, INVALID, CblasTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasNoTrans, INVALID, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasTrans, INVALID, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasNoTrans, CblasTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasTrans, CblasNoTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasTrans, CblasTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasNoTrans, CblasTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasTrans, CblasNoTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasTrans, CblasTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasNoTrans, CblasTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasTrans, CblasNoTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasTrans, CblasTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 2, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasNoTrans, CblasTrans, 2, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasTrans, CblasNoTrans, 0, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasTrans, CblasTrans, 0, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 0, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasTrans, CblasNoTrans, 0, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasNoTrans, CblasTrans, 0, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasTrans, CblasTrans, 0, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 2, 0, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasNoTrans, CblasTrans, 2, 0, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasTrans, CblasNoTrans, 2, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasTrans, CblasTrans, 2, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasTrans, CblasNoTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasTrans, CblasTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 2, 0, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasTrans, CblasTrans, 2, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 0, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 0, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_chemm" ,11)==0) { + cblas_rout = "cblas_chemm" ; + + cblas_info = 1; + cblas_chemm( INVALID, CblasRight, CblasLower, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_chemm( CblasColMajor, INVALID, CblasUpper, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_chemm( CblasColMajor, CblasLeft, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_chemm( CblasColMajor, CblasLeft, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_chemm( CblasColMajor, CblasRight, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_chemm( CblasColMajor, CblasLeft, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_chemm( CblasColMajor, CblasRight, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_chemm( CblasColMajor, CblasLeft, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_chemm( CblasColMajor, CblasRight, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_chemm( CblasColMajor, CblasLeft, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_chemm( CblasColMajor, CblasRight, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_chemm( CblasColMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_chemm( CblasColMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_chemm( CblasColMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_chemm( CblasColMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_chemm( CblasColMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_chemm( CblasColMajor, CblasRight, CblasUpper, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_chemm( CblasColMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_chemm( CblasColMajor, CblasRight, CblasLower, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_chemm( CblasColMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_chemm( CblasColMajor, CblasRight, CblasUpper, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_chemm( CblasColMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_chemm( CblasColMajor, CblasRight, CblasLower, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_chemm( CblasRowMajor, CblasLeft, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_chemm( CblasRowMajor, CblasRight, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_chemm( CblasRowMajor, CblasLeft, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_chemm( CblasRowMajor, CblasRight, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_chemm( CblasRowMajor, CblasLeft, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_chemm( CblasRowMajor, CblasRight, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_chemm( CblasRowMajor, CblasLeft, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_chemm( CblasRowMajor, CblasRight, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_chemm( CblasRowMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_chemm( CblasRowMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_chemm( CblasRowMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_chemm( CblasRowMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_chemm( CblasRowMajor, CblasLeft, CblasUpper, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_chemm( CblasRowMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_chemm( CblasRowMajor, CblasLeft, CblasLower, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_chemm( CblasRowMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_chemm( CblasRowMajor, CblasLeft, CblasUpper, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_chemm( CblasRowMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_chemm( CblasRowMajor, CblasLeft, CblasLower, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_chemm( CblasRowMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_csymm" ,11)==0) { + cblas_rout = "cblas_csymm" ; + + cblas_info = 1; + cblas_csymm( INVALID, CblasRight, CblasLower, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_csymm( CblasColMajor, INVALID, CblasUpper, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_csymm( CblasColMajor, CblasLeft, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_csymm( CblasColMajor, CblasLeft, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_csymm( CblasColMajor, CblasRight, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_csymm( CblasColMajor, CblasLeft, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_csymm( CblasColMajor, CblasRight, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_csymm( CblasColMajor, CblasLeft, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_csymm( CblasColMajor, CblasRight, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_csymm( CblasColMajor, CblasLeft, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_csymm( CblasColMajor, CblasRight, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_csymm( CblasColMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_csymm( CblasColMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_csymm( CblasColMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_csymm( CblasColMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_csymm( CblasColMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_csymm( CblasColMajor, CblasRight, CblasUpper, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_csymm( CblasColMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_csymm( CblasColMajor, CblasRight, CblasLower, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_csymm( CblasColMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_csymm( CblasColMajor, CblasRight, CblasUpper, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_csymm( CblasColMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_csymm( CblasColMajor, CblasRight, CblasLower, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_csymm( CblasRowMajor, CblasLeft, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_csymm( CblasRowMajor, CblasRight, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_csymm( CblasRowMajor, CblasLeft, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_csymm( CblasRowMajor, CblasRight, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_csymm( CblasRowMajor, CblasLeft, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_csymm( CblasRowMajor, CblasRight, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_csymm( CblasRowMajor, CblasLeft, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_csymm( CblasRowMajor, CblasRight, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_csymm( CblasRowMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_csymm( CblasRowMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_csymm( CblasRowMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_csymm( CblasRowMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_csymm( CblasRowMajor, CblasLeft, CblasUpper, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_csymm( CblasRowMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_csymm( CblasRowMajor, CblasLeft, CblasLower, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_csymm( CblasRowMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_csymm( CblasRowMajor, CblasLeft, CblasUpper, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_csymm( CblasRowMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_csymm( CblasRowMajor, CblasLeft, CblasLower, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_csymm( CblasRowMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_ctrmm" ,11)==0) { + cblas_rout = "cblas_ctrmm" ; + + cblas_info = 1; + cblas_ctrmm( INVALID, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasLeft, INVALID, CblasNoTrans, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasLeft, CblasUpper, INVALID, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + INVALID, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ctrmm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ctrmm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_ctrsm" ,11)==0) { + cblas_rout = "cblas_ctrsm" ; + + cblas_info = 1; + cblas_ctrsm( INVALID, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasLeft, INVALID, CblasNoTrans, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasLeft, CblasUpper, INVALID, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + INVALID, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ctrsm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ctrsm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_cherk" ,11)==0) { + cblas_rout = "cblas_cherk" ; + + cblas_info = 1; + cblas_cherk(INVALID, CblasUpper, CblasNoTrans, 0, 0, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_cherk(CblasColMajor, INVALID, CblasNoTrans, 0, 0, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_cherk(CblasColMajor, CblasUpper, CblasTrans, 0, 0, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_cherk(CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_cherk(CblasColMajor, CblasUpper, CblasConjTrans, INVALID, 0, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_cherk(CblasColMajor, CblasLower, CblasNoTrans, INVALID, 0, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_cherk(CblasColMajor, CblasLower, CblasConjTrans, INVALID, 0, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_cherk(CblasColMajor, CblasUpper, CblasNoTrans, 0, INVALID, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_cherk(CblasColMajor, CblasUpper, CblasConjTrans, 0, INVALID, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_cherk(CblasColMajor, CblasLower, CblasNoTrans, 0, INVALID, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_cherk(CblasColMajor, CblasLower, CblasConjTrans, 0, INVALID, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_cherk(CblasRowMajor, CblasUpper, CblasNoTrans, 0, 2, + RALPHA, A, 1, RBETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_cherk(CblasRowMajor, CblasUpper, CblasConjTrans, 2, 0, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_cherk(CblasRowMajor, CblasLower, CblasNoTrans, 0, 2, + RALPHA, A, 1, RBETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_cherk(CblasRowMajor, CblasLower, CblasConjTrans, 2, 0, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_cherk(CblasColMajor, CblasUpper, CblasNoTrans, 2, 0, + RALPHA, A, 1, RBETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_cherk(CblasColMajor, CblasUpper, CblasConjTrans, 0, 2, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_cherk(CblasColMajor, CblasLower, CblasNoTrans, 2, 0, + RALPHA, A, 1, RBETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_cherk(CblasColMajor, CblasLower, CblasConjTrans, 0, 2, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_cherk(CblasRowMajor, CblasUpper, CblasNoTrans, 2, 0, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_cherk(CblasRowMajor, CblasUpper, CblasConjTrans, 2, 0, + RALPHA, A, 2, RBETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_cherk(CblasRowMajor, CblasLower, CblasNoTrans, 2, 0, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_cherk(CblasRowMajor, CblasLower, CblasConjTrans, 2, 0, + RALPHA, A, 2, RBETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_cherk(CblasColMajor, CblasUpper, CblasNoTrans, 2, 0, + RALPHA, A, 2, RBETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_cherk(CblasColMajor, CblasUpper, CblasConjTrans, 2, 0, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_cherk(CblasColMajor, CblasLower, CblasNoTrans, 2, 0, + RALPHA, A, 2, RBETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_cherk(CblasColMajor, CblasLower, CblasConjTrans, 2, 0, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_csyrk" ,11)==0) { + cblas_rout = "cblas_csyrk" ; + + cblas_info = 1; + cblas_csyrk(INVALID, CblasUpper, CblasNoTrans, 0, 0, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_csyrk(CblasColMajor, INVALID, CblasNoTrans, 0, 0, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_csyrk(CblasColMajor, CblasUpper, CblasConjTrans, 0, 0, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_csyrk(CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_csyrk(CblasColMajor, CblasUpper, CblasTrans, INVALID, 0, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_csyrk(CblasColMajor, CblasLower, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_csyrk(CblasColMajor, CblasLower, CblasTrans, INVALID, 0, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_csyrk(CblasColMajor, CblasUpper, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_csyrk(CblasColMajor, CblasUpper, CblasTrans, 0, INVALID, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_csyrk(CblasColMajor, CblasLower, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_csyrk(CblasColMajor, CblasLower, CblasTrans, 0, INVALID, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_csyrk(CblasRowMajor, CblasUpper, CblasNoTrans, 0, 2, + ALPHA, A, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_csyrk(CblasRowMajor, CblasUpper, CblasTrans, 2, 0, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_csyrk(CblasRowMajor, CblasLower, CblasNoTrans, 0, 2, + ALPHA, A, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_csyrk(CblasRowMajor, CblasLower, CblasTrans, 2, 0, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_csyrk(CblasColMajor, CblasUpper, CblasNoTrans, 2, 0, + ALPHA, A, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_csyrk(CblasColMajor, CblasUpper, CblasTrans, 0, 2, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_csyrk(CblasColMajor, CblasLower, CblasNoTrans, 2, 0, + ALPHA, A, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_csyrk(CblasColMajor, CblasLower, CblasTrans, 0, 2, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_csyrk(CblasRowMajor, CblasUpper, CblasNoTrans, 2, 0, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_csyrk(CblasRowMajor, CblasUpper, CblasTrans, 2, 0, + ALPHA, A, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_csyrk(CblasRowMajor, CblasLower, CblasNoTrans, 2, 0, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_csyrk(CblasRowMajor, CblasLower, CblasTrans, 2, 0, + ALPHA, A, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_csyrk(CblasColMajor, CblasUpper, CblasNoTrans, 2, 0, + ALPHA, A, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_csyrk(CblasColMajor, CblasUpper, CblasTrans, 2, 0, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_csyrk(CblasColMajor, CblasLower, CblasNoTrans, 2, 0, + ALPHA, A, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_csyrk(CblasColMajor, CblasLower, CblasTrans, 2, 0, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_cher2k" ,12)==0) { + cblas_rout = "cblas_cher2k" ; + + cblas_info = 1; + cblas_cher2k(INVALID, CblasUpper, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_cher2k(CblasColMajor, INVALID, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_cher2k(CblasColMajor, CblasUpper, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_cher2k(CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_cher2k(CblasColMajor, CblasUpper, CblasConjTrans, INVALID, 0, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_cher2k(CblasColMajor, CblasLower, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_cher2k(CblasColMajor, CblasLower, CblasConjTrans, INVALID, 0, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_cher2k(CblasColMajor, CblasUpper, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_cher2k(CblasColMajor, CblasUpper, CblasConjTrans, 0, INVALID, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_cher2k(CblasColMajor, CblasLower, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_cher2k(CblasColMajor, CblasLower, CblasConjTrans, 0, INVALID, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_cher2k(CblasRowMajor, CblasUpper, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 2, RBETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_cher2k(CblasRowMajor, CblasUpper, CblasConjTrans, 2, 0, + ALPHA, A, 1, B, 2, RBETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_cher2k(CblasRowMajor, CblasLower, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 2, RBETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_cher2k(CblasRowMajor, CblasLower, CblasConjTrans, 2, 0, + ALPHA, A, 1, B, 2, RBETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_cher2k(CblasColMajor, CblasUpper, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 1, RBETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_cher2k(CblasColMajor, CblasUpper, CblasConjTrans, 0, 2, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_cher2k(CblasColMajor, CblasLower, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 1, RBETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_cher2k(CblasColMajor, CblasLower, CblasConjTrans, 0, 2, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_cher2k(CblasRowMajor, CblasUpper, CblasNoTrans, 0, 2, + ALPHA, A, 2, B, 1, RBETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_cher2k(CblasRowMajor, CblasUpper, CblasConjTrans, 2, 0, + ALPHA, A, 2, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_cher2k(CblasRowMajor, CblasLower, CblasNoTrans, 0, 2, + ALPHA, A, 2, B, 1, RBETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_cher2k(CblasRowMajor, CblasLower, CblasConjTrans, 2, 0, + ALPHA, A, 2, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_cher2k(CblasColMajor, CblasUpper, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 1, RBETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_cher2k(CblasColMajor, CblasUpper, CblasConjTrans, 0, 2, + ALPHA, A, 2, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_cher2k(CblasColMajor, CblasLower, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 1, RBETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_cher2k(CblasColMajor, CblasLower, CblasConjTrans, 0, 2, + ALPHA, A, 2, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_cher2k(CblasRowMajor, CblasUpper, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_cher2k(CblasRowMajor, CblasUpper, CblasConjTrans, 2, 0, + ALPHA, A, 2, B, 2, RBETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_cher2k(CblasRowMajor, CblasLower, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_cher2k(CblasRowMajor, CblasLower, CblasConjTrans, 2, 0, + ALPHA, A, 2, B, 2, RBETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_cher2k(CblasColMajor, CblasUpper, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 2, RBETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_cher2k(CblasColMajor, CblasUpper, CblasConjTrans, 2, 0, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_cher2k(CblasColMajor, CblasLower, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 2, RBETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_cher2k(CblasColMajor, CblasLower, CblasConjTrans, 2, 0, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_csyr2k" ,12)==0) { + cblas_rout = "cblas_csyr2k" ; + + cblas_info = 1; + cblas_csyr2k(INVALID, CblasUpper, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_csyr2k(CblasColMajor, INVALID, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_csyr2k(CblasColMajor, CblasUpper, CblasConjTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_csyr2k(CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_csyr2k(CblasColMajor, CblasUpper, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_csyr2k(CblasColMajor, CblasLower, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_csyr2k(CblasColMajor, CblasLower, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_csyr2k(CblasColMajor, CblasUpper, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_csyr2k(CblasColMajor, CblasUpper, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_csyr2k(CblasColMajor, CblasLower, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_csyr2k(CblasColMajor, CblasLower, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_csyr2k(CblasRowMajor, CblasUpper, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_csyr2k(CblasRowMajor, CblasUpper, CblasTrans, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_csyr2k(CblasRowMajor, CblasLower, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_csyr2k(CblasRowMajor, CblasLower, CblasTrans, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_csyr2k(CblasColMajor, CblasUpper, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_csyr2k(CblasColMajor, CblasUpper, CblasTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_csyr2k(CblasColMajor, CblasLower, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_csyr2k(CblasColMajor, CblasLower, CblasTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_csyr2k(CblasRowMajor, CblasUpper, CblasNoTrans, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_csyr2k(CblasRowMajor, CblasUpper, CblasTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_csyr2k(CblasRowMajor, CblasLower, CblasNoTrans, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_csyr2k(CblasRowMajor, CblasLower, CblasTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_csyr2k(CblasColMajor, CblasUpper, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_csyr2k(CblasColMajor, CblasUpper, CblasTrans, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_csyr2k(CblasColMajor, CblasLower, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_csyr2k(CblasColMajor, CblasLower, CblasTrans, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_csyr2k(CblasRowMajor, CblasUpper, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_csyr2k(CblasRowMajor, CblasUpper, CblasTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_csyr2k(CblasRowMajor, CblasLower, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_csyr2k(CblasRowMajor, CblasLower, CblasTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_csyr2k(CblasColMajor, CblasUpper, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_csyr2k(CblasColMajor, CblasUpper, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_csyr2k(CblasColMajor, CblasLower, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_csyr2k(CblasColMajor, CblasLower, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + } + + if (cblas_ok == 1 ) + printf(" %-12s PASSED THE TESTS OF ERROR-EXITS\n", cblas_rout); + else + printf("***** %s FAILED THE TESTS OF ERROR-EXITS *******\n",cblas_rout); +} diff --git a/cblas/testing/c_cblas1.c b/cblas/testing/c_cblas1.c new file mode 100644 index 00000000..31b9d47b --- /dev/null +++ b/cblas/testing/c_cblas1.c @@ -0,0 +1,74 @@ +/* + * c_cblas1.c + * + * The program is a C wrapper for ccblat1. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas_test.h" +#include "cblas.h" +void F77_caxpy(const int *N, const void *alpha, void *X, + const int *incX, void *Y, const int *incY) +{ + cblas_caxpy(*N, alpha, X, *incX, Y, *incY); + return; +} + +void F77_ccopy(const int *N, void *X, const int *incX, + void *Y, const int *incY) +{ + cblas_ccopy(*N, X, *incX, Y, *incY); + return; +} + +void F77_cdotc(const int *N, void *X, const int *incX, + void *Y, const int *incY, void *dotc) +{ + cblas_cdotc_sub(*N, X, *incX, Y, *incY, dotc); + return; +} + +void F77_cdotu(const int *N, void *X, const int *incX, + void *Y, const int *incY,void *dotu) +{ + cblas_cdotu_sub(*N, X, *incX, Y, *incY, dotu); + return; +} + +void F77_cscal(const int *N, const void * *alpha, void *X, + const int *incX) +{ + cblas_cscal(*N, alpha, X, *incX); + return; +} + +void F77_csscal(const int *N, const float *alpha, void *X, + const int *incX) +{ + cblas_csscal(*N, *alpha, X, *incX); + return; +} + +void F77_cswap( const int *N, void *X, const int *incX, + void *Y, const int *incY) +{ + cblas_cswap(*N,X,*incX,Y,*incY); + return; +} + +int F77_icamax(const int *N, const void *X, const int *incX) +{ + if (*N < 1 || *incX < 1) return(0); + return (cblas_icamax(*N, X, *incX)+1); +} + +float F77_scnrm2(const int *N, const void *X, const int *incX) +{ + return cblas_scnrm2(*N, X, *incX); +} + +float F77_scasum(const int *N, void *X, const int *incX) +{ + return cblas_scasum(*N, X, *incX); +} diff --git a/cblas/testing/c_cblas2.c b/cblas/testing/c_cblas2.c new file mode 100644 index 00000000..6ba02769 --- /dev/null +++ b/cblas/testing/c_cblas2.c @@ -0,0 +1,807 @@ +/* + * Written by D.P. Manley, Digital Equipment Corporation. + * Prefixed "C_" to BLAS routines and their declarations. + * + * Modified by T. H. Do, 4/08/98, SGI/CRAY Research. + */ +#include <stdlib.h> +#include "cblas.h" +#include "cblas_test.h" + +void F77_cgemv(int *layout, char *transp, int *m, int *n, + const void *alpha, + CBLAS_TEST_COMPLEX *a, int *lda, const void *x, int *incx, + const void *beta, void *y, int *incy) { + + CBLAS_TEST_COMPLEX *A; + int i,j,LDA; + CBLAS_TRANSPOSE trans; + + get_transpose_type(transp, &trans); + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A = (CBLAS_TEST_COMPLEX *)malloc( (*m)*LDA*sizeof( CBLAS_TEST_COMPLEX) ); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ){ + A[ LDA*i+j ].real=a[ (*lda)*j+i ].real; + A[ LDA*i+j ].imag=a[ (*lda)*j+i ].imag; + } + cblas_cgemv( CblasRowMajor, trans, *m, *n, alpha, A, LDA, x, *incx, + beta, y, *incy ); + free(A); + } + else if (*layout == TEST_COL_MJR) + cblas_cgemv( CblasColMajor, trans, + *m, *n, alpha, a, *lda, x, *incx, beta, y, *incy ); + else + cblas_cgemv( UNDEFINED, trans, + *m, *n, alpha, a, *lda, x, *incx, beta, y, *incy ); +} + +void F77_cgbmv(int *layout, char *transp, int *m, int *n, int *kl, int *ku, + CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, int *lda, + CBLAS_TEST_COMPLEX *x, int *incx, + CBLAS_TEST_COMPLEX *beta, CBLAS_TEST_COMPLEX *y, int *incy) { + + CBLAS_TEST_COMPLEX *A; + int i,j,irow,jcol,LDA; + CBLAS_TRANSPOSE trans; + + get_transpose_type(transp, &trans); + if (*layout == TEST_ROW_MJR) { + LDA = *ku+*kl+2; + A=( CBLAS_TEST_COMPLEX* )malloc((*n+*kl)*LDA*sizeof(CBLAS_TEST_COMPLEX)); + for( i=0; i<*ku; i++ ){ + irow=*ku+*kl-i; + jcol=(*ku)-i; + for( j=jcol; j<*n; j++ ){ + A[ LDA*(j-jcol)+irow ].real=a[ (*lda)*j+i ].real; + A[ LDA*(j-jcol)+irow ].imag=a[ (*lda)*j+i ].imag; + } + } + i=*ku; + irow=*ku+*kl-i; + for( j=0; j<*n; j++ ){ + A[ LDA*j+irow ].real=a[ (*lda)*j+i ].real; + A[ LDA*j+irow ].imag=a[ (*lda)*j+i ].imag; + } + for( i=*ku+1; i<*ku+*kl+1; i++ ){ + irow=*ku+*kl-i; + jcol=i-(*ku); + for( j=jcol; j<(*n+*kl); j++ ){ + A[ LDA*j+irow ].real=a[ (*lda)*(j-jcol)+i ].real; + A[ LDA*j+irow ].imag=a[ (*lda)*(j-jcol)+i ].imag; + } + } + cblas_cgbmv( CblasRowMajor, trans, *m, *n, *kl, *ku, alpha, A, LDA, x, + *incx, beta, y, *incy ); + free(A); + } + else if (*layout == TEST_COL_MJR) + cblas_cgbmv( CblasColMajor, trans, *m, *n, *kl, *ku, alpha, a, *lda, x, + *incx, beta, y, *incy ); + else + cblas_cgbmv( UNDEFINED, trans, *m, *n, *kl, *ku, alpha, a, *lda, x, + *incx, beta, y, *incy ); +} + +void F77_cgeru(int *layout, int *m, int *n, CBLAS_TEST_COMPLEX *alpha, + CBLAS_TEST_COMPLEX *x, int *incx, CBLAS_TEST_COMPLEX *y, int *incy, + CBLAS_TEST_COMPLEX *a, int *lda){ + + CBLAS_TEST_COMPLEX *A; + int i,j,LDA; + + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A=(CBLAS_TEST_COMPLEX*)malloc((*m)*LDA*sizeof(CBLAS_TEST_COMPLEX)); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ){ + A[ LDA*i+j ].real=a[ (*lda)*j+i ].real; + A[ LDA*i+j ].imag=a[ (*lda)*j+i ].imag; + } + cblas_cgeru( CblasRowMajor, *m, *n, alpha, x, *incx, y, *incy, A, LDA ); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ){ + a[ (*lda)*j+i ].real=A[ LDA*i+j ].real; + a[ (*lda)*j+i ].imag=A[ LDA*i+j ].imag; + } + free(A); + } + else if (*layout == TEST_COL_MJR) + cblas_cgeru( CblasColMajor, *m, *n, alpha, x, *incx, y, *incy, a, *lda ); + else + cblas_cgeru( UNDEFINED, *m, *n, alpha, x, *incx, y, *incy, a, *lda ); +} + +void F77_cgerc(int *layout, int *m, int *n, CBLAS_TEST_COMPLEX *alpha, + CBLAS_TEST_COMPLEX *x, int *incx, CBLAS_TEST_COMPLEX *y, int *incy, + CBLAS_TEST_COMPLEX *a, int *lda) { + CBLAS_TEST_COMPLEX *A; + int i,j,LDA; + + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A=(CBLAS_TEST_COMPLEX* )malloc((*m)*LDA*sizeof(CBLAS_TEST_COMPLEX ) ); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ){ + A[ LDA*i+j ].real=a[ (*lda)*j+i ].real; + A[ LDA*i+j ].imag=a[ (*lda)*j+i ].imag; + } + cblas_cgerc( CblasRowMajor, *m, *n, alpha, x, *incx, y, *incy, A, LDA ); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ){ + a[ (*lda)*j+i ].real=A[ LDA*i+j ].real; + a[ (*lda)*j+i ].imag=A[ LDA*i+j ].imag; + } + free(A); + } + else if (*layout == TEST_COL_MJR) + cblas_cgerc( CblasColMajor, *m, *n, alpha, x, *incx, y, *incy, a, *lda ); + else + cblas_cgerc( UNDEFINED, *m, *n, alpha, x, *incx, y, *incy, a, *lda ); +} + +void F77_chemv(int *layout, char *uplow, int *n, CBLAS_TEST_COMPLEX *alpha, + CBLAS_TEST_COMPLEX *a, int *lda, CBLAS_TEST_COMPLEX *x, + int *incx, CBLAS_TEST_COMPLEX *beta, CBLAS_TEST_COMPLEX *y, int *incy){ + + CBLAS_TEST_COMPLEX *A; + int i,j,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A = (CBLAS_TEST_COMPLEX *)malloc((*n)*LDA*sizeof(CBLAS_TEST_COMPLEX)); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ){ + A[ LDA*i+j ].real=a[ (*lda)*j+i ].real; + A[ LDA*i+j ].imag=a[ (*lda)*j+i ].imag; + } + cblas_chemv( CblasRowMajor, uplo, *n, alpha, A, LDA, x, *incx, + beta, y, *incy ); + free(A); + } + else if (*layout == TEST_COL_MJR) + cblas_chemv( CblasColMajor, uplo, *n, alpha, a, *lda, x, *incx, + beta, y, *incy ); + else + cblas_chemv( UNDEFINED, uplo, *n, alpha, a, *lda, x, *incx, + beta, y, *incy ); +} + +void F77_chbmv(int *layout, char *uplow, int *n, int *k, + CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, int *lda, + CBLAS_TEST_COMPLEX *x, int *incx, CBLAS_TEST_COMPLEX *beta, + CBLAS_TEST_COMPLEX *y, int *incy){ + +CBLAS_TEST_COMPLEX *A; +int i,irow,j,jcol,LDA; + + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + if (uplo != CblasUpper && uplo != CblasLower ) + cblas_chbmv(CblasRowMajor, UNDEFINED, *n, *k, alpha, a, *lda, x, + *incx, beta, y, *incy ); + else { + LDA = *k+2; + A =(CBLAS_TEST_COMPLEX*)malloc((*n+*k)*LDA*sizeof(CBLAS_TEST_COMPLEX)); + if (uplo == CblasUpper) { + for( i=0; i<*k; i++ ){ + irow=*k-i; + jcol=(*k)-i; + for( j=jcol; j<*n; j++ ) { + A[ LDA*(j-jcol)+irow ].real=a[ (*lda)*j+i ].real; + A[ LDA*(j-jcol)+irow ].imag=a[ (*lda)*j+i ].imag; + } + } + i=*k; + irow=*k-i; + for( j=0; j<*n; j++ ) { + A[ LDA*j+irow ].real=a[ (*lda)*j+i ].real; + A[ LDA*j+irow ].imag=a[ (*lda)*j+i ].imag; + } + } + else { + i=0; + irow=*k-i; + for( j=0; j<*n; j++ ) { + A[ LDA*j+irow ].real=a[ (*lda)*j+i ].real; + A[ LDA*j+irow ].imag=a[ (*lda)*j+i ].imag; + } + for( i=1; i<*k+1; i++ ){ + irow=*k-i; + jcol=i; + for( j=jcol; j<(*n+*k); j++ ) { + A[ LDA*j+irow ].real=a[ (*lda)*(j-jcol)+i ].real; + A[ LDA*j+irow ].imag=a[ (*lda)*(j-jcol)+i ].imag; + } + } + } + cblas_chbmv( CblasRowMajor, uplo, *n, *k, alpha, A, LDA, x, *incx, + beta, y, *incy ); + free(A); + } + } + else if (*layout == TEST_COL_MJR) + cblas_chbmv(CblasColMajor, uplo, *n, *k, alpha, a, *lda, x, *incx, + beta, y, *incy ); + else + cblas_chbmv(UNDEFINED, uplo, *n, *k, alpha, a, *lda, x, *incx, + beta, y, *incy ); +} + +void F77_chpmv(int *layout, char *uplow, int *n, CBLAS_TEST_COMPLEX *alpha, + CBLAS_TEST_COMPLEX *ap, CBLAS_TEST_COMPLEX *x, int *incx, + CBLAS_TEST_COMPLEX *beta, CBLAS_TEST_COMPLEX *y, int *incy){ + + CBLAS_TEST_COMPLEX *A, *AP; + int i,j,k,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + if (*layout == TEST_ROW_MJR) { + if (uplo != CblasUpper && uplo != CblasLower ) + cblas_chpmv(CblasRowMajor, UNDEFINED, *n, alpha, ap, x, *incx, + beta, y, *incy); + else { + LDA = *n; + A = (CBLAS_TEST_COMPLEX* )malloc(LDA*LDA*sizeof(CBLAS_TEST_COMPLEX )); + AP = (CBLAS_TEST_COMPLEX* )malloc( (((LDA+1)*LDA)/2)* + sizeof( CBLAS_TEST_COMPLEX )); + if (uplo == CblasUpper) { + for( j=0, k=0; j<*n; j++ ) + for( i=0; i<j+1; i++, k++ ) { + A[ LDA*i+j ].real=ap[ k ].real; + A[ LDA*i+j ].imag=ap[ k ].imag; + } + for( i=0, k=0; i<*n; i++ ) + for( j=i; j<*n; j++, k++ ) { + AP[ k ].real=A[ LDA*i+j ].real; + AP[ k ].imag=A[ LDA*i+j ].imag; + } + } + else { + for( j=0, k=0; j<*n; j++ ) + for( i=j; i<*n; i++, k++ ) { + A[ LDA*i+j ].real=ap[ k ].real; + A[ LDA*i+j ].imag=ap[ k ].imag; + } + for( i=0, k=0; i<*n; i++ ) + for( j=0; j<i+1; j++, k++ ) { + AP[ k ].real=A[ LDA*i+j ].real; + AP[ k ].imag=A[ LDA*i+j ].imag; + } + } + cblas_chpmv( CblasRowMajor, uplo, *n, alpha, AP, x, *incx, beta, y, + *incy ); + free(A); + free(AP); + } + } + else if (*layout == TEST_COL_MJR) + cblas_chpmv( CblasColMajor, uplo, *n, alpha, ap, x, *incx, beta, y, + *incy ); + else + cblas_chpmv( UNDEFINED, uplo, *n, alpha, ap, x, *incx, beta, y, + *incy ); +} + +void F77_ctbmv(int *layout, char *uplow, char *transp, char *diagn, + int *n, int *k, CBLAS_TEST_COMPLEX *a, int *lda, CBLAS_TEST_COMPLEX *x, + int *incx) { + CBLAS_TEST_COMPLEX *A; + int irow, jcol, i, j, LDA; + CBLAS_TRANSPOSE trans; + CBLAS_UPLO uplo; + CBLAS_DIAG diag; + + get_transpose_type(transp,&trans); + get_uplo_type(uplow,&uplo); + get_diag_type(diagn,&diag); + + if (*layout == TEST_ROW_MJR) { + if (uplo != CblasUpper && uplo != CblasLower ) + cblas_ctbmv(CblasRowMajor, UNDEFINED, trans, diag, *n, *k, a, *lda, + x, *incx); + else { + LDA = *k+2; + A=(CBLAS_TEST_COMPLEX *)malloc((*n+*k)*LDA*sizeof(CBLAS_TEST_COMPLEX)); + if (uplo == CblasUpper) { + for( i=0; i<*k; i++ ){ + irow=*k-i; + jcol=(*k)-i; + for( j=jcol; j<*n; j++ ) { + A[ LDA*(j-jcol)+irow ].real=a[ (*lda)*j+i ].real; + A[ LDA*(j-jcol)+irow ].imag=a[ (*lda)*j+i ].imag; + } + } + i=*k; + irow=*k-i; + for( j=0; j<*n; j++ ) { + A[ LDA*j+irow ].real=a[ (*lda)*j+i ].real; + A[ LDA*j+irow ].imag=a[ (*lda)*j+i ].imag; + } + } + else { + i=0; + irow=*k-i; + for( j=0; j<*n; j++ ) { + A[ LDA*j+irow ].real=a[ (*lda)*j+i ].real; + A[ LDA*j+irow ].imag=a[ (*lda)*j+i ].imag; + } + for( i=1; i<*k+1; i++ ){ + irow=*k-i; + jcol=i; + for( j=jcol; j<(*n+*k); j++ ) { + A[ LDA*j+irow ].real=a[ (*lda)*(j-jcol)+i ].real; + A[ LDA*j+irow ].imag=a[ (*lda)*(j-jcol)+i ].imag; + } + } + } + cblas_ctbmv(CblasRowMajor, uplo, trans, diag, *n, *k, A, LDA, x, + *incx); + free(A); + } + } + else if (*layout == TEST_COL_MJR) + cblas_ctbmv(CblasColMajor, uplo, trans, diag, *n, *k, a, *lda, x, *incx); + else + cblas_ctbmv(UNDEFINED, uplo, trans, diag, *n, *k, a, *lda, x, *incx); +} + +void F77_ctbsv(int *layout, char *uplow, char *transp, char *diagn, + int *n, int *k, CBLAS_TEST_COMPLEX *a, int *lda, CBLAS_TEST_COMPLEX *x, + int *incx) { + + CBLAS_TEST_COMPLEX *A; + int irow, jcol, i, j, LDA; + CBLAS_TRANSPOSE trans; + CBLAS_UPLO uplo; + CBLAS_DIAG diag; + + get_transpose_type(transp,&trans); + get_uplo_type(uplow,&uplo); + get_diag_type(diagn,&diag); + + if (*layout == TEST_ROW_MJR) { + if (uplo != CblasUpper && uplo != CblasLower ) + cblas_ctbsv(CblasRowMajor, UNDEFINED, trans, diag, *n, *k, a, *lda, x, + *incx); + else { + LDA = *k+2; + A=(CBLAS_TEST_COMPLEX*)malloc((*n+*k)*LDA*sizeof(CBLAS_TEST_COMPLEX )); + if (uplo == CblasUpper) { + for( i=0; i<*k; i++ ){ + irow=*k-i; + jcol=(*k)-i; + for( j=jcol; j<*n; j++ ) { + A[ LDA*(j-jcol)+irow ].real=a[ (*lda)*j+i ].real; + A[ LDA*(j-jcol)+irow ].imag=a[ (*lda)*j+i ].imag; + } + } + i=*k; + irow=*k-i; + for( j=0; j<*n; j++ ) { + A[ LDA*j+irow ].real=a[ (*lda)*j+i ].real; + A[ LDA*j+irow ].imag=a[ (*lda)*j+i ].imag; + } + } + else { + i=0; + irow=*k-i; + for( j=0; j<*n; j++ ) { + A[ LDA*j+irow ].real=a[ (*lda)*j+i ].real; + A[ LDA*j+irow ].imag=a[ (*lda)*j+i ].imag; + } + for( i=1; i<*k+1; i++ ){ + irow=*k-i; + jcol=i; + for( j=jcol; j<(*n+*k); j++ ) { + A[ LDA*j+irow ].real=a[ (*lda)*(j-jcol)+i ].real; + A[ LDA*j+irow ].imag=a[ (*lda)*(j-jcol)+i ].imag; + } + } + } + cblas_ctbsv(CblasRowMajor, uplo, trans, diag, *n, *k, A, LDA, + x, *incx); + free(A); + } + } + else if (*layout == TEST_COL_MJR) + cblas_ctbsv(CblasColMajor, uplo, trans, diag, *n, *k, a, *lda, x, *incx); + else + cblas_ctbsv(UNDEFINED, uplo, trans, diag, *n, *k, a, *lda, x, *incx); +} + +void F77_ctpmv(int *layout, char *uplow, char *transp, char *diagn, + int *n, CBLAS_TEST_COMPLEX *ap, CBLAS_TEST_COMPLEX *x, int *incx) { + CBLAS_TEST_COMPLEX *A, *AP; + int i, j, k, LDA; + CBLAS_TRANSPOSE trans; + CBLAS_UPLO uplo; + CBLAS_DIAG diag; + + get_transpose_type(transp,&trans); + get_uplo_type(uplow,&uplo); + get_diag_type(diagn,&diag); + + if (*layout == TEST_ROW_MJR) { + if (uplo != CblasUpper && uplo != CblasLower ) + cblas_ctpmv( CblasRowMajor, UNDEFINED, trans, diag, *n, ap, x, *incx ); + else { + LDA = *n; + A=(CBLAS_TEST_COMPLEX*)malloc(LDA*LDA*sizeof(CBLAS_TEST_COMPLEX)); + AP=(CBLAS_TEST_COMPLEX*)malloc((((LDA+1)*LDA)/2)* + sizeof(CBLAS_TEST_COMPLEX)); + if (uplo == CblasUpper) { + for( j=0, k=0; j<*n; j++ ) + for( i=0; i<j+1; i++, k++ ) { + A[ LDA*i+j ].real=ap[ k ].real; + A[ LDA*i+j ].imag=ap[ k ].imag; + } + for( i=0, k=0; i<*n; i++ ) + for( j=i; j<*n; j++, k++ ) { + AP[ k ].real=A[ LDA*i+j ].real; + AP[ k ].imag=A[ LDA*i+j ].imag; + } + } + else { + for( j=0, k=0; j<*n; j++ ) + for( i=j; i<*n; i++, k++ ) { + A[ LDA*i+j ].real=ap[ k ].real; + A[ LDA*i+j ].imag=ap[ k ].imag; + } + for( i=0, k=0; i<*n; i++ ) + for( j=0; j<i+1; j++, k++ ) { + AP[ k ].real=A[ LDA*i+j ].real; + AP[ k ].imag=A[ LDA*i+j ].imag; + } + } + cblas_ctpmv( CblasRowMajor, uplo, trans, diag, *n, AP, x, *incx ); + free(A); + free(AP); + } + } + else if (*layout == TEST_COL_MJR) + cblas_ctpmv( CblasColMajor, uplo, trans, diag, *n, ap, x, *incx ); + else + cblas_ctpmv( UNDEFINED, uplo, trans, diag, *n, ap, x, *incx ); +} + +void F77_ctpsv(int *layout, char *uplow, char *transp, char *diagn, + int *n, CBLAS_TEST_COMPLEX *ap, CBLAS_TEST_COMPLEX *x, int *incx) { + CBLAS_TEST_COMPLEX *A, *AP; + int i, j, k, LDA; + CBLAS_TRANSPOSE trans; + CBLAS_UPLO uplo; + CBLAS_DIAG diag; + + get_transpose_type(transp,&trans); + get_uplo_type(uplow,&uplo); + get_diag_type(diagn,&diag); + + if (*layout == TEST_ROW_MJR) { + if (uplo != CblasUpper && uplo != CblasLower ) + cblas_ctpsv( CblasRowMajor, UNDEFINED, trans, diag, *n, ap, x, *incx ); + else { + LDA = *n; + A=(CBLAS_TEST_COMPLEX*)malloc(LDA*LDA*sizeof(CBLAS_TEST_COMPLEX)); + AP=(CBLAS_TEST_COMPLEX*)malloc((((LDA+1)*LDA)/2)* + sizeof(CBLAS_TEST_COMPLEX)); + if (uplo == CblasUpper) { + for( j=0, k=0; j<*n; j++ ) + for( i=0; i<j+1; i++, k++ ) { + A[ LDA*i+j ].real=ap[ k ].real; + A[ LDA*i+j ].imag=ap[ k ].imag; + } + for( i=0, k=0; i<*n; i++ ) + for( j=i; j<*n; j++, k++ ) { + AP[ k ].real=A[ LDA*i+j ].real; + AP[ k ].imag=A[ LDA*i+j ].imag; + } + } + else { + for( j=0, k=0; j<*n; j++ ) + for( i=j; i<*n; i++, k++ ) { + A[ LDA*i+j ].real=ap[ k ].real; + A[ LDA*i+j ].imag=ap[ k ].imag; + } + for( i=0, k=0; i<*n; i++ ) + for( j=0; j<i+1; j++, k++ ) { + AP[ k ].real=A[ LDA*i+j ].real; + AP[ k ].imag=A[ LDA*i+j ].imag; + } + } + cblas_ctpsv( CblasRowMajor, uplo, trans, diag, *n, AP, x, *incx ); + free(A); + free(AP); + } + } + else if (*layout == TEST_COL_MJR) + cblas_ctpsv( CblasColMajor, uplo, trans, diag, *n, ap, x, *incx ); + else + cblas_ctpsv( UNDEFINED, uplo, trans, diag, *n, ap, x, *incx ); +} + +void F77_ctrmv(int *layout, char *uplow, char *transp, char *diagn, + int *n, CBLAS_TEST_COMPLEX *a, int *lda, CBLAS_TEST_COMPLEX *x, + int *incx) { + CBLAS_TEST_COMPLEX *A; + int i,j,LDA; + CBLAS_TRANSPOSE trans; + CBLAS_UPLO uplo; + CBLAS_DIAG diag; + + get_transpose_type(transp,&trans); + get_uplo_type(uplow,&uplo); + get_diag_type(diagn,&diag); + + if (*layout == TEST_ROW_MJR) { + LDA=*n+1; + A=(CBLAS_TEST_COMPLEX*)malloc((*n)*LDA*sizeof(CBLAS_TEST_COMPLEX)); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) { + A[ LDA*i+j ].real=a[ (*lda)*j+i ].real; + A[ LDA*i+j ].imag=a[ (*lda)*j+i ].imag; + } + cblas_ctrmv(CblasRowMajor, uplo, trans, diag, *n, A, LDA, x, *incx); + free(A); + } + else if (*layout == TEST_COL_MJR) + cblas_ctrmv(CblasColMajor, uplo, trans, diag, *n, a, *lda, x, *incx); + else + cblas_ctrmv(UNDEFINED, uplo, trans, diag, *n, a, *lda, x, *incx); +} +void F77_ctrsv(int *layout, char *uplow, char *transp, char *diagn, + int *n, CBLAS_TEST_COMPLEX *a, int *lda, CBLAS_TEST_COMPLEX *x, + int *incx) { + CBLAS_TEST_COMPLEX *A; + int i,j,LDA; + CBLAS_TRANSPOSE trans; + CBLAS_UPLO uplo; + CBLAS_DIAG diag; + + get_transpose_type(transp,&trans); + get_uplo_type(uplow,&uplo); + get_diag_type(diagn,&diag); + + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A =(CBLAS_TEST_COMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_COMPLEX ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) { + A[ LDA*i+j ].real=a[ (*lda)*j+i ].real; + A[ LDA*i+j ].imag=a[ (*lda)*j+i ].imag; + } + cblas_ctrsv(CblasRowMajor, uplo, trans, diag, *n, A, LDA, x, *incx ); + free(A); + } + else if (*layout == TEST_COL_MJR) + cblas_ctrsv(CblasColMajor, uplo, trans, diag, *n, a, *lda, x, *incx ); + else + cblas_ctrsv(UNDEFINED, uplo, trans, diag, *n, a, *lda, x, *incx ); +} + +void F77_chpr(int *layout, char *uplow, int *n, float *alpha, + CBLAS_TEST_COMPLEX *x, int *incx, CBLAS_TEST_COMPLEX *ap) { + CBLAS_TEST_COMPLEX *A, *AP; + int i,j,k,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + if (uplo != CblasUpper && uplo != CblasLower ) + cblas_chpr(CblasRowMajor, UNDEFINED, *n, *alpha, x, *incx, ap ); + else { + LDA = *n; + A = (CBLAS_TEST_COMPLEX* )malloc(LDA*LDA*sizeof(CBLAS_TEST_COMPLEX ) ); + AP = ( CBLAS_TEST_COMPLEX* )malloc( (((LDA+1)*LDA)/2)* + sizeof( CBLAS_TEST_COMPLEX )); + if (uplo == CblasUpper) { + for( j=0, k=0; j<*n; j++ ) + for( i=0; i<j+1; i++, k++ ){ + A[ LDA*i+j ].real=ap[ k ].real; + A[ LDA*i+j ].imag=ap[ k ].imag; + } + for( i=0, k=0; i<*n; i++ ) + for( j=i; j<*n; j++, k++ ){ + AP[ k ].real=A[ LDA*i+j ].real; + AP[ k ].imag=A[ LDA*i+j ].imag; + } + } + else { + for( j=0, k=0; j<*n; j++ ) + for( i=j; i<*n; i++, k++ ){ + A[ LDA*i+j ].real=ap[ k ].real; + A[ LDA*i+j ].imag=ap[ k ].imag; + } + for( i=0, k=0; i<*n; i++ ) + for( j=0; j<i+1; j++, k++ ){ + AP[ k ].real=A[ LDA*i+j ].real; + AP[ k ].imag=A[ LDA*i+j ].imag; + } + } + cblas_chpr(CblasRowMajor, uplo, *n, *alpha, x, *incx, AP ); + if (uplo == CblasUpper) { + for( i=0, k=0; i<*n; i++ ) + for( j=i; j<*n; j++, k++ ){ + A[ LDA*i+j ].real=AP[ k ].real; + A[ LDA*i+j ].imag=AP[ k ].imag; + } + for( j=0, k=0; j<*n; j++ ) + for( i=0; i<j+1; i++, k++ ){ + ap[ k ].real=A[ LDA*i+j ].real; + ap[ k ].imag=A[ LDA*i+j ].imag; + } + } + else { + for( i=0, k=0; i<*n; i++ ) + for( j=0; j<i+1; j++, k++ ){ + A[ LDA*i+j ].real=AP[ k ].real; + A[ LDA*i+j ].imag=AP[ k ].imag; + } + for( j=0, k=0; j<*n; j++ ) + for( i=j; i<*n; i++, k++ ){ + ap[ k ].real=A[ LDA*i+j ].real; + ap[ k ].imag=A[ LDA*i+j ].imag; + } + } + free(A); + free(AP); + } + } + else if (*layout == TEST_COL_MJR) + cblas_chpr(CblasColMajor, uplo, *n, *alpha, x, *incx, ap ); + else + cblas_chpr(UNDEFINED, uplo, *n, *alpha, x, *incx, ap ); +} + +void F77_chpr2(int *layout, char *uplow, int *n, CBLAS_TEST_COMPLEX *alpha, + CBLAS_TEST_COMPLEX *x, int *incx, CBLAS_TEST_COMPLEX *y, int *incy, + CBLAS_TEST_COMPLEX *ap) { + CBLAS_TEST_COMPLEX *A, *AP; + int i,j,k,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + if (uplo != CblasUpper && uplo != CblasLower ) + cblas_chpr2( CblasRowMajor, UNDEFINED, *n, alpha, x, *incx, y, + *incy, ap ); + else { + LDA = *n; + A=(CBLAS_TEST_COMPLEX*)malloc( LDA*LDA*sizeof(CBLAS_TEST_COMPLEX ) ); + AP=(CBLAS_TEST_COMPLEX*)malloc( (((LDA+1)*LDA)/2)* + sizeof( CBLAS_TEST_COMPLEX )); + if (uplo == CblasUpper) { + for( j=0, k=0; j<*n; j++ ) + for( i=0; i<j+1; i++, k++ ) { + A[ LDA*i+j ].real=ap[ k ].real; + A[ LDA*i+j ].imag=ap[ k ].imag; + } + for( i=0, k=0; i<*n; i++ ) + for( j=i; j<*n; j++, k++ ) { + AP[ k ].real=A[ LDA*i+j ].real; + AP[ k ].imag=A[ LDA*i+j ].imag; + } + } + else { + for( j=0, k=0; j<*n; j++ ) + for( i=j; i<*n; i++, k++ ) { + A[ LDA*i+j ].real=ap[ k ].real; + A[ LDA*i+j ].imag=ap[ k ].imag; + } + for( i=0, k=0; i<*n; i++ ) + for( j=0; j<i+1; j++, k++ ) { + AP[ k ].real=A[ LDA*i+j ].real; + AP[ k ].imag=A[ LDA*i+j ].imag; + } + } + cblas_chpr2( CblasRowMajor, uplo, *n, alpha, x, *incx, y, *incy, AP ); + if (uplo == CblasUpper) { + for( i=0, k=0; i<*n; i++ ) + for( j=i; j<*n; j++, k++ ) { + A[ LDA*i+j ].real=AP[ k ].real; + A[ LDA*i+j ].imag=AP[ k ].imag; + } + for( j=0, k=0; j<*n; j++ ) + for( i=0; i<j+1; i++, k++ ) { + ap[ k ].real=A[ LDA*i+j ].real; + ap[ k ].imag=A[ LDA*i+j ].imag; + } + } + else { + for( i=0, k=0; i<*n; i++ ) + for( j=0; j<i+1; j++, k++ ) { + A[ LDA*i+j ].real=AP[ k ].real; + A[ LDA*i+j ].imag=AP[ k ].imag; + } + for( j=0, k=0; j<*n; j++ ) + for( i=j; i<*n; i++, k++ ) { + ap[ k ].real=A[ LDA*i+j ].real; + ap[ k ].imag=A[ LDA*i+j ].imag; + } + } + free(A); + free(AP); + } + } + else if (*layout == TEST_COL_MJR) + cblas_chpr2( CblasColMajor, uplo, *n, alpha, x, *incx, y, *incy, ap ); + else + cblas_chpr2( UNDEFINED, uplo, *n, alpha, x, *incx, y, *incy, ap ); +} + +void F77_cher(int *layout, char *uplow, int *n, float *alpha, + CBLAS_TEST_COMPLEX *x, int *incx, CBLAS_TEST_COMPLEX *a, int *lda) { + CBLAS_TEST_COMPLEX *A; + int i,j,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A=(CBLAS_TEST_COMPLEX*)malloc((*n)*LDA*sizeof( CBLAS_TEST_COMPLEX )); + + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) { + A[ LDA*i+j ].real=a[ (*lda)*j+i ].real; + A[ LDA*i+j ].imag=a[ (*lda)*j+i ].imag; + } + + cblas_cher(CblasRowMajor, uplo, *n, *alpha, x, *incx, A, LDA ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) { + a[ (*lda)*j+i ].real=A[ LDA*i+j ].real; + a[ (*lda)*j+i ].imag=A[ LDA*i+j ].imag; + } + free(A); + } + else if (*layout == TEST_COL_MJR) + cblas_cher( CblasColMajor, uplo, *n, *alpha, x, *incx, a, *lda ); + else + cblas_cher( UNDEFINED, uplo, *n, *alpha, x, *incx, a, *lda ); +} + +void F77_cher2(int *layout, char *uplow, int *n, CBLAS_TEST_COMPLEX *alpha, + CBLAS_TEST_COMPLEX *x, int *incx, CBLAS_TEST_COMPLEX *y, int *incy, + CBLAS_TEST_COMPLEX *a, int *lda) { + + CBLAS_TEST_COMPLEX *A; + int i,j,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A= ( CBLAS_TEST_COMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_COMPLEX ) ); + + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) { + A[ LDA*i+j ].real=a[ (*lda)*j+i ].real; + A[ LDA*i+j ].imag=a[ (*lda)*j+i ].imag; + } + + cblas_cher2(CblasRowMajor, uplo, *n, alpha, x, *incx, y, *incy, A, LDA ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) { + a[ (*lda)*j+i ].real=A[ LDA*i+j ].real; + a[ (*lda)*j+i ].imag=A[ LDA*i+j ].imag; + } + free(A); + } + else if (*layout == TEST_COL_MJR) + cblas_cher2( CblasColMajor, uplo, *n, alpha, x, *incx, y, *incy, a, *lda); + else + cblas_cher2( UNDEFINED, uplo, *n, alpha, x, *incx, y, *incy, a, *lda); +} diff --git a/cblas/testing/c_cblas3.c b/cblas/testing/c_cblas3.c new file mode 100644 index 00000000..5e4b8b38 --- /dev/null +++ b/cblas/testing/c_cblas3.c @@ -0,0 +1,564 @@ +/* + * Written by D.P. Manley, Digital Equipment Corporation. + * Prefixed "C_" to BLAS routines and their declarations. + * + * Modified by T. H. Do, 4/15/98, SGI/CRAY Research. + */ +#include <stdlib.h> +#include "cblas.h" +#include "cblas_test.h" +#define TEST_COL_MJR 0 +#define TEST_ROW_MJR 1 +#define UNDEFINED -1 + +void F77_cgemm(int *layout, char *transpa, char *transpb, int *m, int *n, + int *k, CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, int *lda, + CBLAS_TEST_COMPLEX *b, int *ldb, CBLAS_TEST_COMPLEX *beta, + CBLAS_TEST_COMPLEX *c, int *ldc ) { + + CBLAS_TEST_COMPLEX *A, *B, *C; + int i,j,LDA, LDB, LDC; + CBLAS_TRANSPOSE transa, transb; + + get_transpose_type(transpa, &transa); + get_transpose_type(transpb, &transb); + + if (*layout == TEST_ROW_MJR) { + if (transa == CblasNoTrans) { + LDA = *k+1; + A=(CBLAS_TEST_COMPLEX*)malloc((*m)*LDA*sizeof(CBLAS_TEST_COMPLEX)); + for( i=0; i<*m; i++ ) + for( j=0; j<*k; j++ ) { + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + } + } + else { + LDA = *m+1; + A=(CBLAS_TEST_COMPLEX* )malloc(LDA*(*k)*sizeof(CBLAS_TEST_COMPLEX)); + for( i=0; i<*k; i++ ) + for( j=0; j<*m; j++ ) { + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + } + } + + if (transb == CblasNoTrans) { + LDB = *n+1; + B=(CBLAS_TEST_COMPLEX* )malloc((*k)*LDB*sizeof(CBLAS_TEST_COMPLEX) ); + for( i=0; i<*k; i++ ) + for( j=0; j<*n; j++ ) { + B[i*LDB+j].real=b[j*(*ldb)+i].real; + B[i*LDB+j].imag=b[j*(*ldb)+i].imag; + } + } + else { + LDB = *k+1; + B=(CBLAS_TEST_COMPLEX* )malloc(LDB*(*n)*sizeof(CBLAS_TEST_COMPLEX)); + for( i=0; i<*n; i++ ) + for( j=0; j<*k; j++ ) { + B[i*LDB+j].real=b[j*(*ldb)+i].real; + B[i*LDB+j].imag=b[j*(*ldb)+i].imag; + } + } + + LDC = *n+1; + C=(CBLAS_TEST_COMPLEX* )malloc((*m)*LDC*sizeof(CBLAS_TEST_COMPLEX)); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) { + C[i*LDC+j].real=c[j*(*ldc)+i].real; + C[i*LDC+j].imag=c[j*(*ldc)+i].imag; + } + cblas_cgemm( CblasRowMajor, transa, transb, *m, *n, *k, alpha, A, LDA, + B, LDB, beta, C, LDC ); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) { + c[j*(*ldc)+i].real=C[i*LDC+j].real; + c[j*(*ldc)+i].imag=C[i*LDC+j].imag; + } + free(A); + free(B); + free(C); + } + else if (*layout == TEST_COL_MJR) + cblas_cgemm( CblasColMajor, transa, transb, *m, *n, *k, alpha, a, *lda, + b, *ldb, beta, c, *ldc ); + else + cblas_cgemm( UNDEFINED, transa, transb, *m, *n, *k, alpha, a, *lda, + b, *ldb, beta, c, *ldc ); +} +void F77_chemm(int *layout, char *rtlf, char *uplow, int *m, int *n, + CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, int *lda, + CBLAS_TEST_COMPLEX *b, int *ldb, CBLAS_TEST_COMPLEX *beta, + CBLAS_TEST_COMPLEX *c, int *ldc ) { + + CBLAS_TEST_COMPLEX *A, *B, *C; + int i,j,LDA, LDB, LDC; + CBLAS_UPLO uplo; + CBLAS_SIDE side; + + get_uplo_type(uplow,&uplo); + get_side_type(rtlf,&side); + + if (*layout == TEST_ROW_MJR) { + if (side == CblasLeft) { + LDA = *m+1; + A= (CBLAS_TEST_COMPLEX* )malloc((*m)*LDA*sizeof(CBLAS_TEST_COMPLEX)); + for( i=0; i<*m; i++ ) + for( j=0; j<*m; j++ ) { + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + } + } + else{ + LDA = *n+1; + A=(CBLAS_TEST_COMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_COMPLEX ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) { + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + } + } + LDB = *n+1; + B=(CBLAS_TEST_COMPLEX* )malloc( (*m)*LDB*sizeof(CBLAS_TEST_COMPLEX ) ); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ) { + B[i*LDB+j].real=b[j*(*ldb)+i].real; + B[i*LDB+j].imag=b[j*(*ldb)+i].imag; + } + LDC = *n+1; + C=(CBLAS_TEST_COMPLEX* )malloc((*m)*LDC*sizeof(CBLAS_TEST_COMPLEX ) ); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) { + C[i*LDC+j].real=c[j*(*ldc)+i].real; + C[i*LDC+j].imag=c[j*(*ldc)+i].imag; + } + cblas_chemm( CblasRowMajor, side, uplo, *m, *n, alpha, A, LDA, B, LDB, + beta, C, LDC ); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) { + c[j*(*ldc)+i].real=C[i*LDC+j].real; + c[j*(*ldc)+i].imag=C[i*LDC+j].imag; + } + free(A); + free(B); + free(C); + } + else if (*layout == TEST_COL_MJR) + cblas_chemm( CblasColMajor, side, uplo, *m, *n, alpha, a, *lda, b, *ldb, + beta, c, *ldc ); + else + cblas_chemm( UNDEFINED, side, uplo, *m, *n, alpha, a, *lda, b, *ldb, + beta, c, *ldc ); +} +void F77_csymm(int *layout, char *rtlf, char *uplow, int *m, int *n, + CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, int *lda, + CBLAS_TEST_COMPLEX *b, int *ldb, CBLAS_TEST_COMPLEX *beta, + CBLAS_TEST_COMPLEX *c, int *ldc ) { + + CBLAS_TEST_COMPLEX *A, *B, *C; + int i,j,LDA, LDB, LDC; + CBLAS_UPLO uplo; + CBLAS_SIDE side; + + get_uplo_type(uplow,&uplo); + get_side_type(rtlf,&side); + + if (*layout == TEST_ROW_MJR) { + if (side == CblasLeft) { + LDA = *m+1; + A=(CBLAS_TEST_COMPLEX* )malloc((*m)*LDA*sizeof(CBLAS_TEST_COMPLEX)); + for( i=0; i<*m; i++ ) + for( j=0; j<*m; j++ ) + A[i*LDA+j]=a[j*(*lda)+i]; + } + else{ + LDA = *n+1; + A=(CBLAS_TEST_COMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_COMPLEX ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + A[i*LDA+j]=a[j*(*lda)+i]; + } + LDB = *n+1; + B=(CBLAS_TEST_COMPLEX* )malloc((*m)*LDB*sizeof(CBLAS_TEST_COMPLEX )); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ) + B[i*LDB+j]=b[j*(*ldb)+i]; + LDC = *n+1; + C=(CBLAS_TEST_COMPLEX* )malloc((*m)*LDC*sizeof(CBLAS_TEST_COMPLEX)); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) + C[i*LDC+j]=c[j*(*ldc)+i]; + cblas_csymm( CblasRowMajor, side, uplo, *m, *n, alpha, A, LDA, B, LDB, + beta, C, LDC ); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) + c[j*(*ldc)+i]=C[i*LDC+j]; + free(A); + free(B); + free(C); + } + else if (*layout == TEST_COL_MJR) + cblas_csymm( CblasColMajor, side, uplo, *m, *n, alpha, a, *lda, b, *ldb, + beta, c, *ldc ); + else + cblas_csymm( UNDEFINED, side, uplo, *m, *n, alpha, a, *lda, b, *ldb, + beta, c, *ldc ); +} + +void F77_cherk(int *layout, char *uplow, char *transp, int *n, int *k, + float *alpha, CBLAS_TEST_COMPLEX *a, int *lda, + float *beta, CBLAS_TEST_COMPLEX *c, int *ldc ) { + + int i,j,LDA,LDC; + CBLAS_TEST_COMPLEX *A, *C; + CBLAS_UPLO uplo; + CBLAS_TRANSPOSE trans; + + get_uplo_type(uplow,&uplo); + get_transpose_type(transp,&trans); + + if (*layout == TEST_ROW_MJR) { + if (trans == CblasNoTrans) { + LDA = *k+1; + A=(CBLAS_TEST_COMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_COMPLEX ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*k; j++ ) { + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + } + } + else{ + LDA = *n+1; + A=(CBLAS_TEST_COMPLEX* )malloc((*k)*LDA*sizeof(CBLAS_TEST_COMPLEX ) ); + for( i=0; i<*k; i++ ) + for( j=0; j<*n; j++ ) { + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + } + } + LDC = *n+1; + C=(CBLAS_TEST_COMPLEX* )malloc((*n)*LDC*sizeof(CBLAS_TEST_COMPLEX ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) { + C[i*LDC+j].real=c[j*(*ldc)+i].real; + C[i*LDC+j].imag=c[j*(*ldc)+i].imag; + } + cblas_cherk(CblasRowMajor, uplo, trans, *n, *k, *alpha, A, LDA, *beta, + C, LDC ); + for( j=0; j<*n; j++ ) + for( i=0; i<*n; i++ ) { + c[j*(*ldc)+i].real=C[i*LDC+j].real; + c[j*(*ldc)+i].imag=C[i*LDC+j].imag; + } + free(A); + free(C); + } + else if (*layout == TEST_COL_MJR) + cblas_cherk(CblasColMajor, uplo, trans, *n, *k, *alpha, a, *lda, *beta, + c, *ldc ); + else + cblas_cherk(UNDEFINED, uplo, trans, *n, *k, *alpha, a, *lda, *beta, + c, *ldc ); +} + +void F77_csyrk(int *layout, char *uplow, char *transp, int *n, int *k, + CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, int *lda, + CBLAS_TEST_COMPLEX *beta, CBLAS_TEST_COMPLEX *c, int *ldc ) { + + int i,j,LDA,LDC; + CBLAS_TEST_COMPLEX *A, *C; + CBLAS_UPLO uplo; + CBLAS_TRANSPOSE trans; + + get_uplo_type(uplow,&uplo); + get_transpose_type(transp,&trans); + + if (*layout == TEST_ROW_MJR) { + if (trans == CblasNoTrans) { + LDA = *k+1; + A=(CBLAS_TEST_COMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_COMPLEX)); + for( i=0; i<*n; i++ ) + for( j=0; j<*k; j++ ) { + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + } + } + else{ + LDA = *n+1; + A=(CBLAS_TEST_COMPLEX* )malloc((*k)*LDA*sizeof(CBLAS_TEST_COMPLEX ) ); + for( i=0; i<*k; i++ ) + for( j=0; j<*n; j++ ) { + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + } + } + LDC = *n+1; + C=(CBLAS_TEST_COMPLEX* )malloc((*n)*LDC*sizeof(CBLAS_TEST_COMPLEX ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) { + C[i*LDC+j].real=c[j*(*ldc)+i].real; + C[i*LDC+j].imag=c[j*(*ldc)+i].imag; + } + cblas_csyrk(CblasRowMajor, uplo, trans, *n, *k, alpha, A, LDA, beta, + C, LDC ); + for( j=0; j<*n; j++ ) + for( i=0; i<*n; i++ ) { + c[j*(*ldc)+i].real=C[i*LDC+j].real; + c[j*(*ldc)+i].imag=C[i*LDC+j].imag; + } + free(A); + free(C); + } + else if (*layout == TEST_COL_MJR) + cblas_csyrk(CblasColMajor, uplo, trans, *n, *k, alpha, a, *lda, beta, + c, *ldc ); + else + cblas_csyrk(UNDEFINED, uplo, trans, *n, *k, alpha, a, *lda, beta, + c, *ldc ); +} +void F77_cher2k(int *layout, char *uplow, char *transp, int *n, int *k, + CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, int *lda, + CBLAS_TEST_COMPLEX *b, int *ldb, float *beta, + CBLAS_TEST_COMPLEX *c, int *ldc ) { + int i,j,LDA,LDB,LDC; + CBLAS_TEST_COMPLEX *A, *B, *C; + CBLAS_UPLO uplo; + CBLAS_TRANSPOSE trans; + + get_uplo_type(uplow,&uplo); + get_transpose_type(transp,&trans); + + if (*layout == TEST_ROW_MJR) { + if (trans == CblasNoTrans) { + LDA = *k+1; + LDB = *k+1; + A=(CBLAS_TEST_COMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_COMPLEX )); + B=(CBLAS_TEST_COMPLEX* )malloc((*n)*LDB*sizeof(CBLAS_TEST_COMPLEX )); + for( i=0; i<*n; i++ ) + for( j=0; j<*k; j++ ) { + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + B[i*LDB+j].real=b[j*(*ldb)+i].real; + B[i*LDB+j].imag=b[j*(*ldb)+i].imag; + } + } + else { + LDA = *n+1; + LDB = *n+1; + A=(CBLAS_TEST_COMPLEX* )malloc( LDA*(*k)*sizeof(CBLAS_TEST_COMPLEX ) ); + B=(CBLAS_TEST_COMPLEX* )malloc( LDB*(*k)*sizeof(CBLAS_TEST_COMPLEX ) ); + for( i=0; i<*k; i++ ) + for( j=0; j<*n; j++ ){ + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + B[i*LDB+j].real=b[j*(*ldb)+i].real; + B[i*LDB+j].imag=b[j*(*ldb)+i].imag; + } + } + LDC = *n+1; + C=(CBLAS_TEST_COMPLEX* )malloc( (*n)*LDC*sizeof(CBLAS_TEST_COMPLEX ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) { + C[i*LDC+j].real=c[j*(*ldc)+i].real; + C[i*LDC+j].imag=c[j*(*ldc)+i].imag; + } + cblas_cher2k(CblasRowMajor, uplo, trans, *n, *k, alpha, A, LDA, + B, LDB, *beta, C, LDC ); + for( j=0; j<*n; j++ ) + for( i=0; i<*n; i++ ) { + c[j*(*ldc)+i].real=C[i*LDC+j].real; + c[j*(*ldc)+i].imag=C[i*LDC+j].imag; + } + free(A); + free(B); + free(C); + } + else if (*layout == TEST_COL_MJR) + cblas_cher2k(CblasColMajor, uplo, trans, *n, *k, alpha, a, *lda, + b, *ldb, *beta, c, *ldc ); + else + cblas_cher2k(UNDEFINED, uplo, trans, *n, *k, alpha, a, *lda, + b, *ldb, *beta, c, *ldc ); +} +void F77_csyr2k(int *layout, char *uplow, char *transp, int *n, int *k, + CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, int *lda, + CBLAS_TEST_COMPLEX *b, int *ldb, CBLAS_TEST_COMPLEX *beta, + CBLAS_TEST_COMPLEX *c, int *ldc ) { + int i,j,LDA,LDB,LDC; + CBLAS_TEST_COMPLEX *A, *B, *C; + CBLAS_UPLO uplo; + CBLAS_TRANSPOSE trans; + + get_uplo_type(uplow,&uplo); + get_transpose_type(transp,&trans); + + if (*layout == TEST_ROW_MJR) { + if (trans == CblasNoTrans) { + LDA = *k+1; + LDB = *k+1; + A=(CBLAS_TEST_COMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_COMPLEX)); + B=(CBLAS_TEST_COMPLEX* )malloc((*n)*LDB*sizeof(CBLAS_TEST_COMPLEX)); + for( i=0; i<*n; i++ ) + for( j=0; j<*k; j++ ) { + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + B[i*LDB+j].real=b[j*(*ldb)+i].real; + B[i*LDB+j].imag=b[j*(*ldb)+i].imag; + } + } + else { + LDA = *n+1; + LDB = *n+1; + A=(CBLAS_TEST_COMPLEX* )malloc(LDA*(*k)*sizeof(CBLAS_TEST_COMPLEX)); + B=(CBLAS_TEST_COMPLEX* )malloc(LDB*(*k)*sizeof(CBLAS_TEST_COMPLEX)); + for( i=0; i<*k; i++ ) + for( j=0; j<*n; j++ ){ + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + B[i*LDB+j].real=b[j*(*ldb)+i].real; + B[i*LDB+j].imag=b[j*(*ldb)+i].imag; + } + } + LDC = *n+1; + C=(CBLAS_TEST_COMPLEX* )malloc( (*n)*LDC*sizeof(CBLAS_TEST_COMPLEX)); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) { + C[i*LDC+j].real=c[j*(*ldc)+i].real; + C[i*LDC+j].imag=c[j*(*ldc)+i].imag; + } + cblas_csyr2k(CblasRowMajor, uplo, trans, *n, *k, alpha, A, LDA, + B, LDB, beta, C, LDC ); + for( j=0; j<*n; j++ ) + for( i=0; i<*n; i++ ) { + c[j*(*ldc)+i].real=C[i*LDC+j].real; + c[j*(*ldc)+i].imag=C[i*LDC+j].imag; + } + free(A); + free(B); + free(C); + } + else if (*layout == TEST_COL_MJR) + cblas_csyr2k(CblasColMajor, uplo, trans, *n, *k, alpha, a, *lda, + b, *ldb, beta, c, *ldc ); + else + cblas_csyr2k(UNDEFINED, uplo, trans, *n, *k, alpha, a, *lda, + b, *ldb, beta, c, *ldc ); +} +void F77_ctrmm(int *layout, char *rtlf, char *uplow, char *transp, char *diagn, + int *m, int *n, CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, + int *lda, CBLAS_TEST_COMPLEX *b, int *ldb) { + int i,j,LDA,LDB; + CBLAS_TEST_COMPLEX *A, *B; + CBLAS_SIDE side; + CBLAS_DIAG diag; + CBLAS_UPLO uplo; + CBLAS_TRANSPOSE trans; + + get_uplo_type(uplow,&uplo); + get_transpose_type(transp,&trans); + get_diag_type(diagn,&diag); + get_side_type(rtlf,&side); + + if (*layout == TEST_ROW_MJR) { + if (side == CblasLeft) { + LDA = *m+1; + A=(CBLAS_TEST_COMPLEX* )malloc((*m)*LDA*sizeof(CBLAS_TEST_COMPLEX)); + for( i=0; i<*m; i++ ) + for( j=0; j<*m; j++ ) { + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + } + } + else{ + LDA = *n+1; + A=(CBLAS_TEST_COMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_COMPLEX)); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) { + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + } + } + LDB = *n+1; + B=(CBLAS_TEST_COMPLEX* )malloc((*m)*LDB*sizeof(CBLAS_TEST_COMPLEX)); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ) { + B[i*LDB+j].real=b[j*(*ldb)+i].real; + B[i*LDB+j].imag=b[j*(*ldb)+i].imag; + } + cblas_ctrmm(CblasRowMajor, side, uplo, trans, diag, *m, *n, alpha, + A, LDA, B, LDB ); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) { + b[j*(*ldb)+i].real=B[i*LDB+j].real; + b[j*(*ldb)+i].imag=B[i*LDB+j].imag; + } + free(A); + free(B); + } + else if (*layout == TEST_COL_MJR) + cblas_ctrmm(CblasColMajor, side, uplo, trans, diag, *m, *n, alpha, + a, *lda, b, *ldb); + else + cblas_ctrmm(UNDEFINED, side, uplo, trans, diag, *m, *n, alpha, + a, *lda, b, *ldb); +} + +void F77_ctrsm(int *layout, char *rtlf, char *uplow, char *transp, char *diagn, + int *m, int *n, CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, + int *lda, CBLAS_TEST_COMPLEX *b, int *ldb) { + int i,j,LDA,LDB; + CBLAS_TEST_COMPLEX *A, *B; + CBLAS_SIDE side; + CBLAS_DIAG diag; + CBLAS_UPLO uplo; + CBLAS_TRANSPOSE trans; + + get_uplo_type(uplow,&uplo); + get_transpose_type(transp,&trans); + get_diag_type(diagn,&diag); + get_side_type(rtlf,&side); + + if (*layout == TEST_ROW_MJR) { + if (side == CblasLeft) { + LDA = *m+1; + A=(CBLAS_TEST_COMPLEX* )malloc( (*m)*LDA*sizeof(CBLAS_TEST_COMPLEX ) ); + for( i=0; i<*m; i++ ) + for( j=0; j<*m; j++ ) { + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + } + } + else{ + LDA = *n+1; + A=(CBLAS_TEST_COMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_COMPLEX)); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) { + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + } + } + LDB = *n+1; + B=(CBLAS_TEST_COMPLEX* )malloc((*m)*LDB*sizeof(CBLAS_TEST_COMPLEX)); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ) { + B[i*LDB+j].real=b[j*(*ldb)+i].real; + B[i*LDB+j].imag=b[j*(*ldb)+i].imag; + } + cblas_ctrsm(CblasRowMajor, side, uplo, trans, diag, *m, *n, alpha, + A, LDA, B, LDB ); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) { + b[j*(*ldb)+i].real=B[i*LDB+j].real; + b[j*(*ldb)+i].imag=B[i*LDB+j].imag; + } + free(A); + free(B); + } + else if (*layout == TEST_COL_MJR) + cblas_ctrsm(CblasColMajor, side, uplo, trans, diag, *m, *n, alpha, + a, *lda, b, *ldb); + else + cblas_ctrsm(UNDEFINED, side, uplo, trans, diag, *m, *n, alpha, + a, *lda, b, *ldb); +} diff --git a/cblas/testing/c_cblat1.f b/cblas/testing/c_cblat1.f new file mode 100644 index 00000000..c741ce50 --- /dev/null +++ b/cblas/testing/c_cblat1.f @@ -0,0 +1,682 @@ + PROGRAM CCBLAT1 +* Test program for the COMPLEX Level 1 CBLAS. +* Based upon the original CBLAS test routine together with: +* F06GAF Example Program Text +* .. Parameters .. + INTEGER NOUT + PARAMETER (NOUT=6) +* .. Scalars in Common .. + INTEGER ICASE, INCX, INCY, MODE, N + LOGICAL PASS +* .. Local Scalars .. + REAL SFAC + INTEGER IC +* .. External Subroutines .. + EXTERNAL CHECK1, CHECK2, HEADER +* .. Common blocks .. + COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS +* .. Data statements .. + DATA SFAC/9.765625E-4/ +* .. Executable Statements .. + WRITE (NOUT,99999) + DO 20 IC = 1, 10 + ICASE = IC + CALL HEADER +* +* Initialize PASS, INCX, INCY, and MODE for a new case. +* The value 9999 for INCX, INCY or MODE will appear in the +* detailed output, if any, for cases that do not involve +* these parameters. +* + PASS = .TRUE. + INCX = 9999 + INCY = 9999 + MODE = 9999 + IF (ICASE.LE.5) THEN + CALL CHECK2(SFAC) + ELSE IF (ICASE.GE.6) THEN + CALL CHECK1(SFAC) + END IF +* -- Print + IF (PASS) WRITE (NOUT,99998) + 20 CONTINUE + STOP +* +99999 FORMAT (' Complex CBLAS Test Program Results',/1X) +99998 FORMAT (' ----- PASS -----') + END + SUBROUTINE HEADER +* .. Parameters .. + INTEGER NOUT + PARAMETER (NOUT=6) +* .. Scalars in Common .. + INTEGER ICASE, INCX, INCY, MODE, N + LOGICAL PASS +* .. Local Arrays .. + CHARACTER*15 L(10) +* .. Common blocks .. + COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS +* .. Data statements .. + DATA L(1)/'CBLAS_CDOTC'/ + DATA L(2)/'CBLAS_CDOTU'/ + DATA L(3)/'CBLAS_CAXPY'/ + DATA L(4)/'CBLAS_CCOPY'/ + DATA L(5)/'CBLAS_CSWAP'/ + DATA L(6)/'CBLAS_SCNRM2'/ + DATA L(7)/'CBLAS_SCASUM'/ + DATA L(8)/'CBLAS_CSCAL'/ + DATA L(9)/'CBLAS_CSSCAL'/ + DATA L(10)/'CBLAS_ICAMAX'/ +* .. Executable Statements .. + WRITE (NOUT,99999) ICASE, L(ICASE) + RETURN +* +99999 FORMAT (/' Test of subprogram number',I3,9X,A15) + END + SUBROUTINE CHECK1(SFAC) +* .. Parameters .. + INTEGER NOUT + PARAMETER (NOUT=6) +* .. Scalar Arguments .. + REAL SFAC +* .. Scalars in Common .. + INTEGER ICASE, INCX, INCY, MODE, N + LOGICAL PASS +* .. Local Scalars .. + COMPLEX CA + REAL SA + INTEGER I, J, LEN, NP1 +* .. Local Arrays .. + COMPLEX CTRUE5(8,5,2), CTRUE6(8,5,2), CV(8,5,2), CX(8), + + MWPCS(5), MWPCT(5) + REAL STRUE2(5), STRUE4(5) + INTEGER ITRUE3(5) +* .. External Functions .. + REAL SCASUMTEST, SCNRM2TEST + INTEGER ICAMAXTEST + EXTERNAL SCASUMTEST, SCNRM2TEST, ICAMAXTEST +* .. External Subroutines .. + EXTERNAL CSCAL, CSSCALTEST, CTEST, ITEST1, STEST1 +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Common blocks .. + COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS +* .. Data statements .. + DATA SA, CA/0.3E0, (0.4E0,-0.7E0)/ + DATA ((CV(I,J,1),I=1,8),J=1,5)/(0.1E0,0.1E0), + + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), + + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), + + (1.0E0,2.0E0), (0.3E0,-0.4E0), (3.0E0,4.0E0), + + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), + + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), + + (0.1E0,-0.3E0), (0.5E0,-0.1E0), (5.0E0,6.0E0), + + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), + + (5.0E0,6.0E0), (5.0E0,6.0E0), (0.1E0,0.1E0), + + (-0.6E0,0.1E0), (0.1E0,-0.3E0), (7.0E0,8.0E0), + + (7.0E0,8.0E0), (7.0E0,8.0E0), (7.0E0,8.0E0), + + (7.0E0,8.0E0), (0.3E0,0.1E0), (0.1E0,0.4E0), + + (0.4E0,0.1E0), (0.1E0,0.2E0), (2.0E0,3.0E0), + + (2.0E0,3.0E0), (2.0E0,3.0E0), (2.0E0,3.0E0)/ + DATA ((CV(I,J,2),I=1,8),J=1,5)/(0.1E0,0.1E0), + + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), + + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), + + (4.0E0,5.0E0), (0.3E0,-0.4E0), (6.0E0,7.0E0), + + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), + + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), + + (0.1E0,-0.3E0), (8.0E0,9.0E0), (0.5E0,-0.1E0), + + (2.0E0,5.0E0), (2.0E0,5.0E0), (2.0E0,5.0E0), + + (2.0E0,5.0E0), (2.0E0,5.0E0), (0.1E0,0.1E0), + + (3.0E0,6.0E0), (-0.6E0,0.1E0), (4.0E0,7.0E0), + + (0.1E0,-0.3E0), (7.0E0,2.0E0), (7.0E0,2.0E0), + + (7.0E0,2.0E0), (0.3E0,0.1E0), (5.0E0,8.0E0), + + (0.1E0,0.4E0), (6.0E0,9.0E0), (0.4E0,0.1E0), + + (8.0E0,3.0E0), (0.1E0,0.2E0), (9.0E0,4.0E0)/ + DATA STRUE2/0.0E0, 0.5E0, 0.6E0, 0.7E0, 0.7E0/ + DATA STRUE4/0.0E0, 0.7E0, 1.0E0, 1.3E0, 1.7E0/ + DATA ((CTRUE5(I,J,1),I=1,8),J=1,5)/(0.1E0,0.1E0), + + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), + + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), + + (1.0E0,2.0E0), (-0.16E0,-0.37E0), (3.0E0,4.0E0), + + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), + + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), + + (-0.17E0,-0.19E0), (0.13E0,-0.39E0), + + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), + + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), + + (0.11E0,-0.03E0), (-0.17E0,0.46E0), + + (-0.17E0,-0.19E0), (7.0E0,8.0E0), (7.0E0,8.0E0), + + (7.0E0,8.0E0), (7.0E0,8.0E0), (7.0E0,8.0E0), + + (0.19E0,-0.17E0), (0.32E0,0.09E0), + + (0.23E0,-0.24E0), (0.18E0,0.01E0), + + (2.0E0,3.0E0), (2.0E0,3.0E0), (2.0E0,3.0E0), + + (2.0E0,3.0E0)/ + DATA ((CTRUE5(I,J,2),I=1,8),J=1,5)/(0.1E0,0.1E0), + + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), + + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), + + (4.0E0,5.0E0), (-0.16E0,-0.37E0), (6.0E0,7.0E0), + + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), + + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), + + (-0.17E0,-0.19E0), (8.0E0,9.0E0), + + (0.13E0,-0.39E0), (2.0E0,5.0E0), (2.0E0,5.0E0), + + (2.0E0,5.0E0), (2.0E0,5.0E0), (2.0E0,5.0E0), + + (0.11E0,-0.03E0), (3.0E0,6.0E0), + + (-0.17E0,0.46E0), (4.0E0,7.0E0), + + (-0.17E0,-0.19E0), (7.0E0,2.0E0), (7.0E0,2.0E0), + + (7.0E0,2.0E0), (0.19E0,-0.17E0), (5.0E0,8.0E0), + + (0.32E0,0.09E0), (6.0E0,9.0E0), + + (0.23E0,-0.24E0), (8.0E0,3.0E0), + + (0.18E0,0.01E0), (9.0E0,4.0E0)/ + DATA ((CTRUE6(I,J,1),I=1,8),J=1,5)/(0.1E0,0.1E0), + + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), + + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), + + (1.0E0,2.0E0), (0.09E0,-0.12E0), (3.0E0,4.0E0), + + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), + + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), + + (0.03E0,-0.09E0), (0.15E0,-0.03E0), + + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), + + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), + + (0.03E0,0.03E0), (-0.18E0,0.03E0), + + (0.03E0,-0.09E0), (7.0E0,8.0E0), (7.0E0,8.0E0), + + (7.0E0,8.0E0), (7.0E0,8.0E0), (7.0E0,8.0E0), + + (0.09E0,0.03E0), (0.03E0,0.12E0), + + (0.12E0,0.03E0), (0.03E0,0.06E0), (2.0E0,3.0E0), + + (2.0E0,3.0E0), (2.0E0,3.0E0), (2.0E0,3.0E0)/ + DATA ((CTRUE6(I,J,2),I=1,8),J=1,5)/(0.1E0,0.1E0), + + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), + + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), + + (4.0E0,5.0E0), (0.09E0,-0.12E0), (6.0E0,7.0E0), + + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), + + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), + + (0.03E0,-0.09E0), (8.0E0,9.0E0), + + (0.15E0,-0.03E0), (2.0E0,5.0E0), (2.0E0,5.0E0), + + (2.0E0,5.0E0), (2.0E0,5.0E0), (2.0E0,5.0E0), + + (0.03E0,0.03E0), (3.0E0,6.0E0), + + (-0.18E0,0.03E0), (4.0E0,7.0E0), + + (0.03E0,-0.09E0), (7.0E0,2.0E0), (7.0E0,2.0E0), + + (7.0E0,2.0E0), (0.09E0,0.03E0), (5.0E0,8.0E0), + + (0.03E0,0.12E0), (6.0E0,9.0E0), (0.12E0,0.03E0), + + (8.0E0,3.0E0), (0.03E0,0.06E0), (9.0E0,4.0E0)/ + DATA ITRUE3/0, 1, 2, 2, 2/ +* .. Executable Statements .. + DO 60 INCX = 1, 2 + DO 40 NP1 = 1, 5 + N = NP1 - 1 + LEN = 2*MAX(N,1) +* .. Set vector arguments .. + DO 20 I = 1, LEN + CX(I) = CV(I,NP1,INCX) + 20 CONTINUE + IF (ICASE.EQ.6) THEN +* .. SCNRM2TEST .. + CALL STEST1(SCNRM2TEST(N,CX,INCX),STRUE2(NP1), + + STRUE2(NP1), SFAC) + ELSE IF (ICASE.EQ.7) THEN +* .. SCASUMTEST .. + CALL STEST1(SCASUMTEST(N,CX,INCX),STRUE4(NP1), + + STRUE4(NP1),SFAC) + ELSE IF (ICASE.EQ.8) THEN +* .. CSCAL .. + CALL CSCAL(N,CA,CX,INCX) + CALL CTEST(LEN,CX,CTRUE5(1,NP1,INCX),CTRUE5(1,NP1,INCX), + + SFAC) + ELSE IF (ICASE.EQ.9) THEN +* .. CSSCALTEST .. + CALL CSSCALTEST(N,SA,CX,INCX) + CALL CTEST(LEN,CX,CTRUE6(1,NP1,INCX),CTRUE6(1,NP1,INCX), + + SFAC) + ELSE IF (ICASE.EQ.10) THEN +* .. ICAMAXTEST .. + CALL ITEST1(ICAMAXTEST(N,CX,INCX),ITRUE3(NP1)) + ELSE + WRITE (NOUT,*) ' Shouldn''t be here in CHECK1' + STOP + END IF +* + 40 CONTINUE + 60 CONTINUE +* + INCX = 1 + IF (ICASE.EQ.8) THEN +* CSCAL +* Add a test for alpha equal to zero. + CA = (0.0E0,0.0E0) + DO 80 I = 1, 5 + MWPCT(I) = (0.0E0,0.0E0) + MWPCS(I) = (1.0E0,1.0E0) + 80 CONTINUE + CALL CSCAL(5,CA,CX,INCX) + CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) + ELSE IF (ICASE.EQ.9) THEN +* CSSCALTEST +* Add a test for alpha equal to zero. + SA = 0.0E0 + DO 100 I = 1, 5 + MWPCT(I) = (0.0E0,0.0E0) + MWPCS(I) = (1.0E0,1.0E0) + 100 CONTINUE + CALL CSSCALTEST(5,SA,CX,INCX) + CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) +* Add a test for alpha equal to one. + SA = 1.0E0 + DO 120 I = 1, 5 + MWPCT(I) = CX(I) + MWPCS(I) = CX(I) + 120 CONTINUE + CALL CSSCALTEST(5,SA,CX,INCX) + CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) +* Add a test for alpha equal to minus one. + SA = -1.0E0 + DO 140 I = 1, 5 + MWPCT(I) = -CX(I) + MWPCS(I) = -CX(I) + 140 CONTINUE + CALL CSSCALTEST(5,SA,CX,INCX) + CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) + END IF + RETURN + END + SUBROUTINE CHECK2(SFAC) +* .. Parameters .. + INTEGER NOUT + PARAMETER (NOUT=6) +* .. Scalar Arguments .. + REAL SFAC +* .. Scalars in Common .. + INTEGER ICASE, INCX, INCY, MODE, N + LOGICAL PASS +* .. Local Scalars .. + COMPLEX CA,CTEMP + INTEGER I, J, KI, KN, KSIZE, LENX, LENY, MX, MY +* .. Local Arrays .. + COMPLEX CDOT(1), CSIZE1(4), CSIZE2(7,2), CSIZE3(14), + + CT10X(7,4,4), CT10Y(7,4,4), CT6(4,4), CT7(4,4), + + CT8(7,4,4), CX(7), CX1(7), CY(7), CY1(7) + INTEGER INCXS(4), INCYS(4), LENS(4,2), NS(4) +* .. External Functions .. + EXTERNAL CDOTCTEST, CDOTUTEST +* .. External Subroutines .. + EXTERNAL CAXPYTEST, CCOPYTEST, CSWAPTEST, CTEST +* .. Intrinsic Functions .. + INTRINSIC ABS, MIN +* .. Common blocks .. + COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS +* .. Data statements .. + DATA CA/(0.4E0,-0.7E0)/ + DATA INCXS/1, 2, -2, -1/ + DATA INCYS/1, -2, 1, -2/ + DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/ + DATA NS/0, 1, 2, 4/ + DATA CX1/(0.7E0,-0.8E0), (-0.4E0,-0.7E0), + + (-0.1E0,-0.9E0), (0.2E0,-0.8E0), + + (-0.9E0,-0.4E0), (0.1E0,0.4E0), (-0.6E0,0.6E0)/ + DATA CY1/(0.6E0,-0.6E0), (-0.9E0,0.5E0), + + (0.7E0,-0.6E0), (0.1E0,-0.5E0), (-0.1E0,-0.2E0), + + (-0.5E0,-0.3E0), (0.8E0,-0.7E0)/ + DATA ((CT8(I,J,1),I=1,7),J=1,4)/(0.6E0,-0.6E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.32E0,-1.41E0), + + (-1.55E0,0.5E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.32E0,-1.41E0), (-1.55E0,0.5E0), + + (0.03E0,-0.89E0), (-0.38E0,-0.96E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/ + DATA ((CT8(I,J,2),I=1,7),J=1,4)/(0.6E0,-0.6E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (-0.07E0,-0.89E0), + + (-0.9E0,0.5E0), (0.42E0,-1.41E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.78E0,0.06E0), (-0.9E0,0.5E0), + + (0.06E0,-0.13E0), (0.1E0,-0.5E0), + + (-0.77E0,-0.49E0), (-0.5E0,-0.3E0), + + (0.52E0,-1.51E0)/ + DATA ((CT8(I,J,3),I=1,7),J=1,4)/(0.6E0,-0.6E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (-0.07E0,-0.89E0), + + (-1.18E0,-0.31E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.78E0,0.06E0), (-1.54E0,0.97E0), + + (0.03E0,-0.89E0), (-0.18E0,-1.31E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/ + DATA ((CT8(I,J,4),I=1,7),J=1,4)/(0.6E0,-0.6E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.32E0,-1.41E0), (-0.9E0,0.5E0), + + (0.05E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.32E0,-1.41E0), + + (-0.9E0,0.5E0), (0.05E0,-0.6E0), (0.1E0,-0.5E0), + + (-0.77E0,-0.49E0), (-0.5E0,-0.3E0), + + (0.32E0,-1.16E0)/ + DATA CT7/(0.0E0,0.0E0), (-0.06E0,-0.90E0), + + (0.65E0,-0.47E0), (-0.34E0,-1.22E0), + + (0.0E0,0.0E0), (-0.06E0,-0.90E0), + + (-0.59E0,-1.46E0), (-1.04E0,-0.04E0), + + (0.0E0,0.0E0), (-0.06E0,-0.90E0), + + (-0.83E0,0.59E0), (0.07E0,-0.37E0), + + (0.0E0,0.0E0), (-0.06E0,-0.90E0), + + (-0.76E0,-1.15E0), (-1.33E0,-1.82E0)/ + DATA CT6/(0.0E0,0.0E0), (0.90E0,0.06E0), + + (0.91E0,-0.77E0), (1.80E0,-0.10E0), + + (0.0E0,0.0E0), (0.90E0,0.06E0), (1.45E0,0.74E0), + + (0.20E0,0.90E0), (0.0E0,0.0E0), (0.90E0,0.06E0), + + (-0.55E0,0.23E0), (0.83E0,-0.39E0), + + (0.0E0,0.0E0), (0.90E0,0.06E0), (1.04E0,0.79E0), + + (1.95E0,1.22E0)/ + DATA ((CT10X(I,J,1),I=1,7),J=1,4)/(0.7E0,-0.8E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.6E0,-0.6E0), (-0.9E0,0.5E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.6E0,-0.6E0), + + (-0.9E0,0.5E0), (0.7E0,-0.6E0), (0.1E0,-0.5E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/ + DATA ((CT10X(I,J,2),I=1,7),J=1,4)/(0.7E0,-0.8E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.7E0,-0.6E0), (-0.4E0,-0.7E0), + + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.8E0,-0.7E0), + + (-0.4E0,-0.7E0), (-0.1E0,-0.2E0), + + (0.2E0,-0.8E0), (0.7E0,-0.6E0), (0.1E0,0.4E0), + + (0.6E0,-0.6E0)/ + DATA ((CT10X(I,J,3),I=1,7),J=1,4)/(0.7E0,-0.8E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (-0.9E0,0.5E0), (-0.4E0,-0.7E0), + + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.1E0,-0.5E0), + + (-0.4E0,-0.7E0), (0.7E0,-0.6E0), (0.2E0,-0.8E0), + + (-0.9E0,0.5E0), (0.1E0,0.4E0), (0.6E0,-0.6E0)/ + DATA ((CT10X(I,J,4),I=1,7),J=1,4)/(0.7E0,-0.8E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.6E0,-0.6E0), (0.7E0,-0.6E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.6E0,-0.6E0), + + (0.7E0,-0.6E0), (-0.1E0,-0.2E0), (0.8E0,-0.7E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/ + DATA ((CT10Y(I,J,1),I=1,7),J=1,4)/(0.6E0,-0.6E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.7E0,-0.8E0), (-0.4E0,-0.7E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.7E0,-0.8E0), + + (-0.4E0,-0.7E0), (-0.1E0,-0.9E0), + + (0.2E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0)/ + DATA ((CT10Y(I,J,2),I=1,7),J=1,4)/(0.6E0,-0.6E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (-0.1E0,-0.9E0), (-0.9E0,0.5E0), + + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (-0.6E0,0.6E0), + + (-0.9E0,0.5E0), (-0.9E0,-0.4E0), (0.1E0,-0.5E0), + + (-0.1E0,-0.9E0), (-0.5E0,-0.3E0), + + (0.7E0,-0.8E0)/ + DATA ((CT10Y(I,J,3),I=1,7),J=1,4)/(0.6E0,-0.6E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (-0.1E0,-0.9E0), (0.7E0,-0.8E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (-0.6E0,0.6E0), + + (-0.9E0,-0.4E0), (-0.1E0,-0.9E0), + + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0)/ + DATA ((CT10Y(I,J,4),I=1,7),J=1,4)/(0.6E0,-0.6E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.7E0,-0.8E0), (-0.9E0,0.5E0), + + (-0.4E0,-0.7E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.7E0,-0.8E0), + + (-0.9E0,0.5E0), (-0.4E0,-0.7E0), (0.1E0,-0.5E0), + + (-0.1E0,-0.9E0), (-0.5E0,-0.3E0), + + (0.2E0,-0.8E0)/ + DATA CSIZE1/(0.0E0,0.0E0), (0.9E0,0.9E0), + + (1.63E0,1.73E0), (2.90E0,2.78E0)/ + DATA CSIZE3/(0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (1.17E0,1.17E0), + + (1.17E0,1.17E0), (1.17E0,1.17E0), + + (1.17E0,1.17E0), (1.17E0,1.17E0), + + (1.17E0,1.17E0), (1.17E0,1.17E0)/ + DATA CSIZE2/(0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), + + (0.0E0,0.0E0), (0.0E0,0.0E0), (1.54E0,1.54E0), + + (1.54E0,1.54E0), (1.54E0,1.54E0), + + (1.54E0,1.54E0), (1.54E0,1.54E0), + + (1.54E0,1.54E0), (1.54E0,1.54E0)/ +* .. Executable Statements .. + DO 60 KI = 1, 4 + INCX = INCXS(KI) + INCY = INCYS(KI) + MX = ABS(INCX) + MY = ABS(INCY) +* + DO 40 KN = 1, 4 + N = NS(KN) + KSIZE = MIN(2,KN) + LENX = LENS(KN,MX) + LENY = LENS(KN,MY) +* .. initialize all argument arrays .. + DO 20 I = 1, 7 + CX(I) = CX1(I) + CY(I) = CY1(I) + 20 CONTINUE + IF (ICASE.EQ.1) THEN +* .. CDOTCTEST .. + CALL CDOTCTEST(N,CX,INCX,CY,INCY,CTEMP) + CDOT(1) = CTEMP + CALL CTEST(1,CDOT,CT6(KN,KI),CSIZE1(KN),SFAC) + ELSE IF (ICASE.EQ.2) THEN +* .. CDOTUTEST .. + CALL CDOTUTEST(N,CX,INCX,CY,INCY,CTEMP) + CDOT(1) = CTEMP + CALL CTEST(1,CDOT,CT7(KN,KI),CSIZE1(KN),SFAC) + ELSE IF (ICASE.EQ.3) THEN +* .. CAXPYTEST .. + CALL CAXPYTEST(N,CA,CX,INCX,CY,INCY) + CALL CTEST(LENY,CY,CT8(1,KN,KI),CSIZE2(1,KSIZE),SFAC) + ELSE IF (ICASE.EQ.4) THEN +* .. CCOPYTEST .. + CALL CCOPYTEST(N,CX,INCX,CY,INCY) + CALL CTEST(LENY,CY,CT10Y(1,KN,KI),CSIZE3,1.0E0) + ELSE IF (ICASE.EQ.5) THEN +* .. CSWAPTEST .. + CALL CSWAPTEST(N,CX,INCX,CY,INCY) + CALL CTEST(LENX,CX,CT10X(1,KN,KI),CSIZE3,1.0E0) + CALL CTEST(LENY,CY,CT10Y(1,KN,KI),CSIZE3,1.0E0) + ELSE + WRITE (NOUT,*) ' Shouldn''t be here in CHECK2' + STOP + END IF +* + 40 CONTINUE + 60 CONTINUE + RETURN + END + SUBROUTINE STEST(LEN,SCOMP,STRUE,SSIZE,SFAC) +* ********************************* STEST ************************** +* +* THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO +* SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE +* NEGLIGIBLE. +* +* C. L. LAWSON, JPL, 1974 DEC 10 +* +* .. Parameters .. + INTEGER NOUT + PARAMETER (NOUT=6) +* .. Scalar Arguments .. + REAL SFAC + INTEGER LEN +* .. Array Arguments .. + REAL SCOMP(LEN), SSIZE(LEN), STRUE(LEN) +* .. Scalars in Common .. + INTEGER ICASE, INCX, INCY, MODE, N + LOGICAL PASS +* .. Local Scalars .. + REAL SD + INTEGER I +* .. External Functions .. + REAL SDIFF + EXTERNAL SDIFF +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. Common blocks .. + COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS +* .. Executable Statements .. +* + DO 40 I = 1, LEN + SD = SCOMP(I) - STRUE(I) + IF (SDIFF(ABS(SSIZE(I))+ABS(SFAC*SD),ABS(SSIZE(I))).EQ.0.0E0) + + GO TO 40 +* +* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I). +* + IF ( .NOT. PASS) GO TO 20 +* PRINT FAIL MESSAGE AND HEADER. + PASS = .FALSE. + WRITE (NOUT,99999) + WRITE (NOUT,99998) + 20 WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, I, SCOMP(I), + + STRUE(I), SD, SSIZE(I) + 40 CONTINUE + RETURN +* +99999 FORMAT (' FAIL') +99998 FORMAT (/' CASE N INCX INCY MODE I ', + + ' COMP(I) TRUE(I) DIFFERENCE', + + ' SIZE(I)',/1X) +99997 FORMAT (1X,I4,I3,3I5,I3,2E36.8,2E12.4) + END + SUBROUTINE STEST1(SCOMP1,STRUE1,SSIZE,SFAC) +* ************************* STEST1 ***************************** +* +* THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN +* REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE +* ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT. +* +* C.L. LAWSON, JPL, 1978 DEC 6 +* +* .. Scalar Arguments .. + REAL SCOMP1, SFAC, STRUE1 +* .. Array Arguments .. + REAL SSIZE(*) +* .. Local Arrays .. + REAL SCOMP(1), STRUE(1) +* .. External Subroutines .. + EXTERNAL STEST +* .. Executable Statements .. +* + SCOMP(1) = SCOMP1 + STRUE(1) = STRUE1 + CALL STEST(1,SCOMP,STRUE,SSIZE,SFAC) +* + RETURN + END + REAL FUNCTION SDIFF(SA,SB) +* ********************************* SDIFF ************************** +* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15 +* +* .. Scalar Arguments .. + REAL SA, SB +* .. Executable Statements .. + SDIFF = SA - SB + RETURN + END + SUBROUTINE CTEST(LEN,CCOMP,CTRUE,CSIZE,SFAC) +* **************************** CTEST ***************************** +* +* C.L. LAWSON, JPL, 1978 DEC 6 +* +* .. Scalar Arguments .. + REAL SFAC + INTEGER LEN +* .. Array Arguments .. + COMPLEX CCOMP(LEN), CSIZE(LEN), CTRUE(LEN) +* .. Local Scalars .. + INTEGER I +* .. Local Arrays .. + REAL SCOMP(20), SSIZE(20), STRUE(20) +* .. External Subroutines .. + EXTERNAL STEST +* .. Intrinsic Functions .. + INTRINSIC AIMAG, REAL +* .. Executable Statements .. + DO 20 I = 1, LEN + SCOMP(2*I-1) = REAL(CCOMP(I)) + SCOMP(2*I) = AIMAG(CCOMP(I)) + STRUE(2*I-1) = REAL(CTRUE(I)) + STRUE(2*I) = AIMAG(CTRUE(I)) + SSIZE(2*I-1) = REAL(CSIZE(I)) + SSIZE(2*I) = AIMAG(CSIZE(I)) + 20 CONTINUE +* + CALL STEST(2*LEN,SCOMP,STRUE,SSIZE,SFAC) + RETURN + END + SUBROUTINE ITEST1(ICOMP,ITRUE) +* ********************************* ITEST1 ************************* +* +* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR +* EQUALITY. +* C. L. LAWSON, JPL, 1974 DEC 10 +* +* .. Parameters .. + INTEGER NOUT + PARAMETER (NOUT=6) +* .. Scalar Arguments .. + INTEGER ICOMP, ITRUE +* .. Scalars in Common .. + INTEGER ICASE, INCX, INCY, MODE, N + LOGICAL PASS +* .. Local Scalars .. + INTEGER ID +* .. Common blocks .. + COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS +* .. Executable Statements .. + IF (ICOMP.EQ.ITRUE) GO TO 40 +* +* HERE ICOMP IS NOT EQUAL TO ITRUE. +* + IF ( .NOT. PASS) GO TO 20 +* PRINT FAIL MESSAGE AND HEADER. + PASS = .FALSE. + WRITE (NOUT,99999) + WRITE (NOUT,99998) + 20 ID = ICOMP - ITRUE + WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, ICOMP, ITRUE, ID + 40 CONTINUE + RETURN +* +99999 FORMAT (' FAIL') +99998 FORMAT (/' CASE N INCX INCY MODE ', + + ' COMP TRUE DIFFERENCE', + + /1X) +99997 FORMAT (1X,I4,I3,3I5,2I36,I12) + END diff --git a/cblas/testing/c_cblat2.f b/cblas/testing/c_cblat2.f new file mode 100644 index 00000000..545ba4b9 --- /dev/null +++ b/cblas/testing/c_cblat2.f @@ -0,0 +1,2932 @@ + PROGRAM CBLAT2 +* +* Test program for the COMPLEX Level 2 Blas. +* +* The program must be driven by a short data file. The first 17 records +* of the file are read using list-directed input, the last 17 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 34 lines: +* 'CBLAT2.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 +* 4 NUMBER OF VALUES OF K +* 0 1 2 4 VALUES OF K +* 4 NUMBER OF VALUES OF INCX AND INCY +* 1 2 -1 -2 VALUES OF INCX AND INCY +* 3 NUMBER OF VALUES OF ALPHA +* (0.0,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_cgemv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_cgbmv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_chemv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_chbmv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_chpmv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_ctrmv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_ctbmv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_ctpmv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_ctrsv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_ctbsv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_ctpsv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_cgerc T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_cgeru T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_cher T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_chpr T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_cher2 T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_chpr2 T PUT F FOR NO TEST. SAME COLUMNS. +* +* See: +* +* Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J.. +* An extended set of Fortran Basic Linear Algebra Subprograms. +* +* Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics +* and Computer Science Division, Argonne National Laboratory, +* 9700 South Cass Avenue, Argonne, Illinois 60439, US. +* +* Or +* +* NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms +* Group Ltd., NAG Central Office, 256 Banbury Road, Oxford +* OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st +* Street, Suite 100, Downers Grove, Illinois 60515-1263, USA. +* +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + INTEGER NIN, NOUT + PARAMETER ( NIN = 5, NOUT = 6 ) + INTEGER NSUBS + PARAMETER ( NSUBS = 17 ) + COMPLEX ZERO, ONE + PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) + REAL RZERO, RHALF, RONE + PARAMETER ( RZERO = 0.0, RHALF = 0.5, RONE = 1.0 ) + INTEGER NMAX, INCMAX + PARAMETER ( NMAX = 65, INCMAX = 2 ) + INTEGER NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX + PARAMETER ( NINMAX = 7, NIDMAX = 9, NKBMAX = 7, + $ NALMAX = 7, NBEMAX = 7 ) +* .. Local Scalars .. + REAL EPS, ERR, THRESH + INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB, + $ NTRA, LAYOUT + LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, + $ TSTERR, CORDER, RORDER + CHARACTER*1 TRANS + CHARACTER*12 SNAMET + CHARACTER*32 SNAPS +* .. Local Arrays .. + COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), + $ ALF( NALMAX ), AS( NMAX*NMAX ), BET( NBEMAX ), + $ X( NMAX ), XS( NMAX*INCMAX ), + $ XX( NMAX*INCMAX ), Y( NMAX ), + $ YS( NMAX*INCMAX ), YT( NMAX ), + $ YY( NMAX*INCMAX ), Z( 2*NMAX ) + REAL G( NMAX ) + INTEGER IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX ) + LOGICAL LTEST( NSUBS ) + CHARACTER*12 SNAMES( NSUBS ) +* .. External Functions .. + REAL SDIFF + LOGICAL LCE + EXTERNAL SDIFF, LCE +* .. External Subroutines .. + EXTERNAL CCHK1, CCHK2, CCHK3, CCHK4, CCHK5, CCHK6, + $ CC2CHKE, CMVCH +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK + CHARACTER*12 SRNAMT +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK + COMMON /SRNAMC/SRNAMT +* .. Data statements .. + DATA SNAMES/'cblas_cgemv ', 'cblas_cgbmv ', + $ 'cblas_chemv ','cblas_chbmv ','cblas_chpmv ', + $ 'cblas_ctrmv ','cblas_ctbmv ','cblas_ctpmv ', + $ 'cblas_ctrsv ','cblas_ctbsv ','cblas_ctpsv ', + $ 'cblas_cgerc ','cblas_cgeru ','cblas_cher ', + $ 'cblas_chpr ','cblas_cher2 ','cblas_chpr2 '/ +* .. Executable Statements .. +* + NOUTC = NOUT +* +* Read name and unit number for summary output file and open file. +* + READ( NIN, FMT = * )SNAPS + READ( NIN, FMT = * )NTRA + TRACE = NTRA.GE.0 + IF( TRACE )THEN + OPEN( NTRA, FILE = SNAPS ) + END IF +* Read the flag that directs rewinding of the snapshot file. + READ( NIN, FMT = * )REWI + REWI = REWI.AND.TRACE +* Read the flag that directs stopping on any failure. + READ( NIN, FMT = * )SFATAL +* Read the flag that indicates whether error exits are to be tested. + READ( NIN, FMT = * )TSTERR +* Read the flag that indicates whether row-major data layout to be tested. + READ( NIN, FMT = * )LAYOUT +* Read the threshold value of the test ratio + READ( NIN, FMT = * )THRESH +* +* Read and check the parameter values for the tests. +* +* Values of N + READ( NIN, FMT = * )NIDIM + IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN + WRITE( NOUT, FMT = 9997 )'N', NIDMAX + GO TO 230 + END IF + READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) + DO 10 I = 1, NIDIM + IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN + WRITE( NOUT, FMT = 9996 )NMAX + GO TO 230 + END IF + 10 CONTINUE +* Values of K + READ( NIN, FMT = * )NKB + IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN + WRITE( NOUT, FMT = 9997 )'K', NKBMAX + GO TO 230 + END IF + READ( NIN, FMT = * )( KB( I ), I = 1, NKB ) + DO 20 I = 1, NKB + IF( KB( I ).LT.0 )THEN + WRITE( NOUT, FMT = 9995 ) + GO TO 230 + END IF + 20 CONTINUE +* Values of INCX and INCY + READ( NIN, FMT = * )NINC + IF( NINC.LT.1.OR.NINC.GT.NINMAX )THEN + WRITE( NOUT, FMT = 9997 )'INCX AND INCY', NINMAX + GO TO 230 + END IF + READ( NIN, FMT = * )( INC( I ), I = 1, NINC ) + DO 30 I = 1, NINC + IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN + WRITE( NOUT, FMT = 9994 )INCMAX + GO TO 230 + END IF + 30 CONTINUE +* Values of ALPHA + READ( NIN, FMT = * )NALF + IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN + WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX + GO TO 230 + END IF + READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) +* Values of BETA + READ( NIN, FMT = * )NBET + IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN + WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX + GO TO 230 + END IF + READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) +* +* Report values of parameters. +* + WRITE( NOUT, FMT = 9993 ) + WRITE( NOUT, FMT = 9992 )( IDIM( I ), I = 1, NIDIM ) + WRITE( NOUT, FMT = 9991 )( KB( I ), I = 1, NKB ) + WRITE( NOUT, FMT = 9990 )( INC( I ), I = 1, NINC ) + WRITE( NOUT, FMT = 9989 )( ALF( I ), I = 1, NALF ) + WRITE( NOUT, FMT = 9988 )( BET( I ), I = 1, NBET ) + IF( .NOT.TSTERR )THEN + WRITE( NOUT, FMT = * ) + WRITE( NOUT, FMT = 9980 ) + END IF + WRITE( NOUT, FMT = * ) + WRITE( NOUT, FMT = 9999 )THRESH + WRITE( NOUT, FMT = * ) + + RORDER = .FALSE. + CORDER = .FALSE. + IF (LAYOUT.EQ.2) THEN + RORDER = .TRUE. + CORDER = .TRUE. + WRITE( *, FMT = 10002 ) + ELSE IF (LAYOUT.EQ.1) THEN + RORDER = .TRUE. + WRITE( *, FMT = 10001 ) + ELSE IF (LAYOUT.EQ.0) THEN + CORDER = .TRUE. + WRITE( *, FMT = 10000 ) + END IF + WRITE( *, FMT = * ) +* +* Read names of subroutines and flags which indicate +* whether they are to be tested. +* + DO 40 I = 1, NSUBS + LTEST( I ) = .FALSE. + 40 CONTINUE + 50 READ( NIN, FMT = 9984, END = 80 )SNAMET, LTESTT + DO 60 I = 1, NSUBS + IF( SNAMET.EQ.SNAMES( I ) ) + $ GO TO 70 + 60 CONTINUE + WRITE( NOUT, FMT = 9986 )SNAMET + STOP + 70 LTEST( I ) = LTESTT + GO TO 50 +* + 80 CONTINUE + CLOSE ( NIN ) +* +* Compute EPS (the machine precision). +* + EPS = RONE + 90 CONTINUE + IF( SDIFF( RONE + EPS, RONE ).EQ.RZERO ) + $ GO TO 100 + EPS = RHALF*EPS + GO TO 90 + 100 CONTINUE + EPS = EPS + EPS + WRITE( NOUT, FMT = 9998 )EPS +* +* Check the reliability of CMVCH using exact data. +* + N = MIN( 32, NMAX ) + DO 120 J = 1, N + DO 110 I = 1, N + A( I, J ) = MAX( I - J + 1, 0 ) + 110 CONTINUE + X( J ) = J + Y( J ) = ZERO + 120 CONTINUE + DO 130 J = 1, N + YY( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 + 130 CONTINUE +* YY holds the exact result. On exit from CMVCH YT holds +* the result computed by CMVCH. + TRANS = 'N' + CALL CMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G, + $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) + SAME = LCE( YY, YT, N ) + IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN + WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR + STOP + END IF + TRANS = 'T' + CALL CMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G, + $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) + SAME = LCE( YY, YT, N ) + IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN + WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR + STOP + END IF +* +* Test each subroutine in turn. +* + DO 210 ISNUM = 1, NSUBS + WRITE( NOUT, FMT = * ) + IF( .NOT.LTEST( ISNUM ) )THEN +* Subprogram is not to be tested. + WRITE( NOUT, FMT = 9983 )SNAMES( ISNUM ) + ELSE + SRNAMT = SNAMES( ISNUM ) +* Test error exits. + IF( TSTERR )THEN + CALL CC2CHKE( SNAMES( ISNUM ) ) + WRITE( NOUT, FMT = * ) + END IF +* Test computations. + INFOT = 0 + OK = .TRUE. + FATAL = .FALSE. + GO TO ( 140, 140, 150, 150, 150, 160, 160, + $ 160, 160, 160, 160, 170, 170, 180, + $ 180, 190, 190 )ISNUM +* Test CGEMV, 01, and CGBMV, 02. + 140 IF (CORDER) THEN + CALL CCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, + $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, + $ X, XX, XS, Y, YY, YS, YT, G, 0 ) + END IF + IF (RORDER) THEN + CALL CCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, + $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, + $ X, XX, XS, Y, YY, YS, YT, G, 1 ) + END IF + GO TO 200 +* Test CHEMV, 03, CHBMV, 04, and CHPMV, 05. + 150 IF (CORDER) THEN + CALL CCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, + $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, + $ X, XX, XS, Y, YY, YS, YT, G, 0 ) + END IF + IF (RORDER) THEN + CALL CCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, + $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, + $ X, XX, XS, Y, YY, YS, YT, G, 1 ) + END IF + GO TO 200 +* Test CTRMV, 06, CTBMV, 07, CTPMV, 08, +* CTRSV, 09, CTBSV, 10, and CTPSV, 11. + 160 IF (CORDER) THEN + CALL CCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z, + $ 0 ) + END IF + IF (RORDER) THEN + CALL CCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z, + $ 1 ) + END IF + GO TO 200 +* Test CGERC, 12, CGERU, 13. + 170 IF (CORDER) THEN + CALL CCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, + $ YT, G, Z, 0 ) + END IF + IF (RORDER) THEN + CALL CCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, + $ YT, G, Z, 1 ) + END IF + GO TO 200 +* Test CHER, 14, and CHPR, 15. + 180 IF (CORDER) THEN + CALL CCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, + $ YT, G, Z, 0 ) + END IF + IF (RORDER) THEN + CALL CCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, + $ YT, G, Z, 1 ) + END IF + GO TO 200 +* Test CHER2, 16, and CHPR2, 17. + 190 IF (CORDER) THEN + CALL CCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, + $ YT, G, Z, 0 ) + END IF + IF (RORDER) THEN + CALL CCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, + $ YT, G, Z, 1 ) + END IF +* + 200 IF( FATAL.AND.SFATAL ) + $ GO TO 220 + END IF + 210 CONTINUE + WRITE( NOUT, FMT = 9982 ) + GO TO 240 +* + 220 CONTINUE + WRITE( NOUT, FMT = 9981 ) + GO TO 240 +* + 230 CONTINUE + WRITE( NOUT, FMT = 9987 ) +* + 240 CONTINUE + IF( TRACE ) + $ CLOSE ( NTRA ) + CLOSE ( NOUT ) + STOP +* +10002 FORMAT( ' COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED' ) +10001 FORMAT( ' ROW-MAJOR DATA LAYOUT IS TESTED' ) +10000 FORMAT( ' COLUMN-MAJOR DATA LAYOUT IS TESTED' ) + 9999 FORMAT(' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', + $ 'S THAN', F8.2 ) + 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 ) + 9997 FORMAT(' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', + $ 'THAN ', I2 ) + 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) + 9995 FORMAT( ' VALUE OF K IS LESS THAN 0' ) + 9994 FORMAT( ' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ', + $ I2 ) + 9993 FORMAT(' TESTS OF THE COMPLEX LEVEL 2 BLAS', //' THE F', + $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) + 9992 FORMAT( ' FOR N ', 9I6 ) + 9991 FORMAT( ' FOR K ', 7I6 ) + 9990 FORMAT( ' FOR INCX AND INCY ', 7I6 ) + 9989 FORMAT( ' FOR ALPHA ', + $ 7('(', F4.1, ',', F4.1, ') ', : ) ) + 9988 FORMAT( ' FOR BETA ', + $ 7('(', F4.1, ',', F4.1, ') ', : ) ) + 9987 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', + $ /' ******* TESTS ABANDONED *******' ) + 9986 FORMAT(' SUBPROGRAM NAME ',A12, ' NOT RECOGNIZED', /' ******* T', + $ 'ESTS ABANDONED *******' ) + 9985 FORMAT(' ERROR IN CMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', + $ 'ATED WRONGLY.', /' CMVCH WAS CALLED WITH TRANS = ', A1, + $ ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', / + $ ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.' + $ , /' ******* TESTS ABANDONED *******' ) + 9984 FORMAT(A12, L2 ) + 9983 FORMAT( 1X,A12, ' WAS NOT TESTED' ) + 9982 FORMAT( /' END OF TESTS' ) + 9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) + 9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) +* +* End of CBLAT2. +* + END + SUBROUTINE CCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, + $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, + $ XS, Y, YY, YS, YT, G, IORDER ) +* +* Tests CGEMV and CGBMV. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + COMPLEX ZERO, HALF + PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ) ) + REAL RZERO + PARAMETER ( RZERO = 0.0 ) +* .. Scalar Arguments .. + REAL EPS, THRESH + INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, + $ NOUT, NTRA, IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), BET( NBET ), X( NMAX ), + $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), + $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), + $ YY( NMAX*INCMAX ) + REAL G( NMAX ) + INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) +* .. Local Scalars .. + COMPLEX ALPHA, ALS, BETA, BLS, TRANSL + REAL ERR, ERRMAX + INTEGER I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY, + $ INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA, + $ LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK, + $ NL, NS + LOGICAL BANDED, FULL, NULL, RESET, SAME, TRAN + CHARACTER*1 TRANS, TRANSS + CHARACTER*14 CTRANS + CHARACTER*3 ICH +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LCE, LCERES + EXTERNAL LCE, LCERES +* .. External Subroutines .. + EXTERNAL CCGBMV, CCGEMV, CMAKE, CMVCH +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICH/'NTC'/ +* .. Executable Statements .. + FULL = SNAME( 9: 9 ).EQ.'e' + BANDED = SNAME( 9: 9 ).EQ.'b' +* Define the number of arguments. + IF( FULL )THEN + NARGS = 11 + ELSE IF( BANDED )THEN + NARGS = 13 + END IF +* + NC = 0 + RESET = .TRUE. + ERRMAX = RZERO +* + DO 120 IN = 1, NIDIM + N = IDIM( IN ) + ND = N/2 + 1 +* + DO 110 IM = 1, 2 + IF( IM.EQ.1 ) + $ M = MAX( N - ND, 0 ) + IF( IM.EQ.2 ) + $ M = MIN( N + ND, NMAX ) +* + IF( BANDED )THEN + NK = NKB + ELSE + NK = 1 + END IF + DO 100 IKU = 1, NK + IF( BANDED )THEN + KU = KB( IKU ) + KL = MAX( KU - 1, 0 ) + ELSE + KU = N - 1 + KL = M - 1 + END IF +* Set LDA to 1 more than minimum value if room. + IF( BANDED )THEN + LDA = KL + KU + 1 + ELSE + LDA = M + END IF + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 100 + LAA = LDA*N + NULL = N.LE.0.OR.M.LE.0 +* +* Generate the matrix A. +* + TRANSL = ZERO + CALL CMAKE( SNAME( 8: 9 ), ' ', ' ', M, N, A, NMAX, AA, + $ LDA, KL, KU, RESET, TRANSL ) +* + DO 90 IC = 1, 3 + TRANS = ICH( IC: IC ) + IF (TRANS.EQ.'N')THEN + CTRANS = ' CblasNoTrans' + ELSE IF (TRANS.EQ.'T')THEN + CTRANS = ' CblasTrans' + ELSE + CTRANS = 'CblasConjTrans' + END IF + TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' +* + IF( TRAN )THEN + ML = N + NL = M + ELSE + ML = M + NL = N + END IF +* + DO 80 IX = 1, NINC + INCX = INC( IX ) + LX = ABS( INCX )*NL +* +* Generate the vector X. +* + TRANSL = HALF + CALL CMAKE( 'ge', ' ', ' ', 1, NL, X, 1, XX, + $ ABS( INCX ), 0, NL - 1, RESET, TRANSL ) + IF( NL.GT.1 )THEN + X( NL/2 ) = ZERO + XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO + END IF +* + DO 70 IY = 1, NINC + INCY = INC( IY ) + LY = ABS( INCY )*ML +* + DO 60 IA = 1, NALF + ALPHA = ALF( IA ) +* + DO 50 IB = 1, NBET + BETA = BET( IB ) +* +* Generate the vector Y. +* + TRANSL = ZERO + CALL CMAKE( 'ge', ' ', ' ', 1, ML, Y, 1, + $ YY, ABS( INCY ), 0, ML - 1, + $ RESET, TRANSL ) +* + NC = NC + 1 +* +* Save every datum before calling the +* subroutine. +* + TRANSS = TRANS + MS = M + NS = N + KLS = KL + KUS = KU + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LX + XS( I ) = XX( I ) + 20 CONTINUE + INCXS = INCX + BLS = BETA + DO 30 I = 1, LY + YS( I ) = YY( I ) + 30 CONTINUE + INCYS = INCY +* +* Call the subroutine. +* + IF( FULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9994 )NC, SNAME, + $ CTRANS, M, N, ALPHA, LDA, INCX, BETA, + $ INCY + IF( REWI ) + $ REWIND NTRA + CALL CCGEMV( IORDER, TRANS, M, N, + $ ALPHA, AA, LDA, XX, INCX, + $ BETA, YY, INCY ) + ELSE IF( BANDED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9995 )NC, SNAME, + $ CTRANS, M, N, KL, KU, ALPHA, LDA, + $ INCX, BETA, INCY + IF( REWI ) + $ REWIND NTRA + CALL CCGBMV( IORDER, TRANS, M, N, KL, + $ KU, ALPHA, AA, LDA, XX, + $ INCX, BETA, YY, INCY ) + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9993 ) + FATAL = .TRUE. + GO TO 130 + END IF +* +* See what data changed inside subroutines. +* +* IF(TRANS .NE. 'C' .OR. (INCX .GT. 0 .AND. INCY .GT. 0)) THEN + ISAME( 1 ) = TRANS.EQ.TRANSS + ISAME( 2 ) = MS.EQ.M + ISAME( 3 ) = NS.EQ.N + IF( FULL )THEN + ISAME( 4 ) = ALS.EQ.ALPHA + ISAME( 5 ) = LCE( AS, AA, LAA ) + ISAME( 6 ) = LDAS.EQ.LDA + ISAME( 7 ) = LCE( XS, XX, LX ) + ISAME( 8 ) = INCXS.EQ.INCX + ISAME( 9 ) = BLS.EQ.BETA + IF( NULL )THEN + ISAME( 10 ) = LCE( YS, YY, LY ) + ELSE + ISAME( 10 ) = LCERES( 'ge', ' ', 1, + $ ML, YS, YY, + $ ABS( INCY ) ) + END IF + ISAME( 11 ) = INCYS.EQ.INCY + ELSE IF( BANDED )THEN + ISAME( 4 ) = KLS.EQ.KL + ISAME( 5 ) = KUS.EQ.KU + ISAME( 6 ) = ALS.EQ.ALPHA + ISAME( 7 ) = LCE( AS, AA, LAA ) + ISAME( 8 ) = LDAS.EQ.LDA + ISAME( 9 ) = LCE( XS, XX, LX ) + ISAME( 10 ) = INCXS.EQ.INCX + ISAME( 11 ) = BLS.EQ.BETA + IF( NULL )THEN + ISAME( 12 ) = LCE( YS, YY, LY ) + ELSE + ISAME( 12 ) = LCERES( 'ge', ' ', 1, + $ ML, YS, YY, + $ ABS( INCY ) ) + END IF + ISAME( 13 ) = INCYS.EQ.INCY + END IF +* +* If data was incorrectly changed, report +* and return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 130 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result. +* + CALL CMVCH( TRANS, M, N, ALPHA, A, + $ NMAX, X, INCX, BETA, Y, + $ INCY, YT, G, YY, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and +* return. + IF( FATAL ) + $ GO TO 130 + ELSE +* Avoid repeating tests with M.le.0 or +* N.le.0. + GO TO 110 + END IF +* END IF +* + 50 CONTINUE +* + 60 CONTINUE +* + 70 CONTINUE +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* + 110 CONTINUE +* + 120 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + WRITE( NOUT, FMT = 9999 )SNAME, NC + ELSE + WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX + END IF + GO TO 140 +* + 130 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + IF( FULL )THEN + WRITE( NOUT, FMT = 9994 )NC, SNAME, CTRANS, M, N, ALPHA, LDA, + $ INCX, BETA, INCY + ELSE IF( BANDED )THEN + WRITE( NOUT, FMT = 9995 )NC, SNAME, CTRANS, M, N, KL, KU, + $ ALPHA, LDA, INCX, BETA, INCY + END IF +* + 140 CONTINUE + RETURN +* + 9999 FORMAT(' ',A12, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + $ 'S)' ) + 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9997 FORMAT(' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, + $ ' - SUSPECT *******' ) + 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', 4( I3, ',' ), '(', + $ F4.1, ',', F4.1, '), A,',/ 10x, I3, ', X,', I2, ',(', + $ F4.1, ',', F4.1, '), Y,', I2, ') .' ) + 9994 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', 2( I3, ',' ), '(', + $ F4.1, ',', F4.1, '), A,',/ 10x, I3, ', X,', I2, ',(', + $ F4.1, ',', F4.1, '), Y,', I2, ') .' ) + 9993 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of CCHK1. +* + END + SUBROUTINE CCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, + $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, + $ XS, Y, YY, YS, YT, G, IORDER ) +* +* Tests CHEMV, CHBMV and CHPMV. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + COMPLEX ZERO, HALF + PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ) ) + REAL RZERO + PARAMETER ( RZERO = 0.0 ) +* .. Scalar Arguments .. + REAL EPS, THRESH + INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, + $ NOUT, NTRA, IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), BET( NBET ), X( NMAX ), + $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), + $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), + $ YY( NMAX*INCMAX ) + REAL G( NMAX ) + INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) +* .. Local Scalars .. + COMPLEX ALPHA, ALS, BETA, BLS, TRANSL + REAL ERR, ERRMAX + INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY, + $ INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY, + $ N, NARGS, NC, NK, NS + LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME + CHARACTER*1 UPLO, UPLOS + CHARACTER*14 CUPLO + CHARACTER*2 ICH +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LCE, LCERES + EXTERNAL LCE, LCERES +* .. External Subroutines .. + EXTERNAL CCHBMV, CCHEMV, CCHPMV, CMAKE, CMVCH +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICH/'UL'/ +* .. Executable Statements .. + FULL = SNAME( 9: 9 ).EQ.'e' + BANDED = SNAME( 9: 9 ).EQ.'b' + PACKED = SNAME( 9: 9 ).EQ.'p' +* Define the number of arguments. + IF( FULL )THEN + NARGS = 10 + ELSE IF( BANDED )THEN + NARGS = 11 + ELSE IF( PACKED )THEN + NARGS = 9 + END IF +* + NC = 0 + RESET = .TRUE. + ERRMAX = RZERO +* + DO 110 IN = 1, NIDIM + N = IDIM( IN ) +* + IF( BANDED )THEN + NK = NKB + ELSE + NK = 1 + END IF + DO 100 IK = 1, NK + IF( BANDED )THEN + K = KB( IK ) + ELSE + K = N - 1 + END IF +* Set LDA to 1 more than minimum value if room. + IF( BANDED )THEN + LDA = K + 1 + ELSE + LDA = N + END IF + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 100 + IF( PACKED )THEN + LAA = ( N*( N + 1 ) )/2 + ELSE + LAA = LDA*N + END IF + NULL = N.LE.0 +* + DO 90 IC = 1, 2 + UPLO = ICH( IC: IC ) + IF (UPLO.EQ.'U')THEN + CUPLO = ' CblasUpper' + ELSE + CUPLO = ' CblasLower' + END IF +* +* Generate the matrix A. +* + TRANSL = ZERO + CALL CMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, A, NMAX, AA, + $ LDA, K, K, RESET, TRANSL ) +* + DO 80 IX = 1, NINC + INCX = INC( IX ) + LX = ABS( INCX )*N +* +* Generate the vector X. +* + TRANSL = HALF + CALL CMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX, + $ ABS( INCX ), 0, N - 1, RESET, TRANSL ) + IF( N.GT.1 )THEN + X( N/2 ) = ZERO + XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO + END IF +* + DO 70 IY = 1, NINC + INCY = INC( IY ) + LY = ABS( INCY )*N +* + DO 60 IA = 1, NALF + ALPHA = ALF( IA ) +* + DO 50 IB = 1, NBET + BETA = BET( IB ) +* +* Generate the vector Y. +* + TRANSL = ZERO + CALL CMAKE( 'ge', ' ', ' ', 1, N, Y, 1, YY, + $ ABS( INCY ), 0, N - 1, RESET, + $ TRANSL ) +* + NC = NC + 1 +* +* Save every datum before calling the +* subroutine. +* + UPLOS = UPLO + NS = N + KS = K + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LX + XS( I ) = XX( I ) + 20 CONTINUE + INCXS = INCX + BLS = BETA + DO 30 I = 1, LY + YS( I ) = YY( I ) + 30 CONTINUE + INCYS = INCY +* +* Call the subroutine. +* + IF( FULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, + $ CUPLO, N, ALPHA, LDA, INCX, BETA, INCY + IF( REWI ) + $ REWIND NTRA + CALL CCHEMV( IORDER, UPLO, N, ALPHA, AA, + $ LDA, XX, INCX, BETA, YY, + $ INCY ) + ELSE IF( BANDED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9994 )NC, SNAME, + $ CUPLO, N, K, ALPHA, LDA, INCX, BETA, + $ INCY + IF( REWI ) + $ REWIND NTRA + CALL CCHBMV( IORDER, UPLO, N, K, ALPHA, + $ AA, LDA, XX, INCX, BETA, + $ YY, INCY ) + ELSE IF( PACKED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9995 )NC, SNAME, + $ CUPLO, N, ALPHA, INCX, BETA, INCY + IF( REWI ) + $ REWIND NTRA + CALL CCHPMV( IORDER, UPLO, N, ALPHA, AA, + $ XX, INCX, BETA, YY, INCY ) + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9992 ) + FATAL = .TRUE. + GO TO 120 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = UPLO.EQ.UPLOS + ISAME( 2 ) = NS.EQ.N + IF( FULL )THEN + ISAME( 3 ) = ALS.EQ.ALPHA + ISAME( 4 ) = LCE( AS, AA, LAA ) + ISAME( 5 ) = LDAS.EQ.LDA + ISAME( 6 ) = LCE( XS, XX, LX ) + ISAME( 7 ) = INCXS.EQ.INCX + ISAME( 8 ) = BLS.EQ.BETA + IF( NULL )THEN + ISAME( 9 ) = LCE( YS, YY, LY ) + ELSE + ISAME( 9 ) = LCERES( 'ge', ' ', 1, N, + $ YS, YY, ABS( INCY ) ) + END IF + ISAME( 10 ) = INCYS.EQ.INCY + ELSE IF( BANDED )THEN + ISAME( 3 ) = KS.EQ.K + ISAME( 4 ) = ALS.EQ.ALPHA + ISAME( 5 ) = LCE( AS, AA, LAA ) + ISAME( 6 ) = LDAS.EQ.LDA + ISAME( 7 ) = LCE( XS, XX, LX ) + ISAME( 8 ) = INCXS.EQ.INCX + ISAME( 9 ) = BLS.EQ.BETA + IF( NULL )THEN + ISAME( 10 ) = LCE( YS, YY, LY ) + ELSE + ISAME( 10 ) = LCERES( 'ge', ' ', 1, N, + $ YS, YY, ABS( INCY ) ) + END IF + ISAME( 11 ) = INCYS.EQ.INCY + ELSE IF( PACKED )THEN + ISAME( 3 ) = ALS.EQ.ALPHA + ISAME( 4 ) = LCE( AS, AA, LAA ) + ISAME( 5 ) = LCE( XS, XX, LX ) + ISAME( 6 ) = INCXS.EQ.INCX + ISAME( 7 ) = BLS.EQ.BETA + IF( NULL )THEN + ISAME( 8 ) = LCE( YS, YY, LY ) + ELSE + ISAME( 8 ) = LCERES( 'ge', ' ', 1, N, + $ YS, YY, ABS( INCY ) ) + END IF + ISAME( 9 ) = INCYS.EQ.INCY + END IF +* +* If data was incorrectly changed, report and +* return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 120 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result. +* + CALL CMVCH( 'N', N, N, ALPHA, A, NMAX, X, + $ INCX, BETA, Y, INCY, YT, G, + $ YY, EPS, ERR, FATAL, NOUT, + $ .TRUE. ) + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and +* return. + IF( FATAL ) + $ GO TO 120 + ELSE +* Avoid repeating tests with N.le.0 + GO TO 110 + END IF +* + 50 CONTINUE +* + 60 CONTINUE +* + 70 CONTINUE +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* + 110 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + WRITE( NOUT, FMT = 9999 )SNAME, NC + ELSE + WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX + END IF + GO TO 130 +* + 120 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + IF( FULL )THEN + WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, N, ALPHA, LDA, INCX, + $ BETA, INCY + ELSE IF( BANDED )THEN + WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, N, K, ALPHA, LDA, + $ INCX, BETA, INCY + ELSE IF( PACKED )THEN + WRITE( NOUT, FMT = 9995 )NC, SNAME, CUPLO, N, ALPHA, INCX, + $ BETA, INCY + END IF +* + 130 CONTINUE + RETURN +* + 9999 FORMAT(' ',A12, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + $ 'S)' ) + 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9997 FORMAT(' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, + $ ' - SUSPECT *******' ) + 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',(', F4.1, ',', + $ F4.1, '), AP, X,',/ 10x, I2, ',(', F4.1, ',', F4.1, + $ '), Y,', I2, ') .' ) + 9994 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', 2( I3, ',' ), '(', + $ F4.1, ',', F4.1, '), A,', I3, ', X,',/ 10x, I2, ',(', + $ F4.1, ',', F4.1, '), Y,', I2, ') .' ) + 9993 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',(', F4.1, ',', + $ F4.1, '), A,', I3, ', X,',/ 10x, I2, ',(', F4.1, ',', + $ F4.1, '), ', 'Y,', I2, ') .' ) + 9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of CCHK2. +* + END + SUBROUTINE CCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX, + $ INCMAX, A, AA, AS, X, XX, XS, XT, G, Z, IORDER ) +* +* Tests CTRMV, CTBMV, CTPMV, CTRSV, CTBSV and CTPSV. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + COMPLEX ZERO, HALF, ONE + PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ), + $ ONE = ( 1.0, 0.0 ) ) + REAL RZERO + PARAMETER ( RZERO = 0.0 ) +* .. Scalar Arguments .. + REAL EPS, THRESH + INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA, + $ IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), + $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), + $ XT( NMAX ), XX( NMAX*INCMAX ), Z( NMAX ) + REAL G( NMAX ) + INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) +* .. Local Scalars .. + COMPLEX TRANSL + REAL ERR, ERRMAX + INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K, + $ KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS + LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME + CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS + CHARACTER*14 CUPLO,CTRANS,CDIAG + CHARACTER*2 ICHD, ICHU + CHARACTER*3 ICHT +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LCE, LCERES + EXTERNAL LCE, LCERES +* .. External Subroutines .. + EXTERNAL CMAKE, CMVCH, CCTBMV, CCTBSV, CCTPMV, + $ CCTPSV, CCTRMV, CCTRSV +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/ +* .. Executable Statements .. + FULL = SNAME( 9: 9 ).EQ.'r' + BANDED = SNAME( 9: 9 ).EQ.'b' + PACKED = SNAME( 9: 9 ).EQ.'p' +* Define the number of arguments. + IF( FULL )THEN + NARGS = 8 + ELSE IF( BANDED )THEN + NARGS = 9 + ELSE IF( PACKED )THEN + NARGS = 7 + END IF +* + NC = 0 + RESET = .TRUE. + ERRMAX = RZERO +* Set up zero vector for CMVCH. + DO 10 I = 1, NMAX + Z( I ) = ZERO + 10 CONTINUE +* + DO 110 IN = 1, NIDIM + N = IDIM( IN ) +* + IF( BANDED )THEN + NK = NKB + ELSE + NK = 1 + END IF + DO 100 IK = 1, NK + IF( BANDED )THEN + K = KB( IK ) + ELSE + K = N - 1 + END IF +* Set LDA to 1 more than minimum value if room. + IF( BANDED )THEN + LDA = K + 1 + ELSE + LDA = N + END IF + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 100 + IF( PACKED )THEN + LAA = ( N*( N + 1 ) )/2 + ELSE + LAA = LDA*N + END IF + NULL = N.LE.0 +* + DO 90 ICU = 1, 2 + UPLO = ICHU( ICU: ICU ) + IF (UPLO.EQ.'U')THEN + CUPLO = ' CblasUpper' + ELSE + CUPLO = ' CblasLower' + END IF +* + DO 80 ICT = 1, 3 + TRANS = ICHT( ICT: ICT ) + IF (TRANS.EQ.'N')THEN + CTRANS = ' CblasNoTrans' + ELSE IF (TRANS.EQ.'T')THEN + CTRANS = ' CblasTrans' + ELSE + CTRANS = 'CblasConjTrans' + END IF +* + DO 70 ICD = 1, 2 + DIAG = ICHD( ICD: ICD ) + IF (DIAG.EQ.'N')THEN + CDIAG = ' CblasNonUnit' + ELSE + CDIAG = ' CblasUnit' + END IF +* +* Generate the matrix A. +* + TRANSL = ZERO + CALL CMAKE( SNAME( 8: 9 ), UPLO, DIAG, N, N, A, + $ NMAX, AA, LDA, K, K, RESET, TRANSL ) +* + DO 60 IX = 1, NINC + INCX = INC( IX ) + LX = ABS( INCX )*N +* +* Generate the vector X. +* + TRANSL = HALF + CALL CMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX, + $ ABS( INCX ), 0, N - 1, RESET, + $ TRANSL ) + IF( N.GT.1 )THEN + X( N/2 ) = ZERO + XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO + END IF +* + NC = NC + 1 +* +* Save every datum before calling the subroutine. +* + UPLOS = UPLO + TRANSS = TRANS + DIAGS = DIAG + NS = N + KS = K + DO 20 I = 1, LAA + AS( I ) = AA( I ) + 20 CONTINUE + LDAS = LDA + DO 30 I = 1, LX + XS( I ) = XX( I ) + 30 CONTINUE + INCXS = INCX +* +* Call the subroutine. +* + IF( SNAME( 10: 11 ).EQ.'mv' )THEN + IF( FULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, + $ CUPLO, CTRANS, CDIAG, N, LDA, INCX + IF( REWI ) + $ REWIND NTRA + CALL CCTRMV( IORDER, UPLO, TRANS, DIAG, + $ N, AA, LDA, XX, INCX ) + ELSE IF( BANDED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9994 )NC, SNAME, + $ CUPLO, CTRANS, CDIAG, N, K, LDA, INCX + IF( REWI ) + $ REWIND NTRA + CALL CCTBMV( IORDER, UPLO, TRANS, DIAG, + $ N, K, AA, LDA, XX, INCX ) + ELSE IF( PACKED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9995 )NC, SNAME, + $ CUPLO, CTRANS, CDIAG, N, INCX + IF( REWI ) + $ REWIND NTRA + CALL CCTPMV( IORDER, UPLO, TRANS, DIAG, + $ N, AA, XX, INCX ) + END IF + ELSE IF( SNAME( 10: 11 ).EQ.'sv' )THEN + IF( FULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, + $ CUPLO, CTRANS, CDIAG, N, LDA, INCX + IF( REWI ) + $ REWIND NTRA + CALL CCTRSV( IORDER, UPLO, TRANS, DIAG, + $ N, AA, LDA, XX, INCX ) + ELSE IF( BANDED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9994 )NC, SNAME, + $ CUPLO, CTRANS, CDIAG, N, K, LDA, INCX + IF( REWI ) + $ REWIND NTRA + CALL CCTBSV( IORDER, UPLO, TRANS, DIAG, + $ N, K, AA, LDA, XX, INCX ) + ELSE IF( PACKED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9995 )NC, SNAME, + $ CUPLO, CTRANS, CDIAG, N, INCX + IF( REWI ) + $ REWIND NTRA + CALL CCTPSV( IORDER, UPLO, TRANS, DIAG, + $ N, AA, XX, INCX ) + END IF + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9992 ) + FATAL = .TRUE. + GO TO 120 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = UPLO.EQ.UPLOS + ISAME( 2 ) = TRANS.EQ.TRANSS + ISAME( 3 ) = DIAG.EQ.DIAGS + ISAME( 4 ) = NS.EQ.N + IF( FULL )THEN + ISAME( 5 ) = LCE( AS, AA, LAA ) + ISAME( 6 ) = LDAS.EQ.LDA + IF( NULL )THEN + ISAME( 7 ) = LCE( XS, XX, LX ) + ELSE + ISAME( 7 ) = LCERES( 'ge', ' ', 1, N, XS, + $ XX, ABS( INCX ) ) + END IF + ISAME( 8 ) = INCXS.EQ.INCX + ELSE IF( BANDED )THEN + ISAME( 5 ) = KS.EQ.K + ISAME( 6 ) = LCE( AS, AA, LAA ) + ISAME( 7 ) = LDAS.EQ.LDA + IF( NULL )THEN + ISAME( 8 ) = LCE( XS, XX, LX ) + ELSE + ISAME( 8 ) = LCERES( 'ge', ' ', 1, N, XS, + $ XX, ABS( INCX ) ) + END IF + ISAME( 9 ) = INCXS.EQ.INCX + ELSE IF( PACKED )THEN + ISAME( 5 ) = LCE( AS, AA, LAA ) + IF( NULL )THEN + ISAME( 6 ) = LCE( XS, XX, LX ) + ELSE + ISAME( 6 ) = LCERES( 'ge', ' ', 1, N, XS, + $ XX, ABS( INCX ) ) + END IF + ISAME( 7 ) = INCXS.EQ.INCX + END IF +* +* If data was incorrectly changed, report and +* return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 120 + END IF +* + IF( .NOT.NULL )THEN + IF( SNAME( 10: 11 ).EQ.'mv' )THEN +* +* Check the result. +* + CALL CMVCH( TRANS, N, N, ONE, A, NMAX, X, + $ INCX, ZERO, Z, INCX, XT, G, + $ XX, EPS, ERR, FATAL, NOUT, + $ .TRUE. ) + ELSE IF( SNAME( 10: 11 ).EQ.'sv' )THEN +* +* Compute approximation to original vector. +* + DO 50 I = 1, N + Z( I ) = XX( 1 + ( I - 1 )* + $ ABS( INCX ) ) + XX( 1 + ( I - 1 )*ABS( INCX ) ) + $ = X( I ) + 50 CONTINUE + CALL CMVCH( TRANS, N, N, ONE, A, NMAX, Z, + $ INCX, ZERO, X, INCX, XT, G, + $ XX, EPS, ERR, FATAL, NOUT, + $ .FALSE. ) + END IF + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and return. + IF( FATAL ) + $ GO TO 120 + ELSE +* Avoid repeating tests with N.le.0. + GO TO 110 + END IF +* + 60 CONTINUE +* + 70 CONTINUE +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* + 110 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + WRITE( NOUT, FMT = 9999 )SNAME, NC + ELSE + WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX + END IF + GO TO 130 +* + 120 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + IF( FULL )THEN + WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, CTRANS, CDIAG, N, + $ LDA, INCX + ELSE IF( BANDED )THEN + WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, CTRANS, CDIAG, N, K, + $ LDA, INCX + ELSE IF( PACKED )THEN + WRITE( NOUT, FMT = 9995 )NC, SNAME, CUPLO, CTRANS, CDIAG, N, + $ INCX + END IF +* + 130 CONTINUE + RETURN +* + 9999 FORMAT(' ',A12, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + $ 'S)' ) + 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9997 FORMAT(' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, + $ ' - SUSPECT *******' ) + 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT(1X, I6, ': ',A12, '(', 3( A14, ',' ),/ 10x, I3, ', AP, ', + $ 'X,', I2, ') .' ) + 9994 FORMAT(1X, I6, ': ',A12, '(', 3( A14, ',' ),/ 10x, 2( I3, ',' ), + $ ' A,', I3, ', X,', I2, ') .' ) + 9993 FORMAT( 1X, I6, ': ',A12, '(', 3( A14, ',' ),/ 10x, I3, ', A,', + $ I3, ', X,', I2, ') .' ) + 9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of CCHK3. +* + END + SUBROUTINE CCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, + $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, + $ Z, IORDER ) +* +* Tests CGERC and CGERU. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + COMPLEX ZERO, HALF, ONE + PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ), + $ ONE = ( 1.0, 0.0 ) ) + REAL RZERO + PARAMETER ( RZERO = 0.0 ) +* .. Scalar Arguments .. + REAL EPS, THRESH + INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA, + $ IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), + $ XX( NMAX*INCMAX ), Y( NMAX ), + $ YS( NMAX*INCMAX ), YT( NMAX ), + $ YY( NMAX*INCMAX ), Z( NMAX ) + REAL G( NMAX ) + INTEGER IDIM( NIDIM ), INC( NINC ) +* .. Local Scalars .. + COMPLEX ALPHA, ALS, TRANSL + REAL ERR, ERRMAX + INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX, + $ IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS, + $ NC, ND, NS + LOGICAL CONJ, NULL, RESET, SAME +* .. Local Arrays .. + COMPLEX W( 1 ) + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LCE, LCERES + EXTERNAL LCE, LCERES +* .. External Subroutines .. + EXTERNAL CCGERC, CCGERU, CMAKE, CMVCH +* .. Intrinsic Functions .. + INTRINSIC ABS, CONJG, MAX, MIN +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Executable Statements .. + CONJ = SNAME( 11: 11 ).EQ.'c' +* Define the number of arguments. + NARGS = 9 +* + NC = 0 + RESET = .TRUE. + ERRMAX = RZERO +* + DO 120 IN = 1, NIDIM + N = IDIM( IN ) + ND = N/2 + 1 +* + DO 110 IM = 1, 2 + IF( IM.EQ.1 ) + $ M = MAX( N - ND, 0 ) + IF( IM.EQ.2 ) + $ M = MIN( N + ND, NMAX ) +* +* Set LDA to 1 more than minimum value if room. + LDA = M + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 110 + LAA = LDA*N + NULL = N.LE.0.OR.M.LE.0 +* + DO 100 IX = 1, NINC + INCX = INC( IX ) + LX = ABS( INCX )*M +* +* Generate the vector X. +* + TRANSL = HALF + CALL CMAKE( 'ge', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ), + $ 0, M - 1, RESET, TRANSL ) + IF( M.GT.1 )THEN + X( M/2 ) = ZERO + XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO + END IF +* + DO 90 IY = 1, NINC + INCY = INC( IY ) + LY = ABS( INCY )*N +* +* Generate the vector Y. +* + TRANSL = ZERO + CALL CMAKE( 'ge', ' ', ' ', 1, N, Y, 1, YY, + $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) + IF( N.GT.1 )THEN + Y( N/2 ) = ZERO + YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO + END IF +* + DO 80 IA = 1, NALF + ALPHA = ALF( IA ) +* +* Generate the matrix A. +* + TRANSL = ZERO + CALL CMAKE(SNAME( 8: 9 ), ' ', ' ', M, N, A, NMAX, + $ AA, LDA, M - 1, N - 1, RESET, TRANSL ) +* + NC = NC + 1 +* +* Save every datum before calling the subroutine. +* + MS = M + NS = N + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LX + XS( I ) = XX( I ) + 20 CONTINUE + INCXS = INCX + DO 30 I = 1, LY + YS( I ) = YY( I ) + 30 CONTINUE + INCYS = INCY +* +* Call the subroutine. +* + IF( TRACE ) + $ WRITE( NTRA, FMT = 9994 )NC, SNAME, M, N, + $ ALPHA, INCX, INCY, LDA + IF( CONJ )THEN + IF( REWI ) + $ REWIND NTRA + CALL CCGERC( IORDER, M, N, ALPHA, XX, INCX, + $ YY, INCY, AA, LDA ) + ELSE + IF( REWI ) + $ REWIND NTRA + CALL CCGERU( IORDER, M, N, ALPHA, XX, INCX, + $ YY, INCY, AA, LDA ) + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9993 ) + FATAL = .TRUE. + GO TO 140 + END IF +* +* See what data changed inside subroutine. +* + ISAME( 1 ) = MS.EQ.M + ISAME( 2 ) = NS.EQ.N + ISAME( 3 ) = ALS.EQ.ALPHA + ISAME( 4 ) = LCE( XS, XX, LX ) + ISAME( 5 ) = INCXS.EQ.INCX + ISAME( 6 ) = LCE( YS, YY, LY ) + ISAME( 7 ) = INCYS.EQ.INCY + IF( NULL )THEN + ISAME( 8 ) = LCE( AS, AA, LAA ) + ELSE + ISAME( 8 ) = LCERES( 'ge', ' ', M, N, AS, AA, + $ LDA ) + END IF + ISAME( 9 ) = LDAS.EQ.LDA +* +* If data was incorrectly changed, report and return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 140 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result column by column. +* + IF( INCX.GT.0 )THEN + DO 50 I = 1, M + Z( I ) = X( I ) + 50 CONTINUE + ELSE + DO 60 I = 1, M + Z( I ) = X( M - I + 1 ) + 60 CONTINUE + END IF + DO 70 J = 1, N + IF( INCY.GT.0 )THEN + W( 1 ) = Y( J ) + ELSE + W( 1 ) = Y( N - J + 1 ) + END IF + IF( CONJ ) + $ W( 1 ) = CONJG( W( 1 ) ) + CALL CMVCH( 'N', M, 1, ALPHA, Z, NMAX, W, 1, + $ ONE, A( 1, J ), 1, YT, G, + $ AA( 1 + ( J - 1 )*LDA ), EPS, + $ ERR, FATAL, NOUT, .TRUE. ) + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and return. + IF( FATAL ) + $ GO TO 130 + 70 CONTINUE + ELSE +* Avoid repeating tests with M.le.0 or N.le.0. + GO TO 110 + END IF +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* + 110 CONTINUE +* + 120 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + WRITE( NOUT, FMT = 9999 )SNAME, NC + ELSE + WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX + END IF + GO TO 150 +* + 130 CONTINUE + WRITE( NOUT, FMT = 9995 )J +* + 140 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + WRITE( NOUT, FMT = 9994 )NC, SNAME, M, N, ALPHA, INCX, INCY, LDA +* + 150 CONTINUE + RETURN +* + 9999 FORMAT(' ',A12, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + $ 'S)' ) + 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9997 FORMAT(' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, + $ ' - SUSPECT *******' ) + 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) + 9994 FORMAT(1X, I6, ': ',A12, '(', 2( I3, ',' ), '(', F4.1, ',', F4.1, + $ '), X,', I2, ', Y,', I2, ', A,', I3, ') .' ) + 9993 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of CCHK4. +* + END + SUBROUTINE CCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, + $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, + $ Z, IORDER ) +* +* Tests CHER and CHPR. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + COMPLEX ZERO, HALF, ONE + PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ), + $ ONE = ( 1.0, 0.0 ) ) + REAL RZERO + PARAMETER ( RZERO = 0.0 ) +* .. Scalar Arguments .. + REAL EPS, THRESH + INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA, + $ IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), + $ XX( NMAX*INCMAX ), Y( NMAX ), + $ YS( NMAX*INCMAX ), YT( NMAX ), + $ YY( NMAX*INCMAX ), Z( NMAX ) + REAL G( NMAX ) + INTEGER IDIM( NIDIM ), INC( NINC ) +* .. Local Scalars .. + COMPLEX ALPHA, TRANSL + REAL ERR, ERRMAX, RALPHA, RALS + INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA, + $ LDA, LDAS, LJ, LX, N, NARGS, NC, NS + LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER + CHARACTER*1 UPLO, UPLOS + CHARACTER*14 CUPLO + CHARACTER*2 ICH +* .. Local Arrays .. + COMPLEX W( 1 ) + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LCE, LCERES + EXTERNAL LCE, LCERES +* .. External Subroutines .. + EXTERNAL CCHER, CCHPR, CMAKE, CMVCH +* .. Intrinsic Functions .. + INTRINSIC ABS, CMPLX, CONJG, MAX, REAL +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICH/'UL'/ +* .. Executable Statements .. + FULL = SNAME( 9: 9 ).EQ.'e' + PACKED = SNAME( 9: 9 ).EQ.'p' +* Define the number of arguments. + IF( FULL )THEN + NARGS = 7 + ELSE IF( PACKED )THEN + NARGS = 6 + END IF +* + NC = 0 + RESET = .TRUE. + ERRMAX = RZERO +* + DO 100 IN = 1, NIDIM + N = IDIM( IN ) +* Set LDA to 1 more than minimum value if room. + LDA = N + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 100 + IF( PACKED )THEN + LAA = ( N*( N + 1 ) )/2 + ELSE + LAA = LDA*N + END IF +* + DO 90 IC = 1, 2 + UPLO = ICH( IC: IC ) + IF (UPLO.EQ.'U')THEN + CUPLO = ' CblasUpper' + ELSE + CUPLO = ' CblasLower' + END IF + UPPER = UPLO.EQ.'U' +* + DO 80 IX = 1, NINC + INCX = INC( IX ) + LX = ABS( INCX )*N +* +* Generate the vector X. +* + TRANSL = HALF + CALL CMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), + $ 0, N - 1, RESET, TRANSL ) + IF( N.GT.1 )THEN + X( N/2 ) = ZERO + XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO + END IF +* + DO 70 IA = 1, NALF + RALPHA = REAL( ALF( IA ) ) + ALPHA = CMPLX( RALPHA, RZERO ) + NULL = N.LE.0.OR.RALPHA.EQ.RZERO +* +* Generate the matrix A. +* + TRANSL = ZERO + CALL CMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, A, NMAX, + $ AA, LDA, N - 1, N - 1, RESET, TRANSL ) +* + NC = NC + 1 +* +* Save every datum before calling the subroutine. +* + UPLOS = UPLO + NS = N + RALS = RALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LX + XS( I ) = XX( I ) + 20 CONTINUE + INCXS = INCX +* +* Call the subroutine. +* + IF( FULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, CUPLO, N, + $ RALPHA, INCX, LDA + IF( REWI ) + $ REWIND NTRA + CALL CCHER( IORDER, UPLO, N, RALPHA, XX, + $ INCX, AA, LDA ) + ELSE IF( PACKED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9994 )NC, SNAME, CUPLO, N, + $ RALPHA, INCX + IF( REWI ) + $ REWIND NTRA + CALL CCHPR( IORDER, UPLO, N, RALPHA, + $ XX, INCX, AA ) + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9992 ) + FATAL = .TRUE. + GO TO 120 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = UPLO.EQ.UPLOS + ISAME( 2 ) = NS.EQ.N + ISAME( 3 ) = RALS.EQ.RALPHA + ISAME( 4 ) = LCE( XS, XX, LX ) + ISAME( 5 ) = INCXS.EQ.INCX + IF( NULL )THEN + ISAME( 6 ) = LCE( AS, AA, LAA ) + ELSE + ISAME( 6 ) = LCERES( SNAME( 8: 9 ), UPLO, N, N, AS, + $ AA, LDA ) + END IF + IF( .NOT.PACKED )THEN + ISAME( 7 ) = LDAS.EQ.LDA + END IF +* +* If data was incorrectly changed, report and return. +* + SAME = .TRUE. + DO 30 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 30 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 120 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result column by column. +* + IF( INCX.GT.0 )THEN + DO 40 I = 1, N + Z( I ) = X( I ) + 40 CONTINUE + ELSE + DO 50 I = 1, N + Z( I ) = X( N - I + 1 ) + 50 CONTINUE + END IF + JA = 1 + DO 60 J = 1, N + W( 1 ) = CONJG( Z( J ) ) + IF( UPPER )THEN + JJ = 1 + LJ = J + ELSE + JJ = J + LJ = N - J + 1 + END IF + CALL CMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W, + $ 1, ONE, A( JJ, J ), 1, YT, G, + $ AA( JA ), EPS, ERR, FATAL, NOUT, + $ .TRUE. ) + IF( FULL )THEN + IF( UPPER )THEN + JA = JA + LDA + ELSE + JA = JA + LDA + 1 + END IF + ELSE + JA = JA + LJ + END IF + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and return. + IF( FATAL ) + $ GO TO 110 + 60 CONTINUE + ELSE +* Avoid repeating tests if N.le.0. + IF( N.LE.0 ) + $ GO TO 100 + END IF +* + 70 CONTINUE +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + WRITE( NOUT, FMT = 9999 )SNAME, NC + ELSE + WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX + END IF + GO TO 130 +* + 110 CONTINUE + WRITE( NOUT, FMT = 9995 )J +* + 120 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + IF( FULL )THEN + WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, N, RALPHA, INCX, LDA + ELSE IF( PACKED )THEN + WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, N, RALPHA, INCX + END IF +* + 130 CONTINUE + RETURN +* + 9999 FORMAT(' ',A12, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + $ 'S)' ) + 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9997 FORMAT(' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, + $ ' - SUSPECT *******' ) + 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) + 9994 FORMAT(1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', X,', + $ I2, ', AP) .' ) + 9993 FORMAT(1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', X,', + $ I2, ', A,', I3, ') .' ) + 9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of CCHK5. +* + END + SUBROUTINE CCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, + $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, + $ Z, IORDER ) +* +* Tests CHER2 and CHPR2. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + COMPLEX ZERO, HALF, ONE + PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ), + $ ONE = ( 1.0, 0.0 ) ) + REAL RZERO + PARAMETER ( RZERO = 0.0 ) +* .. Scalar Arguments .. + REAL EPS, THRESH + INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA, + $ IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), + $ XX( NMAX*INCMAX ), Y( NMAX ), + $ YS( NMAX*INCMAX ), YT( NMAX ), + $ YY( NMAX*INCMAX ), Z( NMAX, 2 ) + REAL G( NMAX ) + INTEGER IDIM( NIDIM ), INC( NINC ) +* .. Local Scalars .. + COMPLEX ALPHA, ALS, TRANSL + REAL ERR, ERRMAX + INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX, + $ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N, + $ NARGS, NC, NS + LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER + CHARACTER*1 UPLO, UPLOS + CHARACTER*14 CUPLO + CHARACTER*2 ICH +* .. Local Arrays .. + COMPLEX W( 2 ) + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LCE, LCERES + EXTERNAL LCE, LCERES +* .. External Subroutines .. + EXTERNAL CCHER2, CCHPR2, CMAKE, CMVCH +* .. Intrinsic Functions .. + INTRINSIC ABS, CONJG, MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICH/'UL'/ +* .. Executable Statements .. + FULL = SNAME( 9: 9 ).EQ.'e' + PACKED = SNAME( 9: 9 ).EQ.'p' +* Define the number of arguments. + IF( FULL )THEN + NARGS = 9 + ELSE IF( PACKED )THEN + NARGS = 8 + END IF +* + NC = 0 + RESET = .TRUE. + ERRMAX = RZERO +* + DO 140 IN = 1, NIDIM + N = IDIM( IN ) +* Set LDA to 1 more than minimum value if room. + LDA = N + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 140 + IF( PACKED )THEN + LAA = ( N*( N + 1 ) )/2 + ELSE + LAA = LDA*N + END IF +* + DO 130 IC = 1, 2 + UPLO = ICH( IC: IC ) + IF (UPLO.EQ.'U')THEN + CUPLO = ' CblasUpper' + ELSE + CUPLO = ' CblasLower' + END IF + UPPER = UPLO.EQ.'U' +* + DO 120 IX = 1, NINC + INCX = INC( IX ) + LX = ABS( INCX )*N +* +* Generate the vector X. +* + TRANSL = HALF + CALL CMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), + $ 0, N - 1, RESET, TRANSL ) + IF( N.GT.1 )THEN + X( N/2 ) = ZERO + XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO + END IF +* + DO 110 IY = 1, NINC + INCY = INC( IY ) + LY = ABS( INCY )*N +* +* Generate the vector Y. +* + TRANSL = ZERO + CALL CMAKE( 'ge', ' ', ' ', 1, N, Y, 1, YY, + $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) + IF( N.GT.1 )THEN + Y( N/2 ) = ZERO + YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO + END IF +* + DO 100 IA = 1, NALF + ALPHA = ALF( IA ) + NULL = N.LE.0.OR.ALPHA.EQ.ZERO +* +* Generate the matrix A. +* + TRANSL = ZERO + CALL CMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, A, + $ NMAX, AA, LDA, N - 1, N - 1, RESET, + $ TRANSL ) +* + NC = NC + 1 +* +* Save every datum before calling the subroutine. +* + UPLOS = UPLO + NS = N + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LX + XS( I ) = XX( I ) + 20 CONTINUE + INCXS = INCX + DO 30 I = 1, LY + YS( I ) = YY( I ) + 30 CONTINUE + INCYS = INCY +* +* Call the subroutine. +* + IF( FULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, CUPLO, N, + $ ALPHA, INCX, INCY, LDA + IF( REWI ) + $ REWIND NTRA + CALL CCHER2( IORDER, UPLO, N, ALPHA, XX, INCX, + $ YY, INCY, AA, LDA ) + ELSE IF( PACKED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9994 )NC, SNAME, CUPLO, N, + $ ALPHA, INCX, INCY + IF( REWI ) + $ REWIND NTRA + CALL CCHPR2( IORDER, UPLO, N, ALPHA, XX, INCX, + $ YY, INCY, AA ) + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9992 ) + FATAL = .TRUE. + GO TO 160 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = UPLO.EQ.UPLOS + ISAME( 2 ) = NS.EQ.N + ISAME( 3 ) = ALS.EQ.ALPHA + ISAME( 4 ) = LCE( XS, XX, LX ) + ISAME( 5 ) = INCXS.EQ.INCX + ISAME( 6 ) = LCE( YS, YY, LY ) + ISAME( 7 ) = INCYS.EQ.INCY + IF( NULL )THEN + ISAME( 8 ) = LCE( AS, AA, LAA ) + ELSE + ISAME( 8 ) = LCERES( SNAME( 8: 9 ), UPLO, N, N, + $ AS, AA, LDA ) + END IF + IF( .NOT.PACKED )THEN + ISAME( 9 ) = LDAS.EQ.LDA + END IF +* +* If data was incorrectly changed, report and return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 160 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result column by column. +* + IF( INCX.GT.0 )THEN + DO 50 I = 1, N + Z( I, 1 ) = X( I ) + 50 CONTINUE + ELSE + DO 60 I = 1, N + Z( I, 1 ) = X( N - I + 1 ) + 60 CONTINUE + END IF + IF( INCY.GT.0 )THEN + DO 70 I = 1, N + Z( I, 2 ) = Y( I ) + 70 CONTINUE + ELSE + DO 80 I = 1, N + Z( I, 2 ) = Y( N - I + 1 ) + 80 CONTINUE + END IF + JA = 1 + DO 90 J = 1, N + W( 1 ) = ALPHA*CONJG( Z( J, 2 ) ) + W( 2 ) = CONJG( ALPHA )*CONJG( Z( J, 1 ) ) + IF( UPPER )THEN + JJ = 1 + LJ = J + ELSE + JJ = J + LJ = N - J + 1 + END IF + CALL CMVCH( 'N', LJ, 2, ONE, Z( JJ, 1 ), + $ NMAX, W, 1, ONE, A( JJ, J ), 1, + $ YT, G, AA( JA ), EPS, ERR, FATAL, + $ NOUT, .TRUE. ) + IF( FULL )THEN + IF( UPPER )THEN + JA = JA + LDA + ELSE + JA = JA + LDA + 1 + END IF + ELSE + JA = JA + LJ + END IF + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and return. + IF( FATAL ) + $ GO TO 150 + 90 CONTINUE + ELSE +* Avoid repeating tests with N.le.0. + IF( N.LE.0 ) + $ GO TO 140 + END IF +* + 100 CONTINUE +* + 110 CONTINUE +* + 120 CONTINUE +* + 130 CONTINUE +* + 140 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + WRITE( NOUT, FMT = 9999 )SNAME, NC + ELSE + WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX + END IF + GO TO 170 +* + 150 CONTINUE + WRITE( NOUT, FMT = 9995 )J +* + 160 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + IF( FULL )THEN + WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, N, ALPHA, INCX, + $ INCY, LDA + ELSE IF( PACKED )THEN + WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, N, ALPHA, INCX, INCY + END IF +* + 170 CONTINUE + RETURN +* + 9999 FORMAT(' ',A12, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + $ 'S)' ) + 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9997 FORMAT(' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, + $ ' - SUSPECT *******' ) + 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) + 9994 FORMAT(1X, I6, ': ',A12, '(', A14, ',', I3, ',(', F4.1, ',', + $ F4.1, '), X,', I2, ', Y,', I2, ', AP) .' ) + 9993 FORMAT(1X, I6, ': ',A12, '(', A14, ',', I3, ',(', F4.1, ',', + $ F4.1, '), X,', I2, ', Y,', I2, ', A,', I3, ') .' ) + 9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of CCHK6. +* + END + SUBROUTINE CMVCH( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y, + $ INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV ) +* +* Checks the results of the computational tests. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + COMPLEX ZERO + PARAMETER ( ZERO = ( 0.0, 0.0 ) ) + REAL RZERO, RONE + PARAMETER ( RZERO = 0.0, RONE = 1.0 ) +* .. Scalar Arguments .. + COMPLEX ALPHA, BETA + REAL EPS, ERR + INTEGER INCX, INCY, M, N, NMAX, NOUT + LOGICAL FATAL, MV + CHARACTER*1 TRANS +* .. Array Arguments .. + COMPLEX A( NMAX, * ), X( * ), Y( * ), YT( * ), YY( * ) + REAL G( * ) +* .. Local Scalars .. + COMPLEX C + REAL ERRI + INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL + LOGICAL CTRAN, TRAN +* .. Intrinsic Functions .. + INTRINSIC ABS, AIMAG, CONJG, MAX, REAL, SQRT +* .. Statement Functions .. + REAL ABS1 +* .. Statement Function definitions .. + ABS1( C ) = ABS( REAL( C ) ) + ABS( AIMAG( C ) ) +* .. Executable Statements .. + TRAN = TRANS.EQ.'T' + CTRAN = TRANS.EQ.'C' + IF( TRAN.OR.CTRAN )THEN + ML = N + NL = M + ELSE + ML = M + NL = N + END IF + IF( INCX.LT.0 )THEN + KX = NL + INCXL = -1 + ELSE + KX = 1 + INCXL = 1 + END IF + IF( INCY.LT.0 )THEN + KY = ML + INCYL = -1 + ELSE + KY = 1 + INCYL = 1 + END IF +* +* Compute expected result in YT using data in A, X and Y. +* Compute gauges in G. +* + IY = KY + DO 40 I = 1, ML + YT( IY ) = ZERO + G( IY ) = RZERO + JX = KX + IF( TRAN )THEN + DO 10 J = 1, NL + YT( IY ) = YT( IY ) + A( J, I )*X( JX ) + G( IY ) = G( IY ) + ABS1( A( J, I ) )*ABS1( X( JX ) ) + JX = JX + INCXL + 10 CONTINUE + ELSE IF( CTRAN )THEN + DO 20 J = 1, NL + YT( IY ) = YT( IY ) + CONJG( A( J, I ) )*X( JX ) + G( IY ) = G( IY ) + ABS1( A( J, I ) )*ABS1( X( JX ) ) + JX = JX + INCXL + 20 CONTINUE + ELSE + DO 30 J = 1, NL + YT( IY ) = YT( IY ) + A( I, J )*X( JX ) + G( IY ) = G( IY ) + ABS1( A( I, J ) )*ABS1( X( JX ) ) + JX = JX + INCXL + 30 CONTINUE + END IF + YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY ) + G( IY ) = ABS1( ALPHA )*G( IY ) + ABS1( BETA )*ABS1( Y( IY ) ) + IY = IY + INCYL + 40 CONTINUE +* +* Compute the error ratio for this result. +* + ERR = ZERO + DO 50 I = 1, ML + ERRI = ABS( YT( I ) - YY( 1 + ( I - 1 )*ABS( INCY ) ) )/EPS + IF( G( I ).NE.RZERO ) + $ ERRI = ERRI/G( I ) + ERR = MAX( ERR, ERRI ) + IF( ERR*SQRT( EPS ).GE.RONE ) + $ GO TO 60 + 50 CONTINUE +* If the loop completes, all results are at least half accurate. + GO TO 80 +* +* Report fatal error. +* + 60 FATAL = .TRUE. + WRITE( NOUT, FMT = 9999 ) + DO 70 I = 1, ML + IF( MV )THEN + WRITE( NOUT, FMT = 9998 )I, YT( I ), + $ YY( 1 + ( I - 1 )*ABS( INCY ) ) + ELSE + WRITE( NOUT, FMT = 9998 )I, + $ YY( 1 + ( I - 1 )*ABS( INCY ) ), YT( I ) + END IF + 70 CONTINUE +* + 80 CONTINUE + RETURN +* + 9999 FORMAT(' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', + $ 'F ACCURATE *******', /' EXPECTED RE', + $ 'SULT COMPUTED RESULT' ) + 9998 FORMAT( 1X, I7, 2( ' (', G15.6, ',', G15.6, ')' ) ) +* +* End of CMVCH. +* + END + LOGICAL FUNCTION LCE( RI, RJ, LR ) +* +* Tests if two arrays are identical. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Scalar Arguments .. + INTEGER LR +* .. Array Arguments .. + COMPLEX RI( * ), RJ( * ) +* .. Local Scalars .. + INTEGER I +* .. Executable Statements .. + DO 10 I = 1, LR + IF( RI( I ).NE.RJ( I ) ) + $ GO TO 20 + 10 CONTINUE + LCE = .TRUE. + GO TO 30 + 20 CONTINUE + LCE = .FALSE. + 30 RETURN +* +* End of LCE. +* + END + LOGICAL FUNCTION LCERES( TYPE, UPLO, M, N, AA, AS, LDA ) +* +* Tests if selected elements in two arrays are equal. +* +* TYPE is 'ge', 'he' or 'hp'. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Scalar Arguments .. + INTEGER LDA, M, N + CHARACTER*1 UPLO + CHARACTER*2 TYPE +* .. Array Arguments .. + COMPLEX AA( LDA, * ), AS( LDA, * ) +* .. Local Scalars .. + INTEGER I, IBEG, IEND, J + LOGICAL UPPER +* .. Executable Statements .. + UPPER = UPLO.EQ.'U' + IF( TYPE.EQ.'ge' )THEN + DO 20 J = 1, N + DO 10 I = M + 1, LDA + IF( AA( I, J ).NE.AS( I, J ) ) + $ GO TO 70 + 10 CONTINUE + 20 CONTINUE + ELSE IF( TYPE.EQ.'he' )THEN + DO 50 J = 1, N + IF( UPPER )THEN + IBEG = 1 + IEND = J + ELSE + IBEG = J + IEND = N + END IF + DO 30 I = 1, IBEG - 1 + IF( AA( I, J ).NE.AS( I, J ) ) + $ GO TO 70 + 30 CONTINUE + DO 40 I = IEND + 1, LDA + IF( AA( I, J ).NE.AS( I, J ) ) + $ GO TO 70 + 40 CONTINUE + 50 CONTINUE + END IF +* + 60 CONTINUE + LCERES = .TRUE. + GO TO 80 + 70 CONTINUE + LCERES = .FALSE. + 80 RETURN +* +* End of LCERES. +* + END + COMPLEX FUNCTION CBEG( RESET ) +* +* Generates complex numbers as pairs of random numbers uniformly +* distributed between -0.5 and 0.5. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Scalar Arguments .. + LOGICAL RESET +* .. Local Scalars .. + INTEGER I, IC, J, MI, MJ +* .. Save statement .. + SAVE I, IC, J, MI, MJ +* .. Intrinsic Functions .. + INTRINSIC CMPLX +* .. Executable Statements .. + IF( RESET )THEN +* Initialize local variables. + MI = 891 + MJ = 457 + I = 7 + J = 7 + IC = 0 + RESET = .FALSE. + END IF +* +* 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 = IC + 1 + 10 I = I*MI + J = J*MJ + I = I - 1000*( I/1000 ) + J = J - 1000*( J/1000 ) + IF( IC.GE.5 )THEN + IC = 0 + GO TO 10 + END IF + CBEG = CMPLX( ( I - 500 )/1001.0, ( J - 500 )/1001.0 ) + RETURN +* +* End of CBEG. +* + END + REAL FUNCTION SDIFF( X, Y ) +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* +* .. Scalar Arguments .. + REAL X, Y +* .. Executable Statements .. + SDIFF = X - Y + RETURN +* +* End of SDIFF. +* + END + SUBROUTINE CMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, + $ KU, RESET, TRANSL ) +* +* Generates values for an M by N matrix A within the bandwidth +* defined by KL and KU. +* Stores the values in the array AA in the data structure required +* by the routine, with unwanted elements set to rogue value. +* +* TYPE is 'ge', 'gb', 'he', 'hb', 'hp', 'tr', 'tb' OR 'tp'. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + COMPLEX ZERO, ONE + PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) + COMPLEX ROGUE + PARAMETER ( ROGUE = ( -1.0E10, 1.0E10 ) ) + REAL RZERO + PARAMETER ( RZERO = 0.0 ) + REAL RROGUE + PARAMETER ( RROGUE = -1.0E10 ) +* .. Scalar Arguments .. + COMPLEX TRANSL + INTEGER KL, KU, LDA, M, N, NMAX + LOGICAL RESET + CHARACTER*1 DIAG, UPLO + CHARACTER*2 TYPE +* .. Array Arguments .. + COMPLEX A( NMAX, * ), AA( * ) +* .. Local Scalars .. + INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, JJ, KK + LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER +* .. External Functions .. + COMPLEX CBEG + EXTERNAL CBEG +* .. Intrinsic Functions .. + INTRINSIC CMPLX, CONJG, MAX, MIN, REAL +* .. Executable Statements .. + GEN = TYPE( 1: 1 ).EQ.'g' + SYM = TYPE( 1: 1 ).EQ.'h' + TRI = TYPE( 1: 1 ).EQ.'t' + UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U' + LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L' + UNIT = TRI.AND.DIAG.EQ.'U' +* +* Generate data in array A. +* + DO 20 J = 1, N + DO 10 I = 1, M + IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) + $ THEN + IF( ( I.LE.J.AND.J - I.LE.KU ).OR. + $ ( I.GE.J.AND.I - J.LE.KL ) )THEN + A( I, J ) = CBEG( RESET ) + TRANSL + ELSE + A( I, J ) = ZERO + END IF + IF( I.NE.J )THEN + IF( SYM )THEN + A( J, I ) = CONJG( A( I, J ) ) + ELSE IF( TRI )THEN + A( J, I ) = ZERO + END IF + END IF + END IF + 10 CONTINUE + IF( SYM ) + $ A( J, J ) = CMPLX( REAL( A( J, J ) ), RZERO ) + IF( TRI ) + $ A( J, J ) = A( J, J ) + ONE + IF( UNIT ) + $ A( J, J ) = ONE + 20 CONTINUE +* +* Store elements in array AS in data structure required by routine. +* + IF( TYPE.EQ.'ge' )THEN + DO 50 J = 1, N + DO 30 I = 1, M + AA( I + ( J - 1 )*LDA ) = A( I, J ) + 30 CONTINUE + DO 40 I = M + 1, LDA + AA( I + ( J - 1 )*LDA ) = ROGUE + 40 CONTINUE + 50 CONTINUE + ELSE IF( TYPE.EQ.'gb' )THEN + DO 90 J = 1, N + DO 60 I1 = 1, KU + 1 - J + AA( I1 + ( J - 1 )*LDA ) = ROGUE + 60 CONTINUE + DO 70 I2 = I1, MIN( KL + KU + 1, KU + 1 + M - J ) + AA( I2 + ( J - 1 )*LDA ) = A( I2 + J - KU - 1, J ) + 70 CONTINUE + DO 80 I3 = I2, LDA + AA( I3 + ( J - 1 )*LDA ) = ROGUE + 80 CONTINUE + 90 CONTINUE + ELSE IF( TYPE.EQ.'he'.OR.TYPE.EQ.'tr' )THEN + DO 130 J = 1, N + IF( UPPER )THEN + IBEG = 1 + IF( UNIT )THEN + IEND = J - 1 + ELSE + IEND = J + END IF + ELSE + IF( UNIT )THEN + IBEG = J + 1 + ELSE + IBEG = J + END IF + IEND = N + END IF + DO 100 I = 1, IBEG - 1 + AA( I + ( J - 1 )*LDA ) = ROGUE + 100 CONTINUE + DO 110 I = IBEG, IEND + AA( I + ( J - 1 )*LDA ) = A( I, J ) + 110 CONTINUE + DO 120 I = IEND + 1, LDA + AA( I + ( J - 1 )*LDA ) = ROGUE + 120 CONTINUE + IF( SYM )THEN + JJ = J + ( J - 1 )*LDA + AA( JJ ) = CMPLX( REAL( AA( JJ ) ), RROGUE ) + END IF + 130 CONTINUE + ELSE IF( TYPE.EQ.'hb'.OR.TYPE.EQ.'tb' )THEN + DO 170 J = 1, N + IF( UPPER )THEN + KK = KL + 1 + IBEG = MAX( 1, KL + 2 - J ) + IF( UNIT )THEN + IEND = KL + ELSE + IEND = KL + 1 + END IF + ELSE + KK = 1 + IF( UNIT )THEN + IBEG = 2 + ELSE + IBEG = 1 + END IF + IEND = MIN( KL + 1, 1 + M - J ) + END IF + DO 140 I = 1, IBEG - 1 + AA( I + ( J - 1 )*LDA ) = ROGUE + 140 CONTINUE + DO 150 I = IBEG, IEND + AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J ) + 150 CONTINUE + DO 160 I = IEND + 1, LDA + AA( I + ( J - 1 )*LDA ) = ROGUE + 160 CONTINUE + IF( SYM )THEN + JJ = KK + ( J - 1 )*LDA + AA( JJ ) = CMPLX( REAL( AA( JJ ) ), RROGUE ) + END IF + 170 CONTINUE + ELSE IF( TYPE.EQ.'hp'.OR.TYPE.EQ.'tp' )THEN + IOFF = 0 + DO 190 J = 1, N + IF( UPPER )THEN + IBEG = 1 + IEND = J + ELSE + IBEG = J + IEND = N + END IF + DO 180 I = IBEG, IEND + IOFF = IOFF + 1 + AA( IOFF ) = A( I, J ) + IF( I.EQ.J )THEN + IF( UNIT ) + $ AA( IOFF ) = ROGUE + IF( SYM ) + $ AA( IOFF ) = CMPLX( REAL( AA( IOFF ) ), RROGUE ) + END IF + 180 CONTINUE + 190 CONTINUE + END IF + RETURN +* +* End of CMAKE. +* + END diff --git a/cblas/testing/c_cblat3.f b/cblas/testing/c_cblat3.f new file mode 100644 index 00000000..b03d4791 --- /dev/null +++ b/cblas/testing/c_cblat3.f @@ -0,0 +1,2786 @@ + PROGRAM CBLAT3 +* +* 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 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 +* 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. +* +* .. Parameters .. + INTEGER NIN, NOUT + PARAMETER ( NIN = 5, NOUT = 6 ) + INTEGER NSUBS + PARAMETER ( NSUBS = 9 ) + COMPLEX ZERO, ONE + PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) + REAL RZERO, RHALF, RONE + PARAMETER ( RZERO = 0.0, RHALF = 0.5, RONE = 1.0 ) + INTEGER NMAX + PARAMETER ( NMAX = 65 ) + INTEGER NIDMAX, NALMAX, NBEMAX + PARAMETER ( NIDMAX = 9, NALMAX = 7, NBEMAX = 7 ) +* .. Local Scalars .. + REAL EPS, ERR, THRESH + INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NTRA, + $ LAYOUT + LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, + $ TSTERR, CORDER, RORDER + CHARACTER*1 TRANSA, TRANSB + CHARACTER*12 SNAMET + CHARACTER*32 SNAPS +* .. Local Arrays .. + COMPLEX AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ), + $ ALF( NALMAX ), AS( NMAX*NMAX ), + $ BB( NMAX*NMAX ), BET( NBEMAX ), + $ BS( NMAX*NMAX ), C( NMAX, NMAX ), + $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), + $ W( 2*NMAX ) + REAL G( NMAX ) + INTEGER IDIM( NIDMAX ) + LOGICAL LTEST( NSUBS ) + CHARACTER*12 SNAMES( NSUBS ) +* .. External Functions .. + REAL SDIFF + LOGICAL LCE + EXTERNAL SDIFF, LCE +* .. External Subroutines .. + EXTERNAL CCHK1, CCHK2, CCHK3, CCHK4, CCHK5, CMMCH +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL LERR, OK + CHARACTER*12 SRNAMT +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK, LERR + COMMON /SRNAMC/SRNAMT +* .. Data statements .. + DATA SNAMES/'cblas_cgemm ', 'cblas_chemm ', + $ 'cblas_csymm ', 'cblas_ctrmm ', 'cblas_ctrsm ', + $ 'cblas_cherk ', 'cblas_csyrk ', 'cblas_cher2k', + $ 'cblas_csyr2k'/ +* .. Executable Statements .. +* + NOUTC = NOUT +* +* Read name and unit number for snapshot output file and open file. +* + READ( NIN, FMT = * )SNAPS + READ( NIN, FMT = * )NTRA + TRACE = NTRA.GE.0 + IF( TRACE )THEN + OPEN( NTRA, FILE = SNAPS ) + END IF +* Read the flag that directs rewinding of the snapshot file. + READ( NIN, FMT = * )REWI + REWI = REWI.AND.TRACE +* Read the flag that directs stopping on any failure. + READ( NIN, FMT = * )SFATAL +* Read the flag that indicates whether error exits are to be tested. + READ( NIN, FMT = * )TSTERR +* Read the flag that indicates whether row-major data layout to be tested. + READ( NIN, FMT = * )LAYOUT +* Read the threshold value of the test ratio + READ( NIN, FMT = * )THRESH +* +* Read and check the parameter values for the tests. +* +* Values of N + READ( NIN, FMT = * )NIDIM + IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN + WRITE( NOUT, FMT = 9997 )'N', NIDMAX + GO TO 220 + END IF + READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) + DO 10 I = 1, NIDIM + IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN + WRITE( NOUT, FMT = 9996 )NMAX + GO TO 220 + END IF + 10 CONTINUE +* Values of ALPHA + READ( NIN, FMT = * )NALF + IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN + WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX + GO TO 220 + END IF + READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) +* Values of BETA + READ( NIN, FMT = * )NBET + IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN + WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX + GO TO 220 + END IF + READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) +* +* Report values of parameters. +* + WRITE( NOUT, FMT = 9995 ) + WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM ) + WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF ) + WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET ) + IF( .NOT.TSTERR )THEN + WRITE( NOUT, FMT = * ) + WRITE( NOUT, FMT = 9984 ) + END IF + WRITE( NOUT, FMT = * ) + WRITE( NOUT, FMT = 9999 )THRESH + WRITE( NOUT, FMT = * ) + + RORDER = .FALSE. + CORDER = .FALSE. + IF (LAYOUT.EQ.2) THEN + RORDER = .TRUE. + CORDER = .TRUE. + WRITE( *, FMT = 10002 ) + ELSE IF (LAYOUT.EQ.1) THEN + RORDER = .TRUE. + WRITE( *, FMT = 10001 ) + ELSE IF (LAYOUT.EQ.0) THEN + CORDER = .TRUE. + WRITE( *, FMT = 10000 ) + END IF + WRITE( *, FMT = * ) + +* +* Read names of subroutines and flags which indicate +* whether they are to be tested. +* + DO 20 I = 1, NSUBS + LTEST( I ) = .FALSE. + 20 CONTINUE + 30 READ( NIN, FMT = 9988, END = 60 )SNAMET, LTESTT + DO 40 I = 1, NSUBS + IF( SNAMET.EQ.SNAMES( I ) ) + $ GO TO 50 + 40 CONTINUE + WRITE( NOUT, FMT = 9990 )SNAMET + STOP + 50 LTEST( I ) = LTESTT + GO TO 30 +* + 60 CONTINUE + CLOSE ( NIN ) +* +* Compute EPS (the machine precision). +* + EPS = RONE + 70 CONTINUE + IF( SDIFF( RONE + EPS, RONE ).EQ.RZERO ) + $ GO TO 80 + EPS = RHALF*EPS + GO TO 70 + 80 CONTINUE + EPS = EPS + EPS + WRITE( NOUT, FMT = 9998 )EPS +* +* Check the reliability of CMMCH using exact data. +* + N = MIN( 32, NMAX ) + DO 100 J = 1, N + DO 90 I = 1, N + AB( I, J ) = MAX( I - J + 1, 0 ) + 90 CONTINUE + AB( J, NMAX + 1 ) = J + AB( 1, NMAX + J ) = J + C( J, 1 ) = ZERO + 100 CONTINUE + DO 110 J = 1, N + CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 + 110 CONTINUE +* CC holds the exact result. On exit from CMMCH CT holds +* the result computed by CMMCH. + TRANSA = 'N' + TRANSB = 'N' + CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, + $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, + $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) + SAME = LCE( CC, CT, N ) + IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN + WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR + STOP + END IF + TRANSB = 'C' + CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, + $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, + $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) + SAME = LCE( CC, CT, N ) + IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN + WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR + STOP + END IF + DO 120 J = 1, N + AB( J, NMAX + 1 ) = N - J + 1 + AB( 1, NMAX + J ) = N - J + 1 + 120 CONTINUE + DO 130 J = 1, N + CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 - + $ ( ( J + 1 )*J*( J - 1 ) )/3 + 130 CONTINUE + TRANSA = 'C' + TRANSB = 'N' + CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, + $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, + $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) + SAME = LCE( CC, CT, N ) + IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN + WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR + STOP + END IF + TRANSB = 'C' + CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, + $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, + $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) + SAME = LCE( CC, CT, N ) + IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN + WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR + STOP + END IF +* +* Test each subroutine in turn. +* + DO 200 ISNUM = 1, NSUBS + WRITE( NOUT, FMT = * ) + IF( .NOT.LTEST( ISNUM ) )THEN +* Subprogram is not to be tested. + WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM ) + ELSE + SRNAMT = SNAMES( ISNUM ) +* Test error exits. + IF( TSTERR )THEN + CALL CC3CHKE( SNAMES( ISNUM ) ) + WRITE( NOUT, FMT = * ) + END IF +* Test computations. + INFOT = 0 + OK = .TRUE. + FATAL = .FALSE. + GO TO ( 140, 150, 150, 160, 160, 170, 170, + $ 180, 180 )ISNUM +* Test CGEMM, 01. + 140 IF (CORDER) THEN + CALL CCHK1(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, + $ CC, CS, CT, G, 0 ) + END IF + IF (RORDER) THEN + CALL CCHK1(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, + $ CC, CS, CT, G, 1 ) + END IF + GO TO 190 +* Test CHEMM, 02, CSYMM, 03. + 150 IF (CORDER) THEN + CALL CCHK2(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, + $ CC, CS, CT, G, 0 ) + END IF + IF (RORDER) THEN + CALL CCHK2(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, + $ CC, CS, CT, G, 1 ) + END IF + GO TO 190 +* Test CTRMM, 04, CTRSM, 05. + 160 IF (CORDER) THEN + CALL CCHK3(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB, + $ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C, + $ 0 ) + END IF + IF (RORDER) THEN + CALL CCHK3(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB, + $ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C, + $ 1 ) + END IF + GO TO 190 +* Test CHERK, 06, CSYRK, 07. + 170 IF (CORDER) THEN + CALL CCHK4(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, + $ CC, CS, CT, G, 0 ) + END IF + IF (RORDER) THEN + CALL CCHK4(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, + $ CC, CS, CT, G, 1 ) + END IF + GO TO 190 +* Test CHER2K, 08, CSYR2K, 09. + 180 IF (CORDER) THEN + CALL CCHK5(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W, + $ 0 ) + END IF + IF (RORDER) THEN + CALL CCHK5(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W, + $ 1 ) + END IF + GO TO 190 +* + 190 IF( FATAL.AND.SFATAL ) + $ GO TO 210 + END IF + 200 CONTINUE + WRITE( NOUT, FMT = 9986 ) + GO TO 230 +* + 210 CONTINUE + WRITE( NOUT, FMT = 9985 ) + GO TO 230 +* + 220 CONTINUE + WRITE( NOUT, FMT = 9991 ) +* + 230 CONTINUE + IF( TRACE ) + $ CLOSE ( NTRA ) + CLOSE ( NOUT ) + STOP +* +10002 FORMAT( ' COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED' ) +10001 FORMAT(' ROW-MAJOR DATA LAYOUT IS TESTED' ) +10000 FORMAT(' COLUMN-MAJOR DATA LAYOUT IS TESTED' ) + 9999 FORMAT(' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', + $ 'S THAN', F8.2 ) + 9998 FORMAT(' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 ) + 9997 FORMAT(' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', + $ 'THAN ', I2 ) + 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) + 9995 FORMAT(' TESTS OF THE COMPLEX LEVEL 3 BLAS', //' THE F', + $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) + 9994 FORMAT( ' FOR N ', 9I6 ) + 9993 FORMAT( ' FOR ALPHA ', + $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) + 9992 FORMAT( ' FOR BETA ', + $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) + 9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', + $ /' ******* TESTS ABANDONED *******' ) + 9990 FORMAT(' SUBPROGRAM NAME ', A12,' NOT RECOGNIZED', /' ******* T', + $ 'ESTS ABANDONED *******' ) + 9989 FORMAT(' ERROR IN CMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', + $ 'ATED WRONGLY.', /' CMMCH WAS CALLED WITH TRANSA = ', A1, + $ 'AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ', + $ ' ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ', + $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ', + $ '*******' ) + 9988 FORMAT( A12,L2 ) + 9987 FORMAT( 1X, A12,' WAS NOT TESTED' ) + 9986 FORMAT( /' END OF TESTS' ) + 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) + 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) +* +* End of CBLAT3. +* + END + SUBROUTINE CCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, + $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G, + $ IORDER ) +* +* 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. +* +* .. Parameters .. + COMPLEX ZERO + PARAMETER ( ZERO = ( 0.0, 0.0 ) ) + REAL RZERO + PARAMETER ( RZERO = 0.0 ) +* .. Scalar Arguments .. + REAL EPS, THRESH + INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), B( NMAX, NMAX ), + $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), + $ C( NMAX, NMAX ), CC( NMAX*NMAX ), + $ CS( NMAX*NMAX ), CT( NMAX ) + REAL G( NMAX ) + INTEGER IDIM( NIDIM ) +* .. Local Scalars .. + COMPLEX ALPHA, ALS, BETA, BLS + REAL ERR, ERRMAX + INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA, + $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M, + $ MA, MB, MS, N, NA, NARGS, NB, NC, NS + LOGICAL NULL, RESET, SAME, TRANA, TRANB + CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB + CHARACTER*3 ICH +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LCE, LCERES + EXTERNAL LCE, LCERES +* .. External Subroutines .. + EXTERNAL CCGEMM, CMAKE, CMMCH +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL LERR, OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK, LERR +* .. Data statements .. + DATA ICH/'NTC'/ +* .. Executable Statements .. +* + NARGS = 13 + NC = 0 + RESET = .TRUE. + ERRMAX = RZERO +* + DO 110 IM = 1, NIDIM + M = IDIM( IM ) +* + DO 100 IN = 1, NIDIM + N = IDIM( IN ) +* Set LDC to 1 more than minimum value if room. + LDC = M + IF( LDC.LT.NMAX ) + $ LDC = LDC + 1 +* Skip tests if not enough room. + IF( LDC.GT.NMAX ) + $ GO TO 100 + LCC = LDC*N + NULL = N.LE.0.OR.M.LE.0 +* + DO 90 IK = 1, NIDIM + K = IDIM( IK ) +* + DO 80 ICA = 1, 3 + TRANSA = ICH( ICA: ICA ) + TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' +* + IF( TRANA )THEN + MA = K + NA = M + ELSE + MA = M + NA = K + END IF +* Set LDA to 1 more than minimum value if room. + LDA = MA + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 80 + LAA = LDA*NA +* +* Generate the matrix A. +* + CALL CMAKE( 'ge', ' ', ' ', MA, NA, A, NMAX, AA, LDA, + $ RESET, ZERO ) +* + DO 70 ICB = 1, 3 + TRANSB = ICH( ICB: ICB ) + TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' +* + IF( TRANB )THEN + MB = N + NB = K + ELSE + MB = K + NB = N + END IF +* Set LDB to 1 more than minimum value if room. + LDB = MB + IF( LDB.LT.NMAX ) + $ LDB = LDB + 1 +* Skip tests if not enough room. + IF( LDB.GT.NMAX ) + $ GO TO 70 + LBB = LDB*NB +* +* Generate the matrix B. +* + CALL CMAKE( 'ge', ' ', ' ', MB, NB, B, NMAX, BB, + $ LDB, RESET, ZERO ) +* + DO 60 IA = 1, NALF + ALPHA = ALF( IA ) +* + DO 50 IB = 1, NBET + BETA = BET( IB ) +* +* Generate the matrix C. +* + CALL CMAKE( 'ge', ' ', ' ', M, N, C, NMAX, + $ CC, LDC, RESET, ZERO ) +* + NC = NC + 1 +* +* Save every datum before calling the +* subroutine. +* + TRANAS = TRANSA + TRANBS = TRANSB + MS = M + NS = N + KS = K + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LBB + BS( I ) = BB( I ) + 20 CONTINUE + LDBS = LDB + BLS = BETA + DO 30 I = 1, LCC + CS( I ) = CC( I ) + 30 CONTINUE + LDCS = LDC +* +* Call the subroutine. +* + IF( TRACE ) + $ CALL CPRCN1(NTRA, NC, SNAME, IORDER, + $ TRANSA, TRANSB, M, N, K, ALPHA, LDA, + $ LDB, BETA, LDC) + IF( REWI ) + $ REWIND NTRA + CALL CCGEMM( IORDER, TRANSA, TRANSB, M, N, + $ K, ALPHA, AA, LDA, BB, LDB, + $ BETA, CC, LDC ) +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9994 ) + FATAL = .TRUE. + GO TO 120 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = TRANSA.EQ.TRANAS + ISAME( 2 ) = TRANSB.EQ.TRANBS + ISAME( 3 ) = MS.EQ.M + ISAME( 4 ) = NS.EQ.N + ISAME( 5 ) = KS.EQ.K + ISAME( 6 ) = ALS.EQ.ALPHA + ISAME( 7 ) = LCE( AS, AA, LAA ) + ISAME( 8 ) = LDAS.EQ.LDA + ISAME( 9 ) = LCE( BS, BB, LBB ) + ISAME( 10 ) = LDBS.EQ.LDB + ISAME( 11 ) = BLS.EQ.BETA + IF( NULL )THEN + ISAME( 12 ) = LCE( CS, CC, LCC ) + ELSE + ISAME( 12 ) = LCERES( 'ge', ' ', M, N, CS, + $ CC, LDC ) + END IF + ISAME( 13 ) = LDCS.EQ.LDC +* +* If data was incorrectly changed, report +* and return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 120 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result. +* + CALL CMMCH( TRANSA, TRANSB, M, N, K, + $ ALPHA, A, NMAX, B, NMAX, BETA, + $ C, NMAX, CT, G, CC, LDC, EPS, + $ ERR, FATAL, NOUT, .TRUE. ) + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and +* return. + IF( FATAL ) + $ GO TO 120 + END IF +* + 50 CONTINUE +* + 60 CONTINUE +* + 70 CONTINUE +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* + 110 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 130 +* + 120 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + CALL CPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, + $ M, N, K, ALPHA, LDA, LDB, BETA, LDC) +* + 130 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',', + $ 3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, + $ ',(', F4.1, ',', F4.1, '), C,', I3, ').' ) + 9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of CCHK1. +* + END +* + SUBROUTINE CPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, M, N, + $ K, ALPHA, LDA, LDB, BETA, LDC) + INTEGER NOUT, NC, IORDER, M, N, K, LDA, LDB, LDC + COMPLEX ALPHA, BETA + CHARACTER*1 TRANSA, TRANSB + CHARACTER*12 SNAME + CHARACTER*14 CRC, CTA,CTB + + IF (TRANSA.EQ.'N')THEN + CTA = ' CblasNoTrans' + ELSE IF (TRANSA.EQ.'T')THEN + CTA = ' CblasTrans' + ELSE + CTA = 'CblasConjTrans' + END IF + IF (TRANSB.EQ.'N')THEN + CTB = ' CblasNoTrans' + ELSE IF (TRANSB.EQ.'T')THEN + CTB = ' CblasTrans' + ELSE + CTB = 'CblasConjTrans' + END IF + IF (IORDER.EQ.1)THEN + CRC = ' CblasRowMajor' + ELSE + CRC = ' CblasColMajor' + END IF + WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CTA,CTB + WRITE(NOUT, FMT = 9994)M, N, K, ALPHA, LDA, LDB, BETA, LDC + + 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',') + 9994 FORMAT( 10X, 3( I3, ',' ) ,' (', F4.1,',',F4.1,') , A,', + $ I3, ', B,', I3, ', (', F4.1,',',F4.1,') , C,', I3, ').' ) + END +* + SUBROUTINE CCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, + $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G, + $ IORDER ) +* +* 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. +* +* .. Parameters .. + COMPLEX ZERO + PARAMETER ( ZERO = ( 0.0, 0.0 ) ) + REAL RZERO + PARAMETER ( RZERO = 0.0 ) +* .. Scalar Arguments .. + REAL EPS, THRESH + INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), B( NMAX, NMAX ), + $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), + $ C( NMAX, NMAX ), CC( NMAX*NMAX ), + $ CS( NMAX*NMAX ), CT( NMAX ) + REAL G( NMAX ) + INTEGER IDIM( NIDIM ) +* .. Local Scalars .. + COMPLEX ALPHA, ALS, BETA, BLS + REAL ERR, ERRMAX + INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC, + $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA, + $ NARGS, NC, NS + LOGICAL CONJ, LEFT, NULL, RESET, SAME + CHARACTER*1 SIDE, SIDES, UPLO, UPLOS + CHARACTER*2 ICHS, ICHU +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LCE, LCERES + EXTERNAL LCE, LCERES +* .. External Subroutines .. + EXTERNAL CCHEMM, CMAKE, CMMCH, CCSYMM +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL LERR, OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK, LERR +* .. Data statements .. + DATA ICHS/'LR'/, ICHU/'UL'/ +* .. Executable Statements .. + CONJ = SNAME( 8: 9 ).EQ.'he' +* + NARGS = 12 + NC = 0 + RESET = .TRUE. + ERRMAX = RZERO +* + DO 100 IM = 1, NIDIM + M = IDIM( IM ) +* + DO 90 IN = 1, NIDIM + N = IDIM( IN ) +* Set LDC to 1 more than minimum value if room. + LDC = M + IF( LDC.LT.NMAX ) + $ LDC = LDC + 1 +* Skip tests if not enough room. + IF( LDC.GT.NMAX ) + $ GO TO 90 + LCC = LDC*N + NULL = N.LE.0.OR.M.LE.0 +* Set LDB to 1 more than minimum value if room. + LDB = M + IF( LDB.LT.NMAX ) + $ LDB = LDB + 1 +* Skip tests if not enough room. + IF( LDB.GT.NMAX ) + $ GO TO 90 + LBB = LDB*N +* +* Generate the matrix B. +* + CALL CMAKE( 'ge', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET, + $ ZERO ) +* + DO 80 ICS = 1, 2 + SIDE = ICHS( ICS: ICS ) + LEFT = SIDE.EQ.'L' +* + IF( LEFT )THEN + NA = M + ELSE + NA = N + END IF +* Set LDA to 1 more than minimum value if room. + LDA = NA + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 80 + LAA = LDA*NA +* + DO 70 ICU = 1, 2 + UPLO = ICHU( ICU: ICU ) +* +* Generate the hermitian or symmetric matrix A. +* + CALL CMAKE(SNAME( 8: 9 ), UPLO, ' ', NA, NA, A, NMAX, + $ AA, LDA, RESET, ZERO ) +* + DO 60 IA = 1, NALF + ALPHA = ALF( IA ) +* + DO 50 IB = 1, NBET + BETA = BET( IB ) +* +* Generate the matrix C. +* + CALL CMAKE( 'ge', ' ', ' ', M, N, C, NMAX, CC, + $ LDC, RESET, ZERO ) +* + NC = NC + 1 +* +* Save every datum before calling the +* subroutine. +* + SIDES = SIDE + UPLOS = UPLO + MS = M + NS = N + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LBB + BS( I ) = BB( I ) + 20 CONTINUE + LDBS = LDB + BLS = BETA + DO 30 I = 1, LCC + CS( I ) = CC( I ) + 30 CONTINUE + LDCS = LDC +* +* Call the subroutine. +* + IF( TRACE ) + $ CALL CPRCN2(NTRA, NC, SNAME, IORDER, + $ SIDE, UPLO, M, N, ALPHA, LDA, LDB, + $ BETA, LDC) + IF( REWI ) + $ REWIND NTRA + IF( CONJ )THEN + CALL CCHEMM( IORDER, SIDE, UPLO, M, N, + $ ALPHA, AA, LDA, BB, LDB, BETA, + $ CC, LDC ) + ELSE + CALL CCSYMM( IORDER, SIDE, UPLO, M, N, + $ ALPHA, AA, LDA, BB, LDB, BETA, + $ CC, LDC ) + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9994 ) + FATAL = .TRUE. + GO TO 110 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = SIDES.EQ.SIDE + ISAME( 2 ) = UPLOS.EQ.UPLO + ISAME( 3 ) = MS.EQ.M + ISAME( 4 ) = NS.EQ.N + ISAME( 5 ) = ALS.EQ.ALPHA + ISAME( 6 ) = LCE( AS, AA, LAA ) + ISAME( 7 ) = LDAS.EQ.LDA + ISAME( 8 ) = LCE( BS, BB, LBB ) + ISAME( 9 ) = LDBS.EQ.LDB + ISAME( 10 ) = BLS.EQ.BETA + IF( NULL )THEN + ISAME( 11 ) = LCE( CS, CC, LCC ) + ELSE + ISAME( 11 ) = LCERES( 'ge', ' ', M, N, CS, + $ CC, LDC ) + END IF + ISAME( 12 ) = LDCS.EQ.LDC +* +* If data was incorrectly changed, report and +* return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 110 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result. +* + IF( LEFT )THEN + CALL CMMCH( 'N', 'N', M, N, M, ALPHA, A, + $ NMAX, B, NMAX, BETA, C, NMAX, + $ CT, G, CC, LDC, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + ELSE + CALL CMMCH( 'N', 'N', M, N, N, ALPHA, B, + $ NMAX, A, NMAX, BETA, C, NMAX, + $ CT, G, CC, LDC, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + END IF + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and +* return. + IF( FATAL ) + $ GO TO 110 + END IF +* + 50 CONTINUE +* + 60 CONTINUE +* + 70 CONTINUE +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 120 +* + 110 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + CALL CPRCN2(NOUT, NC, SNAME, IORDER, SIDE, UPLO, M, N, ALPHA, LDA, + $ LDB, BETA, LDC) +* + 120 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' ) + 9995 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), + $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1, + $ ',', F4.1, '), C,', I3, ') .' ) + 9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of CCHK2. +* + END +* + SUBROUTINE CPRCN2(NOUT, NC, SNAME, IORDER, SIDE, UPLO, M, N, + $ ALPHA, LDA, LDB, BETA, LDC) + INTEGER NOUT, NC, IORDER, M, N, LDA, LDB, LDC + COMPLEX ALPHA, BETA + CHARACTER*1 SIDE, UPLO + CHARACTER*12 SNAME + CHARACTER*14 CRC, CS,CU + + IF (SIDE.EQ.'L')THEN + CS = ' CblasLeft' + ELSE + CS = ' CblasRight' + END IF + IF (UPLO.EQ.'U')THEN + CU = ' CblasUpper' + ELSE + CU = ' CblasLower' + END IF + IF (IORDER.EQ.1)THEN + CRC = ' CblasRowMajor' + ELSE + CRC = ' CblasColMajor' + END IF + WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CS,CU + WRITE(NOUT, FMT = 9994)M, N, ALPHA, LDA, LDB, BETA, LDC + + 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',') + 9994 FORMAT( 10X, 2( I3, ',' ),' (',F4.1,',',F4.1, '), A,', I3, + $ ', B,', I3, ', (',F4.1,',',F4.1, '), ', 'C,', I3, ').' ) + END +* + SUBROUTINE CCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NMAX, A, AA, AS, + $ B, BB, BS, CT, G, C, IORDER ) +* +* 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. +* +* .. Parameters .. + COMPLEX ZERO, ONE + PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) + REAL RZERO + PARAMETER ( RZERO = 0.0 ) +* .. Scalar Arguments .. + REAL EPS, THRESH + INTEGER NALF, NIDIM, NMAX, NOUT, NTRA, IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), B( NMAX, NMAX ), + $ BB( NMAX*NMAX ), BS( NMAX*NMAX ), + $ C( NMAX, NMAX ), CT( NMAX ) + REAL G( NMAX ) + INTEGER IDIM( NIDIM ) +* .. Local Scalars .. + COMPLEX ALPHA, ALS + REAL ERR, ERRMAX + INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB, + $ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC, + $ NS + LOGICAL LEFT, NULL, RESET, SAME + CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO, + $ UPLOS + CHARACTER*2 ICHD, ICHS, ICHU + CHARACTER*3 ICHT +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LCE, LCERES + EXTERNAL LCE, LCERES +* .. External Subroutines .. + EXTERNAL CMAKE, CMMCH, CCTRMM, CCTRSM +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL LERR, OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK, LERR +* .. Data statements .. + DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/, ICHS/'LR'/ +* .. Executable Statements .. +* + NARGS = 11 + NC = 0 + RESET = .TRUE. + ERRMAX = RZERO +* Set up zero matrix for CMMCH. + DO 20 J = 1, NMAX + DO 10 I = 1, NMAX + C( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE +* + DO 140 IM = 1, NIDIM + M = IDIM( IM ) +* + DO 130 IN = 1, NIDIM + N = IDIM( IN ) +* Set LDB to 1 more than minimum value if room. + LDB = M + IF( LDB.LT.NMAX ) + $ LDB = LDB + 1 +* Skip tests if not enough room. + IF( LDB.GT.NMAX ) + $ GO TO 130 + LBB = LDB*N + NULL = M.LE.0.OR.N.LE.0 +* + DO 120 ICS = 1, 2 + SIDE = ICHS( ICS: ICS ) + LEFT = SIDE.EQ.'L' + IF( LEFT )THEN + NA = M + ELSE + NA = N + END IF +* Set LDA to 1 more than minimum value if room. + LDA = NA + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 130 + LAA = LDA*NA +* + DO 110 ICU = 1, 2 + UPLO = ICHU( ICU: ICU ) +* + DO 100 ICT = 1, 3 + TRANSA = ICHT( ICT: ICT ) +* + DO 90 ICD = 1, 2 + DIAG = ICHD( ICD: ICD ) +* + DO 80 IA = 1, NALF + ALPHA = ALF( IA ) +* +* Generate the matrix A. +* + CALL CMAKE( 'tr', UPLO, DIAG, NA, NA, A, + $ NMAX, AA, LDA, RESET, ZERO ) +* +* Generate the matrix B. +* + CALL CMAKE( 'ge', ' ', ' ', M, N, B, NMAX, + $ BB, LDB, RESET, ZERO ) +* + NC = NC + 1 +* +* Save every datum before calling the +* subroutine. +* + SIDES = SIDE + UPLOS = UPLO + TRANAS = TRANSA + DIAGS = DIAG + MS = M + NS = N + ALS = ALPHA + DO 30 I = 1, LAA + AS( I ) = AA( I ) + 30 CONTINUE + LDAS = LDA + DO 40 I = 1, LBB + BS( I ) = BB( I ) + 40 CONTINUE + LDBS = LDB +* +* Call the subroutine. +* + IF( SNAME( 10: 11 ).EQ.'mm' )THEN + IF( TRACE ) + $ CALL CPRCN3( NTRA, NC, SNAME, IORDER, + $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, + $ LDA, LDB) + IF( REWI ) + $ REWIND NTRA + CALL CCTRMM(IORDER, SIDE, UPLO, TRANSA, + $ DIAG, M, N, ALPHA, AA, LDA, + $ BB, LDB ) + ELSE IF( SNAME( 10: 11 ).EQ.'sm' )THEN + IF( TRACE ) + $ CALL CPRCN3( NTRA, NC, SNAME, IORDER, + $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, + $ LDA, LDB) + IF( REWI ) + $ REWIND NTRA + CALL CCTRSM(IORDER, SIDE, UPLO, TRANSA, + $ DIAG, M, N, ALPHA, AA, LDA, + $ BB, LDB ) + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9994 ) + FATAL = .TRUE. + GO TO 150 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = SIDES.EQ.SIDE + ISAME( 2 ) = UPLOS.EQ.UPLO + ISAME( 3 ) = TRANAS.EQ.TRANSA + ISAME( 4 ) = DIAGS.EQ.DIAG + ISAME( 5 ) = MS.EQ.M + ISAME( 6 ) = NS.EQ.N + ISAME( 7 ) = ALS.EQ.ALPHA + ISAME( 8 ) = LCE( AS, AA, LAA ) + ISAME( 9 ) = LDAS.EQ.LDA + IF( NULL )THEN + ISAME( 10 ) = LCE( BS, BB, LBB ) + ELSE + ISAME( 10 ) = LCERES( 'ge', ' ', M, N, BS, + $ BB, LDB ) + END IF + ISAME( 11 ) = LDBS.EQ.LDB +* +* If data was incorrectly changed, report and +* return. +* + SAME = .TRUE. + DO 50 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 50 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 150 + END IF +* + IF( .NOT.NULL )THEN + IF( SNAME( 10: 11 ).EQ.'mm' )THEN +* +* Check the result. +* + IF( LEFT )THEN + CALL CMMCH( TRANSA, 'N', M, N, M, + $ ALPHA, A, NMAX, B, NMAX, + $ ZERO, C, NMAX, CT, G, + $ BB, LDB, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + ELSE + CALL CMMCH( 'N', TRANSA, M, N, N, + $ ALPHA, B, NMAX, A, NMAX, + $ ZERO, C, NMAX, CT, G, + $ BB, LDB, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + END IF + ELSE IF( SNAME( 10: 11 ).EQ.'sm' )THEN +* +* Compute approximation to original +* matrix. +* + DO 70 J = 1, N + DO 60 I = 1, M + C( I, J ) = BB( I + ( J - 1 )* + $ LDB ) + BB( I + ( J - 1 )*LDB ) = ALPHA* + $ B( I, J ) + 60 CONTINUE + 70 CONTINUE +* + IF( LEFT )THEN + CALL CMMCH( TRANSA, 'N', M, N, M, + $ ONE, A, NMAX, C, NMAX, + $ ZERO, B, NMAX, CT, G, + $ BB, LDB, EPS, ERR, + $ FATAL, NOUT, .FALSE. ) + ELSE + CALL CMMCH( 'N', TRANSA, M, N, N, + $ ONE, C, NMAX, A, NMAX, + $ ZERO, B, NMAX, CT, G, + $ BB, LDB, EPS, ERR, + $ FATAL, NOUT, .FALSE. ) + END IF + END IF + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and +* return. + IF( FATAL ) + $ GO TO 150 + END IF +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* + 110 CONTINUE +* + 120 CONTINUE +* + 130 CONTINUE +* + 140 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 160 +* + 150 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + CALL CPRCN3( NTRA, NC, SNAME, IORDER, SIDE, UPLO, TRANSA, DIAG, + $ M, N, ALPHA, LDA, LDB) +* + 160 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9996 FORMAT(' ******* ', A12,' FAILED ON CALL NUMBER:' ) + 9995 FORMAT(1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( I3, ',' ), + $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ') ', + $ ' .' ) + 9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of CCHK3. +* + END +* + SUBROUTINE CPRCN3(NOUT, NC, SNAME, IORDER, SIDE, UPLO, TRANSA, + $ DIAG, M, N, ALPHA, LDA, LDB) + INTEGER NOUT, NC, IORDER, M, N, LDA, LDB + COMPLEX ALPHA + CHARACTER*1 SIDE, UPLO, TRANSA, DIAG + CHARACTER*12 SNAME + CHARACTER*14 CRC, CS, CU, CA, CD + + IF (SIDE.EQ.'L')THEN + CS = ' CblasLeft' + ELSE + CS = ' CblasRight' + END IF + IF (UPLO.EQ.'U')THEN + CU = ' CblasUpper' + ELSE + CU = ' CblasLower' + END IF + IF (TRANSA.EQ.'N')THEN + CA = ' CblasNoTrans' + ELSE IF (TRANSA.EQ.'T')THEN + CA = ' CblasTrans' + ELSE + CA = 'CblasConjTrans' + END IF + IF (DIAG.EQ.'N')THEN + CD = ' CblasNonUnit' + ELSE + CD = ' CblasUnit' + END IF + IF (IORDER.EQ.1)THEN + CRC = ' CblasRowMajor' + ELSE + CRC = ' CblasColMajor' + END IF + WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CS,CU + WRITE(NOUT, FMT = 9994)CA, CD, M, N, ALPHA, LDA, LDB + + 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',') + 9994 FORMAT( 10X, 2( A14, ',') , 2( I3, ',' ), ' (', F4.1, ',', + $ F4.1, '), A,', I3, ', B,', I3, ').' ) + END +* + SUBROUTINE CCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, + $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G, + $ IORDER ) +* +* 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. +* +* .. Parameters .. + COMPLEX ZERO + PARAMETER ( ZERO = ( 0.0, 0.0 ) ) + REAL RONE, RZERO + PARAMETER ( RONE = 1.0, RZERO = 0.0 ) +* .. Scalar Arguments .. + REAL EPS, THRESH + INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), B( NMAX, NMAX ), + $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), + $ C( NMAX, NMAX ), CC( NMAX*NMAX ), + $ CS( NMAX*NMAX ), CT( NMAX ) + REAL G( NMAX ) + INTEGER IDIM( NIDIM ) +* .. Local Scalars .. + COMPLEX ALPHA, ALS, BETA, BETS + REAL ERR, ERRMAX, RALPHA, RALS, RBETA, RBETS + INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS, + $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA, + $ NARGS, NC, NS + LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER + CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS + CHARACTER*2 ICHT, ICHU +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LCE, LCERES + EXTERNAL LCE, LCERES +* .. External Subroutines .. + EXTERNAL CCHERK, CMAKE, CMMCH, CCSYRK +* .. Intrinsic Functions .. + INTRINSIC CMPLX, MAX, REAL +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL LERR, OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK, LERR +* .. Data statements .. + DATA ICHT/'NC'/, ICHU/'UL'/ +* .. Executable Statements .. + CONJ = SNAME( 8: 9 ).EQ.'he' +* + NARGS = 10 + NC = 0 + RESET = .TRUE. + ERRMAX = RZERO +* + DO 100 IN = 1, NIDIM + N = IDIM( IN ) +* Set LDC to 1 more than minimum value if room. + LDC = N + IF( LDC.LT.NMAX ) + $ LDC = LDC + 1 +* Skip tests if not enough room. + IF( LDC.GT.NMAX ) + $ GO TO 100 + LCC = LDC*N +* + DO 90 IK = 1, NIDIM + K = IDIM( IK ) +* + DO 80 ICT = 1, 2 + TRANS = ICHT( ICT: ICT ) + TRAN = TRANS.EQ.'C' + IF( TRAN.AND..NOT.CONJ ) + $ TRANS = 'T' + IF( TRAN )THEN + MA = K + NA = N + ELSE + MA = N + NA = K + END IF +* Set LDA to 1 more than minimum value if room. + LDA = MA + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 80 + LAA = LDA*NA +* +* Generate the matrix A. +* + CALL CMAKE( 'ge', ' ', ' ', MA, NA, A, NMAX, AA, LDA, + $ RESET, ZERO ) +* + DO 70 ICU = 1, 2 + UPLO = ICHU( ICU: ICU ) + UPPER = UPLO.EQ.'U' +* + DO 60 IA = 1, NALF + ALPHA = ALF( IA ) + IF( CONJ )THEN + RALPHA = REAL( ALPHA ) + ALPHA = CMPLX( RALPHA, RZERO ) + END IF +* + DO 50 IB = 1, NBET + BETA = BET( IB ) + IF( CONJ )THEN + RBETA = REAL( BETA ) + BETA = CMPLX( RBETA, RZERO ) + END IF + NULL = N.LE.0 + IF( CONJ ) + $ NULL = NULL.OR.( ( K.LE.0.OR.RALPHA.EQ. + $ RZERO ).AND.RBETA.EQ.RONE ) +* +* Generate the matrix C. +* + CALL CMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, C, + $ NMAX, CC, LDC, RESET, ZERO ) +* + NC = NC + 1 +* +* Save every datum before calling the subroutine. +* + UPLOS = UPLO + TRANSS = TRANS + NS = N + KS = K + IF( CONJ )THEN + RALS = RALPHA + ELSE + ALS = ALPHA + END IF + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + IF( CONJ )THEN + RBETS = RBETA + ELSE + BETS = BETA + END IF + DO 20 I = 1, LCC + CS( I ) = CC( I ) + 20 CONTINUE + LDCS = LDC +* +* Call the subroutine. +* + IF( CONJ )THEN + IF( TRACE ) + $ CALL CPRCN6( NTRA, NC, SNAME, IORDER, + $ UPLO, TRANS, N, K, RALPHA, LDA, RBETA, + $ LDC) + IF( REWI ) + $ REWIND NTRA + CALL CCHERK( IORDER, UPLO, TRANS, N, K, + $ RALPHA, AA, LDA, RBETA, CC, + $ LDC ) + ELSE + IF( TRACE ) + $ CALL CPRCN4( NTRA, NC, SNAME, IORDER, + $ UPLO, TRANS, N, K, ALPHA, LDA, BETA, LDC) + IF( REWI ) + $ REWIND NTRA + CALL CCSYRK( IORDER, UPLO, TRANS, N, K, + $ ALPHA, AA, LDA, BETA, CC, LDC ) + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9992 ) + FATAL = .TRUE. + GO TO 120 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = UPLOS.EQ.UPLO + ISAME( 2 ) = TRANSS.EQ.TRANS + ISAME( 3 ) = NS.EQ.N + ISAME( 4 ) = KS.EQ.K + IF( CONJ )THEN + ISAME( 5 ) = RALS.EQ.RALPHA + ELSE + ISAME( 5 ) = ALS.EQ.ALPHA + END IF + ISAME( 6 ) = LCE( AS, AA, LAA ) + ISAME( 7 ) = LDAS.EQ.LDA + IF( CONJ )THEN + ISAME( 8 ) = RBETS.EQ.RBETA + ELSE + ISAME( 8 ) = BETS.EQ.BETA + END IF + IF( NULL )THEN + ISAME( 9 ) = LCE( CS, CC, LCC ) + ELSE + ISAME( 9 ) = LCERES( SNAME( 8: 9 ), UPLO, N, + $ N, CS, CC, LDC ) + END IF + ISAME( 10 ) = LDCS.EQ.LDC +* +* If data was incorrectly changed, report and +* return. +* + SAME = .TRUE. + DO 30 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 30 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 120 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result column by column. +* + IF( CONJ )THEN + TRANST = 'C' + ELSE + TRANST = 'T' + END IF + JC = 1 + DO 40 J = 1, N + IF( UPPER )THEN + JJ = 1 + LJ = J + ELSE + JJ = J + LJ = N - J + 1 + END IF + IF( TRAN )THEN + CALL CMMCH( TRANST, 'N', LJ, 1, K, + $ ALPHA, A( 1, JJ ), NMAX, + $ A( 1, J ), NMAX, BETA, + $ C( JJ, J ), NMAX, CT, G, + $ CC( JC ), LDC, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + ELSE + CALL CMMCH( 'N', TRANST, LJ, 1, K, + $ ALPHA, A( JJ, 1 ), NMAX, + $ A( J, 1 ), NMAX, BETA, + $ C( JJ, J ), NMAX, CT, G, + $ CC( JC ), LDC, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + END IF + IF( UPPER )THEN + JC = JC + LDC + ELSE + JC = JC + LDC + 1 + END IF + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and +* return. + IF( FATAL ) + $ GO TO 110 + 40 CONTINUE + END IF +* + 50 CONTINUE +* + 60 CONTINUE +* + 70 CONTINUE +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 130 +* + 110 CONTINUE + IF( N.GT.1 ) + $ WRITE( NOUT, FMT = 9995 )J +* + 120 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + IF( CONJ )THEN + CALL CPRCN6( NOUT, NC, SNAME, IORDER, UPLO, TRANS, N, K, RALPHA, + $ LDA, rBETA, LDC) + ELSE + CALL CPRCN4( NOUT, NC, SNAME, IORDER, UPLO, TRANS, N, K, ALPHA, + $ LDA, BETA, LDC) + END IF +* + 130 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) + 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, ') .' ) + 9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of CCHK4. +* + END +* + SUBROUTINE CPRCN4(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, + $ N, K, ALPHA, LDA, BETA, LDC) + INTEGER NOUT, NC, IORDER, N, K, LDA, LDC + COMPLEX ALPHA, BETA + CHARACTER*1 UPLO, TRANSA + CHARACTER*12 SNAME + CHARACTER*14 CRC, CU, CA + + IF (UPLO.EQ.'U')THEN + CU = ' CblasUpper' + ELSE + CU = ' CblasLower' + END IF + IF (TRANSA.EQ.'N')THEN + CA = ' CblasNoTrans' + ELSE IF (TRANSA.EQ.'T')THEN + CA = ' CblasTrans' + ELSE + CA = 'CblasConjTrans' + END IF + IF (IORDER.EQ.1)THEN + CRC = ' CblasRowMajor' + ELSE + CRC = ' CblasColMajor' + END IF + WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA + WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, BETA, LDC + + 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') ) + 9994 FORMAT( 10X, 2( I3, ',' ), ' (', F4.1, ',', F4.1 ,'), A,', + $ I3, ', (', F4.1,',', F4.1, '), C,', I3, ').' ) + END +* +* + SUBROUTINE CPRCN6(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, + $ N, K, ALPHA, LDA, BETA, LDC) + INTEGER NOUT, NC, IORDER, N, K, LDA, LDC + REAL ALPHA, BETA + CHARACTER*1 UPLO, TRANSA + CHARACTER*12 SNAME + CHARACTER*14 CRC, CU, CA + + IF (UPLO.EQ.'U')THEN + CU = ' CblasUpper' + ELSE + CU = ' CblasLower' + END IF + IF (TRANSA.EQ.'N')THEN + CA = ' CblasNoTrans' + ELSE IF (TRANSA.EQ.'T')THEN + CA = ' CblasTrans' + ELSE + CA = 'CblasConjTrans' + END IF + IF (IORDER.EQ.1)THEN + CRC = ' CblasRowMajor' + ELSE + CRC = ' CblasColMajor' + END IF + WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA + WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, BETA, LDC + + 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') ) + 9994 FORMAT( 10X, 2( I3, ',' ), + $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ').' ) + END +* + SUBROUTINE CCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, + $ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W, + $ IORDER ) +* +* 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. +* +* .. Parameters .. + COMPLEX ZERO, ONE + PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) + REAL RONE, RZERO + PARAMETER ( RONE = 1.0, RZERO = 0.0 ) +* .. Scalar Arguments .. + REAL EPS, THRESH + INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + COMPLEX AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ), + $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ), + $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ), + $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), + $ W( 2*NMAX ) + REAL G( NMAX ) + INTEGER IDIM( NIDIM ) +* .. Local Scalars .. + COMPLEX ALPHA, ALS, BETA, BETS + REAL ERR, ERRMAX, RBETA, RBETS + INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB, + $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS, + $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS + LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER + CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS + CHARACTER*2 ICHT, ICHU +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LCE, LCERES + EXTERNAL LCE, LCERES +* .. External Subroutines .. + EXTERNAL CCHER2K, CMAKE, CMMCH, CCSYR2K +* .. Intrinsic Functions .. + INTRINSIC CMPLX, CONJG, MAX, REAL +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL LERR, OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK, LERR +* .. Data statements .. + DATA ICHT/'NC'/, ICHU/'UL'/ +* .. Executable Statements .. + CONJ = SNAME( 8: 9 ).EQ.'he' +* + NARGS = 12 + NC = 0 + RESET = .TRUE. + ERRMAX = RZERO +* + DO 130 IN = 1, NIDIM + N = IDIM( IN ) +* Set LDC to 1 more than minimum value if room. + LDC = N + IF( LDC.LT.NMAX ) + $ LDC = LDC + 1 +* Skip tests if not enough room. + IF( LDC.GT.NMAX ) + $ GO TO 130 + LCC = LDC*N +* + DO 120 IK = 1, NIDIM + K = IDIM( IK ) +* + DO 110 ICT = 1, 2 + TRANS = ICHT( ICT: ICT ) + TRAN = TRANS.EQ.'C' + IF( TRAN.AND..NOT.CONJ ) + $ TRANS = 'T' + IF( TRAN )THEN + MA = K + NA = N + ELSE + MA = N + NA = K + END IF +* Set LDA to 1 more than minimum value if room. + LDA = MA + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 110 + LAA = LDA*NA +* +* Generate the matrix A. +* + IF( TRAN )THEN + CALL CMAKE( 'ge', ' ', ' ', MA, NA, AB, 2*NMAX, AA, + $ LDA, RESET, ZERO ) + ELSE + CALL CMAKE( 'ge', ' ', ' ', MA, NA, AB, NMAX, AA, LDA, + $ RESET, ZERO ) + END IF +* +* Generate the matrix B. +* + LDB = LDA + LBB = LAA + IF( TRAN )THEN + CALL CMAKE( 'ge', ' ', ' ', MA, NA, AB( K + 1 ), + $ 2*NMAX, BB, LDB, RESET, ZERO ) + ELSE + CALL CMAKE( 'ge', ' ', ' ', MA, NA, AB( K*NMAX + 1 ), + $ NMAX, BB, LDB, RESET, ZERO ) + END IF +* + DO 100 ICU = 1, 2 + UPLO = ICHU( ICU: ICU ) + UPPER = UPLO.EQ.'U' +* + DO 90 IA = 1, NALF + ALPHA = ALF( IA ) +* + DO 80 IB = 1, NBET + BETA = BET( IB ) + IF( CONJ )THEN + RBETA = REAL( BETA ) + BETA = CMPLX( RBETA, RZERO ) + END IF + NULL = N.LE.0 + IF( CONJ ) + $ NULL = NULL.OR.( ( K.LE.0.OR.ALPHA.EQ. + $ ZERO ).AND.RBETA.EQ.RONE ) +* +* Generate the matrix C. +* + CALL CMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, C, + $ NMAX, CC, LDC, RESET, ZERO ) +* + NC = NC + 1 +* +* Save every datum before calling the subroutine. +* + UPLOS = UPLO + TRANSS = TRANS + NS = N + KS = K + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LBB + BS( I ) = BB( I ) + 20 CONTINUE + LDBS = LDB + IF( CONJ )THEN + RBETS = RBETA + ELSE + BETS = BETA + END IF + DO 30 I = 1, LCC + CS( I ) = CC( I ) + 30 CONTINUE + LDCS = LDC +* +* Call the subroutine. +* + IF( CONJ )THEN + IF( TRACE ) + $ CALL CPRCN7( NTRA, NC, SNAME, IORDER, + $ UPLO, TRANS, N, K, ALPHA, LDA, LDB, + $ RBETA, LDC) + IF( REWI ) + $ REWIND NTRA + CALL CCHER2K( IORDER, UPLO, TRANS, N, K, + $ ALPHA, AA, LDA, BB, LDB, RBETA, + $ CC, LDC ) + ELSE + IF( TRACE ) + $ CALL CPRCN5( NTRA, NC, SNAME, IORDER, + $ UPLO, TRANS, N, K, ALPHA, LDA, LDB, + $ BETA, LDC) + IF( REWI ) + $ REWIND NTRA + CALL CCSYR2K( IORDER, UPLO, TRANS, N, K, + $ ALPHA, AA, LDA, BB, LDB, BETA, + $ CC, LDC ) + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9992 ) + FATAL = .TRUE. + GO TO 150 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = UPLOS.EQ.UPLO + ISAME( 2 ) = TRANSS.EQ.TRANS + ISAME( 3 ) = NS.EQ.N + ISAME( 4 ) = KS.EQ.K + ISAME( 5 ) = ALS.EQ.ALPHA + ISAME( 6 ) = LCE( AS, AA, LAA ) + ISAME( 7 ) = LDAS.EQ.LDA + ISAME( 8 ) = LCE( BS, BB, LBB ) + ISAME( 9 ) = LDBS.EQ.LDB + IF( CONJ )THEN + ISAME( 10 ) = RBETS.EQ.RBETA + ELSE + ISAME( 10 ) = BETS.EQ.BETA + END IF + IF( NULL )THEN + ISAME( 11 ) = LCE( CS, CC, LCC ) + ELSE + ISAME( 11 ) = LCERES( 'he', UPLO, N, N, CS, + $ CC, LDC ) + END IF + ISAME( 12 ) = LDCS.EQ.LDC +* +* If data was incorrectly changed, report and +* return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 150 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result column by column. +* + IF( CONJ )THEN + TRANST = 'C' + ELSE + TRANST = 'T' + END IF + JJAB = 1 + JC = 1 + DO 70 J = 1, N + IF( UPPER )THEN + JJ = 1 + LJ = J + ELSE + JJ = J + LJ = N - J + 1 + END IF + IF( TRAN )THEN + DO 50 I = 1, K + W( I ) = ALPHA*AB( ( J - 1 )*2* + $ NMAX + K + I ) + IF( CONJ )THEN + W( K + I ) = CONJG( ALPHA )* + $ AB( ( J - 1 )*2* + $ NMAX + I ) + ELSE + W( K + I ) = ALPHA* + $ AB( ( J - 1 )*2* + $ NMAX + I ) + END IF + 50 CONTINUE + CALL CMMCH( TRANST, 'N', LJ, 1, 2*K, + $ ONE, AB( JJAB ), 2*NMAX, W, + $ 2*NMAX, BETA, C( JJ, J ), + $ NMAX, CT, G, CC( JC ), LDC, + $ EPS, ERR, FATAL, NOUT, + $ .TRUE. ) + ELSE + DO 60 I = 1, K + IF( CONJ )THEN + W( I ) = ALPHA*CONJG( AB( ( K + + $ I - 1 )*NMAX + J ) ) + W( K + I ) = CONJG( ALPHA* + $ AB( ( I - 1 )*NMAX + + $ J ) ) + ELSE + W( I ) = ALPHA*AB( ( K + I - 1 )* + $ NMAX + J ) + W( K + I ) = ALPHA* + $ AB( ( I - 1 )*NMAX + + $ J ) + END IF + 60 CONTINUE + CALL CMMCH( 'N', 'N', LJ, 1, 2*K, ONE, + $ AB( JJ ), NMAX, W, 2*NMAX, + $ BETA, C( JJ, J ), NMAX, CT, + $ G, CC( JC ), LDC, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + END IF + IF( UPPER )THEN + JC = JC + LDC + ELSE + JC = JC + LDC + 1 + IF( TRAN ) + $ JJAB = JJAB + 2*NMAX + END IF + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and +* return. + IF( FATAL ) + $ GO TO 140 + 70 CONTINUE + END IF +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* + 110 CONTINUE +* + 120 CONTINUE +* + 130 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 160 +* + 140 CONTINUE + IF( N.GT.1 ) + $ WRITE( NOUT, FMT = 9995 )J +* + 150 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + IF( CONJ )THEN + CALL CPRCN7( NOUT, NC, SNAME, IORDER, UPLO, TRANS, N, K, + $ ALPHA, LDA, LDB, RBETA, LDC) + ELSE + CALL CPRCN5( NOUT, NC, SNAME, IORDER, UPLO, TRANS, N, K, + $ ALPHA, LDA, LDB, BETA, LDC) + END IF +* + 160 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) + 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, ') .' ) + 9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of CCHK5. +* + END +* + SUBROUTINE CPRCN5(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, + $ N, K, ALPHA, LDA, LDB, BETA, LDC) + INTEGER NOUT, NC, IORDER, N, K, LDA, LDB, LDC + COMPLEX ALPHA, BETA + CHARACTER*1 UPLO, TRANSA + CHARACTER*12 SNAME + CHARACTER*14 CRC, CU, CA + + IF (UPLO.EQ.'U')THEN + CU = ' CblasUpper' + ELSE + CU = ' CblasLower' + END IF + IF (TRANSA.EQ.'N')THEN + CA = ' CblasNoTrans' + ELSE IF (TRANSA.EQ.'T')THEN + CA = ' CblasTrans' + ELSE + CA = 'CblasConjTrans' + END IF + IF (IORDER.EQ.1)THEN + CRC = ' CblasRowMajor' + ELSE + CRC = ' CblasColMajor' + END IF + WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA + WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, LDB, BETA, LDC + + 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') ) + 9994 FORMAT( 10X, 2( I3, ',' ), ' (', F4.1, ',', F4.1, '), A,', + $ I3, ', B', I3, ', (', F4.1, ',', F4.1, '), C,', I3, ').' ) + END +* +* + SUBROUTINE CPRCN7(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, + $ N, K, ALPHA, LDA, LDB, BETA, LDC) + INTEGER NOUT, NC, IORDER, N, K, LDA, LDB, LDC + COMPLEX ALPHA + REAL BETA + CHARACTER*1 UPLO, TRANSA + CHARACTER*12 SNAME + CHARACTER*14 CRC, CU, CA + + IF (UPLO.EQ.'U')THEN + CU = ' CblasUpper' + ELSE + CU = ' CblasLower' + END IF + IF (TRANSA.EQ.'N')THEN + CA = ' CblasNoTrans' + ELSE IF (TRANSA.EQ.'T')THEN + CA = ' CblasTrans' + ELSE + CA = 'CblasConjTrans' + END IF + IF (IORDER.EQ.1)THEN + CRC = ' CblasRowMajor' + ELSE + CRC = ' CblasColMajor' + END IF + WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA + WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, LDB, BETA, LDC + + 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') ) + 9994 FORMAT( 10X, 2( I3, ',' ), ' (', F4.1, ',', F4.1, '), A,', + $ I3, ', B', I3, ',', F4.1, ', C,', I3, ').' ) + END +* + SUBROUTINE CMAKE(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, + $ TRANSL ) +* +* 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 .. + COMPLEX ZERO, ONE + PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) + COMPLEX ROGUE + PARAMETER ( ROGUE = ( -1.0E10, 1.0E10 ) ) + REAL RZERO + PARAMETER ( RZERO = 0.0 ) + REAL RROGUE + PARAMETER ( RROGUE = -1.0E10 ) +* .. Scalar Arguments .. + COMPLEX TRANSL + INTEGER LDA, M, N, NMAX + LOGICAL RESET + CHARACTER*1 DIAG, UPLO + CHARACTER*2 TYPE +* .. Array Arguments .. + COMPLEX A( NMAX, * ), AA( * ) +* .. Local Scalars .. + INTEGER I, IBEG, IEND, J, JJ + LOGICAL GEN, HER, LOWER, SYM, TRI, UNIT, UPPER +* .. External Functions .. + COMPLEX CBEG + EXTERNAL CBEG +* .. Intrinsic Functions .. + INTRINSIC CMPLX, CONJG, REAL +* .. Executable Statements .. + GEN = TYPE.EQ.'ge' + HER = TYPE.EQ.'he' + SYM = TYPE.EQ.'sy' + TRI = TYPE.EQ.'tr' + UPPER = ( HER.OR.SYM.OR.TRI ).AND.UPLO.EQ.'U' + LOWER = ( HER.OR.SYM.OR.TRI ).AND.UPLO.EQ.'L' + UNIT = TRI.AND.DIAG.EQ.'U' +* +* Generate data in array A. +* + DO 20 J = 1, N + DO 10 I = 1, M + IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) + $ THEN + A( I, J ) = CBEG( RESET ) + TRANSL + IF( I.NE.J )THEN +* Set some elements to zero + IF( N.GT.3.AND.J.EQ.N/2 ) + $ A( I, J ) = ZERO + IF( HER )THEN + A( J, I ) = CONJG( A( I, J ) ) + ELSE IF( SYM )THEN + A( J, I ) = A( I, J ) + ELSE IF( TRI )THEN + A( J, I ) = ZERO + END IF + END IF + END IF + 10 CONTINUE + IF( HER ) + $ A( J, J ) = CMPLX( REAL( A( J, J ) ), RZERO ) + IF( TRI ) + $ A( J, J ) = A( J, J ) + ONE + IF( UNIT ) + $ A( J, J ) = ONE + 20 CONTINUE +* +* Store elements in array AS in data structure required by routine. +* + IF( TYPE.EQ.'ge' )THEN + DO 50 J = 1, N + DO 30 I = 1, M + AA( I + ( J - 1 )*LDA ) = A( I, J ) + 30 CONTINUE + DO 40 I = M + 1, LDA + AA( I + ( J - 1 )*LDA ) = ROGUE + 40 CONTINUE + 50 CONTINUE + ELSE IF( TYPE.EQ.'he'.OR.TYPE.EQ.'sy'.OR.TYPE.EQ.'tr' )THEN + DO 90 J = 1, N + IF( UPPER )THEN + IBEG = 1 + IF( UNIT )THEN + IEND = J - 1 + ELSE + IEND = J + END IF + ELSE + IF( UNIT )THEN + IBEG = J + 1 + ELSE + IBEG = J + END IF + IEND = N + END IF + DO 60 I = 1, IBEG - 1 + AA( I + ( J - 1 )*LDA ) = ROGUE + 60 CONTINUE + DO 70 I = IBEG, IEND + AA( I + ( J - 1 )*LDA ) = A( I, J ) + 70 CONTINUE + DO 80 I = IEND + 1, LDA + AA( I + ( J - 1 )*LDA ) = ROGUE + 80 CONTINUE + IF( HER )THEN + JJ = J + ( J - 1 )*LDA + AA( JJ ) = CMPLX( REAL( AA( JJ ) ), RROGUE ) + END IF + 90 CONTINUE + END IF + RETURN +* +* End of CMAKE. +* + END + SUBROUTINE CMMCH(TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, + $ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, + $ NOUT, MV ) +* +* 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 .. + COMPLEX ZERO + PARAMETER ( ZERO = ( 0.0, 0.0 ) ) + REAL RZERO, RONE + PARAMETER ( RZERO = 0.0, RONE = 1.0 ) +* .. Scalar Arguments .. + COMPLEX ALPHA, BETA + REAL EPS, ERR + INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT + LOGICAL FATAL, MV + CHARACTER*1 TRANSA, TRANSB +* .. Array Arguments .. + COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ CC( LDCC, * ), CT( * ) + REAL G( * ) +* .. Local Scalars .. + COMPLEX CL + REAL ERRI + INTEGER I, J, K + LOGICAL CTRANA, CTRANB, TRANA, TRANB +* .. Intrinsic Functions .. + INTRINSIC ABS, AIMAG, CONJG, MAX, REAL, SQRT +* .. Statement Functions .. + REAL ABS1 +* .. Statement Function definitions .. + ABS1( CL ) = ABS( REAL( CL ) ) + ABS( AIMAG( CL ) ) +* .. Executable Statements .. + TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' + TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' + CTRANA = TRANSA.EQ.'C' + CTRANB = TRANSB.EQ.'C' +* +* Compute expected result, one column at a time, in CT using data +* in A, B and C. +* Compute gauges in G. +* + DO 220 J = 1, N +* + DO 10 I = 1, M + CT( I ) = ZERO + G( I ) = RZERO + 10 CONTINUE + IF( .NOT.TRANA.AND..NOT.TRANB )THEN + DO 30 K = 1, KK + DO 20 I = 1, M + CT( I ) = CT( I ) + A( I, K )*B( K, J ) + G( I ) = G( I ) + ABS1( A( I, K ) )*ABS1( B( K, J ) ) + 20 CONTINUE + 30 CONTINUE + ELSE IF( TRANA.AND..NOT.TRANB )THEN + IF( CTRANA )THEN + DO 50 K = 1, KK + DO 40 I = 1, M + CT( I ) = CT( I ) + CONJG( A( K, I ) )*B( K, J ) + G( I ) = G( I ) + ABS1( A( K, I ) )* + $ ABS1( B( K, J ) ) + 40 CONTINUE + 50 CONTINUE + ELSE + DO 70 K = 1, KK + DO 60 I = 1, M + CT( I ) = CT( I ) + A( K, I )*B( K, J ) + G( I ) = G( I ) + ABS1( A( K, I ) )* + $ ABS1( B( K, J ) ) + 60 CONTINUE + 70 CONTINUE + END IF + ELSE IF( .NOT.TRANA.AND.TRANB )THEN + IF( CTRANB )THEN + DO 90 K = 1, KK + DO 80 I = 1, M + CT( I ) = CT( I ) + A( I, K )*CONJG( B( J, K ) ) + G( I ) = G( I ) + ABS1( A( I, K ) )* + $ ABS1( B( J, K ) ) + 80 CONTINUE + 90 CONTINUE + ELSE + DO 110 K = 1, KK + DO 100 I = 1, M + CT( I ) = CT( I ) + A( I, K )*B( J, K ) + G( I ) = G( I ) + ABS1( A( I, K ) )* + $ ABS1( B( J, K ) ) + 100 CONTINUE + 110 CONTINUE + END IF + ELSE IF( TRANA.AND.TRANB )THEN + IF( CTRANA )THEN + IF( CTRANB )THEN + DO 130 K = 1, KK + DO 120 I = 1, M + CT( I ) = CT( I ) + CONJG( A( K, I ) )* + $ CONJG( B( J, K ) ) + G( I ) = G( I ) + ABS1( A( K, I ) )* + $ ABS1( B( J, K ) ) + 120 CONTINUE + 130 CONTINUE + ELSE + DO 150 K = 1, KK + DO 140 I = 1, M + CT( I ) = CT( I ) + CONJG( A( K, I ) )*B( J, K ) + G( I ) = G( I ) + ABS1( A( K, I ) )* + $ ABS1( B( J, K ) ) + 140 CONTINUE + 150 CONTINUE + END IF + ELSE + IF( CTRANB )THEN + DO 170 K = 1, KK + DO 160 I = 1, M + CT( I ) = CT( I ) + A( K, I )*CONJG( B( J, K ) ) + G( I ) = G( I ) + ABS1( A( K, I ) )* + $ ABS1( B( J, K ) ) + 160 CONTINUE + 170 CONTINUE + ELSE + DO 190 K = 1, KK + DO 180 I = 1, M + CT( I ) = CT( I ) + A( K, I )*B( J, K ) + G( I ) = G( I ) + ABS1( A( K, I ) )* + $ ABS1( B( J, K ) ) + 180 CONTINUE + 190 CONTINUE + END IF + END IF + END IF + DO 200 I = 1, M + CT( I ) = ALPHA*CT( I ) + BETA*C( I, J ) + G( I ) = ABS1( ALPHA )*G( I ) + + $ ABS1( BETA )*ABS1( C( I, J ) ) + 200 CONTINUE +* +* Compute the error ratio for this result. +* + ERR = ZERO + DO 210 I = 1, M + ERRI = ABS1( CT( I ) - CC( I, J ) )/EPS + IF( G( I ).NE.RZERO ) + $ ERRI = ERRI/G( I ) + ERR = MAX( ERR, ERRI ) + IF( ERR*SQRT( EPS ).GE.RONE ) + $ GO TO 230 + 210 CONTINUE +* + 220 CONTINUE +* +* If the loop completes, all results are at least half accurate. + GO TO 250 +* +* Report fatal error. +* + 230 FATAL = .TRUE. + WRITE( NOUT, FMT = 9999 ) + DO 240 I = 1, M + IF( MV )THEN + WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J ) + ELSE + WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I ) + END IF + 240 CONTINUE + IF( N.GT.1 ) + $ WRITE( NOUT, FMT = 9997 )J +* + 250 CONTINUE + RETURN +* + 9999 FORMAT(' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', + $ 'F ACCURATE *******', /' EXPECTED RE', + $ 'SULT COMPUTED RESULT' ) + 9998 FORMAT( 1X, I7, 2( ' (', G15.6, ',', G15.6, ')' ) ) + 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) +* +* End of CMMCH. +* + END + LOGICAL FUNCTION LCE( RI, RJ, LR ) +* +* 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 .. + INTEGER LR +* .. Array Arguments .. + COMPLEX RI( * ), RJ( * ) +* .. Local Scalars .. + INTEGER I +* .. Executable Statements .. + DO 10 I = 1, LR + IF( RI( I ).NE.RJ( I ) ) + $ GO TO 20 + 10 CONTINUE + LCE = .TRUE. + GO TO 30 + 20 CONTINUE + LCE = .FALSE. + 30 RETURN +* +* End of LCE. +* + END + LOGICAL FUNCTION LCERES( TYPE, UPLO, M, N, AA, AS, LDA ) +* +* 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 .. + INTEGER LDA, M, N + CHARACTER*1 UPLO + CHARACTER*2 TYPE +* .. Array Arguments .. + COMPLEX AA( LDA, * ), AS( LDA, * ) +* .. Local Scalars .. + INTEGER I, IBEG, IEND, J + LOGICAL UPPER +* .. Executable Statements .. + UPPER = UPLO.EQ.'U' + IF( TYPE.EQ.'ge' )THEN + DO 20 J = 1, N + DO 10 I = M + 1, LDA + IF( AA( I, J ).NE.AS( I, J ) ) + $ GO TO 70 + 10 CONTINUE + 20 CONTINUE + ELSE IF( TYPE.EQ.'he'.OR.TYPE.EQ.'sy' )THEN + DO 50 J = 1, N + IF( UPPER )THEN + IBEG = 1 + IEND = J + ELSE + IBEG = J + IEND = N + END IF + DO 30 I = 1, IBEG - 1 + IF( AA( I, J ).NE.AS( I, J ) ) + $ GO TO 70 + 30 CONTINUE + DO 40 I = IEND + 1, LDA + IF( AA( I, J ).NE.AS( I, J ) ) + $ GO TO 70 + 40 CONTINUE + 50 CONTINUE + END IF +* + 60 CONTINUE + LCERES = .TRUE. + GO TO 80 + 70 CONTINUE + LCERES = .FALSE. + 80 RETURN +* +* End of LCERES. +* + END + COMPLEX FUNCTION CBEG( RESET ) +* +* 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 .. + LOGICAL RESET +* .. Local Scalars .. + INTEGER I, IC, J, MI, MJ +* .. Save statement .. + SAVE I, IC, J, MI, MJ +* .. Intrinsic Functions .. + INTRINSIC CMPLX +* .. Executable Statements .. + IF( RESET )THEN +* Initialize local variables. + MI = 891 + MJ = 457 + I = 7 + J = 7 + IC = 0 + RESET = .FALSE. + END IF +* +* 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 = IC + 1 + 10 I = I*MI + J = J*MJ + I = I - 1000*( I/1000 ) + J = J - 1000*( J/1000 ) + IF( IC.GE.5 )THEN + IC = 0 + GO TO 10 + END IF + CBEG = CMPLX( ( I - 500 )/1001.0, ( J - 500 )/1001.0 ) + RETURN +* +* End of CBEG. +* + END + REAL FUNCTION SDIFF( X, Y ) +* +* 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 .. + REAL X, Y +* .. Executable Statements .. + SDIFF = X - Y + RETURN +* +* End of SDIFF. +* + END diff --git a/cblas/testing/c_d2chke.c b/cblas/testing/c_d2chke.c new file mode 100644 index 00000000..46a242fc --- /dev/null +++ b/cblas/testing/c_d2chke.c @@ -0,0 +1,789 @@ +#include <stdio.h> +#include <string.h> +#include "cblas.h" +#include "cblas_test.h" + +int cblas_ok, cblas_lerr, cblas_info; +int link_xerbla=TRUE; +char *cblas_rout; + +#ifdef F77_Char +void F77_xerbla(F77_Char F77_srname, void *vinfo); +#else +void F77_xerbla(char *srname, void *vinfo); +#endif + +void chkxer(void) { + extern int cblas_ok, cblas_lerr, cblas_info; + extern int link_xerbla; + extern char *cblas_rout; + if (cblas_lerr == 1 ) { + printf("***** ILLEGAL VALUE OF PARAMETER NUMBER %d NOT DETECTED BY %s *****\n", cblas_info, cblas_rout); + cblas_ok = 0 ; + } + cblas_lerr = 1 ; +} + +void F77_d2chke(char *rout) { + char *sf = ( rout ) ; + double A[2] = {0.0,0.0}, + X[2] = {0.0,0.0}, + Y[2] = {0.0,0.0}, + ALPHA=0.0, BETA=0.0; + extern int cblas_info, cblas_lerr, cblas_ok; + extern int RowMajorStrg; + extern char *cblas_rout; + + if (link_xerbla) /* call these first to link */ + { + cblas_xerbla(cblas_info,cblas_rout,""); + F77_xerbla(cblas_rout,&cblas_info); + } + + cblas_ok = TRUE ; + cblas_lerr = PASSED ; + + if (strncmp( sf,"cblas_dgemv",11)==0) { + cblas_rout = "cblas_dgemv"; + cblas_info = 1; + cblas_dgemv(INVALID, CblasNoTrans, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dgemv(CblasColMajor, INVALID, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dgemv(CblasColMajor, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dgemv(CblasColMajor, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_dgemv(CblasColMajor, CblasNoTrans, 2, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_dgemv(CblasColMajor, CblasNoTrans, 0, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_dgemv(CblasColMajor, CblasNoTrans, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + + cblas_info = 2; RowMajorStrg = TRUE; RowMajorStrg = TRUE; + cblas_dgemv(CblasRowMajor, INVALID, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_dgemv(CblasRowMajor, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_dgemv(CblasRowMajor, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_dgemv(CblasRowMajor, CblasNoTrans, 0, 2, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_dgemv(CblasRowMajor, CblasNoTrans, 0, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_dgemv(CblasRowMajor, CblasNoTrans, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_dgbmv",11)==0) { + cblas_rout = "cblas_dgbmv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_dgbmv(INVALID, CblasNoTrans, 0, 0, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dgbmv(CblasColMajor, INVALID, 0, 0, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dgbmv(CblasColMajor, CblasNoTrans, INVALID, 0, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dgbmv(CblasColMajor, CblasNoTrans, 0, INVALID, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dgbmv(CblasColMajor, CblasNoTrans, 0, 0, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dgbmv(CblasColMajor, CblasNoTrans, 2, 0, 0, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_dgbmv(CblasColMajor, CblasNoTrans, 0, 0, 1, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_dgbmv(CblasColMajor, CblasNoTrans, 0, 0, 0, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_dgbmv(CblasColMajor, CblasNoTrans, 0, 0, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_dgbmv(CblasRowMajor, INVALID, 0, 0, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_dgbmv(CblasRowMajor, CblasNoTrans, INVALID, 0, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_dgbmv(CblasRowMajor, CblasNoTrans, 0, INVALID, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_dgbmv(CblasRowMajor, CblasNoTrans, 0, 0, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dgbmv(CblasRowMajor, CblasNoTrans, 2, 0, 0, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_dgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 1, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_dgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 0, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_dgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_dsymv",11)==0) { + cblas_rout = "cblas_dsymv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_dsymv(INVALID, CblasUpper, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dsymv(CblasColMajor, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dsymv(CblasColMajor, CblasUpper, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dsymv(CblasColMajor, CblasUpper, 2, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dsymv(CblasColMajor, CblasUpper, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_dsymv(CblasColMajor, CblasUpper, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_dsymv(CblasRowMajor, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_dsymv(CblasRowMajor, CblasUpper, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dsymv(CblasRowMajor, CblasUpper, 2, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dsymv(CblasRowMajor, CblasUpper, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_dsymv(CblasRowMajor, CblasUpper, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_dsbmv",11)==0) { + cblas_rout = "cblas_dsbmv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_dsbmv(INVALID, CblasUpper, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dsbmv(CblasColMajor, INVALID, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dsbmv(CblasColMajor, CblasUpper, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dsbmv(CblasColMajor, CblasUpper, 0, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_dsbmv(CblasColMajor, CblasUpper, 0, 1, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_dsbmv(CblasColMajor, CblasUpper, 0, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_dsbmv(CblasColMajor, CblasUpper, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_dsbmv(CblasRowMajor, INVALID, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_dsbmv(CblasRowMajor, CblasUpper, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_dsbmv(CblasRowMajor, CblasUpper, 0, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_dsbmv(CblasRowMajor, CblasUpper, 0, 1, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_dsbmv(CblasRowMajor, CblasUpper, 0, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_dsbmv(CblasRowMajor, CblasUpper, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_dspmv",11)==0) { + cblas_rout = "cblas_dspmv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_dspmv(INVALID, CblasUpper, 0, + ALPHA, A, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dspmv(CblasColMajor, INVALID, 0, + ALPHA, A, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dspmv(CblasColMajor, CblasUpper, INVALID, + ALPHA, A, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_dspmv(CblasColMajor, CblasUpper, 0, + ALPHA, A, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dspmv(CblasColMajor, CblasUpper, 0, + ALPHA, A, X, 1, BETA, Y, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_dspmv(CblasRowMajor, INVALID, 0, + ALPHA, A, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_dspmv(CblasRowMajor, CblasUpper, INVALID, + ALPHA, A, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_dspmv(CblasRowMajor, CblasUpper, 0, + ALPHA, A, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dspmv(CblasRowMajor, CblasUpper, 0, + ALPHA, A, X, 1, BETA, Y, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_dtrmv",11)==0) { + cblas_rout = "cblas_dtrmv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_dtrmv(INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dtrmv(CblasColMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dtrmv(CblasColMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dtrmv(CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dtrmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_dtrmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, A, 1, X, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_dtrmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_dtrmv(CblasRowMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_dtrmv(CblasRowMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_dtrmv(CblasRowMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_dtrmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_dtrmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, A, 1, X, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_dtrmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_dtbmv",11)==0) { + cblas_rout = "cblas_dtbmv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_dtbmv(INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dtbmv(CblasColMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dtbmv(CblasColMajor, CblasUpper, INVALID, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dtbmv(CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dtbmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dtbmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dtbmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 1, A, 1, X, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dtbmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_dtbmv(CblasRowMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_dtbmv(CblasRowMajor, CblasUpper, INVALID, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_dtbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + INVALID, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_dtbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dtbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dtbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 1, A, 1, X, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dtbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_dtpmv",11)==0) { + cblas_rout = "cblas_dtpmv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_dtpmv(INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dtpmv(CblasColMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dtpmv(CblasColMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dtpmv(CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dtpmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dtpmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, X, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_dtpmv(CblasRowMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_dtpmv(CblasRowMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_dtpmv(CblasRowMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_dtpmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dtpmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, X, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_dtrsv",11)==0) { + cblas_rout = "cblas_dtrsv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_dtrsv(INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dtrsv(CblasColMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dtrsv(CblasColMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dtrsv(CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dtrsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_dtrsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, A, 1, X, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_dtrsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_dtrsv(CblasRowMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_dtrsv(CblasRowMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_dtrsv(CblasRowMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_dtrsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_dtrsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, A, 1, X, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_dtrsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_dtbsv",11)==0) { + cblas_rout = "cblas_dtbsv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_dtbsv(INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dtbsv(CblasColMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dtbsv(CblasColMajor, CblasUpper, INVALID, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dtbsv(CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dtbsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dtbsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dtbsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 1, A, 1, X, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dtbsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_dtbsv(CblasRowMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_dtbsv(CblasRowMajor, CblasUpper, INVALID, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_dtbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + INVALID, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_dtbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dtbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dtbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 1, A, 1, X, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dtbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_dtpsv",11)==0) { + cblas_rout = "cblas_dtpsv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_dtpsv(INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dtpsv(CblasColMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dtpsv(CblasColMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dtpsv(CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dtpsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dtpsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, X, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_dtpsv(CblasRowMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_dtpsv(CblasRowMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_dtpsv(CblasRowMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_dtpsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dtpsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, X, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_dger",10)==0) { + cblas_rout = "cblas_dger"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_dger(INVALID, 0, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dger(CblasColMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dger(CblasColMajor, 0, INVALID, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dger(CblasColMajor, 0, 0, ALPHA, X, 0, Y, 1, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dger(CblasColMajor, 0, 0, ALPHA, X, 1, Y, 0, A, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dger(CblasColMajor, 2, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_dger(CblasRowMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_dger(CblasRowMajor, 0, INVALID, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dger(CblasRowMajor, 0, 0, ALPHA, X, 0, Y, 1, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dger(CblasRowMajor, 0, 0, ALPHA, X, 1, Y, 0, A, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dger(CblasRowMajor, 0, 2, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + } else if (strncmp( sf,"cblas_dsyr2",11)==0) { + cblas_rout = "cblas_dsyr2"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_dsyr2(INVALID, CblasUpper, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dsyr2(CblasColMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dsyr2(CblasColMajor, CblasUpper, INVALID, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dsyr2(CblasColMajor, CblasUpper, 0, ALPHA, X, 0, Y, 1, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dsyr2(CblasColMajor, CblasUpper, 0, ALPHA, X, 1, Y, 0, A, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dsyr2(CblasColMajor, CblasUpper, 2, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_dsyr2(CblasRowMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_dsyr2(CblasRowMajor, CblasUpper, INVALID, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dsyr2(CblasRowMajor, CblasUpper, 0, ALPHA, X, 0, Y, 1, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dsyr2(CblasRowMajor, CblasUpper, 0, ALPHA, X, 1, Y, 0, A, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dsyr2(CblasRowMajor, CblasUpper, 2, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + } else if (strncmp( sf,"cblas_dspr2",11)==0) { + cblas_rout = "cblas_dspr2"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_dspr2(INVALID, CblasUpper, 0, ALPHA, X, 1, Y, 1, A ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dspr2(CblasColMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dspr2(CblasColMajor, CblasUpper, INVALID, ALPHA, X, 1, Y, 1, A ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dspr2(CblasColMajor, CblasUpper, 0, ALPHA, X, 0, Y, 1, A ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dspr2(CblasColMajor, CblasUpper, 0, ALPHA, X, 1, Y, 0, A ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_dspr2(CblasRowMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_dspr2(CblasRowMajor, CblasUpper, INVALID, ALPHA, X, 1, Y, 1, A ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dspr2(CblasRowMajor, CblasUpper, 0, ALPHA, X, 0, Y, 1, A ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dspr2(CblasRowMajor, CblasUpper, 0, ALPHA, X, 1, Y, 0, A ); + chkxer(); + } else if (strncmp( sf,"cblas_dsyr",10)==0) { + cblas_rout = "cblas_dsyr"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_dsyr(INVALID, CblasUpper, 0, ALPHA, X, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dsyr(CblasColMajor, INVALID, 0, ALPHA, X, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dsyr(CblasColMajor, CblasUpper, INVALID, ALPHA, X, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dsyr(CblasColMajor, CblasUpper, 0, ALPHA, X, 0, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dsyr(CblasColMajor, CblasUpper, 2, ALPHA, X, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_dsyr(CblasRowMajor, INVALID, 0, ALPHA, X, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_dsyr(CblasRowMajor, CblasUpper, INVALID, ALPHA, X, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dsyr(CblasRowMajor, CblasUpper, 0, ALPHA, X, 0, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dsyr(CblasRowMajor, CblasUpper, 2, ALPHA, X, 1, A, 1 ); + chkxer(); + } else if (strncmp( sf,"cblas_dspr",10)==0) { + cblas_rout = "cblas_dspr"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_dspr(INVALID, CblasUpper, 0, ALPHA, X, 1, A ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dspr(CblasColMajor, INVALID, 0, ALPHA, X, 1, A ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dspr(CblasColMajor, CblasUpper, INVALID, ALPHA, X, 1, A ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dspr(CblasColMajor, CblasUpper, 0, ALPHA, X, 0, A ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dspr(CblasColMajor, INVALID, 0, ALPHA, X, 1, A ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dspr(CblasColMajor, CblasUpper, INVALID, ALPHA, X, 1, A ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dspr(CblasColMajor, CblasUpper, 0, ALPHA, X, 0, A ); + chkxer(); + } + if (cblas_ok == TRUE) + printf(" %-12s PASSED THE TESTS OF ERROR-EXITS\n", cblas_rout); + else + printf("******* %s FAILED THE TESTS OF ERROR-EXITS *******\n",cblas_rout); +} diff --git a/cblas/testing/c_d3chke.c b/cblas/testing/c_d3chke.c new file mode 100644 index 00000000..fae38d48 --- /dev/null +++ b/cblas/testing/c_d3chke.c @@ -0,0 +1,1271 @@ +#include <stdio.h> +#include <string.h> +#include "cblas.h" +#include "cblas_test.h" + +int cblas_ok, cblas_lerr, cblas_info; +int link_xerbla=TRUE; +char *cblas_rout; + +#ifdef F77_Char +void F77_xerbla(F77_Char F77_srname, void *vinfo); +#else +void F77_xerbla(char *srname, void *vinfo); +#endif + +void chkxer(void) { + extern int cblas_ok, cblas_lerr, cblas_info; + extern int link_xerbla; + extern char *cblas_rout; + if (cblas_lerr == 1 ) { + printf("***** ILLEGAL VALUE OF PARAMETER NUMBER %d NOT DETECTED BY %s *****\n", cblas_info, cblas_rout); + cblas_ok = 0 ; + } + cblas_lerr = 1 ; +} + +void F77_d3chke(char *rout) { + char *sf = ( rout ) ; + double A[2] = {0.0,0.0}, + B[2] = {0.0,0.0}, + C[2] = {0.0,0.0}, + ALPHA=0.0, BETA=0.0; + extern int cblas_info, cblas_lerr, cblas_ok; + extern int RowMajorStrg; + extern char *cblas_rout; + + if (link_xerbla) /* call these first to link */ + { + cblas_xerbla(cblas_info,cblas_rout,""); + F77_xerbla(cblas_rout,&cblas_info); + } + + cblas_ok = TRUE ; + cblas_lerr = PASSED ; + + if (strncmp( sf,"cblas_dgemm" ,11)==0) { + cblas_rout = "cblas_dgemm" ; + + cblas_info = 1; + cblas_dgemm( INVALID, CblasNoTrans, CblasNoTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_dgemm( INVALID, CblasNoTrans, CblasTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_dgemm( INVALID, CblasTrans, CblasNoTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_dgemm( INVALID, CblasTrans, CblasTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dgemm( CblasColMajor, INVALID, CblasNoTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dgemm( CblasColMajor, INVALID, CblasTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dgemm( CblasColMajor, CblasNoTrans, INVALID, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dgemm( CblasColMajor, CblasTrans, INVALID, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dgemm( CblasColMajor, CblasNoTrans, CblasTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dgemm( CblasColMajor, CblasTrans, CblasNoTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dgemm( CblasColMajor, CblasTrans, CblasTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dgemm( CblasColMajor, CblasNoTrans, CblasTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dgemm( CblasColMajor, CblasTrans, CblasNoTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dgemm( CblasColMajor, CblasTrans, CblasTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dgemm( CblasColMajor, CblasNoTrans, CblasTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dgemm( CblasColMajor, CblasTrans, CblasNoTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dgemm( CblasColMajor, CblasTrans, CblasTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_dgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 2, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_dgemm( CblasColMajor, CblasNoTrans, CblasTrans, 2, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_dgemm( CblasColMajor, CblasTrans, CblasNoTrans, 0, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_dgemm( CblasColMajor, CblasTrans, CblasTrans, 0, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_dgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 0, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_dgemm( CblasColMajor, CblasTrans, CblasNoTrans, 0, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_dgemm( CblasColMajor, CblasNoTrans, CblasTrans, 0, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_dgemm( CblasColMajor, CblasTrans, CblasTrans, 0, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_dgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 2, 0, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_dgemm( CblasColMajor, CblasNoTrans, CblasTrans, 2, 0, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_dgemm( CblasColMajor, CblasTrans, CblasNoTrans, 2, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_dgemm( CblasColMajor, CblasTrans, CblasTrans, 2, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_dgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_dgemm( CblasRowMajor, CblasNoTrans, CblasTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_dgemm( CblasRowMajor, CblasTrans, CblasNoTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_dgemm( CblasRowMajor, CblasTrans, CblasTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_dgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_dgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_dgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_dgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_dgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_dgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_dgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 2, 0, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_dgemm( CblasRowMajor, CblasTrans, CblasTrans, 2, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_dgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_dgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 0, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_dgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_dgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_dgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_dgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_dgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 0, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_dgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_dsymm" ,11)==0) { + cblas_rout = "cblas_dsymm" ; + + cblas_info = 1; + cblas_dsymm( INVALID, CblasRight, CblasLower, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dsymm( CblasColMajor, INVALID, CblasUpper, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dsymm( CblasColMajor, CblasLeft, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dsymm( CblasColMajor, CblasLeft, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dsymm( CblasColMajor, CblasRight, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dsymm( CblasColMajor, CblasLeft, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dsymm( CblasColMajor, CblasRight, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dsymm( CblasColMajor, CblasLeft, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dsymm( CblasColMajor, CblasRight, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dsymm( CblasColMajor, CblasLeft, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dsymm( CblasColMajor, CblasRight, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dsymm( CblasColMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dsymm( CblasColMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dsymm( CblasColMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dsymm( CblasColMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dsymm( CblasColMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dsymm( CblasColMajor, CblasRight, CblasUpper, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dsymm( CblasColMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dsymm( CblasColMajor, CblasRight, CblasLower, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_dsymm( CblasColMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_dsymm( CblasColMajor, CblasRight, CblasUpper, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_dsymm( CblasColMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_dsymm( CblasColMajor, CblasRight, CblasLower, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_dsymm( CblasRowMajor, CblasLeft, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_dsymm( CblasRowMajor, CblasRight, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_dsymm( CblasRowMajor, CblasLeft, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_dsymm( CblasRowMajor, CblasRight, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_dsymm( CblasRowMajor, CblasLeft, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_dsymm( CblasRowMajor, CblasRight, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_dsymm( CblasRowMajor, CblasLeft, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_dsymm( CblasRowMajor, CblasRight, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dsymm( CblasRowMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dsymm( CblasRowMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dsymm( CblasRowMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dsymm( CblasRowMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dsymm( CblasRowMajor, CblasLeft, CblasUpper, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dsymm( CblasRowMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dsymm( CblasRowMajor, CblasLeft, CblasLower, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dsymm( CblasRowMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_dsymm( CblasRowMajor, CblasLeft, CblasUpper, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_dsymm( CblasRowMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_dsymm( CblasRowMajor, CblasLeft, CblasLower, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_dsymm( CblasRowMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_dtrmm" ,11)==0) { + cblas_rout = "cblas_dtrmm" ; + + cblas_info = 1; + cblas_dtrmm( INVALID, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasLeft, INVALID, CblasNoTrans, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasLeft, CblasUpper, INVALID, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + INVALID, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_dtrmm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_dtrmm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_dtrsm" ,11)==0) { + cblas_rout = "cblas_dtrsm" ; + + cblas_info = 1; + cblas_dtrsm( INVALID, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasLeft, INVALID, CblasNoTrans, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasLeft, CblasUpper, INVALID, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + INVALID, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_dtrsm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_dtrsm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_dsyrk" ,11)==0) { + cblas_rout = "cblas_dsyrk" ; + + cblas_info = 1; + cblas_dsyrk( INVALID, CblasUpper, CblasNoTrans, + 0, 0, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dsyrk( CblasColMajor, INVALID, CblasNoTrans, + 0, 0, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dsyrk( CblasColMajor, CblasUpper, INVALID, + 0, 0, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dsyrk( CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dsyrk( CblasColMajor, CblasUpper, CblasTrans, + INVALID, 0, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dsyrk( CblasColMajor, CblasLower, CblasNoTrans, + INVALID, 0, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dsyrk( CblasColMajor, CblasLower, CblasTrans, + INVALID, 0, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dsyrk( CblasColMajor, CblasUpper, CblasNoTrans, + 0, INVALID, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dsyrk( CblasColMajor, CblasUpper, CblasTrans, + 0, INVALID, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dsyrk( CblasColMajor, CblasLower, CblasNoTrans, + 0, INVALID, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dsyrk( CblasColMajor, CblasLower, CblasTrans, + 0, INVALID, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dsyrk( CblasRowMajor, CblasUpper, CblasNoTrans, + 0, 2, ALPHA, A, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dsyrk( CblasRowMajor, CblasUpper, CblasTrans, + 2, 0, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dsyrk( CblasRowMajor, CblasLower, CblasNoTrans, + 0, 2, ALPHA, A, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dsyrk( CblasRowMajor, CblasLower, CblasTrans, + 2, 0, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dsyrk( CblasColMajor, CblasUpper, CblasNoTrans, + 2, 0, ALPHA, A, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dsyrk( CblasColMajor, CblasUpper, CblasTrans, + 0, 2, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dsyrk( CblasColMajor, CblasLower, CblasNoTrans, + 2, 0, ALPHA, A, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dsyrk( CblasColMajor, CblasLower, CblasTrans, + 0, 2, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_dsyrk( CblasRowMajor, CblasUpper, CblasNoTrans, + 2, 0, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_dsyrk( CblasRowMajor, CblasUpper, CblasTrans, + 2, 0, ALPHA, A, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_dsyrk( CblasRowMajor, CblasLower, CblasNoTrans, + 2, 0, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_dsyrk( CblasRowMajor, CblasLower, CblasTrans, + 2, 0, ALPHA, A, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_dsyrk( CblasColMajor, CblasUpper, CblasNoTrans, + 2, 0, ALPHA, A, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_dsyrk( CblasColMajor, CblasUpper, CblasTrans, + 2, 0, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_dsyrk( CblasColMajor, CblasLower, CblasNoTrans, + 2, 0, ALPHA, A, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_dsyrk( CblasColMajor, CblasLower, CblasTrans, + 2, 0, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_dsyr2k" ,12)==0) { + cblas_rout = "cblas_dsyr2k" ; + + cblas_info = 1; + cblas_dsyr2k( INVALID, CblasUpper, CblasNoTrans, + 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dsyr2k( CblasColMajor, INVALID, CblasNoTrans, + 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dsyr2k( CblasColMajor, CblasUpper, INVALID, + 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dsyr2k( CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dsyr2k( CblasColMajor, CblasUpper, CblasTrans, + INVALID, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dsyr2k( CblasColMajor, CblasLower, CblasNoTrans, + INVALID, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dsyr2k( CblasColMajor, CblasLower, CblasTrans, + INVALID, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dsyr2k( CblasColMajor, CblasUpper, CblasNoTrans, + 0, INVALID, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dsyr2k( CblasColMajor, CblasUpper, CblasTrans, + 0, INVALID, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dsyr2k( CblasColMajor, CblasLower, CblasNoTrans, + 0, INVALID, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dsyr2k( CblasColMajor, CblasLower, CblasTrans, + 0, INVALID, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dsyr2k( CblasRowMajor, CblasUpper, CblasNoTrans, + 0, 2, ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dsyr2k( CblasRowMajor, CblasUpper, CblasTrans, + 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dsyr2k( CblasRowMajor, CblasLower, CblasNoTrans, + 0, 2, ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dsyr2k( CblasRowMajor, CblasLower, CblasTrans, + 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dsyr2k( CblasColMajor, CblasUpper, CblasNoTrans, + 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dsyr2k( CblasColMajor, CblasUpper, CblasTrans, + 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dsyr2k( CblasColMajor, CblasLower, CblasNoTrans, + 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dsyr2k( CblasColMajor, CblasLower, CblasTrans, + 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dsyr2k( CblasRowMajor, CblasUpper, CblasNoTrans, + 0, 2, ALPHA, A, 2, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dsyr2k( CblasRowMajor, CblasUpper, CblasTrans, + 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dsyr2k( CblasRowMajor, CblasLower, CblasNoTrans, + 0, 2, ALPHA, A, 2, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dsyr2k( CblasRowMajor, CblasLower, CblasTrans, + 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dsyr2k( CblasColMajor, CblasUpper, CblasNoTrans, + 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dsyr2k( CblasColMajor, CblasUpper, CblasTrans, + 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dsyr2k( CblasColMajor, CblasLower, CblasNoTrans, + 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dsyr2k( CblasColMajor, CblasLower, CblasTrans, + 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_dsyr2k( CblasRowMajor, CblasUpper, CblasNoTrans, + 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_dsyr2k( CblasRowMajor, CblasUpper, CblasTrans, + 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_dsyr2k( CblasRowMajor, CblasLower, CblasNoTrans, + 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_dsyr2k( CblasRowMajor, CblasLower, CblasTrans, + 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_dsyr2k( CblasColMajor, CblasUpper, CblasNoTrans, + 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_dsyr2k( CblasColMajor, CblasUpper, CblasTrans, + 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_dsyr2k( CblasColMajor, CblasLower, CblasNoTrans, + 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_dsyr2k( CblasColMajor, CblasLower, CblasTrans, + 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + } + if (cblas_ok == TRUE ) + printf(" %-12s PASSED THE TESTS OF ERROR-EXITS\n", cblas_rout); + else + printf("***** %s FAILED THE TESTS OF ERROR-EXITS *******\n",cblas_rout); +} diff --git a/cblas/testing/c_dblas1.c b/cblas/testing/c_dblas1.c new file mode 100644 index 00000000..616c4989 --- /dev/null +++ b/cblas/testing/c_dblas1.c @@ -0,0 +1,83 @@ +/* + * c_dblas1.c + * + * The program is a C wrapper for dcblat1. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas_test.h" +#include "cblas.h" +double F77_dasum(const int *N, double *X, const int *incX) +{ + return cblas_dasum(*N, X, *incX); +} + +void F77_daxpy(const int *N, const double *alpha, const double *X, + const int *incX, double *Y, const int *incY) +{ + cblas_daxpy(*N, *alpha, X, *incX, Y, *incY); + return; +} + +void F77_dcopy(const int *N, double *X, const int *incX, + double *Y, const int *incY) +{ + cblas_dcopy(*N, X, *incX, Y, *incY); + return; +} + +double F77_ddot(const int *N, const double *X, const int *incX, + const double *Y, const int *incY) +{ + return cblas_ddot(*N, X, *incX, Y, *incY); +} + +double F77_dnrm2(const int *N, const double *X, const int *incX) +{ + return cblas_dnrm2(*N, X, *incX); +} + +void F77_drotg( double *a, double *b, double *c, double *s) +{ + cblas_drotg(a,b,c,s); + return; +} + +void F77_drot( const int *N, double *X, const int *incX, double *Y, + const int *incY, const double *c, const double *s) +{ + + cblas_drot(*N,X,*incX,Y,*incY,*c,*s); + return; +} + +void F77_dscal(const int *N, const double *alpha, double *X, + const int *incX) +{ + cblas_dscal(*N, *alpha, X, *incX); + return; +} + +void F77_dswap( const int *N, double *X, const int *incX, + double *Y, const int *incY) +{ + cblas_dswap(*N,X,*incX,Y,*incY); + return; +} + +double F77_dzasum(const int *N, void *X, const int *incX) +{ + return cblas_dzasum(*N, X, *incX); +} + +double F77_dznrm2(const int *N, const void *X, const int *incX) +{ + return cblas_dznrm2(*N, X, *incX); +} + +int F77_idamax(const int *N, const double *X, const int *incX) +{ + if (*N < 1 || *incX < 1) return(0); + return (cblas_idamax(*N, X, *incX)+1); +} diff --git a/cblas/testing/c_dblas2.c b/cblas/testing/c_dblas2.c new file mode 100644 index 00000000..eeaf88e6 --- /dev/null +++ b/cblas/testing/c_dblas2.c @@ -0,0 +1,583 @@ +/* + * Written by D.P. Manley, Digital Equipment Corporation. + * Prefixed "C_" to BLAS routines and their declarations. + * + * Modified by T. H. Do, 1/23/98, SGI/CRAY Research. + */ +#include <stdlib.h> +#include "cblas.h" +#include "cblas_test.h" + +void F77_dgemv(int *layout, char *transp, int *m, int *n, double *alpha, + double *a, int *lda, double *x, int *incx, double *beta, + double *y, int *incy ) { + + double *A; + int i,j,LDA; + CBLAS_TRANSPOSE trans; + + get_transpose_type(transp, &trans); + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A = ( double* )malloc( (*m)*LDA*sizeof( double ) ); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ) + A[ LDA*i+j ]=a[ (*lda)*j+i ]; + cblas_dgemv( CblasRowMajor, trans, + *m, *n, *alpha, A, LDA, x, *incx, *beta, y, *incy ); + free(A); + } + else if (*layout == TEST_COL_MJR) + cblas_dgemv( CblasColMajor, trans, + *m, *n, *alpha, a, *lda, x, *incx, *beta, y, *incy ); + else + cblas_dgemv( UNDEFINED, trans, + *m, *n, *alpha, a, *lda, x, *incx, *beta, y, *incy ); +} + +void F77_dger(int *layout, int *m, int *n, double *alpha, double *x, int *incx, + double *y, int *incy, double *a, int *lda ) { + + double *A; + int i,j,LDA; + + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A = ( double* )malloc( (*m)*LDA*sizeof( double ) ); + + for( i=0; i<*m; i++ ) { + for( j=0; j<*n; j++ ) + A[ LDA*i+j ]=a[ (*lda)*j+i ]; + } + + cblas_dger(CblasRowMajor, *m, *n, *alpha, x, *incx, y, *incy, A, LDA ); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ) + a[ (*lda)*j+i ]=A[ LDA*i+j ]; + free(A); + } + else + cblas_dger( CblasColMajor, *m, *n, *alpha, x, *incx, y, *incy, a, *lda ); +} + +void F77_dtrmv(int *layout, char *uplow, char *transp, char *diagn, + int *n, double *a, int *lda, double *x, int *incx) { + double *A; + int i,j,LDA; + CBLAS_TRANSPOSE trans; + CBLAS_UPLO uplo; + CBLAS_DIAG diag; + + get_transpose_type(transp,&trans); + get_uplo_type(uplow,&uplo); + get_diag_type(diagn,&diag); + + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A = ( double* )malloc( (*n)*LDA*sizeof( double ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + A[ LDA*i+j ]=a[ (*lda)*j+i ]; + cblas_dtrmv(CblasRowMajor, uplo, trans, diag, *n, A, LDA, x, *incx); + free(A); + } + else if (*layout == TEST_COL_MJR) + cblas_dtrmv(CblasColMajor, uplo, trans, diag, *n, a, *lda, x, *incx); + else { + cblas_dtrmv(UNDEFINED, uplo, trans, diag, *n, a, *lda, x, *incx); + } +} + +void F77_dtrsv(int *layout, char *uplow, char *transp, char *diagn, + int *n, double *a, int *lda, double *x, int *incx ) { + double *A; + int i,j,LDA; + CBLAS_TRANSPOSE trans; + CBLAS_UPLO uplo; + CBLAS_DIAG diag; + + get_transpose_type(transp,&trans); + get_uplo_type(uplow,&uplo); + get_diag_type(diagn,&diag); + + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A = ( double* )malloc( (*n)*LDA*sizeof( double ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + A[ LDA*i+j ]=a[ (*lda)*j+i ]; + cblas_dtrsv(CblasRowMajor, uplo, trans, diag, *n, A, LDA, x, *incx ); + free(A); + } + else + cblas_dtrsv(CblasColMajor, uplo, trans, diag, *n, a, *lda, x, *incx ); +} +void F77_dsymv(int *layout, char *uplow, int *n, double *alpha, double *a, + int *lda, double *x, int *incx, double *beta, double *y, + int *incy) { + double *A; + int i,j,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A = ( double* )malloc( (*n)*LDA*sizeof( double ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + A[ LDA*i+j ]=a[ (*lda)*j+i ]; + cblas_dsymv(CblasRowMajor, uplo, *n, *alpha, A, LDA, x, *incx, + *beta, y, *incy ); + free(A); + } + else + cblas_dsymv(CblasColMajor, uplo, *n, *alpha, a, *lda, x, *incx, + *beta, y, *incy ); +} + +void F77_dsyr(int *layout, char *uplow, int *n, double *alpha, double *x, + int *incx, double *a, int *lda) { + double *A; + int i,j,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A = ( double* )malloc( (*n)*LDA*sizeof( double ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + A[ LDA*i+j ]=a[ (*lda)*j+i ]; + cblas_dsyr(CblasRowMajor, uplo, *n, *alpha, x, *incx, A, LDA); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + a[ (*lda)*j+i ]=A[ LDA*i+j ]; + free(A); + } + else + cblas_dsyr(CblasColMajor, uplo, *n, *alpha, x, *incx, a, *lda); +} + +void F77_dsyr2(int *layout, char *uplow, int *n, double *alpha, double *x, + int *incx, double *y, int *incy, double *a, int *lda) { + double *A; + int i,j,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A = ( double* )malloc( (*n)*LDA*sizeof( double ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + A[ LDA*i+j ]=a[ (*lda)*j+i ]; + cblas_dsyr2(CblasRowMajor, uplo, *n, *alpha, x, *incx, y, *incy, A, LDA); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + a[ (*lda)*j+i ]=A[ LDA*i+j ]; + free(A); + } + else + cblas_dsyr2(CblasColMajor, uplo, *n, *alpha, x, *incx, y, *incy, a, *lda); +} + +void F77_dgbmv(int *layout, char *transp, int *m, int *n, int *kl, int *ku, + double *alpha, double *a, int *lda, double *x, int *incx, + double *beta, double *y, int *incy ) { + + double *A; + int i,irow,j,jcol,LDA; + CBLAS_TRANSPOSE trans; + + get_transpose_type(transp, &trans); + + if (*layout == TEST_ROW_MJR) { + LDA = *ku+*kl+2; + A = ( double* )malloc( (*n+*kl)*LDA*sizeof( double ) ); + for( i=0; i<*ku; i++ ){ + irow=*ku+*kl-i; + jcol=(*ku)-i; + for( j=jcol; j<*n; j++ ) + A[ LDA*(j-jcol)+irow ]=a[ (*lda)*j+i ]; + } + i=*ku; + irow=*ku+*kl-i; + for( j=0; j<*n; j++ ) + A[ LDA*j+irow ]=a[ (*lda)*j+i ]; + for( i=*ku+1; i<*ku+*kl+1; i++ ){ + irow=*ku+*kl-i; + jcol=i-(*ku); + for( j=jcol; j<(*n+*kl); j++ ) + A[ LDA*j+irow ]=a[ (*lda)*(j-jcol)+i ]; + } + cblas_dgbmv( CblasRowMajor, trans, *m, *n, *kl, *ku, *alpha, + A, LDA, x, *incx, *beta, y, *incy ); + free(A); + } + else + cblas_dgbmv( CblasColMajor, trans, *m, *n, *kl, *ku, *alpha, + a, *lda, x, *incx, *beta, y, *incy ); +} + +void F77_dtbmv(int *layout, char *uplow, char *transp, char *diagn, + int *n, int *k, double *a, int *lda, double *x, int *incx) { + double *A; + int irow, jcol, i, j, LDA; + CBLAS_TRANSPOSE trans; + CBLAS_UPLO uplo; + CBLAS_DIAG diag; + + get_transpose_type(transp,&trans); + get_uplo_type(uplow,&uplo); + get_diag_type(diagn,&diag); + + if (*layout == TEST_ROW_MJR) { + LDA = *k+1; + A = ( double* )malloc( (*n+*k)*LDA*sizeof( double ) ); + if (uplo == CblasUpper) { + for( i=0; i<*k; i++ ){ + irow=*k-i; + jcol=(*k)-i; + for( j=jcol; j<*n; j++ ) + A[ LDA*(j-jcol)+irow ]=a[ (*lda)*j+i ]; + } + i=*k; + irow=*k-i; + for( j=0; j<*n; j++ ) + A[ LDA*j+irow ]=a[ (*lda)*j+i ]; + } + else { + i=0; + irow=*k-i; + for( j=0; j<*n; j++ ) + A[ LDA*j+irow ]=a[ (*lda)*j+i ]; + for( i=1; i<*k+1; i++ ){ + irow=*k-i; + jcol=i; + for( j=jcol; j<(*n+*k); j++ ) + A[ LDA*j+irow ]=a[ (*lda)*(j-jcol)+i ]; + } + } + cblas_dtbmv(CblasRowMajor, uplo, trans, diag, *n, *k, A, LDA, x, *incx); + free(A); + } + else + cblas_dtbmv(CblasColMajor, uplo, trans, diag, *n, *k, a, *lda, x, *incx); +} + +void F77_dtbsv(int *layout, char *uplow, char *transp, char *diagn, + int *n, int *k, double *a, int *lda, double *x, int *incx) { + double *A; + int irow, jcol, i, j, LDA; + CBLAS_TRANSPOSE trans; + CBLAS_UPLO uplo; + CBLAS_DIAG diag; + + get_transpose_type(transp,&trans); + get_uplo_type(uplow,&uplo); + get_diag_type(diagn,&diag); + + if (*layout == TEST_ROW_MJR) { + LDA = *k+1; + A = ( double* )malloc( (*n+*k)*LDA*sizeof( double ) ); + if (uplo == CblasUpper) { + for( i=0; i<*k; i++ ){ + irow=*k-i; + jcol=(*k)-i; + for( j=jcol; j<*n; j++ ) + A[ LDA*(j-jcol)+irow ]=a[ (*lda)*j+i ]; + } + i=*k; + irow=*k-i; + for( j=0; j<*n; j++ ) + A[ LDA*j+irow ]=a[ (*lda)*j+i ]; + } + else { + i=0; + irow=*k-i; + for( j=0; j<*n; j++ ) + A[ LDA*j+irow ]=a[ (*lda)*j+i ]; + for( i=1; i<*k+1; i++ ){ + irow=*k-i; + jcol=i; + for( j=jcol; j<(*n+*k); j++ ) + A[ LDA*j+irow ]=a[ (*lda)*(j-jcol)+i ]; + } + } + cblas_dtbsv(CblasRowMajor, uplo, trans, diag, *n, *k, A, LDA, x, *incx); + free(A); + } + else + cblas_dtbsv(CblasColMajor, uplo, trans, diag, *n, *k, a, *lda, x, *incx); +} + +void F77_dsbmv(int *layout, char *uplow, int *n, int *k, double *alpha, + double *a, int *lda, double *x, int *incx, double *beta, + double *y, int *incy) { + double *A; + int i,j,irow,jcol,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + LDA = *k+1; + A = ( double* )malloc( (*n+*k)*LDA*sizeof( double ) ); + if (uplo == CblasUpper) { + for( i=0; i<*k; i++ ){ + irow=*k-i; + jcol=(*k)-i; + for( j=jcol; j<*n; j++ ) + A[ LDA*(j-jcol)+irow ]=a[ (*lda)*j+i ]; + } + i=*k; + irow=*k-i; + for( j=0; j<*n; j++ ) + A[ LDA*j+irow ]=a[ (*lda)*j+i ]; + } + else { + i=0; + irow=*k-i; + for( j=0; j<*n; j++ ) + A[ LDA*j+irow ]=a[ (*lda)*j+i ]; + for( i=1; i<*k+1; i++ ){ + irow=*k-i; + jcol=i; + for( j=jcol; j<(*n+*k); j++ ) + A[ LDA*j+irow ]=a[ (*lda)*(j-jcol)+i ]; + } + } + cblas_dsbmv(CblasRowMajor, uplo, *n, *k, *alpha, A, LDA, x, *incx, + *beta, y, *incy ); + free(A); + } + else + cblas_dsbmv(CblasColMajor, uplo, *n, *k, *alpha, a, *lda, x, *incx, + *beta, y, *incy ); +} + +void F77_dspmv(int *layout, char *uplow, int *n, double *alpha, double *ap, + double *x, int *incx, double *beta, double *y, int *incy) { + double *A,*AP; + int i,j,k,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + LDA = *n; + A = ( double* )malloc( LDA*LDA*sizeof( double ) ); + AP = ( double* )malloc( (((LDA+1)*LDA)/2)*sizeof( double ) ); + if (uplo == CblasUpper) { + for( j=0, k=0; j<*n; j++ ) + for( i=0; i<j+1; i++, k++ ) + A[ LDA*i+j ]=ap[ k ]; + for( i=0, k=0; i<*n; i++ ) + for( j=i; j<*n; j++, k++ ) + AP[ k ]=A[ LDA*i+j ]; + } + else { + for( j=0, k=0; j<*n; j++ ) + for( i=j; i<*n; i++, k++ ) + A[ LDA*i+j ]=ap[ k ]; + for( i=0, k=0; i<*n; i++ ) + for( j=0; j<i+1; j++, k++ ) + AP[ k ]=A[ LDA*i+j ]; + } + cblas_dspmv( CblasRowMajor, uplo, *n, *alpha, AP, x, *incx, *beta, y, + *incy ); + free(A); + free(AP); + } + else + cblas_dspmv( CblasColMajor, uplo, *n, *alpha, ap, x, *incx, *beta, y, + *incy ); +} + +void F77_dtpmv(int *layout, char *uplow, char *transp, char *diagn, + int *n, double *ap, double *x, int *incx) { + double *A, *AP; + int i, j, k, LDA; + CBLAS_TRANSPOSE trans; + CBLAS_UPLO uplo; + CBLAS_DIAG diag; + + get_transpose_type(transp,&trans); + get_uplo_type(uplow,&uplo); + get_diag_type(diagn,&diag); + + if (*layout == TEST_ROW_MJR) { + LDA = *n; + A = ( double* )malloc( LDA*LDA*sizeof( double ) ); + AP = ( double* )malloc( (((LDA+1)*LDA)/2)*sizeof( double ) ); + if (uplo == CblasUpper) { + for( j=0, k=0; j<*n; j++ ) + for( i=0; i<j+1; i++, k++ ) + A[ LDA*i+j ]=ap[ k ]; + for( i=0, k=0; i<*n; i++ ) + for( j=i; j<*n; j++, k++ ) + AP[ k ]=A[ LDA*i+j ]; + } + else { + for( j=0, k=0; j<*n; j++ ) + for( i=j; i<*n; i++, k++ ) + A[ LDA*i+j ]=ap[ k ]; + for( i=0, k=0; i<*n; i++ ) + for( j=0; j<i+1; j++, k++ ) + AP[ k ]=A[ LDA*i+j ]; + } + cblas_dtpmv( CblasRowMajor, uplo, trans, diag, *n, AP, x, *incx ); + free(A); + free(AP); + } + else + cblas_dtpmv( CblasColMajor, uplo, trans, diag, *n, ap, x, *incx ); +} + +void F77_dtpsv(int *layout, char *uplow, char *transp, char *diagn, + int *n, double *ap, double *x, int *incx) { + double *A, *AP; + int i, j, k, LDA; + CBLAS_TRANSPOSE trans; + CBLAS_UPLO uplo; + CBLAS_DIAG diag; + + get_transpose_type(transp,&trans); + get_uplo_type(uplow,&uplo); + get_diag_type(diagn,&diag); + + if (*layout == TEST_ROW_MJR) { + LDA = *n; + A = ( double* )malloc( LDA*LDA*sizeof( double ) ); + AP = ( double* )malloc( (((LDA+1)*LDA)/2)*sizeof( double ) ); + if (uplo == CblasUpper) { + for( j=0, k=0; j<*n; j++ ) + for( i=0; i<j+1; i++, k++ ) + A[ LDA*i+j ]=ap[ k ]; + for( i=0, k=0; i<*n; i++ ) + for( j=i; j<*n; j++, k++ ) + AP[ k ]=A[ LDA*i+j ]; + + } + else { + for( j=0, k=0; j<*n; j++ ) + for( i=j; i<*n; i++, k++ ) + A[ LDA*i+j ]=ap[ k ]; + for( i=0, k=0; i<*n; i++ ) + for( j=0; j<i+1; j++, k++ ) + AP[ k ]=A[ LDA*i+j ]; + } + cblas_dtpsv( CblasRowMajor, uplo, trans, diag, *n, AP, x, *incx ); + free(A); + free(AP); + } + else + cblas_dtpsv( CblasColMajor, uplo, trans, diag, *n, ap, x, *incx ); +} + +void F77_dspr(int *layout, char *uplow, int *n, double *alpha, double *x, + int *incx, double *ap ){ + double *A, *AP; + int i,j,k,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + LDA = *n; + A = ( double* )malloc( LDA*LDA*sizeof( double ) ); + AP = ( double* )malloc( (((LDA+1)*LDA)/2)*sizeof( double ) ); + if (uplo == CblasUpper) { + for( j=0, k=0; j<*n; j++ ) + for( i=0; i<j+1; i++, k++ ) + A[ LDA*i+j ]=ap[ k ]; + for( i=0, k=0; i<*n; i++ ) + for( j=i; j<*n; j++, k++ ) + AP[ k ]=A[ LDA*i+j ]; + } + else { + for( j=0, k=0; j<*n; j++ ) + for( i=j; i<*n; i++, k++ ) + A[ LDA*i+j ]=ap[ k ]; + for( i=0, k=0; i<*n; i++ ) + for( j=0; j<i+1; j++, k++ ) + AP[ k ]=A[ LDA*i+j ]; + } + cblas_dspr( CblasRowMajor, uplo, *n, *alpha, x, *incx, AP ); + if (uplo == CblasUpper) { + for( i=0, k=0; i<*n; i++ ) + for( j=i; j<*n; j++, k++ ) + A[ LDA*i+j ]=AP[ k ]; + for( j=0, k=0; j<*n; j++ ) + for( i=0; i<j+1; i++, k++ ) + ap[ k ]=A[ LDA*i+j ]; + } + else { + for( i=0, k=0; i<*n; i++ ) + for( j=0; j<i+1; j++, k++ ) + A[ LDA*i+j ]=AP[ k ]; + for( j=0, k=0; j<*n; j++ ) + for( i=j; i<*n; i++, k++ ) + ap[ k ]=A[ LDA*i+j ]; + } + free(A); + free(AP); + } + else + cblas_dspr( CblasColMajor, uplo, *n, *alpha, x, *incx, ap ); +} + +void F77_dspr2(int *layout, char *uplow, int *n, double *alpha, double *x, + int *incx, double *y, int *incy, double *ap ){ + double *A, *AP; + int i,j,k,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + LDA = *n; + A = ( double* )malloc( LDA*LDA*sizeof( double ) ); + AP = ( double* )malloc( (((LDA+1)*LDA)/2)*sizeof( double ) ); + if (uplo == CblasUpper) { + for( j=0, k=0; j<*n; j++ ) + for( i=0; i<j+1; i++, k++ ) + A[ LDA*i+j ]=ap[ k ]; + for( i=0, k=0; i<*n; i++ ) + for( j=i; j<*n; j++, k++ ) + AP[ k ]=A[ LDA*i+j ]; + } + else { + for( j=0, k=0; j<*n; j++ ) + for( i=j; i<*n; i++, k++ ) + A[ LDA*i+j ]=ap[ k ]; + for( i=0, k=0; i<*n; i++ ) + for( j=0; j<i+1; j++, k++ ) + AP[ k ]=A[ LDA*i+j ]; + } + cblas_dspr2( CblasRowMajor, uplo, *n, *alpha, x, *incx, y, *incy, AP ); + if (uplo == CblasUpper) { + for( i=0, k=0; i<*n; i++ ) + for( j=i; j<*n; j++, k++ ) + A[ LDA*i+j ]=AP[ k ]; + for( j=0, k=0; j<*n; j++ ) + for( i=0; i<j+1; i++, k++ ) + ap[ k ]=A[ LDA*i+j ]; + } + else { + for( i=0, k=0; i<*n; i++ ) + for( j=0; j<i+1; j++, k++ ) + A[ LDA*i+j ]=AP[ k ]; + for( j=0, k=0; j<*n; j++ ) + for( i=j; i<*n; i++, k++ ) + ap[ k ]=A[ LDA*i+j ]; + } + free(A); + free(AP); + } + else + cblas_dspr2( CblasColMajor, uplo, *n, *alpha, x, *incx, y, *incy, ap ); +} diff --git a/cblas/testing/c_dblas3.c b/cblas/testing/c_dblas3.c new file mode 100644 index 00000000..46ddc4a1 --- /dev/null +++ b/cblas/testing/c_dblas3.c @@ -0,0 +1,333 @@ +/* + * Written by D.P. Manley, Digital Equipment Corporation. + * Prefixed "C_" to BLAS routines and their declarations. + * + * Modified by T. H. Do, 2/19/98, SGI/CRAY Research. + */ +#include <stdlib.h> +#include "cblas.h" +#include "cblas_test.h" +#define TEST_COL_MJR 0 +#define TEST_ROW_MJR 1 +#define UNDEFINED -1 + +void F77_dgemm(int *layout, char *transpa, char *transpb, int *m, int *n, + int *k, double *alpha, double *a, int *lda, double *b, int *ldb, + double *beta, double *c, int *ldc ) { + + double *A, *B, *C; + int i,j,LDA, LDB, LDC; + CBLAS_TRANSPOSE transa, transb; + + get_transpose_type(transpa, &transa); + get_transpose_type(transpb, &transb); + + if (*layout == TEST_ROW_MJR) { + if (transa == CblasNoTrans) { + LDA = *k+1; + A = (double *)malloc( (*m)*LDA*sizeof( double ) ); + for( i=0; i<*m; i++ ) + for( j=0; j<*k; j++ ) + A[i*LDA+j]=a[j*(*lda)+i]; + } + else { + LDA = *m+1; + A = ( double* )malloc( LDA*(*k)*sizeof( double ) ); + for( i=0; i<*k; i++ ) + for( j=0; j<*m; j++ ) + A[i*LDA+j]=a[j*(*lda)+i]; + } + if (transb == CblasNoTrans) { + LDB = *n+1; + B = ( double* )malloc( (*k)*LDB*sizeof( double ) ); + for( i=0; i<*k; i++ ) + for( j=0; j<*n; j++ ) + B[i*LDB+j]=b[j*(*ldb)+i]; + } + else { + LDB = *k+1; + B = ( double* )malloc( LDB*(*n)*sizeof( double ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*k; j++ ) + B[i*LDB+j]=b[j*(*ldb)+i]; + } + LDC = *n+1; + C = ( double* )malloc( (*m)*LDC*sizeof( double ) ); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) + C[i*LDC+j]=c[j*(*ldc)+i]; + + cblas_dgemm( CblasRowMajor, transa, transb, *m, *n, *k, *alpha, A, LDA, + B, LDB, *beta, C, LDC ); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) + c[j*(*ldc)+i]=C[i*LDC+j]; + free(A); + free(B); + free(C); + } + else if (*layout == TEST_COL_MJR) + cblas_dgemm( CblasColMajor, transa, transb, *m, *n, *k, *alpha, a, *lda, + b, *ldb, *beta, c, *ldc ); + else + cblas_dgemm( UNDEFINED, transa, transb, *m, *n, *k, *alpha, a, *lda, + b, *ldb, *beta, c, *ldc ); +} +void F77_dsymm(int *layout, char *rtlf, char *uplow, int *m, int *n, + double *alpha, double *a, int *lda, double *b, int *ldb, + double *beta, double *c, int *ldc ) { + + double *A, *B, *C; + int i,j,LDA, LDB, LDC; + CBLAS_UPLO uplo; + CBLAS_SIDE side; + + get_uplo_type(uplow,&uplo); + get_side_type(rtlf,&side); + + if (*layout == TEST_ROW_MJR) { + if (side == CblasLeft) { + LDA = *m+1; + A = ( double* )malloc( (*m)*LDA*sizeof( double ) ); + for( i=0; i<*m; i++ ) + for( j=0; j<*m; j++ ) + A[i*LDA+j]=a[j*(*lda)+i]; + } + else{ + LDA = *n+1; + A = ( double* )malloc( (*n)*LDA*sizeof( double ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + A[i*LDA+j]=a[j*(*lda)+i]; + } + LDB = *n+1; + B = ( double* )malloc( (*m)*LDB*sizeof( double ) ); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ) + B[i*LDB+j]=b[j*(*ldb)+i]; + LDC = *n+1; + C = ( double* )malloc( (*m)*LDC*sizeof( double ) ); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) + C[i*LDC+j]=c[j*(*ldc)+i]; + cblas_dsymm( CblasRowMajor, side, uplo, *m, *n, *alpha, A, LDA, B, LDB, + *beta, C, LDC ); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) + c[j*(*ldc)+i]=C[i*LDC+j]; + free(A); + free(B); + free(C); + } + else if (*layout == TEST_COL_MJR) + cblas_dsymm( CblasColMajor, side, uplo, *m, *n, *alpha, a, *lda, b, *ldb, + *beta, c, *ldc ); + else + cblas_dsymm( UNDEFINED, side, uplo, *m, *n, *alpha, a, *lda, b, *ldb, + *beta, c, *ldc ); +} + +void F77_dsyrk(int *layout, char *uplow, char *transp, int *n, int *k, + double *alpha, double *a, int *lda, + double *beta, double *c, int *ldc ) { + + int i,j,LDA,LDC; + double *A, *C; + CBLAS_UPLO uplo; + CBLAS_TRANSPOSE trans; + + get_uplo_type(uplow,&uplo); + get_transpose_type(transp,&trans); + + if (*layout == TEST_ROW_MJR) { + if (trans == CblasNoTrans) { + LDA = *k+1; + A = ( double* )malloc( (*n)*LDA*sizeof( double ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*k; j++ ) + A[i*LDA+j]=a[j*(*lda)+i]; + } + else{ + LDA = *n+1; + A = ( double* )malloc( (*k)*LDA*sizeof( double ) ); + for( i=0; i<*k; i++ ) + for( j=0; j<*n; j++ ) + A[i*LDA+j]=a[j*(*lda)+i]; + } + LDC = *n+1; + C = ( double* )malloc( (*n)*LDC*sizeof( double ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + C[i*LDC+j]=c[j*(*ldc)+i]; + cblas_dsyrk(CblasRowMajor, uplo, trans, *n, *k, *alpha, A, LDA, *beta, + C, LDC ); + for( j=0; j<*n; j++ ) + for( i=0; i<*n; i++ ) + c[j*(*ldc)+i]=C[i*LDC+j]; + free(A); + free(C); + } + else if (*layout == TEST_COL_MJR) + cblas_dsyrk(CblasColMajor, uplo, trans, *n, *k, *alpha, a, *lda, *beta, + c, *ldc ); + else + cblas_dsyrk(UNDEFINED, uplo, trans, *n, *k, *alpha, a, *lda, *beta, + c, *ldc ); +} + +void F77_dsyr2k(int *layout, char *uplow, char *transp, int *n, int *k, + double *alpha, double *a, int *lda, double *b, int *ldb, + double *beta, double *c, int *ldc ) { + int i,j,LDA,LDB,LDC; + double *A, *B, *C; + CBLAS_UPLO uplo; + CBLAS_TRANSPOSE trans; + + get_uplo_type(uplow,&uplo); + get_transpose_type(transp,&trans); + + if (*layout == TEST_ROW_MJR) { + if (trans == CblasNoTrans) { + LDA = *k+1; + LDB = *k+1; + A = ( double* )malloc( (*n)*LDA*sizeof( double ) ); + B = ( double* )malloc( (*n)*LDB*sizeof( double ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*k; j++ ) { + A[i*LDA+j]=a[j*(*lda)+i]; + B[i*LDB+j]=b[j*(*ldb)+i]; + } + } + else { + LDA = *n+1; + LDB = *n+1; + A = ( double* )malloc( LDA*(*k)*sizeof( double ) ); + B = ( double* )malloc( LDB*(*k)*sizeof( double ) ); + for( i=0; i<*k; i++ ) + for( j=0; j<*n; j++ ){ + A[i*LDA+j]=a[j*(*lda)+i]; + B[i*LDB+j]=b[j*(*ldb)+i]; + } + } + LDC = *n+1; + C = ( double* )malloc( (*n)*LDC*sizeof( double ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + C[i*LDC+j]=c[j*(*ldc)+i]; + cblas_dsyr2k(CblasRowMajor, uplo, trans, *n, *k, *alpha, A, LDA, + B, LDB, *beta, C, LDC ); + for( j=0; j<*n; j++ ) + for( i=0; i<*n; i++ ) + c[j*(*ldc)+i]=C[i*LDC+j]; + free(A); + free(B); + free(C); + } + else if (*layout == TEST_COL_MJR) + cblas_dsyr2k(CblasColMajor, uplo, trans, *n, *k, *alpha, a, *lda, + b, *ldb, *beta, c, *ldc ); + else + cblas_dsyr2k(UNDEFINED, uplo, trans, *n, *k, *alpha, a, *lda, + b, *ldb, *beta, c, *ldc ); +} +void F77_dtrmm(int *layout, char *rtlf, char *uplow, char *transp, char *diagn, + int *m, int *n, double *alpha, double *a, int *lda, double *b, + int *ldb) { + int i,j,LDA,LDB; + double *A, *B; + CBLAS_SIDE side; + CBLAS_DIAG diag; + CBLAS_UPLO uplo; + CBLAS_TRANSPOSE trans; + + get_uplo_type(uplow,&uplo); + get_transpose_type(transp,&trans); + get_diag_type(diagn,&diag); + get_side_type(rtlf,&side); + + if (*layout == TEST_ROW_MJR) { + if (side == CblasLeft) { + LDA = *m+1; + A = ( double* )malloc( (*m)*LDA*sizeof( double ) ); + for( i=0; i<*m; i++ ) + for( j=0; j<*m; j++ ) + A[i*LDA+j]=a[j*(*lda)+i]; + } + else{ + LDA = *n+1; + A = ( double* )malloc( (*n)*LDA*sizeof( double ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + A[i*LDA+j]=a[j*(*lda)+i]; + } + LDB = *n+1; + B = ( double* )malloc( (*m)*LDB*sizeof( double ) ); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ) + B[i*LDB+j]=b[j*(*ldb)+i]; + cblas_dtrmm(CblasRowMajor, side, uplo, trans, diag, *m, *n, *alpha, + A, LDA, B, LDB ); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) + b[j*(*ldb)+i]=B[i*LDB+j]; + free(A); + free(B); + } + else if (*layout == TEST_COL_MJR) + cblas_dtrmm(CblasColMajor, side, uplo, trans, diag, *m, *n, *alpha, + a, *lda, b, *ldb); + else + cblas_dtrmm(UNDEFINED, side, uplo, trans, diag, *m, *n, *alpha, + a, *lda, b, *ldb); +} + +void F77_dtrsm(int *layout, char *rtlf, char *uplow, char *transp, char *diagn, + int *m, int *n, double *alpha, double *a, int *lda, double *b, + int *ldb) { + int i,j,LDA,LDB; + double *A, *B; + CBLAS_SIDE side; + CBLAS_DIAG diag; + CBLAS_UPLO uplo; + CBLAS_TRANSPOSE trans; + + get_uplo_type(uplow,&uplo); + get_transpose_type(transp,&trans); + get_diag_type(diagn,&diag); + get_side_type(rtlf,&side); + + if (*layout == TEST_ROW_MJR) { + if (side == CblasLeft) { + LDA = *m+1; + A = ( double* )malloc( (*m)*LDA*sizeof( double ) ); + for( i=0; i<*m; i++ ) + for( j=0; j<*m; j++ ) + A[i*LDA+j]=a[j*(*lda)+i]; + } + else{ + LDA = *n+1; + A = ( double* )malloc( (*n)*LDA*sizeof( double ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + A[i*LDA+j]=a[j*(*lda)+i]; + } + LDB = *n+1; + B = ( double* )malloc( (*m)*LDB*sizeof( double ) ); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ) + B[i*LDB+j]=b[j*(*ldb)+i]; + cblas_dtrsm(CblasRowMajor, side, uplo, trans, diag, *m, *n, *alpha, + A, LDA, B, LDB ); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) + b[j*(*ldb)+i]=B[i*LDB+j]; + free(A); + free(B); + } + else if (*layout == TEST_COL_MJR) + cblas_dtrsm(CblasColMajor, side, uplo, trans, diag, *m, *n, *alpha, + a, *lda, b, *ldb); + else + cblas_dtrsm(UNDEFINED, side, uplo, trans, diag, *m, *n, *alpha, + a, *lda, b, *ldb); +} diff --git a/cblas/testing/c_dblat1.f b/cblas/testing/c_dblat1.f new file mode 100644 index 00000000..63e1ed80 --- /dev/null +++ b/cblas/testing/c_dblat1.f @@ -0,0 +1,728 @@ + PROGRAM DCBLAT1 +* Test program for the DOUBLE PRECISION Level 1 CBLAS. +* Based upon the original CBLAS test routine together with: +* F06EAF Example Program Text +* .. Parameters .. + INTEGER NOUT + PARAMETER (NOUT=6) +* .. Scalars in Common .. + INTEGER ICASE, INCX, INCY, MODE, N + LOGICAL PASS +* .. Local Scalars .. + DOUBLE PRECISION SFAC + INTEGER IC +* .. External Subroutines .. + EXTERNAL CHECK0, CHECK1, CHECK2, CHECK3, HEADER +* .. Common blocks .. + COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS +* .. Data statements .. + DATA SFAC/9.765625D-4/ +* .. Executable Statements .. + WRITE (NOUT,99999) + DO 20 IC = 1, 10 + ICASE = IC + CALL HEADER +* +* .. Initialize PASS, INCX, INCY, and MODE for a new case. .. +* .. the value 9999 for INCX, INCY or MODE will appear in the .. +* .. detailed output, if any, for cases that do not involve .. +* .. these parameters .. +* + PASS = .TRUE. + INCX = 9999 + INCY = 9999 + MODE = 9999 + IF (ICASE.EQ.3) THEN + CALL CHECK0(SFAC) + ELSE IF (ICASE.EQ.7 .OR. ICASE.EQ.8 .OR. ICASE.EQ.9 .OR. + + ICASE.EQ.10) THEN + CALL CHECK1(SFAC) + ELSE IF (ICASE.EQ.1 .OR. ICASE.EQ.2 .OR. ICASE.EQ.5 .OR. + + ICASE.EQ.6) THEN + CALL CHECK2(SFAC) + ELSE IF (ICASE.EQ.4) THEN + CALL CHECK3(SFAC) + END IF +* -- Print + IF (PASS) WRITE (NOUT,99998) + 20 CONTINUE + STOP +* +99999 FORMAT (' Real CBLAS Test Program Results',/1X) +99998 FORMAT (' ----- PASS -----') + END + SUBROUTINE HEADER +* .. Parameters .. + INTEGER NOUT + PARAMETER (NOUT=6) +* .. Scalars in Common .. + INTEGER ICASE, INCX, INCY, MODE, N + LOGICAL PASS +* .. Local Arrays .. + CHARACTER*15 L(10) +* .. Common blocks .. + COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS +* .. Data statements .. + DATA L(1)/'CBLAS_DDOT'/ + DATA L(2)/'CBLAS_DAXPY '/ + DATA L(3)/'CBLAS_DROTG '/ + DATA L(4)/'CBLAS_DROT '/ + DATA L(5)/'CBLAS_DCOPY '/ + DATA L(6)/'CBLAS_DSWAP '/ + DATA L(7)/'CBLAS_DNRM2 '/ + DATA L(8)/'CBLAS_DASUM '/ + DATA L(9)/'CBLAS_DSCAL '/ + DATA L(10)/'CBLAS_IDAMAX'/ +* .. Executable Statements .. + WRITE (NOUT,99999) ICASE, L(ICASE) + RETURN +* +99999 FORMAT (/' Test of subprogram number',I3,9X,A15) + END + SUBROUTINE CHECK0(SFAC) +* .. Parameters .. + INTEGER NOUT + PARAMETER (NOUT=6) +* .. Scalar Arguments .. + DOUBLE PRECISION SFAC +* .. Scalars in Common .. + INTEGER ICASE, INCX, INCY, MODE, N + LOGICAL PASS +* .. Local Scalars .. + DOUBLE PRECISION SA, SB, SC, SS + INTEGER K +* .. Local Arrays .. + DOUBLE PRECISION DA1(8), DATRUE(8), DB1(8), DBTRUE(8), DC1(8), + + DS1(8) +* .. External Subroutines .. + EXTERNAL DROTGTEST, STEST1 +* .. Common blocks .. + COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS +* .. Data statements .. + DATA DA1/0.3D0, 0.4D0, -0.3D0, -0.4D0, -0.3D0, 0.0D0, + + 0.0D0, 1.0D0/ + DATA DB1/0.4D0, 0.3D0, 0.4D0, 0.3D0, -0.4D0, 0.0D0, + + 1.0D0, 0.0D0/ + DATA DC1/0.6D0, 0.8D0, -0.6D0, 0.8D0, 0.6D0, 1.0D0, + + 0.0D0, 1.0D0/ + DATA DS1/0.8D0, 0.6D0, 0.8D0, -0.6D0, 0.8D0, 0.0D0, + + 1.0D0, 0.0D0/ + DATA DATRUE/0.5D0, 0.5D0, 0.5D0, -0.5D0, -0.5D0, + + 0.0D0, 1.0D0, 1.0D0/ + DATA DBTRUE/0.0D0, 0.6D0, 0.0D0, -0.6D0, 0.0D0, + + 0.0D0, 1.0D0, 0.0D0/ +* .. Executable Statements .. +* +* Compute true values which cannot be prestored +* in decimal notation +* + DBTRUE(1) = 1.0D0/0.6D0 + DBTRUE(3) = -1.0D0/0.6D0 + DBTRUE(5) = 1.0D0/0.6D0 +* + DO 20 K = 1, 8 +* .. Set N=K for identification in output if any .. + N = K + IF (ICASE.EQ.3) THEN +* .. DROTGTEST .. + IF (K.GT.8) GO TO 40 + SA = DA1(K) + SB = DB1(K) + CALL DROTGTEST(SA,SB,SC,SS) + CALL STEST1(SA,DATRUE(K),DATRUE(K),SFAC) + CALL STEST1(SB,DBTRUE(K),DBTRUE(K),SFAC) + CALL STEST1(SC,DC1(K),DC1(K),SFAC) + CALL STEST1(SS,DS1(K),DS1(K),SFAC) + ELSE + WRITE (NOUT,*) ' Shouldn''t be here in CHECK0' + STOP + END IF + 20 CONTINUE + 40 RETURN + END + SUBROUTINE CHECK1(SFAC) +* .. Parameters .. + INTEGER NOUT + PARAMETER (NOUT=6) +* .. Scalar Arguments .. + DOUBLE PRECISION SFAC +* .. Scalars in Common .. + INTEGER ICASE, INCX, INCY, MODE, N + LOGICAL PASS +* .. Local Scalars .. + INTEGER I, LEN, NP1 +* .. Local Arrays .. + DOUBLE PRECISION DTRUE1(5), DTRUE3(5), DTRUE5(8,5,2), DV(8,5,2), + + SA(10), STEMP(1), STRUE(8), SX(8) + INTEGER ITRUE2(5) +* .. External Functions .. + DOUBLE PRECISION DASUMTEST, DNRM2TEST + INTEGER IDAMAXTEST + EXTERNAL DASUMTEST, DNRM2TEST, IDAMAXTEST +* .. External Subroutines .. + EXTERNAL ITEST1, DSCALTEST, STEST, STEST1 +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Common blocks .. + COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS +* .. Data statements .. + DATA SA/0.3D0, -1.0D0, 0.0D0, 1.0D0, 0.3D0, 0.3D0, + + 0.3D0, 0.3D0, 0.3D0, 0.3D0/ + DATA DV/0.1D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0, + + 2.0D0, 2.0D0, 0.3D0, 3.0D0, 3.0D0, 3.0D0, 3.0D0, + + 3.0D0, 3.0D0, 3.0D0, 0.3D0, -0.4D0, 4.0D0, + + 4.0D0, 4.0D0, 4.0D0, 4.0D0, 4.0D0, 0.2D0, + + -0.6D0, 0.3D0, 5.0D0, 5.0D0, 5.0D0, 5.0D0, + + 5.0D0, 0.1D0, -0.3D0, 0.5D0, -0.1D0, 6.0D0, + + 6.0D0, 6.0D0, 6.0D0, 0.1D0, 8.0D0, 8.0D0, 8.0D0, + + 8.0D0, 8.0D0, 8.0D0, 8.0D0, 0.3D0, 9.0D0, 9.0D0, + + 9.0D0, 9.0D0, 9.0D0, 9.0D0, 9.0D0, 0.3D0, 2.0D0, + + -0.4D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0, + + 0.2D0, 3.0D0, -0.6D0, 5.0D0, 0.3D0, 2.0D0, + + 2.0D0, 2.0D0, 0.1D0, 4.0D0, -0.3D0, 6.0D0, + + -0.5D0, 7.0D0, -0.1D0, 3.0D0/ + DATA DTRUE1/0.0D0, 0.3D0, 0.5D0, 0.7D0, 0.6D0/ + DATA DTRUE3/0.0D0, 0.3D0, 0.7D0, 1.1D0, 1.0D0/ + DATA DTRUE5/0.10D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0, + + 2.0D0, 2.0D0, 2.0D0, -0.3D0, 3.0D0, 3.0D0, + + 3.0D0, 3.0D0, 3.0D0, 3.0D0, 3.0D0, 0.0D0, 0.0D0, + + 4.0D0, 4.0D0, 4.0D0, 4.0D0, 4.0D0, 4.0D0, + + 0.20D0, -0.60D0, 0.30D0, 5.0D0, 5.0D0, 5.0D0, + + 5.0D0, 5.0D0, 0.03D0, -0.09D0, 0.15D0, -0.03D0, + + 6.0D0, 6.0D0, 6.0D0, 6.0D0, 0.10D0, 8.0D0, + + 8.0D0, 8.0D0, 8.0D0, 8.0D0, 8.0D0, 8.0D0, + + 0.09D0, 9.0D0, 9.0D0, 9.0D0, 9.0D0, 9.0D0, + + 9.0D0, 9.0D0, 0.09D0, 2.0D0, -0.12D0, 2.0D0, + + 2.0D0, 2.0D0, 2.0D0, 2.0D0, 0.06D0, 3.0D0, + + -0.18D0, 5.0D0, 0.09D0, 2.0D0, 2.0D0, 2.0D0, + + 0.03D0, 4.0D0, -0.09D0, 6.0D0, -0.15D0, 7.0D0, + + -0.03D0, 3.0D0/ + DATA ITRUE2/0, 1, 2, 2, 3/ +* .. Executable Statements .. + DO 80 INCX = 1, 2 + DO 60 NP1 = 1, 5 + N = NP1 - 1 + LEN = 2*MAX(N,1) +* .. Set vector arguments .. + DO 20 I = 1, LEN + SX(I) = DV(I,NP1,INCX) + 20 CONTINUE +* + IF (ICASE.EQ.7) THEN +* .. DNRM2TEST .. + STEMP(1) = DTRUE1(NP1) + CALL STEST1(DNRM2TEST(N,SX,INCX),STEMP,STEMP,SFAC) + ELSE IF (ICASE.EQ.8) THEN +* .. DASUMTEST .. + STEMP(1) = DTRUE3(NP1) + CALL STEST1(DASUMTEST(N,SX,INCX),STEMP,STEMP,SFAC) + ELSE IF (ICASE.EQ.9) THEN +* .. DSCALTEST .. + CALL DSCALTEST(N,SA((INCX-1)*5+NP1),SX,INCX) + DO 40 I = 1, LEN + STRUE(I) = DTRUE5(I,NP1,INCX) + 40 CONTINUE + CALL STEST(LEN,SX,STRUE,STRUE,SFAC) + ELSE IF (ICASE.EQ.10) THEN +* .. IDAMAXTEST .. + CALL ITEST1(IDAMAXTEST(N,SX,INCX),ITRUE2(NP1)) + ELSE + WRITE (NOUT,*) ' Shouldn''t be here in CHECK1' + STOP + END IF + 60 CONTINUE + 80 CONTINUE + RETURN + END + SUBROUTINE CHECK2(SFAC) +* .. Parameters .. + INTEGER NOUT + PARAMETER (NOUT=6) +* .. Scalar Arguments .. + DOUBLE PRECISION SFAC +* .. Scalars in Common .. + INTEGER ICASE, INCX, INCY, MODE, N + LOGICAL PASS +* .. Local Scalars .. + DOUBLE PRECISION SA + INTEGER I, J, KI, KN, KSIZE, LENX, LENY, MX, MY +* .. Local Arrays .. + DOUBLE PRECISION DT10X(7,4,4), DT10Y(7,4,4), DT7(4,4), + + DT8(7,4,4), DX1(7), + + DY1(7), SSIZE1(4), SSIZE2(14,2), STX(7), STY(7), + + SX(7), SY(7) + INTEGER INCXS(4), INCYS(4), LENS(4,2), NS(4) +* .. External Functions .. + EXTERNAL DDOTTEST + DOUBLE PRECISION DDOTTEST +* .. External Subroutines .. + EXTERNAL DAXPYTEST, DCOPYTEST, DSWAPTEST, STEST, STEST1 +* .. Intrinsic Functions .. + INTRINSIC ABS, MIN +* .. Common blocks .. + COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS +* .. Data statements .. + DATA SA/0.3D0/ + DATA INCXS/1, 2, -2, -1/ + DATA INCYS/1, -2, 1, -2/ + DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/ + DATA NS/0, 1, 2, 4/ + DATA DX1/0.6D0, 0.1D0, -0.5D0, 0.8D0, 0.9D0, -0.3D0, + + -0.4D0/ + DATA DY1/0.5D0, -0.9D0, 0.3D0, 0.7D0, -0.6D0, 0.2D0, + + 0.8D0/ + DATA DT7/0.0D0, 0.30D0, 0.21D0, 0.62D0, 0.0D0, + + 0.30D0, -0.07D0, 0.85D0, 0.0D0, 0.30D0, -0.79D0, + + -0.74D0, 0.0D0, 0.30D0, 0.33D0, 1.27D0/ + DATA DT8/0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.68D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.0D0, 0.68D0, -0.87D0, 0.0D0, 0.0D0, + + 0.0D0, 0.0D0, 0.0D0, 0.68D0, -0.87D0, 0.15D0, + + 0.94D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0, 0.0D0, + + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.68D0, + + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.35D0, -0.9D0, 0.48D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.38D0, -0.9D0, 0.57D0, 0.7D0, -0.75D0, + + 0.2D0, 0.98D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.0D0, 0.0D0, 0.68D0, 0.0D0, 0.0D0, + + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.35D0, -0.72D0, + + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.38D0, + + -0.63D0, 0.15D0, 0.88D0, 0.0D0, 0.0D0, 0.0D0, + + 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.68D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.68D0, -0.9D0, 0.33D0, 0.0D0, 0.0D0, + + 0.0D0, 0.0D0, 0.68D0, -0.9D0, 0.33D0, 0.7D0, + + -0.75D0, 0.2D0, 1.04D0/ + DATA DT10X/0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.5D0, -0.9D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.0D0, 0.5D0, -0.9D0, 0.3D0, 0.7D0, + + 0.0D0, 0.0D0, 0.0D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.0D0, 0.0D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.0D0, 0.0D0, 0.3D0, 0.1D0, 0.5D0, 0.0D0, + + 0.0D0, 0.0D0, 0.0D0, 0.8D0, 0.1D0, -0.6D0, + + 0.8D0, 0.3D0, -0.3D0, 0.5D0, 0.6D0, 0.0D0, + + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0, 0.0D0, + + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, -0.9D0, + + 0.1D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.7D0, + + 0.1D0, 0.3D0, 0.8D0, -0.9D0, -0.3D0, 0.5D0, + + 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.5D0, 0.3D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.5D0, 0.3D0, -0.6D0, 0.8D0, 0.0D0, 0.0D0, + + 0.0D0/ + DATA DT10Y/0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.6D0, 0.1D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.6D0, 0.1D0, -0.5D0, 0.8D0, 0.0D0, + + 0.0D0, 0.0D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.0D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.0D0, -0.5D0, -0.9D0, 0.6D0, 0.0D0, + + 0.0D0, 0.0D0, 0.0D0, -0.4D0, -0.9D0, 0.9D0, + + 0.7D0, -0.5D0, 0.2D0, 0.6D0, 0.5D0, 0.0D0, + + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.6D0, 0.0D0, + + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, -0.5D0, + + 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + -0.4D0, 0.9D0, -0.5D0, 0.6D0, 0.0D0, 0.0D0, + + 0.0D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.6D0, -0.9D0, 0.1D0, 0.0D0, 0.0D0, + + 0.0D0, 0.0D0, 0.6D0, -0.9D0, 0.1D0, 0.7D0, + + -0.5D0, 0.2D0, 0.8D0/ + DATA SSIZE1/0.0D0, 0.3D0, 1.6D0, 3.2D0/ + DATA SSIZE2/0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0, + + 1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0, + + 1.17D0, 1.17D0, 1.17D0/ +* .. Executable Statements .. +* + DO 120 KI = 1, 4 + INCX = INCXS(KI) + INCY = INCYS(KI) + MX = ABS(INCX) + MY = ABS(INCY) +* + DO 100 KN = 1, 4 + N = NS(KN) + KSIZE = MIN(2,KN) + LENX = LENS(KN,MX) + LENY = LENS(KN,MY) +* .. Initialize all argument arrays .. + DO 20 I = 1, 7 + SX(I) = DX1(I) + SY(I) = DY1(I) + 20 CONTINUE +* + IF (ICASE.EQ.1) THEN +* .. DDOTTEST .. + CALL STEST1(DDOTTEST(N,SX,INCX,SY,INCY),DT7(KN,KI), + + SSIZE1(KN),SFAC) + ELSE IF (ICASE.EQ.2) THEN +* .. DAXPYTEST .. + CALL DAXPYTEST(N,SA,SX,INCX,SY,INCY) + DO 40 J = 1, LENY + STY(J) = DT8(J,KN,KI) + 40 CONTINUE + CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC) + ELSE IF (ICASE.EQ.5) THEN +* .. DCOPYTEST .. + DO 60 I = 1, 7 + STY(I) = DT10Y(I,KN,KI) + 60 CONTINUE + CALL DCOPYTEST(N,SX,INCX,SY,INCY) + CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0D0) + ELSE IF (ICASE.EQ.6) THEN +* .. DSWAPTEST .. + CALL DSWAPTEST(N,SX,INCX,SY,INCY) + DO 80 I = 1, 7 + STX(I) = DT10X(I,KN,KI) + STY(I) = DT10Y(I,KN,KI) + 80 CONTINUE + CALL STEST(LENX,SX,STX,SSIZE2(1,1),1.0D0) + CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0D0) + ELSE + WRITE (NOUT,*) ' Shouldn''t be here in CHECK2' + STOP + END IF + 100 CONTINUE + 120 CONTINUE + RETURN + END + SUBROUTINE CHECK3(SFAC) +* .. Parameters .. + INTEGER NOUT + PARAMETER (NOUT=6) +* .. Scalar Arguments .. + DOUBLE PRECISION SFAC +* .. Scalars in Common .. + INTEGER ICASE, INCX, INCY, MODE, N + LOGICAL PASS +* .. Local Scalars .. + DOUBLE PRECISION SC, SS + INTEGER I, K, KI, KN, KSIZE, LENX, LENY, MX, MY +* .. Local Arrays .. + DOUBLE PRECISION COPYX(5), COPYY(5), DT9X(7,4,4), DT9Y(7,4,4), + + DX1(7), DY1(7), MWPC(11), MWPS(11), MWPSTX(5), + + MWPSTY(5), MWPTX(11,5), MWPTY(11,5), MWPX(5), + + MWPY(5), SSIZE2(14,2), STX(7), STY(7), SX(7), + + SY(7) + INTEGER INCXS(4), INCYS(4), LENS(4,2), MWPINX(11), + + MWPINY(11), MWPN(11), NS(4) +* .. External Subroutines .. + EXTERNAL STEST,DROTTEST +* .. Intrinsic Functions .. + INTRINSIC ABS, MIN +* .. Common blocks .. + COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS +* .. Data statements .. + DATA INCXS/1, 2, -2, -1/ + DATA INCYS/1, -2, 1, -2/ + DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/ + DATA NS/0, 1, 2, 4/ + DATA DX1/0.6D0, 0.1D0, -0.5D0, 0.8D0, 0.9D0, -0.3D0, + + -0.4D0/ + DATA DY1/0.5D0, -0.9D0, 0.3D0, 0.7D0, -0.6D0, 0.2D0, + + 0.8D0/ + DATA SC, SS/0.8D0, 0.6D0/ + DATA DT9X/0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.78D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.0D0, 0.78D0, -0.46D0, 0.0D0, 0.0D0, + + 0.0D0, 0.0D0, 0.0D0, 0.78D0, -0.46D0, -0.22D0, + + 1.06D0, 0.0D0, 0.0D0, 0.0D0, 0.6D0, 0.0D0, + + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.78D0, + + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.66D0, 0.1D0, -0.1D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.96D0, 0.1D0, -0.76D0, 0.8D0, 0.90D0, + + -0.3D0, -0.02D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.0D0, 0.0D0, 0.78D0, 0.0D0, 0.0D0, + + 0.0D0, 0.0D0, 0.0D0, 0.0D0, -0.06D0, 0.1D0, + + -0.1D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.90D0, + + 0.1D0, -0.22D0, 0.8D0, 0.18D0, -0.3D0, -0.02D0, + + 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.78D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.78D0, 0.26D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.0D0, 0.78D0, 0.26D0, -0.76D0, 1.12D0, + + 0.0D0, 0.0D0, 0.0D0/ + DATA DT9Y/0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.04D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.0D0, 0.04D0, -0.78D0, 0.0D0, 0.0D0, + + 0.0D0, 0.0D0, 0.0D0, 0.04D0, -0.78D0, 0.54D0, + + 0.08D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0, 0.0D0, + + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.04D0, + + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.7D0, + + -0.9D0, -0.12D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.64D0, -0.9D0, -0.30D0, 0.7D0, -0.18D0, 0.2D0, + + 0.28D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.0D0, 0.04D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.0D0, 0.0D0, 0.7D0, -1.08D0, 0.0D0, + + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.64D0, -1.26D0, + + 0.54D0, 0.20D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0, + + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.04D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.04D0, -0.9D0, 0.18D0, 0.0D0, 0.0D0, + + 0.0D0, 0.0D0, 0.04D0, -0.9D0, 0.18D0, 0.7D0, + + -0.18D0, 0.2D0, 0.16D0/ + DATA SSIZE2/0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, + + 0.0D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0, + + 1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0, + + 1.17D0, 1.17D0, 1.17D0/ +* .. Executable Statements .. +* + DO 60 KI = 1, 4 + INCX = INCXS(KI) + INCY = INCYS(KI) + MX = ABS(INCX) + MY = ABS(INCY) +* + DO 40 KN = 1, 4 + N = NS(KN) + KSIZE = MIN(2,KN) + LENX = LENS(KN,MX) + LENY = LENS(KN,MY) +* + IF (ICASE.EQ.4) THEN +* .. DROTTEST .. + DO 20 I = 1, 7 + SX(I) = DX1(I) + SY(I) = DY1(I) + STX(I) = DT9X(I,KN,KI) + STY(I) = DT9Y(I,KN,KI) + 20 CONTINUE + CALL DROTTEST(N,SX,INCX,SY,INCY,SC,SS) + CALL STEST(LENX,SX,STX,SSIZE2(1,KSIZE),SFAC) + CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC) + ELSE + WRITE (NOUT,*) ' Shouldn''t be here in CHECK3' + STOP + END IF + 40 CONTINUE + 60 CONTINUE +* + MWPC(1) = 1 + DO 80 I = 2, 11 + MWPC(I) = 0 + 80 CONTINUE + MWPS(1) = 0.0 + DO 100 I = 2, 6 + MWPS(I) = 1.0 + 100 CONTINUE + DO 120 I = 7, 11 + MWPS(I) = -1.0 + 120 CONTINUE + MWPINX(1) = 1 + MWPINX(2) = 1 + MWPINX(3) = 1 + MWPINX(4) = -1 + MWPINX(5) = 1 + MWPINX(6) = -1 + MWPINX(7) = 1 + MWPINX(8) = 1 + MWPINX(9) = -1 + MWPINX(10) = 1 + MWPINX(11) = -1 + MWPINY(1) = 1 + MWPINY(2) = 1 + MWPINY(3) = -1 + MWPINY(4) = -1 + MWPINY(5) = 2 + MWPINY(6) = 1 + MWPINY(7) = 1 + MWPINY(8) = -1 + MWPINY(9) = -1 + MWPINY(10) = 2 + MWPINY(11) = 1 + DO 140 I = 1, 11 + MWPN(I) = 5 + 140 CONTINUE + MWPN(5) = 3 + MWPN(10) = 3 + DO 160 I = 1, 5 + MWPX(I) = I + MWPY(I) = I + MWPTX(1,I) = I + MWPTY(1,I) = I + MWPTX(2,I) = I + MWPTY(2,I) = -I + MWPTX(3,I) = 6 - I + MWPTY(3,I) = I - 6 + MWPTX(4,I) = I + MWPTY(4,I) = -I + MWPTX(6,I) = 6 - I + MWPTY(6,I) = I - 6 + MWPTX(7,I) = -I + MWPTY(7,I) = I + MWPTX(8,I) = I - 6 + MWPTY(8,I) = 6 - I + MWPTX(9,I) = -I + MWPTY(9,I) = I + MWPTX(11,I) = I - 6 + MWPTY(11,I) = 6 - I + 160 CONTINUE + MWPTX(5,1) = 1 + MWPTX(5,2) = 3 + MWPTX(5,3) = 5 + MWPTX(5,4) = 4 + MWPTX(5,5) = 5 + MWPTY(5,1) = -1 + MWPTY(5,2) = 2 + MWPTY(5,3) = -2 + MWPTY(5,4) = 4 + MWPTY(5,5) = -3 + MWPTX(10,1) = -1 + MWPTX(10,2) = -3 + MWPTX(10,3) = -5 + MWPTX(10,4) = 4 + MWPTX(10,5) = 5 + MWPTY(10,1) = 1 + MWPTY(10,2) = 2 + MWPTY(10,3) = 2 + MWPTY(10,4) = 4 + MWPTY(10,5) = 3 + DO 200 I = 1, 11 + INCX = MWPINX(I) + INCY = MWPINY(I) + DO 180 K = 1, 5 + COPYX(K) = MWPX(K) + COPYY(K) = MWPY(K) + MWPSTX(K) = MWPTX(I,K) + MWPSTY(K) = MWPTY(I,K) + 180 CONTINUE + CALL DROTTEST(MWPN(I),COPYX,INCX,COPYY,INCY,MWPC(I),MWPS(I)) + CALL STEST(5,COPYX,MWPSTX,MWPSTX,SFAC) + CALL STEST(5,COPYY,MWPSTY,MWPSTY,SFAC) + 200 CONTINUE + RETURN + END + SUBROUTINE STEST(LEN,SCOMP,STRUE,SSIZE,SFAC) +* ********************************* STEST ************************** +* +* THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO +* SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE +* NEGLIGIBLE. +* +* C. L. LAWSON, JPL, 1974 DEC 10 +* +* .. Parameters .. + INTEGER NOUT + PARAMETER (NOUT=6) +* .. Scalar Arguments .. + DOUBLE PRECISION SFAC + INTEGER LEN +* .. Array Arguments .. + DOUBLE PRECISION SCOMP(LEN), SSIZE(LEN), STRUE(LEN) +* .. Scalars in Common .. + INTEGER ICASE, INCX, INCY, MODE, N + LOGICAL PASS +* .. Local Scalars .. + DOUBLE PRECISION SD + INTEGER I +* .. External Functions .. + DOUBLE PRECISION SDIFF + EXTERNAL SDIFF +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. Common blocks .. + COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS +* .. Executable Statements .. +* + DO 40 I = 1, LEN + SD = SCOMP(I) - STRUE(I) + IF (SDIFF(ABS(SSIZE(I))+ABS(SFAC*SD),ABS(SSIZE(I))).EQ.0.0D0) + + GO TO 40 +* +* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I). +* + IF ( .NOT. PASS) GO TO 20 +* PRINT FAIL MESSAGE AND HEADER. + PASS = .FALSE. + WRITE (NOUT,99999) + WRITE (NOUT,99998) + 20 WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, I, SCOMP(I), + + STRUE(I), SD, SSIZE(I) + 40 CONTINUE + RETURN +* +99999 FORMAT (' FAIL') +99998 FORMAT (/' CASE N INCX INCY MODE I ', + + ' COMP(I) TRUE(I) DIFFERENCE', + + ' SIZE(I)',/1X) +99997 FORMAT (1X,I4,I3,3I5,I3,2D36.8,2D12.4) + END + SUBROUTINE STEST1(SCOMP1,STRUE1,SSIZE,SFAC) +* ************************* STEST1 ***************************** +* +* THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN +* REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE +* ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT. +* +* C.L. LAWSON, JPL, 1978 DEC 6 +* +* .. Scalar Arguments .. + DOUBLE PRECISION SCOMP1, SFAC, STRUE1 +* .. Array Arguments .. + DOUBLE PRECISION SSIZE(*) +* .. Local Arrays .. + DOUBLE PRECISION SCOMP(1), STRUE(1) +* .. External Subroutines .. + EXTERNAL STEST +* .. Executable Statements .. +* + SCOMP(1) = SCOMP1 + STRUE(1) = STRUE1 + CALL STEST(1,SCOMP,STRUE,SSIZE,SFAC) +* + RETURN + END + DOUBLE PRECISION FUNCTION SDIFF(SA,SB) +* ********************************* SDIFF ************************** +* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15 +* +* .. Scalar Arguments .. + DOUBLE PRECISION SA, SB +* .. Executable Statements .. + SDIFF = SA - SB + RETURN + END + SUBROUTINE ITEST1(ICOMP,ITRUE) +* ********************************* ITEST1 ************************* +* +* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR +* EQUALITY. +* C. L. LAWSON, JPL, 1974 DEC 10 +* +* .. Parameters .. + INTEGER NOUT + PARAMETER (NOUT=6) +* .. Scalar Arguments .. + INTEGER ICOMP, ITRUE +* .. Scalars in Common .. + INTEGER ICASE, INCX, INCY, MODE, N + LOGICAL PASS +* .. Local Scalars .. + INTEGER ID +* .. Common blocks .. + COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS +* .. Executable Statements .. +* + IF (ICOMP.EQ.ITRUE) GO TO 40 +* +* HERE ICOMP IS NOT EQUAL TO ITRUE. +* + IF ( .NOT. PASS) GO TO 20 +* PRINT FAIL MESSAGE AND HEADER. + PASS = .FALSE. + WRITE (NOUT,99999) + WRITE (NOUT,99998) + 20 ID = ICOMP - ITRUE + WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, ICOMP, ITRUE, ID + 40 CONTINUE + RETURN +* +99999 FORMAT (' FAIL') +99998 FORMAT (/' CASE N INCX INCY MODE ', + + ' COMP TRUE DIFFERENCE', + + /1X) +99997 FORMAT (1X,I4,I3,3I5,2I36,I12) + END diff --git a/cblas/testing/c_dblat2.f b/cblas/testing/c_dblat2.f new file mode 100644 index 00000000..357816bd --- /dev/null +++ b/cblas/testing/c_dblat2.f @@ -0,0 +1,2907 @@ + PROGRAM DBLAT2 +* +* Test program for the DOUBLE PRECISION Level 2 Blas. +* +* The program must be driven by a short data file. The first 17 records +* of the file are read using list-directed input, the last 16 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 33 lines: +* 'DBLAT2.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 +* 4 NUMBER OF VALUES OF K +* 0 1 2 4 VALUES OF K +* 4 NUMBER OF VALUES OF INCX AND INCY +* 1 2 -1 -2 VALUES OF INCX AND INCY +* 3 NUMBER OF VALUES OF ALPHA +* 0.0 1.0 0.7 VALUES OF ALPHA +* 3 NUMBER OF VALUES OF BETA +* 0.0 1.0 0.9 VALUES OF BETA +* cblas_dgemv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_dgbmv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_dsymv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_dsbmv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_dspmv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_dtrmv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_dtbmv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_dtpmv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_dtrsv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_dtbsv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_dtpsv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_dger T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_dsyr T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_dspr T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_dsyr2 T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_dspr2 T PUT F FOR NO TEST. SAME COLUMNS. +* +* See: +* +* Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J.. +* An extended set of Fortran Basic Linear Algebra Subprograms. +* +* Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics +* and Computer Science Division, Argonne National Laboratory, +* 9700 South Cass Avenue, Argonne, Illinois 60439, US. +* +* Or +* +* NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms +* Group Ltd., NAG Central Office, 256 Banbury Road, Oxford +* OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st +* Street, Suite 100, Downers Grove, Illinois 60515-1263, USA. +* +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + INTEGER NIN, NOUT + PARAMETER ( NIN = 5, NOUT = 6 ) + INTEGER NSUBS + PARAMETER ( NSUBS = 16 ) + DOUBLE PRECISION ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) + INTEGER NMAX, INCMAX + PARAMETER ( NMAX = 65, INCMAX = 2 ) + INTEGER NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX + PARAMETER ( NINMAX = 7, NIDMAX = 9, NKBMAX = 7, + $ NALMAX = 7, NBEMAX = 7 ) +* .. Local Scalars .. + DOUBLE PRECISION EPS, ERR, THRESH + INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB, + $ NTRA, LAYOUT + LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, + $ TSTERR, CORDER, RORDER + CHARACTER*1 TRANS + CHARACTER*12 SNAMET + CHARACTER*32 SNAPS +* .. Local Arrays .. + DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), + $ ALF( NALMAX ), AS( NMAX*NMAX ), BET( NBEMAX ), + $ G( NMAX ), X( NMAX ), XS( NMAX*INCMAX ), + $ XX( NMAX*INCMAX ), Y( NMAX ), + $ YS( NMAX*INCMAX ), YT( NMAX ), + $ YY( NMAX*INCMAX ), Z( 2*NMAX ) + INTEGER IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX ) + LOGICAL LTEST( NSUBS ) + CHARACTER*12 SNAMES( NSUBS ) +* .. External Functions .. + DOUBLE PRECISION DDIFF + LOGICAL LDE + EXTERNAL DDIFF, LDE +* .. External Subroutines .. + EXTERNAL DCHK1, DCHK2, DCHK3, DCHK4, DCHK5, DCHK6, + $ CD2CHKE, DMVCH +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK + CHARACTER*12 SRNAMT +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK + COMMON /SRNAMC/SRNAMT +* .. Data statements .. + DATA SNAMES/'cblas_dgemv ', 'cblas_dgbmv ', + $ 'cblas_dsymv ','cblas_dsbmv ','cblas_dspmv ', + $ 'cblas_dtrmv ','cblas_dtbmv ','cblas_dtpmv ', + $ 'cblas_dtrsv ','cblas_dtbsv ','cblas_dtpsv ', + $ 'cblas_dger ','cblas_dsyr ','cblas_dspr ', + $ 'cblas_dsyr2 ','cblas_dspr2 '/ +* .. Executable Statements .. +* + NOUTC = NOUT +* +* Read name and unit number for snapshot output file and open file. +* + READ( NIN, FMT = * )SNAPS + READ( NIN, FMT = * )NTRA + TRACE = NTRA.GE.0 + IF( TRACE )THEN + OPEN( NTRA, FILE = SNAPS ) + END IF +* Read the flag that directs rewinding of the snapshot file. + READ( NIN, FMT = * )REWI + REWI = REWI.AND.TRACE +* Read the flag that directs stopping on any failure. + READ( NIN, FMT = * )SFATAL +* Read the flag that indicates whether error exits are to be tested. + READ( NIN, FMT = * )TSTERR +* Read the flag that indicates whether row-major data layout to be tested. + READ( NIN, FMT = * )LAYOUT +* Read the threshold value of the test ratio + READ( NIN, FMT = * )THRESH +* +* Read and check the parameter values for the tests. +* +* Values of N + READ( NIN, FMT = * )NIDIM + IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN + WRITE( NOUT, FMT = 9997 )'N', NIDMAX + GO TO 230 + END IF + READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) + DO 10 I = 1, NIDIM + IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN + WRITE( NOUT, FMT = 9996 )NMAX + GO TO 230 + END IF + 10 CONTINUE +* Values of K + READ( NIN, FMT = * )NKB + IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN + WRITE( NOUT, FMT = 9997 )'K', NKBMAX + GO TO 230 + END IF + READ( NIN, FMT = * )( KB( I ), I = 1, NKB ) + DO 20 I = 1, NKB + IF( KB( I ).LT.0 )THEN + WRITE( NOUT, FMT = 9995 ) + GO TO 230 + END IF + 20 CONTINUE +* Values of INCX and INCY + READ( NIN, FMT = * )NINC + IF( NINC.LT.1.OR.NINC.GT.NINMAX )THEN + WRITE( NOUT, FMT = 9997 )'INCX AND INCY', NINMAX + GO TO 230 + END IF + READ( NIN, FMT = * )( INC( I ), I = 1, NINC ) + DO 30 I = 1, NINC + IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN + WRITE( NOUT, FMT = 9994 )INCMAX + GO TO 230 + END IF + 30 CONTINUE +* Values of ALPHA + READ( NIN, FMT = * )NALF + IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN + WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX + GO TO 230 + END IF + READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) +* Values of BETA + READ( NIN, FMT = * )NBET + IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN + WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX + GO TO 230 + END IF + READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) +* +* Report values of parameters. +* + WRITE( NOUT, FMT = 9993 ) + WRITE( NOUT, FMT = 9992 )( IDIM( I ), I = 1, NIDIM ) + WRITE( NOUT, FMT = 9991 )( KB( I ), I = 1, NKB ) + WRITE( NOUT, FMT = 9990 )( INC( I ), I = 1, NINC ) + WRITE( NOUT, FMT = 9989 )( ALF( I ), I = 1, NALF ) + WRITE( NOUT, FMT = 9988 )( BET( I ), I = 1, NBET ) + IF( .NOT.TSTERR )THEN + WRITE( NOUT, FMT = * ) + WRITE( NOUT, FMT = 9980 ) + END IF + WRITE( NOUT, FMT = * ) + WRITE( NOUT, FMT = 9999 )THRESH + WRITE( NOUT, FMT = * ) + + RORDER = .FALSE. + CORDER = .FALSE. + IF (LAYOUT.EQ.2) THEN + RORDER = .TRUE. + CORDER = .TRUE. + WRITE( *, FMT = 10002 ) + ELSE IF (LAYOUT.EQ.1) THEN + RORDER = .TRUE. + WRITE( *, FMT = 10001 ) + ELSE IF (LAYOUT.EQ.0) THEN + CORDER = .TRUE. + WRITE( *, FMT = 10000 ) + END IF + WRITE( *, FMT = * ) +* +* Read names of subroutines and flags which indicate +* whether they are to be tested. +* + DO 40 I = 1, NSUBS + LTEST( I ) = .FALSE. + 40 CONTINUE + 50 READ( NIN, FMT = 9984, END = 80 )SNAMET, LTESTT + DO 60 I = 1, NSUBS + IF( SNAMET.EQ.SNAMES( I ) ) + $ GO TO 70 + 60 CONTINUE + WRITE( NOUT, FMT = 9986 )SNAMET + STOP + 70 LTEST( I ) = LTESTT + GO TO 50 +* + 80 CONTINUE + CLOSE ( NIN ) +* +* Compute EPS (the machine precision). +* + EPS = ONE + 90 CONTINUE + IF( DDIFF( ONE + EPS, ONE ).EQ.ZERO ) + $ GO TO 100 + EPS = HALF*EPS + GO TO 90 + 100 CONTINUE + EPS = EPS + EPS + WRITE( NOUT, FMT = 9998 )EPS +* +* Check the reliability of DMVCH using exact data. +* + N = MIN( 32, NMAX ) + DO 120 J = 1, N + DO 110 I = 1, N + A( I, J ) = MAX( I - J + 1, 0 ) + 110 CONTINUE + X( J ) = J + Y( J ) = ZERO + 120 CONTINUE + DO 130 J = 1, N + YY( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 + 130 CONTINUE +* YY holds the exact result. On exit from DMVCH YT holds +* the result computed by DMVCH. + TRANS = 'N' + CALL DMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G, + $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) + SAME = LDE( YY, YT, N ) + IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN + WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR + STOP + END IF + TRANS = 'T' + CALL DMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G, + $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) + SAME = LDE( YY, YT, N ) + IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN + WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR + STOP + END IF +* +* Test each subroutine in turn. +* + DO 210 ISNUM = 1, NSUBS + WRITE( NOUT, FMT = * ) + IF( .NOT.LTEST( ISNUM ) )THEN +* Subprogram is not to be tested. + WRITE( NOUT, FMT = 9983 )SNAMES( ISNUM ) + ELSE + SRNAMT = SNAMES( ISNUM ) +* Test error exits. + IF( TSTERR )THEN + CALL CD2CHKE( SNAMES( ISNUM ) ) + WRITE( NOUT, FMT = * ) + END IF +* Test computations. + INFOT = 0 + OK = .TRUE. + FATAL = .FALSE. + GO TO ( 140, 140, 150, 150, 150, 160, 160, + $ 160, 160, 160, 160, 170, 180, 180, + $ 190, 190 )ISNUM +* Test DGEMV, 01, and DGBMV, 02. + 140 IF (CORDER) THEN + CALL DCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, + $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, + $ X, XX, XS, Y, YY, YS, YT, G, 0 ) + END IF + IF (RORDER) THEN + CALL DCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, + $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, + $ X, XX, XS, Y, YY, YS, YT, G, 1 ) + END IF + GO TO 200 +* Test DSYMV, 03, DSBMV, 04, and DSPMV, 05. + 150 IF (CORDER) THEN + CALL DCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, + $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, + $ X, XX, XS, Y, YY, YS, YT, G, 0 ) + END IF + IF (RORDER) THEN + CALL DCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, + $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, + $ X, XX, XS, Y, YY, YS, YT, G, 1 ) + END IF + GO TO 200 +* Test DTRMV, 06, DTBMV, 07, DTPMV, 08, +* DTRSV, 09, DTBSV, 10, and DTPSV, 11. + 160 IF (CORDER) THEN + CALL DCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z, + $ 0 ) + END IF + IF (RORDER) THEN + CALL DCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z, + $ 1 ) + END IF + GO TO 200 +* Test DGER, 12. + 170 IF (CORDER) THEN + CALL DCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, + $ YT, G, Z, 0 ) + END IF + IF (RORDER) THEN + CALL DCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, + $ YT, G, Z, 1 ) + END IF + GO TO 200 +* Test DSYR, 13, and DSPR, 14. + 180 IF (CORDER) THEN + CALL DCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, + $ YT, G, Z, 0 ) + END IF + IF (RORDER) THEN + CALL DCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, + $ YT, G, Z, 1 ) + END IF + GO TO 200 +* Test DSYR2, 15, and DSPR2, 16. + 190 IF (CORDER) THEN + CALL DCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, + $ YT, G, Z, 0 ) + END IF + IF (RORDER) THEN + CALL DCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, + $ YT, G, Z, 1 ) + END IF +* + 200 IF( FATAL.AND.SFATAL ) + $ GO TO 220 + END IF + 210 CONTINUE + WRITE( NOUT, FMT = 9982 ) + GO TO 240 +* + 220 CONTINUE + WRITE( NOUT, FMT = 9981 ) + GO TO 240 +* + 230 CONTINUE + WRITE( NOUT, FMT = 9987 ) +* + 240 CONTINUE + IF( TRACE ) + $ CLOSE ( NTRA ) + CLOSE ( NOUT ) + STOP +* +10002 FORMAT( ' COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED' ) +10001 FORMAT( ' ROW-MAJOR DATA LAYOUT IS TESTED' ) +10000 FORMAT( ' COLUMN-MAJOR DATA LAYOUT IS TESTED' ) + 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', + $ 'S THAN', F8.2 ) + 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, D9.1 ) + 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', + $ 'THAN ', I2 ) + 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) + 9995 FORMAT( ' VALUE OF K IS LESS THAN 0' ) + 9994 FORMAT( ' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ', + $ I2 ) + 9993 FORMAT( ' TESTS OF THE DOUBLE PRECISION LEVEL 2 BLAS', //' THE F', + $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) + 9992 FORMAT( ' FOR N ', 9I6 ) + 9991 FORMAT( ' FOR K ', 7I6 ) + 9990 FORMAT( ' FOR INCX AND INCY ', 7I6 ) + 9989 FORMAT( ' FOR ALPHA ', 7F6.1 ) + 9988 FORMAT( ' FOR BETA ', 7F6.1 ) + 9987 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', + $ /' ******* TESTS ABANDONED *******' ) + 9986 FORMAT( ' SUBPROGRAM NAME ',A12, ' NOT RECOGNIZED', /' ******* T', + $ 'ESTS ABANDONED *******' ) + 9985 FORMAT( ' ERROR IN DMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', + $ 'ATED WRONGLY.', /' DMVCH WAS CALLED WITH TRANS = ', A1, + $ ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', / + $ ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.' + $ , /' ******* TESTS ABANDONED *******' ) + 9984 FORMAT(A12, L2 ) + 9983 FORMAT( 1X,A12, ' WAS NOT TESTED' ) + 9982 FORMAT( /' END OF TESTS' ) + 9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) + 9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) +* +* End of DBLAT2. +* + END + SUBROUTINE DCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, + $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, + $ XS, Y, YY, YS, YT, G, IORDER ) +* +* Tests DGEMV and DGBMV. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + DOUBLE PRECISION ZERO, HALF + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0 ) +* .. Scalar Arguments .. + DOUBLE PRECISION EPS, THRESH + INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, + $ NOUT, NTRA, IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ), + $ X( NMAX ), XS( NMAX*INCMAX ), + $ XX( NMAX*INCMAX ), Y( NMAX ), + $ YS( NMAX*INCMAX ), YT( NMAX ), + $ YY( NMAX*INCMAX ) + INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) +* .. Local Scalars .. + DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL + INTEGER I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY, + $ INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA, + $ LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK, + $ NL, NS + LOGICAL BANDED, FULL, NULL, RESET, SAME, TRAN + CHARACTER*1 TRANS, TRANSS + CHARACTER*14 CTRANS + CHARACTER*3 ICH +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LDE, LDERES + EXTERNAL LDE, LDERES +* .. External Subroutines .. + EXTERNAL CDGBMV, CDGEMV, DMAKE, DMVCH +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICH/'NTC'/ +* .. Executable Statements .. + FULL = SNAME( 9: 9 ).EQ.'e' + BANDED = SNAME( 9: 9 ).EQ.'b' +* Define the number of arguments. + IF( FULL )THEN + NARGS = 11 + ELSE IF( BANDED )THEN + NARGS = 13 + END IF +* + NC = 0 + RESET = .TRUE. + ERRMAX = ZERO +* + DO 120 IN = 1, NIDIM + N = IDIM( IN ) + ND = N/2 + 1 +* + DO 110 IM = 1, 2 + IF( IM.EQ.1 ) + $ M = MAX( N - ND, 0 ) + IF( IM.EQ.2 ) + $ M = MIN( N + ND, NMAX ) +* + IF( BANDED )THEN + NK = NKB + ELSE + NK = 1 + END IF + DO 100 IKU = 1, NK + IF( BANDED )THEN + KU = KB( IKU ) + KL = MAX( KU - 1, 0 ) + ELSE + KU = N - 1 + KL = M - 1 + END IF +* Set LDA to 1 more than minimum value if room. + IF( BANDED )THEN + LDA = KL + KU + 1 + ELSE + LDA = M + END IF + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 100 + LAA = LDA*N + NULL = N.LE.0.OR.M.LE.0 +* +* Generate the matrix A. +* + TRANSL = ZERO + CALL DMAKE( SNAME( 8: 9 ), ' ', ' ', M, N, A, NMAX, AA, + $ LDA, KL, KU, RESET, TRANSL ) +* + DO 90 IC = 1, 3 + TRANS = ICH( IC: IC ) + IF (TRANS.EQ.'N')THEN + CTRANS = ' CblasNoTrans' + ELSE IF (TRANS.EQ.'T')THEN + CTRANS = ' CblasTrans' + ELSE + CTRANS = 'CblasConjTrans' + END IF + TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' +* + IF( TRAN )THEN + ML = N + NL = M + ELSE + ML = M + NL = N + END IF +* + DO 80 IX = 1, NINC + INCX = INC( IX ) + LX = ABS( INCX )*NL +* +* Generate the vector X. +* + TRANSL = HALF + CALL DMAKE( 'ge', ' ', ' ', 1, NL, X, 1, XX, + $ ABS( INCX ), 0, NL - 1, RESET, TRANSL ) + IF( NL.GT.1 )THEN + X( NL/2 ) = ZERO + XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO + END IF +* + DO 70 IY = 1, NINC + INCY = INC( IY ) + LY = ABS( INCY )*ML +* + DO 60 IA = 1, NALF + ALPHA = ALF( IA ) +* + DO 50 IB = 1, NBET + BETA = BET( IB ) +* +* Generate the vector Y. +* + TRANSL = ZERO + CALL DMAKE( 'ge', ' ', ' ', 1, ML, Y, 1, + $ YY, ABS( INCY ), 0, ML - 1, + $ RESET, TRANSL ) +* + NC = NC + 1 +* +* Save every datum before calling the +* subroutine. +* + TRANSS = TRANS + MS = M + NS = N + KLS = KL + KUS = KU + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LX + XS( I ) = XX( I ) + 20 CONTINUE + INCXS = INCX + BLS = BETA + DO 30 I = 1, LY + YS( I ) = YY( I ) + 30 CONTINUE + INCYS = INCY +* +* Call the subroutine. +* + IF( FULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9994 )NC, SNAME, + $ CTRANS, M, N, ALPHA, LDA, INCX, + $ BETA, INCY + IF( REWI ) + $ REWIND NTRA + CALL CDGEMV( IORDER, TRANS, M, N, + $ ALPHA, AA, LDA, XX, INCX, + $ BETA, YY, INCY ) + ELSE IF( BANDED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9995 )NC, SNAME, + $ CTRANS, M, N, KL, KU, ALPHA, LDA, + $ INCX, BETA, INCY + IF( REWI ) + $ REWIND NTRA + CALL CDGBMV( IORDER, TRANS, M, N, KL, + $ KU, ALPHA, AA, LDA, XX, + $ INCX, BETA, YY, INCY ) + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9993 ) + FATAL = .TRUE. + GO TO 130 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = TRANS.EQ.TRANSS + ISAME( 2 ) = MS.EQ.M + ISAME( 3 ) = NS.EQ.N + IF( FULL )THEN + ISAME( 4 ) = ALS.EQ.ALPHA + ISAME( 5 ) = LDE( AS, AA, LAA ) + ISAME( 6 ) = LDAS.EQ.LDA + ISAME( 7 ) = LDE( XS, XX, LX ) + ISAME( 8 ) = INCXS.EQ.INCX + ISAME( 9 ) = BLS.EQ.BETA + IF( NULL )THEN + ISAME( 10 ) = LDE( YS, YY, LY ) + ELSE + ISAME( 10 ) = LDERES( 'ge', ' ', 1, + $ ML, YS, YY, + $ ABS( INCY ) ) + END IF + ISAME( 11 ) = INCYS.EQ.INCY + ELSE IF( BANDED )THEN + ISAME( 4 ) = KLS.EQ.KL + ISAME( 5 ) = KUS.EQ.KU + ISAME( 6 ) = ALS.EQ.ALPHA + ISAME( 7 ) = LDE( AS, AA, LAA ) + ISAME( 8 ) = LDAS.EQ.LDA + ISAME( 9 ) = LDE( XS, XX, LX ) + ISAME( 10 ) = INCXS.EQ.INCX + ISAME( 11 ) = BLS.EQ.BETA + IF( NULL )THEN + ISAME( 12 ) = LDE( YS, YY, LY ) + ELSE + ISAME( 12 ) = LDERES( 'ge', ' ', 1, + $ ML, YS, YY, + $ ABS( INCY ) ) + END IF + ISAME( 13 ) = INCYS.EQ.INCY + END IF +* +* If data was incorrectly changed, report +* and return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 130 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result. +* + CALL DMVCH( TRANS, M, N, ALPHA, A, + $ NMAX, X, INCX, BETA, Y, + $ INCY, YT, G, YY, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and +* return. + IF( FATAL ) + $ GO TO 130 + ELSE +* Avoid repeating tests with M.le.0 or +* N.le.0. + GO TO 110 + END IF +* + 50 CONTINUE +* + 60 CONTINUE +* + 70 CONTINUE +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* + 110 CONTINUE +* + 120 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 140 +* + 130 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + IF( FULL )THEN + WRITE( NOUT, FMT = 9994 )NC, SNAME, CTRANS, M, N, ALPHA, LDA, + $ INCX, BETA, INCY + ELSE IF( BANDED )THEN + WRITE( NOUT, FMT = 9995 )NC, SNAME, CTRANS, M, N, KL, KU, + $ ALPHA, LDA, INCX, BETA, INCY + END IF +* + 140 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, + $ ' - SUSPECT *******' ) + 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', 4( I3, ',' ), F4.1, + $ ', A,', I3, ',',/ 10x,'X,', I2, ',', F4.1, ', Y,', + $ I2, ') .' ) + 9994 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', 2( I3, ',' ), F4.1, + $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, + $ ') .' ) + 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of DCHK1. +* + END + SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, + $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, + $ XS, Y, YY, YS, YT, G, IORDER ) +* +* Tests DSYMV, DSBMV and DSPMV. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + DOUBLE PRECISION ZERO, HALF + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0 ) +* .. Scalar Arguments .. + DOUBLE PRECISION EPS, THRESH + INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, + $ NOUT, NTRA, IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ), + $ X( NMAX ), XS( NMAX*INCMAX ), + $ XX( NMAX*INCMAX ), Y( NMAX ), + $ YS( NMAX*INCMAX ), YT( NMAX ), + $ YY( NMAX*INCMAX ) + INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) +* .. Local Scalars .. + DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL + INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY, + $ INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY, + $ N, NARGS, NC, NK, NS + LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME + CHARACTER*1 UPLO, UPLOS + CHARACTER*14 CUPLO + CHARACTER*2 ICH +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LDE, LDERES + EXTERNAL LDE, LDERES +* .. External Subroutines .. + EXTERNAL DMAKE, DMVCH, CDSBMV, CDSPMV, CDSYMV +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICH/'UL'/ +* .. Executable Statements .. + FULL = SNAME( 9: 9 ).EQ.'y' + BANDED = SNAME( 9: 9 ).EQ.'b' + PACKED = SNAME( 9: 9 ).EQ.'p' +* Define the number of arguments. + IF( FULL )THEN + NARGS = 10 + ELSE IF( BANDED )THEN + NARGS = 11 + ELSE IF( PACKED )THEN + NARGS = 9 + END IF +* + NC = 0 + RESET = .TRUE. + ERRMAX = ZERO +* + DO 110 IN = 1, NIDIM + N = IDIM( IN ) +* + IF( BANDED )THEN + NK = NKB + ELSE + NK = 1 + END IF + DO 100 IK = 1, NK + IF( BANDED )THEN + K = KB( IK ) + ELSE + K = N - 1 + END IF +* Set LDA to 1 more than minimum value if room. + IF( BANDED )THEN + LDA = K + 1 + ELSE + LDA = N + END IF + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 100 + IF( PACKED )THEN + LAA = ( N*( N + 1 ) )/2 + ELSE + LAA = LDA*N + END IF + NULL = N.LE.0 +* + DO 90 IC = 1, 2 + UPLO = ICH( IC: IC ) + IF (UPLO.EQ.'U')THEN + CUPLO = ' CblasUpper' + ELSE + CUPLO = ' CblasLower' + END IF +* +* Generate the matrix A. +* + TRANSL = ZERO + CALL DMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, A, NMAX, AA, + $ LDA, K, K, RESET, TRANSL ) +* + DO 80 IX = 1, NINC + INCX = INC( IX ) + LX = ABS( INCX )*N +* +* Generate the vector X. +* + TRANSL = HALF + CALL DMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX, + $ ABS( INCX ), 0, N - 1, RESET, TRANSL ) + IF( N.GT.1 )THEN + X( N/2 ) = ZERO + XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO + END IF +* + DO 70 IY = 1, NINC + INCY = INC( IY ) + LY = ABS( INCY )*N +* + DO 60 IA = 1, NALF + ALPHA = ALF( IA ) +* + DO 50 IB = 1, NBET + BETA = BET( IB ) +* +* Generate the vector Y. +* + TRANSL = ZERO + CALL DMAKE( 'ge', ' ', ' ', 1, N, Y, 1, YY, + $ ABS( INCY ), 0, N - 1, RESET, + $ TRANSL ) +* + NC = NC + 1 +* +* Save every datum before calling the +* subroutine. +* + UPLOS = UPLO + NS = N + KS = K + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LX + XS( I ) = XX( I ) + 20 CONTINUE + INCXS = INCX + BLS = BETA + DO 30 I = 1, LY + YS( I ) = YY( I ) + 30 CONTINUE + INCYS = INCY +* +* Call the subroutine. +* + IF( FULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, + $ CUPLO, N, ALPHA, LDA, INCX, BETA, INCY + IF( REWI ) + $ REWIND NTRA + CALL CDSYMV( IORDER, UPLO, N, ALPHA, AA, + $ LDA, XX, INCX, BETA, YY, INCY ) + ELSE IF( BANDED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9994 )NC, SNAME, + $ CUPLO, N, K, ALPHA, LDA, INCX, BETA, + $ INCY + IF( REWI ) + $ REWIND NTRA + CALL CDSBMV( IORDER, UPLO, N, K, ALPHA, + $ AA, LDA, XX, INCX, BETA, YY, + $ INCY ) + ELSE IF( PACKED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9995 )NC, SNAME, + $ CUPLO, N, ALPHA, INCX, BETA, INCY + IF( REWI ) + $ REWIND NTRA + CALL CDSPMV( IORDER, UPLO, N, ALPHA, AA, + $ XX, INCX, BETA, YY, INCY ) + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9992 ) + FATAL = .TRUE. + GO TO 120 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = UPLO.EQ.UPLOS + ISAME( 2 ) = NS.EQ.N + IF( FULL )THEN + ISAME( 3 ) = ALS.EQ.ALPHA + ISAME( 4 ) = LDE( AS, AA, LAA ) + ISAME( 5 ) = LDAS.EQ.LDA + ISAME( 6 ) = LDE( XS, XX, LX ) + ISAME( 7 ) = INCXS.EQ.INCX + ISAME( 8 ) = BLS.EQ.BETA + IF( NULL )THEN + ISAME( 9 ) = LDE( YS, YY, LY ) + ELSE + ISAME( 9 ) = LDERES( 'ge', ' ', 1, N, + $ YS, YY, ABS( INCY ) ) + END IF + ISAME( 10 ) = INCYS.EQ.INCY + ELSE IF( BANDED )THEN + ISAME( 3 ) = KS.EQ.K + ISAME( 4 ) = ALS.EQ.ALPHA + ISAME( 5 ) = LDE( AS, AA, LAA ) + ISAME( 6 ) = LDAS.EQ.LDA + ISAME( 7 ) = LDE( XS, XX, LX ) + ISAME( 8 ) = INCXS.EQ.INCX + ISAME( 9 ) = BLS.EQ.BETA + IF( NULL )THEN + ISAME( 10 ) = LDE( YS, YY, LY ) + ELSE + ISAME( 10 ) = LDERES( 'ge', ' ', 1, N, + $ YS, YY, ABS( INCY ) ) + END IF + ISAME( 11 ) = INCYS.EQ.INCY + ELSE IF( PACKED )THEN + ISAME( 3 ) = ALS.EQ.ALPHA + ISAME( 4 ) = LDE( AS, AA, LAA ) + ISAME( 5 ) = LDE( XS, XX, LX ) + ISAME( 6 ) = INCXS.EQ.INCX + ISAME( 7 ) = BLS.EQ.BETA + IF( NULL )THEN + ISAME( 8 ) = LDE( YS, YY, LY ) + ELSE + ISAME( 8 ) = LDERES( 'ge', ' ', 1, N, + $ YS, YY, ABS( INCY ) ) + END IF + ISAME( 9 ) = INCYS.EQ.INCY + END IF +* +* If data was incorrectly changed, report and +* return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 120 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result. +* + CALL DMVCH( 'N', N, N, ALPHA, A, NMAX, X, + $ INCX, BETA, Y, INCY, YT, G, + $ YY, EPS, ERR, FATAL, NOUT, + $ .TRUE. ) + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and +* return. + IF( FATAL ) + $ GO TO 120 + ELSE +* Avoid repeating tests with N.le.0 + GO TO 110 + END IF +* + 50 CONTINUE +* + 60 CONTINUE +* + 70 CONTINUE +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* + 110 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 130 +* + 120 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + IF( FULL )THEN + WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, N, ALPHA, LDA, INCX, + $ BETA, INCY + ELSE IF( BANDED )THEN + WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, N, K, ALPHA, LDA, + $ INCX, BETA, INCY + ELSE IF( PACKED )THEN + WRITE( NOUT, FMT = 9995 )NC, SNAME, CUPLO, N, ALPHA, INCX, + $ BETA, INCY + END IF +* + 130 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, + $ ' - SUSPECT *******' ) + 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', AP', + $ ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) + 9994 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', 2( I3, ',' ), F4.1, + $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, + $ ') .' ) + 9993 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', A,', + $ I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) + 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of DCHK2. +* + END + SUBROUTINE DCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX, + $ INCMAX, A, AA, AS, X, XX, XS, XT, G, Z, IORDER ) +* +* Tests DTRMV, DTBMV, DTPMV, DTRSV, DTBSV and DTPSV. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) +* .. Scalar Arguments .. + DOUBLE PRECISION EPS, THRESH + INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA, + $ IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), + $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), + $ XS( NMAX*INCMAX ), XT( NMAX ), + $ XX( NMAX*INCMAX ), Z( NMAX ) + INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) +* .. Local Scalars .. + DOUBLE PRECISION ERR, ERRMAX, TRANSL + INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K, + $ KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS + LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME + CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS + CHARACTER*14 CUPLO,CTRANS,CDIAG + CHARACTER*2 ICHD, ICHU + CHARACTER*3 ICHT +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LDE, LDERES + EXTERNAL LDE, LDERES +* .. External Subroutines .. + EXTERNAL DMAKE, DMVCH, CDTBMV, CDTBSV, CDTPMV, + $ CDTPSV, CDTRMV, CDTRSV +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/ +* .. Executable Statements .. + FULL = SNAME( 9: 9 ).EQ.'r' + BANDED = SNAME( 9: 9 ).EQ.'b' + PACKED = SNAME( 9: 9 ).EQ.'p' +* Define the number of arguments. + IF( FULL )THEN + NARGS = 8 + ELSE IF( BANDED )THEN + NARGS = 9 + ELSE IF( PACKED )THEN + NARGS = 7 + END IF +* + NC = 0 + RESET = .TRUE. + ERRMAX = ZERO +* Set up zero vector for DMVCH. + DO 10 I = 1, NMAX + Z( I ) = ZERO + 10 CONTINUE +* + DO 110 IN = 1, NIDIM + N = IDIM( IN ) +* + IF( BANDED )THEN + NK = NKB + ELSE + NK = 1 + END IF + DO 100 IK = 1, NK + IF( BANDED )THEN + K = KB( IK ) + ELSE + K = N - 1 + END IF +* Set LDA to 1 more than minimum value if room. + IF( BANDED )THEN + LDA = K + 1 + ELSE + LDA = N + END IF + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 100 + IF( PACKED )THEN + LAA = ( N*( N + 1 ) )/2 + ELSE + LAA = LDA*N + END IF + NULL = N.LE.0 +* + DO 90 ICU = 1, 2 + UPLO = ICHU( ICU: ICU ) + IF (UPLO.EQ.'U')THEN + CUPLO = ' CblasUpper' + ELSE + CUPLO = ' CblasLower' + END IF +* + DO 80 ICT = 1, 3 + TRANS = ICHT( ICT: ICT ) + IF (TRANS.EQ.'N')THEN + CTRANS = ' CblasNoTrans' + ELSE IF (TRANS.EQ.'T')THEN + CTRANS = ' CblasTrans' + ELSE + CTRANS = 'CblasConjTrans' + END IF +* + DO 70 ICD = 1, 2 + DIAG = ICHD( ICD: ICD ) + IF (DIAG.EQ.'N')THEN + CDIAG = ' CblasNonUnit' + ELSE + CDIAG = ' CblasUnit' + END IF +* +* Generate the matrix A. +* + TRANSL = ZERO + CALL DMAKE( SNAME( 8: 9 ), UPLO, DIAG, N, N, A, + $ NMAX, AA, LDA, K, K, RESET, TRANSL ) +* + DO 60 IX = 1, NINC + INCX = INC( IX ) + LX = ABS( INCX )*N +* +* Generate the vector X. +* + TRANSL = HALF + CALL DMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX, + $ ABS( INCX ), 0, N - 1, RESET, + $ TRANSL ) + IF( N.GT.1 )THEN + X( N/2 ) = ZERO + XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO + END IF +* + NC = NC + 1 +* +* Save every datum before calling the subroutine. +* + UPLOS = UPLO + TRANSS = TRANS + DIAGS = DIAG + NS = N + KS = K + DO 20 I = 1, LAA + AS( I ) = AA( I ) + 20 CONTINUE + LDAS = LDA + DO 30 I = 1, LX + XS( I ) = XX( I ) + 30 CONTINUE + INCXS = INCX +* +* Call the subroutine. +* + IF( SNAME( 10: 11 ).EQ.'mv' )THEN + IF( FULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, + $ CUPLO, CTRANS, CDIAG, N, LDA, INCX + IF( REWI ) + $ REWIND NTRA + CALL CDTRMV( IORDER, UPLO, TRANS, DIAG, + $ N, AA, LDA, XX, INCX ) + ELSE IF( BANDED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9994 )NC, SNAME, + $ CUPLO, CTRANS, CDIAG, N, K, LDA, INCX + IF( REWI ) + $ REWIND NTRA + CALL CDTBMV( IORDER, UPLO, TRANS, DIAG, + $ N, K, AA, LDA, XX, INCX ) + ELSE IF( PACKED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9995 )NC, SNAME, + $ CUPLO, CTRANS, CDIAG, N, INCX + IF( REWI ) + $ REWIND NTRA + CALL CDTPMV( IORDER, UPLO, TRANS, DIAG, + $ N, AA, XX, INCX ) + END IF + ELSE IF( SNAME( 10: 11 ).EQ.'sv' )THEN + IF( FULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, + $ CUPLO, CTRANS, CDIAG, N, LDA, INCX + IF( REWI ) + $ REWIND NTRA + CALL CDTRSV( IORDER, UPLO, TRANS, DIAG, + $ N, AA, LDA, XX, INCX ) + ELSE IF( BANDED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9994 )NC, SNAME, + $ CUPLO, CTRANS, CDIAG, N, K, LDA, INCX + IF( REWI ) + $ REWIND NTRA + CALL CDTBSV( IORDER, UPLO, TRANS, DIAG, + $ N, K, AA, LDA, XX, INCX ) + ELSE IF( PACKED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9995 )NC, SNAME, + $ CUPLO, CTRANS, CDIAG, N, INCX + IF( REWI ) + $ REWIND NTRA + CALL CDTPSV( IORDER, UPLO, TRANS, DIAG, + $ N, AA, XX, INCX ) + END IF + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9992 ) + FATAL = .TRUE. + GO TO 120 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = UPLO.EQ.UPLOS + ISAME( 2 ) = TRANS.EQ.TRANSS + ISAME( 3 ) = DIAG.EQ.DIAGS + ISAME( 4 ) = NS.EQ.N + IF( FULL )THEN + ISAME( 5 ) = LDE( AS, AA, LAA ) + ISAME( 6 ) = LDAS.EQ.LDA + IF( NULL )THEN + ISAME( 7 ) = LDE( XS, XX, LX ) + ELSE + ISAME( 7 ) = LDERES( 'ge', ' ', 1, N, XS, + $ XX, ABS( INCX ) ) + END IF + ISAME( 8 ) = INCXS.EQ.INCX + ELSE IF( BANDED )THEN + ISAME( 5 ) = KS.EQ.K + ISAME( 6 ) = LDE( AS, AA, LAA ) + ISAME( 7 ) = LDAS.EQ.LDA + IF( NULL )THEN + ISAME( 8 ) = LDE( XS, XX, LX ) + ELSE + ISAME( 8 ) = LDERES( 'ge', ' ', 1, N, XS, + $ XX, ABS( INCX ) ) + END IF + ISAME( 9 ) = INCXS.EQ.INCX + ELSE IF( PACKED )THEN + ISAME( 5 ) = LDE( AS, AA, LAA ) + IF( NULL )THEN + ISAME( 6 ) = LDE( XS, XX, LX ) + ELSE + ISAME( 6 ) = LDERES( 'ge', ' ', 1, N, XS, + $ XX, ABS( INCX ) ) + END IF + ISAME( 7 ) = INCXS.EQ.INCX + END IF +* +* If data was incorrectly changed, report and +* return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 120 + END IF +* + IF( .NOT.NULL )THEN + IF( SNAME( 10: 11 ).EQ.'mv' )THEN +* +* Check the result. +* + CALL DMVCH( TRANS, N, N, ONE, A, NMAX, X, + $ INCX, ZERO, Z, INCX, XT, G, + $ XX, EPS, ERR, FATAL, NOUT, + $ .TRUE. ) + ELSE IF( SNAME( 10: 11 ).EQ.'sv' )THEN +* +* Compute approximation to original vector. +* + DO 50 I = 1, N + Z( I ) = XX( 1 + ( I - 1 )* + $ ABS( INCX ) ) + XX( 1 + ( I - 1 )*ABS( INCX ) ) + $ = X( I ) + 50 CONTINUE + CALL DMVCH( TRANS, N, N, ONE, A, NMAX, Z, + $ INCX, ZERO, X, INCX, XT, G, + $ XX, EPS, ERR, FATAL, NOUT, + $ .FALSE. ) + END IF + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and return. + IF( FATAL ) + $ GO TO 120 + ELSE +* Avoid repeating tests with N.le.0. + GO TO 110 + END IF +* + 60 CONTINUE +* + 70 CONTINUE +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* + 110 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 130 +* + 120 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + IF( FULL )THEN + WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, CTRANS, CDIAG, N, + $ LDA, INCX + ELSE IF( BANDED )THEN + WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, CTRANS, CDIAG, N, K, + $ LDA, INCX + ELSE IF( PACKED )THEN + WRITE( NOUT, FMT = 9995 )NC, SNAME, CUPLO, CTRANS, CDIAG, N, + $ INCX + END IF +* + 130 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, + $ ' - SUSPECT *******' ) + 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ',A12, '(', 3( A14,',' ),/ 10x, I3, ', AP, ', + $ 'X,', I2, ') .' ) + 9994 FORMAT( 1X, I6, ': ',A12, '(', 3( A14,',' ),/ 10x, 2( I3, ',' ), + $ ' A,', I3, ', X,', I2, ') .' ) + 9993 FORMAT( 1X, I6, ': ',A12, '(', 3( A14,',' ),/ 10x, I3, ', A,', + $ I3, ', X,', I2, ') .' ) + 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of DCHK3. +* + END + SUBROUTINE DCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, + $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, + $ Z, IORDER ) +* +* Tests DGER. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) +* .. Scalar Arguments .. + DOUBLE PRECISION EPS, THRESH + INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA, + $ IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), + $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), + $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), + $ YY( NMAX*INCMAX ), Z( NMAX ) + INTEGER IDIM( NIDIM ), INC( NINC ) +* .. Local Scalars .. + DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX, TRANSL + INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX, + $ IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS, + $ NC, ND, NS + LOGICAL NULL, RESET, SAME +* .. Local Arrays .. + DOUBLE PRECISION W( 1 ) + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LDE, LDERES + EXTERNAL LDE, LDERES +* .. External Subroutines .. + EXTERNAL DGER, DMAKE, DMVCH +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Executable Statements .. +* Define the number of arguments. + NARGS = 9 +* + NC = 0 + RESET = .TRUE. + ERRMAX = ZERO +* + DO 120 IN = 1, NIDIM + N = IDIM( IN ) + ND = N/2 + 1 +* + DO 110 IM = 1, 2 + IF( IM.EQ.1 ) + $ M = MAX( N - ND, 0 ) + IF( IM.EQ.2 ) + $ M = MIN( N + ND, NMAX ) +* +* Set LDA to 1 more than minimum value if room. + LDA = M + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 110 + LAA = LDA*N + NULL = N.LE.0.OR.M.LE.0 +* + DO 100 IX = 1, NINC + INCX = INC( IX ) + LX = ABS( INCX )*M +* +* Generate the vector X. +* + TRANSL = HALF + CALL DMAKE( 'ge', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ), + $ 0, M - 1, RESET, TRANSL ) + IF( M.GT.1 )THEN + X( M/2 ) = ZERO + XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO + END IF +* + DO 90 IY = 1, NINC + INCY = INC( IY ) + LY = ABS( INCY )*N +* +* Generate the vector Y. +* + TRANSL = ZERO + CALL DMAKE( 'ge', ' ', ' ', 1, N, Y, 1, YY, + $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) + IF( N.GT.1 )THEN + Y( N/2 ) = ZERO + YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO + END IF +* + DO 80 IA = 1, NALF + ALPHA = ALF( IA ) +* +* Generate the matrix A. +* + TRANSL = ZERO + CALL DMAKE( SNAME( 8: 9 ), ' ', ' ', M, N, A, NMAX, + $ AA, LDA, M - 1, N - 1, RESET, TRANSL ) +* + NC = NC + 1 +* +* Save every datum before calling the subroutine. +* + MS = M + NS = N + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LX + XS( I ) = XX( I ) + 20 CONTINUE + INCXS = INCX + DO 30 I = 1, LY + YS( I ) = YY( I ) + 30 CONTINUE + INCYS = INCY +* +* Call the subroutine. +* + IF( TRACE ) + $ WRITE( NTRA, FMT = 9994 )NC, SNAME, M, N, + $ ALPHA, INCX, INCY, LDA + IF( REWI ) + $ REWIND NTRA + CALL CDGER( IORDER, M, N, ALPHA, XX, INCX, YY, + $ INCY, AA, LDA ) +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9993 ) + FATAL = .TRUE. + GO TO 140 + END IF +* +* See what data changed inside subroutine. +* + ISAME( 1 ) = MS.EQ.M + ISAME( 2 ) = NS.EQ.N + ISAME( 3 ) = ALS.EQ.ALPHA + ISAME( 4 ) = LDE( XS, XX, LX ) + ISAME( 5 ) = INCXS.EQ.INCX + ISAME( 6 ) = LDE( YS, YY, LY ) + ISAME( 7 ) = INCYS.EQ.INCY + IF( NULL )THEN + ISAME( 8 ) = LDE( AS, AA, LAA ) + ELSE + ISAME( 8 ) = LDERES( 'ge', ' ', M, N, AS, AA, + $ LDA ) + END IF + ISAME( 9 ) = LDAS.EQ.LDA +* +* If data was incorrectly changed, report and return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 140 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result column by column. +* + IF( INCX.GT.0 )THEN + DO 50 I = 1, M + Z( I ) = X( I ) + 50 CONTINUE + ELSE + DO 60 I = 1, M + Z( I ) = X( M - I + 1 ) + 60 CONTINUE + END IF + DO 70 J = 1, N + IF( INCY.GT.0 )THEN + W( 1 ) = Y( J ) + ELSE + W( 1 ) = Y( N - J + 1 ) + END IF + CALL DMVCH( 'N', M, 1, ALPHA, Z, NMAX, W, 1, + $ ONE, A( 1, J ), 1, YT, G, + $ AA( 1 + ( J - 1 )*LDA ), EPS, + $ ERR, FATAL, NOUT, .TRUE. ) + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and return. + IF( FATAL ) + $ GO TO 130 + 70 CONTINUE + ELSE +* Avoid repeating tests with M.le.0 or N.le.0. + GO TO 110 + END IF +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* + 110 CONTINUE +* + 120 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 150 +* + 130 CONTINUE + WRITE( NOUT, FMT = 9995 )J +* + 140 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + WRITE( NOUT, FMT = 9994 )NC, SNAME, M, N, ALPHA, INCX, INCY, LDA +* + 150 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, + $ ' - SUSPECT *******' ) + 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) + 9994 FORMAT( 1X, I6, ': ',A12, '(', 2( I3, ',' ), F4.1, ', X,', I2, + $ ', Y,', I2, ', A,', I3, ') .' ) + 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of DCHK4. +* + END + SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, + $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, + $ Z, IORDER ) +* +* Tests DSYR and DSPR. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) +* .. Scalar Arguments .. + DOUBLE PRECISION EPS, THRESH + INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA, + $ IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), + $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), + $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), + $ YY( NMAX*INCMAX ), Z( NMAX ) + INTEGER IDIM( NIDIM ), INC( NINC ) +* .. Local Scalars .. + DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX, TRANSL + INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA, + $ LDA, LDAS, LJ, LX, N, NARGS, NC, NS + LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER + CHARACTER*1 UPLO, UPLOS + CHARACTER*14 CUPLO + CHARACTER*2 ICH +* .. Local Arrays .. + DOUBLE PRECISION W( 1 ) + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LDE, LDERES + EXTERNAL LDE, LDERES +* .. External Subroutines .. + EXTERNAL DMAKE, DMVCH, CDSPR, CDSYR +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICH/'UL'/ +* .. Executable Statements .. + FULL = SNAME( 9: 9 ).EQ.'y' + PACKED = SNAME( 9: 9 ).EQ.'p' +* Define the number of arguments. + IF( FULL )THEN + NARGS = 7 + ELSE IF( PACKED )THEN + NARGS = 6 + END IF +* + NC = 0 + RESET = .TRUE. + ERRMAX = ZERO +* + DO 100 IN = 1, NIDIM + N = IDIM( IN ) +* Set LDA to 1 more than minimum value if room. + LDA = N + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 100 + IF( PACKED )THEN + LAA = ( N*( N + 1 ) )/2 + ELSE + LAA = LDA*N + END IF +* + DO 90 IC = 1, 2 + UPLO = ICH( IC: IC ) + IF (UPLO.EQ.'U')THEN + CUPLO = ' CblasUpper' + ELSE + CUPLO = ' CblasLower' + END IF + UPPER = UPLO.EQ.'U' +* + DO 80 IX = 1, NINC + INCX = INC( IX ) + LX = ABS( INCX )*N +* +* Generate the vector X. +* + TRANSL = HALF + CALL DMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), + $ 0, N - 1, RESET, TRANSL ) + IF( N.GT.1 )THEN + X( N/2 ) = ZERO + XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO + END IF +* + DO 70 IA = 1, NALF + ALPHA = ALF( IA ) + NULL = N.LE.0.OR.ALPHA.EQ.ZERO +* +* Generate the matrix A. +* + TRANSL = ZERO + CALL DMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, A, NMAX, + $ AA, LDA, N - 1, N - 1, RESET, TRANSL ) +* + NC = NC + 1 +* +* Save every datum before calling the subroutine. +* + UPLOS = UPLO + NS = N + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LX + XS( I ) = XX( I ) + 20 CONTINUE + INCXS = INCX +* +* Call the subroutine. +* + IF( FULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, CUPLO, N, + $ ALPHA, INCX, LDA + IF( REWI ) + $ REWIND NTRA + CALL CDSYR( IORDER, UPLO, N, ALPHA, XX, INCX, + $ AA, LDA ) + ELSE IF( PACKED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9994 )NC, SNAME, CUPLO, N, + $ ALPHA, INCX + IF( REWI ) + $ REWIND NTRA + CALL CDSPR( IORDER, UPLO, N, ALPHA, XX, INCX, AA ) + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9992 ) + FATAL = .TRUE. + GO TO 120 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = UPLO.EQ.UPLOS + ISAME( 2 ) = NS.EQ.N + ISAME( 3 ) = ALS.EQ.ALPHA + ISAME( 4 ) = LDE( XS, XX, LX ) + ISAME( 5 ) = INCXS.EQ.INCX + IF( NULL )THEN + ISAME( 6 ) = LDE( AS, AA, LAA ) + ELSE + ISAME( 6 ) = LDERES( SNAME( 8: 9 ), UPLO, N, N, AS, + $ AA, LDA ) + END IF + IF( .NOT.PACKED )THEN + ISAME( 7 ) = LDAS.EQ.LDA + END IF +* +* If data was incorrectly changed, report and return. +* + SAME = .TRUE. + DO 30 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 30 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 120 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result column by column. +* + IF( INCX.GT.0 )THEN + DO 40 I = 1, N + Z( I ) = X( I ) + 40 CONTINUE + ELSE + DO 50 I = 1, N + Z( I ) = X( N - I + 1 ) + 50 CONTINUE + END IF + JA = 1 + DO 60 J = 1, N + W( 1 ) = Z( J ) + IF( UPPER )THEN + JJ = 1 + LJ = J + ELSE + JJ = J + LJ = N - J + 1 + END IF + CALL DMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W, + $ 1, ONE, A( JJ, J ), 1, YT, G, + $ AA( JA ), EPS, ERR, FATAL, NOUT, + $ .TRUE. ) + IF( FULL )THEN + IF( UPPER )THEN + JA = JA + LDA + ELSE + JA = JA + LDA + 1 + END IF + ELSE + JA = JA + LJ + END IF + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and return. + IF( FATAL ) + $ GO TO 110 + 60 CONTINUE + ELSE +* Avoid repeating tests if N.le.0. + IF( N.LE.0 ) + $ GO TO 100 + END IF +* + 70 CONTINUE +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 130 +* + 110 CONTINUE + WRITE( NOUT, FMT = 9995 )J +* + 120 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + IF( FULL )THEN + WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, N, ALPHA, INCX, LDA + ELSE IF( PACKED )THEN + WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, N, ALPHA, INCX + END IF +* + 130 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, + $ ' - SUSPECT *******' ) + 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) + 9994 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', X,', + $ I2, ', AP) .' ) + 9993 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', X,', + $ I2, ', A,', I3, ') .' ) + 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of DCHK5. +* + END + SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, + $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, + $ Z, IORDER ) +* +* Tests DSYR2 and DSPR2. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) +* .. Scalar Arguments .. + DOUBLE PRECISION EPS, THRESH + INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA, + $ IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), + $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), + $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), + $ YY( NMAX*INCMAX ), Z( NMAX, 2 ) + INTEGER IDIM( NIDIM ), INC( NINC ) +* .. Local Scalars .. + DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX, TRANSL + INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX, + $ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N, + $ NARGS, NC, NS + LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER + CHARACTER*1 UPLO, UPLOS + CHARACTER*14 CUPLO + CHARACTER*2 ICH +* .. Local Arrays .. + DOUBLE PRECISION W( 2 ) + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LDE, LDERES + EXTERNAL LDE, LDERES +* .. External Subroutines .. + EXTERNAL DMAKE, DMVCH, CDSPR2, CDSYR2 +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICH/'UL'/ +* .. Executable Statements .. + FULL = SNAME( 9: 9 ).EQ.'y' + PACKED = SNAME( 9: 9 ).EQ.'p' +* Define the number of arguments. + IF( FULL )THEN + NARGS = 9 + ELSE IF( PACKED )THEN + NARGS = 8 + END IF +* + NC = 0 + RESET = .TRUE. + ERRMAX = ZERO +* + DO 140 IN = 1, NIDIM + N = IDIM( IN ) +* Set LDA to 1 more than minimum value if room. + LDA = N + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 140 + IF( PACKED )THEN + LAA = ( N*( N + 1 ) )/2 + ELSE + LAA = LDA*N + END IF +* + DO 130 IC = 1, 2 + UPLO = ICH( IC: IC ) + IF (UPLO.EQ.'U')THEN + CUPLO = ' CblasUpper' + ELSE + CUPLO = ' CblasLower' + END IF + UPPER = UPLO.EQ.'U' +* + DO 120 IX = 1, NINC + INCX = INC( IX ) + LX = ABS( INCX )*N +* +* Generate the vector X. +* + TRANSL = HALF + CALL DMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), + $ 0, N - 1, RESET, TRANSL ) + IF( N.GT.1 )THEN + X( N/2 ) = ZERO + XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO + END IF +* + DO 110 IY = 1, NINC + INCY = INC( IY ) + LY = ABS( INCY )*N +* +* Generate the vector Y. +* + TRANSL = ZERO + CALL DMAKE( 'ge', ' ', ' ', 1, N, Y, 1, YY, + $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) + IF( N.GT.1 )THEN + Y( N/2 ) = ZERO + YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO + END IF +* + DO 100 IA = 1, NALF + ALPHA = ALF( IA ) + NULL = N.LE.0.OR.ALPHA.EQ.ZERO +* +* Generate the matrix A. +* + TRANSL = ZERO + CALL DMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, A, + $ NMAX, AA, LDA, N - 1, N - 1, RESET, + $ TRANSL ) +* + NC = NC + 1 +* +* Save every datum before calling the subroutine. +* + UPLOS = UPLO + NS = N + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LX + XS( I ) = XX( I ) + 20 CONTINUE + INCXS = INCX + DO 30 I = 1, LY + YS( I ) = YY( I ) + 30 CONTINUE + INCYS = INCY +* +* Call the subroutine. +* + IF( FULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, CUPLO, N, + $ ALPHA, INCX, INCY, LDA + IF( REWI ) + $ REWIND NTRA + CALL CDSYR2( IORDER, UPLO, N, ALPHA, XX, INCX, + $ YY, INCY, AA, LDA ) + ELSE IF( PACKED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9994 )NC, SNAME, CUPLO, N, + $ ALPHA, INCX, INCY + IF( REWI ) + $ REWIND NTRA + CALL CDSPR2( IORDER, UPLO, N, ALPHA, XX, INCX, + $ YY, INCY, AA ) + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9992 ) + FATAL = .TRUE. + GO TO 160 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = UPLO.EQ.UPLOS + ISAME( 2 ) = NS.EQ.N + ISAME( 3 ) = ALS.EQ.ALPHA + ISAME( 4 ) = LDE( XS, XX, LX ) + ISAME( 5 ) = INCXS.EQ.INCX + ISAME( 6 ) = LDE( YS, YY, LY ) + ISAME( 7 ) = INCYS.EQ.INCY + IF( NULL )THEN + ISAME( 8 ) = LDE( AS, AA, LAA ) + ELSE + ISAME( 8 ) = LDERES( SNAME( 8: 9 ), UPLO, N, N, + $ AS, AA, LDA ) + END IF + IF( .NOT.PACKED )THEN + ISAME( 9 ) = LDAS.EQ.LDA + END IF +* +* If data was incorrectly changed, report and return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 160 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result column by column. +* + IF( INCX.GT.0 )THEN + DO 50 I = 1, N + Z( I, 1 ) = X( I ) + 50 CONTINUE + ELSE + DO 60 I = 1, N + Z( I, 1 ) = X( N - I + 1 ) + 60 CONTINUE + END IF + IF( INCY.GT.0 )THEN + DO 70 I = 1, N + Z( I, 2 ) = Y( I ) + 70 CONTINUE + ELSE + DO 80 I = 1, N + Z( I, 2 ) = Y( N - I + 1 ) + 80 CONTINUE + END IF + JA = 1 + DO 90 J = 1, N + W( 1 ) = Z( J, 2 ) + W( 2 ) = Z( J, 1 ) + IF( UPPER )THEN + JJ = 1 + LJ = J + ELSE + JJ = J + LJ = N - J + 1 + END IF + CALL DMVCH( 'N', LJ, 2, ALPHA, Z( JJ, 1 ), + $ NMAX, W, 1, ONE, A( JJ, J ), 1, + $ YT, G, AA( JA ), EPS, ERR, FATAL, + $ NOUT, .TRUE. ) + IF( FULL )THEN + IF( UPPER )THEN + JA = JA + LDA + ELSE + JA = JA + LDA + 1 + END IF + ELSE + JA = JA + LJ + END IF + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and return. + IF( FATAL ) + $ GO TO 150 + 90 CONTINUE + ELSE +* Avoid repeating tests with N.le.0. + IF( N.LE.0 ) + $ GO TO 140 + END IF +* + 100 CONTINUE +* + 110 CONTINUE +* + 120 CONTINUE +* + 130 CONTINUE +* + 140 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 170 +* + 150 CONTINUE + WRITE( NOUT, FMT = 9995 )J +* + 160 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + IF( FULL )THEN + WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, N, ALPHA, INCX, + $ INCY, LDA + ELSE IF( PACKED )THEN + WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, N, ALPHA, INCX, INCY + END IF +* + 170 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, + $ ' - SUSPECT *******' ) + 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) + 9994 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', X,', + $ I2, ', Y,', I2, ', AP) .' ) + 9993 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', X,', + $ I2, ', Y,', I2, ', A,', I3, ') .' ) + 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of DCHK6. +* + END + SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, + $ KU, RESET, TRANSL ) +* +* Generates values for an M by N matrix A within the bandwidth +* defined by KL and KU. +* Stores the values in the array AA in the data structure required +* by the routine, with unwanted elements set to rogue value. +* +* TYPE is 'ge', 'gb', 'sy', 'sb', 'sp', 'tr', 'tb' OR 'tp'. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + DOUBLE PRECISION ROGUE + PARAMETER ( ROGUE = -1.0D10 ) +* .. Scalar Arguments .. + DOUBLE PRECISION TRANSL + INTEGER KL, KU, LDA, M, N, NMAX + LOGICAL RESET + CHARACTER*1 DIAG, UPLO + CHARACTER*2 TYPE +* .. Array Arguments .. + DOUBLE PRECISION A( NMAX, * ), AA( * ) +* .. Local Scalars .. + INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, KK + LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER +* .. External Functions .. + DOUBLE PRECISION DBEG + EXTERNAL DBEG +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. Executable Statements .. + GEN = TYPE( 1: 1 ).EQ.'g' + SYM = TYPE( 1: 1 ).EQ.'s' + TRI = TYPE( 1: 1 ).EQ.'t' + UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U' + LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L' + UNIT = TRI.AND.DIAG.EQ.'U' +* +* Generate data in array A. +* + DO 20 J = 1, N + DO 10 I = 1, M + IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) + $ THEN + IF( ( I.LE.J.AND.J - I.LE.KU ).OR. + $ ( I.GE.J.AND.I - J.LE.KL ) )THEN + A( I, J ) = DBEG( RESET ) + TRANSL + ELSE + A( I, J ) = ZERO + END IF + IF( I.NE.J )THEN + IF( SYM )THEN + A( J, I ) = A( I, J ) + ELSE IF( TRI )THEN + A( J, I ) = ZERO + END IF + END IF + END IF + 10 CONTINUE + IF( TRI ) + $ A( J, J ) = A( J, J ) + ONE + IF( UNIT ) + $ A( J, J ) = ONE + 20 CONTINUE +* +* Store elements in array AS in data structure required by routine. +* + IF( TYPE.EQ.'ge' )THEN + DO 50 J = 1, N + DO 30 I = 1, M + AA( I + ( J - 1 )*LDA ) = A( I, J ) + 30 CONTINUE + DO 40 I = M + 1, LDA + AA( I + ( J - 1 )*LDA ) = ROGUE + 40 CONTINUE + 50 CONTINUE + ELSE IF( TYPE.EQ.'gb' )THEN + DO 90 J = 1, N + DO 60 I1 = 1, KU + 1 - J + AA( I1 + ( J - 1 )*LDA ) = ROGUE + 60 CONTINUE + DO 70 I2 = I1, MIN( KL + KU + 1, KU + 1 + M - J ) + AA( I2 + ( J - 1 )*LDA ) = A( I2 + J - KU - 1, J ) + 70 CONTINUE + DO 80 I3 = I2, LDA + AA( I3 + ( J - 1 )*LDA ) = ROGUE + 80 CONTINUE + 90 CONTINUE + ELSE IF( TYPE.EQ.'sy'.OR.TYPE.EQ.'tr' )THEN + DO 130 J = 1, N + IF( UPPER )THEN + IBEG = 1 + IF( UNIT )THEN + IEND = J - 1 + ELSE + IEND = J + END IF + ELSE + IF( UNIT )THEN + IBEG = J + 1 + ELSE + IBEG = J + END IF + IEND = N + END IF + DO 100 I = 1, IBEG - 1 + AA( I + ( J - 1 )*LDA ) = ROGUE + 100 CONTINUE + DO 110 I = IBEG, IEND + AA( I + ( J - 1 )*LDA ) = A( I, J ) + 110 CONTINUE + DO 120 I = IEND + 1, LDA + AA( I + ( J - 1 )*LDA ) = ROGUE + 120 CONTINUE + 130 CONTINUE + ELSE IF( TYPE.EQ.'sb'.OR.TYPE.EQ.'tb' )THEN + DO 170 J = 1, N + IF( UPPER )THEN + KK = KL + 1 + IBEG = MAX( 1, KL + 2 - J ) + IF( UNIT )THEN + IEND = KL + ELSE + IEND = KL + 1 + END IF + ELSE + KK = 1 + IF( UNIT )THEN + IBEG = 2 + ELSE + IBEG = 1 + END IF + IEND = MIN( KL + 1, 1 + M - J ) + END IF + DO 140 I = 1, IBEG - 1 + AA( I + ( J - 1 )*LDA ) = ROGUE + 140 CONTINUE + DO 150 I = IBEG, IEND + AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J ) + 150 CONTINUE + DO 160 I = IEND + 1, LDA + AA( I + ( J - 1 )*LDA ) = ROGUE + 160 CONTINUE + 170 CONTINUE + ELSE IF( TYPE.EQ.'sp'.OR.TYPE.EQ.'tp' )THEN + IOFF = 0 + DO 190 J = 1, N + IF( UPPER )THEN + IBEG = 1 + IEND = J + ELSE + IBEG = J + IEND = N + END IF + DO 180 I = IBEG, IEND + IOFF = IOFF + 1 + AA( IOFF ) = A( I, J ) + IF( I.EQ.J )THEN + IF( UNIT ) + $ AA( IOFF ) = ROGUE + END IF + 180 CONTINUE + 190 CONTINUE + END IF + RETURN +* +* End of DMAKE. +* + END + SUBROUTINE DMVCH( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y, + $ INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV ) +* +* Checks the results of the computational tests. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, BETA, EPS, ERR + INTEGER INCX, INCY, M, N, NMAX, NOUT + LOGICAL FATAL, MV + CHARACTER*1 TRANS +* .. Array Arguments .. + DOUBLE PRECISION A( NMAX, * ), G( * ), X( * ), Y( * ), YT( * ), + $ YY( * ) +* .. Local Scalars .. + DOUBLE PRECISION ERRI + INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL + LOGICAL TRAN +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. Executable Statements .. + TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' + IF( TRAN )THEN + ML = N + NL = M + ELSE + ML = M + NL = N + END IF + IF( INCX.LT.0 )THEN + KX = NL + INCXL = -1 + ELSE + KX = 1 + INCXL = 1 + END IF + IF( INCY.LT.0 )THEN + KY = ML + INCYL = -1 + ELSE + KY = 1 + INCYL = 1 + END IF +* +* Compute expected result in YT using data in A, X and Y. +* Compute gauges in G. +* + IY = KY + DO 30 I = 1, ML + YT( IY ) = ZERO + G( IY ) = ZERO + JX = KX + IF( TRAN )THEN + DO 10 J = 1, NL + YT( IY ) = YT( IY ) + A( J, I )*X( JX ) + G( IY ) = G( IY ) + ABS( A( J, I )*X( JX ) ) + JX = JX + INCXL + 10 CONTINUE + ELSE + DO 20 J = 1, NL + YT( IY ) = YT( IY ) + A( I, J )*X( JX ) + G( IY ) = G( IY ) + ABS( A( I, J )*X( JX ) ) + JX = JX + INCXL + 20 CONTINUE + END IF + YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY ) + G( IY ) = ABS( ALPHA )*G( IY ) + ABS( BETA*Y( IY ) ) + IY = IY + INCYL + 30 CONTINUE +* +* Compute the error ratio for this result. +* + ERR = ZERO + DO 40 I = 1, ML + ERRI = ABS( YT( I ) - YY( 1 + ( I - 1 )*ABS( INCY ) ) )/EPS + IF( G( I ).NE.ZERO ) + $ ERRI = ERRI/G( I ) + ERR = MAX( ERR, ERRI ) + IF( ERR*SQRT( EPS ).GE.ONE ) + $ GO TO 50 + 40 CONTINUE +* If the loop completes, all results are at least half accurate. + GO TO 70 +* +* Report fatal error. +* + 50 FATAL = .TRUE. + WRITE( NOUT, FMT = 9999 ) + DO 60 I = 1, ML + IF( MV )THEN + WRITE( NOUT, FMT = 9998 )I, YT( I ), + $ YY( 1 + ( I - 1 )*ABS( INCY ) ) + ELSE + WRITE( NOUT, FMT = 9998 )I, + $ YY( 1 + ( I - 1 )*ABS( INCY ) ), YT(I) + END IF + 60 CONTINUE +* + 70 CONTINUE + RETURN +* + 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', + $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU', + $ 'TED RESULT' ) + 9998 FORMAT( 1X, I7, 2G18.6 ) +* +* End of DMVCH. +* + END + LOGICAL FUNCTION LDE( RI, RJ, LR ) +* +* Tests if two arrays are identical. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Scalar Arguments .. + INTEGER LR +* .. Array Arguments .. + DOUBLE PRECISION RI( * ), RJ( * ) +* .. Local Scalars .. + INTEGER I +* .. Executable Statements .. + DO 10 I = 1, LR + IF( RI( I ).NE.RJ( I ) ) + $ GO TO 20 + 10 CONTINUE + LDE = .TRUE. + GO TO 30 + 20 CONTINUE + LDE = .FALSE. + 30 RETURN +* +* End of LDE. +* + END + LOGICAL FUNCTION LDERES( TYPE, UPLO, M, N, AA, AS, LDA ) +* +* Tests if selected elements in two arrays are equal. +* +* TYPE is 'ge', 'sy' or 'sp'. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Scalar Arguments .. + INTEGER LDA, M, N + CHARACTER*1 UPLO + CHARACTER*2 TYPE +* .. Array Arguments .. + DOUBLE PRECISION AA( LDA, * ), AS( LDA, * ) +* .. Local Scalars .. + INTEGER I, IBEG, IEND, J + LOGICAL UPPER +* .. Executable Statements .. + UPPER = UPLO.EQ.'U' + IF( TYPE.EQ.'ge' )THEN + DO 20 J = 1, N + DO 10 I = M + 1, LDA + IF( AA( I, J ).NE.AS( I, J ) ) + $ GO TO 70 + 10 CONTINUE + 20 CONTINUE + ELSE IF( TYPE.EQ.'sy' )THEN + DO 50 J = 1, N + IF( UPPER )THEN + IBEG = 1 + IEND = J + ELSE + IBEG = J + IEND = N + END IF + DO 30 I = 1, IBEG - 1 + IF( AA( I, J ).NE.AS( I, J ) ) + $ GO TO 70 + 30 CONTINUE + DO 40 I = IEND + 1, LDA + IF( AA( I, J ).NE.AS( I, J ) ) + $ GO TO 70 + 40 CONTINUE + 50 CONTINUE + END IF +* + 60 CONTINUE + LDERES = .TRUE. + GO TO 80 + 70 CONTINUE + LDERES = .FALSE. + 80 RETURN +* +* End of LDERES. +* + END + DOUBLE PRECISION FUNCTION DBEG( RESET ) +* +* Generates random numbers uniformly distributed between -0.5 and 0.5. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Scalar Arguments .. + LOGICAL RESET +* .. Local Scalars .. + INTEGER I, IC, MI +* .. Save statement .. + SAVE I, IC, MI +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. Executable Statements .. + IF( RESET )THEN +* Initialize local variables. + MI = 891 + I = 7 + IC = 0 + RESET = .FALSE. + END IF +* +* The sequence of values of I is bounded between 1 and 999. +* If initial I = 1,2,3,6,7 or 9, the period will be 50. +* If initial I = 4 or 8, the period will be 25. +* If initial I = 5, the period will be 10. +* IC is used to break up the period by skipping 1 value of I in 6. +* + IC = IC + 1 + 10 I = I*MI + I = I - 1000*( I/1000 ) + IF( IC.GE.5 )THEN + IC = 0 + GO TO 10 + END IF + DBEG = DBLE( I - 500 )/1001.0D0 + RETURN +* +* End of DBEG. +* + END + DOUBLE PRECISION FUNCTION DDIFF( X, Y ) +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* +* .. Scalar Arguments .. + DOUBLE PRECISION X, Y +* .. Executable Statements .. + DDIFF = X - Y + RETURN +* +* End of DDIFF. +* + END diff --git a/cblas/testing/c_dblat3.f b/cblas/testing/c_dblat3.f new file mode 100644 index 00000000..fb9acbb9 --- /dev/null +++ b/cblas/testing/c_dblat3.f @@ -0,0 +1,2475 @@ + PROGRAM DBLAT3 +* +* 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 .. + INTEGER NIN, NOUT + PARAMETER ( NIN = 5, NOUT = 6 ) + INTEGER NSUBS + PARAMETER ( NSUBS = 6 ) + DOUBLE PRECISION ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) + INTEGER NMAX + PARAMETER ( NMAX = 65 ) + INTEGER NIDMAX, NALMAX, NBEMAX + PARAMETER ( NIDMAX = 9, NALMAX = 7, NBEMAX = 7 ) +* .. Local Scalars .. + DOUBLE PRECISION EPS, ERR, THRESH + INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NTRA, + $ LAYOUT + LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, + $ TSTERR, CORDER, RORDER + CHARACTER*1 TRANSA, TRANSB + CHARACTER*12 SNAMET + CHARACTER*32 SNAPS +* .. Local Arrays .. + DOUBLE PRECISION AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ), + $ ALF( NALMAX ), AS( NMAX*NMAX ), + $ BB( NMAX*NMAX ), BET( NBEMAX ), + $ BS( NMAX*NMAX ), C( NMAX, NMAX ), + $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), + $ G( NMAX ), W( 2*NMAX ) + INTEGER IDIM( NIDMAX ) + LOGICAL LTEST( NSUBS ) + CHARACTER*12 SNAMES( NSUBS ) +* .. External Functions .. + DOUBLE PRECISION DDIFF + LOGICAL LDE + EXTERNAL DDIFF, LDE +* .. External Subroutines .. + EXTERNAL DCHK1, DCHK2, DCHK3, DCHK4, DCHK5, CD3CHKE, + $ DMMCH +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK + CHARACTER*12 SRNAMT +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK + COMMON /SRNAMC/SRNAMT +* .. Data statements .. + DATA SNAMES/'cblas_dgemm ', 'cblas_dsymm ', + $ 'cblas_dtrmm ', 'cblas_dtrsm ','cblas_dsyrk ', + $ 'cblas_dsyr2k'/ +* .. Executable Statements .. +* +* Read name and unit number for summary output file and open file. +* + NOUTC = NOUT +* Read name and unit number for snapshot output file and open file. +* + READ( NIN, FMT = * )SNAPS + READ( NIN, FMT = * )NTRA + TRACE = NTRA.GE.0 + IF( TRACE )THEN + OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' ) + END IF +* Read the flag that directs rewinding of the snapshot file. + READ( NIN, FMT = * )REWI + REWI = REWI.AND.TRACE +* Read the flag that directs stopping on any failure. + READ( NIN, FMT = * )SFATAL +* Read the flag that indicates whether error exits are to be tested. + READ( NIN, FMT = * )TSTERR +* Read the flag that indicates whether row-major data layout to be tested. + READ( NIN, FMT = * )LAYOUT +* Read the threshold value of the test ratio + READ( NIN, FMT = * )THRESH +* +* Read and check the parameter values for the tests. +* +* Values of N + READ( NIN, FMT = * )NIDIM + IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN + WRITE( NOUT, FMT = 9997 )'N', NIDMAX + GO TO 220 + END IF + READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) + DO 10 I = 1, NIDIM + IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN + WRITE( NOUT, FMT = 9996 )NMAX + GO TO 220 + END IF + 10 CONTINUE +* Values of ALPHA + READ( NIN, FMT = * )NALF + IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN + WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX + GO TO 220 + END IF + READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) +* Values of BETA + READ( NIN, FMT = * )NBET + IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN + WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX + GO TO 220 + END IF + READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) +* +* Report values of parameters. +* + WRITE( NOUT, FMT = 9995 ) + WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM ) + WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF ) + WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET ) + IF( .NOT.TSTERR )THEN + WRITE( NOUT, FMT = * ) + WRITE( NOUT, FMT = 9984 ) + END IF + WRITE( NOUT, FMT = * ) + WRITE( NOUT, FMT = 9999 )THRESH + WRITE( NOUT, FMT = * ) + + RORDER = .FALSE. + CORDER = .FALSE. + IF (LAYOUT.EQ.2) THEN + RORDER = .TRUE. + CORDER = .TRUE. + WRITE( *, FMT = 10002 ) + ELSE IF (LAYOUT.EQ.1) THEN + RORDER = .TRUE. + WRITE( *, FMT = 10001 ) + ELSE IF (LAYOUT.EQ.0) THEN + CORDER = .TRUE. + WRITE( *, FMT = 10000 ) + END IF + WRITE( *, FMT = * ) + +* +* Read names of subroutines and flags which indicate +* whether they are to be tested. +* + DO 20 I = 1, NSUBS + LTEST( I ) = .FALSE. + 20 CONTINUE + 30 READ( NIN, FMT = 9988, END = 60 )SNAMET, LTESTT + DO 40 I = 1, NSUBS + IF( SNAMET.EQ.SNAMES( I ) ) + $ GO TO 50 + 40 CONTINUE + WRITE( NOUT, FMT = 9990 )SNAMET + STOP + 50 LTEST( I ) = LTESTT + GO TO 30 +* + 60 CONTINUE + CLOSE ( NIN ) +* +* Compute EPS (the machine precision). +* + EPS = ONE + 70 CONTINUE + IF( DDIFF( ONE + EPS, ONE ).EQ.ZERO ) + $ GO TO 80 + EPS = HALF*EPS + GO TO 70 + 80 CONTINUE + EPS = EPS + EPS + WRITE( NOUT, FMT = 9998 )EPS +* +* Check the reliability of DMMCH using exact data. +* + N = MIN( 32, NMAX ) + DO 100 J = 1, N + DO 90 I = 1, N + AB( I, J ) = MAX( I - J + 1, 0 ) + 90 CONTINUE + AB( J, NMAX + 1 ) = J + AB( 1, NMAX + J ) = J + C( J, 1 ) = ZERO + 100 CONTINUE + DO 110 J = 1, N + CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 + 110 CONTINUE +* CC holds the exact result. On exit from DMMCH CT holds +* the result computed by DMMCH. + TRANSA = 'N' + TRANSB = 'N' + CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, + $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, + $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) + SAME = LDE( CC, CT, N ) + IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN + WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR + STOP + END IF + TRANSB = 'T' + CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, + $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, + $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) + SAME = LDE( CC, CT, N ) + IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN + WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR + STOP + END IF + DO 120 J = 1, N + AB( J, NMAX + 1 ) = N - J + 1 + AB( 1, NMAX + J ) = N - J + 1 + 120 CONTINUE + DO 130 J = 1, N + CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 - + $ ( ( J + 1 )*J*( J - 1 ) )/3 + 130 CONTINUE + TRANSA = 'T' + TRANSB = 'N' + CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, + $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, + $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) + SAME = LDE( CC, CT, N ) + IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN + WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR + STOP + END IF + TRANSB = 'T' + CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, + $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, + $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) + SAME = LDE( CC, CT, N ) + IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN + WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR + STOP + END IF +* +* Test each subroutine in turn. +* + DO 200 ISNUM = 1, NSUBS + WRITE( NOUT, FMT = * ) + IF( .NOT.LTEST( ISNUM ) )THEN +* Subprogram is not to be tested. + WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM ) + ELSE + SRNAMT = SNAMES( ISNUM ) +* Test error exits. + IF( TSTERR )THEN + CALL CD3CHKE( SNAMES( ISNUM ) ) + WRITE( NOUT, FMT = * ) + END IF +* Test computations. + INFOT = 0 + OK = .TRUE. + FATAL = .FALSE. + GO TO ( 140, 150, 160, 160, 170, 180 )ISNUM +* Test DGEMM, 01. + 140 IF (CORDER) THEN + CALL DCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, + $ CC, CS, CT, G, 0 ) + END IF + IF (RORDER) THEN + CALL DCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, + $ CC, CS, CT, G, 1 ) + END IF + GO TO 190 +* Test DSYMM, 02. + 150 IF (CORDER) THEN + CALL DCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, + $ CC, CS, CT, G, 0 ) + END IF + IF (RORDER) THEN + CALL DCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, + $ CC, CS, CT, G, 1 ) + END IF + GO TO 190 +* Test DTRMM, 03, DTRSM, 04. + 160 IF (CORDER) THEN + CALL DCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB, + $ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C, + $ 0 ) + END IF + IF (RORDER) THEN + CALL DCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB, + $ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C, + $ 1 ) + END IF + GO TO 190 +* Test DSYRK, 05. + 170 IF (CORDER) THEN + CALL DCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, + $ CC, CS, CT, G, 0 ) + END IF + IF (RORDER) THEN + CALL DCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, + $ CC, CS, CT, G, 1 ) + END IF + GO TO 190 +* Test DSYR2K, 06. + 180 IF (CORDER) THEN + CALL DCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W, + $ 0 ) + END IF + IF (RORDER) THEN + CALL DCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W, + $ 1 ) + END IF + GO TO 190 +* + 190 IF( FATAL.AND.SFATAL ) + $ GO TO 210 + END IF + 200 CONTINUE + WRITE( NOUT, FMT = 9986 ) + GO TO 230 +* + 210 CONTINUE + WRITE( NOUT, FMT = 9985 ) + GO TO 230 +* + 220 CONTINUE + WRITE( NOUT, FMT = 9991 ) +* + 230 CONTINUE + IF( TRACE ) + $ CLOSE ( NTRA ) + CLOSE ( NOUT ) + STOP +* +10002 FORMAT( ' COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED' ) +10001 FORMAT( ' ROW-MAJOR DATA LAYOUT IS TESTED' ) +10000 FORMAT( ' COLUMN-MAJOR DATA LAYOUT IS TESTED' ) + 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', + $ 'S THAN', F8.2 ) + 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, D9.1 ) + 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', + $ 'THAN ', I2 ) + 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) + 9995 FORMAT( ' TESTS OF THE DOUBLE PRECISION LEVEL 3 BLAS', //' THE F', + $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) + 9994 FORMAT( ' FOR N ', 9I6 ) + 9993 FORMAT( ' FOR ALPHA ', 7F6.1 ) + 9992 FORMAT( ' FOR BETA ', 7F6.1 ) + 9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', + $ /' ******* TESTS ABANDONED *******' ) + 9990 FORMAT( ' SUBPROGRAM NAME ', A12,' NOT RECOGNIZED', /' ******* T', + $ 'ESTS ABANDONED *******' ) + 9989 FORMAT( ' ERROR IN DMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', + $ 'ATED WRONGLY.', /' DMMCH WAS CALLED WITH TRANSA = ', A1, + $ ' AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ', + $ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ', + $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ', + $ '*******' ) + 9988 FORMAT( A12,L2 ) + 9987 FORMAT( 1X, A12,' WAS NOT TESTED' ) + 9986 FORMAT( /' END OF TESTS' ) + 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) + 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) +* +* End of DBLAT3. +* + END + SUBROUTINE DCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, + $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G, IORDER) +* +* 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 .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +* .. Scalar Arguments .. + DOUBLE PRECISION EPS, THRESH + INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), B( NMAX, NMAX ), + $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), + $ C( NMAX, NMAX ), CC( NMAX*NMAX ), + $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX ) + INTEGER IDIM( NIDIM ) +* .. Local Scalars .. + DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX + INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA, + $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M, + $ MA, MB, MS, N, NA, NARGS, NB, NC, NS + LOGICAL NULL, RESET, SAME, TRANA, TRANB + CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB + CHARACTER*3 ICH +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LDE, LDERES + EXTERNAL LDE, LDERES +* .. External Subroutines .. + EXTERNAL CDGEMM, DMAKE, DMMCH +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICH/'NTC'/ +* .. Executable Statements .. +* + NARGS = 13 + NC = 0 + RESET = .TRUE. + ERRMAX = ZERO +* + DO 110 IM = 1, NIDIM + M = IDIM( IM ) +* + DO 100 IN = 1, NIDIM + N = IDIM( IN ) +* Set LDC to 1 more than minimum value if room. + LDC = M + IF( LDC.LT.NMAX ) + $ LDC = LDC + 1 +* Skip tests if not enough room. + IF( LDC.GT.NMAX ) + $ GO TO 100 + LCC = LDC*N + NULL = N.LE.0.OR.M.LE.0 +* + DO 90 IK = 1, NIDIM + K = IDIM( IK ) +* + DO 80 ICA = 1, 3 + TRANSA = ICH( ICA: ICA ) + TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' +* + IF( TRANA )THEN + MA = K + NA = M + ELSE + MA = M + NA = K + END IF +* Set LDA to 1 more than minimum value if room. + LDA = MA + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 80 + LAA = LDA*NA +* +* Generate the matrix A. +* + CALL DMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, + $ RESET, ZERO ) +* + DO 70 ICB = 1, 3 + TRANSB = ICH( ICB: ICB ) + TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' +* + IF( TRANB )THEN + MB = N + NB = K + ELSE + MB = K + NB = N + END IF +* Set LDB to 1 more than minimum value if room. + LDB = MB + IF( LDB.LT.NMAX ) + $ LDB = LDB + 1 +* Skip tests if not enough room. + IF( LDB.GT.NMAX ) + $ GO TO 70 + LBB = LDB*NB +* +* Generate the matrix B. +* + CALL DMAKE( 'GE', ' ', ' ', MB, NB, B, NMAX, BB, + $ LDB, RESET, ZERO ) +* + DO 60 IA = 1, NALF + ALPHA = ALF( IA ) +* + DO 50 IB = 1, NBET + BETA = BET( IB ) +* +* Generate the matrix C. +* + CALL DMAKE( 'GE', ' ', ' ', M, N, C, NMAX, + $ CC, LDC, RESET, ZERO ) +* + NC = NC + 1 +* +* Save every datum before calling the +* subroutine. +* + TRANAS = TRANSA + TRANBS = TRANSB + MS = M + NS = N + KS = K + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LBB + BS( I ) = BB( I ) + 20 CONTINUE + LDBS = LDB + BLS = BETA + DO 30 I = 1, LCC + CS( I ) = CC( I ) + 30 CONTINUE + LDCS = LDC +* +* Call the subroutine. +* + IF( TRACE ) + $ CALL DPRCN1(NTRA, NC, SNAME, IORDER, + $ TRANSA, TRANSB, M, N, K, ALPHA, LDA, + $ LDB, BETA, LDC) + IF( REWI ) + $ REWIND NTRA + CALL CDGEMM( IORDER, TRANSA, TRANSB, M, N, + $ K, ALPHA, AA, LDA, BB, LDB, + $ BETA, CC, LDC ) +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9994 ) + FATAL = .TRUE. + GO TO 120 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = TRANSA.EQ.TRANAS + ISAME( 2 ) = TRANSB.EQ.TRANBS + ISAME( 3 ) = MS.EQ.M + ISAME( 4 ) = NS.EQ.N + ISAME( 5 ) = KS.EQ.K + ISAME( 6 ) = ALS.EQ.ALPHA + ISAME( 7 ) = LDE( AS, AA, LAA ) + ISAME( 8 ) = LDAS.EQ.LDA + ISAME( 9 ) = LDE( BS, BB, LBB ) + ISAME( 10 ) = LDBS.EQ.LDB + ISAME( 11 ) = BLS.EQ.BETA + IF( NULL )THEN + ISAME( 12 ) = LDE( CS, CC, LCC ) + ELSE + ISAME( 12 ) = LDERES( 'GE', ' ', M, N, CS, + $ CC, LDC ) + END IF + ISAME( 13 ) = LDCS.EQ.LDC +* +* If data was incorrectly changed, report +* and return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 120 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result. +* + CALL DMMCH( TRANSA, TRANSB, M, N, K, + $ ALPHA, A, NMAX, B, NMAX, BETA, + $ C, NMAX, CT, G, CC, LDC, EPS, + $ ERR, FATAL, NOUT, .TRUE. ) + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and +* return. + IF( FATAL ) + $ GO TO 120 + END IF +* + 50 CONTINUE +* + 60 CONTINUE +* + 70 CONTINUE +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* + 110 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 130 +* + 120 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + CALL DPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, + $ M, N, K, ALPHA, LDA, LDB, BETA, LDC) +* + 130 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',', + $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ', + $ 'C,', I3, ').' ) + 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of DCHK1. +* + END + SUBROUTINE DPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, M, N, + $ K, ALPHA, LDA, LDB, BETA, LDC) + INTEGER NOUT, NC, IORDER, M, N, K, LDA, LDB, LDC + DOUBLE PRECISION ALPHA, BETA + CHARACTER*1 TRANSA, TRANSB + CHARACTER*12 SNAME + CHARACTER*14 CRC, CTA,CTB + + IF (TRANSA.EQ.'N')THEN + CTA = ' CblasNoTrans' + ELSE IF (TRANSA.EQ.'T')THEN + CTA = ' CblasTrans' + ELSE + CTA = 'CblasConjTrans' + END IF + IF (TRANSB.EQ.'N')THEN + CTB = ' CblasNoTrans' + ELSE IF (TRANSB.EQ.'T')THEN + CTB = ' CblasTrans' + ELSE + CTB = 'CblasConjTrans' + END IF + IF (IORDER.EQ.1)THEN + CRC = ' CblasRowMajor' + ELSE + CRC = ' CblasColMajor' + END IF + WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CTA,CTB + WRITE(NOUT, FMT = 9994)M, N, K, ALPHA, LDA, LDB, BETA, LDC + + 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',') + 9994 FORMAT( 20X, 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', + $ F4.1, ', ', 'C,', I3, ').' ) + END +* + SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, + $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G, IORDER) +* +* 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 .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +* .. Scalar Arguments .. + DOUBLE PRECISION EPS, THRESH + INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), B( NMAX, NMAX ), + $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), + $ C( NMAX, NMAX ), CC( NMAX*NMAX ), + $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX ) + INTEGER IDIM( NIDIM ) +* .. Local Scalars .. + DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX + INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC, + $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA, + $ NARGS, NC, NS + LOGICAL LEFT, NULL, RESET, SAME + CHARACTER*1 SIDE, SIDES, UPLO, UPLOS + CHARACTER*2 ICHS, ICHU +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LDE, LDERES + EXTERNAL LDE, LDERES +* .. External Subroutines .. + EXTERNAL DMAKE, DMMCH, CDSYMM +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICHS/'LR'/, ICHU/'UL'/ +* .. Executable Statements .. +* + NARGS = 12 + NC = 0 + RESET = .TRUE. + ERRMAX = ZERO +* + DO 100 IM = 1, NIDIM + M = IDIM( IM ) +* + DO 90 IN = 1, NIDIM + N = IDIM( IN ) +* Set LDC to 1 more than minimum value if room. + LDC = M + IF( LDC.LT.NMAX ) + $ LDC = LDC + 1 +* Skip tests if not enough room. + IF( LDC.GT.NMAX ) + $ GO TO 90 + LCC = LDC*N + NULL = N.LE.0.OR.M.LE.0 +* +* Set LDB to 1 more than minimum value if room. + LDB = M + IF( LDB.LT.NMAX ) + $ LDB = LDB + 1 +* Skip tests if not enough room. + IF( LDB.GT.NMAX ) + $ GO TO 90 + LBB = LDB*N +* +* Generate the matrix B. +* + CALL DMAKE( 'GE', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET, + $ ZERO ) +* + DO 80 ICS = 1, 2 + SIDE = ICHS( ICS: ICS ) + LEFT = SIDE.EQ.'L' +* + IF( LEFT )THEN + NA = M + ELSE + NA = N + END IF +* Set LDA to 1 more than minimum value if room. + LDA = NA + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 80 + LAA = LDA*NA +* + DO 70 ICU = 1, 2 + UPLO = ICHU( ICU: ICU ) +* +* Generate the symmetric matrix A. +* + CALL DMAKE( 'SY', UPLO, ' ', NA, NA, A, NMAX, AA, LDA, + $ RESET, ZERO ) +* + DO 60 IA = 1, NALF + ALPHA = ALF( IA ) +* + DO 50 IB = 1, NBET + BETA = BET( IB ) +* +* Generate the matrix C. +* + CALL DMAKE( 'GE', ' ', ' ', M, N, C, NMAX, CC, + $ LDC, RESET, ZERO ) +* + NC = NC + 1 +* +* Save every datum before calling the +* subroutine. +* + SIDES = SIDE + UPLOS = UPLO + MS = M + NS = N + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LBB + BS( I ) = BB( I ) + 20 CONTINUE + LDBS = LDB + BLS = BETA + DO 30 I = 1, LCC + CS( I ) = CC( I ) + 30 CONTINUE + LDCS = LDC +* +* Call the subroutine. +* + IF( TRACE ) + $ CALL DPRCN2(NTRA, NC, SNAME, IORDER, + $ SIDE, UPLO, M, N, ALPHA, LDA, LDB, + $ BETA, LDC) + IF( REWI ) + $ REWIND NTRA + CALL CDSYMM( IORDER, SIDE, UPLO, M, N, ALPHA, + $ AA, LDA, BB, LDB, BETA, CC, LDC ) +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9994 ) + FATAL = .TRUE. + GO TO 110 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = SIDES.EQ.SIDE + ISAME( 2 ) = UPLOS.EQ.UPLO + ISAME( 3 ) = MS.EQ.M + ISAME( 4 ) = NS.EQ.N + ISAME( 5 ) = ALS.EQ.ALPHA + ISAME( 6 ) = LDE( AS, AA, LAA ) + ISAME( 7 ) = LDAS.EQ.LDA + ISAME( 8 ) = LDE( BS, BB, LBB ) + ISAME( 9 ) = LDBS.EQ.LDB + ISAME( 10 ) = BLS.EQ.BETA + IF( NULL )THEN + ISAME( 11 ) = LDE( CS, CC, LCC ) + ELSE + ISAME( 11 ) = LDERES( 'GE', ' ', M, N, CS, + $ CC, LDC ) + END IF + ISAME( 12 ) = LDCS.EQ.LDC +* +* If data was incorrectly changed, report and +* return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 110 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result. +* + IF( LEFT )THEN + CALL DMMCH( 'N', 'N', M, N, M, ALPHA, A, + $ NMAX, B, NMAX, BETA, C, NMAX, + $ CT, G, CC, LDC, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + ELSE + CALL DMMCH( 'N', 'N', M, N, N, ALPHA, B, + $ NMAX, A, NMAX, BETA, C, NMAX, + $ CT, G, CC, LDC, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + END IF + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and +* return. + IF( FATAL ) + $ GO TO 110 + END IF +* + 50 CONTINUE +* + 60 CONTINUE +* + 70 CONTINUE +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 120 +* + 110 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + CALL DPRCN2(NOUT, NC, SNAME, IORDER, SIDE, UPLO, M, N, ALPHA, LDA, + $ LDB, BETA, LDC) +* + 120 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), + $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', + $ ' .' ) + 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of DCHK2. +* + END +* + SUBROUTINE DPRCN2(NOUT, NC, SNAME, IORDER, SIDE, UPLO, M, N, + $ ALPHA, LDA, LDB, BETA, LDC) + INTEGER NOUT, NC, IORDER, M, N, LDA, LDB, LDC + DOUBLE PRECISION ALPHA, BETA + CHARACTER*1 SIDE, UPLO + CHARACTER*12 SNAME + CHARACTER*14 CRC, CS,CU + + IF (SIDE.EQ.'L')THEN + CS = ' CblasLeft' + ELSE + CS = ' CblasRight' + END IF + IF (UPLO.EQ.'U')THEN + CU = ' CblasUpper' + ELSE + CU = ' CblasLower' + END IF + IF (IORDER.EQ.1)THEN + CRC = ' CblasRowMajor' + ELSE + CRC = ' CblasColMajor' + END IF + WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CS,CU + WRITE(NOUT, FMT = 9994)M, N, ALPHA, LDA, LDB, BETA, LDC + + 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',') + 9994 FORMAT( 20X, 2( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', + $ F4.1, ', ', 'C,', I3, ').' ) + END +* + SUBROUTINE DCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NMAX, A, AA, AS, + $ B, BB, BS, CT, G, C, IORDER ) +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. Scalar Arguments .. + DOUBLE PRECISION EPS, THRESH + INTEGER NALF, NIDIM, NMAX, NOUT, NTRA, IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), B( NMAX, NMAX ), + $ BB( NMAX*NMAX ), BS( NMAX*NMAX ), + $ C( NMAX, NMAX ), CT( NMAX ), G( NMAX ) + INTEGER IDIM( NIDIM ) +* .. Local Scalars .. + DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX + INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB, + $ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC, + $ NS + LOGICAL LEFT, NULL, RESET, SAME + CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO, + $ UPLOS + CHARACTER*2 ICHD, ICHS, ICHU + CHARACTER*3 ICHT +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LDE, LDERES + EXTERNAL LDE, LDERES +* .. External Subroutines .. + EXTERNAL DMAKE, DMMCH, CDTRMM, CDTRSM +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/, ICHS/'LR'/ +* .. Executable Statements .. +* + NARGS = 11 + NC = 0 + RESET = .TRUE. + ERRMAX = ZERO +* Set up zero matrix for DMMCH. + DO 20 J = 1, NMAX + DO 10 I = 1, NMAX + C( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE +* + DO 140 IM = 1, NIDIM + M = IDIM( IM ) +* + DO 130 IN = 1, NIDIM + N = IDIM( IN ) +* Set LDB to 1 more than minimum value if room. + LDB = M + IF( LDB.LT.NMAX ) + $ LDB = LDB + 1 +* Skip tests if not enough room. + IF( LDB.GT.NMAX ) + $ GO TO 130 + LBB = LDB*N + NULL = M.LE.0.OR.N.LE.0 +* + DO 120 ICS = 1, 2 + SIDE = ICHS( ICS: ICS ) + LEFT = SIDE.EQ.'L' + IF( LEFT )THEN + NA = M + ELSE + NA = N + END IF +* Set LDA to 1 more than minimum value if room. + LDA = NA + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 130 + LAA = LDA*NA +* + DO 110 ICU = 1, 2 + UPLO = ICHU( ICU: ICU ) +* + DO 100 ICT = 1, 3 + TRANSA = ICHT( ICT: ICT ) +* + DO 90 ICD = 1, 2 + DIAG = ICHD( ICD: ICD ) +* + DO 80 IA = 1, NALF + ALPHA = ALF( IA ) +* +* Generate the matrix A. +* + CALL DMAKE( 'TR', UPLO, DIAG, NA, NA, A, + $ NMAX, AA, LDA, RESET, ZERO ) +* +* Generate the matrix B. +* + CALL DMAKE( 'GE', ' ', ' ', M, N, B, NMAX, + $ BB, LDB, RESET, ZERO ) +* + NC = NC + 1 +* +* Save every datum before calling the +* subroutine. +* + SIDES = SIDE + UPLOS = UPLO + TRANAS = TRANSA + DIAGS = DIAG + MS = M + NS = N + ALS = ALPHA + DO 30 I = 1, LAA + AS( I ) = AA( I ) + 30 CONTINUE + LDAS = LDA + DO 40 I = 1, LBB + BS( I ) = BB( I ) + 40 CONTINUE + LDBS = LDB +* +* Call the subroutine. +* + IF( SNAME( 10: 11 ).EQ.'mm' )THEN + IF( TRACE ) + $ CALL DPRCN3( NTRA, NC, SNAME, IORDER, + $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, + $ LDA, LDB) + IF( REWI ) + $ REWIND NTRA + CALL CDTRMM( IORDER, SIDE, UPLO, TRANSA, + $ DIAG, M, N, ALPHA, AA, LDA, + $ BB, LDB ) + ELSE IF( SNAME( 10: 11 ).EQ.'sm' )THEN + IF( TRACE ) + $ CALL DPRCN3( NTRA, NC, SNAME, IORDER, + $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, + $ LDA, LDB) + IF( REWI ) + $ REWIND NTRA + CALL CDTRSM( IORDER, SIDE, UPLO, TRANSA, + $ DIAG, M, N, ALPHA, AA, LDA, + $ BB, LDB ) + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9994 ) + FATAL = .TRUE. + GO TO 150 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = SIDES.EQ.SIDE + ISAME( 2 ) = UPLOS.EQ.UPLO + ISAME( 3 ) = TRANAS.EQ.TRANSA + ISAME( 4 ) = DIAGS.EQ.DIAG + ISAME( 5 ) = MS.EQ.M + ISAME( 6 ) = NS.EQ.N + ISAME( 7 ) = ALS.EQ.ALPHA + ISAME( 8 ) = LDE( AS, AA, LAA ) + ISAME( 9 ) = LDAS.EQ.LDA + IF( NULL )THEN + ISAME( 10 ) = LDE( BS, BB, LBB ) + ELSE + ISAME( 10 ) = LDERES( 'GE', ' ', M, N, BS, + $ BB, LDB ) + END IF + ISAME( 11 ) = LDBS.EQ.LDB +* +* If data was incorrectly changed, report and +* return. +* + SAME = .TRUE. + DO 50 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 50 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 150 + END IF +* + IF( .NOT.NULL )THEN + IF( SNAME( 10: 11 ).EQ.'mm' )THEN +* +* Check the result. +* + IF( LEFT )THEN + CALL DMMCH( TRANSA, 'N', M, N, M, + $ ALPHA, A, NMAX, B, NMAX, + $ ZERO, C, NMAX, CT, G, + $ BB, LDB, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + ELSE + CALL DMMCH( 'N', TRANSA, M, N, N, + $ ALPHA, B, NMAX, A, NMAX, + $ ZERO, C, NMAX, CT, G, + $ BB, LDB, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + END IF + ELSE IF( SNAME( 10: 11 ).EQ.'sm' )THEN +* +* Compute approximation to original +* matrix. +* + DO 70 J = 1, N + DO 60 I = 1, M + C( I, J ) = BB( I + ( J - 1 )* + $ LDB ) + BB( I + ( J - 1 )*LDB ) = ALPHA* + $ B( I, J ) + 60 CONTINUE + 70 CONTINUE +* + IF( LEFT )THEN + CALL DMMCH( TRANSA, 'N', M, N, M, + $ ONE, A, NMAX, C, NMAX, + $ ZERO, B, NMAX, CT, G, + $ BB, LDB, EPS, ERR, + $ FATAL, NOUT, .FALSE. ) + ELSE + CALL DMMCH( 'N', TRANSA, M, N, N, + $ ONE, C, NMAX, A, NMAX, + $ ZERO, B, NMAX, CT, G, + $ BB, LDB, EPS, ERR, + $ FATAL, NOUT, .FALSE. ) + END IF + END IF + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and +* return. + IF( FATAL ) + $ GO TO 150 + END IF +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* + 110 CONTINUE +* + 120 CONTINUE +* + 130 CONTINUE +* + 140 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 160 +* + 150 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + CALL DPRCN3( NTRA, NC, SNAME, IORDER, SIDE, UPLO, TRANSA, DIAG, + $ M, N, ALPHA, LDA, LDB) +* + 160 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( I3, ',' ), + $ F4.1, ', A,', I3, ', B,', I3, ') .' ) + 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of DCHK3. +* + END +* + SUBROUTINE DPRCN3(NOUT, NC, SNAME, IORDER, SIDE, UPLO, TRANSA, + $ DIAG, M, N, ALPHA, LDA, LDB) + INTEGER NOUT, NC, IORDER, M, N, LDA, LDB + DOUBLE PRECISION ALPHA + CHARACTER*1 SIDE, UPLO, TRANSA, DIAG + CHARACTER*12 SNAME + CHARACTER*14 CRC, CS, CU, CA, CD + + IF (SIDE.EQ.'L')THEN + CS = ' CblasLeft' + ELSE + CS = ' CblasRight' + END IF + IF (UPLO.EQ.'U')THEN + CU = ' CblasUpper' + ELSE + CU = ' CblasLower' + END IF + IF (TRANSA.EQ.'N')THEN + CA = ' CblasNoTrans' + ELSE IF (TRANSA.EQ.'T')THEN + CA = ' CblasTrans' + ELSE + CA = 'CblasConjTrans' + END IF + IF (DIAG.EQ.'N')THEN + CD = ' CblasNonUnit' + ELSE + CD = ' CblasUnit' + END IF + IF (IORDER.EQ.1)THEN + CRC = ' CblasRowMajor' + ELSE + CRC = ' CblasColMajor' + END IF + WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CS,CU + WRITE(NOUT, FMT = 9994)CA, CD, M, N, ALPHA, LDA, LDB + + 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',') + 9994 FORMAT( 22X, 2( A14, ',') , 2( I3, ',' ), + $ F4.1, ', A,', I3, ', B,', I3, ').' ) + END +* + SUBROUTINE DCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, + $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G, IORDER) +* +* 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 .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +* .. Scalar Arguments .. + DOUBLE PRECISION EPS, THRESH + INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), B( NMAX, NMAX ), + $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), + $ C( NMAX, NMAX ), CC( NMAX*NMAX ), + $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX ) + INTEGER IDIM( NIDIM ) +* .. Local Scalars .. + DOUBLE PRECISION ALPHA, ALS, BETA, BETS, ERR, ERRMAX + INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS, + $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA, + $ NARGS, NC, NS + LOGICAL NULL, RESET, SAME, TRAN, UPPER + CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS + CHARACTER*2 ICHU + CHARACTER*3 ICHT +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LDE, LDERES + EXTERNAL LDE, LDERES +* .. External Subroutines .. + EXTERNAL DMAKE, DMMCH, CDSYRK +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICHT/'NTC'/, ICHU/'UL'/ +* .. Executable Statements .. +* + NARGS = 10 + NC = 0 + RESET = .TRUE. + ERRMAX = ZERO +* + DO 100 IN = 1, NIDIM + N = IDIM( IN ) +* Set LDC to 1 more than minimum value if room. + LDC = N + IF( LDC.LT.NMAX ) + $ LDC = LDC + 1 +* Skip tests if not enough room. + IF( LDC.GT.NMAX ) + $ GO TO 100 + LCC = LDC*N + NULL = N.LE.0 +* + DO 90 IK = 1, NIDIM + K = IDIM( IK ) +* + DO 80 ICT = 1, 3 + TRANS = ICHT( ICT: ICT ) + TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' + IF( TRAN )THEN + MA = K + NA = N + ELSE + MA = N + NA = K + END IF +* Set LDA to 1 more than minimum value if room. + LDA = MA + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 80 + LAA = LDA*NA +* +* Generate the matrix A. +* + CALL DMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, + $ RESET, ZERO ) +* + DO 70 ICU = 1, 2 + UPLO = ICHU( ICU: ICU ) + UPPER = UPLO.EQ.'U' +* + DO 60 IA = 1, NALF + ALPHA = ALF( IA ) +* + DO 50 IB = 1, NBET + BETA = BET( IB ) +* +* Generate the matrix C. +* + CALL DMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC, + $ LDC, RESET, ZERO ) +* + NC = NC + 1 +* +* Save every datum before calling the subroutine. +* + UPLOS = UPLO + TRANSS = TRANS + NS = N + KS = K + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + BETS = BETA + DO 20 I = 1, LCC + CS( I ) = CC( I ) + 20 CONTINUE + LDCS = LDC +* +* Call the subroutine. +* + IF( TRACE ) + $ CALL DPRCN4( NTRA, NC, SNAME, IORDER, UPLO, + $ TRANS, N, K, ALPHA, LDA, BETA, LDC) + IF( REWI ) + $ REWIND NTRA + CALL CDSYRK( IORDER, UPLO, TRANS, N, K, ALPHA, + $ AA, LDA, BETA, CC, LDC ) +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9993 ) + FATAL = .TRUE. + GO TO 120 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = UPLOS.EQ.UPLO + ISAME( 2 ) = TRANSS.EQ.TRANS + ISAME( 3 ) = NS.EQ.N + ISAME( 4 ) = KS.EQ.K + ISAME( 5 ) = ALS.EQ.ALPHA + ISAME( 6 ) = LDE( AS, AA, LAA ) + ISAME( 7 ) = LDAS.EQ.LDA + ISAME( 8 ) = BETS.EQ.BETA + IF( NULL )THEN + ISAME( 9 ) = LDE( CS, CC, LCC ) + ELSE + ISAME( 9 ) = LDERES( 'SY', UPLO, N, N, CS, + $ CC, LDC ) + END IF + ISAME( 10 ) = LDCS.EQ.LDC +* +* If data was incorrectly changed, report and +* return. +* + SAME = .TRUE. + DO 30 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 30 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 120 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result column by column. +* + JC = 1 + DO 40 J = 1, N + IF( UPPER )THEN + JJ = 1 + LJ = J + ELSE + JJ = J + LJ = N - J + 1 + END IF + IF( TRAN )THEN + CALL DMMCH( 'T', 'N', LJ, 1, K, ALPHA, + $ A( 1, JJ ), NMAX, + $ A( 1, J ), NMAX, BETA, + $ C( JJ, J ), NMAX, CT, G, + $ CC( JC ), LDC, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + ELSE + CALL DMMCH( 'N', 'T', LJ, 1, K, ALPHA, + $ A( JJ, 1 ), NMAX, + $ A( J, 1 ), NMAX, BETA, + $ C( JJ, J ), NMAX, CT, G, + $ CC( JC ), LDC, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + END IF + IF( UPPER )THEN + JC = JC + LDC + ELSE + JC = JC + LDC + 1 + END IF + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and +* return. + IF( FATAL ) + $ GO TO 110 + 40 CONTINUE + END IF +* + 50 CONTINUE +* + 60 CONTINUE +* + 70 CONTINUE +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 130 +* + 110 CONTINUE + IF( N.GT.1 ) + $ WRITE( NOUT, FMT = 9995 )J +* + 120 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + CALL DPRCN4( NOUT, NC, SNAME, IORDER, UPLO, TRANS, N, K, ALPHA, + $ LDA, BETA, LDC) +* + 130 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) + 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), + $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' ) + 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of DCHK4. +* + END +* + SUBROUTINE DPRCN4(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, + $ N, K, ALPHA, LDA, BETA, LDC) + INTEGER NOUT, NC, IORDER, N, K, LDA, LDC + DOUBLE PRECISION ALPHA, BETA + CHARACTER*1 UPLO, TRANSA + CHARACTER*12 SNAME + CHARACTER*14 CRC, CU, CA + + IF (UPLO.EQ.'U')THEN + CU = ' CblasUpper' + ELSE + CU = ' CblasLower' + END IF + IF (TRANSA.EQ.'N')THEN + CA = ' CblasNoTrans' + ELSE IF (TRANSA.EQ.'T')THEN + CA = ' CblasTrans' + ELSE + CA = 'CblasConjTrans' + END IF + IF (IORDER.EQ.1)THEN + CRC = ' CblasRowMajor' + ELSE + CRC = ' CblasColMajor' + END IF + WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA + WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, BETA, LDC + + 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') ) + 9994 FORMAT( 20X, 2( I3, ',' ), + $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ').' ) + END +* + SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, + $ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W, + $ IORDER ) +* +* 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 .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +* .. Scalar Arguments .. + DOUBLE PRECISION EPS, THRESH + INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + DOUBLE PRECISION AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ), + $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ), + $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ), + $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), + $ G( NMAX ), W( 2*NMAX ) + INTEGER IDIM( NIDIM ) +* .. Local Scalars .. + DOUBLE PRECISION ALPHA, ALS, BETA, BETS, ERR, ERRMAX + INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB, + $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS, + $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS + LOGICAL NULL, RESET, SAME, TRAN, UPPER + CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS + CHARACTER*2 ICHU + CHARACTER*3 ICHT +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LDE, LDERES + EXTERNAL LDE, LDERES +* .. External Subroutines .. + EXTERNAL DMAKE, DMMCH, CDSYR2K +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICHT/'NTC'/, ICHU/'UL'/ +* .. Executable Statements .. +* + NARGS = 12 + NC = 0 + RESET = .TRUE. + ERRMAX = ZERO +* + DO 130 IN = 1, NIDIM + N = IDIM( IN ) +* Set LDC to 1 more than minimum value if room. + LDC = N + IF( LDC.LT.NMAX ) + $ LDC = LDC + 1 +* Skip tests if not enough room. + IF( LDC.GT.NMAX ) + $ GO TO 130 + LCC = LDC*N + NULL = N.LE.0 +* + DO 120 IK = 1, NIDIM + K = IDIM( IK ) +* + DO 110 ICT = 1, 3 + TRANS = ICHT( ICT: ICT ) + TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' + IF( TRAN )THEN + MA = K + NA = N + ELSE + MA = N + NA = K + END IF +* Set LDA to 1 more than minimum value if room. + LDA = MA + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 110 + LAA = LDA*NA +* +* Generate the matrix A. +* + IF( TRAN )THEN + CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA, + $ LDA, RESET, ZERO ) + ELSE + CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA, + $ RESET, ZERO ) + END IF +* +* Generate the matrix B. +* + LDB = LDA + LBB = LAA + IF( TRAN )THEN + CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB( K + 1 ), + $ 2*NMAX, BB, LDB, RESET, ZERO ) + ELSE + CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ), + $ NMAX, BB, LDB, RESET, ZERO ) + END IF +* + DO 100 ICU = 1, 2 + UPLO = ICHU( ICU: ICU ) + UPPER = UPLO.EQ.'U' +* + DO 90 IA = 1, NALF + ALPHA = ALF( IA ) +* + DO 80 IB = 1, NBET + BETA = BET( IB ) +* +* Generate the matrix C. +* + CALL DMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC, + $ LDC, RESET, ZERO ) +* + NC = NC + 1 +* +* Save every datum before calling the subroutine. +* + UPLOS = UPLO + TRANSS = TRANS + NS = N + KS = K + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LBB + BS( I ) = BB( I ) + 20 CONTINUE + LDBS = LDB + BETS = BETA + DO 30 I = 1, LCC + CS( I ) = CC( I ) + 30 CONTINUE + LDCS = LDC +* +* Call the subroutine. +* + IF( TRACE ) + $ CALL DPRCN5( NTRA, NC, SNAME, IORDER, UPLO, + $ TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC) + IF( REWI ) + $ REWIND NTRA + CALL CDSYR2K( IORDER, UPLO, TRANS, N, K, + $ ALPHA, AA, LDA, BB, LDB, BETA, + $ CC, LDC ) +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9993 ) + FATAL = .TRUE. + GO TO 150 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = UPLOS.EQ.UPLO + ISAME( 2 ) = TRANSS.EQ.TRANS + ISAME( 3 ) = NS.EQ.N + ISAME( 4 ) = KS.EQ.K + ISAME( 5 ) = ALS.EQ.ALPHA + ISAME( 6 ) = LDE( AS, AA, LAA ) + ISAME( 7 ) = LDAS.EQ.LDA + ISAME( 8 ) = LDE( BS, BB, LBB ) + ISAME( 9 ) = LDBS.EQ.LDB + ISAME( 10 ) = BETS.EQ.BETA + IF( NULL )THEN + ISAME( 11 ) = LDE( CS, CC, LCC ) + ELSE + ISAME( 11 ) = LDERES( 'SY', UPLO, N, N, CS, + $ CC, LDC ) + END IF + ISAME( 12 ) = LDCS.EQ.LDC +* +* If data was incorrectly changed, report and +* return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 150 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result column by column. +* + JJAB = 1 + JC = 1 + DO 70 J = 1, N + IF( UPPER )THEN + JJ = 1 + LJ = J + ELSE + JJ = J + LJ = N - J + 1 + END IF + IF( TRAN )THEN + DO 50 I = 1, K + W( I ) = AB( ( J - 1 )*2*NMAX + K + + $ I ) + W( K + I ) = AB( ( J - 1 )*2*NMAX + + $ I ) + 50 CONTINUE + CALL DMMCH( 'T', 'N', LJ, 1, 2*K, + $ ALPHA, AB( JJAB ), 2*NMAX, + $ W, 2*NMAX, BETA, + $ C( JJ, J ), NMAX, CT, G, + $ CC( JC ), LDC, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + ELSE + DO 60 I = 1, K + W( I ) = AB( ( K + I - 1 )*NMAX + + $ J ) + W( K + I ) = AB( ( I - 1 )*NMAX + + $ J ) + 60 CONTINUE + CALL DMMCH( 'N', 'N', LJ, 1, 2*K, + $ ALPHA, AB( JJ ), NMAX, W, + $ 2*NMAX, BETA, C( JJ, J ), + $ NMAX, CT, G, CC( JC ), LDC, + $ EPS, ERR, FATAL, NOUT, + $ .TRUE. ) + END IF + IF( UPPER )THEN + JC = JC + LDC + ELSE + JC = JC + LDC + 1 + IF( TRAN ) + $ JJAB = JJAB + 2*NMAX + END IF + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and +* return. + IF( FATAL ) + $ GO TO 140 + 70 CONTINUE + END IF +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* + 110 CONTINUE +* + 120 CONTINUE +* + 130 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 160 +* + 140 CONTINUE + IF( N.GT.1 ) + $ WRITE( NOUT, FMT = 9995 )J +* + 150 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + CALL DPRCN5( NOUT, NC, SNAME, IORDER, UPLO, TRANS, N, K, ALPHA, + $ LDA, LDB, BETA, LDC) +* + 160 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) + 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), + $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', + $ ' .' ) + 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of DCHK5. +* + END +* + SUBROUTINE DPRCN5(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, + $ N, K, ALPHA, LDA, LDB, BETA, LDC) + INTEGER NOUT, NC, IORDER, N, K, LDA, LDB, LDC + DOUBLE PRECISION ALPHA, BETA + CHARACTER*1 UPLO, TRANSA + CHARACTER*12 SNAME + CHARACTER*14 CRC, CU, CA + + IF (UPLO.EQ.'U')THEN + CU = ' CblasUpper' + ELSE + CU = ' CblasLower' + END IF + IF (TRANSA.EQ.'N')THEN + CA = ' CblasNoTrans' + ELSE IF (TRANSA.EQ.'T')THEN + CA = ' CblasTrans' + ELSE + CA = 'CblasConjTrans' + END IF + IF (IORDER.EQ.1)THEN + CRC = ' CblasRowMajor' + ELSE + CRC = ' CblasColMajor' + END IF + WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA + WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, LDB, BETA, LDC + + 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') ) + 9994 FORMAT( 20X, 2( I3, ',' ), + $ F4.1, ', A,', I3, ', B', I3, ',', F4.1, ', C,', I3, ').' ) + END +* + SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, + $ TRANSL ) +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + DOUBLE PRECISION ROGUE + PARAMETER ( ROGUE = -1.0D10 ) +* .. Scalar Arguments .. + DOUBLE PRECISION TRANSL + INTEGER LDA, M, N, NMAX + LOGICAL RESET + CHARACTER*1 DIAG, UPLO + CHARACTER*2 TYPE +* .. Array Arguments .. + DOUBLE PRECISION A( NMAX, * ), AA( * ) +* .. Local Scalars .. + INTEGER I, IBEG, IEND, J + LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER +* .. External Functions .. + DOUBLE PRECISION DBEG + EXTERNAL DBEG +* .. Executable Statements .. + GEN = TYPE.EQ.'GE' + SYM = TYPE.EQ.'SY' + TRI = TYPE.EQ.'TR' + UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U' + LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L' + UNIT = TRI.AND.DIAG.EQ.'U' +* +* Generate data in array A. +* + DO 20 J = 1, N + DO 10 I = 1, M + IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) + $ THEN + A( I, J ) = DBEG( RESET ) + TRANSL + IF( I.NE.J )THEN +* Set some elements to zero + IF( N.GT.3.AND.J.EQ.N/2 ) + $ A( I, J ) = ZERO + IF( SYM )THEN + A( J, I ) = A( I, J ) + ELSE IF( TRI )THEN + A( J, I ) = ZERO + END IF + END IF + END IF + 10 CONTINUE + IF( TRI ) + $ A( J, J ) = A( J, J ) + ONE + IF( UNIT ) + $ A( J, J ) = ONE + 20 CONTINUE +* +* Store elements in array AS in data structure required by routine. +* + IF( TYPE.EQ.'GE' )THEN + DO 50 J = 1, N + DO 30 I = 1, M + AA( I + ( J - 1 )*LDA ) = A( I, J ) + 30 CONTINUE + DO 40 I = M + 1, LDA + AA( I + ( J - 1 )*LDA ) = ROGUE + 40 CONTINUE + 50 CONTINUE + ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN + DO 90 J = 1, N + IF( UPPER )THEN + IBEG = 1 + IF( UNIT )THEN + IEND = J - 1 + ELSE + IEND = J + END IF + ELSE + IF( UNIT )THEN + IBEG = J + 1 + ELSE + IBEG = J + END IF + IEND = N + END IF + DO 60 I = 1, IBEG - 1 + AA( I + ( J - 1 )*LDA ) = ROGUE + 60 CONTINUE + DO 70 I = IBEG, IEND + AA( I + ( J - 1 )*LDA ) = A( I, J ) + 70 CONTINUE + DO 80 I = IEND + 1, LDA + AA( I + ( J - 1 )*LDA ) = ROGUE + 80 CONTINUE + 90 CONTINUE + END IF + RETURN +* +* End of DMAKE. +* + END + SUBROUTINE DMMCH( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, + $ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, + $ NOUT, MV ) +* +* 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, BETA, EPS, ERR + INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT + LOGICAL FATAL, MV + CHARACTER*1 TRANSA, TRANSB +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ CC( LDCC, * ), CT( * ), G( * ) +* .. Local Scalars .. + DOUBLE PRECISION ERRI + INTEGER I, J, K + LOGICAL TRANA, TRANB +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. Executable Statements .. + TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' + TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' +* +* Compute expected result, one column at a time, in CT using data +* in A, B and C. +* Compute gauges in G. +* + DO 120 J = 1, N +* + DO 10 I = 1, M + CT( I ) = ZERO + G( I ) = ZERO + 10 CONTINUE + IF( .NOT.TRANA.AND..NOT.TRANB )THEN + DO 30 K = 1, KK + DO 20 I = 1, M + CT( I ) = CT( I ) + A( I, K )*B( K, J ) + G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( K, J ) ) + 20 CONTINUE + 30 CONTINUE + ELSE IF( TRANA.AND..NOT.TRANB )THEN + DO 50 K = 1, KK + DO 40 I = 1, M + CT( I ) = CT( I ) + A( K, I )*B( K, J ) + G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( K, J ) ) + 40 CONTINUE + 50 CONTINUE + ELSE IF( .NOT.TRANA.AND.TRANB )THEN + DO 70 K = 1, KK + DO 60 I = 1, M + CT( I ) = CT( I ) + A( I, K )*B( J, K ) + G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( J, K ) ) + 60 CONTINUE + 70 CONTINUE + ELSE IF( TRANA.AND.TRANB )THEN + DO 90 K = 1, KK + DO 80 I = 1, M + CT( I ) = CT( I ) + A( K, I )*B( J, K ) + G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( J, K ) ) + 80 CONTINUE + 90 CONTINUE + END IF + DO 100 I = 1, M + CT( I ) = ALPHA*CT( I ) + BETA*C( I, J ) + G( I ) = ABS( ALPHA )*G( I ) + ABS( BETA )*ABS( C( I, J ) ) + 100 CONTINUE +* +* Compute the error ratio for this result. +* + ERR = ZERO + DO 110 I = 1, M + ERRI = ABS( CT( I ) - CC( I, J ) )/EPS + IF( G( I ).NE.ZERO ) + $ ERRI = ERRI/G( I ) + ERR = MAX( ERR, ERRI ) + IF( ERR*SQRT( EPS ).GE.ONE ) + $ GO TO 130 + 110 CONTINUE +* + 120 CONTINUE +* +* If the loop completes, all results are at least half accurate. + GO TO 150 +* +* Report fatal error. +* + 130 FATAL = .TRUE. + WRITE( NOUT, FMT = 9999 ) + DO 140 I = 1, M + IF( MV )THEN + WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J ) + ELSE + WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I ) + END IF + 140 CONTINUE + IF( N.GT.1 ) + $ WRITE( NOUT, FMT = 9997 )J +* + 150 CONTINUE + RETURN +* + 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', + $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU', + $ 'TED RESULT' ) + 9998 FORMAT( 1X, I7, 2G18.6 ) + 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) +* +* End of DMMCH. +* + END + LOGICAL FUNCTION LDE( RI, RJ, LR ) +* +* 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 .. + INTEGER LR +* .. Array Arguments .. + DOUBLE PRECISION RI( * ), RJ( * ) +* .. Local Scalars .. + INTEGER I +* .. Executable Statements .. + DO 10 I = 1, LR + IF( RI( I ).NE.RJ( I ) ) + $ GO TO 20 + 10 CONTINUE + LDE = .TRUE. + GO TO 30 + 20 CONTINUE + LDE = .FALSE. + 30 RETURN +* +* End of LDE. +* + END + LOGICAL FUNCTION LDERES( TYPE, UPLO, M, N, AA, AS, LDA ) +* +* 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 .. + INTEGER LDA, M, N + CHARACTER*1 UPLO + CHARACTER*2 TYPE +* .. Array Arguments .. + DOUBLE PRECISION AA( LDA, * ), AS( LDA, * ) +* .. Local Scalars .. + INTEGER I, IBEG, IEND, J + LOGICAL UPPER +* .. Executable Statements .. + UPPER = UPLO.EQ.'U' + IF( TYPE.EQ.'GE' )THEN + DO 20 J = 1, N + DO 10 I = M + 1, LDA + IF( AA( I, J ).NE.AS( I, J ) ) + $ GO TO 70 + 10 CONTINUE + 20 CONTINUE + ELSE IF( TYPE.EQ.'SY' )THEN + DO 50 J = 1, N + IF( UPPER )THEN + IBEG = 1 + IEND = J + ELSE + IBEG = J + IEND = N + END IF + DO 30 I = 1, IBEG - 1 + IF( AA( I, J ).NE.AS( I, J ) ) + $ GO TO 70 + 30 CONTINUE + DO 40 I = IEND + 1, LDA + IF( AA( I, J ).NE.AS( I, J ) ) + $ GO TO 70 + 40 CONTINUE + 50 CONTINUE + END IF +* + 60 CONTINUE + LDERES = .TRUE. + GO TO 80 + 70 CONTINUE + LDERES = .FALSE. + 80 RETURN +* +* End of LDERES. +* + END + DOUBLE PRECISION FUNCTION DBEG( RESET ) +* +* Generates 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 .. + LOGICAL RESET +* .. Local Scalars .. + INTEGER I, IC, MI +* .. Save statement .. + SAVE I, IC, MI +* .. Executable Statements .. + IF( RESET )THEN +* Initialize local variables. + MI = 891 + I = 7 + IC = 0 + RESET = .FALSE. + END IF +* +* The sequence of values of I is bounded between 1 and 999. +* If initial I = 1,2,3,6,7 or 9, the period will be 50. +* If initial I = 4 or 8, the period will be 25. +* If initial I = 5, the period will be 10. +* IC is used to break up the period by skipping 1 value of I in 6. +* + IC = IC + 1 + 10 I = I*MI + I = I - 1000*( I/1000 ) + IF( IC.GE.5 )THEN + IC = 0 + GO TO 10 + END IF + DBEG = ( I - 500 )/1001.0D0 + RETURN +* +* End of DBEG. +* + END + DOUBLE PRECISION FUNCTION DDIFF( X, Y ) +* +* 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 .. + DOUBLE PRECISION X, Y +* .. Executable Statements .. + DDIFF = X - Y + RETURN +* +* End of DDIFF. +* + END diff --git a/cblas/testing/c_s2chke.c b/cblas/testing/c_s2chke.c new file mode 100644 index 00000000..60b837cd --- /dev/null +++ b/cblas/testing/c_s2chke.c @@ -0,0 +1,789 @@ +#include <stdio.h> +#include <string.h> +#include "cblas.h" +#include "cblas_test.h" + +int cblas_ok, cblas_lerr, cblas_info; +int link_xerbla=TRUE; +char *cblas_rout; + +#ifdef F77_Char +void F77_xerbla(F77_Char F77_srname, void *vinfo); +#else +void F77_xerbla(char *srname, void *vinfo); +#endif + +void chkxer(void) { + extern int cblas_ok, cblas_lerr, cblas_info; + extern int link_xerbla; + extern char *cblas_rout; + if (cblas_lerr == 1 ) { + printf("***** ILLEGAL VALUE OF PARAMETER NUMBER %d NOT DETECTED BY %s *****\n", cblas_info, cblas_rout); + cblas_ok = 0 ; + } + cblas_lerr = 1 ; +} + +void F77_s2chke(char *rout) { + char *sf = ( rout ) ; + float A[2] = {0.0,0.0}, + X[2] = {0.0,0.0}, + Y[2] = {0.0,0.0}, + ALPHA=0.0, BETA=0.0; + extern int cblas_info, cblas_lerr, cblas_ok; + extern int RowMajorStrg; + extern char *cblas_rout; + + if (link_xerbla) /* call these first to link */ + { + cblas_xerbla(cblas_info,cblas_rout,""); + F77_xerbla(cblas_rout,&cblas_info); + } + + cblas_ok = TRUE ; + cblas_lerr = PASSED ; + + if (strncmp( sf,"cblas_sgemv",11)==0) { + cblas_rout = "cblas_sgemv"; + cblas_info = 1; + cblas_sgemv(INVALID, CblasNoTrans, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_sgemv(CblasColMajor, INVALID, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_sgemv(CblasColMajor, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_sgemv(CblasColMajor, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_sgemv(CblasColMajor, CblasNoTrans, 2, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_sgemv(CblasColMajor, CblasNoTrans, 0, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_sgemv(CblasColMajor, CblasNoTrans, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + + cblas_info = 2; RowMajorStrg = TRUE; RowMajorStrg = TRUE; + cblas_sgemv(CblasRowMajor, INVALID, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_sgemv(CblasRowMajor, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_sgemv(CblasRowMajor, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_sgemv(CblasRowMajor, CblasNoTrans, 0, 2, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_sgemv(CblasRowMajor, CblasNoTrans, 0, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_sgemv(CblasRowMajor, CblasNoTrans, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_sgbmv",11)==0) { + cblas_rout = "cblas_sgbmv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_sgbmv(INVALID, CblasNoTrans, 0, 0, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_sgbmv(CblasColMajor, INVALID, 0, 0, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_sgbmv(CblasColMajor, CblasNoTrans, INVALID, 0, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_sgbmv(CblasColMajor, CblasNoTrans, 0, INVALID, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_sgbmv(CblasColMajor, CblasNoTrans, 0, 0, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_sgbmv(CblasColMajor, CblasNoTrans, 2, 0, 0, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_sgbmv(CblasColMajor, CblasNoTrans, 0, 0, 1, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_sgbmv(CblasColMajor, CblasNoTrans, 0, 0, 0, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_sgbmv(CblasColMajor, CblasNoTrans, 0, 0, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_sgbmv(CblasRowMajor, INVALID, 0, 0, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_sgbmv(CblasRowMajor, CblasNoTrans, INVALID, 0, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_sgbmv(CblasRowMajor, CblasNoTrans, 0, INVALID, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_sgbmv(CblasRowMajor, CblasNoTrans, 0, 0, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_sgbmv(CblasRowMajor, CblasNoTrans, 2, 0, 0, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_sgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 1, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_sgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 0, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_sgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_ssymv",11)==0) { + cblas_rout = "cblas_ssymv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_ssymv(INVALID, CblasUpper, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_ssymv(CblasColMajor, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_ssymv(CblasColMajor, CblasUpper, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ssymv(CblasColMajor, CblasUpper, 2, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_ssymv(CblasColMajor, CblasUpper, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_ssymv(CblasColMajor, CblasUpper, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_ssymv(CblasRowMajor, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_ssymv(CblasRowMajor, CblasUpper, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ssymv(CblasRowMajor, CblasUpper, 2, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_ssymv(CblasRowMajor, CblasUpper, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_ssymv(CblasRowMajor, CblasUpper, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_ssbmv",11)==0) { + cblas_rout = "cblas_ssbmv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_ssbmv(INVALID, CblasUpper, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_ssbmv(CblasColMajor, INVALID, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_ssbmv(CblasColMajor, CblasUpper, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ssbmv(CblasColMajor, CblasUpper, 0, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ssbmv(CblasColMajor, CblasUpper, 0, 1, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_ssbmv(CblasColMajor, CblasUpper, 0, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ssbmv(CblasColMajor, CblasUpper, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_ssbmv(CblasRowMajor, INVALID, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_ssbmv(CblasRowMajor, CblasUpper, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_ssbmv(CblasRowMajor, CblasUpper, 0, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ssbmv(CblasRowMajor, CblasUpper, 0, 1, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_ssbmv(CblasRowMajor, CblasUpper, 0, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ssbmv(CblasRowMajor, CblasUpper, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_sspmv",11)==0) { + cblas_rout = "cblas_sspmv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_sspmv(INVALID, CblasUpper, 0, + ALPHA, A, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_sspmv(CblasColMajor, INVALID, 0, + ALPHA, A, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_sspmv(CblasColMajor, CblasUpper, INVALID, + ALPHA, A, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_sspmv(CblasColMajor, CblasUpper, 0, + ALPHA, A, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_sspmv(CblasColMajor, CblasUpper, 0, + ALPHA, A, X, 1, BETA, Y, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_sspmv(CblasRowMajor, INVALID, 0, + ALPHA, A, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_sspmv(CblasRowMajor, CblasUpper, INVALID, + ALPHA, A, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_sspmv(CblasRowMajor, CblasUpper, 0, + ALPHA, A, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_sspmv(CblasRowMajor, CblasUpper, 0, + ALPHA, A, X, 1, BETA, Y, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_strmv",11)==0) { + cblas_rout = "cblas_strmv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_strmv(INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_strmv(CblasColMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_strmv(CblasColMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_strmv(CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_strmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_strmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, A, 1, X, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_strmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_strmv(CblasRowMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_strmv(CblasRowMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_strmv(CblasRowMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_strmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_strmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, A, 1, X, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_strmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_stbmv",11)==0) { + cblas_rout = "cblas_stbmv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_stbmv(INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_stbmv(CblasColMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_stbmv(CblasColMajor, CblasUpper, INVALID, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_stbmv(CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_stbmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_stbmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_stbmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 1, A, 1, X, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_stbmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_stbmv(CblasRowMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_stbmv(CblasRowMajor, CblasUpper, INVALID, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_stbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + INVALID, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_stbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_stbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_stbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 1, A, 1, X, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_stbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_stpmv",11)==0) { + cblas_rout = "cblas_stpmv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_stpmv(INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_stpmv(CblasColMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_stpmv(CblasColMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_stpmv(CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_stpmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_stpmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, X, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_stpmv(CblasRowMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_stpmv(CblasRowMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_stpmv(CblasRowMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_stpmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_stpmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, X, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_strsv",11)==0) { + cblas_rout = "cblas_strsv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_strsv(INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_strsv(CblasColMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_strsv(CblasColMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_strsv(CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_strsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_strsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, A, 1, X, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_strsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_strsv(CblasRowMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_strsv(CblasRowMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_strsv(CblasRowMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_strsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_strsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, A, 1, X, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_strsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_stbsv",11)==0) { + cblas_rout = "cblas_stbsv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_stbsv(INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_stbsv(CblasColMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_stbsv(CblasColMajor, CblasUpper, INVALID, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_stbsv(CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_stbsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_stbsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_stbsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 1, A, 1, X, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_stbsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_stbsv(CblasRowMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_stbsv(CblasRowMajor, CblasUpper, INVALID, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_stbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + INVALID, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_stbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_stbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_stbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 1, A, 1, X, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_stbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_stpsv",11)==0) { + cblas_rout = "cblas_stpsv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_stpsv(INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_stpsv(CblasColMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_stpsv(CblasColMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_stpsv(CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_stpsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_stpsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, X, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_stpsv(CblasRowMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_stpsv(CblasRowMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_stpsv(CblasRowMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_stpsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_stpsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, X, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_sger",10)==0) { + cblas_rout = "cblas_sger"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_sger(INVALID, 0, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_sger(CblasColMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_sger(CblasColMajor, 0, INVALID, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_sger(CblasColMajor, 0, 0, ALPHA, X, 0, Y, 1, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_sger(CblasColMajor, 0, 0, ALPHA, X, 1, Y, 0, A, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_sger(CblasColMajor, 2, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_sger(CblasRowMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_sger(CblasRowMajor, 0, INVALID, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_sger(CblasRowMajor, 0, 0, ALPHA, X, 0, Y, 1, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_sger(CblasRowMajor, 0, 0, ALPHA, X, 1, Y, 0, A, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_sger(CblasRowMajor, 0, 2, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + } else if (strncmp( sf,"cblas_ssyr2",11)==0) { + cblas_rout = "cblas_ssyr2"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_ssyr2(INVALID, CblasUpper, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_ssyr2(CblasColMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_ssyr2(CblasColMajor, CblasUpper, INVALID, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ssyr2(CblasColMajor, CblasUpper, 0, ALPHA, X, 0, Y, 1, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_ssyr2(CblasColMajor, CblasUpper, 0, ALPHA, X, 1, Y, 0, A, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ssyr2(CblasColMajor, CblasUpper, 2, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_ssyr2(CblasRowMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_ssyr2(CblasRowMajor, CblasUpper, INVALID, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ssyr2(CblasRowMajor, CblasUpper, 0, ALPHA, X, 0, Y, 1, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_ssyr2(CblasRowMajor, CblasUpper, 0, ALPHA, X, 1, Y, 0, A, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ssyr2(CblasRowMajor, CblasUpper, 2, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + } else if (strncmp( sf,"cblas_sspr2",11)==0) { + cblas_rout = "cblas_sspr2"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_sspr2(INVALID, CblasUpper, 0, ALPHA, X, 1, Y, 1, A ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_sspr2(CblasColMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_sspr2(CblasColMajor, CblasUpper, INVALID, ALPHA, X, 1, Y, 1, A ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_sspr2(CblasColMajor, CblasUpper, 0, ALPHA, X, 0, Y, 1, A ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_sspr2(CblasColMajor, CblasUpper, 0, ALPHA, X, 1, Y, 0, A ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_sspr2(CblasRowMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_sspr2(CblasRowMajor, CblasUpper, INVALID, ALPHA, X, 1, Y, 1, A ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_sspr2(CblasRowMajor, CblasUpper, 0, ALPHA, X, 0, Y, 1, A ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_sspr2(CblasRowMajor, CblasUpper, 0, ALPHA, X, 1, Y, 0, A ); + chkxer(); + } else if (strncmp( sf,"cblas_ssyr",10)==0) { + cblas_rout = "cblas_ssyr"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_ssyr(INVALID, CblasUpper, 0, ALPHA, X, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_ssyr(CblasColMajor, INVALID, 0, ALPHA, X, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_ssyr(CblasColMajor, CblasUpper, INVALID, ALPHA, X, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ssyr(CblasColMajor, CblasUpper, 0, ALPHA, X, 0, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_ssyr(CblasColMajor, CblasUpper, 2, ALPHA, X, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_ssyr(CblasRowMajor, INVALID, 0, ALPHA, X, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_ssyr(CblasRowMajor, CblasUpper, INVALID, ALPHA, X, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ssyr(CblasRowMajor, CblasUpper, 0, ALPHA, X, 0, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_ssyr(CblasRowMajor, CblasUpper, 2, ALPHA, X, 1, A, 1 ); + chkxer(); + } else if (strncmp( sf,"cblas_sspr",10)==0) { + cblas_rout = "cblas_sspr"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_sspr(INVALID, CblasUpper, 0, ALPHA, X, 1, A ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_sspr(CblasColMajor, INVALID, 0, ALPHA, X, 1, A ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_sspr(CblasColMajor, CblasUpper, INVALID, ALPHA, X, 1, A ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_sspr(CblasColMajor, CblasUpper, 0, ALPHA, X, 0, A ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_sspr(CblasColMajor, INVALID, 0, ALPHA, X, 1, A ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_sspr(CblasColMajor, CblasUpper, INVALID, ALPHA, X, 1, A ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_sspr(CblasColMajor, CblasUpper, 0, ALPHA, X, 0, A ); + chkxer(); + } + if (cblas_ok == TRUE) + printf(" %-12s PASSED THE TESTS OF ERROR-EXITS\n", cblas_rout); + else + printf("******* %s FAILED THE TESTS OF ERROR-EXITS *******\n",cblas_rout); +} diff --git a/cblas/testing/c_s3chke.c b/cblas/testing/c_s3chke.c new file mode 100644 index 00000000..1b2a536c --- /dev/null +++ b/cblas/testing/c_s3chke.c @@ -0,0 +1,1273 @@ +#include <stdio.h> +#include <string.h> +#include "cblas.h" +#include "cblas_test.h" + +int cblas_ok, cblas_lerr, cblas_info; +int link_xerbla=TRUE; +char *cblas_rout; + +#ifdef F77_Char +void F77_xerbla(F77_Char F77_srname, void *vinfo); +#else +void F77_xerbla(char *srname, void *vinfo); +#endif + +void chkxer(void) { + extern int cblas_ok, cblas_lerr, cblas_info; + extern int link_xerbla; + extern char *cblas_rout; + if (cblas_lerr == 1 ) { + printf("***** ILLEGAL VALUE OF PARAMETER NUMBER %d NOT DETECTED BY %s *****\n", cblas_info, cblas_rout); + cblas_ok = 0 ; + } + cblas_lerr = 1 ; +} + +void F77_s3chke(char *rout) { + char *sf = ( rout ) ; + float A[2] = {0.0,0.0}, + B[2] = {0.0,0.0}, + C[2] = {0.0,0.0}, + ALPHA=0.0, BETA=0.0; + extern int cblas_info, cblas_lerr, cblas_ok; + extern int RowMajorStrg; + extern char *cblas_rout; + + if (link_xerbla) /* call these first to link */ + { + cblas_xerbla(cblas_info,cblas_rout,""); + F77_xerbla(cblas_rout,&cblas_info); + } + + cblas_ok = TRUE ; + cblas_lerr = PASSED ; + + if (strncmp( sf,"cblas_sgemm" ,11)==0) { + cblas_rout = "cblas_sgemm" ; + cblas_info = 1; + cblas_sgemm( INVALID, CblasNoTrans, CblasNoTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_sgemm( INVALID, CblasNoTrans, CblasTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_sgemm( INVALID, CblasTrans, CblasNoTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_sgemm( INVALID, CblasTrans, CblasTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_sgemm( CblasColMajor, INVALID, CblasNoTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_sgemm( CblasColMajor, INVALID, CblasTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_sgemm( CblasColMajor, CblasNoTrans, INVALID, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_sgemm( CblasColMajor, CblasTrans, INVALID, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_sgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_sgemm( CblasColMajor, CblasNoTrans, CblasTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_sgemm( CblasColMajor, CblasTrans, CblasNoTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_sgemm( CblasColMajor, CblasTrans, CblasTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_sgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_sgemm( CblasColMajor, CblasNoTrans, CblasTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_sgemm( CblasColMajor, CblasTrans, CblasNoTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_sgemm( CblasColMajor, CblasTrans, CblasTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_sgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_sgemm( CblasColMajor, CblasNoTrans, CblasTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_sgemm( CblasColMajor, CblasTrans, CblasNoTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_sgemm( CblasColMajor, CblasTrans, CblasTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_sgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 2, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_sgemm( CblasColMajor, CblasNoTrans, CblasTrans, 2, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_sgemm( CblasColMajor, CblasTrans, CblasNoTrans, 0, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_sgemm( CblasColMajor, CblasTrans, CblasTrans, 0, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_sgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 0, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_sgemm( CblasColMajor, CblasTrans, CblasNoTrans, 0, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_sgemm( CblasColMajor, CblasNoTrans, CblasTrans, 0, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_sgemm( CblasColMajor, CblasTrans, CblasTrans, 0, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_sgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 2, 0, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_sgemm( CblasColMajor, CblasNoTrans, CblasTrans, 2, 0, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_sgemm( CblasColMajor, CblasTrans, CblasNoTrans, 2, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_sgemm( CblasColMajor, CblasTrans, CblasTrans, 2, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 4; RowMajorStrg = TRUE; + cblas_sgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_sgemm( CblasRowMajor, CblasNoTrans, CblasTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_sgemm( CblasRowMajor, CblasTrans, CblasNoTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_sgemm( CblasRowMajor, CblasTrans, CblasTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_sgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_sgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_sgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_sgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_sgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_sgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_sgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_sgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_sgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_sgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_sgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 2, 0, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_sgemm( CblasRowMajor, CblasTrans, CblasTrans, 2, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_sgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_sgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 0, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_sgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_sgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_sgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_sgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_sgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 0, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_sgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_ssymm" ,11)==0) { + cblas_rout = "cblas_ssymm" ; + + cblas_info = 1; + cblas_ssymm( INVALID, CblasRight, CblasLower, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_ssymm( CblasColMajor, INVALID, CblasUpper, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_ssymm( CblasColMajor, CblasLeft, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ssymm( CblasColMajor, CblasLeft, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ssymm( CblasColMajor, CblasRight, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ssymm( CblasColMajor, CblasLeft, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ssymm( CblasColMajor, CblasRight, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_ssymm( CblasColMajor, CblasLeft, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_ssymm( CblasColMajor, CblasRight, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_ssymm( CblasColMajor, CblasLeft, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_ssymm( CblasColMajor, CblasRight, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_ssymm( CblasColMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_ssymm( CblasColMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_ssymm( CblasColMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_ssymm( CblasColMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ssymm( CblasColMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ssymm( CblasColMajor, CblasRight, CblasUpper, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ssymm( CblasColMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ssymm( CblasColMajor, CblasRight, CblasLower, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_ssymm( CblasColMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_ssymm( CblasColMajor, CblasRight, CblasUpper, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_ssymm( CblasColMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_ssymm( CblasColMajor, CblasRight, CblasLower, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + + cblas_info = 4; RowMajorStrg = TRUE; + cblas_ssymm( CblasRowMajor, CblasLeft, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_ssymm( CblasRowMajor, CblasRight, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_ssymm( CblasRowMajor, CblasLeft, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_ssymm( CblasRowMajor, CblasRight, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_ssymm( CblasRowMajor, CblasLeft, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_ssymm( CblasRowMajor, CblasRight, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_ssymm( CblasRowMajor, CblasLeft, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_ssymm( CblasRowMajor, CblasRight, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_ssymm( CblasRowMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_ssymm( CblasRowMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_ssymm( CblasRowMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_ssymm( CblasRowMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ssymm( CblasRowMajor, CblasLeft, CblasUpper, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ssymm( CblasRowMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ssymm( CblasRowMajor, CblasLeft, CblasLower, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ssymm( CblasRowMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_ssymm( CblasRowMajor, CblasLeft, CblasUpper, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_ssymm( CblasRowMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_ssymm( CblasRowMajor, CblasLeft, CblasLower, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_ssymm( CblasRowMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_strmm" ,11)==0) { + cblas_rout = "cblas_strmm" ; + + cblas_info = 1; + cblas_strmm( INVALID, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasLeft, INVALID, CblasNoTrans, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasLeft, CblasUpper, INVALID, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + INVALID, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_strmm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + + cblas_info = 6; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_strmm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_strsm" ,11)==0) { + cblas_rout = "cblas_strsm" ; + + cblas_info = 1; + cblas_strsm( INVALID, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasLeft, INVALID, CblasNoTrans, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasLeft, CblasUpper, INVALID, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + INVALID, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_strsm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + + cblas_info = 6; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_strsm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_ssyrk" ,11)==0) { + cblas_rout = "cblas_ssyrk" ; + + cblas_info = 1; + cblas_ssyrk( INVALID, CblasUpper, CblasNoTrans, + 0, 0, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_ssyrk( CblasColMajor, INVALID, CblasNoTrans, + 0, 0, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_ssyrk( CblasColMajor, CblasUpper, INVALID, + 0, 0, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ssyrk( CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ssyrk( CblasColMajor, CblasUpper, CblasTrans, + INVALID, 0, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ssyrk( CblasColMajor, CblasLower, CblasNoTrans, + INVALID, 0, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ssyrk( CblasColMajor, CblasLower, CblasTrans, + INVALID, 0, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_ssyrk( CblasColMajor, CblasUpper, CblasNoTrans, + 0, INVALID, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_ssyrk( CblasColMajor, CblasUpper, CblasTrans, + 0, INVALID, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_ssyrk( CblasColMajor, CblasLower, CblasNoTrans, + 0, INVALID, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_ssyrk( CblasColMajor, CblasLower, CblasTrans, + 0, INVALID, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_ssyrk( CblasRowMajor, CblasUpper, CblasNoTrans, + 0, 2, ALPHA, A, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_ssyrk( CblasRowMajor, CblasUpper, CblasTrans, + 2, 0, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_ssyrk( CblasRowMajor, CblasLower, CblasNoTrans, + 0, 2, ALPHA, A, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_ssyrk( CblasRowMajor, CblasLower, CblasTrans, + 2, 0, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_ssyrk( CblasColMajor, CblasUpper, CblasNoTrans, + 2, 0, ALPHA, A, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_ssyrk( CblasColMajor, CblasUpper, CblasTrans, + 0, 2, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_ssyrk( CblasColMajor, CblasLower, CblasNoTrans, + 2, 0, ALPHA, A, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_ssyrk( CblasColMajor, CblasLower, CblasTrans, + 0, 2, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_ssyrk( CblasRowMajor, CblasUpper, CblasNoTrans, + 2, 0, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_ssyrk( CblasRowMajor, CblasUpper, CblasTrans, + 2, 0, ALPHA, A, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_ssyrk( CblasRowMajor, CblasLower, CblasNoTrans, + 2, 0, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_ssyrk( CblasRowMajor, CblasLower, CblasTrans, + 2, 0, ALPHA, A, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_ssyrk( CblasColMajor, CblasUpper, CblasNoTrans, + 2, 0, ALPHA, A, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_ssyrk( CblasColMajor, CblasUpper, CblasTrans, + 2, 0, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_ssyrk( CblasColMajor, CblasLower, CblasNoTrans, + 2, 0, ALPHA, A, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_ssyrk( CblasColMajor, CblasLower, CblasTrans, + 2, 0, ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_ssyr2k" ,12)==0) { + cblas_rout = "cblas_ssyr2k" ; + + cblas_info = 1; + cblas_ssyr2k( INVALID, CblasUpper, CblasNoTrans, + 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_ssyr2k( CblasColMajor, INVALID, CblasNoTrans, + 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_ssyr2k( CblasColMajor, CblasUpper, INVALID, + 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ssyr2k( CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ssyr2k( CblasColMajor, CblasUpper, CblasTrans, + INVALID, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ssyr2k( CblasColMajor, CblasLower, CblasNoTrans, + INVALID, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ssyr2k( CblasColMajor, CblasLower, CblasTrans, + INVALID, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_ssyr2k( CblasColMajor, CblasUpper, CblasNoTrans, + 0, INVALID, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_ssyr2k( CblasColMajor, CblasUpper, CblasTrans, + 0, INVALID, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_ssyr2k( CblasColMajor, CblasLower, CblasNoTrans, + 0, INVALID, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_ssyr2k( CblasColMajor, CblasLower, CblasTrans, + 0, INVALID, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_ssyr2k( CblasRowMajor, CblasUpper, CblasNoTrans, + 0, 2, ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_ssyr2k( CblasRowMajor, CblasUpper, CblasTrans, + 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_ssyr2k( CblasRowMajor, CblasLower, CblasNoTrans, + 0, 2, ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_ssyr2k( CblasRowMajor, CblasLower, CblasTrans, + 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_ssyr2k( CblasColMajor, CblasUpper, CblasNoTrans, + 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_ssyr2k( CblasColMajor, CblasUpper, CblasTrans, + 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_ssyr2k( CblasColMajor, CblasLower, CblasNoTrans, + 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_ssyr2k( CblasColMajor, CblasLower, CblasTrans, + 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ssyr2k( CblasRowMajor, CblasUpper, CblasNoTrans, + 0, 2, ALPHA, A, 2, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ssyr2k( CblasRowMajor, CblasUpper, CblasTrans, + 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ssyr2k( CblasRowMajor, CblasLower, CblasNoTrans, + 0, 2, ALPHA, A, 2, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ssyr2k( CblasRowMajor, CblasLower, CblasTrans, + 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ssyr2k( CblasColMajor, CblasUpper, CblasNoTrans, + 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ssyr2k( CblasColMajor, CblasUpper, CblasTrans, + 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ssyr2k( CblasColMajor, CblasLower, CblasNoTrans, + 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ssyr2k( CblasColMajor, CblasLower, CblasTrans, + 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_ssyr2k( CblasRowMajor, CblasUpper, CblasNoTrans, + 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_ssyr2k( CblasRowMajor, CblasUpper, CblasTrans, + 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_ssyr2k( CblasRowMajor, CblasLower, CblasNoTrans, + 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_ssyr2k( CblasRowMajor, CblasLower, CblasTrans, + 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_ssyr2k( CblasColMajor, CblasUpper, CblasNoTrans, + 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_ssyr2k( CblasColMajor, CblasUpper, CblasTrans, + 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_ssyr2k( CblasColMajor, CblasLower, CblasNoTrans, + 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_ssyr2k( CblasColMajor, CblasLower, CblasTrans, + 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + } + if (cblas_ok == TRUE ) + printf(" %-12s PASSED THE TESTS OF ERROR-EXITS\n", cblas_rout); + else + printf("***** %s FAILED THE TESTS OF ERROR-EXITS *******\n",cblas_rout); +} diff --git a/cblas/testing/c_sblas1.c b/cblas/testing/c_sblas1.c new file mode 100644 index 00000000..da72b722 --- /dev/null +++ b/cblas/testing/c_sblas1.c @@ -0,0 +1,82 @@ +/* + * c_sblas1.c + * + * The program is a C wrapper for scblat1. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas_test.h" +#include "cblas.h" +float F77_sasum(const int *N, float *X, const int *incX) +{ + return cblas_sasum(*N, X, *incX); +} + +void F77_saxpy(const int *N, const float *alpha, const float *X, + const int *incX, float *Y, const int *incY) +{ + cblas_saxpy(*N, *alpha, X, *incX, Y, *incY); + return; +} + +float F77_scasum(const int *N, void *X, const int *incX) +{ + return cblas_scasum(*N, X, *incX); +} + +float F77_scnrm2(const int *N, const void *X, const int *incX) +{ + return cblas_scnrm2(*N, X, *incX); +} + +void F77_scopy(const int *N, const float *X, const int *incX, + float *Y, const int *incY) +{ + cblas_scopy(*N, X, *incX, Y, *incY); + return; +} + +float F77_sdot(const int *N, const float *X, const int *incX, + const float *Y, const int *incY) +{ + return cblas_sdot(*N, X, *incX, Y, *incY); +} + +float F77_snrm2(const int *N, const float *X, const int *incX) +{ + return cblas_snrm2(*N, X, *incX); +} + +void F77_srotg( float *a, float *b, float *c, float *s) +{ + cblas_srotg(a,b,c,s); + return; +} + +void F77_srot( const int *N, float *X, const int *incX, float *Y, + const int *incY, const float *c, const float *s) +{ + cblas_srot(*N,X,*incX,Y,*incY,*c,*s); + return; +} + +void F77_sscal(const int *N, const float *alpha, float *X, + const int *incX) +{ + cblas_sscal(*N, *alpha, X, *incX); + return; +} + +void F77_sswap( const int *N, float *X, const int *incX, + float *Y, const int *incY) +{ + cblas_sswap(*N,X,*incX,Y,*incY); + return; +} + +int F77_isamax(const int *N, const float *X, const int *incX) +{ + if (*N < 1 || *incX < 1) return(0); + return (cblas_isamax(*N, X, *incX)+1); +} diff --git a/cblas/testing/c_sblas2.c b/cblas/testing/c_sblas2.c new file mode 100644 index 00000000..c04d8db4 --- /dev/null +++ b/cblas/testing/c_sblas2.c @@ -0,0 +1,579 @@ +/* + * Written by D.P. Manley, Digital Equipment Corporation. + * Prefixed "C_" to BLAS routines and their declarations. + * + * Modified by T. H. Do, 1/23/98, SGI/CRAY Research. + */ +#include <stdlib.h> +#include "cblas.h" +#include "cblas_test.h" + +void F77_sgemv(int *layout, char *transp, int *m, int *n, float *alpha, + float *a, int *lda, float *x, int *incx, float *beta, + float *y, int *incy ) { + + float *A; + int i,j,LDA; + CBLAS_TRANSPOSE trans; + + get_transpose_type(transp, &trans); + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A = ( float* )malloc( (*m)*LDA*sizeof( float ) ); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ) + A[ LDA*i+j ]=a[ (*lda)*j+i ]; + cblas_sgemv( CblasRowMajor, trans, + *m, *n, *alpha, A, LDA, x, *incx, *beta, y, *incy ); + free(A); + } + else if (*layout == TEST_COL_MJR) + cblas_sgemv( CblasColMajor, trans, + *m, *n, *alpha, a, *lda, x, *incx, *beta, y, *incy ); + else + cblas_sgemv( UNDEFINED, trans, + *m, *n, *alpha, a, *lda, x, *incx, *beta, y, *incy ); +} + +void F77_sger(int *layout, int *m, int *n, float *alpha, float *x, int *incx, + float *y, int *incy, float *a, int *lda ) { + + float *A; + int i,j,LDA; + + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A = ( float* )malloc( (*m)*LDA*sizeof( float ) ); + + for( i=0; i<*m; i++ ) { + for( j=0; j<*n; j++ ) + A[ LDA*i+j ]=a[ (*lda)*j+i ]; + } + + cblas_sger(CblasRowMajor, *m, *n, *alpha, x, *incx, y, *incy, A, LDA ); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ) + a[ (*lda)*j+i ]=A[ LDA*i+j ]; + free(A); + } + else + cblas_sger( CblasColMajor, *m, *n, *alpha, x, *incx, y, *incy, a, *lda ); +} + +void F77_strmv(int *layout, char *uplow, char *transp, char *diagn, + int *n, float *a, int *lda, float *x, int *incx) { + float *A; + int i,j,LDA; + CBLAS_TRANSPOSE trans; + CBLAS_UPLO uplo; + CBLAS_DIAG diag; + + get_transpose_type(transp,&trans); + get_uplo_type(uplow,&uplo); + get_diag_type(diagn,&diag); + + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A = ( float* )malloc( (*n)*LDA*sizeof( float ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + A[ LDA*i+j ]=a[ (*lda)*j+i ]; + cblas_strmv(CblasRowMajor, uplo, trans, diag, *n, A, LDA, x, *incx); + free(A); + } + else if (*layout == TEST_COL_MJR) + cblas_strmv(CblasColMajor, uplo, trans, diag, *n, a, *lda, x, *incx); + else { + cblas_strmv(UNDEFINED, uplo, trans, diag, *n, a, *lda, x, *incx); + } +} + +void F77_strsv(int *layout, char *uplow, char *transp, char *diagn, + int *n, float *a, int *lda, float *x, int *incx ) { + float *A; + int i,j,LDA; + CBLAS_TRANSPOSE trans; + CBLAS_UPLO uplo; + CBLAS_DIAG diag; + + get_transpose_type(transp,&trans); + get_uplo_type(uplow,&uplo); + get_diag_type(diagn,&diag); + + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A = ( float* )malloc( (*n)*LDA*sizeof( float ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + A[ LDA*i+j ]=a[ (*lda)*j+i ]; + cblas_strsv(CblasRowMajor, uplo, trans, diag, *n, A, LDA, x, *incx ); + free(A); + } + else + cblas_strsv(CblasColMajor, uplo, trans, diag, *n, a, *lda, x, *incx ); +} +void F77_ssymv(int *layout, char *uplow, int *n, float *alpha, float *a, + int *lda, float *x, int *incx, float *beta, float *y, + int *incy) { + float *A; + int i,j,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A = ( float* )malloc( (*n)*LDA*sizeof( float ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + A[ LDA*i+j ]=a[ (*lda)*j+i ]; + cblas_ssymv(CblasRowMajor, uplo, *n, *alpha, A, LDA, x, *incx, + *beta, y, *incy ); + free(A); + } + else + cblas_ssymv(CblasColMajor, uplo, *n, *alpha, a, *lda, x, *incx, + *beta, y, *incy ); +} + +void F77_ssyr(int *layout, char *uplow, int *n, float *alpha, float *x, + int *incx, float *a, int *lda) { + float *A; + int i,j,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A = ( float* )malloc( (*n)*LDA*sizeof( float ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + A[ LDA*i+j ]=a[ (*lda)*j+i ]; + cblas_ssyr(CblasRowMajor, uplo, *n, *alpha, x, *incx, A, LDA); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + a[ (*lda)*j+i ]=A[ LDA*i+j ]; + free(A); + } + else + cblas_ssyr(CblasColMajor, uplo, *n, *alpha, x, *incx, a, *lda); +} + +void F77_ssyr2(int *layout, char *uplow, int *n, float *alpha, float *x, + int *incx, float *y, int *incy, float *a, int *lda) { + float *A; + int i,j,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A = ( float* )malloc( (*n)*LDA*sizeof( float ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + A[ LDA*i+j ]=a[ (*lda)*j+i ]; + cblas_ssyr2(CblasRowMajor, uplo, *n, *alpha, x, *incx, y, *incy, A, LDA); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + a[ (*lda)*j+i ]=A[ LDA*i+j ]; + free(A); + } + else + cblas_ssyr2(CblasColMajor, uplo, *n, *alpha, x, *incx, y, *incy, a, *lda); +} + +void F77_sgbmv(int *layout, char *transp, int *m, int *n, int *kl, int *ku, + float *alpha, float *a, int *lda, float *x, int *incx, + float *beta, float *y, int *incy ) { + + float *A; + int i,irow,j,jcol,LDA; + CBLAS_TRANSPOSE trans; + + get_transpose_type(transp, &trans); + + if (*layout == TEST_ROW_MJR) { + LDA = *ku+*kl+2; + A = ( float* )malloc( (*n+*kl)*LDA*sizeof( float ) ); + for( i=0; i<*ku; i++ ){ + irow=*ku+*kl-i; + jcol=(*ku)-i; + for( j=jcol; j<*n; j++ ) + A[ LDA*(j-jcol)+irow ]=a[ (*lda)*j+i ]; + } + i=*ku; + irow=*ku+*kl-i; + for( j=0; j<*n; j++ ) + A[ LDA*j+irow ]=a[ (*lda)*j+i ]; + for( i=*ku+1; i<*ku+*kl+1; i++ ){ + irow=*ku+*kl-i; + jcol=i-(*ku); + for( j=jcol; j<(*n+*kl); j++ ) + A[ LDA*j+irow ]=a[ (*lda)*(j-jcol)+i ]; + } + cblas_sgbmv( CblasRowMajor, trans, *m, *n, *kl, *ku, *alpha, + A, LDA, x, *incx, *beta, y, *incy ); + free(A); + } + else + cblas_sgbmv( CblasColMajor, trans, *m, *n, *kl, *ku, *alpha, + a, *lda, x, *incx, *beta, y, *incy ); +} + +void F77_stbmv(int *layout, char *uplow, char *transp, char *diagn, + int *n, int *k, float *a, int *lda, float *x, int *incx) { + float *A; + int irow, jcol, i, j, LDA; + CBLAS_TRANSPOSE trans; + CBLAS_UPLO uplo; + CBLAS_DIAG diag; + + get_transpose_type(transp,&trans); + get_uplo_type(uplow,&uplo); + get_diag_type(diagn,&diag); + + if (*layout == TEST_ROW_MJR) { + LDA = *k+1; + A = ( float* )malloc( (*n+*k)*LDA*sizeof( float ) ); + if (uplo == CblasUpper) { + for( i=0; i<*k; i++ ){ + irow=*k-i; + jcol=(*k)-i; + for( j=jcol; j<*n; j++ ) + A[ LDA*(j-jcol)+irow ]=a[ (*lda)*j+i ]; + } + i=*k; + irow=*k-i; + for( j=0; j<*n; j++ ) + A[ LDA*j+irow ]=a[ (*lda)*j+i ]; + } + else { + i=0; + irow=*k-i; + for( j=0; j<*n; j++ ) + A[ LDA*j+irow ]=a[ (*lda)*j+i ]; + for( i=1; i<*k+1; i++ ){ + irow=*k-i; + jcol=i; + for( j=jcol; j<(*n+*k); j++ ) + A[ LDA*j+irow ]=a[ (*lda)*(j-jcol)+i ]; + } + } + cblas_stbmv(CblasRowMajor, uplo, trans, diag, *n, *k, A, LDA, x, *incx); + free(A); + } + else + cblas_stbmv(CblasColMajor, uplo, trans, diag, *n, *k, a, *lda, x, *incx); +} + +void F77_stbsv(int *layout, char *uplow, char *transp, char *diagn, + int *n, int *k, float *a, int *lda, float *x, int *incx) { + float *A; + int irow, jcol, i, j, LDA; + CBLAS_TRANSPOSE trans; + CBLAS_UPLO uplo; + CBLAS_DIAG diag; + + get_transpose_type(transp,&trans); + get_uplo_type(uplow,&uplo); + get_diag_type(diagn,&diag); + + if (*layout == TEST_ROW_MJR) { + LDA = *k+1; + A = ( float* )malloc( (*n+*k)*LDA*sizeof( float ) ); + if (uplo == CblasUpper) { + for( i=0; i<*k; i++ ){ + irow=*k-i; + jcol=(*k)-i; + for( j=jcol; j<*n; j++ ) + A[ LDA*(j-jcol)+irow ]=a[ (*lda)*j+i ]; + } + i=*k; + irow=*k-i; + for( j=0; j<*n; j++ ) + A[ LDA*j+irow ]=a[ (*lda)*j+i ]; + } + else { + i=0; + irow=*k-i; + for( j=0; j<*n; j++ ) + A[ LDA*j+irow ]=a[ (*lda)*j+i ]; + for( i=1; i<*k+1; i++ ){ + irow=*k-i; + jcol=i; + for( j=jcol; j<(*n+*k); j++ ) + A[ LDA*j+irow ]=a[ (*lda)*(j-jcol)+i ]; + } + } + cblas_stbsv(CblasRowMajor, uplo, trans, diag, *n, *k, A, LDA, x, *incx); + free(A); + } + else + cblas_stbsv(CblasColMajor, uplo, trans, diag, *n, *k, a, *lda, x, *incx); +} + +void F77_ssbmv(int *layout, char *uplow, int *n, int *k, float *alpha, + float *a, int *lda, float *x, int *incx, float *beta, + float *y, int *incy) { + float *A; + int i,j,irow,jcol,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + LDA = *k+1; + A = ( float* )malloc( (*n+*k)*LDA*sizeof( float ) ); + if (uplo == CblasUpper) { + for( i=0; i<*k; i++ ){ + irow=*k-i; + jcol=(*k)-i; + for( j=jcol; j<*n; j++ ) + A[ LDA*(j-jcol)+irow ]=a[ (*lda)*j+i ]; + } + i=*k; + irow=*k-i; + for( j=0; j<*n; j++ ) + A[ LDA*j+irow ]=a[ (*lda)*j+i ]; + } + else { + i=0; + irow=*k-i; + for( j=0; j<*n; j++ ) + A[ LDA*j+irow ]=a[ (*lda)*j+i ]; + for( i=1; i<*k+1; i++ ){ + irow=*k-i; + jcol=i; + for( j=jcol; j<(*n+*k); j++ ) + A[ LDA*j+irow ]=a[ (*lda)*(j-jcol)+i ]; + } + } + cblas_ssbmv(CblasRowMajor, uplo, *n, *k, *alpha, A, LDA, x, *incx, + *beta, y, *incy ); + free(A); + } + else + cblas_ssbmv(CblasColMajor, uplo, *n, *k, *alpha, a, *lda, x, *incx, + *beta, y, *incy ); +} + +void F77_sspmv(int *layout, char *uplow, int *n, float *alpha, float *ap, + float *x, int *incx, float *beta, float *y, int *incy) { + float *A,*AP; + int i,j,k,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + LDA = *n; + A = ( float* )malloc( LDA*LDA*sizeof( float ) ); + AP = ( float* )malloc( (((LDA+1)*LDA)/2)*sizeof( float ) ); + if (uplo == CblasUpper) { + for( j=0, k=0; j<*n; j++ ) + for( i=0; i<j+1; i++, k++ ) + A[ LDA*i+j ]=ap[ k ]; + for( i=0, k=0; i<*n; i++ ) + for( j=i; j<*n; j++, k++ ) + AP[ k ]=A[ LDA*i+j ]; + } + else { + for( j=0, k=0; j<*n; j++ ) + for( i=j; i<*n; i++, k++ ) + A[ LDA*i+j ]=ap[ k ]; + for( i=0, k=0; i<*n; i++ ) + for( j=0; j<i+1; j++, k++ ) + AP[ k ]=A[ LDA*i+j ]; + } + cblas_sspmv( CblasRowMajor, uplo, *n, *alpha, AP, x, *incx, *beta, y, + *incy ); + free(A); free(AP); + } + else + cblas_sspmv( CblasColMajor, uplo, *n, *alpha, ap, x, *incx, *beta, y, + *incy ); +} + +void F77_stpmv(int *layout, char *uplow, char *transp, char *diagn, + int *n, float *ap, float *x, int *incx) { + float *A, *AP; + int i, j, k, LDA; + CBLAS_TRANSPOSE trans; + CBLAS_UPLO uplo; + CBLAS_DIAG diag; + + get_transpose_type(transp,&trans); + get_uplo_type(uplow,&uplo); + get_diag_type(diagn,&diag); + + if (*layout == TEST_ROW_MJR) { + LDA = *n; + A = ( float* )malloc( LDA*LDA*sizeof( float ) ); + AP = ( float* )malloc( (((LDA+1)*LDA)/2)*sizeof( float ) ); + if (uplo == CblasUpper) { + for( j=0, k=0; j<*n; j++ ) + for( i=0; i<j+1; i++, k++ ) + A[ LDA*i+j ]=ap[ k ]; + for( i=0, k=0; i<*n; i++ ) + for( j=i; j<*n; j++, k++ ) + AP[ k ]=A[ LDA*i+j ]; + } + else { + for( j=0, k=0; j<*n; j++ ) + for( i=j; i<*n; i++, k++ ) + A[ LDA*i+j ]=ap[ k ]; + for( i=0, k=0; i<*n; i++ ) + for( j=0; j<i+1; j++, k++ ) + AP[ k ]=A[ LDA*i+j ]; + } + cblas_stpmv( CblasRowMajor, uplo, trans, diag, *n, AP, x, *incx ); + free(A); free(AP); + } + else + cblas_stpmv( CblasColMajor, uplo, trans, diag, *n, ap, x, *incx ); +} + +void F77_stpsv(int *layout, char *uplow, char *transp, char *diagn, + int *n, float *ap, float *x, int *incx) { + float *A, *AP; + int i, j, k, LDA; + CBLAS_TRANSPOSE trans; + CBLAS_UPLO uplo; + CBLAS_DIAG diag; + + get_transpose_type(transp,&trans); + get_uplo_type(uplow,&uplo); + get_diag_type(diagn,&diag); + + if (*layout == TEST_ROW_MJR) { + LDA = *n; + A = ( float* )malloc( LDA*LDA*sizeof( float ) ); + AP = ( float* )malloc( (((LDA+1)*LDA)/2)*sizeof( float ) ); + if (uplo == CblasUpper) { + for( j=0, k=0; j<*n; j++ ) + for( i=0; i<j+1; i++, k++ ) + A[ LDA*i+j ]=ap[ k ]; + for( i=0, k=0; i<*n; i++ ) + for( j=i; j<*n; j++, k++ ) + AP[ k ]=A[ LDA*i+j ]; + + } + else { + for( j=0, k=0; j<*n; j++ ) + for( i=j; i<*n; i++, k++ ) + A[ LDA*i+j ]=ap[ k ]; + for( i=0, k=0; i<*n; i++ ) + for( j=0; j<i+1; j++, k++ ) + AP[ k ]=A[ LDA*i+j ]; + } + cblas_stpsv( CblasRowMajor, uplo, trans, diag, *n, AP, x, *incx ); + free(A); free(AP); + } + else + cblas_stpsv( CblasColMajor, uplo, trans, diag, *n, ap, x, *incx ); +} + +void F77_sspr(int *layout, char *uplow, int *n, float *alpha, float *x, + int *incx, float *ap ){ + float *A, *AP; + int i,j,k,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + LDA = *n; + A = ( float* )malloc( LDA*LDA*sizeof( float ) ); + AP = ( float* )malloc( (((LDA+1)*LDA)/2)*sizeof( float ) ); + if (uplo == CblasUpper) { + for( j=0, k=0; j<*n; j++ ) + for( i=0; i<j+1; i++, k++ ) + A[ LDA*i+j ]=ap[ k ]; + for( i=0, k=0; i<*n; i++ ) + for( j=i; j<*n; j++, k++ ) + AP[ k ]=A[ LDA*i+j ]; + } + else { + for( j=0, k=0; j<*n; j++ ) + for( i=j; i<*n; i++, k++ ) + A[ LDA*i+j ]=ap[ k ]; + for( i=0, k=0; i<*n; i++ ) + for( j=0; j<i+1; j++, k++ ) + AP[ k ]=A[ LDA*i+j ]; + } + cblas_sspr( CblasRowMajor, uplo, *n, *alpha, x, *incx, AP ); + if (uplo == CblasUpper) { + for( i=0, k=0; i<*n; i++ ) + for( j=i; j<*n; j++, k++ ) + A[ LDA*i+j ]=AP[ k ]; + for( j=0, k=0; j<*n; j++ ) + for( i=0; i<j+1; i++, k++ ) + ap[ k ]=A[ LDA*i+j ]; + } + else { + for( i=0, k=0; i<*n; i++ ) + for( j=0; j<i+1; j++, k++ ) + A[ LDA*i+j ]=AP[ k ]; + for( j=0, k=0; j<*n; j++ ) + for( i=j; i<*n; i++, k++ ) + ap[ k ]=A[ LDA*i+j ]; + } + free(A); free(AP); + } + else + cblas_sspr( CblasColMajor, uplo, *n, *alpha, x, *incx, ap ); +} + +void F77_sspr2(int *layout, char *uplow, int *n, float *alpha, float *x, + int *incx, float *y, int *incy, float *ap ){ + float *A, *AP; + int i,j,k,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + LDA = *n; + A = ( float* )malloc( LDA*LDA*sizeof( float ) ); + AP = ( float* )malloc( (((LDA+1)*LDA)/2)*sizeof( float ) ); + if (uplo == CblasUpper) { + for( j=0, k=0; j<*n; j++ ) + for( i=0; i<j+1; i++, k++ ) + A[ LDA*i+j ]=ap[ k ]; + for( i=0, k=0; i<*n; i++ ) + for( j=i; j<*n; j++, k++ ) + AP[ k ]=A[ LDA*i+j ]; + } + else { + for( j=0, k=0; j<*n; j++ ) + for( i=j; i<*n; i++, k++ ) + A[ LDA*i+j ]=ap[ k ]; + for( i=0, k=0; i<*n; i++ ) + for( j=0; j<i+1; j++, k++ ) + AP[ k ]=A[ LDA*i+j ]; + } + cblas_sspr2( CblasRowMajor, uplo, *n, *alpha, x, *incx, y, *incy, AP ); + if (uplo == CblasUpper) { + for( i=0, k=0; i<*n; i++ ) + for( j=i; j<*n; j++, k++ ) + A[ LDA*i+j ]=AP[ k ]; + for( j=0, k=0; j<*n; j++ ) + for( i=0; i<j+1; i++, k++ ) + ap[ k ]=A[ LDA*i+j ]; + } + else { + for( i=0, k=0; i<*n; i++ ) + for( j=0; j<i+1; j++, k++ ) + A[ LDA*i+j ]=AP[ k ]; + for( j=0, k=0; j<*n; j++ ) + for( i=j; i<*n; i++, k++ ) + ap[ k ]=A[ LDA*i+j ]; + } + free(A); + free(AP); + } + else + cblas_sspr2( CblasColMajor, uplo, *n, *alpha, x, *incx, y, *incy, ap ); +} diff --git a/cblas/testing/c_sblas3.c b/cblas/testing/c_sblas3.c new file mode 100644 index 00000000..3da274cd --- /dev/null +++ b/cblas/testing/c_sblas3.c @@ -0,0 +1,330 @@ +/* + * Written by D.P. Manley, Digital Equipment Corporation. + * Prefixed "C_" to BLAS routines and their declarations. + * + * Modified by T. H. Do, 2/19/98, SGI/CRAY Research. + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_test.h" + +void F77_sgemm(int *layout, char *transpa, char *transpb, int *m, int *n, + int *k, float *alpha, float *a, int *lda, float *b, int *ldb, + float *beta, float *c, int *ldc ) { + + float *A, *B, *C; + int i,j,LDA, LDB, LDC; + CBLAS_TRANSPOSE transa, transb; + + get_transpose_type(transpa, &transa); + get_transpose_type(transpb, &transb); + + if (*layout == TEST_ROW_MJR) { + if (transa == CblasNoTrans) { + LDA = *k+1; + A = (float *)malloc( (*m)*LDA*sizeof( float ) ); + for( i=0; i<*m; i++ ) + for( j=0; j<*k; j++ ) + A[i*LDA+j]=a[j*(*lda)+i]; + } + else { + LDA = *m+1; + A = ( float* )malloc( LDA*(*k)*sizeof( float ) ); + for( i=0; i<*k; i++ ) + for( j=0; j<*m; j++ ) + A[i*LDA+j]=a[j*(*lda)+i]; + } + if (transb == CblasNoTrans) { + LDB = *n+1; + B = ( float* )malloc( (*k)*LDB*sizeof( float ) ); + for( i=0; i<*k; i++ ) + for( j=0; j<*n; j++ ) + B[i*LDB+j]=b[j*(*ldb)+i]; + } + else { + LDB = *k+1; + B = ( float* )malloc( LDB*(*n)*sizeof( float ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*k; j++ ) + B[i*LDB+j]=b[j*(*ldb)+i]; + } + LDC = *n+1; + C = ( float* )malloc( (*m)*LDC*sizeof( float ) ); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) + C[i*LDC+j]=c[j*(*ldc)+i]; + cblas_sgemm( CblasRowMajor, transa, transb, *m, *n, *k, *alpha, A, LDA, + B, LDB, *beta, C, LDC ); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) + c[j*(*ldc)+i]=C[i*LDC+j]; + free(A); + free(B); + free(C); + } + else if (*layout == TEST_COL_MJR) + cblas_sgemm( CblasColMajor, transa, transb, *m, *n, *k, *alpha, a, *lda, + b, *ldb, *beta, c, *ldc ); + else + cblas_sgemm( UNDEFINED, transa, transb, *m, *n, *k, *alpha, a, *lda, + b, *ldb, *beta, c, *ldc ); +} +void F77_ssymm(int *layout, char *rtlf, char *uplow, int *m, int *n, + float *alpha, float *a, int *lda, float *b, int *ldb, + float *beta, float *c, int *ldc ) { + + float *A, *B, *C; + int i,j,LDA, LDB, LDC; + CBLAS_UPLO uplo; + CBLAS_SIDE side; + + get_uplo_type(uplow,&uplo); + get_side_type(rtlf,&side); + + if (*layout == TEST_ROW_MJR) { + if (side == CblasLeft) { + LDA = *m+1; + A = ( float* )malloc( (*m)*LDA*sizeof( float ) ); + for( i=0; i<*m; i++ ) + for( j=0; j<*m; j++ ) + A[i*LDA+j]=a[j*(*lda)+i]; + } + else{ + LDA = *n+1; + A = ( float* )malloc( (*n)*LDA*sizeof( float ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + A[i*LDA+j]=a[j*(*lda)+i]; + } + LDB = *n+1; + B = ( float* )malloc( (*m)*LDB*sizeof( float ) ); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ) + B[i*LDB+j]=b[j*(*ldb)+i]; + LDC = *n+1; + C = ( float* )malloc( (*m)*LDC*sizeof( float ) ); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) + C[i*LDC+j]=c[j*(*ldc)+i]; + cblas_ssymm( CblasRowMajor, side, uplo, *m, *n, *alpha, A, LDA, B, LDB, + *beta, C, LDC ); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) + c[j*(*ldc)+i]=C[i*LDC+j]; + free(A); + free(B); + free(C); + } + else if (*layout == TEST_COL_MJR) + cblas_ssymm( CblasColMajor, side, uplo, *m, *n, *alpha, a, *lda, b, *ldb, + *beta, c, *ldc ); + else + cblas_ssymm( UNDEFINED, side, uplo, *m, *n, *alpha, a, *lda, b, *ldb, + *beta, c, *ldc ); +} + +void F77_ssyrk(int *layout, char *uplow, char *transp, int *n, int *k, + float *alpha, float *a, int *lda, + float *beta, float *c, int *ldc ) { + + int i,j,LDA,LDC; + float *A, *C; + CBLAS_UPLO uplo; + CBLAS_TRANSPOSE trans; + + get_uplo_type(uplow,&uplo); + get_transpose_type(transp,&trans); + + if (*layout == TEST_ROW_MJR) { + if (trans == CblasNoTrans) { + LDA = *k+1; + A = ( float* )malloc( (*n)*LDA*sizeof( float ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*k; j++ ) + A[i*LDA+j]=a[j*(*lda)+i]; + } + else{ + LDA = *n+1; + A = ( float* )malloc( (*k)*LDA*sizeof( float ) ); + for( i=0; i<*k; i++ ) + for( j=0; j<*n; j++ ) + A[i*LDA+j]=a[j*(*lda)+i]; + } + LDC = *n+1; + C = ( float* )malloc( (*n)*LDC*sizeof( float ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + C[i*LDC+j]=c[j*(*ldc)+i]; + cblas_ssyrk(CblasRowMajor, uplo, trans, *n, *k, *alpha, A, LDA, *beta, + C, LDC ); + for( j=0; j<*n; j++ ) + for( i=0; i<*n; i++ ) + c[j*(*ldc)+i]=C[i*LDC+j]; + free(A); + free(C); + } + else if (*layout == TEST_COL_MJR) + cblas_ssyrk(CblasColMajor, uplo, trans, *n, *k, *alpha, a, *lda, *beta, + c, *ldc ); + else + cblas_ssyrk(UNDEFINED, uplo, trans, *n, *k, *alpha, a, *lda, *beta, + c, *ldc ); +} + +void F77_ssyr2k(int *layout, char *uplow, char *transp, int *n, int *k, + float *alpha, float *a, int *lda, float *b, int *ldb, + float *beta, float *c, int *ldc ) { + int i,j,LDA,LDB,LDC; + float *A, *B, *C; + CBLAS_UPLO uplo; + CBLAS_TRANSPOSE trans; + + get_uplo_type(uplow,&uplo); + get_transpose_type(transp,&trans); + + if (*layout == TEST_ROW_MJR) { + if (trans == CblasNoTrans) { + LDA = *k+1; + LDB = *k+1; + A = ( float* )malloc( (*n)*LDA*sizeof( float ) ); + B = ( float* )malloc( (*n)*LDB*sizeof( float ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*k; j++ ) { + A[i*LDA+j]=a[j*(*lda)+i]; + B[i*LDB+j]=b[j*(*ldb)+i]; + } + } + else { + LDA = *n+1; + LDB = *n+1; + A = ( float* )malloc( LDA*(*k)*sizeof( float ) ); + B = ( float* )malloc( LDB*(*k)*sizeof( float ) ); + for( i=0; i<*k; i++ ) + for( j=0; j<*n; j++ ){ + A[i*LDA+j]=a[j*(*lda)+i]; + B[i*LDB+j]=b[j*(*ldb)+i]; + } + } + LDC = *n+1; + C = ( float* )malloc( (*n)*LDC*sizeof( float ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + C[i*LDC+j]=c[j*(*ldc)+i]; + cblas_ssyr2k(CblasRowMajor, uplo, trans, *n, *k, *alpha, A, LDA, + B, LDB, *beta, C, LDC ); + for( j=0; j<*n; j++ ) + for( i=0; i<*n; i++ ) + c[j*(*ldc)+i]=C[i*LDC+j]; + free(A); + free(B); + free(C); + } + else if (*layout == TEST_COL_MJR) + cblas_ssyr2k(CblasColMajor, uplo, trans, *n, *k, *alpha, a, *lda, + b, *ldb, *beta, c, *ldc ); + else + cblas_ssyr2k(UNDEFINED, uplo, trans, *n, *k, *alpha, a, *lda, + b, *ldb, *beta, c, *ldc ); +} +void F77_strmm(int *layout, char *rtlf, char *uplow, char *transp, char *diagn, + int *m, int *n, float *alpha, float *a, int *lda, float *b, + int *ldb) { + int i,j,LDA,LDB; + float *A, *B; + CBLAS_SIDE side; + CBLAS_DIAG diag; + CBLAS_UPLO uplo; + CBLAS_TRANSPOSE trans; + + get_uplo_type(uplow,&uplo); + get_transpose_type(transp,&trans); + get_diag_type(diagn,&diag); + get_side_type(rtlf,&side); + + if (*layout == TEST_ROW_MJR) { + if (side == CblasLeft) { + LDA = *m+1; + A = ( float* )malloc( (*m)*LDA*sizeof( float ) ); + for( i=0; i<*m; i++ ) + for( j=0; j<*m; j++ ) + A[i*LDA+j]=a[j*(*lda)+i]; + } + else{ + LDA = *n+1; + A = ( float* )malloc( (*n)*LDA*sizeof( float ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + A[i*LDA+j]=a[j*(*lda)+i]; + } + LDB = *n+1; + B = ( float* )malloc( (*m)*LDB*sizeof( float ) ); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ) + B[i*LDB+j]=b[j*(*ldb)+i]; + cblas_strmm(CblasRowMajor, side, uplo, trans, diag, *m, *n, *alpha, + A, LDA, B, LDB ); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) + b[j*(*ldb)+i]=B[i*LDB+j]; + free(A); + free(B); + } + else if (*layout == TEST_COL_MJR) + cblas_strmm(CblasColMajor, side, uplo, trans, diag, *m, *n, *alpha, + a, *lda, b, *ldb); + else + cblas_strmm(UNDEFINED, side, uplo, trans, diag, *m, *n, *alpha, + a, *lda, b, *ldb); +} + +void F77_strsm(int *layout, char *rtlf, char *uplow, char *transp, char *diagn, + int *m, int *n, float *alpha, float *a, int *lda, float *b, + int *ldb) { + int i,j,LDA,LDB; + float *A, *B; + CBLAS_SIDE side; + CBLAS_DIAG diag; + CBLAS_UPLO uplo; + CBLAS_TRANSPOSE trans; + + get_uplo_type(uplow,&uplo); + get_transpose_type(transp,&trans); + get_diag_type(diagn,&diag); + get_side_type(rtlf,&side); + + if (*layout == TEST_ROW_MJR) { + if (side == CblasLeft) { + LDA = *m+1; + A = ( float* )malloc( (*m)*LDA*sizeof( float ) ); + for( i=0; i<*m; i++ ) + for( j=0; j<*m; j++ ) + A[i*LDA+j]=a[j*(*lda)+i]; + } + else{ + LDA = *n+1; + A = ( float* )malloc( (*n)*LDA*sizeof( float ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + A[i*LDA+j]=a[j*(*lda)+i]; + } + LDB = *n+1; + B = ( float* )malloc( (*m)*LDB*sizeof( float ) ); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ) + B[i*LDB+j]=b[j*(*ldb)+i]; + cblas_strsm(CblasRowMajor, side, uplo, trans, diag, *m, *n, *alpha, + A, LDA, B, LDB ); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) + b[j*(*ldb)+i]=B[i*LDB+j]; + free(A); + free(B); + } + else if (*layout == TEST_COL_MJR) + cblas_strsm(CblasColMajor, side, uplo, trans, diag, *m, *n, *alpha, + a, *lda, b, *ldb); + else + cblas_strsm(UNDEFINED, side, uplo, trans, diag, *m, *n, *alpha, + a, *lda, b, *ldb); +} diff --git a/cblas/testing/c_sblat1.f b/cblas/testing/c_sblat1.f new file mode 100644 index 00000000..de2b0380 --- /dev/null +++ b/cblas/testing/c_sblat1.f @@ -0,0 +1,728 @@ + PROGRAM SCBLAT1 +* Test program for the REAL Level 1 CBLAS. +* Based upon the original CBLAS test routine together with: +* F06EAF Example Program Text +* .. Parameters .. + INTEGER NOUT + PARAMETER (NOUT=6) +* .. Scalars in Common .. + INTEGER ICASE, INCX, INCY, MODE, N + LOGICAL PASS +* .. Local Scalars .. + REAL SFAC + INTEGER IC +* .. External Subroutines .. + EXTERNAL CHECK0, CHECK1, CHECK2, CHECK3, HEADER +* .. Common blocks .. + COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS +* .. Data statements .. + DATA SFAC/9.765625E-4/ +* .. Executable Statements .. + WRITE (NOUT,99999) + DO 20 IC = 1, 10 + ICASE = IC + CALL HEADER +* +* .. Initialize PASS, INCX, INCY, and MODE for a new case. .. +* .. the value 9999 for INCX, INCY or MODE will appear in the .. +* .. detailed output, if any, for cases that do not involve .. +* .. these parameters .. +* + PASS = .TRUE. + INCX = 9999 + INCY = 9999 + MODE = 9999 + IF (ICASE.EQ.3) THEN + CALL CHECK0(SFAC) + ELSE IF (ICASE.EQ.7 .OR. ICASE.EQ.8 .OR. ICASE.EQ.9 .OR. + + ICASE.EQ.10) THEN + CALL CHECK1(SFAC) + ELSE IF (ICASE.EQ.1 .OR. ICASE.EQ.2 .OR. ICASE.EQ.5 .OR. + + ICASE.EQ.6) THEN + CALL CHECK2(SFAC) + ELSE IF (ICASE.EQ.4) THEN + CALL CHECK3(SFAC) + END IF +* -- Print + IF (PASS) WRITE (NOUT,99998) + 20 CONTINUE + STOP +* +99999 FORMAT (' Real CBLAS Test Program Results',/1X) +99998 FORMAT (' ----- PASS -----') + END + SUBROUTINE HEADER +* .. Parameters .. + INTEGER NOUT + PARAMETER (NOUT=6) +* .. Scalars in Common .. + INTEGER ICASE, INCX, INCY, MODE, N + LOGICAL PASS +* .. Local Arrays .. + CHARACTER*15 L(10) +* .. Common blocks .. + COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS +* .. Data statements .. + DATA L(1)/'CBLAS_SDOT '/ + DATA L(2)/'CBLAS_SAXPY '/ + DATA L(3)/'CBLAS_SROTG '/ + DATA L(4)/'CBLAS_SROT '/ + DATA L(5)/'CBLAS_SCOPY '/ + DATA L(6)/'CBLAS_SSWAP '/ + DATA L(7)/'CBLAS_SNRM2 '/ + DATA L(8)/'CBLAS_SASUM '/ + DATA L(9)/'CBLAS_SSCAL '/ + DATA L(10)/'CBLAS_ISAMAX'/ +* .. Executable Statements .. + WRITE (NOUT,99999) ICASE, L(ICASE) + RETURN +* +99999 FORMAT (/' Test of subprogram number',I3,9X,A15) + END + SUBROUTINE CHECK0(SFAC) +* .. Parameters .. + INTEGER NOUT + PARAMETER (NOUT=6) +* .. Scalar Arguments .. + REAL SFAC +* .. Scalars in Common .. + INTEGER ICASE, INCX, INCY, MODE, N + LOGICAL PASS +* .. Local Scalars .. + REAL SA, SB, SC, SS + INTEGER K +* .. Local Arrays .. + REAL DA1(8), DATRUE(8), DB1(8), DBTRUE(8), DC1(8), + + DS1(8) +* .. External Subroutines .. + EXTERNAL SROTGTEST, STEST1 +* .. Common blocks .. + COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS +* .. Data statements .. + DATA DA1/0.3E0, 0.4E0, -0.3E0, -0.4E0, -0.3E0, 0.0E0, + + 0.0E0, 1.0E0/ + DATA DB1/0.4E0, 0.3E0, 0.4E0, 0.3E0, -0.4E0, 0.0E0, + + 1.0E0, 0.0E0/ + DATA DC1/0.6E0, 0.8E0, -0.6E0, 0.8E0, 0.6E0, 1.0E0, + + 0.0E0, 1.0E0/ + DATA DS1/0.8E0, 0.6E0, 0.8E0, -0.6E0, 0.8E0, 0.0E0, + + 1.0E0, 0.0E0/ + DATA DATRUE/0.5E0, 0.5E0, 0.5E0, -0.5E0, -0.5E0, + + 0.0E0, 1.0E0, 1.0E0/ + DATA DBTRUE/0.0E0, 0.6E0, 0.0E0, -0.6E0, 0.0E0, + + 0.0E0, 1.0E0, 0.0E0/ +* .. Executable Statements .. +* +* Compute true values which cannot be prestored +* in decimal notation +* + DBTRUE(1) = 1.0E0/0.6E0 + DBTRUE(3) = -1.0E0/0.6E0 + DBTRUE(5) = 1.0E0/0.6E0 +* + DO 20 K = 1, 8 +* .. Set N=K for identification in output if any .. + N = K + IF (ICASE.EQ.3) THEN +* .. SROTGTEST .. + IF (K.GT.8) GO TO 40 + SA = DA1(K) + SB = DB1(K) + CALL SROTGTEST(SA,SB,SC,SS) + CALL STEST1(SA,DATRUE(K),DATRUE(K),SFAC) + CALL STEST1(SB,DBTRUE(K),DBTRUE(K),SFAC) + CALL STEST1(SC,DC1(K),DC1(K),SFAC) + CALL STEST1(SS,DS1(K),DS1(K),SFAC) + ELSE + WRITE (NOUT,*) ' Shouldn''t be here in CHECK0' + STOP + END IF + 20 CONTINUE + 40 RETURN + END + SUBROUTINE CHECK1(SFAC) +* .. Parameters .. + INTEGER NOUT + PARAMETER (NOUT=6) +* .. Scalar Arguments .. + REAL SFAC +* .. Scalars in Common .. + INTEGER ICASE, INCX, INCY, MODE, N + LOGICAL PASS +* .. Local Scalars .. + INTEGER I, LEN, NP1 +* .. Local Arrays .. + REAL DTRUE1(5), DTRUE3(5), DTRUE5(8,5,2), DV(8,5,2), + + SA(10), STEMP(1), STRUE(8), SX(8) + INTEGER ITRUE2(5) +* .. External Functions .. + REAL SASUMTEST, SNRM2TEST + INTEGER ISAMAXTEST + EXTERNAL SASUMTEST, SNRM2TEST, ISAMAXTEST +* .. External Subroutines .. + EXTERNAL ITEST1, SSCALTEST, STEST, STEST1 +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Common blocks .. + COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS +* .. Data statements .. + DATA SA/0.3E0, -1.0E0, 0.0E0, 1.0E0, 0.3E0, 0.3E0, + + 0.3E0, 0.3E0, 0.3E0, 0.3E0/ + DATA DV/0.1E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, + + 2.0E0, 2.0E0, 0.3E0, 3.0E0, 3.0E0, 3.0E0, 3.0E0, + + 3.0E0, 3.0E0, 3.0E0, 0.3E0, -0.4E0, 4.0E0, + + 4.0E0, 4.0E0, 4.0E0, 4.0E0, 4.0E0, 0.2E0, + + -0.6E0, 0.3E0, 5.0E0, 5.0E0, 5.0E0, 5.0E0, + + 5.0E0, 0.1E0, -0.3E0, 0.5E0, -0.1E0, 6.0E0, + + 6.0E0, 6.0E0, 6.0E0, 0.1E0, 8.0E0, 8.0E0, 8.0E0, + + 8.0E0, 8.0E0, 8.0E0, 8.0E0, 0.3E0, 9.0E0, 9.0E0, + + 9.0E0, 9.0E0, 9.0E0, 9.0E0, 9.0E0, 0.3E0, 2.0E0, + + -0.4E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, + + 0.2E0, 3.0E0, -0.6E0, 5.0E0, 0.3E0, 2.0E0, + + 2.0E0, 2.0E0, 0.1E0, 4.0E0, -0.3E0, 6.0E0, + + -0.5E0, 7.0E0, -0.1E0, 3.0E0/ + DATA DTRUE1/0.0E0, 0.3E0, 0.5E0, 0.7E0, 0.6E0/ + DATA DTRUE3/0.0E0, 0.3E0, 0.7E0, 1.1E0, 1.0E0/ + DATA DTRUE5/0.10E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, + + 2.0E0, 2.0E0, 2.0E0, -0.3E0, 3.0E0, 3.0E0, + + 3.0E0, 3.0E0, 3.0E0, 3.0E0, 3.0E0, 0.0E0, 0.0E0, + + 4.0E0, 4.0E0, 4.0E0, 4.0E0, 4.0E0, 4.0E0, + + 0.20E0, -0.60E0, 0.30E0, 5.0E0, 5.0E0, 5.0E0, + + 5.0E0, 5.0E0, 0.03E0, -0.09E0, 0.15E0, -0.03E0, + + 6.0E0, 6.0E0, 6.0E0, 6.0E0, 0.10E0, 8.0E0, + + 8.0E0, 8.0E0, 8.0E0, 8.0E0, 8.0E0, 8.0E0, + + 0.09E0, 9.0E0, 9.0E0, 9.0E0, 9.0E0, 9.0E0, + + 9.0E0, 9.0E0, 0.09E0, 2.0E0, -0.12E0, 2.0E0, + + 2.0E0, 2.0E0, 2.0E0, 2.0E0, 0.06E0, 3.0E0, + + -0.18E0, 5.0E0, 0.09E0, 2.0E0, 2.0E0, 2.0E0, + + 0.03E0, 4.0E0, -0.09E0, 6.0E0, -0.15E0, 7.0E0, + + -0.03E0, 3.0E0/ + DATA ITRUE2/0, 1, 2, 2, 3/ +* .. Executable Statements .. + DO 80 INCX = 1, 2 + DO 60 NP1 = 1, 5 + N = NP1 - 1 + LEN = 2*MAX(N,1) +* .. Set vector arguments .. + DO 20 I = 1, LEN + SX(I) = DV(I,NP1,INCX) + 20 CONTINUE +* + IF (ICASE.EQ.7) THEN +* .. SNRM2TEST .. + STEMP(1) = DTRUE1(NP1) + CALL STEST1(SNRM2TEST(N,SX,INCX),STEMP,STEMP,SFAC) + ELSE IF (ICASE.EQ.8) THEN +* .. SASUMTEST .. + STEMP(1) = DTRUE3(NP1) + CALL STEST1(SASUMTEST(N,SX,INCX),STEMP,STEMP,SFAC) + ELSE IF (ICASE.EQ.9) THEN +* .. SSCALTEST .. + CALL SSCALTEST(N,SA((INCX-1)*5+NP1),SX,INCX) + DO 40 I = 1, LEN + STRUE(I) = DTRUE5(I,NP1,INCX) + 40 CONTINUE + CALL STEST(LEN,SX,STRUE,STRUE,SFAC) + ELSE IF (ICASE.EQ.10) THEN +* .. ISAMAXTEST .. + CALL ITEST1(ISAMAXTEST(N,SX,INCX),ITRUE2(NP1)) + ELSE + WRITE (NOUT,*) ' Shouldn''t be here in CHECK1' + STOP + END IF + 60 CONTINUE + 80 CONTINUE + RETURN + END + SUBROUTINE CHECK2(SFAC) +* .. Parameters .. + INTEGER NOUT + PARAMETER (NOUT=6) +* .. Scalar Arguments .. + REAL SFAC +* .. Scalars in Common .. + INTEGER ICASE, INCX, INCY, MODE, N + LOGICAL PASS +* .. Local Scalars .. + REAL SA + INTEGER I, J, KI, KN, KSIZE, LENX, LENY, MX, MY +* .. Local Arrays .. + REAL DT10X(7,4,4), DT10Y(7,4,4), DT7(4,4), + + DT8(7,4,4), DX1(7), + + DY1(7), SSIZE1(4), SSIZE2(14,2), STX(7), STY(7), + + SX(7), SY(7) + INTEGER INCXS(4), INCYS(4), LENS(4,2), NS(4) +* .. External Functions .. + REAL SDOTTEST + EXTERNAL SDOTTEST +* .. External Subroutines .. + EXTERNAL SAXPYTEST, SCOPYTEST, SSWAPTEST, STEST, STEST1 +* .. Intrinsic Functions .. + INTRINSIC ABS, MIN +* .. Common blocks .. + COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS +* .. Data statements .. + DATA SA/0.3E0/ + DATA INCXS/1, 2, -2, -1/ + DATA INCYS/1, -2, 1, -2/ + DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/ + DATA NS/0, 1, 2, 4/ + DATA DX1/0.6E0, 0.1E0, -0.5E0, 0.8E0, 0.9E0, -0.3E0, + + -0.4E0/ + DATA DY1/0.5E0, -0.9E0, 0.3E0, 0.7E0, -0.6E0, 0.2E0, + + 0.8E0/ + DATA DT7/0.0E0, 0.30E0, 0.21E0, 0.62E0, 0.0E0, + + 0.30E0, -0.07E0, 0.85E0, 0.0E0, 0.30E0, -0.79E0, + + -0.74E0, 0.0E0, 0.30E0, 0.33E0, 1.27E0/ + DATA DT8/0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.68E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.0E0, 0.68E0, -0.87E0, 0.0E0, 0.0E0, + + 0.0E0, 0.0E0, 0.0E0, 0.68E0, -0.87E0, 0.15E0, + + 0.94E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0, + + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.68E0, + + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.35E0, -0.9E0, 0.48E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.38E0, -0.9E0, 0.57E0, 0.7E0, -0.75E0, + + 0.2E0, 0.98E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.0E0, 0.0E0, 0.68E0, 0.0E0, 0.0E0, + + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.35E0, -0.72E0, + + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.38E0, + + -0.63E0, 0.15E0, 0.88E0, 0.0E0, 0.0E0, 0.0E0, + + 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.68E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.68E0, -0.9E0, 0.33E0, 0.0E0, 0.0E0, + + 0.0E0, 0.0E0, 0.68E0, -0.9E0, 0.33E0, 0.7E0, + + -0.75E0, 0.2E0, 1.04E0/ + DATA DT10X/0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.5E0, -0.9E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.0E0, 0.5E0, -0.9E0, 0.3E0, 0.7E0, + + 0.0E0, 0.0E0, 0.0E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.0E0, 0.0E0, 0.3E0, 0.1E0, 0.5E0, 0.0E0, + + 0.0E0, 0.0E0, 0.0E0, 0.8E0, 0.1E0, -0.6E0, + + 0.8E0, 0.3E0, -0.3E0, 0.5E0, 0.6E0, 0.0E0, + + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0, + + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, -0.9E0, + + 0.1E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.7E0, + + 0.1E0, 0.3E0, 0.8E0, -0.9E0, -0.3E0, 0.5E0, + + 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.5E0, 0.3E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.5E0, 0.3E0, -0.6E0, 0.8E0, 0.0E0, 0.0E0, + + 0.0E0/ + DATA DT10Y/0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.6E0, 0.1E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.6E0, 0.1E0, -0.5E0, 0.8E0, 0.0E0, + + 0.0E0, 0.0E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.0E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.0E0, -0.5E0, -0.9E0, 0.6E0, 0.0E0, + + 0.0E0, 0.0E0, 0.0E0, -0.4E0, -0.9E0, 0.9E0, + + 0.7E0, -0.5E0, 0.2E0, 0.6E0, 0.5E0, 0.0E0, + + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.6E0, 0.0E0, + + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, -0.5E0, + + 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + -0.4E0, 0.9E0, -0.5E0, 0.6E0, 0.0E0, 0.0E0, + + 0.0E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.6E0, -0.9E0, 0.1E0, 0.0E0, 0.0E0, + + 0.0E0, 0.0E0, 0.6E0, -0.9E0, 0.1E0, 0.7E0, + + -0.5E0, 0.2E0, 0.8E0/ + DATA SSIZE1/0.0E0, 0.3E0, 1.6E0, 3.2E0/ + DATA SSIZE2/0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, + + 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, + + 1.17E0, 1.17E0, 1.17E0/ +* .. Executable Statements .. +* + DO 120 KI = 1, 4 + INCX = INCXS(KI) + INCY = INCYS(KI) + MX = ABS(INCX) + MY = ABS(INCY) +* + DO 100 KN = 1, 4 + N = NS(KN) + KSIZE = MIN(2,KN) + LENX = LENS(KN,MX) + LENY = LENS(KN,MY) +* .. Initialize all argument arrays .. + DO 20 I = 1, 7 + SX(I) = DX1(I) + SY(I) = DY1(I) + 20 CONTINUE +* + IF (ICASE.EQ.1) THEN +* .. SDOTTEST .. + CALL STEST1(SDOTTEST(N,SX,INCX,SY,INCY),DT7(KN,KI), + + SSIZE1(KN),SFAC) + ELSE IF (ICASE.EQ.2) THEN +* .. SAXPYTEST .. + CALL SAXPYTEST(N,SA,SX,INCX,SY,INCY) + DO 40 J = 1, LENY + STY(J) = DT8(J,KN,KI) + 40 CONTINUE + CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC) + ELSE IF (ICASE.EQ.5) THEN +* .. SCOPYTEST .. + DO 60 I = 1, 7 + STY(I) = DT10Y(I,KN,KI) + 60 CONTINUE + CALL SCOPYTEST(N,SX,INCX,SY,INCY) + CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0E0) + ELSE IF (ICASE.EQ.6) THEN +* .. SSWAPTEST .. + CALL SSWAPTEST(N,SX,INCX,SY,INCY) + DO 80 I = 1, 7 + STX(I) = DT10X(I,KN,KI) + STY(I) = DT10Y(I,KN,KI) + 80 CONTINUE + CALL STEST(LENX,SX,STX,SSIZE2(1,1),1.0E0) + CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0E0) + ELSE + WRITE (NOUT,*) ' Shouldn''t be here in CHECK2' + STOP + END IF + 100 CONTINUE + 120 CONTINUE + RETURN + END + SUBROUTINE CHECK3(SFAC) +* .. Parameters .. + INTEGER NOUT + PARAMETER (NOUT=6) +* .. Scalar Arguments .. + REAL SFAC +* .. Scalars in Common .. + INTEGER ICASE, INCX, INCY, MODE, N + LOGICAL PASS +* .. Local Scalars .. + REAL SC, SS + INTEGER I, K, KI, KN, KSIZE, LENX, LENY, MX, MY +* .. Local Arrays .. + REAL COPYX(5), COPYY(5), DT9X(7,4,4), DT9Y(7,4,4), + + DX1(7), DY1(7), MWPC(11), MWPS(11), MWPSTX(5), + + MWPSTY(5), MWPTX(11,5), MWPTY(11,5), MWPX(5), + + MWPY(5), SSIZE2(14,2), STX(7), STY(7), SX(7), + + SY(7) + INTEGER INCXS(4), INCYS(4), LENS(4,2), MWPINX(11), + + MWPINY(11), MWPN(11), NS(4) +* .. External Subroutines .. + EXTERNAL SROTTEST, STEST +* .. Intrinsic Functions .. + INTRINSIC ABS, MIN +* .. Common blocks .. + COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS +* .. Data statements .. + DATA INCXS/1, 2, -2, -1/ + DATA INCYS/1, -2, 1, -2/ + DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/ + DATA NS/0, 1, 2, 4/ + DATA DX1/0.6E0, 0.1E0, -0.5E0, 0.8E0, 0.9E0, -0.3E0, + + -0.4E0/ + DATA DY1/0.5E0, -0.9E0, 0.3E0, 0.7E0, -0.6E0, 0.2E0, + + 0.8E0/ + DATA SC, SS/0.8E0, 0.6E0/ + DATA DT9X/0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.78E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.0E0, 0.78E0, -0.46E0, 0.0E0, 0.0E0, + + 0.0E0, 0.0E0, 0.0E0, 0.78E0, -0.46E0, -0.22E0, + + 1.06E0, 0.0E0, 0.0E0, 0.0E0, 0.6E0, 0.0E0, + + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.78E0, + + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.66E0, 0.1E0, -0.1E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.96E0, 0.1E0, -0.76E0, 0.8E0, 0.90E0, + + -0.3E0, -0.02E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.0E0, 0.0E0, 0.78E0, 0.0E0, 0.0E0, + + 0.0E0, 0.0E0, 0.0E0, 0.0E0, -0.06E0, 0.1E0, + + -0.1E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.90E0, + + 0.1E0, -0.22E0, 0.8E0, 0.18E0, -0.3E0, -0.02E0, + + 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.78E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.78E0, 0.26E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.0E0, 0.78E0, 0.26E0, -0.76E0, 1.12E0, + + 0.0E0, 0.0E0, 0.0E0/ + DATA DT9Y/0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.04E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.0E0, 0.04E0, -0.78E0, 0.0E0, 0.0E0, + + 0.0E0, 0.0E0, 0.0E0, 0.04E0, -0.78E0, 0.54E0, + + 0.08E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0, + + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.04E0, + + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.7E0, + + -0.9E0, -0.12E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.64E0, -0.9E0, -0.30E0, 0.7E0, -0.18E0, 0.2E0, + + 0.28E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.0E0, 0.04E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.0E0, 0.0E0, 0.7E0, -1.08E0, 0.0E0, + + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.64E0, -1.26E0, + + 0.54E0, 0.20E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, + + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.04E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.04E0, -0.9E0, 0.18E0, 0.0E0, 0.0E0, + + 0.0E0, 0.0E0, 0.04E0, -0.9E0, 0.18E0, 0.7E0, + + -0.18E0, 0.2E0, 0.16E0/ + DATA SSIZE2/0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + + 0.0E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, + + 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, + + 1.17E0, 1.17E0, 1.17E0/ +* .. Executable Statements .. +* + DO 60 KI = 1, 4 + INCX = INCXS(KI) + INCY = INCYS(KI) + MX = ABS(INCX) + MY = ABS(INCY) +* + DO 40 KN = 1, 4 + N = NS(KN) + KSIZE = MIN(2,KN) + LENX = LENS(KN,MX) + LENY = LENS(KN,MY) +* + IF (ICASE.EQ.4) THEN +* .. SROTTEST .. + DO 20 I = 1, 7 + SX(I) = DX1(I) + SY(I) = DY1(I) + STX(I) = DT9X(I,KN,KI) + STY(I) = DT9Y(I,KN,KI) + 20 CONTINUE + CALL SROTTEST(N,SX,INCX,SY,INCY,SC,SS) + CALL STEST(LENX,SX,STX,SSIZE2(1,KSIZE),SFAC) + CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC) + ELSE + WRITE (NOUT,*) ' Shouldn''t be here in CHECK3' + STOP + END IF + 40 CONTINUE + 60 CONTINUE +* + MWPC(1) = 1 + DO 80 I = 2, 11 + MWPC(I) = 0 + 80 CONTINUE + MWPS(1) = 0 + DO 100 I = 2, 6 + MWPS(I) = 1 + 100 CONTINUE + DO 120 I = 7, 11 + MWPS(I) = -1 + 120 CONTINUE + MWPINX(1) = 1 + MWPINX(2) = 1 + MWPINX(3) = 1 + MWPINX(4) = -1 + MWPINX(5) = 1 + MWPINX(6) = -1 + MWPINX(7) = 1 + MWPINX(8) = 1 + MWPINX(9) = -1 + MWPINX(10) = 1 + MWPINX(11) = -1 + MWPINY(1) = 1 + MWPINY(2) = 1 + MWPINY(3) = -1 + MWPINY(4) = -1 + MWPINY(5) = 2 + MWPINY(6) = 1 + MWPINY(7) = 1 + MWPINY(8) = -1 + MWPINY(9) = -1 + MWPINY(10) = 2 + MWPINY(11) = 1 + DO 140 I = 1, 11 + MWPN(I) = 5 + 140 CONTINUE + MWPN(5) = 3 + MWPN(10) = 3 + DO 160 I = 1, 5 + MWPX(I) = I + MWPY(I) = I + MWPTX(1,I) = I + MWPTY(1,I) = I + MWPTX(2,I) = I + MWPTY(2,I) = -I + MWPTX(3,I) = 6 - I + MWPTY(3,I) = I - 6 + MWPTX(4,I) = I + MWPTY(4,I) = -I + MWPTX(6,I) = 6 - I + MWPTY(6,I) = I - 6 + MWPTX(7,I) = -I + MWPTY(7,I) = I + MWPTX(8,I) = I - 6 + MWPTY(8,I) = 6 - I + MWPTX(9,I) = -I + MWPTY(9,I) = I + MWPTX(11,I) = I - 6 + MWPTY(11,I) = 6 - I + 160 CONTINUE + MWPTX(5,1) = 1 + MWPTX(5,2) = 3 + MWPTX(5,3) = 5 + MWPTX(5,4) = 4 + MWPTX(5,5) = 5 + MWPTY(5,1) = -1 + MWPTY(5,2) = 2 + MWPTY(5,3) = -2 + MWPTY(5,4) = 4 + MWPTY(5,5) = -3 + MWPTX(10,1) = -1 + MWPTX(10,2) = -3 + MWPTX(10,3) = -5 + MWPTX(10,4) = 4 + MWPTX(10,5) = 5 + MWPTY(10,1) = 1 + MWPTY(10,2) = 2 + MWPTY(10,3) = 2 + MWPTY(10,4) = 4 + MWPTY(10,5) = 3 + DO 200 I = 1, 11 + INCX = MWPINX(I) + INCY = MWPINY(I) + DO 180 K = 1, 5 + COPYX(K) = MWPX(K) + COPYY(K) = MWPY(K) + MWPSTX(K) = MWPTX(I,K) + MWPSTY(K) = MWPTY(I,K) + 180 CONTINUE + CALL SROTTEST(MWPN(I),COPYX,INCX,COPYY,INCY,MWPC(I),MWPS(I)) + CALL STEST(5,COPYX,MWPSTX,MWPSTX,SFAC) + CALL STEST(5,COPYY,MWPSTY,MWPSTY,SFAC) + 200 CONTINUE + RETURN + END + SUBROUTINE STEST(LEN,SCOMP,STRUE,SSIZE,SFAC) +* ********************************* STEST ************************** +* +* THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO +* SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE +* NEGLIGIBLE. +* +* C. L. LAWSON, JPL, 1974 DEC 10 +* +* .. Parameters .. + INTEGER NOUT + PARAMETER (NOUT=6) +* .. Scalar Arguments .. + REAL SFAC + INTEGER LEN +* .. Array Arguments .. + REAL SCOMP(LEN), SSIZE(LEN), STRUE(LEN) +* .. Scalars in Common .. + INTEGER ICASE, INCX, INCY, MODE, N + LOGICAL PASS +* .. Local Scalars .. + REAL SD + INTEGER I +* .. External Functions .. + REAL SDIFF + EXTERNAL SDIFF +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. Common blocks .. + COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS +* .. Executable Statements .. +* + DO 40 I = 1, LEN + SD = SCOMP(I) - STRUE(I) + IF (SDIFF(ABS(SSIZE(I))+ABS(SFAC*SD),ABS(SSIZE(I))).EQ.0.0E0) + + GO TO 40 +* +* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I). +* + IF ( .NOT. PASS) GO TO 20 +* PRINT FAIL MESSAGE AND HEADER. + PASS = .FALSE. + WRITE (NOUT,99999) + WRITE (NOUT,99998) + 20 WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, I, SCOMP(I), + + STRUE(I), SD, SSIZE(I) + 40 CONTINUE + RETURN +* +99999 FORMAT (' FAIL') +99998 FORMAT (/' CASE N INCX INCY MODE I ', + + ' COMP(I) TRUE(I) DIFFERENCE', + + ' SIZE(I)',/1X) +99997 FORMAT (1X,I4,I3,3I5,I3,2E36.8,2E12.4) + END + SUBROUTINE STEST1(SCOMP1,STRUE1,SSIZE,SFAC) +* ************************* STEST1 ***************************** +* +* THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN +* REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE +* ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT. +* +* C.L. LAWSON, JPL, 1978 DEC 6 +* +* .. Scalar Arguments .. + REAL SCOMP1, SFAC, STRUE1 +* .. Array Arguments .. + REAL SSIZE(*) +* .. Local Arrays .. + REAL SCOMP(1), STRUE(1) +* .. External Subroutines .. + EXTERNAL STEST +* .. Executable Statements .. +* + SCOMP(1) = SCOMP1 + STRUE(1) = STRUE1 + CALL STEST(1,SCOMP,STRUE,SSIZE,SFAC) +* + RETURN + END + REAL FUNCTION SDIFF(SA,SB) +* ********************************* SDIFF ************************** +* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15 +* +* .. Scalar Arguments .. + REAL SA, SB +* .. Executable Statements .. + SDIFF = SA - SB + RETURN + END + SUBROUTINE ITEST1(ICOMP,ITRUE) +* ********************************* ITEST1 ************************* +* +* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR +* EQUALITY. +* C. L. LAWSON, JPL, 1974 DEC 10 +* +* .. Parameters .. + INTEGER NOUT + PARAMETER (NOUT=6) +* .. Scalar Arguments .. + INTEGER ICOMP, ITRUE +* .. Scalars in Common .. + INTEGER ICASE, INCX, INCY, MODE, N + LOGICAL PASS +* .. Local Scalars .. + INTEGER ID +* .. Common blocks .. + COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS +* .. Executable Statements .. +* + IF (ICOMP.EQ.ITRUE) GO TO 40 +* +* HERE ICOMP IS NOT EQUAL TO ITRUE. +* + IF ( .NOT. PASS) GO TO 20 +* PRINT FAIL MESSAGE AND HEADER. + PASS = .FALSE. + WRITE (NOUT,99999) + WRITE (NOUT,99998) + 20 ID = ICOMP - ITRUE + WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, ICOMP, ITRUE, ID + 40 CONTINUE + RETURN +* +99999 FORMAT (' FAIL') +99998 FORMAT (/' CASE N INCX INCY MODE ', + + ' COMP TRUE DIFFERENCE', + + /1X) +99997 FORMAT (1X,I4,I3,3I5,2I36,I12) + END diff --git a/cblas/testing/c_sblat2.f b/cblas/testing/c_sblat2.f new file mode 100644 index 00000000..bf6f3e45 --- /dev/null +++ b/cblas/testing/c_sblat2.f @@ -0,0 +1,2907 @@ + PROGRAM SBLAT2 +* +* Test program for the REAL Level 2 Blas. +* +* The program must be driven by a short data file. The first 17 records +* of the file are read using list-directed input, the last 16 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 33 lines: +* 'SBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE +* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) +* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. +* F LOGICAL FLAG, T TO STOP ON FAILURES. +* T LOGICAL FLAG, T TO TEST ERROR EXITS. +* 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 +* 4 NUMBER OF VALUES OF K +* 0 1 2 4 VALUES OF K +* 4 NUMBER OF VALUES OF INCX AND INCY +* 1 2 -1 -2 VALUES OF INCX AND INCY +* 3 NUMBER OF VALUES OF ALPHA +* 0.0 1.0 0.7 VALUES OF ALPHA +* 3 NUMBER OF VALUES OF BETA +* 0.0 1.0 0.9 VALUES OF BETA +* cblas_sgemv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_sgbmv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_ssymv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_ssbmv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_sspmv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_strmv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_stbmv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_stpmv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_strsv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_stbsv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_stpsv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_sger T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_ssyr T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_sspr T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_ssyr2 T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_sspr2 T PUT F FOR NO TEST. SAME COLUMNS. +* +* See: +* +* Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J.. +* An extended set of Fortran Basic Linear Algebra Subprograms. +* +* Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics +* and Computer Science Division, Argonne National Laboratory, +* 9700 South Cass Avenue, Argonne, Illinois 60439, US. +* +* Or +* +* NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms +* Group Ltd., NAG Central Office, 256 Banbury Road, Oxford +* OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st +* Street, Suite 100, Downers Grove, Illinois 60515-1263, USA. +* +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + INTEGER NIN, NOUT + PARAMETER ( NIN = 5, NOUT = 6 ) + INTEGER NSUBS + PARAMETER ( NSUBS = 16 ) + REAL ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 ) + INTEGER NMAX, INCMAX + PARAMETER ( NMAX = 65, INCMAX = 2 ) + INTEGER NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX + PARAMETER ( NINMAX = 7, NIDMAX = 9, NKBMAX = 7, + $ NALMAX = 7, NBEMAX = 7 ) +* .. Local Scalars .. + REAL EPS, ERR, THRESH + INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB, + $ NTRA, LAYOUT + LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, + $ TSTERR, CORDER, RORDER + CHARACTER*1 TRANS + CHARACTER*12 SNAMET + CHARACTER*32 SNAPS +* .. Local Arrays .. + REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), + $ ALF( NALMAX ), AS( NMAX*NMAX ), BET( NBEMAX ), + $ G( NMAX ), X( NMAX ), XS( NMAX*INCMAX ), + $ XX( NMAX*INCMAX ), Y( NMAX ), + $ YS( NMAX*INCMAX ), YT( NMAX ), + $ YY( NMAX*INCMAX ), Z( 2*NMAX ) + INTEGER IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX ) + LOGICAL LTEST( NSUBS ) + CHARACTER*12 SNAMES( NSUBS ) +* .. External Functions .. + REAL SDIFF + LOGICAL LSE + EXTERNAL SDIFF, LSE +* .. External Subroutines .. + EXTERNAL SCHK1, SCHK2, SCHK3, SCHK4, SCHK5, SCHK6, + $ CS2CHKE, SMVCH +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK + CHARACTER*12 SRNAMT +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK + COMMON /SRNAMC/SRNAMT +* .. Data statements .. + DATA SNAMES/'cblas_sgemv ', 'cblas_sgbmv ', + $ 'cblas_ssymv ','cblas_ssbmv ','cblas_sspmv ', + $ 'cblas_strmv ','cblas_stbmv ','cblas_stpmv ', + $ 'cblas_strsv ','cblas_stbsv ','cblas_stpsv ', + $ 'cblas_sger ','cblas_ssyr ','cblas_sspr ', + $ 'cblas_ssyr2 ','cblas_sspr2 '/ +* .. Executable Statements .. +* + NOUTC = NOUT +* +* Read name and unit number for snapshot output file and open file. +* + READ( NIN, FMT = * )SNAPS + READ( NIN, FMT = * )NTRA + TRACE = NTRA.GE.0 + IF( TRACE )THEN + OPEN( NTRA, FILE = SNAPS ) + END IF +* Read the flag that directs rewinding of the snapshot file. + READ( NIN, FMT = * )REWI + REWI = REWI.AND.TRACE +* Read the flag that directs stopping on any failure. + READ( NIN, FMT = * )SFATAL +* Read the flag that indicates whether error exits are to be tested. + READ( NIN, FMT = * )TSTERR +* Read the flag that indicates whether row-major data layout to be tested. + READ( NIN, FMT = * )LAYOUT +* Read the threshold value of the test ratio + READ( NIN, FMT = * )THRESH +* +* Read and check the parameter values for the tests. +* +* Values of N + READ( NIN, FMT = * )NIDIM + IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN + WRITE( NOUT, FMT = 9997 )'N', NIDMAX + GO TO 230 + END IF + READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) + DO 10 I = 1, NIDIM + IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN + WRITE( NOUT, FMT = 9996 )NMAX + GO TO 230 + END IF + 10 CONTINUE +* Values of K + READ( NIN, FMT = * )NKB + IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN + WRITE( NOUT, FMT = 9997 )'K', NKBMAX + GO TO 230 + END IF + READ( NIN, FMT = * )( KB( I ), I = 1, NKB ) + DO 20 I = 1, NKB + IF( KB( I ).LT.0 )THEN + WRITE( NOUT, FMT = 9995 ) + GO TO 230 + END IF + 20 CONTINUE +* Values of INCX and INCY + READ( NIN, FMT = * )NINC + IF( NINC.LT.1.OR.NINC.GT.NINMAX )THEN + WRITE( NOUT, FMT = 9997 )'INCX AND INCY', NINMAX + GO TO 230 + END IF + READ( NIN, FMT = * )( INC( I ), I = 1, NINC ) + DO 30 I = 1, NINC + IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN + WRITE( NOUT, FMT = 9994 )INCMAX + GO TO 230 + END IF + 30 CONTINUE +* Values of ALPHA + READ( NIN, FMT = * )NALF + IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN + WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX + GO TO 230 + END IF + READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) +* Values of BETA + READ( NIN, FMT = * )NBET + IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN + WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX + GO TO 230 + END IF + READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) +* +* Report values of parameters. +* + WRITE( NOUT, FMT = 9993 ) + WRITE( NOUT, FMT = 9992 )( IDIM( I ), I = 1, NIDIM ) + WRITE( NOUT, FMT = 9991 )( KB( I ), I = 1, NKB ) + WRITE( NOUT, FMT = 9990 )( INC( I ), I = 1, NINC ) + WRITE( NOUT, FMT = 9989 )( ALF( I ), I = 1, NALF ) + WRITE( NOUT, FMT = 9988 )( BET( I ), I = 1, NBET ) + IF( .NOT.TSTERR )THEN + WRITE( NOUT, FMT = * ) + WRITE( NOUT, FMT = 9980 ) + END IF + WRITE( NOUT, FMT = * ) + WRITE( NOUT, FMT = 9999 )THRESH + WRITE( NOUT, FMT = * ) + + RORDER = .FALSE. + CORDER = .FALSE. + IF (LAYOUT.EQ.2) THEN + RORDER = .TRUE. + CORDER = .TRUE. + WRITE( *, FMT = 10002 ) + ELSE IF (LAYOUT.EQ.1) THEN + RORDER = .TRUE. + WRITE( *, FMT = 10001 ) + ELSE IF (LAYOUT.EQ.0) THEN + CORDER = .TRUE. + WRITE( *, FMT = 10000 ) + END IF + WRITE( *, FMT = * ) +* +* Read names of subroutines and flags which indicate +* whether they are to be tested. +* + DO 40 I = 1, NSUBS + LTEST( I ) = .FALSE. + 40 CONTINUE + 50 READ( NIN, FMT = 9984, END = 80 )SNAMET, LTESTT + DO 60 I = 1, NSUBS + IF( SNAMET.EQ.SNAMES( I ) ) + $ GO TO 70 + 60 CONTINUE + WRITE( NOUT, FMT = 9986 )SNAMET + STOP + 70 LTEST( I ) = LTESTT + GO TO 50 +* + 80 CONTINUE + CLOSE ( NIN ) +* +* Compute EPS (the machine precision). +* + EPS = ONE + 90 CONTINUE + IF( SDIFF( ONE + EPS, ONE ).EQ.ZERO ) + $ GO TO 100 + EPS = HALF*EPS + GO TO 90 + 100 CONTINUE + EPS = EPS + EPS + WRITE( NOUT, FMT = 9998 )EPS +* +* Check the reliability of SMVCH using exact data. +* + N = MIN( 32, NMAX ) + DO 120 J = 1, N + DO 110 I = 1, N + A( I, J ) = MAX( I - J + 1, 0 ) + 110 CONTINUE + X( J ) = J + Y( J ) = ZERO + 120 CONTINUE + DO 130 J = 1, N + YY( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 + 130 CONTINUE +* YY holds the exact result. On exit from SMVCH YT holds +* the result computed by SMVCH. + TRANS = 'N' + CALL SMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G, + $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) + SAME = LSE( YY, YT, N ) + IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN + WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR + STOP + END IF + TRANS = 'T' + CALL SMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G, + $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) + SAME = LSE( YY, YT, N ) + IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN + WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR + STOP + END IF +* +* Test each subroutine in turn. +* + DO 210 ISNUM = 1, NSUBS + WRITE( NOUT, FMT = * ) + IF( .NOT.LTEST( ISNUM ) )THEN +* Subprogram is not to be tested. + WRITE( NOUT, FMT = 9983 )SNAMES( ISNUM ) + ELSE + SRNAMT = SNAMES( ISNUM ) +* Test error exits. + IF( TSTERR )THEN + CALL CS2CHKE( SNAMES( ISNUM ) ) + WRITE( NOUT, FMT = * ) + END IF +* Test computations. + INFOT = 0 + OK = .TRUE. + FATAL = .FALSE. + GO TO ( 140, 140, 150, 150, 150, 160, 160, + $ 160, 160, 160, 160, 170, 180, 180, + $ 190, 190 )ISNUM +* Test SGEMV, 01, and SGBMV, 02. + 140 IF (CORDER) THEN + CALL SCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, + $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, + $ X, XX, XS, Y, YY, YS, YT, G, 0 ) + END IF + IF (RORDER) THEN + CALL SCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, + $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, + $ X, XX, XS, Y, YY, YS, YT, G, 1 ) + END IF + GO TO 200 +* Test SSYMV, 03, SSBMV, 04, and SSPMV, 05. + 150 IF (CORDER) THEN + CALL SCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, + $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, + $ X, XX, XS, Y, YY, YS, YT, G, 0 ) + END IF + IF (RORDER) THEN + CALL SCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, + $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, + $ X, XX, XS, Y, YY, YS, YT, G, 1 ) + END IF + GO TO 200 +* Test STRMV, 06, STBMV, 07, STPMV, 08, +* STRSV, 09, STBSV, 10, and STPSV, 11. + 160 IF (CORDER) THEN + CALL SCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z, + $ 0 ) + END IF + IF (RORDER) THEN + CALL SCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z, + $ 1 ) + END IF + GO TO 200 +* Test SGER, 12. + 170 IF (CORDER) THEN + CALL SCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, + $ YT, G, Z, 0 ) + END IF + IF (RORDER) THEN + CALL SCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, + $ YT, G, Z, 1 ) + END IF + GO TO 200 +* Test SSYR, 13, and SSPR, 14. + 180 IF (CORDER) THEN + CALL SCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, + $ YT, G, Z, 0 ) + END IF + IF (RORDER) THEN + CALL SCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, + $ YT, G, Z, 1 ) + END IF + GO TO 200 +* Test SSYR2, 15, and SSPR2, 16. + 190 IF (CORDER) THEN + CALL SCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, + $ YT, G, Z, 0 ) + END IF + IF (RORDER) THEN + CALL SCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, + $ YT, G, Z, 1 ) + END IF +* + 200 IF( FATAL.AND.SFATAL ) + $ GO TO 220 + END IF + 210 CONTINUE + WRITE( NOUT, FMT = 9982 ) + GO TO 240 +* + 220 CONTINUE + WRITE( NOUT, FMT = 9981 ) + GO TO 240 +* + 230 CONTINUE + WRITE( NOUT, FMT = 9987 ) +* + 240 CONTINUE + IF( TRACE ) + $ CLOSE ( NTRA ) + CLOSE ( NOUT ) + STOP +* +10002 FORMAT( ' COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED' ) +10001 FORMAT( ' ROW-MAJOR DATA LAYOUT IS TESTED' ) +10000 FORMAT( ' COLUMN-MAJOR DATA LAYOUT IS TESTED' ) + 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', + $ 'S THAN', F8.2 ) + 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 ) + 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', + $ 'THAN ', I2 ) + 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) + 9995 FORMAT( ' VALUE OF K IS LESS THAN 0' ) + 9994 FORMAT( ' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ', + $ I2 ) + 9993 FORMAT( ' TESTS OF THE REAL LEVEL 2 BLAS', //' THE F', + $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) + 9992 FORMAT( ' FOR N ', 9I6 ) + 9991 FORMAT( ' FOR K ', 7I6 ) + 9990 FORMAT( ' FOR INCX AND INCY ', 7I6 ) + 9989 FORMAT( ' FOR ALPHA ', 7F6.1 ) + 9988 FORMAT( ' FOR BETA ', 7F6.1 ) + 9987 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', + $ /' ******* TESTS ABANDONED *******' ) + 9986 FORMAT( ' SUBPROGRAM NAME ',A12, ' NOT RECOGNIZED', /' ******* T', + $ 'ESTS ABANDONED *******' ) + 9985 FORMAT( ' ERROR IN SMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', + $ 'ATED WRONGLY.', /' SMVCH WAS CALLED WITH TRANS = ', A1, + $ ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', / + $ ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.' + $ , /' ******* TESTS ABANDONED *******' ) + 9984 FORMAT(A12, L2 ) + 9983 FORMAT( 1X,A12, ' WAS NOT TESTED' ) + 9982 FORMAT( /' END OF TESTS' ) + 9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) + 9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) +* +* End of SBLAT2. +* + END + SUBROUTINE SCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, + $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, + $ XS, Y, YY, YS, YT, G, IORDER ) +* +* Tests SGEMV and SGBMV. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + REAL ZERO, HALF + PARAMETER ( ZERO = 0.0, HALF = 0.5 ) +* .. Scalar Arguments .. + REAL EPS, THRESH + INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, + $ NOUT, NTRA, IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ), + $ X( NMAX ), XS( NMAX*INCMAX ), + $ XX( NMAX*INCMAX ), Y( NMAX ), + $ YS( NMAX*INCMAX ), YT( NMAX ), + $ YY( NMAX*INCMAX ) + INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) +* .. Local Scalars .. + REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL + INTEGER I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY, + $ INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA, + $ LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK, + $ NL, NS + LOGICAL BANDED, FULL, NULL, RESET, SAME, TRAN + CHARACTER*1 TRANS, TRANSS + CHARACTER*14 CTRANS + CHARACTER*3 ICH +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LSE, LSERES + EXTERNAL LSE, LSERES +* .. External Subroutines .. + EXTERNAL CSGBMV, CSGEMV, SMAKE, SMVCH +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICH/'NTC'/ +* .. Executable Statements .. + FULL = SNAME( 9: 9 ).EQ.'e' + BANDED = SNAME( 9: 9 ).EQ.'b' +* Define the number of arguments. + IF( FULL )THEN + NARGS = 11 + ELSE IF( BANDED )THEN + NARGS = 13 + END IF +* + NC = 0 + RESET = .TRUE. + ERRMAX = ZERO +* + DO 120 IN = 1, NIDIM + N = IDIM( IN ) + ND = N/2 + 1 +* + DO 110 IM = 1, 2 + IF( IM.EQ.1 ) + $ M = MAX( N - ND, 0 ) + IF( IM.EQ.2 ) + $ M = MIN( N + ND, NMAX ) +* + IF( BANDED )THEN + NK = NKB + ELSE + NK = 1 + END IF + DO 100 IKU = 1, NK + IF( BANDED )THEN + KU = KB( IKU ) + KL = MAX( KU - 1, 0 ) + ELSE + KU = N - 1 + KL = M - 1 + END IF +* Set LDA to 1 more than minimum value if room. + IF( BANDED )THEN + LDA = KL + KU + 1 + ELSE + LDA = M + END IF + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 100 + LAA = LDA*N + NULL = N.LE.0.OR.M.LE.0 +* +* Generate the matrix A. +* + TRANSL = ZERO + CALL SMAKE( SNAME( 8: 9 ), ' ', ' ', M, N, A, NMAX, AA, + $ LDA, KL, KU, RESET, TRANSL ) +* + DO 90 IC = 1, 3 + TRANS = ICH( IC: IC ) + IF (TRANS.EQ.'N')THEN + CTRANS = ' CblasNoTrans' + ELSE IF (TRANS.EQ.'T')THEN + CTRANS = ' CblasTrans' + ELSE + CTRANS = 'CblasConjTrans' + END IF + TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' +* + IF( TRAN )THEN + ML = N + NL = M + ELSE + ML = M + NL = N + END IF +* + DO 80 IX = 1, NINC + INCX = INC( IX ) + LX = ABS( INCX )*NL +* +* Generate the vector X. +* + TRANSL = HALF + CALL SMAKE( 'ge', ' ', ' ', 1, NL, X, 1, XX, + $ ABS( INCX ), 0, NL - 1, RESET, TRANSL ) + IF( NL.GT.1 )THEN + X( NL/2 ) = ZERO + XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO + END IF +* + DO 70 IY = 1, NINC + INCY = INC( IY ) + LY = ABS( INCY )*ML +* + DO 60 IA = 1, NALF + ALPHA = ALF( IA ) +* + DO 50 IB = 1, NBET + BETA = BET( IB ) +* +* Generate the vector Y. +* + TRANSL = ZERO + CALL SMAKE( 'ge', ' ', ' ', 1, ML, Y, 1, + $ YY, ABS( INCY ), 0, ML - 1, + $ RESET, TRANSL ) +* + NC = NC + 1 +* +* Save every datum before calling the +* subroutine. +* + TRANSS = TRANS + MS = M + NS = N + KLS = KL + KUS = KU + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LX + XS( I ) = XX( I ) + 20 CONTINUE + INCXS = INCX + BLS = BETA + DO 30 I = 1, LY + YS( I ) = YY( I ) + 30 CONTINUE + INCYS = INCY +* +* Call the subroutine. +* + IF( FULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9994 )NC, SNAME, + $ CTRANS, M, N, ALPHA, LDA, INCX, + $ BETA, INCY + IF( REWI ) + $ REWIND NTRA + CALL CSGEMV( IORDER, TRANS, M, N, + $ ALPHA, AA, LDA, XX, INCX, + $ BETA, YY, INCY ) + ELSE IF( BANDED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9995 )NC, SNAME, + $ CTRANS, M, N, KL, KU, ALPHA, LDA, + $ INCX, BETA, INCY + IF( REWI ) + $ REWIND NTRA + CALL CSGBMV( IORDER, TRANS, M, N, KL, + $ KU, ALPHA, AA, LDA, XX, + $ INCX, BETA, YY, INCY ) + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9993 ) + FATAL = .TRUE. + GO TO 130 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = TRANS.EQ.TRANSS + ISAME( 2 ) = MS.EQ.M + ISAME( 3 ) = NS.EQ.N + IF( FULL )THEN + ISAME( 4 ) = ALS.EQ.ALPHA + ISAME( 5 ) = LSE( AS, AA, LAA ) + ISAME( 6 ) = LDAS.EQ.LDA + ISAME( 7 ) = LSE( XS, XX, LX ) + ISAME( 8 ) = INCXS.EQ.INCX + ISAME( 9 ) = BLS.EQ.BETA + IF( NULL )THEN + ISAME( 10 ) = LSE( YS, YY, LY ) + ELSE + ISAME( 10 ) = LSERES( 'ge', ' ', 1, + $ ML, YS, YY, + $ ABS( INCY ) ) + END IF + ISAME( 11 ) = INCYS.EQ.INCY + ELSE IF( BANDED )THEN + ISAME( 4 ) = KLS.EQ.KL + ISAME( 5 ) = KUS.EQ.KU + ISAME( 6 ) = ALS.EQ.ALPHA + ISAME( 7 ) = LSE( AS, AA, LAA ) + ISAME( 8 ) = LDAS.EQ.LDA + ISAME( 9 ) = LSE( XS, XX, LX ) + ISAME( 10 ) = INCXS.EQ.INCX + ISAME( 11 ) = BLS.EQ.BETA + IF( NULL )THEN + ISAME( 12 ) = LSE( YS, YY, LY ) + ELSE + ISAME( 12 ) = LSERES( 'ge', ' ', 1, + $ ML, YS, YY, + $ ABS( INCY ) ) + END IF + ISAME( 13 ) = INCYS.EQ.INCY + END IF +* +* If data was incorrectly changed, report +* and return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 130 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result. +* + CALL SMVCH( TRANS, M, N, ALPHA, A, + $ NMAX, X, INCX, BETA, Y, + $ INCY, YT, G, YY, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and +* return. + IF( FATAL ) + $ GO TO 130 + ELSE +* Avoid repeating tests with M.le.0 or +* N.le.0. + GO TO 110 + END IF +* + 50 CONTINUE +* + 60 CONTINUE +* + 70 CONTINUE +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* + 110 CONTINUE +* + 120 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 140 +* + 130 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + IF( FULL )THEN + WRITE( NOUT, FMT = 9994 )NC, SNAME, CTRANS, M, N, ALPHA, LDA, + $ INCX, BETA, INCY + ELSE IF( BANDED )THEN + WRITE( NOUT, FMT = 9995 )NC, SNAME, CTRANS, M, N, KL, KU, + $ ALPHA, LDA, INCX, BETA, INCY + END IF +* + 140 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, + $ ' - SUSPECT *******' ) + 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', 4( I3, ',' ), F4.1, + $ ', A,', I3, ',',/ 10x, 'X,', I2, ',', F4.1, ', Y,', + $ I2, ') .' ) + 9994 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', 2( I3, ',' ), F4.1, + $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, + $ ') .' ) + 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of SCHK1. +* + END + SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, + $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, + $ XS, Y, YY, YS, YT, G, IORDER ) +* +* Tests SSYMV, SSBMV and SSPMV. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + REAL ZERO, HALF + PARAMETER ( ZERO = 0.0, HALF = 0.5 ) +* .. Scalar Arguments .. + REAL EPS, THRESH + INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, + $ NOUT, NTRA, IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ), + $ X( NMAX ), XS( NMAX*INCMAX ), + $ XX( NMAX*INCMAX ), Y( NMAX ), + $ YS( NMAX*INCMAX ), YT( NMAX ), + $ YY( NMAX*INCMAX ) + INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) +* .. Local Scalars .. + REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL + INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY, + $ INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY, + $ N, NARGS, NC, NK, NS + LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME + CHARACTER*1 UPLO, UPLOS + CHARACTER*14 CUPLO + CHARACTER*2 ICH +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LSE, LSERES + EXTERNAL LSE, LSERES +* .. External Subroutines .. + EXTERNAL SMAKE, SMVCH, CSSBMV, CSSPMV, CSSYMV +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICH/'UL'/ +* .. Executable Statements .. + FULL = SNAME( 9: 9 ).EQ.'y' + BANDED = SNAME( 9: 9 ).EQ.'b' + PACKED = SNAME( 9: 9 ).EQ.'p' +* Define the number of arguments. + IF( FULL )THEN + NARGS = 10 + ELSE IF( BANDED )THEN + NARGS = 11 + ELSE IF( PACKED )THEN + NARGS = 9 + END IF +* + NC = 0 + RESET = .TRUE. + ERRMAX = ZERO +* + DO 110 IN = 1, NIDIM + N = IDIM( IN ) +* + IF( BANDED )THEN + NK = NKB + ELSE + NK = 1 + END IF + DO 100 IK = 1, NK + IF( BANDED )THEN + K = KB( IK ) + ELSE + K = N - 1 + END IF +* Set LDA to 1 more than minimum value if room. + IF( BANDED )THEN + LDA = K + 1 + ELSE + LDA = N + END IF + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 100 + IF( PACKED )THEN + LAA = ( N*( N + 1 ) )/2 + ELSE + LAA = LDA*N + END IF + NULL = N.LE.0 +* + DO 90 IC = 1, 2 + UPLO = ICH( IC: IC ) + IF (UPLO.EQ.'U')THEN + CUPLO = ' CblasUpper' + ELSE + CUPLO = ' CblasLower' + END IF +* +* Generate the matrix A. +* + TRANSL = ZERO + CALL SMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, A, NMAX, AA, + $ LDA, K, K, RESET, TRANSL ) +* + DO 80 IX = 1, NINC + INCX = INC( IX ) + LX = ABS( INCX )*N +* +* Generate the vector X. +* + TRANSL = HALF + CALL SMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX, + $ ABS( INCX ), 0, N - 1, RESET, TRANSL ) + IF( N.GT.1 )THEN + X( N/2 ) = ZERO + XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO + END IF +* + DO 70 IY = 1, NINC + INCY = INC( IY ) + LY = ABS( INCY )*N +* + DO 60 IA = 1, NALF + ALPHA = ALF( IA ) +* + DO 50 IB = 1, NBET + BETA = BET( IB ) +* +* Generate the vector Y. +* + TRANSL = ZERO + CALL SMAKE( 'ge', ' ', ' ', 1, N, Y, 1, YY, + $ ABS( INCY ), 0, N - 1, RESET, + $ TRANSL ) +* + NC = NC + 1 +* +* Save every datum before calling the +* subroutine. +* + UPLOS = UPLO + NS = N + KS = K + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LX + XS( I ) = XX( I ) + 20 CONTINUE + INCXS = INCX + BLS = BETA + DO 30 I = 1, LY + YS( I ) = YY( I ) + 30 CONTINUE + INCYS = INCY +* +* Call the subroutine. +* + IF( FULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, + $ CUPLO, N, ALPHA, LDA, INCX, BETA, INCY + IF( REWI ) + $ REWIND NTRA + CALL CSSYMV( IORDER, UPLO, N, ALPHA, AA, + $ LDA, XX, INCX, BETA, YY, INCY ) + ELSE IF( BANDED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9994 )NC, SNAME, + $ CUPLO, N, K, ALPHA, LDA, INCX, BETA, + $ INCY + IF( REWI ) + $ REWIND NTRA + CALL CSSBMV( IORDER, UPLO, N, K, ALPHA, + $ AA, LDA, XX, INCX, BETA, YY, + $ INCY ) + ELSE IF( PACKED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9995 )NC, SNAME, + $ CUPLO, N, ALPHA, INCX, BETA, INCY + IF( REWI ) + $ REWIND NTRA + CALL CSSPMV( IORDER, UPLO, N, ALPHA, AA, + $ XX, INCX, BETA, YY, INCY ) + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9992 ) + FATAL = .TRUE. + GO TO 120 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = UPLO.EQ.UPLOS + ISAME( 2 ) = NS.EQ.N + IF( FULL )THEN + ISAME( 3 ) = ALS.EQ.ALPHA + ISAME( 4 ) = LSE( AS, AA, LAA ) + ISAME( 5 ) = LDAS.EQ.LDA + ISAME( 6 ) = LSE( XS, XX, LX ) + ISAME( 7 ) = INCXS.EQ.INCX + ISAME( 8 ) = BLS.EQ.BETA + IF( NULL )THEN + ISAME( 9 ) = LSE( YS, YY, LY ) + ELSE + ISAME( 9 ) = LSERES( 'ge', ' ', 1, N, + $ YS, YY, ABS( INCY ) ) + END IF + ISAME( 10 ) = INCYS.EQ.INCY + ELSE IF( BANDED )THEN + ISAME( 3 ) = KS.EQ.K + ISAME( 4 ) = ALS.EQ.ALPHA + ISAME( 5 ) = LSE( AS, AA, LAA ) + ISAME( 6 ) = LDAS.EQ.LDA + ISAME( 7 ) = LSE( XS, XX, LX ) + ISAME( 8 ) = INCXS.EQ.INCX + ISAME( 9 ) = BLS.EQ.BETA + IF( NULL )THEN + ISAME( 10 ) = LSE( YS, YY, LY ) + ELSE + ISAME( 10 ) = LSERES( 'ge', ' ', 1, N, + $ YS, YY, ABS( INCY ) ) + END IF + ISAME( 11 ) = INCYS.EQ.INCY + ELSE IF( PACKED )THEN + ISAME( 3 ) = ALS.EQ.ALPHA + ISAME( 4 ) = LSE( AS, AA, LAA ) + ISAME( 5 ) = LSE( XS, XX, LX ) + ISAME( 6 ) = INCXS.EQ.INCX + ISAME( 7 ) = BLS.EQ.BETA + IF( NULL )THEN + ISAME( 8 ) = LSE( YS, YY, LY ) + ELSE + ISAME( 8 ) = LSERES( 'ge', ' ', 1, N, + $ YS, YY, ABS( INCY ) ) + END IF + ISAME( 9 ) = INCYS.EQ.INCY + END IF +* +* If data was incorrectly changed, report and +* return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 120 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result. +* + CALL SMVCH( 'N', N, N, ALPHA, A, NMAX, X, + $ INCX, BETA, Y, INCY, YT, G, + $ YY, EPS, ERR, FATAL, NOUT, + $ .TRUE. ) + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and +* return. + IF( FATAL ) + $ GO TO 120 + ELSE +* Avoid repeating tests with N.le.0 + GO TO 110 + END IF +* + 50 CONTINUE +* + 60 CONTINUE +* + 70 CONTINUE +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* + 110 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 130 +* + 120 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + IF( FULL )THEN + WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, N, ALPHA, LDA, + $ INCX, BETA, INCY + ELSE IF( BANDED )THEN + WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, N, K, ALPHA, LDA, + $ INCX, BETA, INCY + ELSE IF( PACKED )THEN + WRITE( NOUT, FMT = 9995 )NC, SNAME, CUPLO, N, ALPHA, INCX, + $ BETA, INCY + END IF +* + 130 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, + $ ' - SUSPECT *******' ) + 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', AP', + $ ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) + 9994 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', 2( I3, ',' ), F4.1, + $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, + $ ') .' ) + 9993 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', A,', + $ I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) + 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of SCHK2. +* + END + SUBROUTINE SCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX, + $ INCMAX, A, AA, AS, X, XX, XS, XT, G, Z, IORDER ) +* +* Tests STRMV, STBMV, STPMV, STRSV, STBSV and STPSV. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + REAL ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 ) +* .. Scalar Arguments .. + REAL EPS, THRESH + INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA, + $ IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), + $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), + $ XS( NMAX*INCMAX ), XT( NMAX ), + $ XX( NMAX*INCMAX ), Z( NMAX ) + INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) +* .. Local Scalars .. + REAL ERR, ERRMAX, TRANSL + INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K, + $ KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS + LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME + CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS + CHARACTER*14 CUPLO,CTRANS,CDIAG + CHARACTER*2 ICHD, ICHU + CHARACTER*3 ICHT +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LSE, LSERES + EXTERNAL LSE, LSERES +* .. External Subroutines .. + EXTERNAL SMAKE, SMVCH, CSTBMV, CSTBSV, CSTPMV, + $ CSTPSV, CSTRMV, CSTRSV +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/ +* .. Executable Statements .. + FULL = SNAME( 9: 9 ).EQ.'r' + BANDED = SNAME( 9: 9 ).EQ.'b' + PACKED = SNAME( 9: 9 ).EQ.'p' +* Define the number of arguments. + IF( FULL )THEN + NARGS = 8 + ELSE IF( BANDED )THEN + NARGS = 9 + ELSE IF( PACKED )THEN + NARGS = 7 + END IF +* + NC = 0 + RESET = .TRUE. + ERRMAX = ZERO +* Set up zero vector for SMVCH. + DO 10 I = 1, NMAX + Z( I ) = ZERO + 10 CONTINUE +* + DO 110 IN = 1, NIDIM + N = IDIM( IN ) +* + IF( BANDED )THEN + NK = NKB + ELSE + NK = 1 + END IF + DO 100 IK = 1, NK + IF( BANDED )THEN + K = KB( IK ) + ELSE + K = N - 1 + END IF +* Set LDA to 1 more than minimum value if room. + IF( BANDED )THEN + LDA = K + 1 + ELSE + LDA = N + END IF + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 100 + IF( PACKED )THEN + LAA = ( N*( N + 1 ) )/2 + ELSE + LAA = LDA*N + END IF + NULL = N.LE.0 +* + DO 90 ICU = 1, 2 + UPLO = ICHU( ICU: ICU ) + IF (UPLO.EQ.'U')THEN + CUPLO = ' CblasUpper' + ELSE + CUPLO = ' CblasLower' + END IF +* + DO 80 ICT = 1, 3 + TRANS = ICHT( ICT: ICT ) + IF (TRANS.EQ.'N')THEN + CTRANS = ' CblasNoTrans' + ELSE IF (TRANS.EQ.'T')THEN + CTRANS = ' CblasTrans' + ELSE + CTRANS = 'CblasConjTrans' + END IF +* + DO 70 ICD = 1, 2 + DIAG = ICHD( ICD: ICD ) + IF (DIAG.EQ.'N')THEN + CDIAG = ' CblasNonUnit' + ELSE + CDIAG = ' CblasUnit' + END IF +* +* Generate the matrix A. +* + TRANSL = ZERO + CALL SMAKE( SNAME( 8: 9 ), UPLO, DIAG, N, N, A, + $ NMAX, AA, LDA, K, K, RESET, TRANSL ) +* + DO 60 IX = 1, NINC + INCX = INC( IX ) + LX = ABS( INCX )*N +* +* Generate the vector X. +* + TRANSL = HALF + CALL SMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX, + $ ABS( INCX ), 0, N - 1, RESET, + $ TRANSL ) + IF( N.GT.1 )THEN + X( N/2 ) = ZERO + XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO + END IF +* + NC = NC + 1 +* +* Save every datum before calling the subroutine. +* + UPLOS = UPLO + TRANSS = TRANS + DIAGS = DIAG + NS = N + KS = K + DO 20 I = 1, LAA + AS( I ) = AA( I ) + 20 CONTINUE + LDAS = LDA + DO 30 I = 1, LX + XS( I ) = XX( I ) + 30 CONTINUE + INCXS = INCX +* +* Call the subroutine. +* + IF( SNAME( 10: 11 ).EQ.'mv' )THEN + IF( FULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, + $ CUPLO, CTRANS, CDIAG, N, LDA, INCX + IF( REWI ) + $ REWIND NTRA + CALL CSTRMV( IORDER, UPLO, TRANS, DIAG, + $ N, AA, LDA, XX, INCX ) + ELSE IF( BANDED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9994 )NC, SNAME, + $ CUPLO, CTRANS, CDIAG, N, K, LDA, INCX + IF( REWI ) + $ REWIND NTRA + CALL CSTBMV( IORDER, UPLO, TRANS, DIAG, + $ N, K, AA, LDA, XX, INCX ) + ELSE IF( PACKED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9995 )NC, SNAME, + $ CUPLO, CTRANS, CDIAG, N, INCX + IF( REWI ) + $ REWIND NTRA + CALL CSTPMV( IORDER, UPLO, TRANS, DIAG, + $ N, AA, XX, INCX ) + END IF + ELSE IF( SNAME( 10: 11 ).EQ.'sv' )THEN + IF( FULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, + $ CUPLO, CTRANS, CDIAG, N, LDA, INCX + IF( REWI ) + $ REWIND NTRA + CALL CSTRSV( IORDER, UPLO, TRANS, DIAG, + $ N, AA, LDA, XX, INCX ) + ELSE IF( BANDED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9994 )NC, SNAME, + $ CUPLO, CTRANS, CDIAG, N, K, LDA, INCX + IF( REWI ) + $ REWIND NTRA + CALL CSTBSV( IORDER, UPLO, TRANS, DIAG, + $ N, K, AA, LDA, XX, INCX ) + ELSE IF( PACKED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9995 )NC, SNAME, + $ CUPLO, CTRANS, CDIAG, N, INCX + IF( REWI ) + $ REWIND NTRA + CALL CSTPSV( IORDER, UPLO, TRANS, DIAG, + $ N, AA, XX, INCX ) + END IF + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9992 ) + FATAL = .TRUE. + GO TO 120 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = UPLO.EQ.UPLOS + ISAME( 2 ) = TRANS.EQ.TRANSS + ISAME( 3 ) = DIAG.EQ.DIAGS + ISAME( 4 ) = NS.EQ.N + IF( FULL )THEN + ISAME( 5 ) = LSE( AS, AA, LAA ) + ISAME( 6 ) = LDAS.EQ.LDA + IF( NULL )THEN + ISAME( 7 ) = LSE( XS, XX, LX ) + ELSE + ISAME( 7 ) = LSERES( 'ge', ' ', 1, N, XS, + $ XX, ABS( INCX ) ) + END IF + ISAME( 8 ) = INCXS.EQ.INCX + ELSE IF( BANDED )THEN + ISAME( 5 ) = KS.EQ.K + ISAME( 6 ) = LSE( AS, AA, LAA ) + ISAME( 7 ) = LDAS.EQ.LDA + IF( NULL )THEN + ISAME( 8 ) = LSE( XS, XX, LX ) + ELSE + ISAME( 8 ) = LSERES( 'ge', ' ', 1, N, XS, + $ XX, ABS( INCX ) ) + END IF + ISAME( 9 ) = INCXS.EQ.INCX + ELSE IF( PACKED )THEN + ISAME( 5 ) = LSE( AS, AA, LAA ) + IF( NULL )THEN + ISAME( 6 ) = LSE( XS, XX, LX ) + ELSE + ISAME( 6 ) = LSERES( 'ge', ' ', 1, N, XS, + $ XX, ABS( INCX ) ) + END IF + ISAME( 7 ) = INCXS.EQ.INCX + END IF +* +* If data was incorrectly changed, report and +* return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 120 + END IF +* + IF( .NOT.NULL )THEN + IF( SNAME( 10: 11 ).EQ.'mv' )THEN +* +* Check the result. +* + CALL SMVCH( TRANS, N, N, ONE, A, NMAX, X, + $ INCX, ZERO, Z, INCX, XT, G, + $ XX, EPS, ERR, FATAL, NOUT, + $ .TRUE. ) + ELSE IF( SNAME( 10: 11 ).EQ.'sv' )THEN +* +* Compute approximation to original vector. +* + DO 50 I = 1, N + Z( I ) = XX( 1 + ( I - 1 )* + $ ABS( INCX ) ) + XX( 1 + ( I - 1 )*ABS( INCX ) ) + $ = X( I ) + 50 CONTINUE + CALL SMVCH( TRANS, N, N, ONE, A, NMAX, Z, + $ INCX, ZERO, X, INCX, XT, G, + $ XX, EPS, ERR, FATAL, NOUT, + $ .FALSE. ) + END IF + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and return. + IF( FATAL ) + $ GO TO 120 + ELSE +* Avoid repeating tests with N.le.0. + GO TO 110 + END IF +* + 60 CONTINUE +* + 70 CONTINUE +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* + 110 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 130 +* + 120 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + IF( FULL )THEN + WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, CTRANS, CDIAG, N, + $ LDA, INCX + ELSE IF( BANDED )THEN + WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, CTRANS, CDIAG, N, + $ K, LDA, INCX + ELSE IF( PACKED )THEN + WRITE( NOUT, FMT = 9995 )NC, SNAME, CUPLO, CTRANS, CDIAG, N, + $ INCX + END IF +* + 130 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, + $ ' - SUSPECT *******' ) + 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ',A12, '(', 3( A14,',' ),/ 10x, I3, ', AP, ', + $ 'X,', I2, ') .' ) + 9994 FORMAT( 1X, I6, ': ',A12, '(', 3( A14,',' ),/ 10x, 2( I3, ',' ), + $ ' A,', I3, ', X,', I2, ') .' ) + 9993 FORMAT( 1X, I6, ': ',A12, '(', 3( A14,',' ),/ 10x, I3, ', A,', + $ I3, ', X,', I2, ') .' ) + 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of SCHK3. +* + END + SUBROUTINE SCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, + $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, + $ Z, IORDER ) +* +* Tests SGER. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + REAL ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 ) +* .. Scalar Arguments .. + REAL EPS, THRESH + INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA, + $ IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), + $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), + $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), + $ YY( NMAX*INCMAX ), Z( NMAX ) + INTEGER IDIM( NIDIM ), INC( NINC ) +* .. Local Scalars .. + REAL ALPHA, ALS, ERR, ERRMAX, TRANSL + INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX, + $ IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS, + $ NC, ND, NS + LOGICAL NULL, RESET, SAME +* .. Local Arrays .. + REAL W( 1 ) + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LSE, LSERES + EXTERNAL LSE, LSERES +* .. External Subroutines .. + EXTERNAL CSGER, SMAKE, SMVCH +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Executable Statements .. +* Define the number of arguments. + NARGS = 9 +* + NC = 0 + RESET = .TRUE. + ERRMAX = ZERO +* + DO 120 IN = 1, NIDIM + N = IDIM( IN ) + ND = N/2 + 1 +* + DO 110 IM = 1, 2 + IF( IM.EQ.1 ) + $ M = MAX( N - ND, 0 ) + IF( IM.EQ.2 ) + $ M = MIN( N + ND, NMAX ) +* +* Set LDA to 1 more than minimum value if room. + LDA = M + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 110 + LAA = LDA*N + NULL = N.LE.0.OR.M.LE.0 +* + DO 100 IX = 1, NINC + INCX = INC( IX ) + LX = ABS( INCX )*M +* +* Generate the vector X. +* + TRANSL = HALF + CALL SMAKE( 'ge', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ), + $ 0, M - 1, RESET, TRANSL ) + IF( M.GT.1 )THEN + X( M/2 ) = ZERO + XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO + END IF +* + DO 90 IY = 1, NINC + INCY = INC( IY ) + LY = ABS( INCY )*N +* +* Generate the vector Y. +* + TRANSL = ZERO + CALL SMAKE( 'ge', ' ', ' ', 1, N, Y, 1, YY, + $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) + IF( N.GT.1 )THEN + Y( N/2 ) = ZERO + YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO + END IF +* + DO 80 IA = 1, NALF + ALPHA = ALF( IA ) +* +* Generate the matrix A. +* + TRANSL = ZERO + CALL SMAKE( SNAME( 8: 9 ), ' ', ' ', M, N, A, NMAX, + $ AA, LDA, M - 1, N - 1, RESET, TRANSL ) +* + NC = NC + 1 +* +* Save every datum before calling the subroutine. +* + MS = M + NS = N + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LX + XS( I ) = XX( I ) + 20 CONTINUE + INCXS = INCX + DO 30 I = 1, LY + YS( I ) = YY( I ) + 30 CONTINUE + INCYS = INCY +* +* Call the subroutine. +* + IF( TRACE ) + $ WRITE( NTRA, FMT = 9994 )NC, SNAME, M, N, + $ ALPHA, INCX, INCY, LDA + IF( REWI ) + $ REWIND NTRA + CALL CSGER( IORDER, M, N, ALPHA, XX, INCX, YY, + $ INCY, AA, LDA ) +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9993 ) + FATAL = .TRUE. + GO TO 140 + END IF +* +* See what data changed inside subroutine. +* + ISAME( 1 ) = MS.EQ.M + ISAME( 2 ) = NS.EQ.N + ISAME( 3 ) = ALS.EQ.ALPHA + ISAME( 4 ) = LSE( XS, XX, LX ) + ISAME( 5 ) = INCXS.EQ.INCX + ISAME( 6 ) = LSE( YS, YY, LY ) + ISAME( 7 ) = INCYS.EQ.INCY + IF( NULL )THEN + ISAME( 8 ) = LSE( AS, AA, LAA ) + ELSE + ISAME( 8 ) = LSERES( 'ge', ' ', M, N, AS, AA, + $ LDA ) + END IF + ISAME( 9 ) = LDAS.EQ.LDA +* +* If data was incorrectly changed, report and return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 140 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result column by column. +* + IF( INCX.GT.0 )THEN + DO 50 I = 1, M + Z( I ) = X( I ) + 50 CONTINUE + ELSE + DO 60 I = 1, M + Z( I ) = X( M - I + 1 ) + 60 CONTINUE + END IF + DO 70 J = 1, N + IF( INCY.GT.0 )THEN + W( 1 ) = Y( J ) + ELSE + W( 1 ) = Y( N - J + 1 ) + END IF + CALL SMVCH( 'N', M, 1, ALPHA, Z, NMAX, W, 1, + $ ONE, A( 1, J ), 1, YT, G, + $ AA( 1 + ( J - 1 )*LDA ), EPS, + $ ERR, FATAL, NOUT, .TRUE. ) + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and return. + IF( FATAL ) + $ GO TO 130 + 70 CONTINUE + ELSE +* Avoid repeating tests with M.le.0 or N.le.0. + GO TO 110 + END IF +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* + 110 CONTINUE +* + 120 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 150 +* + 130 CONTINUE + WRITE( NOUT, FMT = 9995 )J +* + 140 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + WRITE( NOUT, FMT = 9994 )NC, SNAME, M, N, ALPHA, INCX, INCY, LDA +* + 150 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, + $ ' - SUSPECT *******' ) + 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) + 9994 FORMAT( 1X, I6, ': ',A12, '(', 2( I3, ',' ), F4.1, ', X,', I2, + $ ', Y,', I2, ', A,', I3, ') .' ) + 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of SCHK4. +* + END + SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, + $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, + $ Z, IORDER ) +* +* Tests SSYR and SSPR. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + REAL ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 ) +* .. Scalar Arguments .. + REAL EPS, THRESH + INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA, + $ IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), + $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), + $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), + $ YY( NMAX*INCMAX ), Z( NMAX ) + INTEGER IDIM( NIDIM ), INC( NINC ) +* .. Local Scalars .. + REAL ALPHA, ALS, ERR, ERRMAX, TRANSL + INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA, + $ LDA, LDAS, LJ, LX, N, NARGS, NC, NS + LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER + CHARACTER*1 UPLO, UPLOS + CHARACTER*14 CUPLO + CHARACTER*2 ICH +* .. Local Arrays .. + REAL W( 1 ) + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LSE, LSERES + EXTERNAL LSE, LSERES +* .. External Subroutines .. + EXTERNAL SMAKE, SMVCH, CSSPR, CSSYR +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICH/'UL'/ +* .. Executable Statements .. + FULL = SNAME( 9: 9 ).EQ.'y' + PACKED = SNAME( 9: 9 ).EQ.'p' +* Define the number of arguments. + IF( FULL )THEN + NARGS = 7 + ELSE IF( PACKED )THEN + NARGS = 6 + END IF +* + NC = 0 + RESET = .TRUE. + ERRMAX = ZERO +* + DO 100 IN = 1, NIDIM + N = IDIM( IN ) +* Set LDA to 1 more than minimum value if room. + LDA = N + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 100 + IF( PACKED )THEN + LAA = ( N*( N + 1 ) )/2 + ELSE + LAA = LDA*N + END IF +* + DO 90 IC = 1, 2 + UPLO = ICH( IC: IC ) + IF (UPLO.EQ.'U')THEN + CUPLO = ' CblasUpper' + ELSE + CUPLO = ' CblasLower' + END IF + UPPER = UPLO.EQ.'U' +* + DO 80 IX = 1, NINC + INCX = INC( IX ) + LX = ABS( INCX )*N +* +* Generate the vector X. +* + TRANSL = HALF + CALL SMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), + $ 0, N - 1, RESET, TRANSL ) + IF( N.GT.1 )THEN + X( N/2 ) = ZERO + XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO + END IF +* + DO 70 IA = 1, NALF + ALPHA = ALF( IA ) + NULL = N.LE.0.OR.ALPHA.EQ.ZERO +* +* Generate the matrix A. +* + TRANSL = ZERO + CALL SMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, A, NMAX, + $ AA, LDA, N - 1, N - 1, RESET, TRANSL ) +* + NC = NC + 1 +* +* Save every datum before calling the subroutine. +* + UPLOS = UPLO + NS = N + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LX + XS( I ) = XX( I ) + 20 CONTINUE + INCXS = INCX +* +* Call the subroutine. +* + IF( FULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, CUPLO, N, + $ ALPHA, INCX, LDA + IF( REWI ) + $ REWIND NTRA + CALL CSSYR( IORDER, UPLO, N, ALPHA, XX, INCX, + $ AA, LDA ) + ELSE IF( PACKED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9994 )NC, SNAME, CUPLO, N, + $ ALPHA, INCX + IF( REWI ) + $ REWIND NTRA + CALL CSSPR( IORDER, UPLO, N, ALPHA, XX, INCX, AA ) + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9992 ) + FATAL = .TRUE. + GO TO 120 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = UPLO.EQ.UPLOS + ISAME( 2 ) = NS.EQ.N + ISAME( 3 ) = ALS.EQ.ALPHA + ISAME( 4 ) = LSE( XS, XX, LX ) + ISAME( 5 ) = INCXS.EQ.INCX + IF( NULL )THEN + ISAME( 6 ) = LSE( AS, AA, LAA ) + ELSE + ISAME( 6 ) = LSERES( SNAME( 8: 9 ), UPLO, N, N, AS, + $ AA, LDA ) + END IF + IF( .NOT.PACKED )THEN + ISAME( 7 ) = LDAS.EQ.LDA + END IF +* +* If data was incorrectly changed, report and return. +* + SAME = .TRUE. + DO 30 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 30 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 120 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result column by column. +* + IF( INCX.GT.0 )THEN + DO 40 I = 1, N + Z( I ) = X( I ) + 40 CONTINUE + ELSE + DO 50 I = 1, N + Z( I ) = X( N - I + 1 ) + 50 CONTINUE + END IF + JA = 1 + DO 60 J = 1, N + W( 1 ) = Z( J ) + IF( UPPER )THEN + JJ = 1 + LJ = J + ELSE + JJ = J + LJ = N - J + 1 + END IF + CALL SMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W, + $ 1, ONE, A( JJ, J ), 1, YT, G, + $ AA( JA ), EPS, ERR, FATAL, NOUT, + $ .TRUE. ) + IF( FULL )THEN + IF( UPPER )THEN + JA = JA + LDA + ELSE + JA = JA + LDA + 1 + END IF + ELSE + JA = JA + LJ + END IF + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and return. + IF( FATAL ) + $ GO TO 110 + 60 CONTINUE + ELSE +* Avoid repeating tests if N.le.0. + IF( N.LE.0 ) + $ GO TO 100 + END IF +* + 70 CONTINUE +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 130 +* + 110 CONTINUE + WRITE( NOUT, FMT = 9995 )J +* + 120 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + IF( FULL )THEN + WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, N, ALPHA, INCX, LDA + ELSE IF( PACKED )THEN + WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, N, ALPHA, INCX + END IF +* + 130 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, + $ ' - SUSPECT *******' ) + 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) + 9994 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', X,', + $ I2, ', AP) .' ) + 9993 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', X,', + $ I2, ', A,', I3, ') .' ) + 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of SCHK5. +* + END + SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, + $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, + $ Z, IORDER ) +* +* Tests SSYR2 and SSPR2. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + REAL ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 ) +* .. Scalar Arguments .. + REAL EPS, THRESH + INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA, + $ IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), + $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), + $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), + $ YY( NMAX*INCMAX ), Z( NMAX, 2 ) + INTEGER IDIM( NIDIM ), INC( NINC ) +* .. Local Scalars .. + REAL ALPHA, ALS, ERR, ERRMAX, TRANSL + INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX, + $ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N, + $ NARGS, NC, NS + LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER + CHARACTER*1 UPLO, UPLOS + CHARACTER*14 CUPLO + CHARACTER*2 ICH +* .. Local Arrays .. + REAL W( 2 ) + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LSE, LSERES + EXTERNAL LSE, LSERES +* .. External Subroutines .. + EXTERNAL SMAKE, SMVCH, CSSPR2, CSSYR2 +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICH/'UL'/ +* .. Executable Statements .. + FULL = SNAME( 9: 9 ).EQ.'y' + PACKED = SNAME( 9: 9 ).EQ.'p' +* Define the number of arguments. + IF( FULL )THEN + NARGS = 9 + ELSE IF( PACKED )THEN + NARGS = 8 + END IF +* + NC = 0 + RESET = .TRUE. + ERRMAX = ZERO +* + DO 140 IN = 1, NIDIM + N = IDIM( IN ) +* Set LDA to 1 more than minimum value if room. + LDA = N + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 140 + IF( PACKED )THEN + LAA = ( N*( N + 1 ) )/2 + ELSE + LAA = LDA*N + END IF +* + DO 130 IC = 1, 2 + UPLO = ICH( IC: IC ) + IF (UPLO.EQ.'U')THEN + CUPLO = ' CblasUpper' + ELSE + CUPLO = ' CblasLower' + END IF + UPPER = UPLO.EQ.'U' +* + DO 120 IX = 1, NINC + INCX = INC( IX ) + LX = ABS( INCX )*N +* +* Generate the vector X. +* + TRANSL = HALF + CALL SMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), + $ 0, N - 1, RESET, TRANSL ) + IF( N.GT.1 )THEN + X( N/2 ) = ZERO + XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO + END IF +* + DO 110 IY = 1, NINC + INCY = INC( IY ) + LY = ABS( INCY )*N +* +* Generate the vector Y. +* + TRANSL = ZERO + CALL SMAKE( 'ge', ' ', ' ', 1, N, Y, 1, YY, + $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) + IF( N.GT.1 )THEN + Y( N/2 ) = ZERO + YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO + END IF +* + DO 100 IA = 1, NALF + ALPHA = ALF( IA ) + NULL = N.LE.0.OR.ALPHA.EQ.ZERO +* +* Generate the matrix A. +* + TRANSL = ZERO + CALL SMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, A, + $ NMAX, AA, LDA, N - 1, N - 1, RESET, + $ TRANSL ) +* + NC = NC + 1 +* +* Save every datum before calling the subroutine. +* + UPLOS = UPLO + NS = N + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LX + XS( I ) = XX( I ) + 20 CONTINUE + INCXS = INCX + DO 30 I = 1, LY + YS( I ) = YY( I ) + 30 CONTINUE + INCYS = INCY +* +* Call the subroutine. +* + IF( FULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, CUPLO, N, + $ ALPHA, INCX, INCY, LDA + IF( REWI ) + $ REWIND NTRA + CALL CSSYR2( IORDER, UPLO, N, ALPHA, XX, INCX, + $ YY, INCY, AA, LDA ) + ELSE IF( PACKED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9994 )NC, SNAME, CUPLO, N, + $ ALPHA, INCX, INCY + IF( REWI ) + $ REWIND NTRA + CALL CSSPR2( IORDER, UPLO, N, ALPHA, XX, INCX, + $ YY, INCY, AA ) + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9992 ) + FATAL = .TRUE. + GO TO 160 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = UPLO.EQ.UPLOS + ISAME( 2 ) = NS.EQ.N + ISAME( 3 ) = ALS.EQ.ALPHA + ISAME( 4 ) = LSE( XS, XX, LX ) + ISAME( 5 ) = INCXS.EQ.INCX + ISAME( 6 ) = LSE( YS, YY, LY ) + ISAME( 7 ) = INCYS.EQ.INCY + IF( NULL )THEN + ISAME( 8 ) = LSE( AS, AA, LAA ) + ELSE + ISAME( 8 ) = LSERES( SNAME( 8: 9 ), UPLO, N, N, + $ AS, AA, LDA ) + END IF + IF( .NOT.PACKED )THEN + ISAME( 9 ) = LDAS.EQ.LDA + END IF +* +* If data was incorrectly changed, report and return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 160 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result column by column. +* + IF( INCX.GT.0 )THEN + DO 50 I = 1, N + Z( I, 1 ) = X( I ) + 50 CONTINUE + ELSE + DO 60 I = 1, N + Z( I, 1 ) = X( N - I + 1 ) + 60 CONTINUE + END IF + IF( INCY.GT.0 )THEN + DO 70 I = 1, N + Z( I, 2 ) = Y( I ) + 70 CONTINUE + ELSE + DO 80 I = 1, N + Z( I, 2 ) = Y( N - I + 1 ) + 80 CONTINUE + END IF + JA = 1 + DO 90 J = 1, N + W( 1 ) = Z( J, 2 ) + W( 2 ) = Z( J, 1 ) + IF( UPPER )THEN + JJ = 1 + LJ = J + ELSE + JJ = J + LJ = N - J + 1 + END IF + CALL SMVCH( 'N', LJ, 2, ALPHA, Z( JJ, 1 ), + $ NMAX, W, 1, ONE, A( JJ, J ), 1, + $ YT, G, AA( JA ), EPS, ERR, FATAL, + $ NOUT, .TRUE. ) + IF( FULL )THEN + IF( UPPER )THEN + JA = JA + LDA + ELSE + JA = JA + LDA + 1 + END IF + ELSE + JA = JA + LJ + END IF + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and return. + IF( FATAL ) + $ GO TO 150 + 90 CONTINUE + ELSE +* Avoid repeating tests with N.le.0. + IF( N.LE.0 ) + $ GO TO 140 + END IF +* + 100 CONTINUE +* + 110 CONTINUE +* + 120 CONTINUE +* + 130 CONTINUE +* + 140 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 170 +* + 150 CONTINUE + WRITE( NOUT, FMT = 9995 )J +* + 160 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + IF( FULL )THEN + WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, N, ALPHA, INCX, + $ INCY, LDA + ELSE IF( PACKED )THEN + WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, N, ALPHA, INCX, INCY + END IF +* + 170 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, + $ ' - SUSPECT *******' ) + 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) + 9994 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', X,', + $ I2, ', Y,', I2, ', AP) .' ) + 9993 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', X,', + $ I2, ', Y,', I2, ', A,', I3, ') .' ) + 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of SCHK6. +* + END + SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, + $ KU, RESET, TRANSL ) +* +* Generates values for an M by N matrix A within the bandwidth +* defined by KL and KU. +* Stores the values in the array AA in the data structure required +* by the routine, with unwanted elements set to rogue value. +* +* TYPE is 'ge', 'gb', 'sy', 'sb', 'sp', 'tr', 'tb' OR 'tp'. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0, ONE = 1.0 ) + REAL ROGUE + PARAMETER ( ROGUE = -1.0E10 ) +* .. Scalar Arguments .. + REAL TRANSL + INTEGER KL, KU, LDA, M, N, NMAX + LOGICAL RESET + CHARACTER*1 DIAG, UPLO + CHARACTER*2 TYPE +* .. Array Arguments .. + REAL A( NMAX, * ), AA( * ) +* .. Local Scalars .. + INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, KK + LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER +* .. External Functions .. + REAL SBEG + EXTERNAL SBEG +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. Executable Statements .. + GEN = TYPE( 1: 1 ).EQ.'g' + SYM = TYPE( 1: 1 ).EQ.'s' + TRI = TYPE( 1: 1 ).EQ.'t' + UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U' + LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L' + UNIT = TRI.AND.DIAG.EQ.'U' +* +* Generate data in array A. +* + DO 20 J = 1, N + DO 10 I = 1, M + IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) + $ THEN + IF( ( I.LE.J.AND.J - I.LE.KU ).OR. + $ ( I.GE.J.AND.I - J.LE.KL ) )THEN + A( I, J ) = SBEG( RESET ) + TRANSL + ELSE + A( I, J ) = ZERO + END IF + IF( I.NE.J )THEN + IF( SYM )THEN + A( J, I ) = A( I, J ) + ELSE IF( TRI )THEN + A( J, I ) = ZERO + END IF + END IF + END IF + 10 CONTINUE + IF( TRI ) + $ A( J, J ) = A( J, J ) + ONE + IF( UNIT ) + $ A( J, J ) = ONE + 20 CONTINUE +* +* Store elements in array AS in data structure required by routine. +* + IF( TYPE.EQ.'ge' )THEN + DO 50 J = 1, N + DO 30 I = 1, M + AA( I + ( J - 1 )*LDA ) = A( I, J ) + 30 CONTINUE + DO 40 I = M + 1, LDA + AA( I + ( J - 1 )*LDA ) = ROGUE + 40 CONTINUE + 50 CONTINUE + ELSE IF( TYPE.EQ.'gb' )THEN + DO 90 J = 1, N + DO 60 I1 = 1, KU + 1 - J + AA( I1 + ( J - 1 )*LDA ) = ROGUE + 60 CONTINUE + DO 70 I2 = I1, MIN( KL + KU + 1, KU + 1 + M - J ) + AA( I2 + ( J - 1 )*LDA ) = A( I2 + J - KU - 1, J ) + 70 CONTINUE + DO 80 I3 = I2, LDA + AA( I3 + ( J - 1 )*LDA ) = ROGUE + 80 CONTINUE + 90 CONTINUE + ELSE IF( TYPE.EQ.'sy'.OR.TYPE.EQ.'tr' )THEN + DO 130 J = 1, N + IF( UPPER )THEN + IBEG = 1 + IF( UNIT )THEN + IEND = J - 1 + ELSE + IEND = J + END IF + ELSE + IF( UNIT )THEN + IBEG = J + 1 + ELSE + IBEG = J + END IF + IEND = N + END IF + DO 100 I = 1, IBEG - 1 + AA( I + ( J - 1 )*LDA ) = ROGUE + 100 CONTINUE + DO 110 I = IBEG, IEND + AA( I + ( J - 1 )*LDA ) = A( I, J ) + 110 CONTINUE + DO 120 I = IEND + 1, LDA + AA( I + ( J - 1 )*LDA ) = ROGUE + 120 CONTINUE + 130 CONTINUE + ELSE IF( TYPE.EQ.'sb'.OR.TYPE.EQ.'tb' )THEN + DO 170 J = 1, N + IF( UPPER )THEN + KK = KL + 1 + IBEG = MAX( 1, KL + 2 - J ) + IF( UNIT )THEN + IEND = KL + ELSE + IEND = KL + 1 + END IF + ELSE + KK = 1 + IF( UNIT )THEN + IBEG = 2 + ELSE + IBEG = 1 + END IF + IEND = MIN( KL + 1, 1 + M - J ) + END IF + DO 140 I = 1, IBEG - 1 + AA( I + ( J - 1 )*LDA ) = ROGUE + 140 CONTINUE + DO 150 I = IBEG, IEND + AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J ) + 150 CONTINUE + DO 160 I = IEND + 1, LDA + AA( I + ( J - 1 )*LDA ) = ROGUE + 160 CONTINUE + 170 CONTINUE + ELSE IF( TYPE.EQ.'sp'.OR.TYPE.EQ.'tp' )THEN + IOFF = 0 + DO 190 J = 1, N + IF( UPPER )THEN + IBEG = 1 + IEND = J + ELSE + IBEG = J + IEND = N + END IF + DO 180 I = IBEG, IEND + IOFF = IOFF + 1 + AA( IOFF ) = A( I, J ) + IF( I.EQ.J )THEN + IF( UNIT ) + $ AA( IOFF ) = ROGUE + END IF + 180 CONTINUE + 190 CONTINUE + END IF + RETURN +* +* End of SMAKE. +* + END + SUBROUTINE SMVCH( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y, + $ INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV ) +* +* Checks the results of the computational tests. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0, ONE = 1.0 ) +* .. Scalar Arguments .. + REAL ALPHA, BETA, EPS, ERR + INTEGER INCX, INCY, M, N, NMAX, NOUT + LOGICAL FATAL, MV + CHARACTER*1 TRANS +* .. Array Arguments .. + REAL A( NMAX, * ), G( * ), X( * ), Y( * ), YT( * ), + $ YY( * ) +* .. Local Scalars .. + REAL ERRI + INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL + LOGICAL TRAN +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. Executable Statements .. + TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' + IF( TRAN )THEN + ML = N + NL = M + ELSE + ML = M + NL = N + END IF + IF( INCX.LT.0 )THEN + KX = NL + INCXL = -1 + ELSE + KX = 1 + INCXL = 1 + END IF + IF( INCY.LT.0 )THEN + KY = ML + INCYL = -1 + ELSE + KY = 1 + INCYL = 1 + END IF +* +* Compute expected result in YT using data in A, X and Y. +* Compute gauges in G. +* + IY = KY + DO 30 I = 1, ML + YT( IY ) = ZERO + G( IY ) = ZERO + JX = KX + IF( TRAN )THEN + DO 10 J = 1, NL + YT( IY ) = YT( IY ) + A( J, I )*X( JX ) + G( IY ) = G( IY ) + ABS( A( J, I )*X( JX ) ) + JX = JX + INCXL + 10 CONTINUE + ELSE + DO 20 J = 1, NL + YT( IY ) = YT( IY ) + A( I, J )*X( JX ) + G( IY ) = G( IY ) + ABS( A( I, J )*X( JX ) ) + JX = JX + INCXL + 20 CONTINUE + END IF + YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY ) + G( IY ) = ABS( ALPHA )*G( IY ) + ABS( BETA*Y( IY ) ) + IY = IY + INCYL + 30 CONTINUE +* +* Compute the error ratio for this result. +* + ERR = ZERO + DO 40 I = 1, ML + ERRI = ABS( YT( I ) - YY( 1 + ( I - 1 )*ABS( INCY ) ) )/EPS + IF( G( I ).NE.ZERO ) + $ ERRI = ERRI/G( I ) + ERR = MAX( ERR, ERRI ) + IF( ERR*SQRT( EPS ).GE.ONE ) + $ GO TO 50 + 40 CONTINUE +* If the loop completes, all results are at least half accurate. + GO TO 70 +* +* Report fatal error. +* + 50 FATAL = .TRUE. + WRITE( NOUT, FMT = 9999 ) + DO 60 I = 1, ML + IF( MV )THEN + WRITE( NOUT, FMT = 9998 )I, YT( I ), + $ YY( 1 + ( I - 1 )*ABS( INCY ) ) + ELSE + WRITE( NOUT, FMT = 9998 )I, + $ YY( 1 + ( I - 1 )*ABS( INCY ) ), YT(I) + END IF + 60 CONTINUE +* + 70 CONTINUE + RETURN +* + 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', + $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU', + $ 'TED RESULT' ) + 9998 FORMAT( 1X, I7, 2G18.6 ) +* +* End of SMVCH. +* + END + LOGICAL FUNCTION LSE( RI, RJ, LR ) +* +* Tests if two arrays are identical. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Scalar Arguments .. + INTEGER LR +* .. Array Arguments .. + REAL RI( * ), RJ( * ) +* .. Local Scalars .. + INTEGER I +* .. Executable Statements .. + DO 10 I = 1, LR + IF( RI( I ).NE.RJ( I ) ) + $ GO TO 20 + 10 CONTINUE + LSE = .TRUE. + GO TO 30 + 20 CONTINUE + LSE = .FALSE. + 30 RETURN +* +* End of LSE. +* + END + LOGICAL FUNCTION LSERES( TYPE, UPLO, M, N, AA, AS, LDA ) +* +* Tests if selected elements in two arrays are equal. +* +* TYPE is 'ge', 'sy' or 'sp'. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Scalar Arguments .. + INTEGER LDA, M, N + CHARACTER*1 UPLO + CHARACTER*2 TYPE +* .. Array Arguments .. + REAL AA( LDA, * ), AS( LDA, * ) +* .. Local Scalars .. + INTEGER I, IBEG, IEND, J + LOGICAL UPPER +* .. Executable Statements .. + UPPER = UPLO.EQ.'U' + IF( TYPE.EQ.'ge' )THEN + DO 20 J = 1, N + DO 10 I = M + 1, LDA + IF( AA( I, J ).NE.AS( I, J ) ) + $ GO TO 70 + 10 CONTINUE + 20 CONTINUE + ELSE IF( TYPE.EQ.'sy' )THEN + DO 50 J = 1, N + IF( UPPER )THEN + IBEG = 1 + IEND = J + ELSE + IBEG = J + IEND = N + END IF + DO 30 I = 1, IBEG - 1 + IF( AA( I, J ).NE.AS( I, J ) ) + $ GO TO 70 + 30 CONTINUE + DO 40 I = IEND + 1, LDA + IF( AA( I, J ).NE.AS( I, J ) ) + $ GO TO 70 + 40 CONTINUE + 50 CONTINUE + END IF +* + 60 CONTINUE + LSERES = .TRUE. + GO TO 80 + 70 CONTINUE + LSERES = .FALSE. + 80 RETURN +* +* End of LSERES. +* + END + REAL FUNCTION SBEG( RESET ) +* +* Generates random numbers uniformly distributed between -0.5 and 0.5. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Scalar Arguments .. + LOGICAL RESET +* .. Local Scalars .. + INTEGER I, IC, MI +* .. Save statement .. + SAVE I, IC, MI +* .. Intrinsic Functions .. + INTRINSIC REAL +* .. Executable Statements .. + IF( RESET )THEN +* Initialize local variables. + MI = 891 + I = 7 + IC = 0 + RESET = .FALSE. + END IF +* +* The sequence of values of I is bounded between 1 and 999. +* If initial I = 1,2,3,6,7 or 9, the period will be 50. +* If initial I = 4 or 8, the period will be 25. +* If initial I = 5, the period will be 10. +* IC is used to break up the period by skipping 1 value of I in 6. +* + IC = IC + 1 + 10 I = I*MI + I = I - 1000*( I/1000 ) + IF( IC.GE.5 )THEN + IC = 0 + GO TO 10 + END IF + SBEG = REAL( I - 500 )/1001.0 + RETURN +* +* End of SBEG. +* + END + REAL FUNCTION SDIFF( X, Y ) +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* +* .. Scalar Arguments .. + REAL X, Y +* .. Executable Statements .. + SDIFF = X - Y + RETURN +* +* End of SDIFF. +* + END diff --git a/cblas/testing/c_sblat3.f b/cblas/testing/c_sblat3.f new file mode 100644 index 00000000..948fd6ed --- /dev/null +++ b/cblas/testing/c_sblat3.f @@ -0,0 +1,2479 @@ + PROGRAM SBLAT3 +* +* 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 .. + INTEGER NIN, NOUT + PARAMETER ( NIN = 5, NOUT = 6 ) + INTEGER NSUBS + PARAMETER ( NSUBS = 6 ) + REAL ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 ) + INTEGER NMAX + PARAMETER ( NMAX = 65 ) + INTEGER NIDMAX, NALMAX, NBEMAX + PARAMETER ( NIDMAX = 9, NALMAX = 7, NBEMAX = 7 ) +* .. Local Scalars .. + REAL EPS, ERR, THRESH + INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NTRA, + $ LAYOUT + LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, + $ TSTERR, CORDER, RORDER + CHARACTER*1 TRANSA, TRANSB + CHARACTER*12 SNAMET + CHARACTER*32 SNAPS +* .. Local Arrays .. + REAL AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ), + $ ALF( NALMAX ), AS( NMAX*NMAX ), + $ BB( NMAX*NMAX ), BET( NBEMAX ), + $ BS( NMAX*NMAX ), C( NMAX, NMAX ), + $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), + $ G( NMAX ), W( 2*NMAX ) + INTEGER IDIM( NIDMAX ) + LOGICAL LTEST( NSUBS ) + CHARACTER*12 SNAMES( NSUBS ) +* .. External Functions .. + REAL SDIFF + LOGICAL LSE + EXTERNAL SDIFF, LSE +* .. External Subroutines .. + EXTERNAL SCHK1, SCHK2, SCHK3, SCHK4, SCHK5, CS3CHKE, + $ SMMCH +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK + CHARACTER*12 SRNAMT +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK + COMMON /SRNAMC/SRNAMT +* .. Data statements .. + DATA SNAMES/'cblas_sgemm ', 'cblas_ssymm ', + $ 'cblas_strmm ', 'cblas_strsm ','cblas_ssyrk ', + $ 'cblas_ssyr2k'/ +* .. Executable Statements .. +* + NOUTC = NOUT +* Read name and unit number for summary output file and open file. +* + READ( NIN, FMT = * )SNAPS + READ( NIN, FMT = * )NTRA + TRACE = NTRA.GE.0 + IF( TRACE )THEN +* OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' ) + OPEN( NTRA, FILE = SNAPS ) + END IF +* Read the flag that directs rewinding of the snapshot file. + READ( NIN, FMT = * )REWI + REWI = REWI.AND.TRACE +* Read the flag that directs stopping on any failure. + READ( NIN, FMT = * )SFATAL +* Read the flag that indicates whether error exits are to be tested. + READ( NIN, FMT = * )TSTERR +* Read the flag that indicates whether row-major data layout to be tested. + READ( NIN, FMT = * )LAYOUT +* Read the threshold value of the test ratio + READ( NIN, FMT = * )THRESH +* +* Read and check the parameter values for the tests. +* +* Values of N + READ( NIN, FMT = * )NIDIM + IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN + WRITE( NOUT, FMT = 9997 )'N', NIDMAX + GO TO 220 + END IF + READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) + DO 10 I = 1, NIDIM + IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN + WRITE( NOUT, FMT = 9996 )NMAX + GO TO 220 + END IF + 10 CONTINUE +* Values of ALPHA + READ( NIN, FMT = * )NALF + IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN + WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX + GO TO 220 + END IF + READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) +* Values of BETA + READ( NIN, FMT = * )NBET + IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN + WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX + GO TO 220 + END IF + READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) +* +* Report values of parameters. +* + WRITE( NOUT, FMT = 9995 ) + WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM ) + WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF ) + WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET ) + IF( .NOT.TSTERR )THEN + WRITE( NOUT, FMT = * ) + WRITE( NOUT, FMT = 9984 ) + END IF + WRITE( NOUT, FMT = * ) + WRITE( NOUT, FMT = 9999 )THRESH + WRITE( NOUT, FMT = * ) + + RORDER = .FALSE. + CORDER = .FALSE. + IF (LAYOUT.EQ.2) THEN + RORDER = .TRUE. + CORDER = .TRUE. + WRITE( *, FMT = 10002 ) + ELSE IF (LAYOUT.EQ.1) THEN + RORDER = .TRUE. + WRITE( *, FMT = 10001 ) + ELSE IF (LAYOUT.EQ.0) THEN + CORDER = .TRUE. + WRITE( *, FMT = 10000 ) + END IF + WRITE( *, FMT = * ) + +* +* Read names of subroutines and flags which indicate +* whether they are to be tested. +* + DO 20 I = 1, NSUBS + LTEST( I ) = .FALSE. + 20 CONTINUE + 30 READ( NIN, FMT = 9988, END = 60 )SNAMET, LTESTT + DO 40 I = 1, NSUBS + IF( SNAMET.EQ.SNAMES( I ) ) + $ GO TO 50 + 40 CONTINUE + WRITE( NOUT, FMT = 9990 )SNAMET + STOP + 50 LTEST( I ) = LTESTT + GO TO 30 +* + 60 CONTINUE + CLOSE ( NIN ) +* +* Compute EPS (the machine precision). +* + EPS = ONE + 70 CONTINUE + IF( SDIFF( ONE + EPS, ONE ).EQ.ZERO ) + $ GO TO 80 + EPS = HALF*EPS + GO TO 70 + 80 CONTINUE + EPS = EPS + EPS + WRITE( NOUT, FMT = 9998 )EPS +* +* Check the reliability of SMMCH using exact data. +* + N = MIN( 32, NMAX ) + DO 100 J = 1, N + DO 90 I = 1, N + AB( I, J ) = MAX( I - J + 1, 0 ) + 90 CONTINUE + AB( J, NMAX + 1 ) = J + AB( 1, NMAX + J ) = J + C( J, 1 ) = ZERO + 100 CONTINUE + DO 110 J = 1, N + CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 + 110 CONTINUE +* CC holds the exact result. On exit from SMMCH CT holds +* the result computed by SMMCH. + TRANSA = 'N' + TRANSB = 'N' + CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, + $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, + $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) + SAME = LSE( CC, CT, N ) + IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN + WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR + STOP + END IF + TRANSB = 'T' + CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, + $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, + $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) + SAME = LSE( CC, CT, N ) + IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN + WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR + STOP + END IF + DO 120 J = 1, N + AB( J, NMAX + 1 ) = N - J + 1 + AB( 1, NMAX + J ) = N - J + 1 + 120 CONTINUE + DO 130 J = 1, N + CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 - + $ ( ( J + 1 )*J*( J - 1 ) )/3 + 130 CONTINUE + TRANSA = 'T' + TRANSB = 'N' + CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, + $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, + $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) + SAME = LSE( CC, CT, N ) + IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN + WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR + STOP + END IF + TRANSB = 'T' + CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, + $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, + $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) + SAME = LSE( CC, CT, N ) + IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN + WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR + STOP + END IF +* +* Test each subroutine in turn. +* + DO 200 ISNUM = 1, NSUBS + WRITE( NOUT, FMT = * ) + IF( .NOT.LTEST( ISNUM ) )THEN +* Subprogram is not to be tested. + WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM ) + ELSE + SRNAMT = SNAMES( ISNUM ) +* Test error exits. + IF( TSTERR )THEN + CALL CS3CHKE( SNAMES( ISNUM ) ) + WRITE( NOUT, FMT = * ) + END IF +* Test computations. + INFOT = 0 + OK = .TRUE. + FATAL = .FALSE. + GO TO ( 140, 150, 160, 160, 170, 180 )ISNUM +* Test SGEMM, 01. + 140 IF (CORDER) THEN + CALL SCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, + $ CC, CS, CT, G, 0 ) + END IF + IF (RORDER) THEN + CALL SCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, + $ CC, CS, CT, G, 1 ) + END IF + GO TO 190 +* Test SSYMM, 02. + 150 IF (CORDER) THEN + CALL SCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, + $ CC, CS, CT, G, 0 ) + END IF + IF (RORDER) THEN + CALL SCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, + $ CC, CS, CT, G, 1 ) + END IF + GO TO 190 +* Test STRMM, 03, STRSM, 04. + 160 IF (CORDER) THEN + CALL SCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB, + $ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C, + $ 0 ) + END IF + IF (RORDER) THEN + CALL SCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB, + $ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C, + $ 1 ) + END IF + GO TO 190 +* Test SSYRK, 05. + 170 IF (CORDER) THEN + CALL SCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, + $ CC, CS, CT, G, 0 ) + END IF + IF (RORDER) THEN + CALL SCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, + $ CC, CS, CT, G, 1 ) + END IF + GO TO 190 +* Test SSYR2K, 06. + 180 IF (CORDER) THEN + CALL SCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W, + $ 0 ) + END IF + IF (RORDER) THEN + CALL SCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W, + $ 1 ) + END IF + GO TO 190 +* + 190 IF( FATAL.AND.SFATAL ) + $ GO TO 210 + END IF + 200 CONTINUE + WRITE( NOUT, FMT = 9986 ) + GO TO 230 +* + 210 CONTINUE + WRITE( NOUT, FMT = 9985 ) + GO TO 230 +* + 220 CONTINUE + WRITE( NOUT, FMT = 9991 ) +* + 230 CONTINUE + IF( TRACE ) + $ CLOSE ( NTRA ) + CLOSE ( NOUT ) + STOP +* +10002 FORMAT( ' COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED' ) +10001 FORMAT( ' ROW-MAJOR DATA LAYOUT IS TESTED' ) +10000 FORMAT( ' COLUMN-MAJOR DATA LAYOUT IS TESTED' ) + 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', + $ 'S THAN', F8.2 ) + 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 ) + 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', + $ 'THAN ', I2 ) + 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) + 9995 FORMAT( ' TESTS OF THE REAL LEVEL 3 BLAS', //' THE F', + $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) + 9994 FORMAT( ' FOR N ', 9I6 ) + 9993 FORMAT( ' FOR ALPHA ', 7F6.1 ) + 9992 FORMAT( ' FOR BETA ', 7F6.1 ) + 9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', + $ /' ******* TESTS ABANDONED *******' ) + 9990 FORMAT( ' SUBPROGRAM NAME ', A12,' NOT RECOGNIZED', /' ******* ', + $ 'TESTS ABANDONED *******' ) + 9989 FORMAT( ' ERROR IN SMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', + $ 'ATED WRONGLY.', /' SMMCH WAS CALLED WITH TRANSA = ', A1, + $ ' AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ', + $ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ', + $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ', + $ '*******' ) + 9988 FORMAT( A12,L2 ) + 9987 FORMAT( 1X, A12,' WAS NOT TESTED' ) + 9986 FORMAT( /' END OF TESTS' ) + 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) + 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) +* +* End of SBLAT3. +* + END + SUBROUTINE SCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, + $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G, + $ IORDER ) +* +* 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 .. + REAL ZERO + PARAMETER ( ZERO = 0.0 ) +* .. Scalar Arguments .. + REAL EPS, THRESH + INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), B( NMAX, NMAX ), + $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), + $ C( NMAX, NMAX ), CC( NMAX*NMAX ), + $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX ) + INTEGER IDIM( NIDIM ) +* .. Local Scalars .. + REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX + INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA, + $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M, + $ MA, MB, MS, N, NA, NARGS, NB, NC, NS + LOGICAL NULL, RESET, SAME, TRANA, TRANB + CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB + CHARACTER*3 ICH +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LSE, LSERES + EXTERNAL LSE, LSERES +* .. External Subroutines .. + EXTERNAL CSGEMM, SMAKE, SMMCH +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICH/'NTC'/ +* .. Executable Statements .. +* + NARGS = 13 + NC = 0 + RESET = .TRUE. + ERRMAX = ZERO +* + DO 110 IM = 1, NIDIM + M = IDIM( IM ) +* + DO 100 IN = 1, NIDIM + N = IDIM( IN ) +* Set LDC to 1 more than minimum value if room. + LDC = M + IF( LDC.LT.NMAX ) + $ LDC = LDC + 1 +* Skip tests if not enough room. + IF( LDC.GT.NMAX ) + $ GO TO 100 + LCC = LDC*N + NULL = N.LE.0.OR.M.LE.0 +* + DO 90 IK = 1, NIDIM + K = IDIM( IK ) +* + DO 80 ICA = 1, 3 + TRANSA = ICH( ICA: ICA ) + TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' +* + IF( TRANA )THEN + MA = K + NA = M + ELSE + MA = M + NA = K + END IF +* Set LDA to 1 more than minimum value if room. + LDA = MA + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 80 + LAA = LDA*NA +* +* Generate the matrix A. +* + CALL SMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, + $ RESET, ZERO ) +* + DO 70 ICB = 1, 3 + TRANSB = ICH( ICB: ICB ) + TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' +* + IF( TRANB )THEN + MB = N + NB = K + ELSE + MB = K + NB = N + END IF +* Set LDB to 1 more than minimum value if room. + LDB = MB + IF( LDB.LT.NMAX ) + $ LDB = LDB + 1 +* Skip tests if not enough room. + IF( LDB.GT.NMAX ) + $ GO TO 70 + LBB = LDB*NB +* +* Generate the matrix B. +* + CALL SMAKE( 'GE', ' ', ' ', MB, NB, B, NMAX, BB, + $ LDB, RESET, ZERO ) +* + DO 60 IA = 1, NALF + ALPHA = ALF( IA ) +* + DO 50 IB = 1, NBET + BETA = BET( IB ) +* +* Generate the matrix C. +* + CALL SMAKE( 'GE', ' ', ' ', M, N, C, NMAX, + $ CC, LDC, RESET, ZERO ) +* + NC = NC + 1 +* +* Save every datum before calling the +* subroutine. +* + TRANAS = TRANSA + TRANBS = TRANSB + MS = M + NS = N + KS = K + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LBB + BS( I ) = BB( I ) + 20 CONTINUE + LDBS = LDB + BLS = BETA + DO 30 I = 1, LCC + CS( I ) = CC( I ) + 30 CONTINUE + LDCS = LDC +* +* Call the subroutine. +* + IF( TRACE ) + $ CALL SPRCN1(NTRA, NC, SNAME, IORDER, + $ TRANSA, TRANSB, M, N, K, ALPHA, LDA, + $ LDB, BETA, LDC) + IF( REWI ) + $ REWIND NTRA + CALL CSGEMM( IORDER, TRANSA, TRANSB, M, N, + $ K, ALPHA, AA, LDA, BB, LDB, + $ BETA, CC, LDC ) +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9994 ) + FATAL = .TRUE. + GO TO 120 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = TRANSA.EQ.TRANAS + ISAME( 2 ) = TRANSB.EQ.TRANBS + ISAME( 3 ) = MS.EQ.M + ISAME( 4 ) = NS.EQ.N + ISAME( 5 ) = KS.EQ.K + ISAME( 6 ) = ALS.EQ.ALPHA + ISAME( 7 ) = LSE( AS, AA, LAA ) + ISAME( 8 ) = LDAS.EQ.LDA + ISAME( 9 ) = LSE( BS, BB, LBB ) + ISAME( 10 ) = LDBS.EQ.LDB + ISAME( 11 ) = BLS.EQ.BETA + IF( NULL )THEN + ISAME( 12 ) = LSE( CS, CC, LCC ) + ELSE + ISAME( 12 ) = LSERES( 'GE', ' ', M, N, CS, + $ CC, LDC ) + END IF + ISAME( 13 ) = LDCS.EQ.LDC +* +* If data was incorrectly changed, report +* and return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I+1 + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 120 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result. +* + CALL SMMCH( TRANSA, TRANSB, M, N, K, + $ ALPHA, A, NMAX, B, NMAX, BETA, + $ C, NMAX, CT, G, CC, LDC, EPS, + $ ERR, FATAL, NOUT, .TRUE. ) + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and +* return. + IF( FATAL ) + $ GO TO 120 + END IF +* + 50 CONTINUE +* + 60 CONTINUE +* + 70 CONTINUE +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* + 110 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 130 +* + 120 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + CALL SPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, + $ M, N, K, ALPHA, LDA, LDB, BETA, LDC) +* + 130 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',', + $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ', + $ 'C,', I3, ').' ) + 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of SCHK1. +* + END +* +* +* + SUBROUTINE SPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, M, N, + $ K, ALPHA, LDA, LDB, BETA, LDC) + INTEGER NOUT, NC, IORDER, M, N, K, LDA, LDB, LDC + REAL ALPHA, BETA + CHARACTER*1 TRANSA, TRANSB + CHARACTER*12 SNAME + CHARACTER*14 CRC, CTA,CTB + + IF (TRANSA.EQ.'N')THEN + CTA = ' CblasNoTrans' + ELSE IF (TRANSA.EQ.'T')THEN + CTA = ' CblasTrans' + ELSE + CTA = 'CblasConjTrans' + END IF + IF (TRANSB.EQ.'N')THEN + CTB = ' CblasNoTrans' + ELSE IF (TRANSB.EQ.'T')THEN + CTB = ' CblasTrans' + ELSE + CTB = 'CblasConjTrans' + END IF + IF (IORDER.EQ.1)THEN + CRC = ' CblasRowMajor' + ELSE + CRC = ' CblasColMajor' + END IF + WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CTA,CTB + WRITE(NOUT, FMT = 9994)M, N, K, ALPHA, LDA, LDB, BETA, LDC + + 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',') + 9994 FORMAT( 20X, 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', + $ F4.1, ', ', 'C,', I3, ').' ) + END +* + SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, + $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G, + $ IORDER ) +* +* 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 .. + REAL ZERO + PARAMETER ( ZERO = 0.0 ) +* .. Scalar Arguments .. + REAL EPS, THRESH + INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), B( NMAX, NMAX ), + $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), + $ C( NMAX, NMAX ), CC( NMAX*NMAX ), + $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX ) + INTEGER IDIM( NIDIM ) +* .. Local Scalars .. + REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX + INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC, + $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA, + $ NARGS, NC, NS + LOGICAL LEFT, NULL, RESET, SAME + CHARACTER*1 SIDE, SIDES, UPLO, UPLOS + CHARACTER*2 ICHS, ICHU +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LSE, LSERES + EXTERNAL LSE, LSERES +* .. External Subroutines .. + EXTERNAL SMAKE, SMMCH, CSSYMM +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICHS/'LR'/, ICHU/'UL'/ +* .. Executable Statements .. +* + NARGS = 12 + NC = 0 + RESET = .TRUE. + ERRMAX = ZERO +* + DO 100 IM = 1, NIDIM + M = IDIM( IM ) +* + DO 90 IN = 1, NIDIM + N = IDIM( IN ) +* Set LDC to 1 more than minimum value if room. + LDC = M + IF( LDC.LT.NMAX ) + $ LDC = LDC + 1 +* Skip tests if not enough room. + IF( LDC.GT.NMAX ) + $ GO TO 90 + LCC = LDC*N + NULL = N.LE.0.OR.M.LE.0 +* +* Set LDB to 1 more than minimum value if room. + LDB = M + IF( LDB.LT.NMAX ) + $ LDB = LDB + 1 +* Skip tests if not enough room. + IF( LDB.GT.NMAX ) + $ GO TO 90 + LBB = LDB*N +* +* Generate the matrix B. +* + CALL SMAKE( 'GE', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET, + $ ZERO ) +* + DO 80 ICS = 1, 2 + SIDE = ICHS( ICS: ICS ) + LEFT = SIDE.EQ.'L' +* + IF( LEFT )THEN + NA = M + ELSE + NA = N + END IF +* Set LDA to 1 more than minimum value if room. + LDA = NA + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 80 + LAA = LDA*NA +* + DO 70 ICU = 1, 2 + UPLO = ICHU( ICU: ICU ) +* +* Generate the symmetric matrix A. +* + CALL SMAKE( 'SY', UPLO, ' ', NA, NA, A, NMAX, AA, LDA, + $ RESET, ZERO ) +* + DO 60 IA = 1, NALF + ALPHA = ALF( IA ) +* + DO 50 IB = 1, NBET + BETA = BET( IB ) +* +* Generate the matrix C. +* + CALL SMAKE( 'GE', ' ', ' ', M, N, C, NMAX, CC, + $ LDC, RESET, ZERO ) +* + NC = NC + 1 +* +* Save every datum before calling the +* subroutine. +* + SIDES = SIDE + UPLOS = UPLO + MS = M + NS = N + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LBB + BS( I ) = BB( I ) + 20 CONTINUE + LDBS = LDB + BLS = BETA + DO 30 I = 1, LCC + CS( I ) = CC( I ) + 30 CONTINUE + LDCS = LDC +* +* Call the subroutine. +* + IF( TRACE ) + $ CALL SPRCN2(NTRA, NC, SNAME, IORDER, + $ SIDE, UPLO, M, N, ALPHA, LDA, LDB, + $ BETA, LDC) + IF( REWI ) + $ REWIND NTRA + CALL CSSYMM( IORDER, SIDE, UPLO, M, N, ALPHA, + $ AA, LDA, BB, LDB, BETA, CC, LDC ) +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9994 ) + FATAL = .TRUE. + GO TO 110 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = SIDES.EQ.SIDE + ISAME( 2 ) = UPLOS.EQ.UPLO + ISAME( 3 ) = MS.EQ.M + ISAME( 4 ) = NS.EQ.N + ISAME( 5 ) = ALS.EQ.ALPHA + ISAME( 6 ) = LSE( AS, AA, LAA ) + ISAME( 7 ) = LDAS.EQ.LDA + ISAME( 8 ) = LSE( BS, BB, LBB ) + ISAME( 9 ) = LDBS.EQ.LDB + ISAME( 10 ) = BLS.EQ.BETA + IF( NULL )THEN + ISAME( 11 ) = LSE( CS, CC, LCC ) + ELSE + ISAME( 11 ) = LSERES( 'GE', ' ', M, N, CS, + $ CC, LDC ) + END IF + ISAME( 12 ) = LDCS.EQ.LDC +* +* If data was incorrectly changed, report and +* return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I+1 + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 110 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result. +* + IF( LEFT )THEN + CALL SMMCH( 'N', 'N', M, N, M, ALPHA, A, + $ NMAX, B, NMAX, BETA, C, NMAX, + $ CT, G, CC, LDC, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + ELSE + CALL SMMCH( 'N', 'N', M, N, N, ALPHA, B, + $ NMAX, A, NMAX, BETA, C, NMAX, + $ CT, G, CC, LDC, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + END IF + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and +* return. + IF( FATAL ) + $ GO TO 110 + END IF +* + 50 CONTINUE +* + 60 CONTINUE +* + 70 CONTINUE +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 120 +* + 110 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + CALL SPRCN2(NOUT, NC, SNAME, IORDER, SIDE, UPLO, M, N, ALPHA, LDA, + $ LDB, BETA, LDC) +* + 120 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), + $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', + $ ' .' ) + 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of SCHK2. +* + END +* + SUBROUTINE SPRCN2(NOUT, NC, SNAME, IORDER, SIDE, UPLO, M, N, + $ ALPHA, LDA, LDB, BETA, LDC) + INTEGER NOUT, NC, IORDER, M, N, LDA, LDB, LDC + REAL ALPHA, BETA + CHARACTER*1 SIDE, UPLO + CHARACTER*12 SNAME + CHARACTER*14 CRC, CS,CU + + IF (SIDE.EQ.'L')THEN + CS = ' CblasLeft' + ELSE + CS = ' CblasRight' + END IF + IF (UPLO.EQ.'U')THEN + CU = ' CblasUpper' + ELSE + CU = ' CblasLower' + END IF + IF (IORDER.EQ.1)THEN + CRC = ' CblasRowMajor' + ELSE + CRC = ' CblasColMajor' + END IF + WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CS,CU + WRITE(NOUT, FMT = 9994)M, N, ALPHA, LDA, LDB, BETA, LDC + + 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',') + 9994 FORMAT( 20X, 2( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', + $ F4.1, ', ', 'C,', I3, ').' ) + END +* + SUBROUTINE SCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NMAX, A, AA, AS, + $ B, BB, BS, CT, G, C, IORDER ) +* +* Tests STRMM and STRSM. +* +* 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 .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0, ONE = 1.0 ) +* .. Scalar Arguments .. + REAL EPS, THRESH + INTEGER NALF, NIDIM, NMAX, NOUT, NTRA, IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), B( NMAX, NMAX ), + $ BB( NMAX*NMAX ), BS( NMAX*NMAX ), + $ C( NMAX, NMAX ), CT( NMAX ), G( NMAX ) + INTEGER IDIM( NIDIM ) +* .. Local Scalars .. + REAL ALPHA, ALS, ERR, ERRMAX + INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB, + $ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC, + $ NS + LOGICAL LEFT, NULL, RESET, SAME + CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO, + $ UPLOS + CHARACTER*2 ICHD, ICHS, ICHU + CHARACTER*3 ICHT +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LSE, LSERES + EXTERNAL LSE, LSERES +* .. External Subroutines .. + EXTERNAL SMAKE, SMMCH, CSTRMM, CSTRSM +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/, ICHS/'LR'/ +* .. Executable Statements .. +* + NARGS = 11 + NC = 0 + RESET = .TRUE. + ERRMAX = ZERO +* Set up zero matrix for SMMCH. + DO 20 J = 1, NMAX + DO 10 I = 1, NMAX + C( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE +* + DO 140 IM = 1, NIDIM + M = IDIM( IM ) +* + DO 130 IN = 1, NIDIM + N = IDIM( IN ) +* Set LDB to 1 more than minimum value if room. + LDB = M + IF( LDB.LT.NMAX ) + $ LDB = LDB + 1 +* Skip tests if not enough room. + IF( LDB.GT.NMAX ) + $ GO TO 130 + LBB = LDB*N + NULL = M.LE.0.OR.N.LE.0 +* + DO 120 ICS = 1, 2 + SIDE = ICHS( ICS: ICS ) + LEFT = SIDE.EQ.'L' + IF( LEFT )THEN + NA = M + ELSE + NA = N + END IF +* Set LDA to 1 more than minimum value if room. + LDA = NA + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 130 + LAA = LDA*NA +* + DO 110 ICU = 1, 2 + UPLO = ICHU( ICU: ICU ) +* + DO 100 ICT = 1, 3 + TRANSA = ICHT( ICT: ICT ) +* + DO 90 ICD = 1, 2 + DIAG = ICHD( ICD: ICD ) +* + DO 80 IA = 1, NALF + ALPHA = ALF( IA ) +* +* Generate the matrix A. +* + CALL SMAKE( 'TR', UPLO, DIAG, NA, NA, A, + $ NMAX, AA, LDA, RESET, ZERO ) +* +* Generate the matrix B. +* + CALL SMAKE( 'GE', ' ', ' ', M, N, B, NMAX, + $ BB, LDB, RESET, ZERO ) +* + NC = NC + 1 +* +* Save every datum before calling the +* subroutine. +* + SIDES = SIDE + UPLOS = UPLO + TRANAS = TRANSA + DIAGS = DIAG + MS = M + NS = N + ALS = ALPHA + DO 30 I = 1, LAA + AS( I ) = AA( I ) + 30 CONTINUE + LDAS = LDA + DO 40 I = 1, LBB + BS( I ) = BB( I ) + 40 CONTINUE + LDBS = LDB +* +* Call the subroutine. +* + IF( SNAME( 10: 11 ).EQ.'mm' )THEN + IF( TRACE ) + $ CALL SPRCN3( NTRA, NC, SNAME, IORDER, + $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, + $ LDA, LDB) + IF( REWI ) + $ REWIND NTRA + CALL CSTRMM( IORDER, SIDE, UPLO, TRANSA, + $ DIAG, M, N, ALPHA, AA, LDA, + $ BB, LDB ) + ELSE IF( SNAME( 10: 11 ).EQ.'sm' )THEN + IF( TRACE ) + $ CALL SPRCN3( NTRA, NC, SNAME, IORDER, + $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, + $ LDA, LDB) + IF( REWI ) + $ REWIND NTRA + CALL CSTRSM( IORDER, SIDE, UPLO, TRANSA, + $ DIAG, M, N, ALPHA, AA, LDA, + $ BB, LDB ) + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9994 ) + FATAL = .TRUE. + GO TO 150 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = SIDES.EQ.SIDE + ISAME( 2 ) = UPLOS.EQ.UPLO + ISAME( 3 ) = TRANAS.EQ.TRANSA + ISAME( 4 ) = DIAGS.EQ.DIAG + ISAME( 5 ) = MS.EQ.M + ISAME( 6 ) = NS.EQ.N + ISAME( 7 ) = ALS.EQ.ALPHA + ISAME( 8 ) = LSE( AS, AA, LAA ) + ISAME( 9 ) = LDAS.EQ.LDA + IF( NULL )THEN + ISAME( 10 ) = LSE( BS, BB, LBB ) + ELSE + ISAME( 10 ) = LSERES( 'GE', ' ', M, N, BS, + $ BB, LDB ) + END IF + ISAME( 11 ) = LDBS.EQ.LDB +* +* If data was incorrectly changed, report and +* return. +* + SAME = .TRUE. + DO 50 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I+1 + 50 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 150 + END IF +* + IF( .NOT.NULL )THEN + IF( SNAME( 10: 11 ).EQ.'mm' )THEN +* +* Check the result. +* + IF( LEFT )THEN + CALL SMMCH( TRANSA, 'N', M, N, M, + $ ALPHA, A, NMAX, B, NMAX, + $ ZERO, C, NMAX, CT, G, + $ BB, LDB, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + ELSE + CALL SMMCH( 'N', TRANSA, M, N, N, + $ ALPHA, B, NMAX, A, NMAX, + $ ZERO, C, NMAX, CT, G, + $ BB, LDB, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + END IF + ELSE IF( SNAME( 10: 11 ).EQ.'sm' )THEN +* +* Compute approximation to original +* matrix. +* + DO 70 J = 1, N + DO 60 I = 1, M + C( I, J ) = BB( I + ( J - 1 )* + $ LDB ) + BB( I + ( J - 1 )*LDB ) = ALPHA* + $ B( I, J ) + 60 CONTINUE + 70 CONTINUE +* + IF( LEFT )THEN + CALL SMMCH( TRANSA, 'N', M, N, M, + $ ONE, A, NMAX, C, NMAX, + $ ZERO, B, NMAX, CT, G, + $ BB, LDB, EPS, ERR, + $ FATAL, NOUT, .FALSE. ) + ELSE + CALL SMMCH( 'N', TRANSA, M, N, N, + $ ONE, C, NMAX, A, NMAX, + $ ZERO, B, NMAX, CT, G, + $ BB, LDB, EPS, ERR, + $ FATAL, NOUT, .FALSE. ) + END IF + END IF + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and +* return. + IF( FATAL ) + $ GO TO 150 + END IF +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* + 110 CONTINUE +* + 120 CONTINUE +* + 130 CONTINUE +* + 140 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 160 +* + 150 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + CALL SPRCN3( NTRA, NC, SNAME, IORDER, SIDE, UPLO, TRANSA, DIAG, + $ M, N, ALPHA, LDA, LDB) +* + 160 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( I3, ',' ), + $ F4.1, ', A,', I3, ', B,', I3, ') .' ) + 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of SCHK3. +* + END +* + SUBROUTINE SPRCN3(NOUT, NC, SNAME, IORDER, SIDE, UPLO, TRANSA, + $ DIAG, M, N, ALPHA, LDA, LDB) + INTEGER NOUT, NC, IORDER, M, N, LDA, LDB + REAL ALPHA + CHARACTER*1 SIDE, UPLO, TRANSA, DIAG + CHARACTER*12 SNAME + CHARACTER*14 CRC, CS, CU, CA, CD + + IF (SIDE.EQ.'L')THEN + CS = ' CblasLeft' + ELSE + CS = ' CblasRight' + END IF + IF (UPLO.EQ.'U')THEN + CU = ' CblasUpper' + ELSE + CU = ' CblasLower' + END IF + IF (TRANSA.EQ.'N')THEN + CA = ' CblasNoTrans' + ELSE IF (TRANSA.EQ.'T')THEN + CA = ' CblasTrans' + ELSE + CA = 'CblasConjTrans' + END IF + IF (DIAG.EQ.'N')THEN + CD = ' CblasNonUnit' + ELSE + CD = ' CblasUnit' + END IF + IF (IORDER.EQ.1)THEN + CRC = 'CblasRowMajor' + ELSE + CRC = 'CblasColMajor' + END IF + WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CS,CU + WRITE(NOUT, FMT = 9994)CA, CD, M, N, ALPHA, LDA, LDB + + 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',') + 9994 FORMAT( 22X, 2( A14, ',') , 2( I3, ',' ), + $ F4.1, ', A,', I3, ', B,', I3, ').' ) + END +* + SUBROUTINE SCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, + $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G, + $ IORDER ) +* +* Tests SSYRK. +* +* 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 .. + REAL ZERO + PARAMETER ( ZERO = 0.0 ) +* .. Scalar Arguments .. + REAL EPS, THRESH + INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), B( NMAX, NMAX ), + $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), + $ C( NMAX, NMAX ), CC( NMAX*NMAX ), + $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX ) + INTEGER IDIM( NIDIM ) +* .. Local Scalars .. + REAL ALPHA, ALS, BETA, BETS, ERR, ERRMAX + INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS, + $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA, + $ NARGS, NC, NS + LOGICAL NULL, RESET, SAME, TRAN, UPPER + CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS + CHARACTER*2 ICHU + CHARACTER*3 ICHT +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LSE, LSERES + EXTERNAL LSE, LSERES +* .. External Subroutines .. + EXTERNAL SMAKE, SMMCH, CSSYRK +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICHT/'NTC'/, ICHU/'UL'/ +* .. Executable Statements .. +* + NARGS = 10 + NC = 0 + RESET = .TRUE. + ERRMAX = ZERO +* + DO 100 IN = 1, NIDIM + N = IDIM( IN ) +* Set LDC to 1 more than minimum value if room. + LDC = N + IF( LDC.LT.NMAX ) + $ LDC = LDC + 1 +* Skip tests if not enough room. + IF( LDC.GT.NMAX ) + $ GO TO 100 + LCC = LDC*N + NULL = N.LE.0 +* + DO 90 IK = 1, NIDIM + K = IDIM( IK ) +* + DO 80 ICT = 1, 3 + TRANS = ICHT( ICT: ICT ) + TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' + IF( TRAN )THEN + MA = K + NA = N + ELSE + MA = N + NA = K + END IF +* Set LDA to 1 more than minimum value if room. + LDA = MA + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 80 + LAA = LDA*NA +* +* Generate the matrix A. +* + CALL SMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, + $ RESET, ZERO ) +* + DO 70 ICU = 1, 2 + UPLO = ICHU( ICU: ICU ) + UPPER = UPLO.EQ.'U' +* + DO 60 IA = 1, NALF + ALPHA = ALF( IA ) +* + DO 50 IB = 1, NBET + BETA = BET( IB ) +* +* Generate the matrix C. +* + CALL SMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC, + $ LDC, RESET, ZERO ) +* + NC = NC + 1 +* +* Save every datum before calling the subroutine. +* + UPLOS = UPLO + TRANSS = TRANS + NS = N + KS = K + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + BETS = BETA + DO 20 I = 1, LCC + CS( I ) = CC( I ) + 20 CONTINUE + LDCS = LDC +* +* Call the subroutine. +* + IF( TRACE ) + $ CALL SPRCN4( NTRA, NC, SNAME, IORDER, UPLO, + $ TRANS, N, K, ALPHA, LDA, BETA, LDC) + IF( REWI ) + $ REWIND NTRA + CALL CSSYRK( IORDER, UPLO, TRANS, N, K, ALPHA, + $ AA, LDA, BETA, CC, LDC ) +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9993 ) + FATAL = .TRUE. + GO TO 120 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = UPLOS.EQ.UPLO + ISAME( 2 ) = TRANSS.EQ.TRANS + ISAME( 3 ) = NS.EQ.N + ISAME( 4 ) = KS.EQ.K + ISAME( 5 ) = ALS.EQ.ALPHA + ISAME( 6 ) = LSE( AS, AA, LAA ) + ISAME( 7 ) = LDAS.EQ.LDA + ISAME( 8 ) = BETS.EQ.BETA + IF( NULL )THEN + ISAME( 9 ) = LSE( CS, CC, LCC ) + ELSE + ISAME( 9 ) = LSERES( 'SY', UPLO, N, N, CS, + $ CC, LDC ) + END IF + ISAME( 10 ) = LDCS.EQ.LDC +* +* If data was incorrectly changed, report and +* return. +* + SAME = .TRUE. + DO 30 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I+1 + 30 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 120 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result column by column. +* + JC = 1 + DO 40 J = 1, N + IF( UPPER )THEN + JJ = 1 + LJ = J + ELSE + JJ = J + LJ = N - J + 1 + END IF + IF( TRAN )THEN + CALL SMMCH( 'T', 'N', LJ, 1, K, ALPHA, + $ A( 1, JJ ), NMAX, + $ A( 1, J ), NMAX, BETA, + $ C( JJ, J ), NMAX, CT, G, + $ CC( JC ), LDC, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + ELSE + CALL SMMCH( 'N', 'T', LJ, 1, K, ALPHA, + $ A( JJ, 1 ), NMAX, + $ A( J, 1 ), NMAX, BETA, + $ C( JJ, J ), NMAX, CT, G, + $ CC( JC ), LDC, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + END IF + IF( UPPER )THEN + JC = JC + LDC + ELSE + JC = JC + LDC + 1 + END IF + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and +* return. + IF( FATAL ) + $ GO TO 110 + 40 CONTINUE + END IF +* + 50 CONTINUE +* + 60 CONTINUE +* + 70 CONTINUE +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 130 +* + 110 CONTINUE + IF( N.GT.1 ) + $ WRITE( NOUT, FMT = 9995 )J +* + 120 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + CALL SPRCN4( NOUT, NC, SNAME, IORDER, UPLO, TRANS, N, K, ALPHA, + $ LDA, BETA, LDC) +* + 130 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) + 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), + $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' ) + 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of SCHK4. +* + END +* + SUBROUTINE SPRCN4(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, + $ N, K, ALPHA, LDA, BETA, LDC) + INTEGER NOUT, NC, IORDER, N, K, LDA, LDC + REAL ALPHA, BETA + CHARACTER*1 UPLO, TRANSA + CHARACTER*12 SNAME + CHARACTER*14 CRC, CU, CA + + IF (UPLO.EQ.'U')THEN + CU = ' CblasUpper' + ELSE + CU = ' CblasLower' + END IF + IF (TRANSA.EQ.'N')THEN + CA = ' CblasNoTrans' + ELSE IF (TRANSA.EQ.'T')THEN + CA = ' CblasTrans' + ELSE + CA = 'CblasConjTrans' + END IF + IF (IORDER.EQ.1)THEN + CRC = ' CblasRowMajor' + ELSE + CRC = ' CblasColMajor' + END IF + WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA + WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, BETA, LDC + + 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') ) + 9994 FORMAT( 20X, 2( I3, ',' ), + $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ').' ) + END +* + SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, + $ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W, + $ IORDER ) +* +* 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 .. + REAL ZERO + PARAMETER ( ZERO = 0.0 ) +* .. Scalar Arguments .. + REAL EPS, THRESH + INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + REAL AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ), + $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ), + $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ), + $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), + $ G( NMAX ), W( 2*NMAX ) + INTEGER IDIM( NIDIM ) +* .. Local Scalars .. + REAL ALPHA, ALS, BETA, BETS, ERR, ERRMAX + INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB, + $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS, + $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS + LOGICAL NULL, RESET, SAME, TRAN, UPPER + CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS + CHARACTER*2 ICHU + CHARACTER*3 ICHT +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LSE, LSERES + EXTERNAL LSE, LSERES +* .. External Subroutines .. + EXTERNAL SMAKE, SMMCH, CSSYR2K +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICHT/'NTC'/, ICHU/'UL'/ +* .. Executable Statements .. +* + NARGS = 12 + NC = 0 + RESET = .TRUE. + ERRMAX = ZERO +* + DO 130 IN = 1, NIDIM + N = IDIM( IN ) +* Set LDC to 1 more than minimum value if room. + LDC = N + IF( LDC.LT.NMAX ) + $ LDC = LDC + 1 +* Skip tests if not enough room. + IF( LDC.GT.NMAX ) + $ GO TO 130 + LCC = LDC*N + NULL = N.LE.0 +* + DO 120 IK = 1, NIDIM + K = IDIM( IK ) +* + DO 110 ICT = 1, 3 + TRANS = ICHT( ICT: ICT ) + TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' + IF( TRAN )THEN + MA = K + NA = N + ELSE + MA = N + NA = K + END IF +* Set LDA to 1 more than minimum value if room. + LDA = MA + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 110 + LAA = LDA*NA +* +* Generate the matrix A. +* + IF( TRAN )THEN + CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA, + $ LDA, RESET, ZERO ) + ELSE + CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA, + $ RESET, ZERO ) + END IF +* +* Generate the matrix B. +* + LDB = LDA + LBB = LAA + IF( TRAN )THEN + CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB( K + 1 ), + $ 2*NMAX, BB, LDB, RESET, ZERO ) + ELSE + CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ), + $ NMAX, BB, LDB, RESET, ZERO ) + END IF +* + DO 100 ICU = 1, 2 + UPLO = ICHU( ICU: ICU ) + UPPER = UPLO.EQ.'U' +* + DO 90 IA = 1, NALF + ALPHA = ALF( IA ) +* + DO 80 IB = 1, NBET + BETA = BET( IB ) +* +* Generate the matrix C. +* + CALL SMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC, + $ LDC, RESET, ZERO ) +* + NC = NC + 1 +* +* Save every datum before calling the subroutine. +* + UPLOS = UPLO + TRANSS = TRANS + NS = N + KS = K + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LBB + BS( I ) = BB( I ) + 20 CONTINUE + LDBS = LDB + BETS = BETA + DO 30 I = 1, LCC + CS( I ) = CC( I ) + 30 CONTINUE + LDCS = LDC +* +* Call the subroutine. +* + IF( TRACE ) + $ CALL SPRCN5( NTRA, NC, SNAME, IORDER, UPLO, + $ TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC) + IF( REWI ) + $ REWIND NTRA + CALL CSSYR2K( IORDER, UPLO, TRANS, N, K, ALPHA, + $ AA, LDA, BB, LDB, BETA, CC, LDC ) +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9993 ) + FATAL = .TRUE. + GO TO 150 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = UPLOS.EQ.UPLO + ISAME( 2 ) = TRANSS.EQ.TRANS + ISAME( 3 ) = NS.EQ.N + ISAME( 4 ) = KS.EQ.K + ISAME( 5 ) = ALS.EQ.ALPHA + ISAME( 6 ) = LSE( AS, AA, LAA ) + ISAME( 7 ) = LDAS.EQ.LDA + ISAME( 8 ) = LSE( BS, BB, LBB ) + ISAME( 9 ) = LDBS.EQ.LDB + ISAME( 10 ) = BETS.EQ.BETA + IF( NULL )THEN + ISAME( 11 ) = LSE( CS, CC, LCC ) + ELSE + ISAME( 11 ) = LSERES( 'SY', UPLO, N, N, CS, + $ CC, LDC ) + END IF + ISAME( 12 ) = LDCS.EQ.LDC +* +* If data was incorrectly changed, report and +* return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I+1 + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 150 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result column by column. +* + JJAB = 1 + JC = 1 + DO 70 J = 1, N + IF( UPPER )THEN + JJ = 1 + LJ = J + ELSE + JJ = J + LJ = N - J + 1 + END IF + IF( TRAN )THEN + DO 50 I = 1, K + W( I ) = AB( ( J - 1 )*2*NMAX + K + + $ I ) + W( K + I ) = AB( ( J - 1 )*2*NMAX + + $ I ) + 50 CONTINUE + CALL SMMCH( 'T', 'N', LJ, 1, 2*K, + $ ALPHA, AB( JJAB ), 2*NMAX, + $ W, 2*NMAX, BETA, + $ C( JJ, J ), NMAX, CT, G, + $ CC( JC ), LDC, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + ELSE + DO 60 I = 1, K + W( I ) = AB( ( K + I - 1 )*NMAX + + $ J ) + W( K + I ) = AB( ( I - 1 )*NMAX + + $ J ) + 60 CONTINUE + CALL SMMCH( 'N', 'N', LJ, 1, 2*K, + $ ALPHA, AB( JJ ), NMAX, W, + $ 2*NMAX, BETA, C( JJ, J ), + $ NMAX, CT, G, CC( JC ), LDC, + $ EPS, ERR, FATAL, NOUT, + $ .TRUE. ) + END IF + IF( UPPER )THEN + JC = JC + LDC + ELSE + JC = JC + LDC + 1 + IF( TRAN ) + $ JJAB = JJAB + 2*NMAX + END IF + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and +* return. + IF( FATAL ) + $ GO TO 140 + 70 CONTINUE + END IF +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* + 110 CONTINUE +* + 120 CONTINUE +* + 130 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 160 +* + 140 CONTINUE + IF( N.GT.1 ) + $ WRITE( NOUT, FMT = 9995 )J +* + 150 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + CALL SPRCN5( NOUT, NC, SNAME, IORDER, UPLO, TRANS, N, K, ALPHA, + $ LDA, LDB, BETA, LDC) +* + 160 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) + 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), + $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', + $ ' .' ) + 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of SCHK5. +* + END +* + SUBROUTINE SPRCN5(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, + $ N, K, ALPHA, LDA, LDB, BETA, LDC) + INTEGER NOUT, NC, IORDER, N, K, LDA, LDB, LDC + REAL ALPHA, BETA + CHARACTER*1 UPLO, TRANSA + CHARACTER*12 SNAME + CHARACTER*14 CRC, CU, CA + + IF (UPLO.EQ.'U')THEN + CU = ' CblasUpper' + ELSE + CU = ' CblasLower' + END IF + IF (TRANSA.EQ.'N')THEN + CA = ' CblasNoTrans' + ELSE IF (TRANSA.EQ.'T')THEN + CA = ' CblasTrans' + ELSE + CA = 'CblasConjTrans' + END IF + IF (IORDER.EQ.1)THEN + CRC = ' CblasRowMajor' + ELSE + CRC = ' CblasColMajor' + END IF + WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA + WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, LDB, BETA, LDC + + 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') ) + 9994 FORMAT( 20X, 2( I3, ',' ), + $ F4.1, ', A,', I3, ', B', I3, ',', F4.1, ', C,', I3, ').' ) + END +* + SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, + $ TRANSL ) +* +* 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 .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0, ONE = 1.0 ) + REAL ROGUE + PARAMETER ( ROGUE = -1.0E10 ) +* .. Scalar Arguments .. + REAL TRANSL + INTEGER LDA, M, N, NMAX + LOGICAL RESET + CHARACTER*1 DIAG, UPLO + CHARACTER*2 TYPE +* .. Array Arguments .. + REAL A( NMAX, * ), AA( * ) +* .. Local Scalars .. + INTEGER I, IBEG, IEND, J + LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER +* .. External Functions .. + REAL SBEG + EXTERNAL SBEG +* .. Executable Statements .. + GEN = TYPE.EQ.'GE' + SYM = TYPE.EQ.'SY' + TRI = TYPE.EQ.'TR' + UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U' + LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L' + UNIT = TRI.AND.DIAG.EQ.'U' +* +* Generate data in array A. +* + DO 20 J = 1, N + DO 10 I = 1, M + IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) + $ THEN + A( I, J ) = SBEG( RESET ) + TRANSL + IF( I.NE.J )THEN +* Set some elements to zero + IF( N.GT.3.AND.J.EQ.N/2 ) + $ A( I, J ) = ZERO + IF( SYM )THEN + A( J, I ) = A( I, J ) + ELSE IF( TRI )THEN + A( J, I ) = ZERO + END IF + END IF + END IF + 10 CONTINUE + IF( TRI ) + $ A( J, J ) = A( J, J ) + ONE + IF( UNIT ) + $ A( J, J ) = ONE + 20 CONTINUE +* +* Store elements in array AS in data structure required by routine. +* + IF( TYPE.EQ.'GE' )THEN + DO 50 J = 1, N + DO 30 I = 1, M + AA( I + ( J - 1 )*LDA ) = A( I, J ) + 30 CONTINUE + DO 40 I = M + 1, LDA + AA( I + ( J - 1 )*LDA ) = ROGUE + 40 CONTINUE + 50 CONTINUE + ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN + DO 90 J = 1, N + IF( UPPER )THEN + IBEG = 1 + IF( UNIT )THEN + IEND = J - 1 + ELSE + IEND = J + END IF + ELSE + IF( UNIT )THEN + IBEG = J + 1 + ELSE + IBEG = J + END IF + IEND = N + END IF + DO 60 I = 1, IBEG - 1 + AA( I + ( J - 1 )*LDA ) = ROGUE + 60 CONTINUE + DO 70 I = IBEG, IEND + AA( I + ( J - 1 )*LDA ) = A( I, J ) + 70 CONTINUE + DO 80 I = IEND + 1, LDA + AA( I + ( J - 1 )*LDA ) = ROGUE + 80 CONTINUE + 90 CONTINUE + END IF + RETURN +* +* End of SMAKE. +* + END + SUBROUTINE SMMCH( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, + $ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, + $ NOUT, MV ) +* +* 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 .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0, ONE = 1.0 ) +* .. Scalar Arguments .. + REAL ALPHA, BETA, EPS, ERR + INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT + LOGICAL FATAL, MV + CHARACTER*1 TRANSA, TRANSB +* .. Array Arguments .. + REAL A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ CC( LDCC, * ), CT( * ), G( * ) +* .. Local Scalars .. + REAL ERRI + INTEGER I, J, K + LOGICAL TRANA, TRANB +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. Executable Statements .. + TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' + TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' +* +* Compute expected result, one column at a time, in CT using data +* in A, B and C. +* Compute gauges in G. +* + DO 120 J = 1, N +* + DO 10 I = 1, M + CT( I ) = ZERO + G( I ) = ZERO + 10 CONTINUE + IF( .NOT.TRANA.AND..NOT.TRANB )THEN + DO 30 K = 1, KK + DO 20 I = 1, M + CT( I ) = CT( I ) + A( I, K )*B( K, J ) + G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( K, J ) ) + 20 CONTINUE + 30 CONTINUE + ELSE IF( TRANA.AND..NOT.TRANB )THEN + DO 50 K = 1, KK + DO 40 I = 1, M + CT( I ) = CT( I ) + A( K, I )*B( K, J ) + G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( K, J ) ) + 40 CONTINUE + 50 CONTINUE + ELSE IF( .NOT.TRANA.AND.TRANB )THEN + DO 70 K = 1, KK + DO 60 I = 1, M + CT( I ) = CT( I ) + A( I, K )*B( J, K ) + G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( J, K ) ) + 60 CONTINUE + 70 CONTINUE + ELSE IF( TRANA.AND.TRANB )THEN + DO 90 K = 1, KK + DO 80 I = 1, M + CT( I ) = CT( I ) + A( K, I )*B( J, K ) + G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( J, K ) ) + 80 CONTINUE + 90 CONTINUE + END IF + DO 100 I = 1, M + CT( I ) = ALPHA*CT( I ) + BETA*C( I, J ) + G( I ) = ABS( ALPHA )*G( I ) + ABS( BETA )*ABS( C( I, J ) ) + 100 CONTINUE +* +* Compute the error ratio for this result. +* + ERR = ZERO + DO 110 I = 1, M + ERRI = ABS( CT( I ) - CC( I, J ) )/EPS + IF( G( I ).NE.ZERO ) + $ ERRI = ERRI/G( I ) + ERR = MAX( ERR, ERRI ) + IF( ERR*SQRT( EPS ).GE.ONE ) + $ GO TO 130 + 110 CONTINUE +* + 120 CONTINUE +* +* If the loop completes, all results are at least half accurate. + GO TO 150 +* +* Report fatal error. +* + 130 FATAL = .TRUE. + WRITE( NOUT, FMT = 9999 ) + DO 140 I = 1, M + IF( MV )THEN + WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J ) + ELSE + WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I ) + END IF + 140 CONTINUE + IF( N.GT.1 ) + $ WRITE( NOUT, FMT = 9997 )J +* + 150 CONTINUE + RETURN +* + 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', + $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU', + $ 'TED RESULT' ) + 9998 FORMAT( 1X, I7, 2G18.6 ) + 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) +* +* End of SMMCH. +* + END + LOGICAL FUNCTION LSE( RI, RJ, LR ) +* +* 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 .. + INTEGER LR +* .. Array Arguments .. + REAL RI( * ), RJ( * ) +* .. Local Scalars .. + INTEGER I +* .. Executable Statements .. + DO 10 I = 1, LR + IF( RI( I ).NE.RJ( I ) ) + $ GO TO 20 + 10 CONTINUE + LSE = .TRUE. + GO TO 30 + 20 CONTINUE + LSE = .FALSE. + 30 RETURN +* +* End of LSE. +* + END + LOGICAL FUNCTION LSERES( TYPE, UPLO, M, N, AA, AS, LDA ) +* +* 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 .. + INTEGER LDA, M, N + CHARACTER*1 UPLO + CHARACTER*2 TYPE +* .. Array Arguments .. + REAL AA( LDA, * ), AS( LDA, * ) +* .. Local Scalars .. + INTEGER I, IBEG, IEND, J + LOGICAL UPPER +* .. Executable Statements .. + UPPER = UPLO.EQ.'U' + IF( TYPE.EQ.'GE' )THEN + DO 20 J = 1, N + DO 10 I = M + 1, LDA + IF( AA( I, J ).NE.AS( I, J ) ) + $ GO TO 70 + 10 CONTINUE + 20 CONTINUE + ELSE IF( TYPE.EQ.'SY' )THEN + DO 50 J = 1, N + IF( UPPER )THEN + IBEG = 1 + IEND = J + ELSE + IBEG = J + IEND = N + END IF + DO 30 I = 1, IBEG - 1 + IF( AA( I, J ).NE.AS( I, J ) ) + $ GO TO 70 + 30 CONTINUE + DO 40 I = IEND + 1, LDA + IF( AA( I, J ).NE.AS( I, J ) ) + $ GO TO 70 + 40 CONTINUE + 50 CONTINUE + END IF +* + 60 CONTINUE + LSERES = .TRUE. + GO TO 80 + 70 CONTINUE + LSERES = .FALSE. + 80 RETURN +* +* End of LSERES. +* + END + REAL FUNCTION SBEG( RESET ) +* +* Generates 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 .. + LOGICAL RESET +* .. Local Scalars .. + INTEGER I, IC, MI +* .. Save statement .. + SAVE I, IC, MI +* .. Executable Statements .. + IF( RESET )THEN +* Initialize local variables. + MI = 891 + I = 7 + IC = 0 + RESET = .FALSE. + END IF +* +* The sequence of values of I is bounded between 1 and 999. +* If initial I = 1,2,3,6,7 or 9, the period will be 50. +* If initial I = 4 or 8, the period will be 25. +* If initial I = 5, the period will be 10. +* IC is used to break up the period by skipping 1 value of I in 6. +* + IC = IC + 1 + 10 I = I*MI + I = I - 1000*( I/1000 ) + IF( IC.GE.5 )THEN + IC = 0 + GO TO 10 + END IF + SBEG = ( I - 500 )/1001.0 + RETURN +* +* End of SBEG. +* + END + REAL FUNCTION SDIFF( X, Y ) +* +* 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 .. + REAL X, Y +* .. Executable Statements .. + SDIFF = X - Y + RETURN +* +* End of SDIFF. +* + END diff --git a/cblas/testing/c_xerbla.c b/cblas/testing/c_xerbla.c new file mode 100644 index 00000000..cc5eda40 --- /dev/null +++ b/cblas/testing/c_xerbla.c @@ -0,0 +1,125 @@ +#include <stdio.h> +#include <ctype.h> +#include <stdarg.h> +#include <string.h> +#include "cblas.h" +#include "cblas_test.h" + +void cblas_xerbla(int info, const char *rout, const char *form, ...) +{ + extern int cblas_lerr, cblas_info, cblas_ok; + extern int link_xerbla; + extern int RowMajorStrg; + extern char *cblas_rout; + + /* Initially, c__3chke will call this routine with + * global variable link_xerbla=1, and F77_xerbla will set link_xerbla=0. + * This is done to fool the linker into loading these subroutines first + * instead of ones in the CBLAS or the legacy BLAS library. + */ + if (link_xerbla) return; + + if (cblas_rout != NULL && strcmp(cblas_rout, rout) != 0){ + printf("***** XERBLA WAS CALLED WITH SRNAME = <%s> INSTEAD OF <%s> *******\n", rout, cblas_rout); + cblas_ok = FALSE; + } + + if (RowMajorStrg) + { + /* To properly check leading dimension problems in cblas__gemm, we + * need to do the following trick. When cblas__gemm is called with + * CblasRowMajor, the arguments A and B switch places in the call to + * f77__gemm. Thus when we test for bad leading dimension problems + * for A and B, lda is in position 11 instead of 9, and ldb is in + * position 9 instead of 11. + */ + if (strstr(rout,"gemm") != 0) + { + if (info == 5 ) info = 4; + else if (info == 4 ) info = 5; + else if (info == 11) info = 9; + else if (info == 9 ) info = 11; + } + else if (strstr(rout,"symm") != 0 || strstr(rout,"hemm") != 0) + { + if (info == 5 ) info = 4; + else if (info == 4 ) info = 5; + } + else if (strstr(rout,"trmm") != 0 || strstr(rout,"trsm") != 0) + { + if (info == 7 ) info = 6; + else if (info == 6 ) info = 7; + } + else if (strstr(rout,"gemv") != 0) + { + if (info == 4) info = 3; + else if (info == 3) info = 4; + } + else if (strstr(rout,"gbmv") != 0) + { + if (info == 4) info = 3; + else if (info == 3) info = 4; + else if (info == 6) info = 5; + else if (info == 5) info = 6; + } + else if (strstr(rout,"ger") != 0) + { + if (info == 3) info = 2; + else if (info == 2) info = 3; + else if (info == 8) info = 6; + else if (info == 6) info = 8; + } + else if ( ( strstr(rout,"her2") != 0 || strstr(rout,"hpr2") != 0 ) + && strstr(rout,"her2k") == 0 ) + { + if (info == 8) info = 6; + else if (info == 6) info = 8; + } + } + + if (info != cblas_info){ + printf("***** XERBLA WAS CALLED WITH INFO = %d INSTEAD OF %d in %s *******\n",info, cblas_info, rout); + cblas_lerr = PASSED; + cblas_ok = FALSE; + } else cblas_lerr = FAILED; +} + +#ifdef F77_Char +void F77_xerbla(F77_Char F77_srname, void *vinfo) +#else +void F77_xerbla(char *srname, void *vinfo) +#endif +{ +#ifdef F77_Char + char *srname; +#endif + + char rout[] = {'c','b','l','a','s','_','\0','\0','\0','\0','\0','\0','\0'}; + +#ifdef F77_Integer + F77_Integer *info=vinfo; + F77_Integer i; + extern F77_Integer link_xerbla; +#else + int *info=vinfo; + int i; + extern int link_xerbla; +#endif +#ifdef F77_Char + srname = F2C_STR(F77_srname, XerblaStrLen); +#endif + + /* See the comment in cblas_xerbla() above */ + if (link_xerbla) + { + link_xerbla = 0; + return; + } + for(i=0; i < 6; i++) rout[i+6] = tolower(srname[i]); + for(i=11; i >= 9; i--) if (rout[i] == ' ') rout[i] = '\0'; + + /* We increment *info by 1 since the CBLAS interface adds one more + * argument to all level 2 and 3 routines. + */ + cblas_xerbla(*info+1,rout,""); +} diff --git a/cblas/testing/c_z2chke.c b/cblas/testing/c_z2chke.c new file mode 100644 index 00000000..09aaa68a --- /dev/null +++ b/cblas/testing/c_z2chke.c @@ -0,0 +1,826 @@ +#include <stdio.h> +#include <string.h> +#include "cblas.h" +#include "cblas_test.h" + +int cblas_ok, cblas_lerr, cblas_info; +int link_xerbla=TRUE; +char *cblas_rout; + +#ifdef F77_Char +void F77_xerbla(F77_Char F77_srname, void *vinfo); +#else +void F77_xerbla(char *srname, void *vinfo); +#endif + +void chkxer(void) { + extern int cblas_ok, cblas_lerr, cblas_info; + extern int link_xerbla; + extern char *cblas_rout; + if (cblas_lerr == 1 ) { + printf("***** ILLEGAL VALUE OF PARAMETER NUMBER %d NOT DETECTED BY %s *****\n", cblas_info, cblas_rout); + cblas_ok = 0 ; + } + cblas_lerr = 1 ; +} + +void F77_z2chke(char *rout) { + char *sf = ( rout ) ; + double A[2] = {0.0,0.0}, + X[2] = {0.0,0.0}, + Y[2] = {0.0,0.0}, + ALPHA[2] = {0.0,0.0}, + BETA[2] = {0.0,0.0}, + RALPHA = 0.0; + extern int cblas_info, cblas_lerr, cblas_ok; + extern int RowMajorStrg; + extern char *cblas_rout; + + if (link_xerbla) /* call these first to link */ + { + cblas_xerbla(cblas_info,cblas_rout,""); + F77_xerbla(cblas_rout,&cblas_info); + } + + cblas_ok = TRUE ; + cblas_lerr = PASSED ; + + if (strncmp( sf,"cblas_zgemv",11)==0) { + cblas_rout = "cblas_zgemv"; + cblas_info = 1; + cblas_zgemv(INVALID, CblasNoTrans, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_zgemv(CblasColMajor, INVALID, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_zgemv(CblasColMajor, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zgemv(CblasColMajor, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_zgemv(CblasColMajor, CblasNoTrans, 2, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_zgemv(CblasColMajor, CblasNoTrans, 0, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_zgemv(CblasColMajor, CblasNoTrans, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + + cblas_info = 2; RowMajorStrg = TRUE; RowMajorStrg = TRUE; + cblas_zgemv(CblasRowMajor, INVALID, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_zgemv(CblasRowMajor, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_zgemv(CblasRowMajor, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_zgemv(CblasRowMajor, CblasNoTrans, 0, 2, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_zgemv(CblasRowMajor, CblasNoTrans, 0, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_zgemv(CblasRowMajor, CblasNoTrans, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_zgbmv",11)==0) { + cblas_rout = "cblas_zgbmv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_zgbmv(INVALID, CblasNoTrans, 0, 0, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_zgbmv(CblasColMajor, INVALID, 0, 0, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_zgbmv(CblasColMajor, CblasNoTrans, INVALID, 0, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zgbmv(CblasColMajor, CblasNoTrans, 0, INVALID, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zgbmv(CblasColMajor, CblasNoTrans, 0, 0, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_zgbmv(CblasColMajor, CblasNoTrans, 2, 0, 0, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_zgbmv(CblasColMajor, CblasNoTrans, 0, 0, 1, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_zgbmv(CblasColMajor, CblasNoTrans, 0, 0, 0, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_zgbmv(CblasColMajor, CblasNoTrans, 0, 0, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_zgbmv(CblasRowMajor, INVALID, 0, 0, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_zgbmv(CblasRowMajor, CblasNoTrans, INVALID, 0, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_zgbmv(CblasRowMajor, CblasNoTrans, 0, INVALID, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_zgbmv(CblasRowMajor, CblasNoTrans, 0, 0, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_zgbmv(CblasRowMajor, CblasNoTrans, 2, 0, 0, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_zgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 1, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_zgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 0, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_zgbmv(CblasRowMajor, CblasNoTrans, 0, 0, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_zhemv",11)==0) { + cblas_rout = "cblas_zhemv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_zhemv(INVALID, CblasUpper, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_zhemv(CblasColMajor, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_zhemv(CblasColMajor, CblasUpper, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_zhemv(CblasColMajor, CblasUpper, 2, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zhemv(CblasColMajor, CblasUpper, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_zhemv(CblasColMajor, CblasUpper, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_zhemv(CblasRowMajor, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_zhemv(CblasRowMajor, CblasUpper, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_zhemv(CblasRowMajor, CblasUpper, 2, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zhemv(CblasRowMajor, CblasUpper, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_zhemv(CblasRowMajor, CblasUpper, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_zhbmv",11)==0) { + cblas_rout = "cblas_zhbmv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_zhbmv(INVALID, CblasUpper, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_zhbmv(CblasColMajor, INVALID, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_zhbmv(CblasColMajor, CblasUpper, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zhbmv(CblasColMajor, CblasUpper, 0, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_zhbmv(CblasColMajor, CblasUpper, 0, 1, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_zhbmv(CblasColMajor, CblasUpper, 0, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_zhbmv(CblasColMajor, CblasUpper, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_zhbmv(CblasRowMajor, INVALID, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_zhbmv(CblasRowMajor, CblasUpper, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_zhbmv(CblasRowMajor, CblasUpper, 0, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_zhbmv(CblasRowMajor, CblasUpper, 0, 1, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_zhbmv(CblasRowMajor, CblasUpper, 0, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_zhbmv(CblasRowMajor, CblasUpper, 0, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_zhpmv",11)==0) { + cblas_rout = "cblas_zhpmv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_zhpmv(INVALID, CblasUpper, 0, + ALPHA, A, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_zhpmv(CblasColMajor, INVALID, 0, + ALPHA, A, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_zhpmv(CblasColMajor, CblasUpper, INVALID, + ALPHA, A, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_zhpmv(CblasColMajor, CblasUpper, 0, + ALPHA, A, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_zhpmv(CblasColMajor, CblasUpper, 0, + ALPHA, A, X, 1, BETA, Y, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_zhpmv(CblasRowMajor, INVALID, 0, + ALPHA, A, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_zhpmv(CblasRowMajor, CblasUpper, INVALID, + ALPHA, A, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_zhpmv(CblasRowMajor, CblasUpper, 0, + ALPHA, A, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_zhpmv(CblasRowMajor, CblasUpper, 0, + ALPHA, A, X, 1, BETA, Y, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_ztrmv",11)==0) { + cblas_rout = "cblas_ztrmv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_ztrmv(INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_ztrmv(CblasColMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_ztrmv(CblasColMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ztrmv(CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_ztrmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ztrmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, A, 1, X, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_ztrmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_ztrmv(CblasRowMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_ztrmv(CblasRowMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_ztrmv(CblasRowMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_ztrmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ztrmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, A, 1, X, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_ztrmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_ztbmv",11)==0) { + cblas_rout = "cblas_ztbmv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_ztbmv(INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_ztbmv(CblasColMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_ztbmv(CblasColMajor, CblasUpper, INVALID, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ztbmv(CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_ztbmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ztbmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_ztbmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 1, A, 1, X, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ztbmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_ztbmv(CblasRowMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_ztbmv(CblasRowMajor, CblasUpper, INVALID, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_ztbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + INVALID, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_ztbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ztbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_ztbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 1, A, 1, X, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ztbmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_ztpmv",11)==0) { + cblas_rout = "cblas_ztpmv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_ztpmv(INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_ztpmv(CblasColMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_ztpmv(CblasColMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ztpmv(CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_ztpmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_ztpmv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, X, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_ztpmv(CblasRowMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_ztpmv(CblasRowMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_ztpmv(CblasRowMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_ztpmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_ztpmv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, X, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_ztrsv",11)==0) { + cblas_rout = "cblas_ztrsv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_ztrsv(INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_ztrsv(CblasColMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_ztrsv(CblasColMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ztrsv(CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_ztrsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ztrsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, A, 1, X, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_ztrsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_ztrsv(CblasRowMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_ztrsv(CblasRowMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_ztrsv(CblasRowMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_ztrsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ztrsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, A, 1, X, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_ztrsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, 1, X, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_ztbsv",11)==0) { + cblas_rout = "cblas_ztbsv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_ztbsv(INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_ztbsv(CblasColMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_ztbsv(CblasColMajor, CblasUpper, INVALID, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ztbsv(CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_ztbsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ztbsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_ztbsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 1, A, 1, X, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ztbsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_ztbsv(CblasRowMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_ztbsv(CblasRowMajor, CblasUpper, INVALID, + CblasNonUnit, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_ztbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + INVALID, 0, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_ztbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, A, 1, X, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ztbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, A, 1, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_ztbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 1, A, 1, X, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ztbsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, A, 1, X, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_ztpsv",11)==0) { + cblas_rout = "cblas_ztpsv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_ztpsv(INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_ztpsv(CblasColMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_ztpsv(CblasColMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ztpsv(CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_ztpsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_ztpsv(CblasColMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, X, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_ztpsv(CblasRowMajor, INVALID, CblasNoTrans, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_ztpsv(CblasRowMajor, CblasUpper, INVALID, + CblasNonUnit, 0, A, X, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_ztpsv(CblasRowMajor, CblasUpper, CblasNoTrans, + INVALID, 0, A, X, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_ztpsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, A, X, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_ztpsv(CblasRowMajor, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, A, X, 0 ); + chkxer(); + } else if (strncmp( sf,"cblas_zgeru",10)==0) { + cblas_rout = "cblas_zgeru"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_zgeru(INVALID, 0, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_zgeru(CblasColMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_zgeru(CblasColMajor, 0, INVALID, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_zgeru(CblasColMajor, 0, 0, ALPHA, X, 0, Y, 1, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zgeru(CblasColMajor, 0, 0, ALPHA, X, 1, Y, 0, A, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_zgeru(CblasColMajor, 2, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_zgeru(CblasRowMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_zgeru(CblasRowMajor, 0, INVALID, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_zgeru(CblasRowMajor, 0, 0, ALPHA, X, 0, Y, 1, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zgeru(CblasRowMajor, 0, 0, ALPHA, X, 1, Y, 0, A, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_zgeru(CblasRowMajor, 0, 2, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + } else if (strncmp( sf,"cblas_zgerc",10)==0) { + cblas_rout = "cblas_zgerc"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_zgerc(INVALID, 0, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_zgerc(CblasColMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_zgerc(CblasColMajor, 0, INVALID, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_zgerc(CblasColMajor, 0, 0, ALPHA, X, 0, Y, 1, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zgerc(CblasColMajor, 0, 0, ALPHA, X, 1, Y, 0, A, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_zgerc(CblasColMajor, 2, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_zgerc(CblasRowMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_zgerc(CblasRowMajor, 0, INVALID, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_zgerc(CblasRowMajor, 0, 0, ALPHA, X, 0, Y, 1, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zgerc(CblasRowMajor, 0, 0, ALPHA, X, 1, Y, 0, A, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_zgerc(CblasRowMajor, 0, 2, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + } else if (strncmp( sf,"cblas_zher2",11)==0) { + cblas_rout = "cblas_zher2"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_zher2(INVALID, CblasUpper, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_zher2(CblasColMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_zher2(CblasColMajor, CblasUpper, INVALID, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_zher2(CblasColMajor, CblasUpper, 0, ALPHA, X, 0, Y, 1, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zher2(CblasColMajor, CblasUpper, 0, ALPHA, X, 1, Y, 0, A, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_zher2(CblasColMajor, CblasUpper, 2, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_zher2(CblasRowMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_zher2(CblasRowMajor, CblasUpper, INVALID, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_zher2(CblasRowMajor, CblasUpper, 0, ALPHA, X, 0, Y, 1, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zher2(CblasRowMajor, CblasUpper, 0, ALPHA, X, 1, Y, 0, A, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_zher2(CblasRowMajor, CblasUpper, 2, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + } else if (strncmp( sf,"cblas_zhpr2",11)==0) { + cblas_rout = "cblas_zhpr2"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_zhpr2(INVALID, CblasUpper, 0, ALPHA, X, 1, Y, 1, A ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_zhpr2(CblasColMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_zhpr2(CblasColMajor, CblasUpper, INVALID, ALPHA, X, 1, Y, 1, A ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_zhpr2(CblasColMajor, CblasUpper, 0, ALPHA, X, 0, Y, 1, A ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zhpr2(CblasColMajor, CblasUpper, 0, ALPHA, X, 1, Y, 0, A ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_zhpr2(CblasRowMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_zhpr2(CblasRowMajor, CblasUpper, INVALID, ALPHA, X, 1, Y, 1, A ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_zhpr2(CblasRowMajor, CblasUpper, 0, ALPHA, X, 0, Y, 1, A ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zhpr2(CblasRowMajor, CblasUpper, 0, ALPHA, X, 1, Y, 0, A ); + chkxer(); + } else if (strncmp( sf,"cblas_zher",10)==0) { + cblas_rout = "cblas_zher"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_zher(INVALID, CblasUpper, 0, RALPHA, X, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_zher(CblasColMajor, INVALID, 0, RALPHA, X, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_zher(CblasColMajor, CblasUpper, INVALID, RALPHA, X, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_zher(CblasColMajor, CblasUpper, 0, RALPHA, X, 0, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zher(CblasColMajor, CblasUpper, 2, RALPHA, X, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_zher(CblasRowMajor, INVALID, 0, RALPHA, X, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_zher(CblasRowMajor, CblasUpper, INVALID, RALPHA, X, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_zher(CblasRowMajor, CblasUpper, 0, RALPHA, X, 0, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zher(CblasRowMajor, CblasUpper, 2, RALPHA, X, 1, A, 1 ); + chkxer(); + } else if (strncmp( sf,"cblas_zhpr",10)==0) { + cblas_rout = "cblas_zhpr"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_zhpr(INVALID, CblasUpper, 0, RALPHA, X, 1, A ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_zhpr(CblasColMajor, INVALID, 0, RALPHA, X, 1, A ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_zhpr(CblasColMajor, CblasUpper, INVALID, RALPHA, X, 1, A ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_zhpr(CblasColMajor, CblasUpper, 0, RALPHA, X, 0, A ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_zhpr(CblasColMajor, INVALID, 0, RALPHA, X, 1, A ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_zhpr(CblasColMajor, CblasUpper, INVALID, RALPHA, X, 1, A ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_zhpr(CblasColMajor, CblasUpper, 0, RALPHA, X, 0, A ); + chkxer(); + } + if (cblas_ok == TRUE) + printf(" %-12s PASSED THE TESTS OF ERROR-EXITS\n", cblas_rout); + else + printf("******* %s FAILED THE TESTS OF ERROR-EXITS *******\n",cblas_rout); +} diff --git a/cblas/testing/c_z3chke.c b/cblas/testing/c_z3chke.c new file mode 100644 index 00000000..0bb1bfb6 --- /dev/null +++ b/cblas/testing/c_z3chke.c @@ -0,0 +1,1706 @@ +#include <stdio.h> +#include <string.h> +#include "cblas.h" +#include "cblas_test.h" + +int cblas_ok, cblas_lerr, cblas_info; +int link_xerbla=TRUE; +char *cblas_rout; + +#ifdef F77_Char +void F77_xerbla(F77_Char F77_srname, void *vinfo); +#else +void F77_xerbla(char *srname, void *vinfo); +#endif + +void chkxer(void) { + extern int cblas_ok, cblas_lerr, cblas_info; + extern int link_xerbla; + extern char *cblas_rout; + if (cblas_lerr == 1 ) { + printf("***** ILLEGAL VALUE OF PARAMETER NUMBER %d NOT DETECTED BY %s *****\n", cblas_info, cblas_rout); + cblas_ok = 0 ; + } + cblas_lerr = 1 ; +} + +void F77_z3chke(char * rout) { + char *sf = ( rout ) ; + double A[4] = {0.0,0.0,0.0,0.0}, + B[4] = {0.0,0.0,0.0,0.0}, + C[4] = {0.0,0.0,0.0,0.0}, + ALPHA[2] = {0.0,0.0}, + BETA[2] = {0.0,0.0}, + RALPHA = 0.0, RBETA = 0.0; + extern int cblas_info, cblas_lerr, cblas_ok; + extern int RowMajorStrg; + extern char *cblas_rout; + + cblas_ok = TRUE ; + cblas_lerr = PASSED ; + + if (link_xerbla) /* call these first to link */ + { + cblas_xerbla(cblas_info,cblas_rout,""); + F77_xerbla(cblas_rout,&cblas_info); + } + + if (strncmp( sf,"cblas_zgemm" ,11)==0) { + cblas_rout = "cblas_zgemm" ; + + cblas_info = 1; + cblas_zgemm( INVALID, CblasNoTrans, CblasNoTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_zgemm( INVALID, CblasNoTrans, CblasTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_zgemm( INVALID, CblasTrans, CblasNoTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_zgemm( INVALID, CblasTrans, CblasTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_zgemm( CblasColMajor, INVALID, CblasNoTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_zgemm( CblasColMajor, INVALID, CblasTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_zgemm( CblasColMajor, CblasNoTrans, INVALID, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_zgemm( CblasColMajor, CblasTrans, INVALID, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zgemm( CblasColMajor, CblasNoTrans, CblasTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zgemm( CblasColMajor, CblasTrans, CblasNoTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zgemm( CblasColMajor, CblasTrans, CblasTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zgemm( CblasColMajor, CblasNoTrans, CblasTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zgemm( CblasColMajor, CblasTrans, CblasNoTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zgemm( CblasColMajor, CblasTrans, CblasTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_zgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_zgemm( CblasColMajor, CblasNoTrans, CblasTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_zgemm( CblasColMajor, CblasTrans, CblasNoTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_zgemm( CblasColMajor, CblasTrans, CblasTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_zgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 2, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_zgemm( CblasColMajor, CblasNoTrans, CblasTrans, 2, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_zgemm( CblasColMajor, CblasTrans, CblasNoTrans, 0, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_zgemm( CblasColMajor, CblasTrans, CblasTrans, 0, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_zgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 0, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_zgemm( CblasColMajor, CblasTrans, CblasNoTrans, 0, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_zgemm( CblasColMajor, CblasNoTrans, CblasTrans, 0, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_zgemm( CblasColMajor, CblasTrans, CblasTrans, 0, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_zgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 2, 0, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_zgemm( CblasColMajor, CblasNoTrans, CblasTrans, 2, 0, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_zgemm( CblasColMajor, CblasTrans, CblasNoTrans, 2, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_zgemm( CblasColMajor, CblasTrans, CblasTrans, 2, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_zgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_zgemm( CblasRowMajor, CblasNoTrans, CblasTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_zgemm( CblasRowMajor, CblasTrans, CblasNoTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_zgemm( CblasRowMajor, CblasTrans, CblasTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_zgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_zgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_zgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_zgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_zgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_zgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_zgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_zgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_zgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_zgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_zgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 2, 0, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_zgemm( CblasRowMajor, CblasTrans, CblasTrans, 2, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_zgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_zgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 0, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_zgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_zgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_zgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_zgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_zgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 0, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_zgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_zhemm" ,11)==0) { + cblas_rout = "cblas_zhemm" ; + + cblas_info = 1; + cblas_zhemm( INVALID, CblasRight, CblasLower, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_zhemm( CblasColMajor, INVALID, CblasUpper, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_zhemm( CblasColMajor, CblasLeft, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zhemm( CblasColMajor, CblasLeft, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zhemm( CblasColMajor, CblasRight, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zhemm( CblasColMajor, CblasLeft, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zhemm( CblasColMajor, CblasRight, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zhemm( CblasColMajor, CblasLeft, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zhemm( CblasColMajor, CblasRight, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zhemm( CblasColMajor, CblasLeft, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zhemm( CblasColMajor, CblasRight, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zhemm( CblasColMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zhemm( CblasColMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zhemm( CblasColMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zhemm( CblasColMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_zhemm( CblasColMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_zhemm( CblasColMajor, CblasRight, CblasUpper, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_zhemm( CblasColMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_zhemm( CblasColMajor, CblasRight, CblasLower, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_zhemm( CblasColMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_zhemm( CblasColMajor, CblasRight, CblasUpper, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_zhemm( CblasColMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_zhemm( CblasColMajor, CblasRight, CblasLower, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_zhemm( CblasRowMajor, CblasLeft, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_zhemm( CblasRowMajor, CblasRight, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_zhemm( CblasRowMajor, CblasLeft, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_zhemm( CblasRowMajor, CblasRight, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_zhemm( CblasRowMajor, CblasLeft, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_zhemm( CblasRowMajor, CblasRight, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_zhemm( CblasRowMajor, CblasLeft, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_zhemm( CblasRowMajor, CblasRight, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zhemm( CblasRowMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zhemm( CblasRowMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zhemm( CblasRowMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zhemm( CblasRowMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_zhemm( CblasRowMajor, CblasLeft, CblasUpper, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_zhemm( CblasRowMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_zhemm( CblasRowMajor, CblasLeft, CblasLower, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_zhemm( CblasRowMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_zhemm( CblasRowMajor, CblasLeft, CblasUpper, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_zhemm( CblasRowMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_zhemm( CblasRowMajor, CblasLeft, CblasLower, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_zhemm( CblasRowMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_zsymm" ,11)==0) { + cblas_rout = "cblas_zsymm" ; + + cblas_info = 1; + cblas_zsymm( INVALID, CblasRight, CblasLower, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_zsymm( CblasColMajor, INVALID, CblasUpper, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_zsymm( CblasColMajor, CblasLeft, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zsymm( CblasColMajor, CblasLeft, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zsymm( CblasColMajor, CblasRight, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zsymm( CblasColMajor, CblasLeft, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zsymm( CblasColMajor, CblasRight, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zsymm( CblasColMajor, CblasLeft, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zsymm( CblasColMajor, CblasRight, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zsymm( CblasColMajor, CblasLeft, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zsymm( CblasColMajor, CblasRight, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zsymm( CblasColMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zsymm( CblasColMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zsymm( CblasColMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zsymm( CblasColMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_zsymm( CblasColMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_zsymm( CblasColMajor, CblasRight, CblasUpper, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_zsymm( CblasColMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_zsymm( CblasColMajor, CblasRight, CblasLower, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_zsymm( CblasColMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_zsymm( CblasColMajor, CblasRight, CblasUpper, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_zsymm( CblasColMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_zsymm( CblasColMajor, CblasRight, CblasLower, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_zsymm( CblasRowMajor, CblasLeft, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_zsymm( CblasRowMajor, CblasRight, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_zsymm( CblasRowMajor, CblasLeft, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_zsymm( CblasRowMajor, CblasRight, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_zsymm( CblasRowMajor, CblasLeft, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_zsymm( CblasRowMajor, CblasRight, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_zsymm( CblasRowMajor, CblasLeft, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_zsymm( CblasRowMajor, CblasRight, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zsymm( CblasRowMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zsymm( CblasRowMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zsymm( CblasRowMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zsymm( CblasRowMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_zsymm( CblasRowMajor, CblasLeft, CblasUpper, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_zsymm( CblasRowMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_zsymm( CblasRowMajor, CblasLeft, CblasLower, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_zsymm( CblasRowMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_zsymm( CblasRowMajor, CblasLeft, CblasUpper, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_zsymm( CblasRowMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_zsymm( CblasRowMajor, CblasLeft, CblasLower, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_zsymm( CblasRowMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_ztrmm" ,11)==0) { + cblas_rout = "cblas_ztrmm" ; + + cblas_info = 1; + cblas_ztrmm( INVALID, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasLeft, INVALID, CblasNoTrans, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasLeft, CblasUpper, INVALID, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + INVALID, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ztrmm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ztrmm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_ztrsm" ,11)==0) { + cblas_rout = "cblas_ztrsm" ; + + cblas_info = 1; + cblas_ztrsm( INVALID, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, INVALID, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasLeft, INVALID, CblasNoTrans, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasLeft, CblasUpper, INVALID, + CblasNonUnit, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + INVALID, 0, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = FALSE; + cblas_ztrsm( CblasColMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, INVALID, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 7; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, INVALID, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 2, 0, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 2 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasLeft, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasLeft, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasRight, CblasUpper, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasRight, CblasUpper, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasLeft, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasLeft, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 1, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasRight, CblasLower, CblasNoTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + cblas_info = 12; RowMajorStrg = TRUE; + cblas_ztrsm( CblasRowMajor, CblasRight, CblasLower, CblasTrans, + CblasNonUnit, 0, 2, ALPHA, A, 2, B, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_zherk" ,11)==0) { + cblas_rout = "cblas_zherk" ; + + cblas_info = 1; + cblas_zherk(INVALID, CblasUpper, CblasNoTrans, 0, 0, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_zherk(CblasColMajor, INVALID, CblasNoTrans, 0, 0, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_zherk(CblasColMajor, CblasUpper, CblasTrans, 0, 0, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zherk(CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zherk(CblasColMajor, CblasUpper, CblasConjTrans, INVALID, 0, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zherk(CblasColMajor, CblasLower, CblasNoTrans, INVALID, 0, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zherk(CblasColMajor, CblasLower, CblasConjTrans, INVALID, 0, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zherk(CblasColMajor, CblasUpper, CblasNoTrans, 0, INVALID, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zherk(CblasColMajor, CblasUpper, CblasConjTrans, 0, INVALID, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zherk(CblasColMajor, CblasLower, CblasNoTrans, 0, INVALID, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zherk(CblasColMajor, CblasLower, CblasConjTrans, 0, INVALID, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zherk(CblasRowMajor, CblasUpper, CblasNoTrans, 0, 2, + RALPHA, A, 1, RBETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zherk(CblasRowMajor, CblasUpper, CblasConjTrans, 2, 0, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zherk(CblasRowMajor, CblasLower, CblasNoTrans, 0, 2, + RALPHA, A, 1, RBETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zherk(CblasRowMajor, CblasLower, CblasConjTrans, 2, 0, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zherk(CblasColMajor, CblasUpper, CblasNoTrans, 2, 0, + RALPHA, A, 1, RBETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zherk(CblasColMajor, CblasUpper, CblasConjTrans, 0, 2, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zherk(CblasColMajor, CblasLower, CblasNoTrans, 2, 0, + RALPHA, A, 1, RBETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zherk(CblasColMajor, CblasLower, CblasConjTrans, 0, 2, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_zherk(CblasRowMajor, CblasUpper, CblasNoTrans, 2, 0, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_zherk(CblasRowMajor, CblasUpper, CblasConjTrans, 2, 0, + RALPHA, A, 2, RBETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_zherk(CblasRowMajor, CblasLower, CblasNoTrans, 2, 0, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_zherk(CblasRowMajor, CblasLower, CblasConjTrans, 2, 0, + RALPHA, A, 2, RBETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_zherk(CblasColMajor, CblasUpper, CblasNoTrans, 2, 0, + RALPHA, A, 2, RBETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_zherk(CblasColMajor, CblasUpper, CblasConjTrans, 2, 0, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_zherk(CblasColMajor, CblasLower, CblasNoTrans, 2, 0, + RALPHA, A, 2, RBETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_zherk(CblasColMajor, CblasLower, CblasConjTrans, 2, 0, + RALPHA, A, 1, RBETA, C, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_zsyrk" ,11)==0) { + cblas_rout = "cblas_zsyrk" ; + + cblas_info = 1; + cblas_zsyrk(INVALID, CblasUpper, CblasNoTrans, 0, 0, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_zsyrk(CblasColMajor, INVALID, CblasNoTrans, 0, 0, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_zsyrk(CblasColMajor, CblasUpper, CblasConjTrans, 0, 0, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zsyrk(CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zsyrk(CblasColMajor, CblasUpper, CblasTrans, INVALID, 0, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zsyrk(CblasColMajor, CblasLower, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zsyrk(CblasColMajor, CblasLower, CblasTrans, INVALID, 0, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zsyrk(CblasColMajor, CblasUpper, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zsyrk(CblasColMajor, CblasUpper, CblasTrans, 0, INVALID, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zsyrk(CblasColMajor, CblasLower, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zsyrk(CblasColMajor, CblasLower, CblasTrans, 0, INVALID, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zsyrk(CblasRowMajor, CblasUpper, CblasNoTrans, 0, 2, + ALPHA, A, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zsyrk(CblasRowMajor, CblasUpper, CblasTrans, 2, 0, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zsyrk(CblasRowMajor, CblasLower, CblasNoTrans, 0, 2, + ALPHA, A, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zsyrk(CblasRowMajor, CblasLower, CblasTrans, 2, 0, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zsyrk(CblasColMajor, CblasUpper, CblasNoTrans, 2, 0, + ALPHA, A, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zsyrk(CblasColMajor, CblasUpper, CblasTrans, 0, 2, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zsyrk(CblasColMajor, CblasLower, CblasNoTrans, 2, 0, + ALPHA, A, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zsyrk(CblasColMajor, CblasLower, CblasTrans, 0, 2, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_zsyrk(CblasRowMajor, CblasUpper, CblasNoTrans, 2, 0, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_zsyrk(CblasRowMajor, CblasUpper, CblasTrans, 2, 0, + ALPHA, A, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_zsyrk(CblasRowMajor, CblasLower, CblasNoTrans, 2, 0, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_zsyrk(CblasRowMajor, CblasLower, CblasTrans, 2, 0, + ALPHA, A, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_zsyrk(CblasColMajor, CblasUpper, CblasNoTrans, 2, 0, + ALPHA, A, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_zsyrk(CblasColMajor, CblasUpper, CblasTrans, 2, 0, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_zsyrk(CblasColMajor, CblasLower, CblasNoTrans, 2, 0, + ALPHA, A, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_zsyrk(CblasColMajor, CblasLower, CblasTrans, 2, 0, + ALPHA, A, 1, BETA, C, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_zher2k" ,12)==0) { + cblas_rout = "cblas_zher2k" ; + + cblas_info = 1; + cblas_zher2k(INVALID, CblasUpper, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_zher2k(CblasColMajor, INVALID, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_zher2k(CblasColMajor, CblasUpper, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zher2k(CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zher2k(CblasColMajor, CblasUpper, CblasConjTrans, INVALID, 0, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zher2k(CblasColMajor, CblasLower, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zher2k(CblasColMajor, CblasLower, CblasConjTrans, INVALID, 0, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zher2k(CblasColMajor, CblasUpper, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zher2k(CblasColMajor, CblasUpper, CblasConjTrans, 0, INVALID, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zher2k(CblasColMajor, CblasLower, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zher2k(CblasColMajor, CblasLower, CblasConjTrans, 0, INVALID, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zher2k(CblasRowMajor, CblasUpper, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 2, RBETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zher2k(CblasRowMajor, CblasUpper, CblasConjTrans, 2, 0, + ALPHA, A, 1, B, 2, RBETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zher2k(CblasRowMajor, CblasLower, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 2, RBETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zher2k(CblasRowMajor, CblasLower, CblasConjTrans, 2, 0, + ALPHA, A, 1, B, 2, RBETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zher2k(CblasColMajor, CblasUpper, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 1, RBETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zher2k(CblasColMajor, CblasUpper, CblasConjTrans, 0, 2, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zher2k(CblasColMajor, CblasLower, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 1, RBETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zher2k(CblasColMajor, CblasLower, CblasConjTrans, 0, 2, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_zher2k(CblasRowMajor, CblasUpper, CblasNoTrans, 0, 2, + ALPHA, A, 2, B, 1, RBETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_zher2k(CblasRowMajor, CblasUpper, CblasConjTrans, 2, 0, + ALPHA, A, 2, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_zher2k(CblasRowMajor, CblasLower, CblasNoTrans, 0, 2, + ALPHA, A, 2, B, 1, RBETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_zher2k(CblasRowMajor, CblasLower, CblasConjTrans, 2, 0, + ALPHA, A, 2, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_zher2k(CblasColMajor, CblasUpper, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 1, RBETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_zher2k(CblasColMajor, CblasUpper, CblasConjTrans, 0, 2, + ALPHA, A, 2, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_zher2k(CblasColMajor, CblasLower, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 1, RBETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_zher2k(CblasColMajor, CblasLower, CblasConjTrans, 0, 2, + ALPHA, A, 2, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_zher2k(CblasRowMajor, CblasUpper, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_zher2k(CblasRowMajor, CblasUpper, CblasConjTrans, 2, 0, + ALPHA, A, 2, B, 2, RBETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_zher2k(CblasRowMajor, CblasLower, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_zher2k(CblasRowMajor, CblasLower, CblasConjTrans, 2, 0, + ALPHA, A, 2, B, 2, RBETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_zher2k(CblasColMajor, CblasUpper, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 2, RBETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_zher2k(CblasColMajor, CblasUpper, CblasConjTrans, 2, 0, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_zher2k(CblasColMajor, CblasLower, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 2, RBETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_zher2k(CblasColMajor, CblasLower, CblasConjTrans, 2, 0, + ALPHA, A, 1, B, 1, RBETA, C, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_zsyr2k" ,12)==0) { + cblas_rout = "cblas_zsyr2k" ; + + cblas_info = 1; + cblas_zsyr2k(INVALID, CblasUpper, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_zsyr2k(CblasColMajor, INVALID, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_zsyr2k(CblasColMajor, CblasUpper, CblasConjTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zsyr2k(CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zsyr2k(CblasColMajor, CblasUpper, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zsyr2k(CblasColMajor, CblasLower, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zsyr2k(CblasColMajor, CblasLower, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zsyr2k(CblasColMajor, CblasUpper, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zsyr2k(CblasColMajor, CblasUpper, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zsyr2k(CblasColMajor, CblasLower, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zsyr2k(CblasColMajor, CblasLower, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zsyr2k(CblasRowMajor, CblasUpper, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zsyr2k(CblasRowMajor, CblasUpper, CblasTrans, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zsyr2k(CblasRowMajor, CblasLower, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_zsyr2k(CblasRowMajor, CblasLower, CblasTrans, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zsyr2k(CblasColMajor, CblasUpper, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zsyr2k(CblasColMajor, CblasUpper, CblasTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zsyr2k(CblasColMajor, CblasLower, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_zsyr2k(CblasColMajor, CblasLower, CblasTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_zsyr2k(CblasRowMajor, CblasUpper, CblasNoTrans, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_zsyr2k(CblasRowMajor, CblasUpper, CblasTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_zsyr2k(CblasRowMajor, CblasLower, CblasNoTrans, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_zsyr2k(CblasRowMajor, CblasLower, CblasTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_zsyr2k(CblasColMajor, CblasUpper, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_zsyr2k(CblasColMajor, CblasUpper, CblasTrans, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_zsyr2k(CblasColMajor, CblasLower, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_zsyr2k(CblasColMajor, CblasLower, CblasTrans, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_zsyr2k(CblasRowMajor, CblasUpper, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_zsyr2k(CblasRowMajor, CblasUpper, CblasTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_zsyr2k(CblasRowMajor, CblasLower, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_zsyr2k(CblasRowMajor, CblasLower, CblasTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_zsyr2k(CblasColMajor, CblasUpper, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_zsyr2k(CblasColMajor, CblasUpper, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_zsyr2k(CblasColMajor, CblasLower, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_zsyr2k(CblasColMajor, CblasLower, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + } + + if (cblas_ok == 1 ) + printf(" %-12s PASSED THE TESTS OF ERROR-EXITS\n", cblas_rout); + else + printf("***** %s FAILED THE TESTS OF ERROR-EXITS *******\n",cblas_rout); +} diff --git a/cblas/testing/c_zblas1.c b/cblas/testing/c_zblas1.c new file mode 100644 index 00000000..d2215a89 --- /dev/null +++ b/cblas/testing/c_zblas1.c @@ -0,0 +1,74 @@ +/* + * c_zblas1.c + * + * The program is a C wrapper for zcblat1. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas_test.h" +#include "cblas.h" +void F77_zaxpy(const int *N, const void *alpha, void *X, + const int *incX, void *Y, const int *incY) +{ + cblas_zaxpy(*N, alpha, X, *incX, Y, *incY); + return; +} + +void F77_zcopy(const int *N, void *X, const int *incX, + void *Y, const int *incY) +{ + cblas_zcopy(*N, X, *incX, Y, *incY); + return; +} + +void F77_zdotc(const int *N, const void *X, const int *incX, + const void *Y, const int *incY,void *dotc) +{ + cblas_zdotc_sub(*N, X, *incX, Y, *incY, dotc); + return; +} + +void F77_zdotu(const int *N, void *X, const int *incX, + void *Y, const int *incY,void *dotu) +{ + cblas_zdotu_sub(*N, X, *incX, Y, *incY, dotu); + return; +} + +void F77_zdscal(const int *N, const double *alpha, void *X, + const int *incX) +{ + cblas_zdscal(*N, *alpha, X, *incX); + return; +} + +void F77_zscal(const int *N, const void * *alpha, void *X, + const int *incX) +{ + cblas_zscal(*N, alpha, X, *incX); + return; +} + +void F77_zswap( const int *N, void *X, const int *incX, + void *Y, const int *incY) +{ + cblas_zswap(*N,X,*incX,Y,*incY); + return; +} + +int F77_izamax(const int *N, const void *X, const int *incX) +{ + if (*N < 1 || *incX < 1) return(0); + return(cblas_izamax(*N, X, *incX)+1); +} + +double F77_dznrm2(const int *N, const void *X, const int *incX) +{ + return cblas_dznrm2(*N, X, *incX); +} + +double F77_dzasum(const int *N, void *X, const int *incX) +{ + return cblas_dzasum(*N, X, *incX); +} diff --git a/cblas/testing/c_zblas2.c b/cblas/testing/c_zblas2.c new file mode 100644 index 00000000..d4b46081 --- /dev/null +++ b/cblas/testing/c_zblas2.c @@ -0,0 +1,807 @@ +/* + * Written by D.P. Manley, Digital Equipment Corporation. + * Prefixed "C_" to BLAS routines and their declarations. + * + * Modified by T. H. Do, 4/08/98, SGI/CRAY Research. + */ +#include <stdlib.h> +#include "cblas.h" +#include "cblas_test.h" + +void F77_zgemv(int *layout, char *transp, int *m, int *n, + const void *alpha, + CBLAS_TEST_ZOMPLEX *a, int *lda, const void *x, int *incx, + const void *beta, void *y, int *incy) { + + CBLAS_TEST_ZOMPLEX *A; + int i,j,LDA; + CBLAS_TRANSPOSE trans; + + get_transpose_type(transp, &trans); + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A = (CBLAS_TEST_ZOMPLEX *)malloc( (*m)*LDA*sizeof( CBLAS_TEST_ZOMPLEX) ); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ){ + A[ LDA*i+j ].real=a[ (*lda)*j+i ].real; + A[ LDA*i+j ].imag=a[ (*lda)*j+i ].imag; + } + cblas_zgemv( CblasRowMajor, trans, *m, *n, alpha, A, LDA, x, *incx, + beta, y, *incy ); + free(A); + } + else if (*layout == TEST_COL_MJR) + cblas_zgemv( CblasColMajor, trans, + *m, *n, alpha, a, *lda, x, *incx, beta, y, *incy ); + else + cblas_zgemv( UNDEFINED, trans, + *m, *n, alpha, a, *lda, x, *incx, beta, y, *incy ); +} + +void F77_zgbmv(int *layout, char *transp, int *m, int *n, int *kl, int *ku, + CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, int *lda, + CBLAS_TEST_ZOMPLEX *x, int *incx, + CBLAS_TEST_ZOMPLEX *beta, CBLAS_TEST_ZOMPLEX *y, int *incy) { + + CBLAS_TEST_ZOMPLEX *A; + int i,j,irow,jcol,LDA; + CBLAS_TRANSPOSE trans; + + get_transpose_type(transp, &trans); + if (*layout == TEST_ROW_MJR) { + LDA = *ku+*kl+2; + A=( CBLAS_TEST_ZOMPLEX* )malloc((*n+*kl)*LDA*sizeof(CBLAS_TEST_ZOMPLEX)); + for( i=0; i<*ku; i++ ){ + irow=*ku+*kl-i; + jcol=(*ku)-i; + for( j=jcol; j<*n; j++ ){ + A[ LDA*(j-jcol)+irow ].real=a[ (*lda)*j+i ].real; + A[ LDA*(j-jcol)+irow ].imag=a[ (*lda)*j+i ].imag; + } + } + i=*ku; + irow=*ku+*kl-i; + for( j=0; j<*n; j++ ){ + A[ LDA*j+irow ].real=a[ (*lda)*j+i ].real; + A[ LDA*j+irow ].imag=a[ (*lda)*j+i ].imag; + } + for( i=*ku+1; i<*ku+*kl+1; i++ ){ + irow=*ku+*kl-i; + jcol=i-(*ku); + for( j=jcol; j<(*n+*kl); j++ ){ + A[ LDA*j+irow ].real=a[ (*lda)*(j-jcol)+i ].real; + A[ LDA*j+irow ].imag=a[ (*lda)*(j-jcol)+i ].imag; + } + } + cblas_zgbmv( CblasRowMajor, trans, *m, *n, *kl, *ku, alpha, A, LDA, x, + *incx, beta, y, *incy ); + free(A); + } + else if (*layout == TEST_COL_MJR) + cblas_zgbmv( CblasColMajor, trans, *m, *n, *kl, *ku, alpha, a, *lda, x, + *incx, beta, y, *incy ); + else + cblas_zgbmv( UNDEFINED, trans, *m, *n, *kl, *ku, alpha, a, *lda, x, + *incx, beta, y, *incy ); +} + +void F77_zgeru(int *layout, int *m, int *n, CBLAS_TEST_ZOMPLEX *alpha, + CBLAS_TEST_ZOMPLEX *x, int *incx, CBLAS_TEST_ZOMPLEX *y, int *incy, + CBLAS_TEST_ZOMPLEX *a, int *lda){ + + CBLAS_TEST_ZOMPLEX *A; + int i,j,LDA; + + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A=(CBLAS_TEST_ZOMPLEX*)malloc((*m)*LDA*sizeof(CBLAS_TEST_ZOMPLEX)); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ){ + A[ LDA*i+j ].real=a[ (*lda)*j+i ].real; + A[ LDA*i+j ].imag=a[ (*lda)*j+i ].imag; + } + cblas_zgeru( CblasRowMajor, *m, *n, alpha, x, *incx, y, *incy, A, LDA ); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ){ + a[ (*lda)*j+i ].real=A[ LDA*i+j ].real; + a[ (*lda)*j+i ].imag=A[ LDA*i+j ].imag; + } + free(A); + } + else if (*layout == TEST_COL_MJR) + cblas_zgeru( CblasColMajor, *m, *n, alpha, x, *incx, y, *incy, a, *lda ); + else + cblas_zgeru( UNDEFINED, *m, *n, alpha, x, *incx, y, *incy, a, *lda ); +} + +void F77_zgerc(int *layout, int *m, int *n, CBLAS_TEST_ZOMPLEX *alpha, + CBLAS_TEST_ZOMPLEX *x, int *incx, CBLAS_TEST_ZOMPLEX *y, int *incy, + CBLAS_TEST_ZOMPLEX *a, int *lda) { + CBLAS_TEST_ZOMPLEX *A; + int i,j,LDA; + + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A=(CBLAS_TEST_ZOMPLEX* )malloc((*m)*LDA*sizeof(CBLAS_TEST_ZOMPLEX ) ); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ){ + A[ LDA*i+j ].real=a[ (*lda)*j+i ].real; + A[ LDA*i+j ].imag=a[ (*lda)*j+i ].imag; + } + cblas_zgerc( CblasRowMajor, *m, *n, alpha, x, *incx, y, *incy, A, LDA ); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ){ + a[ (*lda)*j+i ].real=A[ LDA*i+j ].real; + a[ (*lda)*j+i ].imag=A[ LDA*i+j ].imag; + } + free(A); + } + else if (*layout == TEST_COL_MJR) + cblas_zgerc( CblasColMajor, *m, *n, alpha, x, *incx, y, *incy, a, *lda ); + else + cblas_zgerc( UNDEFINED, *m, *n, alpha, x, *incx, y, *incy, a, *lda ); +} + +void F77_zhemv(int *layout, char *uplow, int *n, CBLAS_TEST_ZOMPLEX *alpha, + CBLAS_TEST_ZOMPLEX *a, int *lda, CBLAS_TEST_ZOMPLEX *x, + int *incx, CBLAS_TEST_ZOMPLEX *beta, CBLAS_TEST_ZOMPLEX *y, int *incy){ + + CBLAS_TEST_ZOMPLEX *A; + int i,j,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A = (CBLAS_TEST_ZOMPLEX *)malloc((*n)*LDA*sizeof(CBLAS_TEST_ZOMPLEX)); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ){ + A[ LDA*i+j ].real=a[ (*lda)*j+i ].real; + A[ LDA*i+j ].imag=a[ (*lda)*j+i ].imag; + } + cblas_zhemv( CblasRowMajor, uplo, *n, alpha, A, LDA, x, *incx, + beta, y, *incy ); + free(A); + } + else if (*layout == TEST_COL_MJR) + cblas_zhemv( CblasColMajor, uplo, *n, alpha, a, *lda, x, *incx, + beta, y, *incy ); + else + cblas_zhemv( UNDEFINED, uplo, *n, alpha, a, *lda, x, *incx, + beta, y, *incy ); +} + +void F77_zhbmv(int *layout, char *uplow, int *n, int *k, + CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, int *lda, + CBLAS_TEST_ZOMPLEX *x, int *incx, CBLAS_TEST_ZOMPLEX *beta, + CBLAS_TEST_ZOMPLEX *y, int *incy){ + +CBLAS_TEST_ZOMPLEX *A; +int i,irow,j,jcol,LDA; + + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + if (uplo != CblasUpper && uplo != CblasLower ) + cblas_zhbmv(CblasRowMajor, UNDEFINED, *n, *k, alpha, a, *lda, x, + *incx, beta, y, *incy ); + else { + LDA = *k+2; + A =(CBLAS_TEST_ZOMPLEX*)malloc((*n+*k)*LDA*sizeof(CBLAS_TEST_ZOMPLEX)); + if (uplo == CblasUpper) { + for( i=0; i<*k; i++ ){ + irow=*k-i; + jcol=(*k)-i; + for( j=jcol; j<*n; j++ ) { + A[ LDA*(j-jcol)+irow ].real=a[ (*lda)*j+i ].real; + A[ LDA*(j-jcol)+irow ].imag=a[ (*lda)*j+i ].imag; + } + } + i=*k; + irow=*k-i; + for( j=0; j<*n; j++ ) { + A[ LDA*j+irow ].real=a[ (*lda)*j+i ].real; + A[ LDA*j+irow ].imag=a[ (*lda)*j+i ].imag; + } + } + else { + i=0; + irow=*k-i; + for( j=0; j<*n; j++ ) { + A[ LDA*j+irow ].real=a[ (*lda)*j+i ].real; + A[ LDA*j+irow ].imag=a[ (*lda)*j+i ].imag; + } + for( i=1; i<*k+1; i++ ){ + irow=*k-i; + jcol=i; + for( j=jcol; j<(*n+*k); j++ ) { + A[ LDA*j+irow ].real=a[ (*lda)*(j-jcol)+i ].real; + A[ LDA*j+irow ].imag=a[ (*lda)*(j-jcol)+i ].imag; + } + } + } + cblas_zhbmv( CblasRowMajor, uplo, *n, *k, alpha, A, LDA, x, *incx, + beta, y, *incy ); + free(A); + } + } + else if (*layout == TEST_COL_MJR) + cblas_zhbmv(CblasColMajor, uplo, *n, *k, alpha, a, *lda, x, *incx, + beta, y, *incy ); + else + cblas_zhbmv(UNDEFINED, uplo, *n, *k, alpha, a, *lda, x, *incx, + beta, y, *incy ); +} + +void F77_zhpmv(int *layout, char *uplow, int *n, CBLAS_TEST_ZOMPLEX *alpha, + CBLAS_TEST_ZOMPLEX *ap, CBLAS_TEST_ZOMPLEX *x, int *incx, + CBLAS_TEST_ZOMPLEX *beta, CBLAS_TEST_ZOMPLEX *y, int *incy){ + + CBLAS_TEST_ZOMPLEX *A, *AP; + int i,j,k,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + if (*layout == TEST_ROW_MJR) { + if (uplo != CblasUpper && uplo != CblasLower ) + cblas_zhpmv(CblasRowMajor, UNDEFINED, *n, alpha, ap, x, *incx, + beta, y, *incy); + else { + LDA = *n; + A = (CBLAS_TEST_ZOMPLEX* )malloc(LDA*LDA*sizeof(CBLAS_TEST_ZOMPLEX )); + AP = (CBLAS_TEST_ZOMPLEX* )malloc( (((LDA+1)*LDA)/2)* + sizeof( CBLAS_TEST_ZOMPLEX )); + if (uplo == CblasUpper) { + for( j=0, k=0; j<*n; j++ ) + for( i=0; i<j+1; i++, k++ ) { + A[ LDA*i+j ].real=ap[ k ].real; + A[ LDA*i+j ].imag=ap[ k ].imag; + } + for( i=0, k=0; i<*n; i++ ) + for( j=i; j<*n; j++, k++ ) { + AP[ k ].real=A[ LDA*i+j ].real; + AP[ k ].imag=A[ LDA*i+j ].imag; + } + } + else { + for( j=0, k=0; j<*n; j++ ) + for( i=j; i<*n; i++, k++ ) { + A[ LDA*i+j ].real=ap[ k ].real; + A[ LDA*i+j ].imag=ap[ k ].imag; + } + for( i=0, k=0; i<*n; i++ ) + for( j=0; j<i+1; j++, k++ ) { + AP[ k ].real=A[ LDA*i+j ].real; + AP[ k ].imag=A[ LDA*i+j ].imag; + } + } + cblas_zhpmv( CblasRowMajor, uplo, *n, alpha, AP, x, *incx, beta, y, + *incy ); + free(A); + free(AP); + } + } + else if (*layout == TEST_COL_MJR) + cblas_zhpmv( CblasColMajor, uplo, *n, alpha, ap, x, *incx, beta, y, + *incy ); + else + cblas_zhpmv( UNDEFINED, uplo, *n, alpha, ap, x, *incx, beta, y, + *incy ); +} + +void F77_ztbmv(int *layout, char *uplow, char *transp, char *diagn, + int *n, int *k, CBLAS_TEST_ZOMPLEX *a, int *lda, CBLAS_TEST_ZOMPLEX *x, + int *incx) { + CBLAS_TEST_ZOMPLEX *A; + int irow, jcol, i, j, LDA; + CBLAS_TRANSPOSE trans; + CBLAS_UPLO uplo; + CBLAS_DIAG diag; + + get_transpose_type(transp,&trans); + get_uplo_type(uplow,&uplo); + get_diag_type(diagn,&diag); + + if (*layout == TEST_ROW_MJR) { + if (uplo != CblasUpper && uplo != CblasLower ) + cblas_ztbmv(CblasRowMajor, UNDEFINED, trans, diag, *n, *k, a, *lda, + x, *incx); + else { + LDA = *k+2; + A=(CBLAS_TEST_ZOMPLEX *)malloc((*n+*k)*LDA*sizeof(CBLAS_TEST_ZOMPLEX)); + if (uplo == CblasUpper) { + for( i=0; i<*k; i++ ){ + irow=*k-i; + jcol=(*k)-i; + for( j=jcol; j<*n; j++ ) { + A[ LDA*(j-jcol)+irow ].real=a[ (*lda)*j+i ].real; + A[ LDA*(j-jcol)+irow ].imag=a[ (*lda)*j+i ].imag; + } + } + i=*k; + irow=*k-i; + for( j=0; j<*n; j++ ) { + A[ LDA*j+irow ].real=a[ (*lda)*j+i ].real; + A[ LDA*j+irow ].imag=a[ (*lda)*j+i ].imag; + } + } + else { + i=0; + irow=*k-i; + for( j=0; j<*n; j++ ) { + A[ LDA*j+irow ].real=a[ (*lda)*j+i ].real; + A[ LDA*j+irow ].imag=a[ (*lda)*j+i ].imag; + } + for( i=1; i<*k+1; i++ ){ + irow=*k-i; + jcol=i; + for( j=jcol; j<(*n+*k); j++ ) { + A[ LDA*j+irow ].real=a[ (*lda)*(j-jcol)+i ].real; + A[ LDA*j+irow ].imag=a[ (*lda)*(j-jcol)+i ].imag; + } + } + } + cblas_ztbmv(CblasRowMajor, uplo, trans, diag, *n, *k, A, LDA, x, + *incx); + free(A); + } + } + else if (*layout == TEST_COL_MJR) + cblas_ztbmv(CblasColMajor, uplo, trans, diag, *n, *k, a, *lda, x, *incx); + else + cblas_ztbmv(UNDEFINED, uplo, trans, diag, *n, *k, a, *lda, x, *incx); +} + +void F77_ztbsv(int *layout, char *uplow, char *transp, char *diagn, + int *n, int *k, CBLAS_TEST_ZOMPLEX *a, int *lda, CBLAS_TEST_ZOMPLEX *x, + int *incx) { + + CBLAS_TEST_ZOMPLEX *A; + int irow, jcol, i, j, LDA; + CBLAS_TRANSPOSE trans; + CBLAS_UPLO uplo; + CBLAS_DIAG diag; + + get_transpose_type(transp,&trans); + get_uplo_type(uplow,&uplo); + get_diag_type(diagn,&diag); + + if (*layout == TEST_ROW_MJR) { + if (uplo != CblasUpper && uplo != CblasLower ) + cblas_ztbsv(CblasRowMajor, UNDEFINED, trans, diag, *n, *k, a, *lda, x, + *incx); + else { + LDA = *k+2; + A=(CBLAS_TEST_ZOMPLEX*)malloc((*n+*k)*LDA*sizeof(CBLAS_TEST_ZOMPLEX )); + if (uplo == CblasUpper) { + for( i=0; i<*k; i++ ){ + irow=*k-i; + jcol=(*k)-i; + for( j=jcol; j<*n; j++ ) { + A[ LDA*(j-jcol)+irow ].real=a[ (*lda)*j+i ].real; + A[ LDA*(j-jcol)+irow ].imag=a[ (*lda)*j+i ].imag; + } + } + i=*k; + irow=*k-i; + for( j=0; j<*n; j++ ) { + A[ LDA*j+irow ].real=a[ (*lda)*j+i ].real; + A[ LDA*j+irow ].imag=a[ (*lda)*j+i ].imag; + } + } + else { + i=0; + irow=*k-i; + for( j=0; j<*n; j++ ) { + A[ LDA*j+irow ].real=a[ (*lda)*j+i ].real; + A[ LDA*j+irow ].imag=a[ (*lda)*j+i ].imag; + } + for( i=1; i<*k+1; i++ ){ + irow=*k-i; + jcol=i; + for( j=jcol; j<(*n+*k); j++ ) { + A[ LDA*j+irow ].real=a[ (*lda)*(j-jcol)+i ].real; + A[ LDA*j+irow ].imag=a[ (*lda)*(j-jcol)+i ].imag; + } + } + } + cblas_ztbsv(CblasRowMajor, uplo, trans, diag, *n, *k, A, LDA, + x, *incx); + free(A); + } + } + else if (*layout == TEST_COL_MJR) + cblas_ztbsv(CblasColMajor, uplo, trans, diag, *n, *k, a, *lda, x, *incx); + else + cblas_ztbsv(UNDEFINED, uplo, trans, diag, *n, *k, a, *lda, x, *incx); +} + +void F77_ztpmv(int *layout, char *uplow, char *transp, char *diagn, + int *n, CBLAS_TEST_ZOMPLEX *ap, CBLAS_TEST_ZOMPLEX *x, int *incx) { + CBLAS_TEST_ZOMPLEX *A, *AP; + int i, j, k, LDA; + CBLAS_TRANSPOSE trans; + CBLAS_UPLO uplo; + CBLAS_DIAG diag; + + get_transpose_type(transp,&trans); + get_uplo_type(uplow,&uplo); + get_diag_type(diagn,&diag); + + if (*layout == TEST_ROW_MJR) { + if (uplo != CblasUpper && uplo != CblasLower ) + cblas_ztpmv( CblasRowMajor, UNDEFINED, trans, diag, *n, ap, x, *incx ); + else { + LDA = *n; + A=(CBLAS_TEST_ZOMPLEX*)malloc(LDA*LDA*sizeof(CBLAS_TEST_ZOMPLEX)); + AP=(CBLAS_TEST_ZOMPLEX*)malloc((((LDA+1)*LDA)/2)* + sizeof(CBLAS_TEST_ZOMPLEX)); + if (uplo == CblasUpper) { + for( j=0, k=0; j<*n; j++ ) + for( i=0; i<j+1; i++, k++ ) { + A[ LDA*i+j ].real=ap[ k ].real; + A[ LDA*i+j ].imag=ap[ k ].imag; + } + for( i=0, k=0; i<*n; i++ ) + for( j=i; j<*n; j++, k++ ) { + AP[ k ].real=A[ LDA*i+j ].real; + AP[ k ].imag=A[ LDA*i+j ].imag; + } + } + else { + for( j=0, k=0; j<*n; j++ ) + for( i=j; i<*n; i++, k++ ) { + A[ LDA*i+j ].real=ap[ k ].real; + A[ LDA*i+j ].imag=ap[ k ].imag; + } + for( i=0, k=0; i<*n; i++ ) + for( j=0; j<i+1; j++, k++ ) { + AP[ k ].real=A[ LDA*i+j ].real; + AP[ k ].imag=A[ LDA*i+j ].imag; + } + } + cblas_ztpmv( CblasRowMajor, uplo, trans, diag, *n, AP, x, *incx ); + free(A); + free(AP); + } + } + else if (*layout == TEST_COL_MJR) + cblas_ztpmv( CblasColMajor, uplo, trans, diag, *n, ap, x, *incx ); + else + cblas_ztpmv( UNDEFINED, uplo, trans, diag, *n, ap, x, *incx ); +} + +void F77_ztpsv(int *layout, char *uplow, char *transp, char *diagn, + int *n, CBLAS_TEST_ZOMPLEX *ap, CBLAS_TEST_ZOMPLEX *x, int *incx) { + CBLAS_TEST_ZOMPLEX *A, *AP; + int i, j, k, LDA; + CBLAS_TRANSPOSE trans; + CBLAS_UPLO uplo; + CBLAS_DIAG diag; + + get_transpose_type(transp,&trans); + get_uplo_type(uplow,&uplo); + get_diag_type(diagn,&diag); + + if (*layout == TEST_ROW_MJR) { + if (uplo != CblasUpper && uplo != CblasLower ) + cblas_ztpsv( CblasRowMajor, UNDEFINED, trans, diag, *n, ap, x, *incx ); + else { + LDA = *n; + A=(CBLAS_TEST_ZOMPLEX*)malloc(LDA*LDA*sizeof(CBLAS_TEST_ZOMPLEX)); + AP=(CBLAS_TEST_ZOMPLEX*)malloc((((LDA+1)*LDA)/2)* + sizeof(CBLAS_TEST_ZOMPLEX)); + if (uplo == CblasUpper) { + for( j=0, k=0; j<*n; j++ ) + for( i=0; i<j+1; i++, k++ ) { + A[ LDA*i+j ].real=ap[ k ].real; + A[ LDA*i+j ].imag=ap[ k ].imag; + } + for( i=0, k=0; i<*n; i++ ) + for( j=i; j<*n; j++, k++ ) { + AP[ k ].real=A[ LDA*i+j ].real; + AP[ k ].imag=A[ LDA*i+j ].imag; + } + } + else { + for( j=0, k=0; j<*n; j++ ) + for( i=j; i<*n; i++, k++ ) { + A[ LDA*i+j ].real=ap[ k ].real; + A[ LDA*i+j ].imag=ap[ k ].imag; + } + for( i=0, k=0; i<*n; i++ ) + for( j=0; j<i+1; j++, k++ ) { + AP[ k ].real=A[ LDA*i+j ].real; + AP[ k ].imag=A[ LDA*i+j ].imag; + } + } + cblas_ztpsv( CblasRowMajor, uplo, trans, diag, *n, AP, x, *incx ); + free(A); + free(AP); + } + } + else if (*layout == TEST_COL_MJR) + cblas_ztpsv( CblasColMajor, uplo, trans, diag, *n, ap, x, *incx ); + else + cblas_ztpsv( UNDEFINED, uplo, trans, diag, *n, ap, x, *incx ); +} + +void F77_ztrmv(int *layout, char *uplow, char *transp, char *diagn, + int *n, CBLAS_TEST_ZOMPLEX *a, int *lda, CBLAS_TEST_ZOMPLEX *x, + int *incx) { + CBLAS_TEST_ZOMPLEX *A; + int i,j,LDA; + CBLAS_TRANSPOSE trans; + CBLAS_UPLO uplo; + CBLAS_DIAG diag; + + get_transpose_type(transp,&trans); + get_uplo_type(uplow,&uplo); + get_diag_type(diagn,&diag); + + if (*layout == TEST_ROW_MJR) { + LDA=*n+1; + A=(CBLAS_TEST_ZOMPLEX*)malloc((*n)*LDA*sizeof(CBLAS_TEST_ZOMPLEX)); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) { + A[ LDA*i+j ].real=a[ (*lda)*j+i ].real; + A[ LDA*i+j ].imag=a[ (*lda)*j+i ].imag; + } + cblas_ztrmv(CblasRowMajor, uplo, trans, diag, *n, A, LDA, x, *incx); + free(A); + } + else if (*layout == TEST_COL_MJR) + cblas_ztrmv(CblasColMajor, uplo, trans, diag, *n, a, *lda, x, *incx); + else + cblas_ztrmv(UNDEFINED, uplo, trans, diag, *n, a, *lda, x, *incx); +} +void F77_ztrsv(int *layout, char *uplow, char *transp, char *diagn, + int *n, CBLAS_TEST_ZOMPLEX *a, int *lda, CBLAS_TEST_ZOMPLEX *x, + int *incx) { + CBLAS_TEST_ZOMPLEX *A; + int i,j,LDA; + CBLAS_TRANSPOSE trans; + CBLAS_UPLO uplo; + CBLAS_DIAG diag; + + get_transpose_type(transp,&trans); + get_uplo_type(uplow,&uplo); + get_diag_type(diagn,&diag); + + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A =(CBLAS_TEST_ZOMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_ZOMPLEX ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) { + A[ LDA*i+j ].real=a[ (*lda)*j+i ].real; + A[ LDA*i+j ].imag=a[ (*lda)*j+i ].imag; + } + cblas_ztrsv(CblasRowMajor, uplo, trans, diag, *n, A, LDA, x, *incx ); + free(A); + } + else if (*layout == TEST_COL_MJR) + cblas_ztrsv(CblasColMajor, uplo, trans, diag, *n, a, *lda, x, *incx ); + else + cblas_ztrsv(UNDEFINED, uplo, trans, diag, *n, a, *lda, x, *incx ); +} + +void F77_zhpr(int *layout, char *uplow, int *n, double *alpha, + CBLAS_TEST_ZOMPLEX *x, int *incx, CBLAS_TEST_ZOMPLEX *ap) { + CBLAS_TEST_ZOMPLEX *A, *AP; + int i,j,k,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + if (uplo != CblasUpper && uplo != CblasLower ) + cblas_zhpr(CblasRowMajor, UNDEFINED, *n, *alpha, x, *incx, ap ); + else { + LDA = *n; + A = (CBLAS_TEST_ZOMPLEX* )malloc(LDA*LDA*sizeof(CBLAS_TEST_ZOMPLEX ) ); + AP = ( CBLAS_TEST_ZOMPLEX* )malloc( (((LDA+1)*LDA)/2)* + sizeof( CBLAS_TEST_ZOMPLEX )); + if (uplo == CblasUpper) { + for( j=0, k=0; j<*n; j++ ) + for( i=0; i<j+1; i++, k++ ){ + A[ LDA*i+j ].real=ap[ k ].real; + A[ LDA*i+j ].imag=ap[ k ].imag; + } + for( i=0, k=0; i<*n; i++ ) + for( j=i; j<*n; j++, k++ ){ + AP[ k ].real=A[ LDA*i+j ].real; + AP[ k ].imag=A[ LDA*i+j ].imag; + } + } + else { + for( j=0, k=0; j<*n; j++ ) + for( i=j; i<*n; i++, k++ ){ + A[ LDA*i+j ].real=ap[ k ].real; + A[ LDA*i+j ].imag=ap[ k ].imag; + } + for( i=0, k=0; i<*n; i++ ) + for( j=0; j<i+1; j++, k++ ){ + AP[ k ].real=A[ LDA*i+j ].real; + AP[ k ].imag=A[ LDA*i+j ].imag; + } + } + cblas_zhpr(CblasRowMajor, uplo, *n, *alpha, x, *incx, AP ); + if (uplo == CblasUpper) { + for( i=0, k=0; i<*n; i++ ) + for( j=i; j<*n; j++, k++ ){ + A[ LDA*i+j ].real=AP[ k ].real; + A[ LDA*i+j ].imag=AP[ k ].imag; + } + for( j=0, k=0; j<*n; j++ ) + for( i=0; i<j+1; i++, k++ ){ + ap[ k ].real=A[ LDA*i+j ].real; + ap[ k ].imag=A[ LDA*i+j ].imag; + } + } + else { + for( i=0, k=0; i<*n; i++ ) + for( j=0; j<i+1; j++, k++ ){ + A[ LDA*i+j ].real=AP[ k ].real; + A[ LDA*i+j ].imag=AP[ k ].imag; + } + for( j=0, k=0; j<*n; j++ ) + for( i=j; i<*n; i++, k++ ){ + ap[ k ].real=A[ LDA*i+j ].real; + ap[ k ].imag=A[ LDA*i+j ].imag; + } + } + free(A); + free(AP); + } + } + else if (*layout == TEST_COL_MJR) + cblas_zhpr(CblasColMajor, uplo, *n, *alpha, x, *incx, ap ); + else + cblas_zhpr(UNDEFINED, uplo, *n, *alpha, x, *incx, ap ); +} + +void F77_zhpr2(int *layout, char *uplow, int *n, CBLAS_TEST_ZOMPLEX *alpha, + CBLAS_TEST_ZOMPLEX *x, int *incx, CBLAS_TEST_ZOMPLEX *y, int *incy, + CBLAS_TEST_ZOMPLEX *ap) { + CBLAS_TEST_ZOMPLEX *A, *AP; + int i,j,k,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + if (uplo != CblasUpper && uplo != CblasLower ) + cblas_zhpr2( CblasRowMajor, UNDEFINED, *n, alpha, x, *incx, y, + *incy, ap ); + else { + LDA = *n; + A=(CBLAS_TEST_ZOMPLEX*)malloc( LDA*LDA*sizeof(CBLAS_TEST_ZOMPLEX ) ); + AP=(CBLAS_TEST_ZOMPLEX*)malloc( (((LDA+1)*LDA)/2)* + sizeof( CBLAS_TEST_ZOMPLEX )); + if (uplo == CblasUpper) { + for( j=0, k=0; j<*n; j++ ) + for( i=0; i<j+1; i++, k++ ) { + A[ LDA*i+j ].real=ap[ k ].real; + A[ LDA*i+j ].imag=ap[ k ].imag; + } + for( i=0, k=0; i<*n; i++ ) + for( j=i; j<*n; j++, k++ ) { + AP[ k ].real=A[ LDA*i+j ].real; + AP[ k ].imag=A[ LDA*i+j ].imag; + } + } + else { + for( j=0, k=0; j<*n; j++ ) + for( i=j; i<*n; i++, k++ ) { + A[ LDA*i+j ].real=ap[ k ].real; + A[ LDA*i+j ].imag=ap[ k ].imag; + } + for( i=0, k=0; i<*n; i++ ) + for( j=0; j<i+1; j++, k++ ) { + AP[ k ].real=A[ LDA*i+j ].real; + AP[ k ].imag=A[ LDA*i+j ].imag; + } + } + cblas_zhpr2( CblasRowMajor, uplo, *n, alpha, x, *incx, y, *incy, AP ); + if (uplo == CblasUpper) { + for( i=0, k=0; i<*n; i++ ) + for( j=i; j<*n; j++, k++ ) { + A[ LDA*i+j ].real=AP[ k ].real; + A[ LDA*i+j ].imag=AP[ k ].imag; + } + for( j=0, k=0; j<*n; j++ ) + for( i=0; i<j+1; i++, k++ ) { + ap[ k ].real=A[ LDA*i+j ].real; + ap[ k ].imag=A[ LDA*i+j ].imag; + } + } + else { + for( i=0, k=0; i<*n; i++ ) + for( j=0; j<i+1; j++, k++ ) { + A[ LDA*i+j ].real=AP[ k ].real; + A[ LDA*i+j ].imag=AP[ k ].imag; + } + for( j=0, k=0; j<*n; j++ ) + for( i=j; i<*n; i++, k++ ) { + ap[ k ].real=A[ LDA*i+j ].real; + ap[ k ].imag=A[ LDA*i+j ].imag; + } + } + free(A); + free(AP); + } + } + else if (*layout == TEST_COL_MJR) + cblas_zhpr2( CblasColMajor, uplo, *n, alpha, x, *incx, y, *incy, ap ); + else + cblas_zhpr2( UNDEFINED, uplo, *n, alpha, x, *incx, y, *incy, ap ); +} + +void F77_zher(int *layout, char *uplow, int *n, double *alpha, + CBLAS_TEST_ZOMPLEX *x, int *incx, CBLAS_TEST_ZOMPLEX *a, int *lda) { + CBLAS_TEST_ZOMPLEX *A; + int i,j,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A=(CBLAS_TEST_ZOMPLEX*)malloc((*n)*LDA*sizeof( CBLAS_TEST_ZOMPLEX )); + + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) { + A[ LDA*i+j ].real=a[ (*lda)*j+i ].real; + A[ LDA*i+j ].imag=a[ (*lda)*j+i ].imag; + } + + cblas_zher(CblasRowMajor, uplo, *n, *alpha, x, *incx, A, LDA ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) { + a[ (*lda)*j+i ].real=A[ LDA*i+j ].real; + a[ (*lda)*j+i ].imag=A[ LDA*i+j ].imag; + } + free(A); + } + else if (*layout == TEST_COL_MJR) + cblas_zher( CblasColMajor, uplo, *n, *alpha, x, *incx, a, *lda ); + else + cblas_zher( UNDEFINED, uplo, *n, *alpha, x, *incx, a, *lda ); +} + +void F77_zher2(int *layout, char *uplow, int *n, CBLAS_TEST_ZOMPLEX *alpha, + CBLAS_TEST_ZOMPLEX *x, int *incx, CBLAS_TEST_ZOMPLEX *y, int *incy, + CBLAS_TEST_ZOMPLEX *a, int *lda) { + + CBLAS_TEST_ZOMPLEX *A; + int i,j,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A= ( CBLAS_TEST_ZOMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_ZOMPLEX ) ); + + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) { + A[ LDA*i+j ].real=a[ (*lda)*j+i ].real; + A[ LDA*i+j ].imag=a[ (*lda)*j+i ].imag; + } + + cblas_zher2(CblasRowMajor, uplo, *n, alpha, x, *incx, y, *incy, A, LDA ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) { + a[ (*lda)*j+i ].real=A[ LDA*i+j ].real; + a[ (*lda)*j+i ].imag=A[ LDA*i+j ].imag; + } + free(A); + } + else if (*layout == TEST_COL_MJR) + cblas_zher2( CblasColMajor, uplo, *n, alpha, x, *incx, y, *incy, a, *lda); + else + cblas_zher2( UNDEFINED, uplo, *n, alpha, x, *incx, y, *incy, a, *lda); +} diff --git a/cblas/testing/c_zblas3.c b/cblas/testing/c_zblas3.c new file mode 100644 index 00000000..de4cb56d --- /dev/null +++ b/cblas/testing/c_zblas3.c @@ -0,0 +1,564 @@ +/* + * Written by D.P. Manley, Digital Equipment Corporation. + * Prefixed "C_" to BLAS routines and their declarations. + * + * Modified by T. H. Do, 4/15/98, SGI/CRAY Research. + */ +#include <stdlib.h> +#include "cblas.h" +#include "cblas_test.h" +#define TEST_COL_MJR 0 +#define TEST_ROW_MJR 1 +#define UNDEFINED -1 + +void F77_zgemm(int *layout, char *transpa, char *transpb, int *m, int *n, + int *k, CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, int *lda, + CBLAS_TEST_ZOMPLEX *b, int *ldb, CBLAS_TEST_ZOMPLEX *beta, + CBLAS_TEST_ZOMPLEX *c, int *ldc ) { + + CBLAS_TEST_ZOMPLEX *A, *B, *C; + int i,j,LDA, LDB, LDC; + CBLAS_TRANSPOSE transa, transb; + + get_transpose_type(transpa, &transa); + get_transpose_type(transpb, &transb); + + if (*layout == TEST_ROW_MJR) { + if (transa == CblasNoTrans) { + LDA = *k+1; + A=(CBLAS_TEST_ZOMPLEX*)malloc((*m)*LDA*sizeof(CBLAS_TEST_ZOMPLEX)); + for( i=0; i<*m; i++ ) + for( j=0; j<*k; j++ ) { + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + } + } + else { + LDA = *m+1; + A=(CBLAS_TEST_ZOMPLEX* )malloc(LDA*(*k)*sizeof(CBLAS_TEST_ZOMPLEX)); + for( i=0; i<*k; i++ ) + for( j=0; j<*m; j++ ) { + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + } + } + + if (transb == CblasNoTrans) { + LDB = *n+1; + B=(CBLAS_TEST_ZOMPLEX* )malloc((*k)*LDB*sizeof(CBLAS_TEST_ZOMPLEX) ); + for( i=0; i<*k; i++ ) + for( j=0; j<*n; j++ ) { + B[i*LDB+j].real=b[j*(*ldb)+i].real; + B[i*LDB+j].imag=b[j*(*ldb)+i].imag; + } + } + else { + LDB = *k+1; + B=(CBLAS_TEST_ZOMPLEX* )malloc(LDB*(*n)*sizeof(CBLAS_TEST_ZOMPLEX)); + for( i=0; i<*n; i++ ) + for( j=0; j<*k; j++ ) { + B[i*LDB+j].real=b[j*(*ldb)+i].real; + B[i*LDB+j].imag=b[j*(*ldb)+i].imag; + } + } + + LDC = *n+1; + C=(CBLAS_TEST_ZOMPLEX* )malloc((*m)*LDC*sizeof(CBLAS_TEST_ZOMPLEX)); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) { + C[i*LDC+j].real=c[j*(*ldc)+i].real; + C[i*LDC+j].imag=c[j*(*ldc)+i].imag; + } + cblas_zgemm( CblasRowMajor, transa, transb, *m, *n, *k, alpha, A, LDA, + B, LDB, beta, C, LDC ); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) { + c[j*(*ldc)+i].real=C[i*LDC+j].real; + c[j*(*ldc)+i].imag=C[i*LDC+j].imag; + } + free(A); + free(B); + free(C); + } + else if (*layout == TEST_COL_MJR) + cblas_zgemm( CblasColMajor, transa, transb, *m, *n, *k, alpha, a, *lda, + b, *ldb, beta, c, *ldc ); + else + cblas_zgemm( UNDEFINED, transa, transb, *m, *n, *k, alpha, a, *lda, + b, *ldb, beta, c, *ldc ); +} +void F77_zhemm(int *layout, char *rtlf, char *uplow, int *m, int *n, + CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, int *lda, + CBLAS_TEST_ZOMPLEX *b, int *ldb, CBLAS_TEST_ZOMPLEX *beta, + CBLAS_TEST_ZOMPLEX *c, int *ldc ) { + + CBLAS_TEST_ZOMPLEX *A, *B, *C; + int i,j,LDA, LDB, LDC; + CBLAS_UPLO uplo; + CBLAS_SIDE side; + + get_uplo_type(uplow,&uplo); + get_side_type(rtlf,&side); + + if (*layout == TEST_ROW_MJR) { + if (side == CblasLeft) { + LDA = *m+1; + A= (CBLAS_TEST_ZOMPLEX* )malloc((*m)*LDA*sizeof(CBLAS_TEST_ZOMPLEX)); + for( i=0; i<*m; i++ ) + for( j=0; j<*m; j++ ) { + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + } + } + else{ + LDA = *n+1; + A=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_ZOMPLEX ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) { + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + } + } + LDB = *n+1; + B=(CBLAS_TEST_ZOMPLEX* )malloc( (*m)*LDB*sizeof(CBLAS_TEST_ZOMPLEX ) ); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ) { + B[i*LDB+j].real=b[j*(*ldb)+i].real; + B[i*LDB+j].imag=b[j*(*ldb)+i].imag; + } + LDC = *n+1; + C=(CBLAS_TEST_ZOMPLEX* )malloc((*m)*LDC*sizeof(CBLAS_TEST_ZOMPLEX ) ); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) { + C[i*LDC+j].real=c[j*(*ldc)+i].real; + C[i*LDC+j].imag=c[j*(*ldc)+i].imag; + } + cblas_zhemm( CblasRowMajor, side, uplo, *m, *n, alpha, A, LDA, B, LDB, + beta, C, LDC ); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) { + c[j*(*ldc)+i].real=C[i*LDC+j].real; + c[j*(*ldc)+i].imag=C[i*LDC+j].imag; + } + free(A); + free(B); + free(C); + } + else if (*layout == TEST_COL_MJR) + cblas_zhemm( CblasColMajor, side, uplo, *m, *n, alpha, a, *lda, b, *ldb, + beta, c, *ldc ); + else + cblas_zhemm( UNDEFINED, side, uplo, *m, *n, alpha, a, *lda, b, *ldb, + beta, c, *ldc ); +} +void F77_zsymm(int *layout, char *rtlf, char *uplow, int *m, int *n, + CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, int *lda, + CBLAS_TEST_ZOMPLEX *b, int *ldb, CBLAS_TEST_ZOMPLEX *beta, + CBLAS_TEST_ZOMPLEX *c, int *ldc ) { + + CBLAS_TEST_ZOMPLEX *A, *B, *C; + int i,j,LDA, LDB, LDC; + CBLAS_UPLO uplo; + CBLAS_SIDE side; + + get_uplo_type(uplow,&uplo); + get_side_type(rtlf,&side); + + if (*layout == TEST_ROW_MJR) { + if (side == CblasLeft) { + LDA = *m+1; + A=(CBLAS_TEST_ZOMPLEX* )malloc((*m)*LDA*sizeof(CBLAS_TEST_ZOMPLEX)); + for( i=0; i<*m; i++ ) + for( j=0; j<*m; j++ ) + A[i*LDA+j]=a[j*(*lda)+i]; + } + else{ + LDA = *n+1; + A=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_ZOMPLEX ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + A[i*LDA+j]=a[j*(*lda)+i]; + } + LDB = *n+1; + B=(CBLAS_TEST_ZOMPLEX* )malloc((*m)*LDB*sizeof(CBLAS_TEST_ZOMPLEX )); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ) + B[i*LDB+j]=b[j*(*ldb)+i]; + LDC = *n+1; + C=(CBLAS_TEST_ZOMPLEX* )malloc((*m)*LDC*sizeof(CBLAS_TEST_ZOMPLEX)); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) + C[i*LDC+j]=c[j*(*ldc)+i]; + cblas_zsymm( CblasRowMajor, side, uplo, *m, *n, alpha, A, LDA, B, LDB, + beta, C, LDC ); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) + c[j*(*ldc)+i]=C[i*LDC+j]; + free(A); + free(B); + free(C); + } + else if (*layout == TEST_COL_MJR) + cblas_zsymm( CblasColMajor, side, uplo, *m, *n, alpha, a, *lda, b, *ldb, + beta, c, *ldc ); + else + cblas_zsymm( UNDEFINED, side, uplo, *m, *n, alpha, a, *lda, b, *ldb, + beta, c, *ldc ); +} + +void F77_zherk(int *layout, char *uplow, char *transp, int *n, int *k, + double *alpha, CBLAS_TEST_ZOMPLEX *a, int *lda, + double *beta, CBLAS_TEST_ZOMPLEX *c, int *ldc ) { + + int i,j,LDA,LDC; + CBLAS_TEST_ZOMPLEX *A, *C; + CBLAS_UPLO uplo; + CBLAS_TRANSPOSE trans; + + get_uplo_type(uplow,&uplo); + get_transpose_type(transp,&trans); + + if (*layout == TEST_ROW_MJR) { + if (trans == CblasNoTrans) { + LDA = *k+1; + A=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_ZOMPLEX ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*k; j++ ) { + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + } + } + else{ + LDA = *n+1; + A=(CBLAS_TEST_ZOMPLEX* )malloc((*k)*LDA*sizeof(CBLAS_TEST_ZOMPLEX ) ); + for( i=0; i<*k; i++ ) + for( j=0; j<*n; j++ ) { + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + } + } + LDC = *n+1; + C=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*LDC*sizeof(CBLAS_TEST_ZOMPLEX ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) { + C[i*LDC+j].real=c[j*(*ldc)+i].real; + C[i*LDC+j].imag=c[j*(*ldc)+i].imag; + } + cblas_zherk(CblasRowMajor, uplo, trans, *n, *k, *alpha, A, LDA, *beta, + C, LDC ); + for( j=0; j<*n; j++ ) + for( i=0; i<*n; i++ ) { + c[j*(*ldc)+i].real=C[i*LDC+j].real; + c[j*(*ldc)+i].imag=C[i*LDC+j].imag; + } + free(A); + free(C); + } + else if (*layout == TEST_COL_MJR) + cblas_zherk(CblasColMajor, uplo, trans, *n, *k, *alpha, a, *lda, *beta, + c, *ldc ); + else + cblas_zherk(UNDEFINED, uplo, trans, *n, *k, *alpha, a, *lda, *beta, + c, *ldc ); +} + +void F77_zsyrk(int *layout, char *uplow, char *transp, int *n, int *k, + CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, int *lda, + CBLAS_TEST_ZOMPLEX *beta, CBLAS_TEST_ZOMPLEX *c, int *ldc ) { + + int i,j,LDA,LDC; + CBLAS_TEST_ZOMPLEX *A, *C; + CBLAS_UPLO uplo; + CBLAS_TRANSPOSE trans; + + get_uplo_type(uplow,&uplo); + get_transpose_type(transp,&trans); + + if (*layout == TEST_ROW_MJR) { + if (trans == CblasNoTrans) { + LDA = *k+1; + A=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_ZOMPLEX)); + for( i=0; i<*n; i++ ) + for( j=0; j<*k; j++ ) { + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + } + } + else{ + LDA = *n+1; + A=(CBLAS_TEST_ZOMPLEX* )malloc((*k)*LDA*sizeof(CBLAS_TEST_ZOMPLEX ) ); + for( i=0; i<*k; i++ ) + for( j=0; j<*n; j++ ) { + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + } + } + LDC = *n+1; + C=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*LDC*sizeof(CBLAS_TEST_ZOMPLEX ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) { + C[i*LDC+j].real=c[j*(*ldc)+i].real; + C[i*LDC+j].imag=c[j*(*ldc)+i].imag; + } + cblas_zsyrk(CblasRowMajor, uplo, trans, *n, *k, alpha, A, LDA, beta, + C, LDC ); + for( j=0; j<*n; j++ ) + for( i=0; i<*n; i++ ) { + c[j*(*ldc)+i].real=C[i*LDC+j].real; + c[j*(*ldc)+i].imag=C[i*LDC+j].imag; + } + free(A); + free(C); + } + else if (*layout == TEST_COL_MJR) + cblas_zsyrk(CblasColMajor, uplo, trans, *n, *k, alpha, a, *lda, beta, + c, *ldc ); + else + cblas_zsyrk(UNDEFINED, uplo, trans, *n, *k, alpha, a, *lda, beta, + c, *ldc ); +} +void F77_zher2k(int *layout, char *uplow, char *transp, int *n, int *k, + CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, int *lda, + CBLAS_TEST_ZOMPLEX *b, int *ldb, double *beta, + CBLAS_TEST_ZOMPLEX *c, int *ldc ) { + int i,j,LDA,LDB,LDC; + CBLAS_TEST_ZOMPLEX *A, *B, *C; + CBLAS_UPLO uplo; + CBLAS_TRANSPOSE trans; + + get_uplo_type(uplow,&uplo); + get_transpose_type(transp,&trans); + + if (*layout == TEST_ROW_MJR) { + if (trans == CblasNoTrans) { + LDA = *k+1; + LDB = *k+1; + A=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_ZOMPLEX )); + B=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*LDB*sizeof(CBLAS_TEST_ZOMPLEX )); + for( i=0; i<*n; i++ ) + for( j=0; j<*k; j++ ) { + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + B[i*LDB+j].real=b[j*(*ldb)+i].real; + B[i*LDB+j].imag=b[j*(*ldb)+i].imag; + } + } + else { + LDA = *n+1; + LDB = *n+1; + A=(CBLAS_TEST_ZOMPLEX* )malloc( LDA*(*k)*sizeof(CBLAS_TEST_ZOMPLEX ) ); + B=(CBLAS_TEST_ZOMPLEX* )malloc( LDB*(*k)*sizeof(CBLAS_TEST_ZOMPLEX ) ); + for( i=0; i<*k; i++ ) + for( j=0; j<*n; j++ ){ + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + B[i*LDB+j].real=b[j*(*ldb)+i].real; + B[i*LDB+j].imag=b[j*(*ldb)+i].imag; + } + } + LDC = *n+1; + C=(CBLAS_TEST_ZOMPLEX* )malloc( (*n)*LDC*sizeof(CBLAS_TEST_ZOMPLEX ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) { + C[i*LDC+j].real=c[j*(*ldc)+i].real; + C[i*LDC+j].imag=c[j*(*ldc)+i].imag; + } + cblas_zher2k(CblasRowMajor, uplo, trans, *n, *k, alpha, A, LDA, + B, LDB, *beta, C, LDC ); + for( j=0; j<*n; j++ ) + for( i=0; i<*n; i++ ) { + c[j*(*ldc)+i].real=C[i*LDC+j].real; + c[j*(*ldc)+i].imag=C[i*LDC+j].imag; + } + free(A); + free(B); + free(C); + } + else if (*layout == TEST_COL_MJR) + cblas_zher2k(CblasColMajor, uplo, trans, *n, *k, alpha, a, *lda, + b, *ldb, *beta, c, *ldc ); + else + cblas_zher2k(UNDEFINED, uplo, trans, *n, *k, alpha, a, *lda, + b, *ldb, *beta, c, *ldc ); +} +void F77_zsyr2k(int *layout, char *uplow, char *transp, int *n, int *k, + CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, int *lda, + CBLAS_TEST_ZOMPLEX *b, int *ldb, CBLAS_TEST_ZOMPLEX *beta, + CBLAS_TEST_ZOMPLEX *c, int *ldc ) { + int i,j,LDA,LDB,LDC; + CBLAS_TEST_ZOMPLEX *A, *B, *C; + CBLAS_UPLO uplo; + CBLAS_TRANSPOSE trans; + + get_uplo_type(uplow,&uplo); + get_transpose_type(transp,&trans); + + if (*layout == TEST_ROW_MJR) { + if (trans == CblasNoTrans) { + LDA = *k+1; + LDB = *k+1; + A=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_ZOMPLEX)); + B=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*LDB*sizeof(CBLAS_TEST_ZOMPLEX)); + for( i=0; i<*n; i++ ) + for( j=0; j<*k; j++ ) { + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + B[i*LDB+j].real=b[j*(*ldb)+i].real; + B[i*LDB+j].imag=b[j*(*ldb)+i].imag; + } + } + else { + LDA = *n+1; + LDB = *n+1; + A=(CBLAS_TEST_ZOMPLEX* )malloc(LDA*(*k)*sizeof(CBLAS_TEST_ZOMPLEX)); + B=(CBLAS_TEST_ZOMPLEX* )malloc(LDB*(*k)*sizeof(CBLAS_TEST_ZOMPLEX)); + for( i=0; i<*k; i++ ) + for( j=0; j<*n; j++ ){ + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + B[i*LDB+j].real=b[j*(*ldb)+i].real; + B[i*LDB+j].imag=b[j*(*ldb)+i].imag; + } + } + LDC = *n+1; + C=(CBLAS_TEST_ZOMPLEX* )malloc( (*n)*LDC*sizeof(CBLAS_TEST_ZOMPLEX)); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) { + C[i*LDC+j].real=c[j*(*ldc)+i].real; + C[i*LDC+j].imag=c[j*(*ldc)+i].imag; + } + cblas_zsyr2k(CblasRowMajor, uplo, trans, *n, *k, alpha, A, LDA, + B, LDB, beta, C, LDC ); + for( j=0; j<*n; j++ ) + for( i=0; i<*n; i++ ) { + c[j*(*ldc)+i].real=C[i*LDC+j].real; + c[j*(*ldc)+i].imag=C[i*LDC+j].imag; + } + free(A); + free(B); + free(C); + } + else if (*layout == TEST_COL_MJR) + cblas_zsyr2k(CblasColMajor, uplo, trans, *n, *k, alpha, a, *lda, + b, *ldb, beta, c, *ldc ); + else + cblas_zsyr2k(UNDEFINED, uplo, trans, *n, *k, alpha, a, *lda, + b, *ldb, beta, c, *ldc ); +} +void F77_ztrmm(int *layout, char *rtlf, char *uplow, char *transp, char *diagn, + int *m, int *n, CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, + int *lda, CBLAS_TEST_ZOMPLEX *b, int *ldb) { + int i,j,LDA,LDB; + CBLAS_TEST_ZOMPLEX *A, *B; + CBLAS_SIDE side; + CBLAS_DIAG diag; + CBLAS_UPLO uplo; + CBLAS_TRANSPOSE trans; + + get_uplo_type(uplow,&uplo); + get_transpose_type(transp,&trans); + get_diag_type(diagn,&diag); + get_side_type(rtlf,&side); + + if (*layout == TEST_ROW_MJR) { + if (side == CblasLeft) { + LDA = *m+1; + A=(CBLAS_TEST_ZOMPLEX* )malloc((*m)*LDA*sizeof(CBLAS_TEST_ZOMPLEX)); + for( i=0; i<*m; i++ ) + for( j=0; j<*m; j++ ) { + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + } + } + else{ + LDA = *n+1; + A=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_ZOMPLEX)); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) { + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + } + } + LDB = *n+1; + B=(CBLAS_TEST_ZOMPLEX* )malloc((*m)*LDB*sizeof(CBLAS_TEST_ZOMPLEX)); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ) { + B[i*LDB+j].real=b[j*(*ldb)+i].real; + B[i*LDB+j].imag=b[j*(*ldb)+i].imag; + } + cblas_ztrmm(CblasRowMajor, side, uplo, trans, diag, *m, *n, alpha, + A, LDA, B, LDB ); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) { + b[j*(*ldb)+i].real=B[i*LDB+j].real; + b[j*(*ldb)+i].imag=B[i*LDB+j].imag; + } + free(A); + free(B); + } + else if (*layout == TEST_COL_MJR) + cblas_ztrmm(CblasColMajor, side, uplo, trans, diag, *m, *n, alpha, + a, *lda, b, *ldb); + else + cblas_ztrmm(UNDEFINED, side, uplo, trans, diag, *m, *n, alpha, + a, *lda, b, *ldb); +} + +void F77_ztrsm(int *layout, char *rtlf, char *uplow, char *transp, char *diagn, + int *m, int *n, CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, + int *lda, CBLAS_TEST_ZOMPLEX *b, int *ldb) { + int i,j,LDA,LDB; + CBLAS_TEST_ZOMPLEX *A, *B; + CBLAS_SIDE side; + CBLAS_DIAG diag; + CBLAS_UPLO uplo; + CBLAS_TRANSPOSE trans; + + get_uplo_type(uplow,&uplo); + get_transpose_type(transp,&trans); + get_diag_type(diagn,&diag); + get_side_type(rtlf,&side); + + if (*layout == TEST_ROW_MJR) { + if (side == CblasLeft) { + LDA = *m+1; + A=(CBLAS_TEST_ZOMPLEX* )malloc( (*m)*LDA*sizeof(CBLAS_TEST_ZOMPLEX ) ); + for( i=0; i<*m; i++ ) + for( j=0; j<*m; j++ ) { + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + } + } + else{ + LDA = *n+1; + A=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_ZOMPLEX)); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) { + A[i*LDA+j].real=a[j*(*lda)+i].real; + A[i*LDA+j].imag=a[j*(*lda)+i].imag; + } + } + LDB = *n+1; + B=(CBLAS_TEST_ZOMPLEX* )malloc((*m)*LDB*sizeof(CBLAS_TEST_ZOMPLEX)); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ) { + B[i*LDB+j].real=b[j*(*ldb)+i].real; + B[i*LDB+j].imag=b[j*(*ldb)+i].imag; + } + cblas_ztrsm(CblasRowMajor, side, uplo, trans, diag, *m, *n, alpha, + A, LDA, B, LDB ); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) { + b[j*(*ldb)+i].real=B[i*LDB+j].real; + b[j*(*ldb)+i].imag=B[i*LDB+j].imag; + } + free(A); + free(B); + } + else if (*layout == TEST_COL_MJR) + cblas_ztrsm(CblasColMajor, side, uplo, trans, diag, *m, *n, alpha, + a, *lda, b, *ldb); + else + cblas_ztrsm(UNDEFINED, side, uplo, trans, diag, *m, *n, alpha, + a, *lda, b, *ldb); +} diff --git a/cblas/testing/c_zblat1.f b/cblas/testing/c_zblat1.f new file mode 100644 index 00000000..03753e78 --- /dev/null +++ b/cblas/testing/c_zblat1.f @@ -0,0 +1,682 @@ + PROGRAM ZCBLAT1 +* Test program for the COMPLEX*16 Level 1 CBLAS. +* Based upon the original CBLAS test routine together with: +* F06GAF Example Program Text +* .. Parameters .. + INTEGER NOUT + PARAMETER (NOUT=6) +* .. Scalars in Common .. + INTEGER ICASE, INCX, INCY, MODE, N + LOGICAL PASS +* .. Local Scalars .. + DOUBLE PRECISION SFAC + INTEGER IC +* .. External Subroutines .. + EXTERNAL CHECK1, CHECK2, HEADER +* .. Common blocks .. + COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS +* .. Data statements .. + DATA SFAC/9.765625D-4/ +* .. Executable Statements .. + WRITE (NOUT,99999) + DO 20 IC = 1, 10 + ICASE = IC + CALL HEADER +* +* Initialize PASS, INCX, INCY, and MODE for a new case. +* The value 9999 for INCX, INCY or MODE will appear in the +* detailed output, if any, for cases that do not involve +* these parameters. +* + PASS = .TRUE. + INCX = 9999 + INCY = 9999 + MODE = 9999 + IF (ICASE.LE.5) THEN + CALL CHECK2(SFAC) + ELSE IF (ICASE.GE.6) THEN + CALL CHECK1(SFAC) + END IF +* -- Print + IF (PASS) WRITE (NOUT,99998) + 20 CONTINUE + STOP +* +99999 FORMAT (' Complex CBLAS Test Program Results',/1X) +99998 FORMAT (' ----- PASS -----') + END + SUBROUTINE HEADER +* .. Parameters .. + INTEGER NOUT + PARAMETER (NOUT=6) +* .. Scalars in Common .. + INTEGER ICASE, INCX, INCY, MODE, N + LOGICAL PASS +* .. Local Arrays .. + CHARACTER*15 L(10) +* .. Common blocks .. + COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS +* .. Data statements .. + DATA L(1)/'CBLAS_ZDOTC'/ + DATA L(2)/'CBLAS_ZDOTU'/ + DATA L(3)/'CBLAS_ZAXPY'/ + DATA L(4)/'CBLAS_ZCOPY'/ + DATA L(5)/'CBLAS_ZSWAP'/ + DATA L(6)/'CBLAS_DZNRM2'/ + DATA L(7)/'CBLAS_DZASUM'/ + DATA L(8)/'CBLAS_ZSCAL'/ + DATA L(9)/'CBLAS_ZDSCAL'/ + DATA L(10)/'CBLAS_IZAMAX'/ +* .. Executable Statements .. + WRITE (NOUT,99999) ICASE, L(ICASE) + RETURN +* +99999 FORMAT (/' Test of subprogram number',I3,9X,A15) + END + SUBROUTINE CHECK1(SFAC) +* .. Parameters .. + INTEGER NOUT + PARAMETER (NOUT=6) +* .. Scalar Arguments .. + DOUBLE PRECISION SFAC +* .. Scalars in Common .. + INTEGER ICASE, INCX, INCY, MODE, N + LOGICAL PASS +* .. Local Scalars .. + COMPLEX*16 CA + DOUBLE PRECISION SA + INTEGER I, J, LEN, NP1 +* .. Local Arrays .. + COMPLEX*16 CTRUE5(8,5,2), CTRUE6(8,5,2), CV(8,5,2), CX(8), + + MWPCS(5), MWPCT(5) + DOUBLE PRECISION STRUE2(5), STRUE4(5) + INTEGER ITRUE3(5) +* .. External Functions .. + DOUBLE PRECISION DZASUMTEST, DZNRM2TEST + INTEGER IZAMAXTEST + EXTERNAL DZASUMTEST, DZNRM2TEST, IZAMAXTEST +* .. External Subroutines .. + EXTERNAL ZSCALTEST, ZDSCALTEST, CTEST, ITEST1, STEST1 +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Common blocks .. + COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS +* .. Data statements .. + DATA SA, CA/0.3D0, (0.4D0,-0.7D0)/ + DATA ((CV(I,J,1),I=1,8),J=1,5)/(0.1D0,0.1D0), + + (1.0D0,2.0D0), (1.0D0,2.0D0), (1.0D0,2.0D0), + + (1.0D0,2.0D0), (1.0D0,2.0D0), (1.0D0,2.0D0), + + (1.0D0,2.0D0), (0.3D0,-0.4D0), (3.0D0,4.0D0), + + (3.0D0,4.0D0), (3.0D0,4.0D0), (3.0D0,4.0D0), + + (3.0D0,4.0D0), (3.0D0,4.0D0), (3.0D0,4.0D0), + + (0.1D0,-0.3D0), (0.5D0,-0.1D0), (5.0D0,6.0D0), + + (5.0D0,6.0D0), (5.0D0,6.0D0), (5.0D0,6.0D0), + + (5.0D0,6.0D0), (5.0D0,6.0D0), (0.1D0,0.1D0), + + (-0.6D0,0.1D0), (0.1D0,-0.3D0), (7.0D0,8.0D0), + + (7.0D0,8.0D0), (7.0D0,8.0D0), (7.0D0,8.0D0), + + (7.0D0,8.0D0), (0.3D0,0.1D0), (0.1D0,0.4D0), + + (0.4D0,0.1D0), (0.1D0,0.2D0), (2.0D0,3.0D0), + + (2.0D0,3.0D0), (2.0D0,3.0D0), (2.0D0,3.0D0)/ + DATA ((CV(I,J,2),I=1,8),J=1,5)/(0.1D0,0.1D0), + + (4.0D0,5.0D0), (4.0D0,5.0D0), (4.0D0,5.0D0), + + (4.0D0,5.0D0), (4.0D0,5.0D0), (4.0D0,5.0D0), + + (4.0D0,5.0D0), (0.3D0,-0.4D0), (6.0D0,7.0D0), + + (6.0D0,7.0D0), (6.0D0,7.0D0), (6.0D0,7.0D0), + + (6.0D0,7.0D0), (6.0D0,7.0D0), (6.0D0,7.0D0), + + (0.1D0,-0.3D0), (8.0D0,9.0D0), (0.5D0,-0.1D0), + + (2.0D0,5.0D0), (2.0D0,5.0D0), (2.0D0,5.0D0), + + (2.0D0,5.0D0), (2.0D0,5.0D0), (0.1D0,0.1D0), + + (3.0D0,6.0D0), (-0.6D0,0.1D0), (4.0D0,7.0D0), + + (0.1D0,-0.3D0), (7.0D0,2.0D0), (7.0D0,2.0D0), + + (7.0D0,2.0D0), (0.3D0,0.1D0), (5.0D0,8.0D0), + + (0.1D0,0.4D0), (6.0D0,9.0D0), (0.4D0,0.1D0), + + (8.0D0,3.0D0), (0.1D0,0.2D0), (9.0D0,4.0D0)/ + DATA STRUE2/0.0D0, 0.5D0, 0.6D0, 0.7D0, 0.7D0/ + DATA STRUE4/0.0D0, 0.7D0, 1.0D0, 1.3D0, 1.7D0/ + DATA ((CTRUE5(I,J,1),I=1,8),J=1,5)/(0.1D0,0.1D0), + + (1.0D0,2.0D0), (1.0D0,2.0D0), (1.0D0,2.0D0), + + (1.0D0,2.0D0), (1.0D0,2.0D0), (1.0D0,2.0D0), + + (1.0D0,2.0D0), (-0.16D0,-0.37D0), (3.0D0,4.0D0), + + (3.0D0,4.0D0), (3.0D0,4.0D0), (3.0D0,4.0D0), + + (3.0D0,4.0D0), (3.0D0,4.0D0), (3.0D0,4.0D0), + + (-0.17D0,-0.19D0), (0.13D0,-0.39D0), + + (5.0D0,6.0D0), (5.0D0,6.0D0), (5.0D0,6.0D0), + + (5.0D0,6.0D0), (5.0D0,6.0D0), (5.0D0,6.0D0), + + (0.11D0,-0.03D0), (-0.17D0,0.46D0), + + (-0.17D0,-0.19D0), (7.0D0,8.0D0), (7.0D0,8.0D0), + + (7.0D0,8.0D0), (7.0D0,8.0D0), (7.0D0,8.0D0), + + (0.19D0,-0.17D0), (0.32D0,0.09D0), + + (0.23D0,-0.24D0), (0.18D0,0.01D0), + + (2.0D0,3.0D0), (2.0D0,3.0D0), (2.0D0,3.0D0), + + (2.0D0,3.0D0)/ + DATA ((CTRUE5(I,J,2),I=1,8),J=1,5)/(0.1D0,0.1D0), + + (4.0D0,5.0D0), (4.0D0,5.0D0), (4.0D0,5.0D0), + + (4.0D0,5.0D0), (4.0D0,5.0D0), (4.0D0,5.0D0), + + (4.0D0,5.0D0), (-0.16D0,-0.37D0), (6.0D0,7.0D0), + + (6.0D0,7.0D0), (6.0D0,7.0D0), (6.0D0,7.0D0), + + (6.0D0,7.0D0), (6.0D0,7.0D0), (6.0D0,7.0D0), + + (-0.17D0,-0.19D0), (8.0D0,9.0D0), + + (0.13D0,-0.39D0), (2.0D0,5.0D0), (2.0D0,5.0D0), + + (2.0D0,5.0D0), (2.0D0,5.0D0), (2.0D0,5.0D0), + + (0.11D0,-0.03D0), (3.0D0,6.0D0), + + (-0.17D0,0.46D0), (4.0D0,7.0D0), + + (-0.17D0,-0.19D0), (7.0D0,2.0D0), (7.0D0,2.0D0), + + (7.0D0,2.0D0), (0.19D0,-0.17D0), (5.0D0,8.0D0), + + (0.32D0,0.09D0), (6.0D0,9.0D0), + + (0.23D0,-0.24D0), (8.0D0,3.0D0), + + (0.18D0,0.01D0), (9.0D0,4.0D0)/ + DATA ((CTRUE6(I,J,1),I=1,8),J=1,5)/(0.1D0,0.1D0), + + (1.0D0,2.0D0), (1.0D0,2.0D0), (1.0D0,2.0D0), + + (1.0D0,2.0D0), (1.0D0,2.0D0), (1.0D0,2.0D0), + + (1.0D0,2.0D0), (0.09D0,-0.12D0), (3.0D0,4.0D0), + + (3.0D0,4.0D0), (3.0D0,4.0D0), (3.0D0,4.0D0), + + (3.0D0,4.0D0), (3.0D0,4.0D0), (3.0D0,4.0D0), + + (0.03D0,-0.09D0), (0.15D0,-0.03D0), + + (5.0D0,6.0D0), (5.0D0,6.0D0), (5.0D0,6.0D0), + + (5.0D0,6.0D0), (5.0D0,6.0D0), (5.0D0,6.0D0), + + (0.03D0,0.03D0), (-0.18D0,0.03D0), + + (0.03D0,-0.09D0), (7.0D0,8.0D0), (7.0D0,8.0D0), + + (7.0D0,8.0D0), (7.0D0,8.0D0), (7.0D0,8.0D0), + + (0.09D0,0.03D0), (0.03D0,0.12D0), + + (0.12D0,0.03D0), (0.03D0,0.06D0), (2.0D0,3.0D0), + + (2.0D0,3.0D0), (2.0D0,3.0D0), (2.0D0,3.0D0)/ + DATA ((CTRUE6(I,J,2),I=1,8),J=1,5)/(0.1D0,0.1D0), + + (4.0D0,5.0D0), (4.0D0,5.0D0), (4.0D0,5.0D0), + + (4.0D0,5.0D0), (4.0D0,5.0D0), (4.0D0,5.0D0), + + (4.0D0,5.0D0), (0.09D0,-0.12D0), (6.0D0,7.0D0), + + (6.0D0,7.0D0), (6.0D0,7.0D0), (6.0D0,7.0D0), + + (6.0D0,7.0D0), (6.0D0,7.0D0), (6.0D0,7.0D0), + + (0.03D0,-0.09D0), (8.0D0,9.0D0), + + (0.15D0,-0.03D0), (2.0D0,5.0D0), (2.0D0,5.0D0), + + (2.0D0,5.0D0), (2.0D0,5.0D0), (2.0D0,5.0D0), + + (0.03D0,0.03D0), (3.0D0,6.0D0), + + (-0.18D0,0.03D0), (4.0D0,7.0D0), + + (0.03D0,-0.09D0), (7.0D0,2.0D0), (7.0D0,2.0D0), + + (7.0D0,2.0D0), (0.09D0,0.03D0), (5.0D0,8.0D0), + + (0.03D0,0.12D0), (6.0D0,9.0D0), (0.12D0,0.03D0), + + (8.0D0,3.0D0), (0.03D0,0.06D0), (9.0D0,4.0D0)/ + DATA ITRUE3/0, 1, 2, 2, 2/ +* .. Executable Statements .. + DO 60 INCX = 1, 2 + DO 40 NP1 = 1, 5 + N = NP1 - 1 + LEN = 2*MAX(N,1) +* .. Set vector arguments .. + DO 20 I = 1, LEN + CX(I) = CV(I,NP1,INCX) + 20 CONTINUE + IF (ICASE.EQ.6) THEN +* .. DZNRM2TEST .. + CALL STEST1(DZNRM2TEST(N,CX,INCX),STRUE2(NP1), + + STRUE2(NP1),SFAC) + ELSE IF (ICASE.EQ.7) THEN +* .. DZASUMTEST .. + CALL STEST1(DZASUMTEST(N,CX,INCX),STRUE4(NP1), + + STRUE4(NP1),SFAC) + ELSE IF (ICASE.EQ.8) THEN +* .. ZSCALTEST .. + CALL ZSCALTEST(N,CA,CX,INCX) + CALL CTEST(LEN,CX,CTRUE5(1,NP1,INCX),CTRUE5(1,NP1,INCX), + + SFAC) + ELSE IF (ICASE.EQ.9) THEN +* .. ZDSCALTEST .. + CALL ZDSCALTEST(N,SA,CX,INCX) + CALL CTEST(LEN,CX,CTRUE6(1,NP1,INCX),CTRUE6(1,NP1,INCX), + + SFAC) + ELSE IF (ICASE.EQ.10) THEN +* .. IZAMAXTEST .. + CALL ITEST1(IZAMAXTEST(N,CX,INCX),ITRUE3(NP1)) + ELSE + WRITE (NOUT,*) ' Shouldn''t be here in CHECK1' + STOP + END IF +* + 40 CONTINUE + 60 CONTINUE +* + INCX = 1 + IF (ICASE.EQ.8) THEN +* ZSCALTEST +* Add a test for alpha equal to zero. + CA = (0.0D0,0.0D0) + DO 80 I = 1, 5 + MWPCT(I) = (0.0D0,0.0D0) + MWPCS(I) = (1.0D0,1.0D0) + 80 CONTINUE + CALL ZSCALTEST(5,CA,CX,INCX) + CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) + ELSE IF (ICASE.EQ.9) THEN +* ZDSCALTEST +* Add a test for alpha equal to zero. + SA = 0.0D0 + DO 100 I = 1, 5 + MWPCT(I) = (0.0D0,0.0D0) + MWPCS(I) = (1.0D0,1.0D0) + 100 CONTINUE + CALL ZDSCALTEST(5,SA,CX,INCX) + CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) +* Add a test for alpha equal to one. + SA = 1.0D0 + DO 120 I = 1, 5 + MWPCT(I) = CX(I) + MWPCS(I) = CX(I) + 120 CONTINUE + CALL ZDSCALTEST(5,SA,CX,INCX) + CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) +* Add a test for alpha equal to minus one. + SA = -1.0D0 + DO 140 I = 1, 5 + MWPCT(I) = -CX(I) + MWPCS(I) = -CX(I) + 140 CONTINUE + CALL ZDSCALTEST(5,SA,CX,INCX) + CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) + END IF + RETURN + END + SUBROUTINE CHECK2(SFAC) +* .. Parameters .. + INTEGER NOUT + PARAMETER (NOUT=6) +* .. Scalar Arguments .. + DOUBLE PRECISION SFAC +* .. Scalars in Common .. + INTEGER ICASE, INCX, INCY, MODE, N + LOGICAL PASS +* .. Local Scalars .. + COMPLEX*16 CA,ZTEMP + INTEGER I, J, KI, KN, KSIZE, LENX, LENY, MX, MY +* .. Local Arrays .. + COMPLEX*16 CDOT(1), CSIZE1(4), CSIZE2(7,2), CSIZE3(14), + + CT10X(7,4,4), CT10Y(7,4,4), CT6(4,4), CT7(4,4), + + CT8(7,4,4), CX(7), CX1(7), CY(7), CY1(7) + INTEGER INCXS(4), INCYS(4), LENS(4,2), NS(4) +* .. External Functions .. + EXTERNAL ZDOTCTEST, ZDOTUTEST +* .. External Subroutines .. + EXTERNAL ZAXPYTEST, ZCOPYTEST, ZSWAPTEST, CTEST +* .. Intrinsic Functions .. + INTRINSIC ABS, MIN +* .. Common blocks .. + COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS +* .. Data statements .. + DATA CA/(0.4D0,-0.7D0)/ + DATA INCXS/1, 2, -2, -1/ + DATA INCYS/1, -2, 1, -2/ + DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/ + DATA NS/0, 1, 2, 4/ + DATA CX1/(0.7D0,-0.8D0), (-0.4D0,-0.7D0), + + (-0.1D0,-0.9D0), (0.2D0,-0.8D0), + + (-0.9D0,-0.4D0), (0.1D0,0.4D0), (-0.6D0,0.6D0)/ + DATA CY1/(0.6D0,-0.6D0), (-0.9D0,0.5D0), + + (0.7D0,-0.6D0), (0.1D0,-0.5D0), (-0.1D0,-0.2D0), + + (-0.5D0,-0.3D0), (0.8D0,-0.7D0)/ + DATA ((CT8(I,J,1),I=1,7),J=1,4)/(0.6D0,-0.6D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.32D0,-1.41D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.32D0,-1.41D0), + + (-1.55D0,0.5D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.32D0,-1.41D0), (-1.55D0,0.5D0), + + (0.03D0,-0.89D0), (-0.38D0,-0.96D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0)/ + DATA ((CT8(I,J,2),I=1,7),J=1,4)/(0.6D0,-0.6D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.32D0,-1.41D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (-0.07D0,-0.89D0), + + (-0.9D0,0.5D0), (0.42D0,-1.41D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.78D0,0.06D0), (-0.9D0,0.5D0), + + (0.06D0,-0.13D0), (0.1D0,-0.5D0), + + (-0.77D0,-0.49D0), (-0.5D0,-0.3D0), + + (0.52D0,-1.51D0)/ + DATA ((CT8(I,J,3),I=1,7),J=1,4)/(0.6D0,-0.6D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.32D0,-1.41D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (-0.07D0,-0.89D0), + + (-1.18D0,-0.31D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.78D0,0.06D0), (-1.54D0,0.97D0), + + (0.03D0,-0.89D0), (-0.18D0,-1.31D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0)/ + DATA ((CT8(I,J,4),I=1,7),J=1,4)/(0.6D0,-0.6D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.32D0,-1.41D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.32D0,-1.41D0), (-0.9D0,0.5D0), + + (0.05D0,-0.6D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.32D0,-1.41D0), + + (-0.9D0,0.5D0), (0.05D0,-0.6D0), (0.1D0,-0.5D0), + + (-0.77D0,-0.49D0), (-0.5D0,-0.3D0), + + (0.32D0,-1.16D0)/ + DATA CT7/(0.0D0,0.0D0), (-0.06D0,-0.90D0), + + (0.65D0,-0.47D0), (-0.34D0,-1.22D0), + + (0.0D0,0.0D0), (-0.06D0,-0.90D0), + + (-0.59D0,-1.46D0), (-1.04D0,-0.04D0), + + (0.0D0,0.0D0), (-0.06D0,-0.90D0), + + (-0.83D0,0.59D0), (0.07D0,-0.37D0), + + (0.0D0,0.0D0), (-0.06D0,-0.90D0), + + (-0.76D0,-1.15D0), (-1.33D0,-1.82D0)/ + DATA CT6/(0.0D0,0.0D0), (0.90D0,0.06D0), + + (0.91D0,-0.77D0), (1.80D0,-0.10D0), + + (0.0D0,0.0D0), (0.90D0,0.06D0), (1.45D0,0.74D0), + + (0.20D0,0.90D0), (0.0D0,0.0D0), (0.90D0,0.06D0), + + (-0.55D0,0.23D0), (0.83D0,-0.39D0), + + (0.0D0,0.0D0), (0.90D0,0.06D0), (1.04D0,0.79D0), + + (1.95D0,1.22D0)/ + DATA ((CT10X(I,J,1),I=1,7),J=1,4)/(0.7D0,-0.8D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.6D0,-0.6D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.6D0,-0.6D0), (-0.9D0,0.5D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.6D0,-0.6D0), + + (-0.9D0,0.5D0), (0.7D0,-0.6D0), (0.1D0,-0.5D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0)/ + DATA ((CT10X(I,J,2),I=1,7),J=1,4)/(0.7D0,-0.8D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.6D0,-0.6D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.7D0,-0.6D0), (-0.4D0,-0.7D0), + + (0.6D0,-0.6D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.8D0,-0.7D0), + + (-0.4D0,-0.7D0), (-0.1D0,-0.2D0), + + (0.2D0,-0.8D0), (0.7D0,-0.6D0), (0.1D0,0.4D0), + + (0.6D0,-0.6D0)/ + DATA ((CT10X(I,J,3),I=1,7),J=1,4)/(0.7D0,-0.8D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.6D0,-0.6D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (-0.9D0,0.5D0), (-0.4D0,-0.7D0), + + (0.6D0,-0.6D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.1D0,-0.5D0), + + (-0.4D0,-0.7D0), (0.7D0,-0.6D0), (0.2D0,-0.8D0), + + (-0.9D0,0.5D0), (0.1D0,0.4D0), (0.6D0,-0.6D0)/ + DATA ((CT10X(I,J,4),I=1,7),J=1,4)/(0.7D0,-0.8D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.6D0,-0.6D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.6D0,-0.6D0), (0.7D0,-0.6D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.6D0,-0.6D0), + + (0.7D0,-0.6D0), (-0.1D0,-0.2D0), (0.8D0,-0.7D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0)/ + DATA ((CT10Y(I,J,1),I=1,7),J=1,4)/(0.6D0,-0.6D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.7D0,-0.8D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.7D0,-0.8D0), (-0.4D0,-0.7D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.7D0,-0.8D0), + + (-0.4D0,-0.7D0), (-0.1D0,-0.9D0), + + (0.2D0,-0.8D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0)/ + DATA ((CT10Y(I,J,2),I=1,7),J=1,4)/(0.6D0,-0.6D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.7D0,-0.8D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (-0.1D0,-0.9D0), (-0.9D0,0.5D0), + + (0.7D0,-0.8D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (-0.6D0,0.6D0), + + (-0.9D0,0.5D0), (-0.9D0,-0.4D0), (0.1D0,-0.5D0), + + (-0.1D0,-0.9D0), (-0.5D0,-0.3D0), + + (0.7D0,-0.8D0)/ + DATA ((CT10Y(I,J,3),I=1,7),J=1,4)/(0.6D0,-0.6D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.7D0,-0.8D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (-0.1D0,-0.9D0), (0.7D0,-0.8D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (-0.6D0,0.6D0), + + (-0.9D0,-0.4D0), (-0.1D0,-0.9D0), + + (0.7D0,-0.8D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0)/ + DATA ((CT10Y(I,J,4),I=1,7),J=1,4)/(0.6D0,-0.6D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.7D0,-0.8D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.7D0,-0.8D0), (-0.9D0,0.5D0), + + (-0.4D0,-0.7D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.7D0,-0.8D0), + + (-0.9D0,0.5D0), (-0.4D0,-0.7D0), (0.1D0,-0.5D0), + + (-0.1D0,-0.9D0), (-0.5D0,-0.3D0), + + (0.2D0,-0.8D0)/ + DATA CSIZE1/(0.0D0,0.0D0), (0.9D0,0.9D0), + + (1.63D0,1.73D0), (2.90D0,2.78D0)/ + DATA CSIZE3/(0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (1.17D0,1.17D0), + + (1.17D0,1.17D0), (1.17D0,1.17D0), + + (1.17D0,1.17D0), (1.17D0,1.17D0), + + (1.17D0,1.17D0), (1.17D0,1.17D0)/ + DATA CSIZE2/(0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0), + + (0.0D0,0.0D0), (0.0D0,0.0D0), (1.54D0,1.54D0), + + (1.54D0,1.54D0), (1.54D0,1.54D0), + + (1.54D0,1.54D0), (1.54D0,1.54D0), + + (1.54D0,1.54D0), (1.54D0,1.54D0)/ +* .. Executable Statements .. + DO 60 KI = 1, 4 + INCX = INCXS(KI) + INCY = INCYS(KI) + MX = ABS(INCX) + MY = ABS(INCY) +* + DO 40 KN = 1, 4 + N = NS(KN) + KSIZE = MIN(2,KN) + LENX = LENS(KN,MX) + LENY = LENS(KN,MY) +* .. initialize all argument arrays .. + DO 20 I = 1, 7 + CX(I) = CX1(I) + CY(I) = CY1(I) + 20 CONTINUE + IF (ICASE.EQ.1) THEN +* .. ZDOTCTEST .. + CALL ZDOTCTEST(N,CX,INCX,CY,INCY,ZTEMP) + CDOT(1) = ZTEMP + CALL CTEST(1,CDOT,CT6(KN,KI),CSIZE1(KN),SFAC) + ELSE IF (ICASE.EQ.2) THEN +* .. ZDOTUTEST .. + CALL ZDOTUTEST(N,CX,INCX,CY,INCY,ZTEMP) + CDOT(1) = ZTEMP + CALL CTEST(1,CDOT,CT7(KN,KI),CSIZE1(KN),SFAC) + ELSE IF (ICASE.EQ.3) THEN +* .. ZAXPYTEST .. + CALL ZAXPYTEST(N,CA,CX,INCX,CY,INCY) + CALL CTEST(LENY,CY,CT8(1,KN,KI),CSIZE2(1,KSIZE),SFAC) + ELSE IF (ICASE.EQ.4) THEN +* .. ZCOPYTEST .. + CALL ZCOPYTEST(N,CX,INCX,CY,INCY) + CALL CTEST(LENY,CY,CT10Y(1,KN,KI),CSIZE3,1.0D0) + ELSE IF (ICASE.EQ.5) THEN +* .. ZSWAPTEST .. + CALL ZSWAPTEST(N,CX,INCX,CY,INCY) + CALL CTEST(LENX,CX,CT10X(1,KN,KI),CSIZE3,1.0D0) + CALL CTEST(LENY,CY,CT10Y(1,KN,KI),CSIZE3,1.0D0) + ELSE + WRITE (NOUT,*) ' Shouldn''t be here in CHECK2' + STOP + END IF +* + 40 CONTINUE + 60 CONTINUE + RETURN + END + SUBROUTINE STEST(LEN,SCOMP,STRUE,SSIZE,SFAC) +* ********************************* STEST ************************** +* +* THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO +* SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE +* NEGLIGIBLE. +* +* C. L. LAWSON, JPL, 1974 DEC 10 +* +* .. Parameters .. + INTEGER NOUT + PARAMETER (NOUT=6) +* .. Scalar Arguments .. + DOUBLE PRECISION SFAC + INTEGER LEN +* .. Array Arguments .. + DOUBLE PRECISION SCOMP(LEN), SSIZE(LEN), STRUE(LEN) +* .. Scalars in Common .. + INTEGER ICASE, INCX, INCY, MODE, N + LOGICAL PASS +* .. Local Scalars .. + DOUBLE PRECISION SD + INTEGER I +* .. External Functions .. + DOUBLE PRECISION SDIFF + EXTERNAL SDIFF +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. Common blocks .. + COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS +* .. Executable Statements .. +* + DO 40 I = 1, LEN + SD = SCOMP(I) - STRUE(I) + IF (SDIFF(ABS(SSIZE(I))+ABS(SFAC*SD),ABS(SSIZE(I))).EQ.0.0D0) + + GO TO 40 +* +* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I). +* + IF ( .NOT. PASS) GO TO 20 +* PRINT FAIL MESSAGE AND HEADER. + PASS = .FALSE. + WRITE (NOUT,99999) + WRITE (NOUT,99998) + 20 WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, I, SCOMP(I), + + STRUE(I), SD, SSIZE(I) + 40 CONTINUE + RETURN +* +99999 FORMAT (' FAIL') +99998 FORMAT (/' CASE N INCX INCY MODE I ', + + ' COMP(I) TRUE(I) DIFFERENCE', + + ' SIZE(I)',/1X) +99997 FORMAT (1X,I4,I3,3I5,I3,2D36.8,2D12.4) + END + SUBROUTINE STEST1(SCOMP1,STRUE1,SSIZE,SFAC) +* ************************* STEST1 ***************************** +* +* THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN +* REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE +* ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT. +* +* C.L. LAWSON, JPL, 1978 DEC 6 +* +* .. Scalar Arguments .. + DOUBLE PRECISION SCOMP1, SFAC, STRUE1 +* .. Array Arguments .. + DOUBLE PRECISION SSIZE(*) +* .. Local Arrays .. + DOUBLE PRECISION SCOMP(1), STRUE(1) +* .. External Subroutines .. + EXTERNAL STEST +* .. Executable Statements .. +* + SCOMP(1) = SCOMP1 + STRUE(1) = STRUE1 + CALL STEST(1,SCOMP,STRUE,SSIZE,SFAC) +* + RETURN + END + DOUBLE PRECISION FUNCTION SDIFF(SA,SB) +* ********************************* SDIFF ************************** +* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15 +* +* .. Scalar Arguments .. + DOUBLE PRECISION SA, SB +* .. Executable Statements .. + SDIFF = SA - SB + RETURN + END + SUBROUTINE CTEST(LEN,CCOMP,CTRUE,CSIZE,SFAC) +* **************************** CTEST ***************************** +* +* C.L. LAWSON, JPL, 1978 DEC 6 +* +* .. Scalar Arguments .. + DOUBLE PRECISION SFAC + INTEGER LEN +* .. Array Arguments .. + COMPLEX*16 CCOMP(LEN), CSIZE(LEN), CTRUE(LEN) +* .. Local Scalars .. + INTEGER I +* .. Local Arrays .. + DOUBLE PRECISION SCOMP(20), SSIZE(20), STRUE(20) +* .. External Subroutines .. + EXTERNAL STEST +* .. Intrinsic Functions .. + INTRINSIC DIMAG, DBLE +* .. Executable Statements .. + DO 20 I = 1, LEN + SCOMP(2*I-1) = DBLE(CCOMP(I)) + SCOMP(2*I) = DIMAG(CCOMP(I)) + STRUE(2*I-1) = DBLE(CTRUE(I)) + STRUE(2*I) = DIMAG(CTRUE(I)) + SSIZE(2*I-1) = DBLE(CSIZE(I)) + SSIZE(2*I) = DIMAG(CSIZE(I)) + 20 CONTINUE +* + CALL STEST(2*LEN,SCOMP,STRUE,SSIZE,SFAC) + RETURN + END + SUBROUTINE ITEST1(ICOMP,ITRUE) +* ********************************* ITEST1 ************************* +* +* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR +* EQUALITY. +* C. L. LAWSON, JPL, 1974 DEC 10 +* +* .. Parameters .. + INTEGER NOUT + PARAMETER (NOUT=6) +* .. Scalar Arguments .. + INTEGER ICOMP, ITRUE +* .. Scalars in Common .. + INTEGER ICASE, INCX, INCY, MODE, N + LOGICAL PASS +* .. Local Scalars .. + INTEGER ID +* .. Common blocks .. + COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS +* .. Executable Statements .. + IF (ICOMP.EQ.ITRUE) GO TO 40 +* +* HERE ICOMP IS NOT EQUAL TO ITRUE. +* + IF ( .NOT. PASS) GO TO 20 +* PRINT FAIL MESSAGE AND HEADER. + PASS = .FALSE. + WRITE (NOUT,99999) + WRITE (NOUT,99998) + 20 ID = ICOMP - ITRUE + WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, ICOMP, ITRUE, ID + 40 CONTINUE + RETURN +* +99999 FORMAT (' FAIL') +99998 FORMAT (/' CASE N INCX INCY MODE ', + + ' COMP TRUE DIFFERENCE', + + /1X) +99997 FORMAT (1X,I4,I3,3I5,2I36,I12) + END diff --git a/cblas/testing/c_zblat2.f b/cblas/testing/c_zblat2.f new file mode 100644 index 00000000..236088ff --- /dev/null +++ b/cblas/testing/c_zblat2.f @@ -0,0 +1,2939 @@ + PROGRAM ZBLAT2 +* +* Test program for the COMPLEX*16 Level 2 Blas. +* +* The program must be driven by a short data file. The first 17 records +* of the file are read using list-directed input, the last 17 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 34 lines: +* 'CBLAT2.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 +* 4 NUMBER OF VALUES OF K +* 0 1 2 4 VALUES OF K +* 4 NUMBER OF VALUES OF INCX AND INCY +* 1 2 -1 -2 VALUES OF INCX AND INCY +* 3 NUMBER OF VALUES OF ALPHA +* (0.0,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_zgemv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_zgbmv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_zhemv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_zhbmv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_zhpmv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_ztrmv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_ztbmv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_ztpmv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_ztrsv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_ztbsv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_ztpsv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_zgerc T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_zgeru T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_zher T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_zhpr T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_zher2 T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_zhpr2 T PUT F FOR NO TEST. SAME COLUMNS. +* +* See: +* +* Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J.. +* An extended set of Fortran Basic Linear Algebra Subprograms. +* +* Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics +* and Computer Science Division, Argonne National Laboratory, +* 9700 South Cass Avenue, Argonne, Illinois 60439, US. +* +* Or +* +* NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms +* Group Ltd., NAG Central Office, 256 Banbury Road, Oxford +* OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st +* Street, Suite 100, Downers Grove, Illinois 60515-1263, USA. +* +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + INTEGER NIN, NOUT + PARAMETER ( NIN = 5, NOUT = 6 ) + INTEGER NSUBS + PARAMETER ( NSUBS = 17 ) + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), + $ ONE = ( 1.0D0, 0.0D0 ) ) + DOUBLE PRECISION RZERO, RHALF, RONE + PARAMETER ( RZERO = 0.0D0, RHALF = 0.5D0, RONE = 1.0D0 ) + INTEGER NMAX, INCMAX + PARAMETER ( NMAX = 65, INCMAX = 2 ) + INTEGER NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX + PARAMETER ( NINMAX = 7, NIDMAX = 9, NKBMAX = 7, + $ NALMAX = 7, NBEMAX = 7 ) +* .. Local Scalars .. + DOUBLE PRECISION EPS, ERR, THRESH + INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB, + $ NTRA, LAYOUT + LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, + $ TSTERR, CORDER, RORDER + CHARACTER*1 TRANS + CHARACTER*12 SNAMET + CHARACTER*32 SNAPS +* .. Local Arrays .. + COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), + $ ALF( NALMAX ), AS( NMAX*NMAX ), BET( NBEMAX ), + $ X( NMAX ), XS( NMAX*INCMAX ), + $ XX( NMAX*INCMAX ), Y( NMAX ), + $ YS( NMAX*INCMAX ), YT( NMAX ), + $ YY( NMAX*INCMAX ), Z( 2*NMAX ) + DOUBLE PRECISION G( NMAX ) + INTEGER IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX ) + LOGICAL LTEST( NSUBS ) + CHARACTER*12 SNAMES( NSUBS ) +* .. External Functions .. + DOUBLE PRECISION DDIFF + LOGICAL LZE + EXTERNAL DDIFF, LZE +* .. External Subroutines .. + EXTERNAL ZCHK1, ZCHK2, ZCHK3, ZCHK4, ZCHK5, ZCHK6, + $ CZ2CHKE, ZMVCH +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK + CHARACTER*12 SRNAMT +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK + COMMON /SRNAMC/SRNAMT +* .. Data statements .. + DATA SNAMES/'cblas_zgemv ', 'cblas_zgbmv ', + $ 'cblas_zhemv ','cblas_zhbmv ','cblas_zhpmv ', + $ 'cblas_ztrmv ','cblas_ztbmv ','cblas_ztpmv ', + $ 'cblas_ztrsv ','cblas_ztbsv ','cblas_ztpsv ', + $ 'cblas_zgerc ','cblas_zgeru ','cblas_zher ', + $ 'cblas_zhpr ','cblas_zher2 ','cblas_zhpr2 '/ +* .. Executable Statements .. +* + NOUTC = NOUT +* +* Read name and unit number for summary output file and open file. +* + READ( NIN, FMT = * )SNAPS + READ( NIN, FMT = * )NTRA + TRACE = NTRA.GE.0 + IF( TRACE )THEN + OPEN( NTRA, FILE = SNAPS ) + END IF +* Read the flag that directs rewinding of the snapshot file. + READ( NIN, FMT = * )REWI + REWI = REWI.AND.TRACE +* Read the flag that directs stopping on any failure. + READ( NIN, FMT = * )SFATAL +* Read the flag that indicates whether error exits are to be tested. + READ( NIN, FMT = * )TSTERR +* Read the flag that indicates whether row-major data layout to be tested. + READ( NIN, FMT = * )LAYOUT +* Read the threshold value of the test ratio + READ( NIN, FMT = * )THRESH +* +* Read and check the parameter values for the tests. +* +* Values of N + READ( NIN, FMT = * )NIDIM + IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN + WRITE( NOUT, FMT = 9997 )'N', NIDMAX + GO TO 230 + END IF + READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) + DO 10 I = 1, NIDIM + IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN + WRITE( NOUT, FMT = 9996 )NMAX + GO TO 230 + END IF + 10 CONTINUE +* Values of K + READ( NIN, FMT = * )NKB + IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN + WRITE( NOUT, FMT = 9997 )'K', NKBMAX + GO TO 230 + END IF + READ( NIN, FMT = * )( KB( I ), I = 1, NKB ) + DO 20 I = 1, NKB + IF( KB( I ).LT.0 )THEN + WRITE( NOUT, FMT = 9995 ) + GO TO 230 + END IF + 20 CONTINUE +* Values of INCX and INCY + READ( NIN, FMT = * )NINC + IF( NINC.LT.1.OR.NINC.GT.NINMAX )THEN + WRITE( NOUT, FMT = 9997 )'INCX AND INCY', NINMAX + GO TO 230 + END IF + READ( NIN, FMT = * )( INC( I ), I = 1, NINC ) + DO 30 I = 1, NINC + IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN + WRITE( NOUT, FMT = 9994 )INCMAX + GO TO 230 + END IF + 30 CONTINUE +* Values of ALPHA + READ( NIN, FMT = * )NALF + IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN + WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX + GO TO 230 + END IF + READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) +* Values of BETA + READ( NIN, FMT = * )NBET + IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN + WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX + GO TO 230 + END IF + READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) +* +* Report values of parameters. +* + WRITE( NOUT, FMT = 9993 ) + WRITE( NOUT, FMT = 9992 )( IDIM( I ), I = 1, NIDIM ) + WRITE( NOUT, FMT = 9991 )( KB( I ), I = 1, NKB ) + WRITE( NOUT, FMT = 9990 )( INC( I ), I = 1, NINC ) + WRITE( NOUT, FMT = 9989 )( ALF( I ), I = 1, NALF ) + WRITE( NOUT, FMT = 9988 )( BET( I ), I = 1, NBET ) + IF( .NOT.TSTERR )THEN + WRITE( NOUT, FMT = * ) + WRITE( NOUT, FMT = 9980 ) + END IF + WRITE( NOUT, FMT = * ) + WRITE( NOUT, FMT = 9999 )THRESH + WRITE( NOUT, FMT = * ) + RORDER = .FALSE. + CORDER = .FALSE. + IF (LAYOUT.EQ.2) THEN + RORDER = .TRUE. + CORDER = .TRUE. + WRITE( *, FMT = 10002 ) + ELSE IF (LAYOUT.EQ.1) THEN + RORDER = .TRUE. + WRITE( *, FMT = 10001 ) + ELSE IF (LAYOUT.EQ.0) THEN + CORDER = .TRUE. + WRITE( *, FMT = 10000 ) + END IF + WRITE( *, FMT = * ) +* +* Read names of subroutines and flags which indicate +* whether they are to be tested. +* + DO 40 I = 1, NSUBS + LTEST( I ) = .FALSE. + 40 CONTINUE + 50 READ( NIN, FMT = 9984, END = 80 )SNAMET, LTESTT + DO 60 I = 1, NSUBS + IF( SNAMET.EQ.SNAMES( I ) ) + $ GO TO 70 + 60 CONTINUE + WRITE( NOUT, FMT = 9986 )SNAMET + STOP + 70 LTEST( I ) = LTESTT + GO TO 50 +* + 80 CONTINUE + CLOSE ( NIN ) +* +* Compute EPS (the machine precision). +* + EPS = RONE + 90 CONTINUE + IF( DDIFF( RONE + EPS, RONE ).EQ.RZERO ) + $ GO TO 100 + EPS = RHALF*EPS + GO TO 90 + 100 CONTINUE + EPS = EPS + EPS + WRITE( NOUT, FMT = 9998 )EPS +* +* Check the reliability of ZMVCH using exact data. +* + N = MIN( 32, NMAX ) + DO 120 J = 1, N + DO 110 I = 1, N + A( I, J ) = MAX( I - J + 1, 0 ) + 110 CONTINUE + X( J ) = J + Y( J ) = ZERO + 120 CONTINUE + DO 130 J = 1, N + YY( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 + 130 CONTINUE +* YY holds the exact result. On exit from CMVCH YT holds +* the result computed by CMVCH. + TRANS = 'N' + CALL ZMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G, + $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) + SAME = LZE( YY, YT, N ) + IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN + WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR + STOP + END IF + TRANS = 'T' + CALL ZMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G, + $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) + SAME = LZE( YY, YT, N ) + IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN + WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR + STOP + END IF +* +* Test each subroutine in turn. +* + DO 210 ISNUM = 1, NSUBS + WRITE( NOUT, FMT = * ) + IF( .NOT.LTEST( ISNUM ) )THEN +* Subprogram is not to be tested. + WRITE( NOUT, FMT = 9983 )SNAMES( ISNUM ) + ELSE + SRNAMT = SNAMES( ISNUM ) +* Test error exits. + IF( TSTERR )THEN + CALL CZ2CHKE( SNAMES( ISNUM ) ) + WRITE( NOUT, FMT = * ) + END IF +* Test computations. + INFOT = 0 + OK = .TRUE. + FATAL = .FALSE. + GO TO ( 140, 140, 150, 150, 150, 160, 160, + $ 160, 160, 160, 160, 170, 170, 180, + $ 180, 190, 190 )ISNUM +* Test ZGEMV, 01, and ZGBMV, 02. + 140 IF (CORDER) THEN + CALL ZCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, + $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, + $ X, XX, XS, Y, YY, YS, YT, G, 0 ) + END IF + IF (RORDER) THEN + CALL ZCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, + $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, + $ X, XX, XS, Y, YY, YS, YT, G, 1 ) + END IF + GO TO 200 +* Test ZHEMV, 03, ZHBMV, 04, and ZHPMV, 05. + 150 IF (CORDER) THEN + CALL ZCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, + $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, + $ X, XX, XS, Y, YY, YS, YT, G, 0 ) + END IF + IF (RORDER) THEN + CALL ZCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, + $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, + $ X, XX, XS, Y, YY, YS, YT, G, 1 ) + END IF + GO TO 200 +* Test ZTRMV, 06, ZTBMV, 07, ZTPMV, 08, +* ZTRSV, 09, ZTBSV, 10, and ZTPSV, 11. + 160 IF (CORDER) THEN + CALL ZCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z, + $ 0 ) + END IF + IF (RORDER) THEN + CALL ZCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z, + $ 1 ) + END IF + GO TO 200 +* Test ZGERC, 12, ZGERU, 13. + 170 IF (CORDER) THEN + CALL ZCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, + $ YT, G, Z, 0 ) + END IF + IF (RORDER) THEN + CALL ZCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, + $ YT, G, Z, 1 ) + END IF + GO TO 200 +* Test ZHER, 14, and ZHPR, 15. + 180 IF (CORDER) THEN + CALL ZCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, + $ YT, G, Z, 0 ) + END IF + IF (RORDER) THEN + CALL ZCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, + $ YT, G, Z, 1 ) + END IF + GO TO 200 +* Test ZHER2, 16, and ZHPR2, 17. + 190 IF (CORDER) THEN + CALL ZCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, + $ YT, G, Z, 0 ) + END IF + IF (RORDER) THEN + CALL ZCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, + $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, + $ YT, G, Z, 1 ) + END IF +* + 200 IF( FATAL.AND.SFATAL ) + $ GO TO 220 + END IF + 210 CONTINUE + WRITE( NOUT, FMT = 9982 ) + GO TO 240 +* + 220 CONTINUE + WRITE( NOUT, FMT = 9981 ) + GO TO 240 +* + 230 CONTINUE + WRITE( NOUT, FMT = 9987 ) +* + 240 CONTINUE + IF( TRACE ) + $ CLOSE ( NTRA ) + CLOSE ( NOUT ) + STOP +* +10002 FORMAT( ' COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED' ) +10001 FORMAT( ' ROW-MAJOR DATA LAYOUT IS TESTED' ) +10000 FORMAT( ' COLUMN-MAJOR DATA LAYOUT IS TESTED' ) + 9999 FORMAT(' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', + $ 'S THAN', F8.2 ) + 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 ) + 9997 FORMAT(' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', + $ 'THAN ', I2 ) + 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) + 9995 FORMAT( ' VALUE OF K IS LESS THAN 0' ) + 9994 FORMAT( ' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ', + $ I2 ) + 9993 FORMAT(' TESTS OF THE COMPLEX*16 LEVEL 2 BLAS', //' THE F', + $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) + 9992 FORMAT( ' FOR N ', 9I6 ) + 9991 FORMAT( ' FOR K ', 7I6 ) + 9990 FORMAT( ' FOR INCX AND INCY ', 7I6 ) + 9989 FORMAT( ' FOR ALPHA ', + $ 7('(', F4.1, ',', F4.1, ') ', : ) ) + 9988 FORMAT( ' FOR BETA ', + $ 7('(', F4.1, ',', F4.1, ') ', : ) ) + 9987 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', + $ /' ******* TESTS ABANDONED *******' ) + 9986 FORMAT(' SUBPROGRAM NAME ',A12, ' NOT RECOGNIZED', /' ******* T', + $ 'ESTS ABANDONED *******' ) + 9985 FORMAT(' ERROR IN CMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', + $ 'ATED WRONGLY.', /' CMVCH WAS CALLED WITH TRANS = ', A1, + $ ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', / + $ ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.' + $ , /' ******* TESTS ABANDONED *******' ) + 9984 FORMAT( A12, L2 ) + 9983 FORMAT( 1X,A12, ' WAS NOT TESTED' ) + 9982 FORMAT( /' END OF TESTS' ) + 9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) + 9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) +* +* End of ZBLAT2. +* + END + SUBROUTINE ZCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, + $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, + $ XS, Y, YY, YS, YT, G, IORDER ) +* +* Tests CGEMV and CGBMV. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + COMPLEX*16 ZERO, HALF + PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), + $ HALF = ( 0.5D0, 0.0D0 ) ) + DOUBLE PRECISION RZERO + PARAMETER ( RZERO = 0.0D0 ) +* .. Scalar Arguments .. + DOUBLE PRECISION EPS, THRESH + INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, + $ NOUT, NTRA, IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), BET( NBET ), X( NMAX ), + $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), + $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), + $ YY( NMAX*INCMAX ) + DOUBLE PRECISION G( NMAX ) + INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) +* .. Local Scalars .. + COMPLEX*16 ALPHA, ALS, BETA, BLS, TRANSL + DOUBLE PRECISION ERR, ERRMAX + INTEGER I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY, + $ INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA, + $ LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK, + $ NL, NS + LOGICAL BANDED, FULL, NULL, RESET, SAME, TRAN + CHARACTER*1 TRANS, TRANSS + CHARACTER*14 CTRANS + CHARACTER*3 ICH +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LZE, LZERES + EXTERNAL LZE, LZERES +* .. External Subroutines .. + EXTERNAL CZGBMV, CZGEMV, ZMAKE, ZMVCH +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICH/'NTC'/ +* .. Executable Statements .. + FULL = SNAME( 9: 9 ).EQ.'e' + BANDED = SNAME( 9: 9 ).EQ.'b' +* Define the number of arguments. + IF( FULL )THEN + NARGS = 11 + ELSE IF( BANDED )THEN + NARGS = 13 + END IF +* + NC = 0 + RESET = .TRUE. + ERRMAX = RZERO +* + DO 120 IN = 1, NIDIM + N = IDIM( IN ) + ND = N/2 + 1 +* + DO 110 IM = 1, 2 + IF( IM.EQ.1 ) + $ M = MAX( N - ND, 0 ) + IF( IM.EQ.2 ) + $ M = MIN( N + ND, NMAX ) +* + IF( BANDED )THEN + NK = NKB + ELSE + NK = 1 + END IF + DO 100 IKU = 1, NK + IF( BANDED )THEN + KU = KB( IKU ) + KL = MAX( KU - 1, 0 ) + ELSE + KU = N - 1 + KL = M - 1 + END IF +* Set LDA to 1 more than minimum value if room. + IF( BANDED )THEN + LDA = KL + KU + 1 + ELSE + LDA = M + END IF + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 100 + LAA = LDA*N + NULL = N.LE.0.OR.M.LE.0 +* +* Generate the matrix A. +* + TRANSL = ZERO + CALL ZMAKE( SNAME( 8: 9 ), ' ', ' ', M, N, A, NMAX, AA, + $ LDA, KL, KU, RESET, TRANSL ) +* + DO 90 IC = 1, 3 + TRANS = ICH( IC: IC ) + IF (TRANS.EQ.'N')THEN + CTRANS = ' CblasNoTrans' + ELSE IF (TRANS.EQ.'T')THEN + CTRANS = ' CblasTrans' + ELSE + CTRANS = 'CblasConjTrans' + END IF + TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' +* + IF( TRAN )THEN + ML = N + NL = M + ELSE + ML = M + NL = N + END IF +* + DO 80 IX = 1, NINC + INCX = INC( IX ) + LX = ABS( INCX )*NL +* +* Generate the vector X. +* + TRANSL = HALF + CALL ZMAKE( 'ge', ' ', ' ', 1, NL, X, 1, XX, + $ ABS( INCX ), 0, NL - 1, RESET, TRANSL ) + IF( NL.GT.1 )THEN + X( NL/2 ) = ZERO + XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO + END IF +* + DO 70 IY = 1, NINC + INCY = INC( IY ) + LY = ABS( INCY )*ML +* + DO 60 IA = 1, NALF + ALPHA = ALF( IA ) +* + DO 50 IB = 1, NBET + BETA = BET( IB ) +* +* Generate the vector Y. +* + TRANSL = ZERO + CALL ZMAKE( 'ge', ' ', ' ', 1, ML, Y, 1, + $ YY, ABS( INCY ), 0, ML - 1, + $ RESET, TRANSL ) +* + NC = NC + 1 +* +* Save every datum before calling the +* subroutine. +* + TRANSS = TRANS + MS = M + NS = N + KLS = KL + KUS = KU + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LX + XS( I ) = XX( I ) + 20 CONTINUE + INCXS = INCX + BLS = BETA + DO 30 I = 1, LY + YS( I ) = YY( I ) + 30 CONTINUE + INCYS = INCY +* +* Call the subroutine. +* + IF( FULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9994 )NC, SNAME, + $ CTRANS, M, N, ALPHA, LDA, INCX, BETA, + $ INCY + IF( REWI ) + $ REWIND NTRA + CALL CZGEMV( IORDER, TRANS, M, N, + $ ALPHA, AA, LDA, XX, INCX, + $ BETA, YY, INCY ) + ELSE IF( BANDED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9995 )NC, SNAME, + $ CTRANS, M, N, KL, KU, ALPHA, LDA, + $ INCX, BETA, INCY + IF( REWI ) + $ REWIND NTRA + CALL CZGBMV( IORDER, TRANS, M, N, KL, + $ KU, ALPHA, AA, LDA, XX, + $ INCX, BETA, YY, INCY ) + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9993 ) + FATAL = .TRUE. + GO TO 130 + END IF +* +* See what data changed inside subroutines. +* +* IF(TRANS .NE. 'C' .OR. (INCX .GT. 0 .AND. INCY .GT. 0)) THEN + ISAME( 1 ) = TRANS.EQ.TRANSS + ISAME( 2 ) = MS.EQ.M + ISAME( 3 ) = NS.EQ.N + IF( FULL )THEN + ISAME( 4 ) = ALS.EQ.ALPHA + ISAME( 5 ) = LZE( AS, AA, LAA ) + ISAME( 6 ) = LDAS.EQ.LDA + ISAME( 7 ) = LZE( XS, XX, LX ) + ISAME( 8 ) = INCXS.EQ.INCX + ISAME( 9 ) = BLS.EQ.BETA + IF( NULL )THEN + ISAME( 10 ) = LZE( YS, YY, LY ) + ELSE + ISAME( 10 ) = LZERES( 'ge', ' ', 1, + $ ML, YS, YY, + $ ABS( INCY ) ) + END IF + ISAME( 11 ) = INCYS.EQ.INCY + ELSE IF( BANDED )THEN + ISAME( 4 ) = KLS.EQ.KL + ISAME( 5 ) = KUS.EQ.KU + ISAME( 6 ) = ALS.EQ.ALPHA + ISAME( 7 ) = LZE( AS, AA, LAA ) + ISAME( 8 ) = LDAS.EQ.LDA + ISAME( 9 ) = LZE( XS, XX, LX ) + ISAME( 10 ) = INCXS.EQ.INCX + ISAME( 11 ) = BLS.EQ.BETA + IF( NULL )THEN + ISAME( 12 ) = LZE( YS, YY, LY ) + ELSE + ISAME( 12 ) = LZERES( 'ge', ' ', 1, + $ ML, YS, YY, + $ ABS( INCY ) ) + END IF + ISAME( 13 ) = INCYS.EQ.INCY + END IF +* +* If data was incorrectly changed, report +* and return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 130 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result. +* + CALL ZMVCH( TRANS, M, N, ALPHA, A, + $ NMAX, X, INCX, BETA, Y, + $ INCY, YT, G, YY, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and +* return. + IF( FATAL ) + $ GO TO 130 + ELSE +* Avoid repeating tests with M.le.0 or +* N.le.0. + GO TO 110 + END IF +* END IF +* + 50 CONTINUE +* + 60 CONTINUE +* + 70 CONTINUE +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* + 110 CONTINUE +* + 120 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + WRITE( NOUT, FMT = 9999 )SNAME, NC + ELSE + WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX + END IF + GO TO 140 +* + 130 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + IF( FULL )THEN + WRITE( NOUT, FMT = 9994 )NC, SNAME, CTRANS, M, N, ALPHA, LDA, + $ INCX, BETA, INCY + ELSE IF( BANDED )THEN + WRITE( NOUT, FMT = 9995 )NC, SNAME, CTRANS, M, N, KL, KU, + $ ALPHA, LDA, INCX, BETA, INCY + END IF +* + 140 CONTINUE + RETURN +* + 9999 FORMAT(' ',A12, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + $ 'S)' ) + 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9997 FORMAT(' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, + $ ' - SUSPECT *******' ) + 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', 4( I3, ',' ), '(', + $ F4.1, ',', F4.1, '), A,',/ 10x, I3, ', X,', I2, ',(', + $ F4.1, ',', F4.1, '), Y,', I2, ') .' ) + 9994 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', 2( I3, ',' ), '(', + $ F4.1, ',', F4.1, '), A,',/ 10x, I3, ', X,', I2, ',(', + $ F4.1, ',', F4.1, '), Y,', I2, ') .' ) + 9993 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of ZCHK1. +* + END + SUBROUTINE ZCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, + $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, + $ XS, Y, YY, YS, YT, G, IORDER ) +* +* Tests CHEMV, CHBMV and CHPMV. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + COMPLEX*16 ZERO, HALF + PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), + $ HALF = ( 0.5D0, 0.0D0 ) ) + DOUBLE PRECISION RZERO + PARAMETER ( RZERO = 0.0D0 ) +* .. Scalar Arguments .. + DOUBLE PRECISION EPS, THRESH + INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, + $ NOUT, NTRA, IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), BET( NBET ), X( NMAX ), + $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), + $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), + $ YY( NMAX*INCMAX ) + DOUBLE PRECISION G( NMAX ) + INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) +* .. Local Scalars .. + COMPLEX*16 ALPHA, ALS, BETA, BLS, TRANSL + DOUBLE PRECISION ERR, ERRMAX + INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY, + $ INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY, + $ N, NARGS, NC, NK, NS + LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME + CHARACTER*1 UPLO, UPLOS + CHARACTER*14 CUPLO + CHARACTER*2 ICH +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LZE, LZERES + EXTERNAL LZE, LZERES +* .. External Subroutines .. + EXTERNAL CZHBMV, CZHEMV, CZHPMV, ZMAKE, ZMVCH +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICH/'UL'/ +* .. Executable Statements .. + FULL = SNAME( 9: 9 ).EQ.'e' + BANDED = SNAME( 9: 9 ).EQ.'b' + PACKED = SNAME( 9: 9 ).EQ.'p' +* Define the number of arguments. + IF( FULL )THEN + NARGS = 10 + ELSE IF( BANDED )THEN + NARGS = 11 + ELSE IF( PACKED )THEN + NARGS = 9 + END IF +* + NC = 0 + RESET = .TRUE. + ERRMAX = RZERO +* + DO 110 IN = 1, NIDIM + N = IDIM( IN ) +* + IF( BANDED )THEN + NK = NKB + ELSE + NK = 1 + END IF + DO 100 IK = 1, NK + IF( BANDED )THEN + K = KB( IK ) + ELSE + K = N - 1 + END IF +* Set LDA to 1 more than minimum value if room. + IF( BANDED )THEN + LDA = K + 1 + ELSE + LDA = N + END IF + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 100 + IF( PACKED )THEN + LAA = ( N*( N + 1 ) )/2 + ELSE + LAA = LDA*N + END IF + NULL = N.LE.0 +* + DO 90 IC = 1, 2 + UPLO = ICH( IC: IC ) + IF (UPLO.EQ.'U')THEN + CUPLO = ' CblasUpper' + ELSE + CUPLO = ' CblasLower' + END IF +* +* Generate the matrix A. +* + TRANSL = ZERO + CALL ZMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, A, NMAX, AA, + $ LDA, K, K, RESET, TRANSL ) +* + DO 80 IX = 1, NINC + INCX = INC( IX ) + LX = ABS( INCX )*N +* +* Generate the vector X. +* + TRANSL = HALF + CALL ZMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX, + $ ABS( INCX ), 0, N - 1, RESET, TRANSL ) + IF( N.GT.1 )THEN + X( N/2 ) = ZERO + XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO + END IF +* + DO 70 IY = 1, NINC + INCY = INC( IY ) + LY = ABS( INCY )*N +* + DO 60 IA = 1, NALF + ALPHA = ALF( IA ) +* + DO 50 IB = 1, NBET + BETA = BET( IB ) +* +* Generate the vector Y. +* + TRANSL = ZERO + CALL ZMAKE( 'ge', ' ', ' ', 1, N, Y, 1, YY, + $ ABS( INCY ), 0, N - 1, RESET, + $ TRANSL ) +* + NC = NC + 1 +* +* Save every datum before calling the +* subroutine. +* + UPLOS = UPLO + NS = N + KS = K + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LX + XS( I ) = XX( I ) + 20 CONTINUE + INCXS = INCX + BLS = BETA + DO 30 I = 1, LY + YS( I ) = YY( I ) + 30 CONTINUE + INCYS = INCY +* +* Call the subroutine. +* + IF( FULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, + $ CUPLO, N, ALPHA, LDA, INCX, BETA, INCY + IF( REWI ) + $ REWIND NTRA + CALL CZHEMV( IORDER, UPLO, N, ALPHA, AA, + $ LDA, XX, INCX, BETA, YY, + $ INCY ) + ELSE IF( BANDED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9994 )NC, SNAME, + $ CUPLO, N, K, ALPHA, LDA, INCX, BETA, + $ INCY + IF( REWI ) + $ REWIND NTRA + CALL CZHBMV( IORDER, UPLO, N, K, ALPHA, + $ AA, LDA, XX, INCX, BETA, + $ YY, INCY ) + ELSE IF( PACKED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9995 )NC, SNAME, + $ CUPLO, N, ALPHA, INCX, BETA, INCY + IF( REWI ) + $ REWIND NTRA + CALL CZHPMV( IORDER, UPLO, N, ALPHA, AA, + $ XX, INCX, BETA, YY, INCY ) + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9992 ) + FATAL = .TRUE. + GO TO 120 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = UPLO.EQ.UPLOS + ISAME( 2 ) = NS.EQ.N + IF( FULL )THEN + ISAME( 3 ) = ALS.EQ.ALPHA + ISAME( 4 ) = LZE( AS, AA, LAA ) + ISAME( 5 ) = LDAS.EQ.LDA + ISAME( 6 ) = LZE( XS, XX, LX ) + ISAME( 7 ) = INCXS.EQ.INCX + ISAME( 8 ) = BLS.EQ.BETA + IF( NULL )THEN + ISAME( 9 ) = LZE( YS, YY, LY ) + ELSE + ISAME( 9 ) = LZERES( 'ge', ' ', 1, N, + $ YS, YY, ABS( INCY ) ) + END IF + ISAME( 10 ) = INCYS.EQ.INCY + ELSE IF( BANDED )THEN + ISAME( 3 ) = KS.EQ.K + ISAME( 4 ) = ALS.EQ.ALPHA + ISAME( 5 ) = LZE( AS, AA, LAA ) + ISAME( 6 ) = LDAS.EQ.LDA + ISAME( 7 ) = LZE( XS, XX, LX ) + ISAME( 8 ) = INCXS.EQ.INCX + ISAME( 9 ) = BLS.EQ.BETA + IF( NULL )THEN + ISAME( 10 ) = LZE( YS, YY, LY ) + ELSE + ISAME( 10 ) = LZERES( 'ge', ' ', 1, N, + $ YS, YY, ABS( INCY ) ) + END IF + ISAME( 11 ) = INCYS.EQ.INCY + ELSE IF( PACKED )THEN + ISAME( 3 ) = ALS.EQ.ALPHA + ISAME( 4 ) = LZE( AS, AA, LAA ) + ISAME( 5 ) = LZE( XS, XX, LX ) + ISAME( 6 ) = INCXS.EQ.INCX + ISAME( 7 ) = BLS.EQ.BETA + IF( NULL )THEN + ISAME( 8 ) = LZE( YS, YY, LY ) + ELSE + ISAME( 8 ) = LZERES( 'ge', ' ', 1, N, + $ YS, YY, ABS( INCY ) ) + END IF + ISAME( 9 ) = INCYS.EQ.INCY + END IF +* +* If data was incorrectly changed, report and +* return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 120 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result. +* + CALL ZMVCH( 'N', N, N, ALPHA, A, NMAX, X, + $ INCX, BETA, Y, INCY, YT, G, + $ YY, EPS, ERR, FATAL, NOUT, + $ .TRUE. ) + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and +* return. + IF( FATAL ) + $ GO TO 120 + ELSE +* Avoid repeating tests with N.le.0 + GO TO 110 + END IF +* + 50 CONTINUE +* + 60 CONTINUE +* + 70 CONTINUE +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* + 110 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + WRITE( NOUT, FMT = 9999 )SNAME, NC + ELSE + WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX + END IF + GO TO 130 +* + 120 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + IF( FULL )THEN + WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, N, ALPHA, LDA, INCX, + $ BETA, INCY + ELSE IF( BANDED )THEN + WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, N, K, ALPHA, LDA, + $ INCX, BETA, INCY + ELSE IF( PACKED )THEN + WRITE( NOUT, FMT = 9995 )NC, SNAME, CUPLO, N, ALPHA, INCX, + $ BETA, INCY + END IF +* + 130 CONTINUE + RETURN +* + 9999 FORMAT(' ',A12, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + $ 'S)' ) + 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9997 FORMAT(' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, + $ ' - SUSPECT *******' ) + 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',(', F4.1, ',', + $ F4.1, '), AP, X,',/ 10x, I2, ',(', F4.1, ',', F4.1, + $ '), Y,', I2, ') .' ) + 9994 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', 2( I3, ',' ), '(', + $ F4.1, ',', F4.1, '), A,', I3, ', X,',/ 10x, I2, ',(', + $ F4.1, ',', F4.1, '), Y,', I2, ') .' ) + 9993 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',(', F4.1, ',', + $ F4.1, '), A,', I3, ', X,',/ 10x, I2, ',(', F4.1, ',', + $ F4.1, '), ', 'Y,', I2, ') .' ) + 9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of CZHK2. +* + END + SUBROUTINE ZCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX, + $ INCMAX, A, AA, AS, X, XX, XS, XT, G, Z, IORDER ) +* +* Tests ZTRMV, ZTBMV, ZTPMV, ZTRSV, ZTBSV and ZTPSV. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + COMPLEX*16 ZERO, HALF, ONE + PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), + $ HALF = ( 0.5D0, 0.0D0 ), + $ ONE = ( 1.0D0, 0.0D0 ) ) + DOUBLE PRECISION RZERO + PARAMETER ( RZERO = 0.0D0 ) +* .. Scalar Arguments .. + DOUBLE PRECISION EPS, THRESH + INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA, + $ IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), + $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), + $ XT( NMAX ), XX( NMAX*INCMAX ), Z( NMAX ) + DOUBLE PRECISION G( NMAX ) + INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) +* .. Local Scalars .. + COMPLEX*16 TRANSL + DOUBLE PRECISION ERR, ERRMAX + INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K, + $ KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS + LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME + CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS + CHARACTER*14 CUPLO,CTRANS,CDIAG + CHARACTER*2 ICHD, ICHU + CHARACTER*3 ICHT +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LZE, LZERES + EXTERNAL LZE, LZERES +* .. External Subroutines .. + EXTERNAL ZMAKE, ZMVCH, CZTBMV, CZTBSV, CZTPMV, + $ CZTPSV, CZTRMV, CZTRSV +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/ +* .. Executable Statements .. + FULL = SNAME( 9: 9 ).EQ.'r' + BANDED = SNAME( 9: 9 ).EQ.'b' + PACKED = SNAME( 9: 9 ).EQ.'p' +* Define the number of arguments. + IF( FULL )THEN + NARGS = 8 + ELSE IF( BANDED )THEN + NARGS = 9 + ELSE IF( PACKED )THEN + NARGS = 7 + END IF +* + NC = 0 + RESET = .TRUE. + ERRMAX = RZERO +* Set up zero vector for ZMVCH. + DO 10 I = 1, NMAX + Z( I ) = ZERO + 10 CONTINUE +* + DO 110 IN = 1, NIDIM + N = IDIM( IN ) +* + IF( BANDED )THEN + NK = NKB + ELSE + NK = 1 + END IF + DO 100 IK = 1, NK + IF( BANDED )THEN + K = KB( IK ) + ELSE + K = N - 1 + END IF +* Set LDA to 1 more than minimum value if room. + IF( BANDED )THEN + LDA = K + 1 + ELSE + LDA = N + END IF + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 100 + IF( PACKED )THEN + LAA = ( N*( N + 1 ) )/2 + ELSE + LAA = LDA*N + END IF + NULL = N.LE.0 +* + DO 90 ICU = 1, 2 + UPLO = ICHU( ICU: ICU ) + IF (UPLO.EQ.'U')THEN + CUPLO = ' CblasUpper' + ELSE + CUPLO = ' CblasLower' + END IF +* + DO 80 ICT = 1, 3 + TRANS = ICHT( ICT: ICT ) + IF (TRANS.EQ.'N')THEN + CTRANS = ' CblasNoTrans' + ELSE IF (TRANS.EQ.'T')THEN + CTRANS = ' CblasTrans' + ELSE + CTRANS = 'CblasConjTrans' + END IF +* + DO 70 ICD = 1, 2 + DIAG = ICHD( ICD: ICD ) + IF (DIAG.EQ.'N')THEN + CDIAG = ' CblasNonUnit' + ELSE + CDIAG = ' CblasUnit' + END IF +* +* Generate the matrix A. +* + TRANSL = ZERO + CALL ZMAKE( SNAME( 8: 9 ), UPLO, DIAG, N, N, A, + $ NMAX, AA, LDA, K, K, RESET, TRANSL ) +* + DO 60 IX = 1, NINC + INCX = INC( IX ) + LX = ABS( INCX )*N +* +* Generate the vector X. +* + TRANSL = HALF + CALL ZMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX, + $ ABS( INCX ), 0, N - 1, RESET, + $ TRANSL ) + IF( N.GT.1 )THEN + X( N/2 ) = ZERO + XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO + END IF +* + NC = NC + 1 +* +* Save every datum before calling the subroutine. +* + UPLOS = UPLO + TRANSS = TRANS + DIAGS = DIAG + NS = N + KS = K + DO 20 I = 1, LAA + AS( I ) = AA( I ) + 20 CONTINUE + LDAS = LDA + DO 30 I = 1, LX + XS( I ) = XX( I ) + 30 CONTINUE + INCXS = INCX +* +* Call the subroutine. +* + IF( SNAME( 4: 5 ).EQ.'mv' )THEN + IF( FULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, + $ CUPLO, CTRANS, CDIAG, N, LDA, INCX + IF( REWI ) + $ REWIND NTRA + CALL CZTRMV( IORDER, UPLO, TRANS, DIAG, + $ N, AA, LDA, XX, INCX ) + ELSE IF( BANDED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9994 )NC, SNAME, + $ CUPLO, CTRANS, CDIAG, N, K, LDA, INCX + IF( REWI ) + $ REWIND NTRA + CALL CZTBMV( IORDER, UPLO, TRANS, DIAG, + $ N, K, AA, LDA, XX, INCX ) + ELSE IF( PACKED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9995 )NC, SNAME, + $ CUPLO, CTRANS, CDIAG, N, INCX + IF( REWI ) + $ REWIND NTRA + CALL CZTPMV( IORDER, UPLO, TRANS, DIAG, + $ N, AA, XX, INCX ) + END IF + ELSE IF( SNAME( 4: 5 ).EQ.'sv' )THEN + IF( FULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, + $ CUPLO, CTRANS, CDIAG, N, LDA, INCX + IF( REWI ) + $ REWIND NTRA + CALL CZTRSV( IORDER, UPLO, TRANS, DIAG, + $ N, AA, LDA, XX, INCX ) + ELSE IF( BANDED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9994 )NC, SNAME, + $ CUPLO, CTRANS, CDIAG, N, K, LDA, INCX + IF( REWI ) + $ REWIND NTRA + CALL CZTBSV( IORDER, UPLO, TRANS, DIAG, + $ N, K, AA, LDA, XX, INCX ) + ELSE IF( PACKED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9995 )NC, SNAME, + $ CUPLO, CTRANS, CDIAG, N, INCX + IF( REWI ) + $ REWIND NTRA + CALL CZTPSV( IORDER, UPLO, TRANS, DIAG, + $ N, AA, XX, INCX ) + END IF + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9992 ) + FATAL = .TRUE. + GO TO 120 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = UPLO.EQ.UPLOS + ISAME( 2 ) = TRANS.EQ.TRANSS + ISAME( 3 ) = DIAG.EQ.DIAGS + ISAME( 4 ) = NS.EQ.N + IF( FULL )THEN + ISAME( 5 ) = LZE( AS, AA, LAA ) + ISAME( 6 ) = LDAS.EQ.LDA + IF( NULL )THEN + ISAME( 7 ) = LZE( XS, XX, LX ) + ELSE + ISAME( 7 ) = LZERES( 'ge', ' ', 1, N, XS, + $ XX, ABS( INCX ) ) + END IF + ISAME( 8 ) = INCXS.EQ.INCX + ELSE IF( BANDED )THEN + ISAME( 5 ) = KS.EQ.K + ISAME( 6 ) = LZE( AS, AA, LAA ) + ISAME( 7 ) = LDAS.EQ.LDA + IF( NULL )THEN + ISAME( 8 ) = LZE( XS, XX, LX ) + ELSE + ISAME( 8 ) = LZERES( 'ge', ' ', 1, N, XS, + $ XX, ABS( INCX ) ) + END IF + ISAME( 9 ) = INCXS.EQ.INCX + ELSE IF( PACKED )THEN + ISAME( 5 ) = LZE( AS, AA, LAA ) + IF( NULL )THEN + ISAME( 6 ) = LZE( XS, XX, LX ) + ELSE + ISAME( 6 ) = LZERES( 'ge', ' ', 1, N, XS, + $ XX, ABS( INCX ) ) + END IF + ISAME( 7 ) = INCXS.EQ.INCX + END IF +* +* If data was incorrectly changed, report and +* return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 120 + END IF +* + IF( .NOT.NULL )THEN + IF( SNAME( 4: 5 ).EQ.'mv' )THEN +* +* Check the result. +* + CALL ZMVCH( TRANS, N, N, ONE, A, NMAX, X, + $ INCX, ZERO, Z, INCX, XT, G, + $ XX, EPS, ERR, FATAL, NOUT, + $ .TRUE. ) + ELSE IF( SNAME( 4: 5 ).EQ.'sv' )THEN +* +* Compute approximation to original vector. +* + DO 50 I = 1, N + Z( I ) = XX( 1 + ( I - 1 )* + $ ABS( INCX ) ) + XX( 1 + ( I - 1 )*ABS( INCX ) ) + $ = X( I ) + 50 CONTINUE + CALL ZMVCH( TRANS, N, N, ONE, A, NMAX, Z, + $ INCX, ZERO, X, INCX, XT, G, + $ XX, EPS, ERR, FATAL, NOUT, + $ .FALSE. ) + END IF + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and return. + IF( FATAL ) + $ GO TO 120 + ELSE +* Avoid repeating tests with N.le.0. + GO TO 110 + END IF +* + 60 CONTINUE +* + 70 CONTINUE +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* + 110 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + WRITE( NOUT, FMT = 9999 )SNAME, NC + ELSE + WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX + END IF + GO TO 130 +* + 120 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + IF( FULL )THEN + WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, CTRANS, CDIAG, N, + $ LDA, INCX + ELSE IF( BANDED )THEN + WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, CTRANS, CDIAG, N, K, + $ LDA, INCX + ELSE IF( PACKED )THEN + WRITE( NOUT, FMT = 9995 )NC, SNAME, CUPLO, CTRANS, CDIAG, N, + $ INCX + END IF +* + 130 CONTINUE + RETURN +* + 9999 FORMAT(' ',A12, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + $ 'S)' ) + 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9997 FORMAT(' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, + $ ' - SUSPECT *******' ) + 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT(1X, I6, ': ',A12, '(', 3( A14, ',' ),/ 10x, I3, ', AP, ', + $ 'X,', I2, ') .' ) + 9994 FORMAT(1X, I6, ': ',A12, '(', 3( A14, ',' ),/ 10x, 2( I3, ',' ), + $ ' A,', I3, ', X,', I2, ') .' ) + 9993 FORMAT( 1X, I6, ': ',A12, '(', 3( A14, ',' ),/ 10x, I3, ', A,', + $ I3, ', X,', I2, ') .' ) + 9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of ZCHK3. +* + END + SUBROUTINE ZCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, + $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, + $ Z, IORDER ) +* +* Tests ZGERC and ZGERU. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + COMPLEX*16 ZERO, HALF, ONE + PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), + $ HALF = ( 0.5D0, 0.0D0 ), + $ ONE = ( 1.0D0, 0.0D0 ) ) + DOUBLE PRECISION RZERO + PARAMETER ( RZERO = 0.0D0 ) +* .. Scalar Arguments .. + DOUBLE PRECISION EPS, THRESH + INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA, + $ IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), + $ XX( NMAX*INCMAX ), Y( NMAX ), + $ YS( NMAX*INCMAX ), YT( NMAX ), + $ YY( NMAX*INCMAX ), Z( NMAX ) + DOUBLE PRECISION G( NMAX ) + INTEGER IDIM( NIDIM ), INC( NINC ) +* .. Local Scalars .. + COMPLEX*16 ALPHA, ALS, TRANSL + DOUBLE PRECISION ERR, ERRMAX + INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX, + $ IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS, + $ NC, ND, NS + LOGICAL CONJ, NULL, RESET, SAME +* .. Local Arrays .. + COMPLEX*16 W( 1 ) + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LZE, LZERES + EXTERNAL LZE, LZERES +* .. External Subroutines .. + EXTERNAL CZGERC, CZGERU, ZMAKE, ZMVCH +* .. Intrinsic Functions .. + INTRINSIC ABS, DCONJG, MAX, MIN +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Executable Statements .. + CONJ = SNAME( 5: 5 ).EQ.'c' +* Define the number of arguments. + NARGS = 9 +* + NC = 0 + RESET = .TRUE. + ERRMAX = RZERO +* + DO 120 IN = 1, NIDIM + N = IDIM( IN ) + ND = N/2 + 1 +* + DO 110 IM = 1, 2 + IF( IM.EQ.1 ) + $ M = MAX( N - ND, 0 ) + IF( IM.EQ.2 ) + $ M = MIN( N + ND, NMAX ) +* +* Set LDA to 1 more than minimum value if room. + LDA = M + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 110 + LAA = LDA*N + NULL = N.LE.0.OR.M.LE.0 +* + DO 100 IX = 1, NINC + INCX = INC( IX ) + LX = ABS( INCX )*M +* +* Generate the vector X. +* + TRANSL = HALF + CALL ZMAKE( 'ge', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ), + $ 0, M - 1, RESET, TRANSL ) + IF( M.GT.1 )THEN + X( M/2 ) = ZERO + XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO + END IF +* + DO 90 IY = 1, NINC + INCY = INC( IY ) + LY = ABS( INCY )*N +* +* Generate the vector Y. +* + TRANSL = ZERO + CALL ZMAKE( 'ge', ' ', ' ', 1, N, Y, 1, YY, + $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) + IF( N.GT.1 )THEN + Y( N/2 ) = ZERO + YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO + END IF +* + DO 80 IA = 1, NALF + ALPHA = ALF( IA ) +* +* Generate the matrix A. +* + TRANSL = ZERO + CALL ZMAKE(SNAME( 8: 9 ), ' ', ' ', M, N, A, NMAX, + $ AA, LDA, M - 1, N - 1, RESET, TRANSL ) +* + NC = NC + 1 +* +* Save every datum before calling the subroutine. +* + MS = M + NS = N + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LX + XS( I ) = XX( I ) + 20 CONTINUE + INCXS = INCX + DO 30 I = 1, LY + YS( I ) = YY( I ) + 30 CONTINUE + INCYS = INCY +* +* Call the subroutine. +* + IF( TRACE ) + $ WRITE( NTRA, FMT = 9994 )NC, SNAME, M, N, + $ ALPHA, INCX, INCY, LDA + IF( CONJ )THEN + IF( REWI ) + $ REWIND NTRA + CALL CZGERC( IORDER, M, N, ALPHA, XX, INCX, + $ YY, INCY, AA, LDA ) + ELSE + IF( REWI ) + $ REWIND NTRA + CALL CZGERU( IORDER, M, N, ALPHA, XX, INCX, + $ YY, INCY, AA, LDA ) + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9993 ) + FATAL = .TRUE. + GO TO 140 + END IF +* +* See what data changed inside subroutine. +* + ISAME( 1 ) = MS.EQ.M + ISAME( 2 ) = NS.EQ.N + ISAME( 3 ) = ALS.EQ.ALPHA + ISAME( 4 ) = LZE( XS, XX, LX ) + ISAME( 5 ) = INCXS.EQ.INCX + ISAME( 6 ) = LZE( YS, YY, LY ) + ISAME( 7 ) = INCYS.EQ.INCY + IF( NULL )THEN + ISAME( 8 ) = LZE( AS, AA, LAA ) + ELSE + ISAME( 8 ) = LZERES( 'ge', ' ', M, N, AS, AA, + $ LDA ) + END IF + ISAME( 9 ) = LDAS.EQ.LDA +* +* If data was incorrectly changed, report and return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 140 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result column by column. +* + IF( INCX.GT.0 )THEN + DO 50 I = 1, M + Z( I ) = X( I ) + 50 CONTINUE + ELSE + DO 60 I = 1, M + Z( I ) = X( M - I + 1 ) + 60 CONTINUE + END IF + DO 70 J = 1, N + IF( INCY.GT.0 )THEN + W( 1 ) = Y( J ) + ELSE + W( 1 ) = Y( N - J + 1 ) + END IF + IF( CONJ ) + $ W( 1 ) = DCONJG( W( 1 ) ) + CALL ZMVCH( 'N', M, 1, ALPHA, Z, NMAX, W, 1, + $ ONE, A( 1, J ), 1, YT, G, + $ AA( 1 + ( J - 1 )*LDA ), EPS, + $ ERR, FATAL, NOUT, .TRUE. ) + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and return. + IF( FATAL ) + $ GO TO 130 + 70 CONTINUE + ELSE +* Avoid repeating tests with M.le.0 or N.le.0. + GO TO 110 + END IF +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* + 110 CONTINUE +* + 120 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + WRITE( NOUT, FMT = 9999 )SNAME, NC + ELSE + WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX + END IF + GO TO 150 +* + 130 CONTINUE + WRITE( NOUT, FMT = 9995 )J +* + 140 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + WRITE( NOUT, FMT = 9994 )NC, SNAME, M, N, ALPHA, INCX, INCY, LDA +* + 150 CONTINUE + RETURN +* + 9999 FORMAT(' ',A12, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + $ 'S)' ) + 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9997 FORMAT(' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, + $ ' - SUSPECT *******' ) + 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) + 9994 FORMAT(1X, I6, ': ',A12, '(', 2( I3, ',' ), '(', F4.1, ',', F4.1, + $ '), X,', I2, ', Y,', I2, ', A,', I3, ') .' ) + 9993 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of ZCHK4. +* + END + SUBROUTINE ZCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, + $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, + $ Z, IORDER ) +* +* Tests ZHER and ZHPR. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + COMPLEX*16 ZERO, HALF, ONE + PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), + $ HALF = ( 0.5D0, 0.0D0 ), + $ ONE = ( 1.0D0, 0.0D0 ) ) + DOUBLE PRECISION RZERO + PARAMETER ( RZERO = 0.0D0 ) +* .. Scalar Arguments .. + DOUBLE PRECISION EPS, THRESH + INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA, + $ IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), + $ XX( NMAX*INCMAX ), Y( NMAX ), + $ YS( NMAX*INCMAX ), YT( NMAX ), + $ YY( NMAX*INCMAX ), Z( NMAX ) + DOUBLE PRECISION G( NMAX ) + INTEGER IDIM( NIDIM ), INC( NINC ) +* .. Local Scalars .. + COMPLEX*16 ALPHA, TRANSL + DOUBLE PRECISION ERR, ERRMAX, RALPHA, RALS + INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA, + $ LDA, LDAS, LJ, LX, N, NARGS, NC, NS + LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER + CHARACTER*1 UPLO, UPLOS + CHARACTER*14 CUPLO + CHARACTER*2 ICH +* .. Local Arrays .. + COMPLEX*16 W( 1 ) + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LZE, LZERES + EXTERNAL LZE, LZERES +* .. External Subroutines .. + EXTERNAL CZHER, CZHPR, ZMAKE, ZMVCH +* .. Intrinsic Functions .. + INTRINSIC ABS, DCMPLX, DCONJG, MAX, DBLE +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICH/'UL'/ +* .. Executable Statements .. + FULL = SNAME( 9: 9 ).EQ.'e' + PACKED = SNAME( 9: 9 ).EQ.'p' +* Define the number of arguments. + IF( FULL )THEN + NARGS = 7 + ELSE IF( PACKED )THEN + NARGS = 6 + END IF +* + NC = 0 + RESET = .TRUE. + ERRMAX = RZERO +* + DO 100 IN = 1, NIDIM + N = IDIM( IN ) +* Set LDA to 1 more than minimum value if room. + LDA = N + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 100 + IF( PACKED )THEN + LAA = ( N*( N + 1 ) )/2 + ELSE + LAA = LDA*N + END IF +* + DO 90 IC = 1, 2 + UPLO = ICH( IC: IC ) + IF (UPLO.EQ.'U')THEN + CUPLO = ' CblasUpper' + ELSE + CUPLO = ' CblasLower' + END IF + UPPER = UPLO.EQ.'U' +* + DO 80 IX = 1, NINC + INCX = INC( IX ) + LX = ABS( INCX )*N +* +* Generate the vector X. +* + TRANSL = HALF + CALL ZMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), + $ 0, N - 1, RESET, TRANSL ) + IF( N.GT.1 )THEN + X( N/2 ) = ZERO + XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO + END IF +* + DO 70 IA = 1, NALF + RALPHA = DBLE( ALF( IA ) ) + ALPHA = DCMPLX( RALPHA, RZERO ) + NULL = N.LE.0.OR.RALPHA.EQ.RZERO +* +* Generate the matrix A. +* + TRANSL = ZERO + CALL ZMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, A, NMAX, + $ AA, LDA, N - 1, N - 1, RESET, TRANSL ) +* + NC = NC + 1 +* +* Save every datum before calling the subroutine. +* + UPLOS = UPLO + NS = N + RALS = RALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LX + XS( I ) = XX( I ) + 20 CONTINUE + INCXS = INCX +* +* Call the subroutine. +* + IF( FULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, CUPLO, N, + $ RALPHA, INCX, LDA + IF( REWI ) + $ REWIND NTRA + CALL CZHER( IORDER, UPLO, N, RALPHA, XX, + $ INCX, AA, LDA ) + ELSE IF( PACKED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9994 )NC, SNAME, CUPLO, N, + $ RALPHA, INCX + IF( REWI ) + $ REWIND NTRA + CALL CZHPR( IORDER, UPLO, N, RALPHA, + $ XX, INCX, AA ) + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9992 ) + FATAL = .TRUE. + GO TO 120 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = UPLO.EQ.UPLOS + ISAME( 2 ) = NS.EQ.N + ISAME( 3 ) = RALS.EQ.RALPHA + ISAME( 4 ) = LZE( XS, XX, LX ) + ISAME( 5 ) = INCXS.EQ.INCX + IF( NULL )THEN + ISAME( 6 ) = LZE( AS, AA, LAA ) + ELSE + ISAME( 6 ) = LZERES( SNAME( 8: 9 ), UPLO, N, N, AS, + $ AA, LDA ) + END IF + IF( .NOT.PACKED )THEN + ISAME( 7 ) = LDAS.EQ.LDA + END IF +* +* If data was incorrectly changed, report and return. +* + SAME = .TRUE. + DO 30 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 30 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 120 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result column by column. +* + IF( INCX.GT.0 )THEN + DO 40 I = 1, N + Z( I ) = X( I ) + 40 CONTINUE + ELSE + DO 50 I = 1, N + Z( I ) = X( N - I + 1 ) + 50 CONTINUE + END IF + JA = 1 + DO 60 J = 1, N + W( 1 ) = DCONJG( Z( J ) ) + IF( UPPER )THEN + JJ = 1 + LJ = J + ELSE + JJ = J + LJ = N - J + 1 + END IF + CALL ZMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W, + $ 1, ONE, A( JJ, J ), 1, YT, G, + $ AA( JA ), EPS, ERR, FATAL, NOUT, + $ .TRUE. ) + IF( FULL )THEN + IF( UPPER )THEN + JA = JA + LDA + ELSE + JA = JA + LDA + 1 + END IF + ELSE + JA = JA + LJ + END IF + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and return. + IF( FATAL ) + $ GO TO 110 + 60 CONTINUE + ELSE +* Avoid repeating tests if N.le.0. + IF( N.LE.0 ) + $ GO TO 100 + END IF +* + 70 CONTINUE +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + WRITE( NOUT, FMT = 9999 )SNAME, NC + ELSE + WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX + END IF + GO TO 130 +* + 110 CONTINUE + WRITE( NOUT, FMT = 9995 )J +* + 120 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + IF( FULL )THEN + WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, N, RALPHA, INCX, LDA + ELSE IF( PACKED )THEN + WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, N, RALPHA, INCX + END IF +* + 130 CONTINUE + RETURN +* + 9999 FORMAT(' ',A12, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + $ 'S)' ) + 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9997 FORMAT(' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, + $ ' - SUSPECT *******' ) + 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) + 9994 FORMAT(1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', X,', + $ I2, ', AP) .' ) + 9993 FORMAT(1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', X,', + $ I2, ', A,', I3, ') .' ) + 9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of CZHK5. +* + END + SUBROUTINE ZCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, + $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, + $ Z, IORDER ) +* +* Tests ZHER2 and ZHPR2. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + COMPLEX*16 ZERO, HALF, ONE + PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), + $ HALF = ( 0.5D0, 0.0D0 ), + $ ONE = ( 1.0D0, 0.0D0 ) ) + DOUBLE PRECISION RZERO + PARAMETER ( RZERO = 0.0D0 ) +* .. Scalar Arguments .. + DOUBLE PRECISION EPS, THRESH + INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA, + $ IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), + $ XX( NMAX*INCMAX ), Y( NMAX ), + $ YS( NMAX*INCMAX ), YT( NMAX ), + $ YY( NMAX*INCMAX ), Z( NMAX, 2 ) + DOUBLE PRECISION G( NMAX ) + INTEGER IDIM( NIDIM ), INC( NINC ) +* .. Local Scalars .. + COMPLEX*16 ALPHA, ALS, TRANSL + DOUBLE PRECISION ERR, ERRMAX + INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX, + $ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N, + $ NARGS, NC, NS + LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER + CHARACTER*1 UPLO, UPLOS + CHARACTER*14 CUPLO + CHARACTER*2 ICH +* .. Local Arrays .. + COMPLEX*16 W( 2 ) + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LZE, LZERES + EXTERNAL LZE, LZERES +* .. External Subroutines .. + EXTERNAL CZHER2, CZHPR2, ZMAKE, ZMVCH +* .. Intrinsic Functions .. + INTRINSIC ABS, DCONJG, MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK +* .. Data statements .. + DATA ICH/'UL'/ +* .. Executable Statements .. + FULL = SNAME( 9: 9 ).EQ.'e' + PACKED = SNAME( 9: 9 ).EQ.'p' +* Define the number of arguments. + IF( FULL )THEN + NARGS = 9 + ELSE IF( PACKED )THEN + NARGS = 8 + END IF +* + NC = 0 + RESET = .TRUE. + ERRMAX = RZERO +* + DO 140 IN = 1, NIDIM + N = IDIM( IN ) +* Set LDA to 1 more than minimum value if room. + LDA = N + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 140 + IF( PACKED )THEN + LAA = ( N*( N + 1 ) )/2 + ELSE + LAA = LDA*N + END IF +* + DO 130 IC = 1, 2 + UPLO = ICH( IC: IC ) + IF (UPLO.EQ.'U')THEN + CUPLO = ' CblasUpper' + ELSE + CUPLO = ' CblasLower' + END IF + UPPER = UPLO.EQ.'U' +* + DO 120 IX = 1, NINC + INCX = INC( IX ) + LX = ABS( INCX )*N +* +* Generate the vector X. +* + TRANSL = HALF + CALL ZMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), + $ 0, N - 1, RESET, TRANSL ) + IF( N.GT.1 )THEN + X( N/2 ) = ZERO + XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO + END IF +* + DO 110 IY = 1, NINC + INCY = INC( IY ) + LY = ABS( INCY )*N +* +* Generate the vector Y. +* + TRANSL = ZERO + CALL ZMAKE( 'ge', ' ', ' ', 1, N, Y, 1, YY, + $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) + IF( N.GT.1 )THEN + Y( N/2 ) = ZERO + YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO + END IF +* + DO 100 IA = 1, NALF + ALPHA = ALF( IA ) + NULL = N.LE.0.OR.ALPHA.EQ.ZERO +* +* Generate the matrix A. +* + TRANSL = ZERO + CALL ZMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, A, + $ NMAX, AA, LDA, N - 1, N - 1, RESET, + $ TRANSL ) +* + NC = NC + 1 +* +* Save every datum before calling the subroutine. +* + UPLOS = UPLO + NS = N + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LX + XS( I ) = XX( I ) + 20 CONTINUE + INCXS = INCX + DO 30 I = 1, LY + YS( I ) = YY( I ) + 30 CONTINUE + INCYS = INCY +* +* Call the subroutine. +* + IF( FULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, CUPLO, N, + $ ALPHA, INCX, INCY, LDA + IF( REWI ) + $ REWIND NTRA + CALL CZHER2( IORDER, UPLO, N, ALPHA, XX, INCX, + $ YY, INCY, AA, LDA ) + ELSE IF( PACKED )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9994 )NC, SNAME, CUPLO, N, + $ ALPHA, INCX, INCY + IF( REWI ) + $ REWIND NTRA + CALL CZHPR2( IORDER, UPLO, N, ALPHA, XX, INCX, + $ YY, INCY, AA ) + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9992 ) + FATAL = .TRUE. + GO TO 160 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = UPLO.EQ.UPLOS + ISAME( 2 ) = NS.EQ.N + ISAME( 3 ) = ALS.EQ.ALPHA + ISAME( 4 ) = LZE( XS, XX, LX ) + ISAME( 5 ) = INCXS.EQ.INCX + ISAME( 6 ) = LZE( YS, YY, LY ) + ISAME( 7 ) = INCYS.EQ.INCY + IF( NULL )THEN + ISAME( 8 ) = LZE( AS, AA, LAA ) + ELSE + ISAME( 8 ) = LZERES( SNAME( 8: 9 ), UPLO, N, N, + $ AS, AA, LDA ) + END IF + IF( .NOT.PACKED )THEN + ISAME( 9 ) = LDAS.EQ.LDA + END IF +* +* If data was incorrectly changed, report and return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 160 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result column by column. +* + IF( INCX.GT.0 )THEN + DO 50 I = 1, N + Z( I, 1 ) = X( I ) + 50 CONTINUE + ELSE + DO 60 I = 1, N + Z( I, 1 ) = X( N - I + 1 ) + 60 CONTINUE + END IF + IF( INCY.GT.0 )THEN + DO 70 I = 1, N + Z( I, 2 ) = Y( I ) + 70 CONTINUE + ELSE + DO 80 I = 1, N + Z( I, 2 ) = Y( N - I + 1 ) + 80 CONTINUE + END IF + JA = 1 + DO 90 J = 1, N + W( 1 ) = ALPHA*DCONJG( Z( J, 2 ) ) + W( 2 ) = DCONJG( ALPHA )*DCONJG( Z( J, 1 ) ) + IF( UPPER )THEN + JJ = 1 + LJ = J + ELSE + JJ = J + LJ = N - J + 1 + END IF + CALL ZMVCH( 'N', LJ, 2, ONE, Z( JJ, 1 ), + $ NMAX, W, 1, ONE, A( JJ, J ), 1, + $ YT, G, AA( JA ), EPS, ERR, FATAL, + $ NOUT, .TRUE. ) + IF( FULL )THEN + IF( UPPER )THEN + JA = JA + LDA + ELSE + JA = JA + LDA + 1 + END IF + ELSE + JA = JA + LJ + END IF + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and return. + IF( FATAL ) + $ GO TO 150 + 90 CONTINUE + ELSE +* Avoid repeating tests with N.le.0. + IF( N.LE.0 ) + $ GO TO 140 + END IF +* + 100 CONTINUE +* + 110 CONTINUE +* + 120 CONTINUE +* + 130 CONTINUE +* + 140 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + WRITE( NOUT, FMT = 9999 )SNAME, NC + ELSE + WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX + END IF + GO TO 170 +* + 150 CONTINUE + WRITE( NOUT, FMT = 9995 )J +* + 160 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + IF( FULL )THEN + WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, N, ALPHA, INCX, + $ INCY, LDA + ELSE IF( PACKED )THEN + WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, N, ALPHA, INCX, INCY + END IF +* + 170 CONTINUE + RETURN +* + 9999 FORMAT(' ',A12, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + $ 'S)' ) + 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9997 FORMAT(' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, + $ ' - SUSPECT *******' ) + 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) + 9994 FORMAT(1X, I6, ': ',A12, '(', A14, ',', I3, ',(', F4.1, ',', + $ F4.1, '), X,', I2, ', Y,', I2, ', AP) .' ) + 9993 FORMAT(1X, I6, ': ',A12, '(', A14, ',', I3, ',(', F4.1, ',', + $ F4.1, '), X,', I2, ', Y,', I2, ', A,', I3, ') .' ) + 9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of ZCHK6. +* + END + SUBROUTINE ZMVCH( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y, + $ INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV ) +* +* Checks the results of the computational tests. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ) ) + DOUBLE PRECISION RZERO, RONE + PARAMETER ( RZERO = 0.0D0, RONE = 1.0D0 ) +* .. Scalar Arguments .. + COMPLEX*16 ALPHA, BETA + DOUBLE PRECISION EPS, ERR + INTEGER INCX, INCY, M, N, NMAX, NOUT + LOGICAL FATAL, MV + CHARACTER*1 TRANS +* .. Array Arguments .. + COMPLEX*16 A( NMAX, * ), X( * ), Y( * ), YT( * ), YY( * ) + DOUBLE PRECISION G( * ) +* .. Local Scalars .. + COMPLEX*16 C + DOUBLE PRECISION ERRI + INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL + LOGICAL CTRAN, TRAN +* .. Intrinsic Functions .. + INTRINSIC ABS, DIMAG, DCONJG, MAX, DBLE, SQRT +* .. Statement Functions .. + DOUBLE PRECISION ABS1 +* .. Statement Function definitions .. + ABS1( C ) = ABS( DBLE( C ) ) + ABS( DIMAG( C ) ) +* .. Executable Statements .. + TRAN = TRANS.EQ.'T' + CTRAN = TRANS.EQ.'C' + IF( TRAN.OR.CTRAN )THEN + ML = N + NL = M + ELSE + ML = M + NL = N + END IF + IF( INCX.LT.0 )THEN + KX = NL + INCXL = -1 + ELSE + KX = 1 + INCXL = 1 + END IF + IF( INCY.LT.0 )THEN + KY = ML + INCYL = -1 + ELSE + KY = 1 + INCYL = 1 + END IF +* +* Compute expected result in YT using data in A, X and Y. +* Compute gauges in G. +* + IY = KY + DO 40 I = 1, ML + YT( IY ) = ZERO + G( IY ) = RZERO + JX = KX + IF( TRAN )THEN + DO 10 J = 1, NL + YT( IY ) = YT( IY ) + A( J, I )*X( JX ) + G( IY ) = G( IY ) + ABS1( A( J, I ) )*ABS1( X( JX ) ) + JX = JX + INCXL + 10 CONTINUE + ELSE IF( CTRAN )THEN + DO 20 J = 1, NL + YT( IY ) = YT( IY ) + DCONJG( A( J, I ) )*X( JX ) + G( IY ) = G( IY ) + ABS1( A( J, I ) )*ABS1( X( JX ) ) + JX = JX + INCXL + 20 CONTINUE + ELSE + DO 30 J = 1, NL + YT( IY ) = YT( IY ) + A( I, J )*X( JX ) + G( IY ) = G( IY ) + ABS1( A( I, J ) )*ABS1( X( JX ) ) + JX = JX + INCXL + 30 CONTINUE + END IF + YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY ) + G( IY ) = ABS1( ALPHA )*G( IY ) + ABS1( BETA )*ABS1( Y( IY ) ) + IY = IY + INCYL + 40 CONTINUE +* +* Compute the error ratio for this result. +* + ERR = ZERO + DO 50 I = 1, ML + ERRI = ABS( YT( I ) - YY( 1 + ( I - 1 )*ABS( INCY ) ) )/EPS + IF( G( I ).NE.RZERO ) + $ ERRI = ERRI/G( I ) + ERR = MAX( ERR, ERRI ) + IF( ERR*SQRT( EPS ).GE.RONE ) + $ GO TO 60 + 50 CONTINUE +* If the loop completes, all results are at least half accurate. + GO TO 80 +* +* Report fatal error. +* + 60 FATAL = .TRUE. + WRITE( NOUT, FMT = 9999 ) + DO 70 I = 1, ML + IF( MV )THEN + WRITE( NOUT, FMT = 9998 )I, YT( I ), + $ YY( 1 + ( I - 1 )*ABS( INCY ) ) + ELSE + WRITE( NOUT, FMT = 9998 )I, + $ YY( 1 + ( I - 1 )*ABS( INCY ) ), YT( I ) + END IF + 70 CONTINUE +* + 80 CONTINUE + RETURN +* + 9999 FORMAT(' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', + $ 'F ACCURATE *******', /' EXPECTED RE', + $ 'SULT COMPUTED RESULT' ) + 9998 FORMAT( 1X, I7, 2( ' (', G15.6, ',', G15.6, ')' ) ) +* +* End of ZMVCH. +* + END + LOGICAL FUNCTION LZE( RI, RJ, LR ) +* +* Tests if two arrays are identical. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Scalar Arguments .. + INTEGER LR +* .. Array Arguments .. + COMPLEX*16 RI( * ), RJ( * ) +* .. Local Scalars .. + INTEGER I +* .. Executable Statements .. + DO 10 I = 1, LR + IF( RI( I ).NE.RJ( I ) ) + $ GO TO 20 + 10 CONTINUE + LZE = .TRUE. + GO TO 30 + 20 CONTINUE + LZE = .FALSE. + 30 RETURN +* +* End of LZE. +* + END + LOGICAL FUNCTION LZERES( TYPE, UPLO, M, N, AA, AS, LDA ) +* +* Tests if selected elements in two arrays are equal. +* +* TYPE is 'ge', 'he' or 'hp'. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Scalar Arguments .. + INTEGER LDA, M, N + CHARACTER*1 UPLO + CHARACTER*2 TYPE +* .. Array Arguments .. + COMPLEX*16 AA( LDA, * ), AS( LDA, * ) +* .. Local Scalars .. + INTEGER I, IBEG, IEND, J + LOGICAL UPPER +* .. Executable Statements .. + UPPER = UPLO.EQ.'U' + IF( TYPE.EQ.'ge' )THEN + DO 20 J = 1, N + DO 10 I = M + 1, LDA + IF( AA( I, J ).NE.AS( I, J ) ) + $ GO TO 70 + 10 CONTINUE + 20 CONTINUE + ELSE IF( TYPE.EQ.'he' )THEN + DO 50 J = 1, N + IF( UPPER )THEN + IBEG = 1 + IEND = J + ELSE + IBEG = J + IEND = N + END IF + DO 30 I = 1, IBEG - 1 + IF( AA( I, J ).NE.AS( I, J ) ) + $ GO TO 70 + 30 CONTINUE + DO 40 I = IEND + 1, LDA + IF( AA( I, J ).NE.AS( I, J ) ) + $ GO TO 70 + 40 CONTINUE + 50 CONTINUE + END IF +* + 60 CONTINUE + LZERES = .TRUE. + GO TO 80 + 70 CONTINUE + LZERES = .FALSE. + 80 RETURN +* +* End of LZERES. +* + END + COMPLEX*16 FUNCTION ZBEG( RESET ) +* +* Generates complex numbers as pairs of random numbers uniformly +* distributed between -0.5 and 0.5. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Scalar Arguments .. + LOGICAL RESET +* .. Local Scalars .. + INTEGER I, IC, J, MI, MJ +* .. Save statement .. + SAVE I, IC, J, MI, MJ +* .. Intrinsic Functions .. + INTRINSIC DCMPLX +* .. Executable Statements .. + IF( RESET )THEN +* Initialize local variables. + MI = 891 + MJ = 457 + I = 7 + J = 7 + IC = 0 + RESET = .FALSE. + END IF +* +* 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 = IC + 1 + 10 I = I*MI + J = J*MJ + I = I - 1000*( I/1000 ) + J = J - 1000*( J/1000 ) + IF( IC.GE.5 )THEN + IC = 0 + GO TO 10 + END IF + ZBEG = DCMPLX( ( I - 500 )/1001.0, ( J - 500 )/1001.0 ) + RETURN +* +* End of ZBEG. +* + END + DOUBLE PRECISION FUNCTION DDIFF( X, Y ) +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* +* .. Scalar Arguments .. + DOUBLE PRECISION X, Y +* .. Executable Statements .. + DDIFF = X - Y + RETURN +* +* End of DDIFF. +* + END + SUBROUTINE ZMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, + $ KU, RESET, TRANSL ) +* +* Generates values for an M by N matrix A within the bandwidth +* defined by KL and KU. +* Stores the values in the array AA in the data structure required +* by the routine, with unwanted elements set to rogue value. +* +* TYPE is 'ge', 'gb', 'he', 'hb', 'hp', 'tr', 'tb' OR 'tp'. +* +* Auxiliary routine for test program for Level 2 Blas. +* +* -- Written on 10-August-1987. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, NAG Central Office. +* +* .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), + $ ONE = ( 1.0D0, 0.0D0 ) ) + COMPLEX*16 ROGUE + PARAMETER ( ROGUE = ( -1.0D10, 1.0D10 ) ) + DOUBLE PRECISION RZERO + PARAMETER ( RZERO = 0.0D0 ) + DOUBLE PRECISION RROGUE + PARAMETER ( RROGUE = -1.0D10 ) +* .. Scalar Arguments .. + COMPLEX*16 TRANSL + INTEGER KL, KU, LDA, M, N, NMAX + LOGICAL RESET + CHARACTER*1 DIAG, UPLO + CHARACTER*2 TYPE +* .. Array Arguments .. + COMPLEX*16 A( NMAX, * ), AA( * ) +* .. Local Scalars .. + INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, JJ, KK + LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER +* .. External Functions .. + COMPLEX*16 ZBEG + EXTERNAL ZBEG +* .. Intrinsic Functions .. + INTRINSIC DCMPLX, DCONJG, MAX, MIN, DBLE +* .. Executable Statements .. + GEN = TYPE( 1: 1 ).EQ.'g' + SYM = TYPE( 1: 1 ).EQ.'h' + TRI = TYPE( 1: 1 ).EQ.'t' + UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U' + LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L' + UNIT = TRI.AND.DIAG.EQ.'U' +* +* Generate data in array A. +* + DO 20 J = 1, N + DO 10 I = 1, M + IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) + $ THEN + IF( ( I.LE.J.AND.J - I.LE.KU ).OR. + $ ( I.GE.J.AND.I - J.LE.KL ) )THEN + A( I, J ) = ZBEG( RESET ) + TRANSL + ELSE + A( I, J ) = ZERO + END IF + IF( I.NE.J )THEN + IF( SYM )THEN + A( J, I ) = DCONJG( A( I, J ) ) + ELSE IF( TRI )THEN + A( J, I ) = ZERO + END IF + END IF + END IF + 10 CONTINUE + IF( SYM ) + $ A( J, J ) = DCMPLX( DBLE( A( J, J ) ), RZERO ) + IF( TRI ) + $ A( J, J ) = A( J, J ) + ONE + IF( UNIT ) + $ A( J, J ) = ONE + 20 CONTINUE +* +* Store elements in array AS in data structure required by routine. +* + IF( TYPE.EQ.'ge' )THEN + DO 50 J = 1, N + DO 30 I = 1, M + AA( I + ( J - 1 )*LDA ) = A( I, J ) + 30 CONTINUE + DO 40 I = M + 1, LDA + AA( I + ( J - 1 )*LDA ) = ROGUE + 40 CONTINUE + 50 CONTINUE + ELSE IF( TYPE.EQ.'gb' )THEN + DO 90 J = 1, N + DO 60 I1 = 1, KU + 1 - J + AA( I1 + ( J - 1 )*LDA ) = ROGUE + 60 CONTINUE + DO 70 I2 = I1, MIN( KL + KU + 1, KU + 1 + M - J ) + AA( I2 + ( J - 1 )*LDA ) = A( I2 + J - KU - 1, J ) + 70 CONTINUE + DO 80 I3 = I2, LDA + AA( I3 + ( J - 1 )*LDA ) = ROGUE + 80 CONTINUE + 90 CONTINUE + ELSE IF( TYPE.EQ.'he'.OR.TYPE.EQ.'tr' )THEN + DO 130 J = 1, N + IF( UPPER )THEN + IBEG = 1 + IF( UNIT )THEN + IEND = J - 1 + ELSE + IEND = J + END IF + ELSE + IF( UNIT )THEN + IBEG = J + 1 + ELSE + IBEG = J + END IF + IEND = N + END IF + DO 100 I = 1, IBEG - 1 + AA( I + ( J - 1 )*LDA ) = ROGUE + 100 CONTINUE + DO 110 I = IBEG, IEND + AA( I + ( J - 1 )*LDA ) = A( I, J ) + 110 CONTINUE + DO 120 I = IEND + 1, LDA + AA( I + ( J - 1 )*LDA ) = ROGUE + 120 CONTINUE + IF( SYM )THEN + JJ = J + ( J - 1 )*LDA + AA( JJ ) = DCMPLX( DBLE( AA( JJ ) ), RROGUE ) + END IF + 130 CONTINUE + ELSE IF( TYPE.EQ.'hb'.OR.TYPE.EQ.'tb' )THEN + DO 170 J = 1, N + IF( UPPER )THEN + KK = KL + 1 + IBEG = MAX( 1, KL + 2 - J ) + IF( UNIT )THEN + IEND = KL + ELSE + IEND = KL + 1 + END IF + ELSE + KK = 1 + IF( UNIT )THEN + IBEG = 2 + ELSE + IBEG = 1 + END IF + IEND = MIN( KL + 1, 1 + M - J ) + END IF + DO 140 I = 1, IBEG - 1 + AA( I + ( J - 1 )*LDA ) = ROGUE + 140 CONTINUE + DO 150 I = IBEG, IEND + AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J ) + 150 CONTINUE + DO 160 I = IEND + 1, LDA + AA( I + ( J - 1 )*LDA ) = ROGUE + 160 CONTINUE + IF( SYM )THEN + JJ = KK + ( J - 1 )*LDA + AA( JJ ) = DCMPLX( DBLE( AA( JJ ) ), RROGUE ) + END IF + 170 CONTINUE + ELSE IF( TYPE.EQ.'hp'.OR.TYPE.EQ.'tp' )THEN + IOFF = 0 + DO 190 J = 1, N + IF( UPPER )THEN + IBEG = 1 + IEND = J + ELSE + IBEG = J + IEND = N + END IF + DO 180 I = IBEG, IEND + IOFF = IOFF + 1 + AA( IOFF ) = A( I, J ) + IF( I.EQ.J )THEN + IF( UNIT ) + $ AA( IOFF ) = ROGUE + IF( SYM ) + $ AA( IOFF ) = DCMPLX( DBLE( AA( IOFF ) ), RROGUE ) + END IF + 180 CONTINUE + 190 CONTINUE + END IF + RETURN +* +* End of ZMAKE. +* + END diff --git a/cblas/testing/c_zblat3.f b/cblas/testing/c_zblat3.f new file mode 100644 index 00000000..6e9dbbd8 --- /dev/null +++ b/cblas/testing/c_zblat3.f @@ -0,0 +1,2791 @@ + PROGRAM ZBLAT3 +* +* 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 .. + INTEGER NIN, NOUT + PARAMETER ( NIN = 5, NOUT = 6 ) + INTEGER NSUBS + PARAMETER ( NSUBS = 9 ) + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), + $ ONE = ( 1.0D0, 0.0D0 ) ) + DOUBLE PRECISION RZERO, RHALF, RONE + PARAMETER ( RZERO = 0.0D0, RHALF = 0.5D0, RONE = 1.0D0 ) + INTEGER NMAX + PARAMETER ( NMAX = 65 ) + INTEGER NIDMAX, NALMAX, NBEMAX + PARAMETER ( NIDMAX = 9, NALMAX = 7, NBEMAX = 7 ) +* .. Local Scalars .. + DOUBLE PRECISION EPS, ERR, THRESH + INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NTRA, + $ LAYOUT + LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, + $ TSTERR, CORDER, RORDER + CHARACTER*1 TRANSA, TRANSB + CHARACTER*12 SNAMET + CHARACTER*32 SNAPS +* .. Local Arrays .. + COMPLEX*16 AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ), + $ ALF( NALMAX ), AS( NMAX*NMAX ), + $ BB( NMAX*NMAX ), BET( NBEMAX ), + $ BS( NMAX*NMAX ), C( NMAX, NMAX ), + $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), + $ W( 2*NMAX ) + DOUBLE PRECISION G( NMAX ) + INTEGER IDIM( NIDMAX ) + LOGICAL LTEST( NSUBS ) + CHARACTER*12 SNAMES( NSUBS ) +* .. External Functions .. + DOUBLE PRECISION DDIFF + LOGICAL LZE + EXTERNAL DDIFF, LZE +* .. External Subroutines .. + EXTERNAL ZCHK1, ZCHK2, ZCHK3, ZCHK4, ZCHK5,ZMMCH +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL LERR, OK + CHARACTER*12 SRNAMT +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK, LERR + COMMON /SRNAMC/SRNAMT +* .. Data statements .. + DATA SNAMES/'cblas_zgemm ', 'cblas_zhemm ', + $ 'cblas_zsymm ', 'cblas_ztrmm ', 'cblas_ztrsm ', + $ 'cblas_zherk ', 'cblas_zsyrk ', 'cblas_zher2k', + $ 'cblas_zsyr2k'/ +* .. Executable Statements .. +* + NOUTC = NOUT +* +* Read name and unit number for snapshot output file and open file. +* + READ( NIN, FMT = * )SNAPS + READ( NIN, FMT = * )NTRA + TRACE = NTRA.GE.0 + IF( TRACE )THEN + OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' ) + END IF +* Read the flag that directs rewinding of the snapshot file. + READ( NIN, FMT = * )REWI + REWI = REWI.AND.TRACE +* Read the flag that directs stopping on any failure. + READ( NIN, FMT = * )SFATAL +* Read the flag that indicates whether error exits are to be tested. + READ( NIN, FMT = * )TSTERR +* Read the flag that indicates whether row-major data layout to be tested. + READ( NIN, FMT = * )LAYOUT +* Read the threshold value of the test ratio + READ( NIN, FMT = * )THRESH +* +* Read and check the parameter values for the tests. +* +* Values of N + READ( NIN, FMT = * )NIDIM + IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN + WRITE( NOUT, FMT = 9997 )'N', NIDMAX + GO TO 220 + END IF + READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) + DO 10 I = 1, NIDIM + IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN + WRITE( NOUT, FMT = 9996 )NMAX + GO TO 220 + END IF + 10 CONTINUE +* Values of ALPHA + READ( NIN, FMT = * )NALF + IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN + WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX + GO TO 220 + END IF + READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) +* Values of BETA + READ( NIN, FMT = * )NBET + IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN + WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX + GO TO 220 + END IF + READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) +* +* Report values of parameters. +* + WRITE( NOUT, FMT = 9995 ) + WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM ) + WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF ) + WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET ) + IF( .NOT.TSTERR )THEN + WRITE( NOUT, FMT = * ) + WRITE( NOUT, FMT = 9984 ) + END IF + WRITE( NOUT, FMT = * ) + WRITE( NOUT, FMT = 9999 )THRESH + WRITE( NOUT, FMT = * ) + + RORDER = .FALSE. + CORDER = .FALSE. + IF (LAYOUT.EQ.2) THEN + RORDER = .TRUE. + CORDER = .TRUE. + WRITE( *, FMT = 10002 ) + ELSE IF (LAYOUT.EQ.1) THEN + RORDER = .TRUE. + WRITE( *, FMT = 10001 ) + ELSE IF (LAYOUT.EQ.0) THEN + CORDER = .TRUE. + WRITE( *, FMT = 10000 ) + END IF + WRITE( *, FMT = * ) + +* +* Read names of subroutines and flags which indicate +* whether they are to be tested. +* + DO 20 I = 1, NSUBS + LTEST( I ) = .FALSE. + 20 CONTINUE + 30 READ( NIN, FMT = 9988, END = 60 )SNAMET, LTESTT + DO 40 I = 1, NSUBS + IF( SNAMET.EQ.SNAMES( I ) ) + $ GO TO 50 + 40 CONTINUE + WRITE( NOUT, FMT = 9990 )SNAMET + STOP + 50 LTEST( I ) = LTESTT + GO TO 30 +* + 60 CONTINUE + CLOSE ( NIN ) +* +* Compute EPS (the machine precision). +* + EPS = RONE + 70 CONTINUE + IF( DDIFF( RONE + EPS, RONE ).EQ.RZERO ) + $ GO TO 80 + EPS = RHALF*EPS + GO TO 70 + 80 CONTINUE + EPS = EPS + EPS + WRITE( NOUT, FMT = 9998 )EPS +* +* Check the reliability of ZMMCH using exact data. +* + N = MIN( 32, NMAX ) + DO 100 J = 1, N + DO 90 I = 1, N + AB( I, J ) = MAX( I - J + 1, 0 ) + 90 CONTINUE + AB( J, NMAX + 1 ) = J + AB( 1, NMAX + J ) = J + C( J, 1 ) = ZERO + 100 CONTINUE + DO 110 J = 1, N + CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 + 110 CONTINUE +* CC holds the exact result. On exit from ZMMCH CT holds +* the result computed by ZMMCH. + TRANSA = 'N' + TRANSB = 'N' + CALL ZMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, + $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, + $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) + SAME = LZE( CC, CT, N ) + IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN + WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR + STOP + END IF + TRANSB = 'C' + CALL ZMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, + $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, + $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) + SAME = LZE( CC, CT, N ) + IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN + WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR + STOP + END IF + DO 120 J = 1, N + AB( J, NMAX + 1 ) = N - J + 1 + AB( 1, NMAX + J ) = N - J + 1 + 120 CONTINUE + DO 130 J = 1, N + CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 - + $ ( ( J + 1 )*J*( J - 1 ) )/3 + 130 CONTINUE + TRANSA = 'C' + TRANSB = 'N' + CALL ZMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, + $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, + $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) + SAME = LZE( CC, CT, N ) + IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN + WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR + STOP + END IF + TRANSB = 'C' + CALL ZMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, + $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, + $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) + SAME = LZE( CC, CT, N ) + IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN + WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR + STOP + END IF +* +* Test each subroutine in turn. +* + DO 200 ISNUM = 1, NSUBS + WRITE( NOUT, FMT = * ) + IF( .NOT.LTEST( ISNUM ) )THEN +* Subprogram is not to be tested. + WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM ) + ELSE + SRNAMT = SNAMES( ISNUM ) +* Test error exits. + IF( TSTERR )THEN + CALL CZ3CHKE( SNAMES( ISNUM ) ) + WRITE( NOUT, FMT = * ) + END IF +* Test computations. + INFOT = 0 + OK = .TRUE. + FATAL = .FALSE. + GO TO ( 140, 150, 150, 160, 160, 170, 170, + $ 180, 180 )ISNUM +* Test ZGEMM, 01. + 140 IF (CORDER) THEN + CALL ZCHK1(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, + $ CC, CS, CT, G, 0 ) + END IF + IF (RORDER) THEN + CALL ZCHK1(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, + $ CC, CS, CT, G, 1 ) + END IF + GO TO 190 +* Test ZHEMM, 02, ZSYMM, 03. + 150 IF (CORDER) THEN + CALL ZCHK2(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, + $ CC, CS, CT, G, 0 ) + END IF + IF (RORDER) THEN + CALL ZCHK2(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, + $ CC, CS, CT, G, 1 ) + END IF + GO TO 190 +* Test ZTRMM, 04, ZTRSM, 05. + 160 IF (CORDER) THEN + CALL ZCHK3(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB, + $ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C, + $ 0 ) + END IF + IF (RORDER) THEN + CALL ZCHK3(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB, + $ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C, + $ 1 ) + END IF + GO TO 190 +* Test ZHERK, 06, ZSYRK, 07. + 170 IF (CORDER) THEN + CALL ZCHK4(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, + $ CC, CS, CT, G, 0 ) + END IF + IF (RORDER) THEN + CALL ZCHK4(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, + $ CC, CS, CT, G, 1 ) + END IF + GO TO 190 +* Test ZHER2K, 08, ZSYR2K, 09. + 180 IF (CORDER) THEN + CALL ZCHK5(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W, + $ 0 ) + END IF + IF (RORDER) THEN + CALL ZCHK5(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, + $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, + $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W, + $ 1 ) + END IF + GO TO 190 +* + 190 IF( FATAL.AND.SFATAL ) + $ GO TO 210 + END IF + 200 CONTINUE + WRITE( NOUT, FMT = 9986 ) + GO TO 230 +* + 210 CONTINUE + WRITE( NOUT, FMT = 9985 ) + GO TO 230 +* + 220 CONTINUE + WRITE( NOUT, FMT = 9991 ) +* + 230 CONTINUE + IF( TRACE ) + $ CLOSE ( NTRA ) + CLOSE ( NOUT ) + STOP +* +10002 FORMAT( ' COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED' ) +10001 FORMAT(' ROW-MAJOR DATA LAYOUT IS TESTED' ) +10000 FORMAT(' COLUMN-MAJOR DATA LAYOUT IS TESTED' ) + 9999 FORMAT(' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', + $ 'S THAN', F8.2 ) + 9998 FORMAT(' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 ) + 9997 FORMAT(' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', + $ 'THAN ', I2 ) + 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) + 9995 FORMAT('TESTS OF THE COMPLEX*16 LEVEL 3 BLAS', //' THE F', + $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) + 9994 FORMAT( ' FOR N ', 9I6 ) + 9993 FORMAT( ' FOR ALPHA ', + $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) + 9992 FORMAT( ' FOR BETA ', + $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) + 9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', + $ /' ******* TESTS ABANDONED *******' ) + 9990 FORMAT(' SUBPROGRAM NAME ', A12,' NOT RECOGNIZED', /' ******* T', + $ 'ESTS ABANDONED *******' ) + 9989 FORMAT(' ERROR IN ZMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', + $ 'ATED WRONGLY.', /' ZMMCH WAS CALLED WITH TRANSA = ', A1, + $ 'AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ', + $ ' ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ', + $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ', + $ '*******' ) + 9988 FORMAT( A12,L2 ) + 9987 FORMAT( 1X, A12,' WAS NOT TESTED' ) + 9986 FORMAT( /' END OF TESTS' ) + 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) + 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) +* +* End of ZBLAT3. +* + END + SUBROUTINE ZCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, + $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G, + $ IORDER ) +* +* 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 .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0, 0.0 ) ) + DOUBLE PRECISION RZERO + PARAMETER ( RZERO = 0.0 ) +* .. Scalar Arguments .. + DOUBLE PRECISION EPS, THRESH + INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), B( NMAX, NMAX ), + $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), + $ C( NMAX, NMAX ), CC( NMAX*NMAX ), + $ CS( NMAX*NMAX ), CT( NMAX ) + DOUBLE PRECISION G( NMAX ) + INTEGER IDIM( NIDIM ) +* .. Local Scalars .. + COMPLEX*16 ALPHA, ALS, BETA, BLS + DOUBLE PRECISION ERR, ERRMAX + INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA, + $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M, + $ MA, MB, MS, N, NA, NARGS, NB, NC, NS + LOGICAL NULL, RESET, SAME, TRANA, TRANB + CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB + CHARACTER*3 ICH +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LZE, LZERES + EXTERNAL LZE, LZERES +* .. External Subroutines .. + EXTERNAL CZGEMM, ZMAKE, ZMMCH +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL LERR, OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK, LERR +* .. Data statements .. + DATA ICH/'NTC'/ +* .. Executable Statements .. +* + NARGS = 13 + NC = 0 + RESET = .TRUE. + ERRMAX = RZERO +* + DO 110 IM = 1, NIDIM + M = IDIM( IM ) +* + DO 100 IN = 1, NIDIM + N = IDIM( IN ) +* Set LDC to 1 more than minimum value if room. + LDC = M + IF( LDC.LT.NMAX ) + $ LDC = LDC + 1 +* Skip tests if not enough room. + IF( LDC.GT.NMAX ) + $ GO TO 100 + LCC = LDC*N + NULL = N.LE.0.OR.M.LE.0 +* + DO 90 IK = 1, NIDIM + K = IDIM( IK ) +* + DO 80 ICA = 1, 3 + TRANSA = ICH( ICA: ICA ) + TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' +* + IF( TRANA )THEN + MA = K + NA = M + ELSE + MA = M + NA = K + END IF +* Set LDA to 1 more than minimum value if room. + LDA = MA + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 80 + LAA = LDA*NA +* +* Generate the matrix A. +* + CALL ZMAKE( 'ge', ' ', ' ', MA, NA, A, NMAX, AA, LDA, + $ RESET, ZERO ) +* + DO 70 ICB = 1, 3 + TRANSB = ICH( ICB: ICB ) + TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' +* + IF( TRANB )THEN + MB = N + NB = K + ELSE + MB = K + NB = N + END IF +* Set LDB to 1 more than minimum value if room. + LDB = MB + IF( LDB.LT.NMAX ) + $ LDB = LDB + 1 +* Skip tests if not enough room. + IF( LDB.GT.NMAX ) + $ GO TO 70 + LBB = LDB*NB +* +* Generate the matrix B. +* + CALL ZMAKE( 'ge', ' ', ' ', MB, NB, B, NMAX, BB, + $ LDB, RESET, ZERO ) +* + DO 60 IA = 1, NALF + ALPHA = ALF( IA ) +* + DO 50 IB = 1, NBET + BETA = BET( IB ) +* +* Generate the matrix C. +* + CALL ZMAKE( 'ge', ' ', ' ', M, N, C, NMAX, + $ CC, LDC, RESET, ZERO ) +* + NC = NC + 1 +* +* Save every datum before calling the +* subroutine. +* + TRANAS = TRANSA + TRANBS = TRANSB + MS = M + NS = N + KS = K + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LBB + BS( I ) = BB( I ) + 20 CONTINUE + LDBS = LDB + BLS = BETA + DO 30 I = 1, LCC + CS( I ) = CC( I ) + 30 CONTINUE + LDCS = LDC +* +* Call the subroutine. +* + IF( TRACE ) + $ CALL ZPRCN1(NTRA, NC, SNAME, IORDER, + $ TRANSA, TRANSB, M, N, K, ALPHA, LDA, + $ LDB, BETA, LDC) + IF( REWI ) + $ REWIND NTRA + CALL CZGEMM( IORDER, TRANSA, TRANSB, M, N, + $ K, ALPHA, AA, LDA, BB, LDB, + $ BETA, CC, LDC ) +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9994 ) + FATAL = .TRUE. + GO TO 120 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = TRANSA.EQ.TRANAS + ISAME( 2 ) = TRANSB.EQ.TRANBS + ISAME( 3 ) = MS.EQ.M + ISAME( 4 ) = NS.EQ.N + ISAME( 5 ) = KS.EQ.K + ISAME( 6 ) = ALS.EQ.ALPHA + ISAME( 7 ) = LZE( AS, AA, LAA ) + ISAME( 8 ) = LDAS.EQ.LDA + ISAME( 9 ) = LZE( BS, BB, LBB ) + ISAME( 10 ) = LDBS.EQ.LDB + ISAME( 11 ) = BLS.EQ.BETA + IF( NULL )THEN + ISAME( 12 ) = LZE( CS, CC, LCC ) + ELSE + ISAME( 12 ) = LZERES( 'ge', ' ', M, N, CS, + $ CC, LDC ) + END IF + ISAME( 13 ) = LDCS.EQ.LDC +* +* If data was incorrectly changed, report +* and return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 120 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result. +* + CALL ZMMCH( TRANSA, TRANSB, M, N, K, + $ ALPHA, A, NMAX, B, NMAX, BETA, + $ C, NMAX, CT, G, CC, LDC, EPS, + $ ERR, FATAL, NOUT, .TRUE. ) + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and +* return. + IF( FATAL ) + $ GO TO 120 + END IF +* + 50 CONTINUE +* + 60 CONTINUE +* + 70 CONTINUE +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* + 110 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 130 +* + 120 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + CALL ZPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, + $ M, N, K, ALPHA, LDA, LDB, BETA, LDC) +* + 130 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',', + $ 3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, + $ ',(', F4.1, ',', F4.1, '), C,', I3, ').' ) + 9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of ZCHK1. +* + END +* + SUBROUTINE ZPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, M, N, + $ K, ALPHA, LDA, LDB, BETA, LDC) + INTEGER NOUT, NC, IORDER, M, N, K, LDA, LDB, LDC + DOUBLE COMPLEX ALPHA, BETA + CHARACTER*1 TRANSA, TRANSB + CHARACTER*12 SNAME + CHARACTER*14 CRC, CTA,CTB + + IF (TRANSA.EQ.'N')THEN + CTA = ' CblasNoTrans' + ELSE IF (TRANSA.EQ.'T')THEN + CTA = ' CblasTrans' + ELSE + CTA = 'CblasConjTrans' + END IF + IF (TRANSB.EQ.'N')THEN + CTB = ' CblasNoTrans' + ELSE IF (TRANSB.EQ.'T')THEN + CTB = ' CblasTrans' + ELSE + CTB = 'CblasConjTrans' + END IF + IF (IORDER.EQ.1)THEN + CRC = ' CblasRowMajor' + ELSE + CRC = ' CblasColMajor' + END IF + WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CTA,CTB + WRITE(NOUT, FMT = 9994)M, N, K, ALPHA, LDA, LDB, BETA, LDC + + 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',') + 9994 FORMAT( 10X, 3( I3, ',' ) ,' (', F4.1,',',F4.1,') , A,', + $ I3, ', B,', I3, ', (', F4.1,',',F4.1,') , C,', I3, ').' ) + END +* + SUBROUTINE ZCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, + $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G, + $ IORDER ) +* +* 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 .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ) ) + DOUBLE PRECISION RZERO + PARAMETER ( RZERO = 0.0D0 ) +* .. Scalar Arguments .. + DOUBLE PRECISION EPS, THRESH + INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), B( NMAX, NMAX ), + $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), + $ C( NMAX, NMAX ), CC( NMAX*NMAX ), + $ CS( NMAX*NMAX ), CT( NMAX ) + DOUBLE PRECISION G( NMAX ) + INTEGER IDIM( NIDIM ) +* .. Local Scalars .. + COMPLEX*16 ALPHA, ALS, BETA, BLS + DOUBLE PRECISION ERR, ERRMAX + INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC, + $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA, + $ NARGS, NC, NS + LOGICAL CONJ, LEFT, NULL, RESET, SAME + CHARACTER*1 SIDE, SIDES, UPLO, UPLOS + CHARACTER*2 ICHS, ICHU +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LZE, LZERES + EXTERNAL LZE, LZERES +* .. External Subroutines .. + EXTERNAL CZHEMM, ZMAKE, ZMMCH, CZSYMM +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL LERR, OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK, LERR +* .. Data statements .. + DATA ICHS/'LR'/, ICHU/'UL'/ +* .. Executable Statements .. + CONJ = SNAME( 8: 9 ).EQ.'he' +* + NARGS = 12 + NC = 0 + RESET = .TRUE. + ERRMAX = RZERO +* + DO 100 IM = 1, NIDIM + M = IDIM( IM ) +* + DO 90 IN = 1, NIDIM + N = IDIM( IN ) +* Set LDC to 1 more than minimum value if room. + LDC = M + IF( LDC.LT.NMAX ) + $ LDC = LDC + 1 +* Skip tests if not enough room. + IF( LDC.GT.NMAX ) + $ GO TO 90 + LCC = LDC*N + NULL = N.LE.0.OR.M.LE.0 +* Set LDB to 1 more than minimum value if room. + LDB = M + IF( LDB.LT.NMAX ) + $ LDB = LDB + 1 +* Skip tests if not enough room. + IF( LDB.GT.NMAX ) + $ GO TO 90 + LBB = LDB*N +* +* Generate the matrix B. +* + CALL ZMAKE( 'ge', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET, + $ ZERO ) +* + DO 80 ICS = 1, 2 + SIDE = ICHS( ICS: ICS ) + LEFT = SIDE.EQ.'L' +* + IF( LEFT )THEN + NA = M + ELSE + NA = N + END IF +* Set LDA to 1 more than minimum value if room. + LDA = NA + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 80 + LAA = LDA*NA +* + DO 70 ICU = 1, 2 + UPLO = ICHU( ICU: ICU ) +* +* Generate the hermitian or symmetric matrix A. +* + CALL ZMAKE(SNAME( 8: 9 ), UPLO, ' ', NA, NA, A, NMAX, + $ AA, LDA, RESET, ZERO ) +* + DO 60 IA = 1, NALF + ALPHA = ALF( IA ) +* + DO 50 IB = 1, NBET + BETA = BET( IB ) +* +* Generate the matrix C. +* + CALL ZMAKE( 'ge', ' ', ' ', M, N, C, NMAX, CC, + $ LDC, RESET, ZERO ) +* + NC = NC + 1 +* +* Save every datum before calling the +* subroutine. +* + SIDES = SIDE + UPLOS = UPLO + MS = M + NS = N + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LBB + BS( I ) = BB( I ) + 20 CONTINUE + LDBS = LDB + BLS = BETA + DO 30 I = 1, LCC + CS( I ) = CC( I ) + 30 CONTINUE + LDCS = LDC +* +* Call the subroutine. +* + IF( TRACE ) + $ CALL ZPRCN2(NTRA, NC, SNAME, IORDER, + $ SIDE, UPLO, M, N, ALPHA, LDA, LDB, + $ BETA, LDC) + IF( REWI ) + $ REWIND NTRA + IF( CONJ )THEN + CALL CZHEMM( IORDER, SIDE, UPLO, M, N, + $ ALPHA, AA, LDA, BB, LDB, BETA, + $ CC, LDC ) + ELSE + CALL CZSYMM( IORDER, SIDE, UPLO, M, N, + $ ALPHA, AA, LDA, BB, LDB, BETA, + $ CC, LDC ) + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9994 ) + FATAL = .TRUE. + GO TO 110 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = SIDES.EQ.SIDE + ISAME( 2 ) = UPLOS.EQ.UPLO + ISAME( 3 ) = MS.EQ.M + ISAME( 4 ) = NS.EQ.N + ISAME( 5 ) = ALS.EQ.ALPHA + ISAME( 6 ) = LZE( AS, AA, LAA ) + ISAME( 7 ) = LDAS.EQ.LDA + ISAME( 8 ) = LZE( BS, BB, LBB ) + ISAME( 9 ) = LDBS.EQ.LDB + ISAME( 10 ) = BLS.EQ.BETA + IF( NULL )THEN + ISAME( 11 ) = LZE( CS, CC, LCC ) + ELSE + ISAME( 11 ) = LZERES( 'ge', ' ', M, N, CS, + $ CC, LDC ) + END IF + ISAME( 12 ) = LDCS.EQ.LDC +* +* If data was incorrectly changed, report and +* return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 110 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result. +* + IF( LEFT )THEN + CALL ZMMCH( 'N', 'N', M, N, M, ALPHA, A, + $ NMAX, B, NMAX, BETA, C, NMAX, + $ CT, G, CC, LDC, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + ELSE + CALL ZMMCH( 'N', 'N', M, N, N, ALPHA, B, + $ NMAX, A, NMAX, BETA, C, NMAX, + $ CT, G, CC, LDC, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + END IF + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and +* return. + IF( FATAL ) + $ GO TO 110 + END IF +* + 50 CONTINUE +* + 60 CONTINUE +* + 70 CONTINUE +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 120 +* + 110 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + CALL ZPRCN2(NOUT, NC, SNAME, IORDER, SIDE, UPLO, M, N, ALPHA, LDA, + $ LDB, BETA, LDC) +* + 120 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' ) + 9995 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), + $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1, + $ ',', F4.1, '), C,', I3, ') .' ) + 9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of ZCHK2. +* + END +* + SUBROUTINE ZPRCN2(NOUT, NC, SNAME, IORDER, SIDE, UPLO, M, N, + $ ALPHA, LDA, LDB, BETA, LDC) + INTEGER NOUT, NC, IORDER, M, N, LDA, LDB, LDC + DOUBLE COMPLEX ALPHA, BETA + CHARACTER*1 SIDE, UPLO + CHARACTER*12 SNAME + CHARACTER*14 CRC, CS,CU + + IF (SIDE.EQ.'L')THEN + CS = ' CblasLeft' + ELSE + CS = ' CblasRight' + END IF + IF (UPLO.EQ.'U')THEN + CU = ' CblasUpper' + ELSE + CU = ' CblasLower' + END IF + IF (IORDER.EQ.1)THEN + CRC = ' CblasRowMajor' + ELSE + CRC = ' CblasColMajor' + END IF + WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CS,CU + WRITE(NOUT, FMT = 9994)M, N, ALPHA, LDA, LDB, BETA, LDC + + 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',') + 9994 FORMAT( 10X, 2( I3, ',' ),' (',F4.1,',',F4.1, '), A,', I3, + $ ', B,', I3, ', (',F4.1,',',F4.1, '), ', 'C,', I3, ').' ) + END +* + SUBROUTINE ZCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NMAX, A, AA, AS, + $ B, BB, BS, CT, G, C, IORDER ) +* +* 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 .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), ONE = ( 1.0D0, 0.0D0 ) ) + DOUBLE PRECISION RZERO + PARAMETER ( RZERO = 0.0D0 ) +* .. Scalar Arguments .. + DOUBLE PRECISION EPS, THRESH + INTEGER NALF, NIDIM, NMAX, NOUT, NTRA, IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), B( NMAX, NMAX ), + $ BB( NMAX*NMAX ), BS( NMAX*NMAX ), + $ C( NMAX, NMAX ), CT( NMAX ) + DOUBLE PRECISION G( NMAX ) + INTEGER IDIM( NIDIM ) +* .. Local Scalars .. + COMPLEX*16 ALPHA, ALS + DOUBLE PRECISION ERR, ERRMAX + INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB, + $ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC, + $ NS + LOGICAL LEFT, NULL, RESET, SAME + CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO, + $ UPLOS + CHARACTER*2 ICHD, ICHS, ICHU + CHARACTER*3 ICHT +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LZE, LZERES + EXTERNAL LZE, LZERES +* .. External Subroutines .. + EXTERNAL ZMAKE, ZMMCH, CZTRMM, CZTRSM +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL LERR, OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK, LERR +* .. Data statements .. + DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/, ICHS/'LR'/ +* .. Executable Statements .. +* + NARGS = 11 + NC = 0 + RESET = .TRUE. + ERRMAX = RZERO +* Set up zero matrix for ZMMCH. + DO 20 J = 1, NMAX + DO 10 I = 1, NMAX + C( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE +* + DO 140 IM = 1, NIDIM + M = IDIM( IM ) +* + DO 130 IN = 1, NIDIM + N = IDIM( IN ) +* Set LDB to 1 more than minimum value if room. + LDB = M + IF( LDB.LT.NMAX ) + $ LDB = LDB + 1 +* Skip tests if not enough room. + IF( LDB.GT.NMAX ) + $ GO TO 130 + LBB = LDB*N + NULL = M.LE.0.OR.N.LE.0 +* + DO 120 ICS = 1, 2 + SIDE = ICHS( ICS: ICS ) + LEFT = SIDE.EQ.'L' + IF( LEFT )THEN + NA = M + ELSE + NA = N + END IF +* Set LDA to 1 more than minimum value if room. + LDA = NA + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 130 + LAA = LDA*NA +* + DO 110 ICU = 1, 2 + UPLO = ICHU( ICU: ICU ) +* + DO 100 ICT = 1, 3 + TRANSA = ICHT( ICT: ICT ) +* + DO 90 ICD = 1, 2 + DIAG = ICHD( ICD: ICD ) +* + DO 80 IA = 1, NALF + ALPHA = ALF( IA ) +* +* Generate the matrix A. +* + CALL ZMAKE( 'tr', UPLO, DIAG, NA, NA, A, + $ NMAX, AA, LDA, RESET, ZERO ) +* +* Generate the matrix B. +* + CALL ZMAKE( 'ge', ' ', ' ', M, N, B, NMAX, + $ BB, LDB, RESET, ZERO ) +* + NC = NC + 1 +* +* Save every datum before calling the +* subroutine. +* + SIDES = SIDE + UPLOS = UPLO + TRANAS = TRANSA + DIAGS = DIAG + MS = M + NS = N + ALS = ALPHA + DO 30 I = 1, LAA + AS( I ) = AA( I ) + 30 CONTINUE + LDAS = LDA + DO 40 I = 1, LBB + BS( I ) = BB( I ) + 40 CONTINUE + LDBS = LDB +* +* Call the subroutine. +* + IF( SNAME( 10: 11 ).EQ.'mm' )THEN + IF( TRACE ) + $ CALL ZPRCN3( NTRA, NC, SNAME, IORDER, + $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, + $ LDA, LDB) + IF( REWI ) + $ REWIND NTRA + CALL CZTRMM(IORDER, SIDE, UPLO, TRANSA, + $ DIAG, M, N, ALPHA, AA, LDA, + $ BB, LDB ) + ELSE IF( SNAME( 10: 11 ).EQ.'sm' )THEN + IF( TRACE ) + $ CALL ZPRCN3( NTRA, NC, SNAME, IORDER, + $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, + $ LDA, LDB) + IF( REWI ) + $ REWIND NTRA + CALL CZTRSM(IORDER, SIDE, UPLO, TRANSA, + $ DIAG, M, N, ALPHA, AA, LDA, + $ BB, LDB ) + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9994 ) + FATAL = .TRUE. + GO TO 150 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = SIDES.EQ.SIDE + ISAME( 2 ) = UPLOS.EQ.UPLO + ISAME( 3 ) = TRANAS.EQ.TRANSA + ISAME( 4 ) = DIAGS.EQ.DIAG + ISAME( 5 ) = MS.EQ.M + ISAME( 6 ) = NS.EQ.N + ISAME( 7 ) = ALS.EQ.ALPHA + ISAME( 8 ) = LZE( AS, AA, LAA ) + ISAME( 9 ) = LDAS.EQ.LDA + IF( NULL )THEN + ISAME( 10 ) = LZE( BS, BB, LBB ) + ELSE + ISAME( 10 ) = LZERES( 'ge', ' ', M, N, BS, + $ BB, LDB ) + END IF + ISAME( 11 ) = LDBS.EQ.LDB +* +* If data was incorrectly changed, report and +* return. +* + SAME = .TRUE. + DO 50 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 50 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 150 + END IF +* + IF( .NOT.NULL )THEN + IF( SNAME( 10: 11 ).EQ.'mm' )THEN +* +* Check the result. +* + IF( LEFT )THEN + CALL ZMMCH( TRANSA, 'N', M, N, M, + $ ALPHA, A, NMAX, B, NMAX, + $ ZERO, C, NMAX, CT, G, + $ BB, LDB, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + ELSE + CALL ZMMCH( 'N', TRANSA, M, N, N, + $ ALPHA, B, NMAX, A, NMAX, + $ ZERO, C, NMAX, CT, G, + $ BB, LDB, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + END IF + ELSE IF( SNAME( 10: 11 ).EQ.'sm' )THEN +* +* Compute approximation to original +* matrix. +* + DO 70 J = 1, N + DO 60 I = 1, M + C( I, J ) = BB( I + ( J - 1 )* + $ LDB ) + BB( I + ( J - 1 )*LDB ) = ALPHA* + $ B( I, J ) + 60 CONTINUE + 70 CONTINUE +* + IF( LEFT )THEN + CALL ZMMCH( TRANSA, 'N', M, N, M, + $ ONE, A, NMAX, C, NMAX, + $ ZERO, B, NMAX, CT, G, + $ BB, LDB, EPS, ERR, + $ FATAL, NOUT, .FALSE. ) + ELSE + CALL ZMMCH( 'N', TRANSA, M, N, N, + $ ONE, C, NMAX, A, NMAX, + $ ZERO, B, NMAX, CT, G, + $ BB, LDB, EPS, ERR, + $ FATAL, NOUT, .FALSE. ) + END IF + END IF + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and +* return. + IF( FATAL ) + $ GO TO 150 + END IF +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* + 110 CONTINUE +* + 120 CONTINUE +* + 130 CONTINUE +* + 140 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 160 +* + 150 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + CALL ZPRCN3( NTRA, NC, SNAME, IORDER, SIDE, UPLO, TRANSA, DIAG, + $ M, N, ALPHA, LDA, LDB) +* + 160 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9996 FORMAT(' ******* ', A12,' FAILED ON CALL NUMBER:' ) + 9995 FORMAT(1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( I3, ',' ), + $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ') ', + $ ' .' ) + 9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of ZCHK3. +* + END +* + SUBROUTINE ZPRCN3(NOUT, NC, SNAME, IORDER, SIDE, UPLO, TRANSA, + $ DIAG, M, N, ALPHA, LDA, LDB) + INTEGER NOUT, NC, IORDER, M, N, LDA, LDB + DOUBLE COMPLEX ALPHA + CHARACTER*1 SIDE, UPLO, TRANSA, DIAG + CHARACTER*12 SNAME + CHARACTER*14 CRC, CS, CU, CA, CD + + IF (SIDE.EQ.'L')THEN + CS = ' CblasLeft' + ELSE + CS = ' CblasRight' + END IF + IF (UPLO.EQ.'U')THEN + CU = ' CblasUpper' + ELSE + CU = ' CblasLower' + END IF + IF (TRANSA.EQ.'N')THEN + CA = ' CblasNoTrans' + ELSE IF (TRANSA.EQ.'T')THEN + CA = ' CblasTrans' + ELSE + CA = 'CblasConjTrans' + END IF + IF (DIAG.EQ.'N')THEN + CD = ' CblasNonUnit' + ELSE + CD = ' CblasUnit' + END IF + IF (IORDER.EQ.1)THEN + CRC = ' CblasRowMajor' + ELSE + CRC = ' CblasColMajor' + END IF + WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CS,CU + WRITE(NOUT, FMT = 9994)CA, CD, M, N, ALPHA, LDA, LDB + + 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',') + 9994 FORMAT( 10X, 2( A14, ',') , 2( I3, ',' ), ' (', F4.1, ',', + $ F4.1, '), A,', I3, ', B,', I3, ').' ) + END +* + SUBROUTINE ZCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, + $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G, + $ IORDER ) +* +* 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 .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ) ) + DOUBLE PRECISION RONE, RZERO + PARAMETER ( RONE = 1.0D0, RZERO = 0.0D0 ) +* .. Scalar Arguments .. + DOUBLE PRECISION EPS, THRESH + INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), + $ AS( NMAX*NMAX ), B( NMAX, NMAX ), + $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), + $ C( NMAX, NMAX ), CC( NMAX*NMAX ), + $ CS( NMAX*NMAX ), CT( NMAX ) + DOUBLE PRECISION G( NMAX ) + INTEGER IDIM( NIDIM ) +* .. Local Scalars .. + COMPLEX*16 ALPHA, ALS, BETA, BETS + DOUBLE PRECISION ERR, ERRMAX, RALPHA, RALS, RBETA, RBETS + INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS, + $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA, + $ NARGS, NC, NS + LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER + CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS + CHARACTER*2 ICHT, ICHU +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LZE, LZERES + EXTERNAL LZE, LZERES +* .. External Subroutines .. + EXTERNAL CZHERK, ZMAKE, ZMMCH, CZSYRK +* .. Intrinsic Functions .. + INTRINSIC DCMPLX, MAX, DBLE +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL LERR, OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK, LERR +* .. Data statements .. + DATA ICHT/'NC'/, ICHU/'UL'/ +* .. Executable Statements .. + CONJ = SNAME( 8: 9 ).EQ.'he' +* + NARGS = 10 + NC = 0 + RESET = .TRUE. + ERRMAX = RZERO +* + DO 100 IN = 1, NIDIM + N = IDIM( IN ) +* Set LDC to 1 more than minimum value if room. + LDC = N + IF( LDC.LT.NMAX ) + $ LDC = LDC + 1 +* Skip tests if not enough room. + IF( LDC.GT.NMAX ) + $ GO TO 100 + LCC = LDC*N +* + DO 90 IK = 1, NIDIM + K = IDIM( IK ) +* + DO 80 ICT = 1, 2 + TRANS = ICHT( ICT: ICT ) + TRAN = TRANS.EQ.'C' + IF( TRAN.AND..NOT.CONJ ) + $ TRANS = 'T' + IF( TRAN )THEN + MA = K + NA = N + ELSE + MA = N + NA = K + END IF +* Set LDA to 1 more than minimum value if room. + LDA = MA + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 80 + LAA = LDA*NA +* +* Generate the matrix A. +* + CALL ZMAKE( 'ge', ' ', ' ', MA, NA, A, NMAX, AA, LDA, + $ RESET, ZERO ) +* + DO 70 ICU = 1, 2 + UPLO = ICHU( ICU: ICU ) + UPPER = UPLO.EQ.'U' +* + DO 60 IA = 1, NALF + ALPHA = ALF( IA ) + IF( CONJ )THEN + RALPHA = DBLE( ALPHA ) + ALPHA = DCMPLX( RALPHA, RZERO ) + END IF +* + DO 50 IB = 1, NBET + BETA = BET( IB ) + IF( CONJ )THEN + RBETA = DBLE( BETA ) + BETA = DCMPLX( RBETA, RZERO ) + END IF + NULL = N.LE.0 + IF( CONJ ) + $ NULL = NULL.OR.( ( K.LE.0.OR.RALPHA.EQ. + $ RZERO ).AND.RBETA.EQ.RONE ) +* +* Generate the matrix C. +* + CALL ZMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, C, + $ NMAX, CC, LDC, RESET, ZERO ) +* + NC = NC + 1 +* +* Save every datum before calling the subroutine. +* + UPLOS = UPLO + TRANSS = TRANS + NS = N + KS = K + IF( CONJ )THEN + RALS = RALPHA + ELSE + ALS = ALPHA + END IF + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + IF( CONJ )THEN + RBETS = RBETA + ELSE + BETS = BETA + END IF + DO 20 I = 1, LCC + CS( I ) = CC( I ) + 20 CONTINUE + LDCS = LDC +* +* Call the subroutine. +* + IF( CONJ )THEN + IF( TRACE ) + $ CALL ZPRCN6( NTRA, NC, SNAME, IORDER, + $ UPLO, TRANS, N, K, RALPHA, LDA, RBETA, + $ LDC) + IF( REWI ) + $ REWIND NTRA + CALL CZHERK( IORDER, UPLO, TRANS, N, K, + $ RALPHA, AA, LDA, RBETA, CC, + $ LDC ) + ELSE + IF( TRACE ) + $ CALL ZPRCN4( NTRA, NC, SNAME, IORDER, + $ UPLO, TRANS, N, K, ALPHA, LDA, BETA, LDC) + IF( REWI ) + $ REWIND NTRA + CALL CZSYRK( IORDER, UPLO, TRANS, N, K, + $ ALPHA, AA, LDA, BETA, CC, LDC ) + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9992 ) + FATAL = .TRUE. + GO TO 120 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = UPLOS.EQ.UPLO + ISAME( 2 ) = TRANSS.EQ.TRANS + ISAME( 3 ) = NS.EQ.N + ISAME( 4 ) = KS.EQ.K + IF( CONJ )THEN + ISAME( 5 ) = RALS.EQ.RALPHA + ELSE + ISAME( 5 ) = ALS.EQ.ALPHA + END IF + ISAME( 6 ) = LZE( AS, AA, LAA ) + ISAME( 7 ) = LDAS.EQ.LDA + IF( CONJ )THEN + ISAME( 8 ) = RBETS.EQ.RBETA + ELSE + ISAME( 8 ) = BETS.EQ.BETA + END IF + IF( NULL )THEN + ISAME( 9 ) = LZE( CS, CC, LCC ) + ELSE + ISAME( 9 ) = LZERES( SNAME( 8: 9 ), UPLO, N, + $ N, CS, CC, LDC ) + END IF + ISAME( 10 ) = LDCS.EQ.LDC +* +* If data was incorrectly changed, report and +* return. +* + SAME = .TRUE. + DO 30 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 30 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 120 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result column by column. +* + IF( CONJ )THEN + TRANST = 'C' + ELSE + TRANST = 'T' + END IF + JC = 1 + DO 40 J = 1, N + IF( UPPER )THEN + JJ = 1 + LJ = J + ELSE + JJ = J + LJ = N - J + 1 + END IF + IF( TRAN )THEN + CALL ZMMCH( TRANST, 'N', LJ, 1, K, + $ ALPHA, A( 1, JJ ), NMAX, + $ A( 1, J ), NMAX, BETA, + $ C( JJ, J ), NMAX, CT, G, + $ CC( JC ), LDC, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + ELSE + CALL ZMMCH( 'N', TRANST, LJ, 1, K, + $ ALPHA, A( JJ, 1 ), NMAX, + $ A( J, 1 ), NMAX, BETA, + $ C( JJ, J ), NMAX, CT, G, + $ CC( JC ), LDC, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + END IF + IF( UPPER )THEN + JC = JC + LDC + ELSE + JC = JC + LDC + 1 + END IF + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and +* return. + IF( FATAL ) + $ GO TO 110 + 40 CONTINUE + END IF +* + 50 CONTINUE +* + 60 CONTINUE +* + 70 CONTINUE +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 130 +* + 110 CONTINUE + IF( N.GT.1 ) + $ WRITE( NOUT, FMT = 9995 )J +* + 120 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + IF( CONJ )THEN + CALL ZPRCN6( NOUT, NC, SNAME, IORDER, UPLO, TRANS, N, K, RALPHA, + $ LDA, rBETA, LDC) + ELSE + CALL ZPRCN4( NOUT, NC, SNAME, IORDER, UPLO, TRANS, N, K, ALPHA, + $ LDA, BETA, LDC) + END IF +* + 130 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) + 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, ') .' ) + 9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of CCHK4. +* + END +* + SUBROUTINE ZPRCN4(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, + $ N, K, ALPHA, LDA, BETA, LDC) + INTEGER NOUT, NC, IORDER, N, K, LDA, LDC + DOUBLE COMPLEX ALPHA, BETA + CHARACTER*1 UPLO, TRANSA + CHARACTER*12 SNAME + CHARACTER*14 CRC, CU, CA + + IF (UPLO.EQ.'U')THEN + CU = ' CblasUpper' + ELSE + CU = ' CblasLower' + END IF + IF (TRANSA.EQ.'N')THEN + CA = ' CblasNoTrans' + ELSE IF (TRANSA.EQ.'T')THEN + CA = ' CblasTrans' + ELSE + CA = 'CblasConjTrans' + END IF + IF (IORDER.EQ.1)THEN + CRC = ' CblasRowMajor' + ELSE + CRC = ' CblasColMajor' + END IF + WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA + WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, BETA, LDC + + 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') ) + 9994 FORMAT( 10X, 2( I3, ',' ), ' (', F4.1, ',', F4.1 ,'), A,', + $ I3, ', (', F4.1,',', F4.1, '), C,', I3, ').' ) + END +* +* + SUBROUTINE ZPRCN6(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, + $ N, K, ALPHA, LDA, BETA, LDC) + INTEGER NOUT, NC, IORDER, N, K, LDA, LDC + DOUBLE PRECISION ALPHA, BETA + CHARACTER*1 UPLO, TRANSA + CHARACTER*12 SNAME + CHARACTER*14 CRC, CU, CA + + IF (UPLO.EQ.'U')THEN + CU = ' CblasUpper' + ELSE + CU = ' CblasLower' + END IF + IF (TRANSA.EQ.'N')THEN + CA = ' CblasNoTrans' + ELSE IF (TRANSA.EQ.'T')THEN + CA = ' CblasTrans' + ELSE + CA = 'CblasConjTrans' + END IF + IF (IORDER.EQ.1)THEN + CRC = ' CblasRowMajor' + ELSE + CRC = ' CblasColMajor' + END IF + WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA + WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, BETA, LDC + + 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') ) + 9994 FORMAT( 10X, 2( I3, ',' ), + $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ').' ) + END +* + SUBROUTINE ZCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, + $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, + $ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W, + $ IORDER ) +* +* 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 .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), ONE = ( 1.0D0, 0.0D0 ) ) + DOUBLE PRECISION RONE, RZERO + PARAMETER ( RONE = 1.0D0, RZERO = 0.0D0 ) +* .. Scalar Arguments .. + DOUBLE PRECISION EPS, THRESH + INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER + LOGICAL FATAL, REWI, TRACE + CHARACTER*12 SNAME +* .. Array Arguments .. + COMPLEX*16 AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ), + $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ), + $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ), + $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), + $ W( 2*NMAX ) + DOUBLE PRECISION G( NMAX ) + INTEGER IDIM( NIDIM ) +* .. Local Scalars .. + COMPLEX*16 ALPHA, ALS, BETA, BETS + DOUBLE PRECISION ERR, ERRMAX, RBETA, RBETS + INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB, + $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS, + $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS + LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER + CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS + CHARACTER*2 ICHT, ICHU +* .. Local Arrays .. + LOGICAL ISAME( 13 ) +* .. External Functions .. + LOGICAL LZE, LZERES + EXTERNAL LZE, LZERES +* .. External Subroutines .. + EXTERNAL CZHER2K, ZMAKE, ZMMCH, CZSYR2K +* .. Intrinsic Functions .. + INTRINSIC DCMPLX, DCONJG, MAX, DBLE +* .. Scalars in Common .. + INTEGER INFOT, NOUTC + LOGICAL LERR, OK +* .. Common blocks .. + COMMON /INFOC/INFOT, NOUTC, OK, LERR +* .. Data statements .. + DATA ICHT/'NC'/, ICHU/'UL'/ +* .. Executable Statements .. + CONJ = SNAME( 8: 9 ).EQ.'he' +* + NARGS = 12 + NC = 0 + RESET = .TRUE. + ERRMAX = RZERO +* + DO 130 IN = 1, NIDIM + N = IDIM( IN ) +* Set LDC to 1 more than minimum value if room. + LDC = N + IF( LDC.LT.NMAX ) + $ LDC = LDC + 1 +* Skip tests if not enough room. + IF( LDC.GT.NMAX ) + $ GO TO 130 + LCC = LDC*N +* + DO 120 IK = 1, NIDIM + K = IDIM( IK ) +* + DO 110 ICT = 1, 2 + TRANS = ICHT( ICT: ICT ) + TRAN = TRANS.EQ.'C' + IF( TRAN.AND..NOT.CONJ ) + $ TRANS = 'T' + IF( TRAN )THEN + MA = K + NA = N + ELSE + MA = N + NA = K + END IF +* Set LDA to 1 more than minimum value if room. + LDA = MA + IF( LDA.LT.NMAX ) + $ LDA = LDA + 1 +* Skip tests if not enough room. + IF( LDA.GT.NMAX ) + $ GO TO 110 + LAA = LDA*NA +* +* Generate the matrix A. +* + IF( TRAN )THEN + CALL ZMAKE( 'ge', ' ', ' ', MA, NA, AB, 2*NMAX, AA, + $ LDA, RESET, ZERO ) + ELSE + CALL ZMAKE( 'ge', ' ', ' ', MA, NA, AB, NMAX, AA, LDA, + $ RESET, ZERO ) + END IF +* +* Generate the matrix B. +* + LDB = LDA + LBB = LAA + IF( TRAN )THEN + CALL ZMAKE( 'ge', ' ', ' ', MA, NA, AB( K + 1 ), + $ 2*NMAX, BB, LDB, RESET, ZERO ) + ELSE + CALL ZMAKE( 'ge', ' ', ' ', MA, NA, AB( K*NMAX + 1 ), + $ NMAX, BB, LDB, RESET, ZERO ) + END IF +* + DO 100 ICU = 1, 2 + UPLO = ICHU( ICU: ICU ) + UPPER = UPLO.EQ.'U' +* + DO 90 IA = 1, NALF + ALPHA = ALF( IA ) +* + DO 80 IB = 1, NBET + BETA = BET( IB ) + IF( CONJ )THEN + RBETA = DBLE( BETA ) + BETA = DCMPLX( RBETA, RZERO ) + END IF + NULL = N.LE.0 + IF( CONJ ) + $ NULL = NULL.OR.( ( K.LE.0.OR.ALPHA.EQ. + $ ZERO ).AND.RBETA.EQ.RONE ) +* +* Generate the matrix C. +* + CALL ZMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, C, + $ NMAX, CC, LDC, RESET, ZERO ) +* + NC = NC + 1 +* +* Save every datum before calling the subroutine. +* + UPLOS = UPLO + TRANSS = TRANS + NS = N + KS = K + ALS = ALPHA + DO 10 I = 1, LAA + AS( I ) = AA( I ) + 10 CONTINUE + LDAS = LDA + DO 20 I = 1, LBB + BS( I ) = BB( I ) + 20 CONTINUE + LDBS = LDB + IF( CONJ )THEN + RBETS = RBETA + ELSE + BETS = BETA + END IF + DO 30 I = 1, LCC + CS( I ) = CC( I ) + 30 CONTINUE + LDCS = LDC +* +* Call the subroutine. +* + IF( CONJ )THEN + IF( TRACE ) + $ CALL ZPRCN7( NTRA, NC, SNAME, IORDER, + $ UPLO, TRANS, N, K, ALPHA, LDA, LDB, + $ RBETA, LDC) + IF( REWI ) + $ REWIND NTRA + CALL CZHER2K( IORDER, UPLO, TRANS, N, K, + $ ALPHA, AA, LDA, BB, LDB, RBETA, + $ CC, LDC ) + ELSE + IF( TRACE ) + $ CALL ZPRCN5( NTRA, NC, SNAME, IORDER, + $ UPLO, TRANS, N, K, ALPHA, LDA, LDB, + $ BETA, LDC) + IF( REWI ) + $ REWIND NTRA + CALL CZSYR2K( IORDER, UPLO, TRANS, N, K, + $ ALPHA, AA, LDA, BB, LDB, BETA, + $ CC, LDC ) + END IF +* +* Check if error-exit was taken incorrectly. +* + IF( .NOT.OK )THEN + WRITE( NOUT, FMT = 9992 ) + FATAL = .TRUE. + GO TO 150 + END IF +* +* See what data changed inside subroutines. +* + ISAME( 1 ) = UPLOS.EQ.UPLO + ISAME( 2 ) = TRANSS.EQ.TRANS + ISAME( 3 ) = NS.EQ.N + ISAME( 4 ) = KS.EQ.K + ISAME( 5 ) = ALS.EQ.ALPHA + ISAME( 6 ) = LZE( AS, AA, LAA ) + ISAME( 7 ) = LDAS.EQ.LDA + ISAME( 8 ) = LZE( BS, BB, LBB ) + ISAME( 9 ) = LDBS.EQ.LDB + IF( CONJ )THEN + ISAME( 10 ) = RBETS.EQ.RBETA + ELSE + ISAME( 10 ) = BETS.EQ.BETA + END IF + IF( NULL )THEN + ISAME( 11 ) = LZE( CS, CC, LCC ) + ELSE + ISAME( 11 ) = LZERES( 'he', UPLO, N, N, CS, + $ CC, LDC ) + END IF + ISAME( 12 ) = LDCS.EQ.LDC +* +* If data was incorrectly changed, report and +* return. +* + SAME = .TRUE. + DO 40 I = 1, NARGS + SAME = SAME.AND.ISAME( I ) + IF( .NOT.ISAME( I ) ) + $ WRITE( NOUT, FMT = 9998 )I + 40 CONTINUE + IF( .NOT.SAME )THEN + FATAL = .TRUE. + GO TO 150 + END IF +* + IF( .NOT.NULL )THEN +* +* Check the result column by column. +* + IF( CONJ )THEN + TRANST = 'C' + ELSE + TRANST = 'T' + END IF + JJAB = 1 + JC = 1 + DO 70 J = 1, N + IF( UPPER )THEN + JJ = 1 + LJ = J + ELSE + JJ = J + LJ = N - J + 1 + END IF + IF( TRAN )THEN + DO 50 I = 1, K + W( I ) = ALPHA*AB( ( J - 1 )*2* + $ NMAX + K + I ) + IF( CONJ )THEN + W( K + I ) = DCONJG( ALPHA )* + $ AB( ( J - 1 )*2* + $ NMAX + I ) + ELSE + W( K + I ) = ALPHA* + $ AB( ( J - 1 )*2* + $ NMAX + I ) + END IF + 50 CONTINUE + CALL ZMMCH( TRANST, 'N', LJ, 1, 2*K, + $ ONE, AB( JJAB ), 2*NMAX, W, + $ 2*NMAX, BETA, C( JJ, J ), + $ NMAX, CT, G, CC( JC ), LDC, + $ EPS, ERR, FATAL, NOUT, + $ .TRUE. ) + ELSE + DO 60 I = 1, K + IF( CONJ )THEN + W( I ) = ALPHA*DCONJG( AB( ( K + + $ I - 1 )*NMAX + J ) ) + W( K + I ) = DCONJG( ALPHA* + $ AB( ( I - 1 )*NMAX + + $ J ) ) + ELSE + W( I ) = ALPHA*AB( ( K + I - 1 )* + $ NMAX + J ) + W( K + I ) = ALPHA* + $ AB( ( I - 1 )*NMAX + + $ J ) + END IF + 60 CONTINUE + CALL ZMMCH( 'N', 'N', LJ, 1, 2*K, ONE, + $ AB( JJ ), NMAX, W, 2*NMAX, + $ BETA, C( JJ, J ), NMAX, CT, + $ G, CC( JC ), LDC, EPS, ERR, + $ FATAL, NOUT, .TRUE. ) + END IF + IF( UPPER )THEN + JC = JC + LDC + ELSE + JC = JC + LDC + 1 + IF( TRAN ) + $ JJAB = JJAB + 2*NMAX + END IF + ERRMAX = MAX( ERRMAX, ERR ) +* If got really bad answer, report and +* return. + IF( FATAL ) + $ GO TO 140 + 70 CONTINUE + END IF +* + 80 CONTINUE +* + 90 CONTINUE +* + 100 CONTINUE +* + 110 CONTINUE +* + 120 CONTINUE +* + 130 CONTINUE +* +* Report result. +* + IF( ERRMAX.LT.THRESH )THEN + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC + ELSE + IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX + IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX + END IF + GO TO 160 +* + 140 CONTINUE + IF( N.GT.1 ) + $ WRITE( NOUT, FMT = 9995 )J +* + 150 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + IF( CONJ )THEN + CALL ZPRCN7( NOUT, NC, SNAME, IORDER, UPLO, TRANS, N, K, + $ ALPHA, LDA, LDB, RBETA, LDC) + ELSE + CALL ZPRCN5( NOUT, NC, SNAME, IORDER, UPLO, TRANS, N, K, + $ ALPHA, LDA, LDB, BETA, LDC) + END IF +* + 160 CONTINUE + RETURN +* +10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', + $ ' (', I6, ' CALL', 'S)' ) + 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) + 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, ') .' ) + 9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', + $ '******' ) +* +* End of ZCHK5. +* + END +* + SUBROUTINE ZPRCN5(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, + $ N, K, ALPHA, LDA, LDB, BETA, LDC) + INTEGER NOUT, NC, IORDER, N, K, LDA, LDB, LDC + DOUBLE COMPLEX ALPHA, BETA + CHARACTER*1 UPLO, TRANSA + CHARACTER*12 SNAME + CHARACTER*14 CRC, CU, CA + + IF (UPLO.EQ.'U')THEN + CU = ' CblasUpper' + ELSE + CU = ' CblasLower' + END IF + IF (TRANSA.EQ.'N')THEN + CA = ' CblasNoTrans' + ELSE IF (TRANSA.EQ.'T')THEN + CA = ' CblasTrans' + ELSE + CA = 'CblasConjTrans' + END IF + IF (IORDER.EQ.1)THEN + CRC = ' CblasRowMajor' + ELSE + CRC = ' CblasColMajor' + END IF + WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA + WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, LDB, BETA, LDC + + 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') ) + 9994 FORMAT( 10X, 2( I3, ',' ), ' (', F4.1, ',', F4.1, '), A,', + $ I3, ', B', I3, ', (', F4.1, ',', F4.1, '), C,', I3, ').' ) + END +* +* + SUBROUTINE ZPRCN7(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, + $ N, K, ALPHA, LDA, LDB, BETA, LDC) + INTEGER NOUT, NC, IORDER, N, K, LDA, LDB, LDC + DOUBLE COMPLEX ALPHA + DOUBLE PRECISION BETA + CHARACTER*1 UPLO, TRANSA + CHARACTER*12 SNAME + CHARACTER*14 CRC, CU, CA + + IF (UPLO.EQ.'U')THEN + CU = ' CblasUpper' + ELSE + CU = ' CblasLower' + END IF + IF (TRANSA.EQ.'N')THEN + CA = ' CblasNoTrans' + ELSE IF (TRANSA.EQ.'T')THEN + CA = ' CblasTrans' + ELSE + CA = 'CblasConjTrans' + END IF + IF (IORDER.EQ.1)THEN + CRC = ' CblasRowMajor' + ELSE + CRC = ' CblasColMajor' + END IF + WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA + WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, LDB, BETA, LDC + + 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') ) + 9994 FORMAT( 10X, 2( I3, ',' ), ' (', F4.1, ',', F4.1, '), A,', + $ I3, ', B', I3, ',', F4.1, ', C,', I3, ').' ) + END +* + SUBROUTINE ZMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, + $ TRANSL ) +* +* 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 .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), + $ ONE = ( 1.0D0, 0.0D0 ) ) + COMPLEX*16 ROGUE + PARAMETER ( ROGUE = ( -1.0D10, 1.0D10 ) ) + DOUBLE PRECISION RZERO + PARAMETER ( RZERO = 0.0D0 ) + DOUBLE PRECISION RROGUE + PARAMETER ( RROGUE = -1.0D10 ) +* .. Scalar Arguments .. + COMPLEX*16 TRANSL + INTEGER LDA, M, N, NMAX + LOGICAL RESET + CHARACTER*1 DIAG, UPLO + CHARACTER*2 TYPE +* .. Array Arguments .. + COMPLEX*16 A( NMAX, * ), AA( * ) +* .. Local Scalars .. + INTEGER I, IBEG, IEND, J, JJ + LOGICAL GEN, HER, LOWER, SYM, TRI, UNIT, UPPER +* .. External Functions .. + COMPLEX*16 ZBEG + EXTERNAL ZBEG +* .. Intrinsic Functions .. + INTRINSIC DCMPLX, DCONJG, DBLE +* .. Executable Statements .. + GEN = TYPE.EQ.'ge' + HER = TYPE.EQ.'he' + SYM = TYPE.EQ.'sy' + TRI = TYPE.EQ.'tr' + UPPER = ( HER.OR.SYM.OR.TRI ).AND.UPLO.EQ.'U' + LOWER = ( HER.OR.SYM.OR.TRI ).AND.UPLO.EQ.'L' + UNIT = TRI.AND.DIAG.EQ.'U' +* +* Generate data in array A. +* + DO 20 J = 1, N + DO 10 I = 1, M + IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) + $ THEN + A( I, J ) = ZBEG( RESET ) + TRANSL + IF( I.NE.J )THEN +* Set some elements to zero + IF( N.GT.3.AND.J.EQ.N/2 ) + $ A( I, J ) = ZERO + IF( HER )THEN + A( J, I ) = DCONJG( A( I, J ) ) + ELSE IF( SYM )THEN + A( J, I ) = A( I, J ) + ELSE IF( TRI )THEN + A( J, I ) = ZERO + END IF + END IF + END IF + 10 CONTINUE + IF( HER ) + $ A( J, J ) = DCMPLX( DBLE( A( J, J ) ), RZERO ) + IF( TRI ) + $ A( J, J ) = A( J, J ) + ONE + IF( UNIT ) + $ A( J, J ) = ONE + 20 CONTINUE +* +* Store elements in array AS in data structure required by routine. +* + IF( TYPE.EQ.'ge' )THEN + DO 50 J = 1, N + DO 30 I = 1, M + AA( I + ( J - 1 )*LDA ) = A( I, J ) + 30 CONTINUE + DO 40 I = M + 1, LDA + AA( I + ( J - 1 )*LDA ) = ROGUE + 40 CONTINUE + 50 CONTINUE + ELSE IF( TYPE.EQ.'he'.OR.TYPE.EQ.'sy'.OR.TYPE.EQ.'tr' )THEN + DO 90 J = 1, N + IF( UPPER )THEN + IBEG = 1 + IF( UNIT )THEN + IEND = J - 1 + ELSE + IEND = J + END IF + ELSE + IF( UNIT )THEN + IBEG = J + 1 + ELSE + IBEG = J + END IF + IEND = N + END IF + DO 60 I = 1, IBEG - 1 + AA( I + ( J - 1 )*LDA ) = ROGUE + 60 CONTINUE + DO 70 I = IBEG, IEND + AA( I + ( J - 1 )*LDA ) = A( I, J ) + 70 CONTINUE + DO 80 I = IEND + 1, LDA + AA( I + ( J - 1 )*LDA ) = ROGUE + 80 CONTINUE + IF( HER )THEN + JJ = J + ( J - 1 )*LDA + AA( JJ ) = DCMPLX( DBLE( AA( JJ ) ), RROGUE ) + END IF + 90 CONTINUE + END IF + RETURN +* +* End of ZMAKE. +* + END + SUBROUTINE ZMMCH( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, + $ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, + $ NOUT, MV ) +* +* 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 .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ) ) + DOUBLE PRECISION RZERO, RONE + PARAMETER ( RZERO = 0.0D0, RONE = 1.0D0 ) +* .. Scalar Arguments .. + COMPLEX*16 ALPHA, BETA + DOUBLE PRECISION EPS, ERR + INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT + LOGICAL FATAL, MV + CHARACTER*1 TRANSA, TRANSB +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ CC( LDCC, * ), CT( * ) + DOUBLE PRECISION G( * ) +* .. Local Scalars .. + COMPLEX*16 CL + DOUBLE PRECISION ERRI + INTEGER I, J, K + LOGICAL CTRANA, CTRANB, TRANA, TRANB +* .. Intrinsic Functions .. + INTRINSIC ABS, DIMAG, DCONJG, MAX, DBLE, SQRT +* .. Statement Functions .. + DOUBLE PRECISION ABS1 +* .. Statement Function definitions .. + ABS1( CL ) = ABS( DBLE( CL ) ) + ABS( DIMAG( CL ) ) +* .. Executable Statements .. + TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' + TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' + CTRANA = TRANSA.EQ.'C' + CTRANB = TRANSB.EQ.'C' +* +* Compute expected result, one column at a time, in CT using data +* in A, B and C. +* Compute gauges in G. +* + DO 220 J = 1, N +* + DO 10 I = 1, M + CT( I ) = ZERO + G( I ) = RZERO + 10 CONTINUE + IF( .NOT.TRANA.AND..NOT.TRANB )THEN + DO 30 K = 1, KK + DO 20 I = 1, M + CT( I ) = CT( I ) + A( I, K )*B( K, J ) + G( I ) = G( I ) + ABS1( A( I, K ) )*ABS1( B( K, J ) ) + 20 CONTINUE + 30 CONTINUE + ELSE IF( TRANA.AND..NOT.TRANB )THEN + IF( CTRANA )THEN + DO 50 K = 1, KK + DO 40 I = 1, M + CT( I ) = CT( I ) + DCONJG( A( K, I ) )*B( K, J ) + G( I ) = G( I ) + ABS1( A( K, I ) )* + $ ABS1( B( K, J ) ) + 40 CONTINUE + 50 CONTINUE + ELSE + DO 70 K = 1, KK + DO 60 I = 1, M + CT( I ) = CT( I ) + A( K, I )*B( K, J ) + G( I ) = G( I ) + ABS1( A( K, I ) )* + $ ABS1( B( K, J ) ) + 60 CONTINUE + 70 CONTINUE + END IF + ELSE IF( .NOT.TRANA.AND.TRANB )THEN + IF( CTRANB )THEN + DO 90 K = 1, KK + DO 80 I = 1, M + CT( I ) = CT( I ) + A( I, K )*DCONJG( B( J, K ) ) + G( I ) = G( I ) + ABS1( A( I, K ) )* + $ ABS1( B( J, K ) ) + 80 CONTINUE + 90 CONTINUE + ELSE + DO 110 K = 1, KK + DO 100 I = 1, M + CT( I ) = CT( I ) + A( I, K )*B( J, K ) + G( I ) = G( I ) + ABS1( A( I, K ) )* + $ ABS1( B( J, K ) ) + 100 CONTINUE + 110 CONTINUE + END IF + ELSE IF( TRANA.AND.TRANB )THEN + IF( CTRANA )THEN + IF( CTRANB )THEN + DO 130 K = 1, KK + DO 120 I = 1, M + CT( I ) = CT( I ) + DCONJG( A( K, I ) )* + $ DCONJG( B( J, K ) ) + G( I ) = G( I ) + ABS1( A( K, I ) )* + $ ABS1( B( J, K ) ) + 120 CONTINUE + 130 CONTINUE + ELSE + DO 150 K = 1, KK + DO 140 I = 1, M + CT( I ) = CT( I ) + DCONJG( A( K, I ) )* + $ B( J, K ) + G( I ) = G( I ) + ABS1( A( K, I ) )* + $ ABS1( B( J, K ) ) + 140 CONTINUE + 150 CONTINUE + END IF + ELSE + IF( CTRANB )THEN + DO 170 K = 1, KK + DO 160 I = 1, M + CT( I ) = CT( I ) + A( K, I )* + $ DCONJG( B( J, K ) ) + G( I ) = G( I ) + ABS1( A( K, I ) )* + $ ABS1( B( J, K ) ) + 160 CONTINUE + 170 CONTINUE + ELSE + DO 190 K = 1, KK + DO 180 I = 1, M + CT( I ) = CT( I ) + A( K, I )*B( J, K ) + G( I ) = G( I ) + ABS1( A( K, I ) )* + $ ABS1( B( J, K ) ) + 180 CONTINUE + 190 CONTINUE + END IF + END IF + END IF + DO 200 I = 1, M + CT( I ) = ALPHA*CT( I ) + BETA*C( I, J ) + G( I ) = ABS1( ALPHA )*G( I ) + + $ ABS1( BETA )*ABS1( C( I, J ) ) + 200 CONTINUE +* +* Compute the error ratio for this result. +* + ERR = ZERO + DO 210 I = 1, M + ERRI = ABS1( CT( I ) - CC( I, J ) )/EPS + IF( G( I ).NE.RZERO ) + $ ERRI = ERRI/G( I ) + ERR = MAX( ERR, ERRI ) + IF( ERR*SQRT( EPS ).GE.RONE ) + $ GO TO 230 + 210 CONTINUE +* + 220 CONTINUE +* +* If the loop completes, all results are at least half accurate. + GO TO 250 +* +* Report fatal error. +* + 230 FATAL = .TRUE. + WRITE( NOUT, FMT = 9999 ) + DO 240 I = 1, M + IF( MV )THEN + WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J ) + ELSE + WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I ) + END IF + 240 CONTINUE + IF( N.GT.1 ) + $ WRITE( NOUT, FMT = 9997 )J +* + 250 CONTINUE + RETURN +* + 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', + $ 'F ACCURATE *******', /' EXPECTED RE', + $ 'SULT COMPUTED RESULT' ) + 9998 FORMAT( 1X, I7, 2( ' (', G15.6, ',', G15.6, ')' ) ) + 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) +* +* End of ZMMCH. +* + END + LOGICAL FUNCTION LZE( RI, RJ, LR ) +* +* 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 .. + INTEGER LR +* .. Array Arguments .. + COMPLEX*16 RI( * ), RJ( * ) +* .. Local Scalars .. + INTEGER I +* .. Executable Statements .. + DO 10 I = 1, LR + IF( RI( I ).NE.RJ( I ) ) + $ GO TO 20 + 10 CONTINUE + LZE = .TRUE. + GO TO 30 + 20 CONTINUE + LZE = .FALSE. + 30 RETURN +* +* End of LZE. +* + END + LOGICAL FUNCTION LZERES( TYPE, UPLO, M, N, AA, AS, LDA ) +* +* 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 .. + INTEGER LDA, M, N + CHARACTER*1 UPLO + CHARACTER*2 TYPE +* .. Array Arguments .. + COMPLEX*16 AA( LDA, * ), AS( LDA, * ) +* .. Local Scalars .. + INTEGER I, IBEG, IEND, J + LOGICAL UPPER +* .. Executable Statements .. + UPPER = UPLO.EQ.'U' + IF( TYPE.EQ.'ge' )THEN + DO 20 J = 1, N + DO 10 I = M + 1, LDA + IF( AA( I, J ).NE.AS( I, J ) ) + $ GO TO 70 + 10 CONTINUE + 20 CONTINUE + ELSE IF( TYPE.EQ.'he'.OR.TYPE.EQ.'sy' )THEN + DO 50 J = 1, N + IF( UPPER )THEN + IBEG = 1 + IEND = J + ELSE + IBEG = J + IEND = N + END IF + DO 30 I = 1, IBEG - 1 + IF( AA( I, J ).NE.AS( I, J ) ) + $ GO TO 70 + 30 CONTINUE + DO 40 I = IEND + 1, LDA + IF( AA( I, J ).NE.AS( I, J ) ) + $ GO TO 70 + 40 CONTINUE + 50 CONTINUE + END IF +* + 60 CONTINUE + LZERES = .TRUE. + GO TO 80 + 70 CONTINUE + LZERES = .FALSE. + 80 RETURN +* +* End of LZERES. +* + END + COMPLEX*16 FUNCTION ZBEG( RESET ) +* +* 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 .. + LOGICAL RESET +* .. Local Scalars .. + INTEGER I, IC, J, MI, MJ +* .. Save statement .. + SAVE I, IC, J, MI, MJ +* .. Intrinsic Functions .. + INTRINSIC DCMPLX +* .. Executable Statements .. + IF( RESET )THEN +* Initialize local variables. + MI = 891 + MJ = 457 + I = 7 + J = 7 + IC = 0 + RESET = .FALSE. + END IF +* +* 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 = IC + 1 + 10 I = I*MI + J = J*MJ + I = I - 1000*( I/1000 ) + J = J - 1000*( J/1000 ) + IF( IC.GE.5 )THEN + IC = 0 + GO TO 10 + END IF + ZBEG = DCMPLX( ( I - 500 )/1001.0D0, ( J - 500 )/1001.0D0 ) + RETURN +* +* End of ZBEG. +* + END + DOUBLE PRECISION FUNCTION DDIFF( X, Y ) +* +* 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 .. + DOUBLE PRECISION X, Y +* .. Executable Statements .. + DDIFF = X - Y + RETURN +* +* End of DDIFF. +* + END + diff --git a/cblas/testing/cblas_test.h b/cblas/testing/cblas_test.h new file mode 100644 index 00000000..21011f17 --- /dev/null +++ b/cblas/testing/cblas_test.h @@ -0,0 +1,513 @@ +/* + * cblas_test.h + * Written by Keita Teranishi + */ +#ifndef CBLAS_TEST_H +#define CBLAS_TEST_H +#include "cblas.h" + +#define TRUE 1 +#define PASSED 1 +#define TEST_ROW_MJR 1 + +#define FALSE 0 +#define FAILED 0 +#define TEST_COL_MJR 0 + +#define INVALID -1 +#define UNDEFINED -1 + +typedef struct { float real; float imag; } CBLAS_TEST_COMPLEX; +typedef struct { double real; double imag; } CBLAS_TEST_ZOMPLEX; + +#if defined(ADD_) + #define F77_xerbla xerbla_ +/* + * Level 1 BLAS + */ + #define F77_srotg srotgtest_ + #define F77_srotmg srotmgtest_ + #define F77_srot srottest_ + #define F77_srotm srotmtest_ + #define F77_drotg drotgtest_ + #define F77_drotmg drotmgtest_ + #define F77_drot drottest_ + #define F77_drotm drotmtest_ + #define F77_sswap sswaptest_ + #define F77_scopy scopytest_ + #define F77_saxpy saxpytest_ + #define F77_isamax isamaxtest_ + #define F77_dswap dswaptest_ + #define F77_dcopy dcopytest_ + #define F77_daxpy daxpytest_ + #define F77_idamax idamaxtest_ + #define F77_cswap cswaptest_ + #define F77_ccopy ccopytest_ + #define F77_caxpy caxpytest_ + #define F77_icamax icamaxtest_ + #define F77_zswap zswaptest_ + #define F77_zcopy zcopytest_ + #define F77_zaxpy zaxpytest_ + #define F77_izamax izamaxtest_ + #define F77_sdot sdottest_ + #define F77_ddot ddottest_ + #define F77_dsdot dsdottest_ + #define F77_sscal sscaltest_ + #define F77_dscal dscaltest_ + #define F77_cscal cscaltest_ + #define F77_zscal zscaltest_ + #define F77_csscal csscaltest_ + #define F77_zdscal zdscaltest_ + #define F77_cdotu cdotutest_ + #define F77_cdotc cdotctest_ + #define F77_zdotu zdotutest_ + #define F77_zdotc zdotctest_ + #define F77_snrm2 snrm2test_ + #define F77_sasum sasumtest_ + #define F77_dnrm2 dnrm2test_ + #define F77_dasum dasumtest_ + #define F77_scnrm2 scnrm2test_ + #define F77_scasum scasumtest_ + #define F77_dznrm2 dznrm2test_ + #define F77_dzasum dzasumtest_ + #define F77_sdsdot sdsdottest_ +/* + * Level 2 BLAS + */ + #define F77_s2chke cs2chke_ + #define F77_d2chke cd2chke_ + #define F77_c2chke cc2chke_ + #define F77_z2chke cz2chke_ + #define F77_ssymv cssymv_ + #define F77_ssbmv cssbmv_ + #define F77_sspmv csspmv_ + #define F77_sger csger_ + #define F77_ssyr cssyr_ + #define F77_sspr csspr_ + #define F77_ssyr2 cssyr2_ + #define F77_sspr2 csspr2_ + #define F77_dsymv cdsymv_ + #define F77_dsbmv cdsbmv_ + #define F77_dspmv cdspmv_ + #define F77_dger cdger_ + #define F77_dsyr cdsyr_ + #define F77_dspr cdspr_ + #define F77_dsyr2 cdsyr2_ + #define F77_dspr2 cdspr2_ + #define F77_chemv cchemv_ + #define F77_chbmv cchbmv_ + #define F77_chpmv cchpmv_ + #define F77_cgeru ccgeru_ + #define F77_cgerc ccgerc_ + #define F77_cher ccher_ + #define F77_chpr cchpr_ + #define F77_cher2 ccher2_ + #define F77_chpr2 cchpr2_ + #define F77_zhemv czhemv_ + #define F77_zhbmv czhbmv_ + #define F77_zhpmv czhpmv_ + #define F77_zgeru czgeru_ + #define F77_zgerc czgerc_ + #define F77_zher czher_ + #define F77_zhpr czhpr_ + #define F77_zher2 czher2_ + #define F77_zhpr2 czhpr2_ + #define F77_sgemv csgemv_ + #define F77_sgbmv csgbmv_ + #define F77_strmv cstrmv_ + #define F77_stbmv cstbmv_ + #define F77_stpmv cstpmv_ + #define F77_strsv cstrsv_ + #define F77_stbsv cstbsv_ + #define F77_stpsv cstpsv_ + #define F77_dgemv cdgemv_ + #define F77_dgbmv cdgbmv_ + #define F77_dtrmv cdtrmv_ + #define F77_dtbmv cdtbmv_ + #define F77_dtpmv cdtpmv_ + #define F77_dtrsv cdtrsv_ + #define F77_dtbsv cdtbsv_ + #define F77_dtpsv cdtpsv_ + #define F77_cgemv ccgemv_ + #define F77_cgbmv ccgbmv_ + #define F77_ctrmv cctrmv_ + #define F77_ctbmv cctbmv_ + #define F77_ctpmv cctpmv_ + #define F77_ctrsv cctrsv_ + #define F77_ctbsv cctbsv_ + #define F77_ctpsv cctpsv_ + #define F77_zgemv czgemv_ + #define F77_zgbmv czgbmv_ + #define F77_ztrmv cztrmv_ + #define F77_ztbmv cztbmv_ + #define F77_ztpmv cztpmv_ + #define F77_ztrsv cztrsv_ + #define F77_ztbsv cztbsv_ + #define F77_ztpsv cztpsv_ +/* + * Level 3 BLAS + */ + #define F77_s3chke cs3chke_ + #define F77_d3chke cd3chke_ + #define F77_c3chke cc3chke_ + #define F77_z3chke cz3chke_ + #define F77_chemm cchemm_ + #define F77_cherk ccherk_ + #define F77_cher2k ccher2k_ + #define F77_zhemm czhemm_ + #define F77_zherk czherk_ + #define F77_zher2k czher2k_ + #define F77_sgemm csgemm_ + #define F77_ssymm cssymm_ + #define F77_ssyrk cssyrk_ + #define F77_ssyr2k cssyr2k_ + #define F77_strmm cstrmm_ + #define F77_strsm cstrsm_ + #define F77_dgemm cdgemm_ + #define F77_dsymm cdsymm_ + #define F77_dsyrk cdsyrk_ + #define F77_dsyr2k cdsyr2k_ + #define F77_dtrmm cdtrmm_ + #define F77_dtrsm cdtrsm_ + #define F77_cgemm ccgemm_ + #define F77_csymm ccsymm_ + #define F77_csyrk ccsyrk_ + #define F77_csyr2k ccsyr2k_ + #define F77_ctrmm cctrmm_ + #define F77_ctrsm cctrsm_ + #define F77_zgemm czgemm_ + #define F77_zsymm czsymm_ + #define F77_zsyrk czsyrk_ + #define F77_zsyr2k czsyr2k_ + #define F77_ztrmm cztrmm_ + #define F77_ztrsm cztrsm_ +#elif defined(UPCASE) + #define F77_xerbla XERBLA +/* + * Level 1 BLAS + */ + #define F77_srotg SROTGTEST + #define F77_srotmg SROTMGTEST + #define F77_srot SROTCTEST + #define F77_srotm SROTMTEST + #define F77_drotg DROTGTEST + #define F77_drotmg DROTMGTEST + #define F77_drot DROTTEST + #define F77_drotm DROTMTEST + #define F77_sswap SSWAPTEST + #define F77_scopy SCOPYTEST + #define F77_saxpy SAXPYTEST + #define F77_isamax ISAMAXTEST + #define F77_dswap DSWAPTEST + #define F77_dcopy DCOPYTEST + #define F77_daxpy DAXPYTEST + #define F77_idamax IDAMAXTEST + #define F77_cswap CSWAPTEST + #define F77_ccopy CCOPYTEST + #define F77_caxpy CAXPYTEST + #define F77_icamax ICAMAXTEST + #define F77_zswap ZSWAPTEST + #define F77_zcopy ZCOPYTEST + #define F77_zaxpy ZAXPYTEST + #define F77_izamax IZAMAXTEST + #define F77_sdot SDOTTEST + #define F77_ddot DDOTTEST + #define F77_dsdot DSDOTTEST + #define F77_sscal SSCALTEST + #define F77_dscal DSCALTEST + #define F77_cscal CSCALTEST + #define F77_zscal ZSCALTEST + #define F77_csscal CSSCALTEST + #define F77_zdscal ZDSCALTEST + #define F77_cdotu CDOTUTEST + #define F77_cdotc CDOTCTEST + #define F77_zdotu ZDOTUTEST + #define F77_zdotc ZDOTCTEST + #define F77_snrm2 SNRM2TEST + #define F77_sasum SASUMTEST + #define F77_dnrm2 DNRM2TEST + #define F77_dasum DASUMTEST + #define F77_scnrm2 SCNRM2TEST + #define F77_scasum SCASUMTEST + #define F77_dznrm2 DZNRM2TEST + #define F77_dzasum DZASUMTEST + #define F77_sdsdot SDSDOTTEST +/* + * Level 2 BLAS + */ + #define F77_s2chke CS2CHKE + #define F77_d2chke CD2CHKE + #define F77_c2chke CC2CHKE + #define F77_z2chke CZ2CHKE + #define F77_ssymv CSSYMV + #define F77_ssbmv CSSBMV + #define F77_sspmv CSSPMV + #define F77_sger CSGER + #define F77_ssyr CSSYR + #define F77_sspr CSSPR + #define F77_ssyr2 CSSYR2 + #define F77_sspr2 CSSPR2 + #define F77_dsymv CDSYMV + #define F77_dsbmv CDSBMV + #define F77_dspmv CDSPMV + #define F77_dger CDGER + #define F77_dsyr CDSYR + #define F77_dspr CDSPR + #define F77_dsyr2 CDSYR2 + #define F77_dspr2 CDSPR2 + #define F77_chemv CCHEMV + #define F77_chbmv CCHBMV + #define F77_chpmv CCHPMV + #define F77_cgeru CCGERU + #define F77_cgerc CCGERC + #define F77_cher CCHER + #define F77_chpr CCHPR + #define F77_cher2 CCHER2 + #define F77_chpr2 CCHPR2 + #define F77_zhemv CZHEMV + #define F77_zhbmv CZHBMV + #define F77_zhpmv CZHPMV + #define F77_zgeru CZGERU + #define F77_zgerc CZGERC + #define F77_zher CZHER + #define F77_zhpr CZHPR + #define F77_zher2 CZHER2 + #define F77_zhpr2 CZHPR2 + #define F77_sgemv CSGEMV + #define F77_sgbmv CSGBMV + #define F77_strmv CSTRMV + #define F77_stbmv CSTBMV + #define F77_stpmv CSTPMV + #define F77_strsv CSTRSV + #define F77_stbsv CSTBSV + #define F77_stpsv CSTPSV + #define F77_dgemv CDGEMV + #define F77_dgbmv CDGBMV + #define F77_dtrmv CDTRMV + #define F77_dtbmv CDTBMV + #define F77_dtpmv CDTPMV + #define F77_dtrsv CDTRSV + #define F77_dtbsv CDTBSV + #define F77_dtpsv CDTPSV + #define F77_cgemv CCGEMV + #define F77_cgbmv CCGBMV + #define F77_ctrmv CCTRMV + #define F77_ctbmv CCTBMV + #define F77_ctpmv CCTPMV + #define F77_ctrsv CCTRSV + #define F77_ctbsv CCTBSV + #define F77_ctpsv CCTPSV + #define F77_zgemv CZGEMV + #define F77_zgbmv CZGBMV + #define F77_ztrmv CZTRMV + #define F77_ztbmv CZTBMV + #define F77_ztpmv CZTPMV + #define F77_ztrsv CZTRSV + #define F77_ztbsv CZTBSV + #define F77_ztpsv CZTPSV +/* + * Level 3 BLAS + */ + #define F77_s3chke CS3CHKE + #define F77_d3chke CD3CHKE + #define F77_c3chke CC3CHKE + #define F77_z3chke CZ3CHKE + #define F77_chemm CCHEMM + #define F77_cherk CCHERK + #define F77_cher2k CCHER2K + #define F77_zhemm CZHEMM + #define F77_zherk CZHERK + #define F77_zher2k CZHER2K + #define F77_sgemm CSGEMM + #define F77_ssymm CSSYMM + #define F77_ssyrk CSSYRK + #define F77_ssyr2k CSSYR2K + #define F77_strmm CSTRMM + #define F77_strsm CSTRSM + #define F77_dgemm CDGEMM + #define F77_dsymm CDSYMM + #define F77_dsyrk CDSYRK + #define F77_dsyr2k CDSYR2K + #define F77_dtrmm CDTRMM + #define F77_dtrsm CDTRSM + #define F77_cgemm CCGEMM + #define F77_csymm CCSYMM + #define F77_csyrk CCSYRK + #define F77_csyr2k CCSYR2K + #define F77_ctrmm CCTRMM + #define F77_ctrsm CCTRSM + #define F77_zgemm CZGEMM + #define F77_zsymm CZSYMM + #define F77_zsyrk CZSYRK + #define F77_zsyr2k CZSYR2K + #define F77_ztrmm CZTRMM + #define F77_ztrsm CZTRSM +#elif defined(NOCHANGE) + #define F77_xerbla xerbla +/* + * Level 1 BLAS + */ + #define F77_srotg srotgtest + #define F77_srotmg srotmgtest + #define F77_srot srottest + #define F77_srotm srotmtest + #define F77_drotg drotgtest + #define F77_drotmg drotmgtest + #define F77_drot drottest + #define F77_drotm drotmtest + #define F77_sswap sswaptest + #define F77_scopy scopytest + #define F77_saxpy saxpytest + #define F77_isamax isamaxtest + #define F77_dswap dswaptest + #define F77_dcopy dcopytest + #define F77_daxpy daxpytest + #define F77_idamax idamaxtest + #define F77_cswap cswaptest + #define F77_ccopy ccopytest + #define F77_caxpy caxpytest + #define F77_icamax icamaxtest + #define F77_zswap zswaptest + #define F77_zcopy zcopytest + #define F77_zaxpy zaxpytest + #define F77_izamax izamaxtest + #define F77_sdot sdottest + #define F77_ddot ddottest + #define F77_dsdot dsdottest + #define F77_sscal sscaltest + #define F77_dscal dscaltest + #define F77_cscal cscaltest + #define F77_zscal zscaltest + #define F77_csscal csscaltest + #define F77_zdscal zdscaltest + #define F77_cdotu cdotutest + #define F77_cdotc cdotctest + #define F77_zdotu zdotutest + #define F77_zdotc zdotctest + #define F77_snrm2 snrm2test + #define F77_sasum sasumtest + #define F77_dnrm2 dnrm2test + #define F77_dasum dasumtest + #define F77_scnrm2 scnrm2test + #define F77_scasum scasumtest + #define F77_dznrm2 dznrm2test + #define F77_dzasum dzasumtest + #define F77_sdsdot sdsdottest +/* + * Level 2 BLAS + */ + #define F77_s2chke cs2chke + #define F77_d2chke cd2chke + #define F77_c2chke cc2chke + #define F77_z2chke cz2chke + #define F77_ssymv cssymv + #define F77_ssbmv cssbmv + #define F77_sspmv csspmv + #define F77_sger csger + #define F77_ssyr cssyr + #define F77_sspr csspr + #define F77_ssyr2 cssyr2 + #define F77_sspr2 csspr2 + #define F77_dsymv cdsymv + #define F77_dsbmv cdsbmv + #define F77_dspmv cdspmv + #define F77_dger cdger + #define F77_dsyr cdsyr + #define F77_dspr cdspr + #define F77_dsyr2 cdsyr2 + #define F77_dspr2 cdspr2 + #define F77_chemv cchemv + #define F77_chbmv cchbmv + #define F77_chpmv cchpmv + #define F77_cgeru ccgeru + #define F77_cgerc ccgerc + #define F77_cher ccher + #define F77_chpr cchpr + #define F77_cher2 ccher2 + #define F77_chpr2 cchpr2 + #define F77_zhemv czhemv + #define F77_zhbmv czhbmv + #define F77_zhpmv czhpmv + #define F77_zgeru czgeru + #define F77_zgerc czgerc + #define F77_zher czher + #define F77_zhpr czhpr + #define F77_zher2 czher2 + #define F77_zhpr2 czhpr2 + #define F77_sgemv csgemv + #define F77_sgbmv csgbmv + #define F77_strmv cstrmv + #define F77_stbmv cstbmv + #define F77_stpmv cstpmv + #define F77_strsv cstrsv + #define F77_stbsv cstbsv + #define F77_stpsv cstpsv + #define F77_dgemv cdgemv + #define F77_dgbmv cdgbmv + #define F77_dtrmv cdtrmv + #define F77_dtbmv cdtbmv + #define F77_dtpmv cdtpmv + #define F77_dtrsv cdtrsv + #define F77_dtbsv cdtbsv + #define F77_dtpsv cdtpsv + #define F77_cgemv ccgemv + #define F77_cgbmv ccgbmv + #define F77_ctrmv cctrmv + #define F77_ctbmv cctbmv + #define F77_ctpmv cctpmv + #define F77_ctrsv cctrsv + #define F77_ctbsv cctbsv + #define F77_ctpsv cctpsv + #define F77_zgemv czgemv + #define F77_zgbmv czgbmv + #define F77_ztrmv cztrmv + #define F77_ztbmv cztbmv + #define F77_ztpmv cztpmv + #define F77_ztrsv cztrsv + #define F77_ztbsv cztbsv + #define F77_ztpsv cztpsv +/* + * Level 3 BLAS + */ + #define F77_s3chke cs3chke + #define F77_d3chke cd3chke + #define F77_c3chke cc3chke + #define F77_z3chke cz3chke + #define F77_chemm cchemm + #define F77_cherk ccherk + #define F77_cher2k ccher2k + #define F77_zhemm czhemm + #define F77_zherk czherk + #define F77_zher2k czher2k + #define F77_sgemm csgemm + #define F77_ssymm cssymm + #define F77_ssyrk cssyrk + #define F77_ssyr2k cssyr2k + #define F77_strmm cstrmm + #define F77_strsm cstrsm + #define F77_dgemm cdgemm + #define F77_dsymm cdsymm + #define F77_dsyrk cdsyrk + #define F77_dsyr2k cdsyr2k + #define F77_dtrmm cdtrmm + #define F77_dtrsm cdtrsm + #define F77_cgemm ccgemm + #define F77_csymm ccsymm + #define F77_csyrk ccsyrk + #define F77_csyr2k ccsyr2k + #define F77_ctrmm cctrmm + #define F77_ctrsm cctrsm + #define F77_zgemm czgemm + #define F77_zsymm czsymm + #define F77_zsyrk czsyrk + #define F77_zsyr2k czsyr2k + #define F77_ztrmm cztrmm + #define F77_ztrsm cztrsm +#endif + +void get_transpose_type(char *type, CBLAS_TRANSPOSE *trans); +void get_uplo_type(char *type, CBLAS_UPLO *uplo); +void get_diag_type(char *type, CBLAS_DIAG *diag); +void get_side_type(char *type, CBLAS_SIDE *side); + +#endif /* CBLAS_TEST_H */ diff --git a/cblas/testing/cin2 b/cblas/testing/cin2 new file mode 100644 index 00000000..5c613d16 --- /dev/null +++ b/cblas/testing/cin2 @@ -0,0 +1,34 @@ +'CBLAT2.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 LOGICAL FLAG, T TO TEST ROW-MAJOR (IF FALSE COLUMN-MAJOR IS TESTED) +16.0 THRESHOLD VALUE OF TEST RATIO +6 NUMBER OF VALUES OF N +0 1 2 3 5 9 VALUES OF N +4 NUMBER OF VALUES OF K +0 1 2 4 VALUES OF K +4 NUMBER OF VALUES OF INCX AND INCY +1 2 -1 -2 VALUES OF INCX AND INCY +3 NUMBER OF VALUES OF ALPHA +(0.0,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_cgemv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_cgbmv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_chemv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_chbmv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_chpmv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_ctrmv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_ctbmv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_ctpmv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_ctrsv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_ctbsv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_ctpsv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_cgerc T PUT F FOR NO TEST. SAME COLUMNS. +cblas_cgeru T PUT F FOR NO TEST. SAME COLUMNS. +cblas_cher T PUT F FOR NO TEST. SAME COLUMNS. +cblas_chpr T PUT F FOR NO TEST. SAME COLUMNS. +cblas_cher2 T PUT F FOR NO TEST. SAME COLUMNS. +cblas_chpr2 T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/cblas/testing/cin3 b/cblas/testing/cin3 new file mode 100644 index 00000000..7b34f267 --- /dev/null +++ b/cblas/testing/cin3 @@ -0,0 +1,22 @@ +'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 +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. diff --git a/cblas/testing/din2 b/cblas/testing/din2 new file mode 100644 index 00000000..000351c7 --- /dev/null +++ b/cblas/testing/din2 @@ -0,0 +1,33 @@ +'DBLAT2.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 +4 NUMBER OF VALUES OF K +0 1 2 4 VALUES OF K +4 NUMBER OF VALUES OF INCX AND INCY +1 2 -1 -2 VALUES OF INCX AND INCY +3 NUMBER OF VALUES OF ALPHA +0.0 1.0 0.7 VALUES OF ALPHA +3 NUMBER OF VALUES OF BETA +0.0 1.0 0.9 VALUES OF BETA +cblas_dgemv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_dgbmv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_dsymv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_dsbmv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_dspmv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_dtrmv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_dtbmv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_dtpmv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_dtrsv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_dtbsv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_dtpsv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_dger T PUT F FOR NO TEST. SAME COLUMNS. +cblas_dsyr T PUT F FOR NO TEST. SAME COLUMNS. +cblas_dspr T PUT F FOR NO TEST. SAME COLUMNS. +cblas_dsyr2 T PUT F FOR NO TEST. SAME COLUMNS. +cblas_dspr2 T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/cblas/testing/din3 b/cblas/testing/din3 new file mode 100644 index 00000000..1f777156 --- /dev/null +++ b/cblas/testing/din3 @@ -0,0 +1,19 @@ +'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 +1 2 3 5 7 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. diff --git a/cblas/testing/sin2 b/cblas/testing/sin2 new file mode 100644 index 00000000..b5bb12d0 --- /dev/null +++ b/cblas/testing/sin2 @@ -0,0 +1,33 @@ +'SBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE +-1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) +F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. +F LOGICAL FLAG, T TO STOP ON FAILURES. +T LOGICAL FLAG, T TO TEST ERROR EXITS. +2 LOGICAL FLAG, T TO TEST ROW-MAJOR (IF FALSE COLUMN-MAJOR IS TESTED) +16.0 THRESHOLD VALUE OF TEST RATIO +6 NUMBER OF VALUES OF N +0 1 2 3 5 9 VALUES OF N +4 NUMBER OF VALUES OF K +0 1 2 4 VALUES OF K +4 NUMBER OF VALUES OF INCX AND INCY +1 2 -1 -2 VALUES OF INCX AND INCY +3 NUMBER OF VALUES OF ALPHA +0.0 1.0 0.7 VALUES OF ALPHA +3 NUMBER OF VALUES OF BETA +0.0 1.0 0.9 VALUES OF BETA +cblas_sgemv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_sgbmv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_ssymv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_ssbmv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_sspmv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_strmv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_stbmv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_stpmv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_strsv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_stbsv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_stpsv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_sger T PUT F FOR NO TEST. SAME COLUMNS. +cblas_ssyr T PUT F FOR NO TEST. SAME COLUMNS. +cblas_sspr T PUT F FOR NO TEST. SAME COLUMNS. +cblas_ssyr2 T PUT F FOR NO TEST. SAME COLUMNS. +cblas_sspr2 T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/cblas/testing/sin3 b/cblas/testing/sin3 new file mode 100644 index 00000000..aa18530c --- /dev/null +++ b/cblas/testing/sin3 @@ -0,0 +1,19 @@ +'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. diff --git a/cblas/testing/zin2 b/cblas/testing/zin2 new file mode 100644 index 00000000..fb74abab --- /dev/null +++ b/cblas/testing/zin2 @@ -0,0 +1,34 @@ +'ZBLAT2.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 LOGICAL FLAG, T TO TEST ROW-MAJOR (IF FALSE COLUMN-MAJOR IS TESTED) +16.0 THRESHOLD VALUE OF TEST RATIO +6 NUMBER OF VALUES OF N +0 1 2 3 5 9 VALUES OF N +4 NUMBER OF VALUES OF K +0 1 2 4 VALUES OF K +4 NUMBER OF VALUES OF INCX AND INCY +1 2 -1 -2 VALUES OF INCX AND INCY +3 NUMBER OF VALUES OF ALPHA +(0.0,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_zgemv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_zgbmv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_zhemv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_zhbmv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_zhpmv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_ztrmv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_ztbmv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_ztpmv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_ztrsv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_ztbsv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_ztpsv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_zgerc T PUT F FOR NO TEST. SAME COLUMNS. +cblas_zgeru T PUT F FOR NO TEST. SAME COLUMNS. +cblas_zher T PUT F FOR NO TEST. SAME COLUMNS. +cblas_zhpr T PUT F FOR NO TEST. SAME COLUMNS. +cblas_zher2 T PUT F FOR NO TEST. SAME COLUMNS. +cblas_zhpr2 T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/cblas/testing/zin3 b/cblas/testing/zin3 new file mode 100644 index 00000000..90a65759 --- /dev/null +++ b/cblas/testing/zin3 @@ -0,0 +1,22 @@ +'ZBLAT3.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 +cblas_zgemm T PUT F FOR NO TEST. SAME COLUMNS. +cblas_zhemm T PUT F FOR NO TEST. SAME COLUMNS. +cblas_zsymm T PUT F FOR NO TEST. SAME COLUMNS. +cblas_ztrmm T PUT F FOR NO TEST. SAME COLUMNS. +cblas_ztrsm T PUT F FOR NO TEST. SAME COLUMNS. +cblas_zherk T PUT F FOR NO TEST. SAME COLUMNS. +cblas_zsyrk T PUT F FOR NO TEST. SAME COLUMNS. +cblas_zher2k T PUT F FOR NO TEST. SAME COLUMNS. +cblas_zsyr2k T PUT F FOR NO TEST. SAME COLUMNS. |