--- /dev/null
+cmake_minimum_required(VERSION 2.8.10)
+project(CBLAS C)
+enable_language(Fortran)
+
+include_directories( include )
+add_subdirectory(src)
+
--- /dev/null
+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 )
--- /dev/null
+#
+# 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
--- /dev/null
+#
+# 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
--- /dev/null
+#
+# 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
--- /dev/null
+#
+# 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
--- /dev/null
+#
+# 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
--- /dev/null
+#
+# 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
--- /dev/null
+#
+# 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
--- /dev/null
+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.
--- /dev/null
+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
--- /dev/null
+/* 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;
+}
--- /dev/null
+/* 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;
+}
--- /dev/null
+#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
--- /dev/null
+/*
+ * 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 */
--- /dev/null
+# 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
--- /dev/null
+# 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
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
+
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+#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);
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
+
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+int CBLAS_CallFromC=0;
+int RowMajorStrg=0;
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
+
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+#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);
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+/*
+ *
+ * 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;
+}
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+#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);
+ }
+}
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+#
+# 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
--- /dev/null
+/*
+ * 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;
+}
--- /dev/null
+#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);
+}
--- /dev/null
+#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);
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+ 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
--- /dev/null
+ 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
--- /dev/null
+ 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
--- /dev/null
+#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);
+}
--- /dev/null
+#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);
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ * 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 );
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+ 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
--- /dev/null
+ 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
--- /dev/null
+ 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
--- /dev/null
+#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);
+}
--- /dev/null
+#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);
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ * 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 );
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+ 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
--- /dev/null
+ 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
--- /dev/null
+ 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
--- /dev/null
+#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,"");
+}
--- /dev/null
+#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);
+}
--- /dev/null
+#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);
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+ 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
--- /dev/null
+ 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
--- /dev/null
+ 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
+
--- /dev/null
+/*
+ * 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 */
--- /dev/null
+'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.
--- /dev/null
+'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.
--- /dev/null
+'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.
--- /dev/null
+'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.
--- /dev/null
+'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.
--- /dev/null
+'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.
--- /dev/null
+'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.
--- /dev/null
+'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.
projects / platform / upstream / lapack.git / commitdiff