diff --git a/CMakeLists.txt b/CMakeLists.txt index 8d1f99608..ac42f8b88 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -314,16 +314,16 @@ endif() if (NOT NOFORTRAN) # Build test and ctest add_subdirectory(test) - if(NOT NO_CBLAS) - add_subdirectory(ctest) - endif() if (BUILD_TESTING) add_subdirectory(lapack-netlib/TESTING) endif() +endif() + if(NOT NO_CBLAS) + add_subdirectory(ctest) + endif() if (CPP_THREAD_SAFETY_TEST OR CPP_THREAD_SAFETY_GEMV) add_subdirectory(cpp_thread_test) endif() -endif() set_target_properties(${OpenBLAS_LIBS} PROPERTIES VERSION ${OpenBLAS_MAJOR_VERSION}.${OpenBLAS_MINOR_VERSION} @@ -398,13 +398,13 @@ if (BUILD_SHARED_LIBS AND NOT ${SYMBOLPREFIX}${SYMBOLSUFFIX} STREQUAL "") if (NOT DEFINED USE_PERL) add_custom_command(TARGET ${OpenBLAS_LIBNAME}_shared POST_BUILD - COMMAND ${PROJECT_SOURCE_DIR}/exports/gensymbol "objcopy" "${ARCH}" "${BU}" "${EXPRECISION_IN}" "${NO_CBLAS_IN}" "${NO_LAPACK_IN}" "${NO_LAPACKE_IN}" "${NEED2UNDERSCORES_IN}" "${ONLY_CBLAS_IN}" \"${SYMBOLPREFIX}\" \"${SYMBOLSUFFIX}\" "${BUILD_LAPACK_DEPRECATED}" > ${PROJECT_BINARY_DIR}/objcopy.def + COMMAND ${PROJECT_SOURCE_DIR}/exports/gensymbol "objcopy" "${ARCH}" "${BU}" "${EXPRECISION_IN}" "${NO_CBLAS_IN}" "${NO_LAPACK_IN}" "${NO_LAPACKE_IN}" "${NEED2UNDERSCORES_IN}" "${ONLY_CBLAS_IN}" \"${SYMBOLPREFIX}\" \"${SYMBOLSUFFIX}\" "${BUILD_LAPACK_DEPRECATED}" "${BUILD_BFLOAT16}" "${BUILD_SINGLE}" "${BUILD_DOUBLE}" "${BUILD_COMPLEX}" "${BUILD_COMPLEX16}" > ${PROJECT_BINARY_DIR}/objcopy.def COMMAND objcopy -v --redefine-syms ${PROJECT_BINARY_DIR}/objcopy.def ${PROJECT_BINARY_DIR}/lib/lib${OpenBLAS_LIBNAME}.so COMMENT "renaming symbols" ) else() add_custom_command(TARGET ${OpenBLAS_LIBNAME}_shared POST_BUILD - COMMAND perl ${PROJECT_SOURCE_DIR}/exports/gensymbol.pl "objcopy" "${ARCH}" "${BU}" "${EXPRECISION_IN}" "${NO_CBLAS_IN}" "${NO_LAPACK_IN}" "${NO_LAPACKE_IN}" "${NEED2UNDERSCORES_IN}" "${ONLY_CBLAS_IN}" \"${SYMBOLPREFIX}\" \"${SYMBOLSUFFIX}\" "${BUILD_LAPACK_DEPRECATED}" > ${PROJECT_BINARY_DIR}/objcopy.def + COMMAND perl ${PROJECT_SOURCE_DIR}/exports/gensymbol.pl "objcopy" "${ARCH}" "${BU}" "${EXPRECISION_IN}" "${NO_CBLAS_IN}" "${NO_LAPACK_IN}" "${NO_LAPACKE_IN}" "${NEED2UNDERSCORES_IN}" "${ONLY_CBLAS_IN}" \"${SYMBOLPREFIX}\" \"${SYMBOLSUFFIX}\" "${BUILD_LAPACK_DEPRECATED}" "${BUILD_BFLOAT16}" "${BUILD_SINGLE}" "${BUILD_DOUBLE}" "${BUILD_COMPLEX}" "${BUILD_COMPLEX16}" > ${PROJECT_BINARY_DIR}/objcopy.def COMMAND objcopy -v --redefine-syms ${PROJECT_BINARY_DIR}/objcopy.def ${PROJECT_BINARY_DIR}/lib/lib${OpenBLAS_LIBNAME}.so COMMENT "renaming symbols" ) diff --git a/Makefile b/Makefile index 1ed8180b8..967ab1bb6 100644 --- a/Makefile +++ b/Makefile @@ -149,14 +149,18 @@ ifeq ($(NOFORTRAN), $(filter 0,$(NOFORTRAN))) ifndef NO_FBLAS $(MAKE) -C test all endif +endif +ifneq ($(ONLY_CBLAS), 1) $(MAKE) -C utest all +endif ifneq ($(NO_CBLAS), 1) +ifneq ($(ONLY_CBLAS), 1) $(MAKE) -C ctest all +endif ifeq ($(CPP_THREAD_SAFETY_TEST), 1) $(MAKE) -C cpp_thread_test all endif endif -endif libs : ifeq ($(CORE), UNKNOWN) diff --git a/Makefile.system b/Makefile.system index b1593e8f5..8a62eb3a3 100644 --- a/Makefile.system +++ b/Makefile.system @@ -1042,10 +1042,12 @@ FCOMMON_OPT += -frecursive FCOMMON_OPT += -fno-optimize-sibling-calls #Don't include -lgfortran, when NO_LAPACK=1 or lsbcc ifneq ($(NOFORTRAN), 1) +ifneq ($(NOFORTRAN), 2) ifneq ($(NO_LAPACK), 1) EXTRALIB += -lgfortran endif endif +endif ifdef NO_BINARY_MODE ifeq ($(ARCH), $(filter $(ARCH),mips64)) ifdef BINARY64 diff --git a/azure-pipelines.yml b/azure-pipelines.yml index 4feff1f3a..622a2fe32 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -163,11 +163,12 @@ jobs: variables: LD_LIBRARY_PATH: /usr/local/opt/llvm/lib LIBRARY_PATH: /usr/local/opt/llvm/lib + MACOSX_DEPLOYMENT_TARGET: 11.0 steps: - script: | brew update brew install llvm libomp - make TARGET=CORE2 USE_OPENMP=1 INTERFACE64=1 DYNAMIC_ARCH=1 CC=/usr/local/opt/llvm/bin/clang FC=gfortran-10 + make TARGET=CORE2 USE_OPENMP=1 DYNAMIC_ARCH=1 CC=/usr/local/opt/llvm/bin/clang NOFORTRAN=1 - job: OSX_OpenMP_Clang_cmake pool: diff --git a/ctest/CMakeLists.txt b/ctest/CMakeLists.txt index f785d3f90..e779fb168 100644 --- a/ctest/CMakeLists.txt +++ b/ctest/CMakeLists.txt @@ -1,7 +1,9 @@ include_directories(${PROJECT_SOURCE_DIR}) include_directories(${PROJECT_BINARY_DIR}) +if (NOT NOFORTRAN) enable_language(Fortran) +endif() set(CMAKE_C_FLAGS "${CMAKE_C_FLAGS} -DADD${BU} -DCBLAS") if (CMAKE_Fortran_COMPILER_ID STREQUAL GNU) @@ -28,14 +30,24 @@ foreach(float_type ${FLOAT_TYPES}) continue() endif() #level1 +if (NOT NOFORTRAN) add_executable(x${float_char}cblat1 c_${float_char}blat1.f c_${float_char}blas1.c) +else() + add_executable(x${float_char}cblat1 + c_${float_char}blat1c.c + c_${float_char}blas1.c) +endif() target_link_libraries(x${float_char}cblat1 ${OpenBLAS_LIBNAME}) + if(${CMAKE_SYSTEM_NAME} MATCHES "Linux" OR ${CMAKE_SYSTEM_NAME} MATCHES "FreeBSD") + target_link_libraries(x${float_char}cblat1 m) + endif() add_test(NAME "x${float_char}cblat1" COMMAND $) #level2 +if (NOT NOFORTRAN) add_executable(x${float_char}cblat2 c_${float_char}blat2.f c_${float_char}blas2.c @@ -43,11 +55,24 @@ foreach(float_type ${FLOAT_TYPES}) auxiliary.c c_xerbla.c constant.c) +else() + add_executable(x${float_char}cblat2 + c_${float_char}blat2c.c + c_${float_char}blas2.c + c_${float_char}2chke.c + auxiliary.c + c_xerbla.c + constant.c) +endif() target_link_libraries(x${float_char}cblat2 ${OpenBLAS_LIBNAME}) + if(${CMAKE_SYSTEM_NAME} MATCHES "Linux" OR ${CMAKE_SYSTEM_NAME} MATCHES "FreeBSD") + target_link_libraries(x${float_char}cblat2 m) + endif() add_test(NAME "x${float_char}cblat2" COMMAND ${test_helper} $ "${PROJECT_SOURCE_DIR}/ctest/${float_char}in2") #level3 +if (NOT NOFORTRAN) add_executable(x${float_char}cblat3 c_${float_char}blat3.f c_${float_char}blas3.c @@ -55,7 +80,19 @@ foreach(float_type ${FLOAT_TYPES}) auxiliary.c c_xerbla.c constant.c) +else() + add_executable(x${float_char}cblat3 + c_${float_char}blat3c.c + c_${float_char}blas3.c + c_${float_char}3chke.c + auxiliary.c + c_xerbla.c + constant.c) +endif() target_link_libraries(x${float_char}cblat3 ${OpenBLAS_LIBNAME}) + if(${CMAKE_SYSTEM_NAME} MATCHES "Linux" OR ${CMAKE_SYSTEM_NAME} MATCHES "FreeBSD") + target_link_libraries(x${float_char}cblat3 m) + endif() add_test(NAME "x${float_char}cblat3" COMMAND ${test_helper} $ "${PROJECT_SOURCE_DIR}/ctest/${float_char}in3") diff --git a/ctest/Makefile b/ctest/Makefile index c5e1094da..0692d8448 100644 --- a/ctest/Makefile +++ b/ctest/Makefile @@ -43,11 +43,7 @@ ztestl3o = c_zblas3.o c_z3chke.o auxiliary.o c_xerbla.o constant.o ztestl3o_3m = c_zblas3_3m.o c_z3chke_3m.o auxiliary.o c_xerbla.o constant.o -ifeq ($(NOFORTRAN),1) -all :: -else all :: all1 all2 all3 -endif ifeq ($(BUILD_SINGLE),1) all1targets += xscblat1 @@ -222,53 +218,83 @@ endif ifeq ($(BUILD_SINGLE),1) # Single real +ifeq ($(NOFORTRAN),0) xscblat1: $(stestl1o) c_sblat1.o $(TOPDIR)/$(LIBNAME) $(FC) $(FLDFLAGS) -o xscblat1 c_sblat1.o $(stestl1o) $(LIB) $(EXTRALIB) $(CEXTRALIB) - xscblat2: $(stestl2o) c_sblat2.o $(TOPDIR)/$(LIBNAME) $(FC) $(FLDFLAGS) -o xscblat2 c_sblat2.o $(stestl2o) $(LIB) $(EXTRALIB) $(CEXTRALIB) - xscblat3: $(stestl3o) c_sblat3.o $(TOPDIR)/$(LIBNAME) $(FC) $(FLDFLAGS) -o xscblat3 c_sblat3.o $(stestl3o) $(LIB) $(EXTRALIB) $(CEXTRALIB) +else +xscblat1: $(stestl1o) c_sblat1c.o $(TOPDIR)/$(LIBNAME) + $(CC) $(CFLAGS) -o xscblat1 c_sblat1c.o $(stestl1o) $(LIB) $(CEXTRALIB) $(filter-out -lgfortran,$(EXTRALIB)) +xscblat2: $(stestl2o) c_sblat2c.o $(TOPDIR)/$(LIBNAME) + $(CC) $(CFLAGS) -o xscblat2 c_sblat2c.o $(stestl2o) $(LIB) $(CEXTRALIB) $(filter-out -lgfortran,$(EXTRALIB)) +xscblat3: $(stestl3o) c_sblat3c.o $(TOPDIR)/$(LIBNAME) + $(CC) $(CFLAGS) -o xscblat3 c_sblat3c.o $(stestl3o) $(LIB) $(CEXTRALIB) $(filter-out -lgfortran,$(EXTRALIB)) +endif endif ifeq ($(BUILD_DOUBLE),1) # Double real +ifeq ($(NOFORTRAN),0) xdcblat1: $(dtestl1o) c_dblat1.o $(TOPDIR)/$(LIBNAME) $(FC) $(FLDFLAGS) -o xdcblat1 c_dblat1.o $(dtestl1o) $(LIB) $(EXTRALIB) $(CEXTRALIB) xdcblat2: $(dtestl2o) c_dblat2.o $(TOPDIR)/$(LIBNAME) $(FC) $(FLDFLAGS) -o xdcblat2 c_dblat2.o $(dtestl2o) $(LIB) $(EXTRALIB) $(CEXTRALIB) xdcblat3: $(dtestl3o) c_dblat3.o $(TOPDIR)/$(LIBNAME) $(FC) $(FLDFLAGS) -o xdcblat3 c_dblat3.o $(dtestl3o) $(LIB) $(EXTRALIB) $(CEXTRALIB) +else +xdcblat1: $(dtestl1o) c_dblat1c.o $(TOPDIR)/$(LIBNAME) + $(CC) $(CFLAGS) -o xdcblat1 c_dblat1c.o $(dtestl1o) $(LIB) $(CEXTRALIB) $(filter-out -lgfortran,$(EXTRALIB)) +xdcblat2: $(dtestl2o) c_dblat2c.o $(TOPDIR)/$(LIBNAME) + $(CC) $(CFLAGS) -o xdcblat2 c_dblat2c.o $(dtestl2o) $(LIB) $(CEXTRALIB) $(filter-out -lgfortran,$(EXTRALIB)) +xdcblat3: $(dtestl3o) c_dblat3c.o $(TOPDIR)/$(LIBNAME) + $(CC) $(CFLAGS) -o xdcblat3 c_dblat3c.o $(dtestl3o) $(LIB) $(CEXTRALIB) $(filter-out -lgfortran,$(EXTRALIB)) +endif endif - ifeq ($(BUILD_COMPLEX),1) # Single complex +ifeq ($(NOFORTRAN),0) xccblat1: $(ctestl1o) c_cblat1.o $(TOPDIR)/$(LIBNAME) $(FC) $(FLDFLAGS) -o xccblat1 c_cblat1.o $(ctestl1o) $(LIB) $(EXTRALIB) $(CEXTRALIB) xccblat2: $(ctestl2o) c_cblat2.o $(TOPDIR)/$(LIBNAME) $(FC) $(FLDFLAGS) -o xccblat2 c_cblat2.o $(ctestl2o) $(LIB) $(EXTRALIB) $(CEXTRALIB) xccblat3: $(ctestl3o) c_cblat3.o $(TOPDIR)/$(LIBNAME) $(FC) $(FLDFLAGS) -o xccblat3 c_cblat3.o $(ctestl3o) $(LIB) $(EXTRALIB) $(CEXTRALIB) - xccblat3_3m: $(ctestl3o_3m) c_cblat3_3m.o $(TOPDIR)/$(LIBNAME) $(FC) $(FLDFLAGS) -o xccblat3_3m c_cblat3_3m.o $(ctestl3o_3m) $(LIB) $(EXTRALIB) $(CEXTRALIB) +else +xccblat1: $(ctestl1o) c_cblat1c.o $(TOPDIR)/$(LIBNAME) + $(CC) $(CFLAGS) -o xccblat1 c_cblat1c.o $(ctestl1o) $(LIB) $(CEXTRALIB) $(filter-out -lgfortran,$(EXTRALIB)) +xccblat2: $(ctestl2o) c_cblat2c.o $(TOPDIR)/$(LIBNAME) + $(CC) $(CFLAGS) -o xccblat2 c_cblat2c.o $(ctestl2o) $(LIB) $(CEXTRALIB) $(filter-out -lgfortran,$(EXTRALIB)) +xccblat3: $(ctestl3o) c_cblat3c.o $(TOPDIR)/$(LIBNAME) + $(CC) $(CFLAGS) -o xccblat3 c_cblat3c.o $(ctestl3o) $(LIB) $(CEXTRALIB) $(filter-out -lgfortran,$(EXTRALIB)) +endif endif ifeq ($(BUILD_COMPLEX16),1) # Double complex +ifeq ($(NOFORTRAN),0) xzcblat1: $(ztestl1o) c_zblat1.o $(TOPDIR)/$(LIBNAME) $(FC) $(FLDFLAGS) -o xzcblat1 c_zblat1.o $(ztestl1o) $(LIB) $(EXTRALIB) $(CEXTRALIB) xzcblat2: $(ztestl2o) c_zblat2.o $(TOPDIR)/$(LIBNAME) $(FC) $(FLDFLAGS) -o xzcblat2 c_zblat2.o $(ztestl2o) $(LIB) $(EXTRALIB) $(CEXTRALIB) xzcblat3: $(ztestl3o) c_zblat3.o $(TOPDIR)/$(LIBNAME) $(FC) $(FLDFLAGS) -o xzcblat3 c_zblat3.o $(ztestl3o) $(LIB) $(EXTRALIB) $(CEXTRALIB) - - xzcblat3_3m: $(ztestl3o_3m) c_zblat3_3m.o $(TOPDIR)/$(LIBNAME) $(FC) $(FLDFLAGS) -o xzcblat3_3m c_zblat3_3m.o $(ztestl3o_3m) $(LIB) $(EXTRALIB) $(CEXTRALIB) +else +xzcblat1: $(ztestl1o) c_zblat1c.o $(TOPDIR)/$(LIBNAME) + $(CC) $(CFLAGS) -o xzcblat1 c_zblat1c.o $(ztestl1o) $(LIB) $(CEXTRALIB) $(filter-out -lgfortran,$(EXTRALIB)) +xzcblat2: $(ztestl2o) c_zblat2c.o $(TOPDIR)/$(LIBNAME) + $(CC) $(CFLAGS) -o xzcblat2 c_zblat2c.o $(ztestl2o) $(LIB) $(CEXTRALIB) $(filter-out -lgfortran,$(EXTRALIB)) +xzcblat3: $(ztestl3o) c_zblat3c.o $(TOPDIR)/$(LIBNAME) + $(CC) $(CFLAGS) -o xzcblat3 c_zblat3c.o $(ztestl3o) $(LIB) $(CEXTRALIB) $(filter-out -lgfortran,$(EXTRALIB)) +endif endif include $(TOPDIR)/Makefile.tail diff --git a/ctest/c_cblat1c.c b/ctest/c_cblat1c.c new file mode 100644 index 000000000..6949bfcaf --- /dev/null +++ b/ctest/c_cblat1c.c @@ -0,0 +1,1289 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +#if 0 +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +#endif +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i= 6) { + check1_(&sfac); + } +/* -- Print */ + if (combla_1.pass) { + printf(" ----- PASS -----\n"); + } +/* L20: */ + } + exit(0); + +} /* MAIN__ */ + +/* Subroutine */ int header_() +{ + /* Initialized data */ + + static char l[15][13] = {"CBLAS_CDOTC " , "CBLAS_CDOTU " , "CBLAS_CAXPY " , + "CBLAS_CCOPY " , "CBLAS_CSWAP " , "CBLAS_SCNRM2" , "CBLAS_SCASUM" , "CBLAS_CSCAL " , + "CBLAS_CSSCAL" , "CBLAS_ICAMAX" }; + + /* Format strings */ + + /* Builtin functions */ + integer s_wsfe(), do_fio(), e_wsfe(); + +/* .. Parameters .. */ +/* .. Scalars in Common .. */ +/* .. Local Arrays .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ +/* .. Executable Statements .. */ + printf("Test of subprogram number %3d %15s\n", combla_1.icase, l[combla_1.icase - 1]); + return 0; + +} /* header_ */ + +/* Subroutine */ int check1_(sfac) +real *sfac; +{ + /* Initialized data */ + + static real strue2[5] = { (float)0.,(float).5,(float).6,(float).7,(float) + .7 }; + static real strue4[5] = { (float)0.,(float).7,(float)1.,(float)1.3,(float) + 1.7 }; + static complex ctrue5[80] /* was [8][5][2] */ = { {(float).1,(float).1}, + {(float)1.,(float)2.},{(float)1.,(float)2.},{(float)1.,(float)2.}, + {(float)1.,(float)2.},{(float)1.,(float)2.},{(float)1.,(float)2.}, + {(float)1.,(float)2.},{(float)-.16,(float)-.37},{(float)3.,(float) + 4.},{(float)3.,(float)4.},{(float)3.,(float)4.},{(float)3.,(float) + 4.},{(float)3.,(float)4.},{(float)3.,(float)4.},{(float)3.,(float) + 4.},{(float)-.17,(float)-.19},{(float).13,(float)-.39},{(float)5., + (float)6.},{(float)5.,(float)6.},{(float)5.,(float)6.},{(float)5., + (float)6.},{(float)5.,(float)6.},{(float)5.,(float)6.},{(float) + .11,(float)-.03},{(float)-.17,(float).46},{(float)-.17,(float) + -.19},{(float)7.,(float)8.},{(float)7.,(float)8.},{(float)7.,( + float)8.},{(float)7.,(float)8.},{(float)7.,(float)8.},{(float).19, + (float)-.17},{(float).32,(float).09},{(float).23,(float)-.24},{( + float).18,(float).01},{(float)2.,(float)3.},{(float)2.,(float)3.}, + {(float)2.,(float)3.},{(float)2.,(float)3.},{(float).1,(float).1}, + {(float)4.,(float)5.},{(float)4.,(float)5.},{(float)4.,(float)5.}, + {(float)4.,(float)5.},{(float)4.,(float)5.},{(float)4.,(float)5.}, + {(float)4.,(float)5.},{(float)-.16,(float)-.37},{(float)6.,(float) + 7.},{(float)6.,(float)7.},{(float)6.,(float)7.},{(float)6.,(float) + 7.},{(float)6.,(float)7.},{(float)6.,(float)7.},{(float)6.,(float) + 7.},{(float)-.17,(float)-.19},{(float)8.,(float)9.},{(float).13,( + float)-.39},{(float)2.,(float)5.},{(float)2.,(float)5.},{(float) + 2.,(float)5.},{(float)2.,(float)5.},{(float)2.,(float)5.},{(float) + .11,(float)-.03},{(float)3.,(float)6.},{(float)-.17,(float).46},{( + float)4.,(float)7.},{(float)-.17,(float)-.19},{(float)7.,(float) + 2.},{(float)7.,(float)2.},{(float)7.,(float)2.},{(float).19,( + float)-.17},{(float)5.,(float)8.},{(float).32,(float).09},{(float) + 6.,(float)9.},{(float).23,(float)-.24},{(float)8.,(float)3.},{( + float).18,(float).01},{(float)9.,(float)4.} }; + static complex ctrue6[80] /* was [8][5][2] */ = { {(float).1,(float).1}, + {(float)1.,(float)2.},{(float)1.,(float)2.},{(float)1.,(float)2.}, + {(float)1.,(float)2.},{(float)1.,(float)2.},{(float)1.,(float)2.}, + {(float)1.,(float)2.},{(float).09,(float)-.12},{(float)3.,(float) + 4.},{(float)3.,(float)4.},{(float)3.,(float)4.},{(float)3.,(float) + 4.},{(float)3.,(float)4.},{(float)3.,(float)4.},{(float)3.,(float) + 4.},{(float).03,(float)-.09},{(float).15,(float)-.03},{(float)5.,( + float)6.},{(float)5.,(float)6.},{(float)5.,(float)6.},{(float)5.,( + float)6.},{(float)5.,(float)6.},{(float)5.,(float)6.},{(float).03, + (float).03},{(float)-.18,(float).03},{(float).03,(float)-.09},{( + float)7.,(float)8.},{(float)7.,(float)8.},{(float)7.,(float)8.},{( + float)7.,(float)8.},{(float)7.,(float)8.},{(float).09,(float).03}, + {(float).03,(float).12},{(float).12,(float).03},{(float).03,( + float).06},{(float)2.,(float)3.},{(float)2.,(float)3.},{(float)2., + (float)3.},{(float)2.,(float)3.},{(float).1,(float).1},{(float)4., + (float)5.},{(float)4.,(float)5.},{(float)4.,(float)5.},{(float)4., + (float)5.},{(float)4.,(float)5.},{(float)4.,(float)5.},{(float)4., + (float)5.},{(float).09,(float)-.12},{(float)6.,(float)7.},{(float) + 6.,(float)7.},{(float)6.,(float)7.},{(float)6.,(float)7.},{(float) + 6.,(float)7.},{(float)6.,(float)7.},{(float)6.,(float)7.},{(float) + .03,(float)-.09},{(float)8.,(float)9.},{(float).15,(float)-.03},{( + float)2.,(float)5.},{(float)2.,(float)5.},{(float)2.,(float)5.},{( + float)2.,(float)5.},{(float)2.,(float)5.},{(float).03,(float).03}, + {(float)3.,(float)6.},{(float)-.18,(float).03},{(float)4.,(float) + 7.},{(float).03,(float)-.09},{(float)7.,(float)2.},{(float)7.,( + float)2.},{(float)7.,(float)2.},{(float).09,(float).03},{(float) + 5.,(float)8.},{(float).03,(float).12},{(float)6.,(float)9.},{( + float).12,(float).03},{(float)8.,(float)3.},{(float).03,(float) + .06},{(float)9.,(float)4.} }; + static integer itrue3[5] = { 0,1,2,2,2 }; + static real sa = (float).3; + static complex ca = {(float).4,(float)-.7}; + static complex cv[80] /* was [8][5][2] */ = { {(float).1,(float).1}, + {(float)1.,(float)2.},{(float)1.,(float)2.},{(float)1.,(float)2.}, + {(float)1.,(float)2.},{(float)1.,(float)2.},{(float)1.,(float)2.}, + {(float)1.,(float)2.},{(float).3,(float)-.4},{(float)3.,(float)4.} + ,{(float)3.,(float)4.},{(float)3.,(float)4.},{(float)3.,(float)4.} + ,{(float)3.,(float)4.},{(float)3.,(float)4.},{(float)3.,(float)4.} + ,{(float).1,(float)-.3},{(float).5,(float)-.1},{(float)5.,(float) + 6.},{(float)5.,(float)6.},{(float)5.,(float)6.},{(float)5.,(float) + 6.},{(float)5.,(float)6.},{(float)5.,(float)6.},{(float).1,(float) + .1},{(float)-.6,(float).1},{(float).1,(float)-.3},{(float)7.,( + float)8.},{(float)7.,(float)8.},{(float)7.,(float)8.},{(float)7.,( + float)8.},{(float)7.,(float)8.},{(float).3,(float).1},{(float).1,( + float).4},{(float).4,(float).1},{(float).1,(float).2},{(float)2.,( + float)3.},{(float)2.,(float)3.},{(float)2.,(float)3.},{(float)2.,( + float)3.},{(float).1,(float).1},{(float)4.,(float)5.},{(float)4.,( + float)5.},{(float)4.,(float)5.},{(float)4.,(float)5.},{(float)4.,( + float)5.},{(float)4.,(float)5.},{(float)4.,(float)5.},{(float).3,( + float)-.4},{(float)6.,(float)7.},{(float)6.,(float)7.},{(float)6., + (float)7.},{(float)6.,(float)7.},{(float)6.,(float)7.},{(float)6., + (float)7.},{(float)6.,(float)7.},{(float).1,(float)-.3},{(float) + 8.,(float)9.},{(float).5,(float)-.1},{(float)2.,(float)5.},{( + float)2.,(float)5.},{(float)2.,(float)5.},{(float)2.,(float)5.},{( + float)2.,(float)5.},{(float).1,(float).1},{(float)3.,(float)6.},{( + float)-.6,(float).1},{(float)4.,(float)7.},{(float).1,(float)-.3}, + {(float)7.,(float)2.},{(float)7.,(float)2.},{(float)7.,(float)2.}, + {(float).3,(float).1},{(float)5.,(float)8.},{(float).1,(float).4}, + {(float)6.,(float)9.},{(float).4,(float).1},{(float)8.,(float)3.}, + {(float).1,(float).2},{(float)9.,(float)4.} }; + + /* System generated locals */ + integer i__1, i__2, i__3; + real r__1; + complex q__1; + + /* Local variables */ + static integer i__; + extern /* Subroutine */ int cscal_(), ctest_(); + static complex mwpcs[5], mwpct[5]; + extern /* Subroutine */ int itest1_(), stest1_(); + static complex cx[8]; + extern real scnrm2test_(); + static integer np1; + extern integer icamaxtest_(); + extern /* Subroutine */ int csscaltest_(); + extern real scasumtest_(); + static integer len; + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Scalars in Common .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ +/* .. Executable Statements .. */ + for (combla_1.incx = 1; combla_1.incx <= 2; ++combla_1.incx) { + for (np1 = 1; np1 <= 5; ++np1) { + combla_1.n = np1 - 1; + len = f2cmax(combla_1.n,1) << 1; +/* .. Set vector arguments .. */ + i__1 = len; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ - 1; + i__3 = i__ + (np1 + combla_1.incx * 5 << 3) - 49; + cx[i__2].r = cv[i__3].r, cx[i__2].i = cv[i__3].i; +/* L20: */ + } + if (combla_1.icase == 6) { +/* .. SCNRM2TEST .. */ + r__1 = scnrm2test_(&combla_1.n, cx, &combla_1.incx); + stest1_(&r__1, &strue2[np1 - 1], &strue2[np1 - 1], sfac); + } else if (combla_1.icase == 7) { +/* .. SCASUMTEST .. */ + r__1 = scasumtest_(&combla_1.n, cx, &combla_1.incx); + stest1_(&r__1, &strue4[np1 - 1], &strue4[np1 - 1], sfac); + } else if (combla_1.icase == 8) { +/* .. CSCAL .. */ + cscal_(&combla_1.n, &ca, cx, &combla_1.incx); + ctest_(&len, cx, &ctrue5[(np1 + combla_1.incx * 5 << 3) - 48], + &ctrue5[(np1 + combla_1.incx * 5 << 3) - 48], sfac); + } else if (combla_1.icase == 9) { +/* .. CSSCALTEST .. */ + csscaltest_(&combla_1.n, &sa, cx, &combla_1.incx); + ctest_(&len, cx, &ctrue6[(np1 + combla_1.incx * 5 << 3) - 48], + &ctrue6[(np1 + combla_1.incx * 5 << 3) - 48], sfac); + } else if (combla_1.icase == 10) { +/* .. ICAMAXTEST .. */ + i__1 = icamaxtest_(&combla_1.n, cx, &combla_1.incx); + itest1_(&i__1, &itrue3[np1 - 1]); + } else { + fprintf(stderr,"Shouldn't be here in CHECK1\n"); + exit(0); + } + +/* L40: */ + } +/* L60: */ + } + + combla_1.incx = 1; + if (combla_1.icase == 8) { +/* CSCAL */ +/* Add a test for alpha equal to zero. */ + ca.r = (float)0., ca.i = (float)0.; + for (i__ = 1; i__ <= 5; ++i__) { + i__1 = i__ - 1; + mwpct[i__1].r = (float)0., mwpct[i__1].i = (float)0.; + i__1 = i__ - 1; + mwpcs[i__1].r = (float)1., mwpcs[i__1].i = (float)1.; +/* L80: */ + } + cscal_(&c__5, &ca, cx, &combla_1.incx); + ctest_(&c__5, cx, mwpct, mwpcs, sfac); + } else if (combla_1.icase == 9) { +/* CSSCALTEST */ +/* Add a test for alpha equal to zero. */ + sa = (float)0.; + for (i__ = 1; i__ <= 5; ++i__) { + i__1 = i__ - 1; + mwpct[i__1].r = (float)0., mwpct[i__1].i = (float)0.; + i__1 = i__ - 1; + mwpcs[i__1].r = (float)1., mwpcs[i__1].i = (float)1.; +/* L100: */ + } + csscaltest_(&c__5, &sa, cx, &combla_1.incx); + ctest_(&c__5, cx, mwpct, mwpcs, sfac); +/* Add a test for alpha equal to one. */ + sa = (float)1.; + for (i__ = 1; i__ <= 5; ++i__) { + i__1 = i__ - 1; + i__2 = i__ - 1; + mwpct[i__1].r = cx[i__2].r, mwpct[i__1].i = cx[i__2].i; + i__1 = i__ - 1; + i__2 = i__ - 1; + mwpcs[i__1].r = cx[i__2].r, mwpcs[i__1].i = cx[i__2].i; +/* L120: */ + } + csscaltest_(&c__5, &sa, cx, &combla_1.incx); + ctest_(&c__5, cx, mwpct, mwpcs, sfac); +/* Add a test for alpha equal to minus one. */ + sa = (float)-1.; + for (i__ = 1; i__ <= 5; ++i__) { + i__1 = i__ - 1; + i__2 = i__ - 1; + q__1.r = -cx[i__2].r, q__1.i = -cx[i__2].i; + mwpct[i__1].r = q__1.r, mwpct[i__1].i = q__1.i; + i__1 = i__ - 1; + i__2 = i__ - 1; + q__1.r = -cx[i__2].r, q__1.i = -cx[i__2].i; + mwpcs[i__1].r = q__1.r, mwpcs[i__1].i = q__1.i; +/* L140: */ + } + csscaltest_(&c__5, &sa, cx, &combla_1.incx); + ctest_(&c__5, cx, mwpct, mwpcs, sfac); + } + return 0; +} /* check1_ */ + +/* Subroutine */ int check2_(sfac) +real *sfac; +{ + /* Initialized data */ + + static complex ca = {(float).4,(float)-.7}; + static integer incxs[4] = { 1,2,-2,-1 }; + static integer incys[4] = { 1,-2,1,-2 }; + static integer lens[8] /* was [4][2] */ = { 1,1,2,4,1,1,3,7 }; + static integer ns[4] = { 0,1,2,4 }; + static complex cx1[7] = { {(float).7,(float)-.8},{(float)-.4,(float)-.7},{ + (float)-.1,(float)-.9},{(float).2,(float)-.8},{(float)-.9,(float) + -.4},{(float).1,(float).4},{(float)-.6,(float).6} }; + static complex cy1[7] = { {(float).6,(float)-.6},{(float)-.9,(float).5},{( + float).7,(float)-.6},{(float).1,(float)-.5},{(float)-.1,(float) + -.2},{(float)-.5,(float)-.3},{(float).8,(float)-.7} }; + static complex ct8[112] /* was [7][4][4] */ = { {(float).6,(float)-.6} + ,{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.} + ,{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.} + ,{(float).32,(float)-1.41},{(float)0.,(float)0.},{(float)0.,( + float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,( + float)0.},{(float)0.,(float)0.},{(float).32,(float)-1.41},{(float) + -1.55,(float).5},{(float)0.,(float)0.},{(float)0.,(float)0.},{( + float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{( + float).32,(float)-1.41},{(float)-1.55,(float).5},{(float).03,( + float)-.89},{(float)-.38,(float)-.96},{(float)0.,(float)0.},{( + float)0.,(float)0.},{(float)0.,(float)0.},{(float).6,(float)-.6},{ + (float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{ + (float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{ + (float).32,(float)-1.41},{(float)0.,(float)0.},{(float)0.,(float) + 0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float) + 0.},{(float)0.,(float)0.},{(float)-.07,(float)-.89},{(float)-.9,( + float).5},{(float).42,(float)-1.41},{(float)0.,(float)0.},{(float) + 0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float) + .78,(float).06},{(float)-.9,(float).5},{(float).06,(float)-.13},{( + float).1,(float)-.5},{(float)-.77,(float)-.49},{(float)-.5,(float) + -.3},{(float).52,(float)-1.51},{(float).6,(float)-.6},{(float)0.,( + float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,( + float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float).32, + (float)-1.41},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float) + 0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float) + 0.,(float)0.},{(float)-.07,(float)-.89},{(float)-1.18,(float)-.31} + ,{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.} + ,{(float)0.,(float)0.},{(float)0.,(float)0.},{(float).78,(float) + .06},{(float)-1.54,(float).97},{(float).03,(float)-.89},{(float) + -.18,(float)-1.31},{(float)0.,(float)0.},{(float)0.,(float)0.},{( + float)0.,(float)0.},{(float).6,(float)-.6},{(float)0.,(float)0.},{ + (float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{ + (float)0.,(float)0.},{(float)0.,(float)0.},{(float).32,(float) + -1.41},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,( + float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,( + float)0.},{(float).32,(float)-1.41},{(float)-.9,(float).5},{( + float).05,(float)-.6},{(float)0.,(float)0.},{(float)0.,(float)0.}, + {(float)0.,(float)0.},{(float)0.,(float)0.},{(float).32,(float) + -1.41},{(float)-.9,(float).5},{(float).05,(float)-.6},{(float).1,( + float)-.5},{(float)-.77,(float)-.49},{(float)-.5,(float)-.3},{( + float).32,(float)-1.16} }; + static complex ct7[16] /* was [4][4] */ = { {(float)0.,(float)0.},{( + float)-.06,(float)-.9},{(float).65,(float)-.47},{(float)-.34,( + float)-1.22},{(float)0.,(float)0.},{(float)-.06,(float)-.9},{( + float)-.59,(float)-1.46},{(float)-1.04,(float)-.04},{(float)0.,( + float)0.},{(float)-.06,(float)-.9},{(float)-.83,(float).59},{( + float).07,(float)-.37},{(float)0.,(float)0.},{(float)-.06,(float) + -.9},{(float)-.76,(float)-1.15},{(float)-1.33,(float)-1.82} }; + static complex ct6[16] /* was [4][4] */ = { {(float)0.,(float)0.},{( + float).9,(float).06},{(float).91,(float)-.77},{(float)1.8,(float) + -.1},{(float)0.,(float)0.},{(float).9,(float).06},{(float)1.45,( + float).74},{(float).2,(float).9},{(float)0.,(float)0.},{(float).9, + (float).06},{(float)-.55,(float).23},{(float).83,(float)-.39},{( + float)0.,(float)0.},{(float).9,(float).06},{(float)1.04,(float) + .79},{(float)1.95,(float)1.22} }; + static complex ct10x[112] /* was [7][4][4] */ = { {(float).7,(float)-.8} + ,{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.} + ,{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.} + ,{(float).6,(float)-.6},{(float)0.,(float)0.},{(float)0.,(float) + 0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float) + 0.},{(float)0.,(float)0.},{(float).6,(float)-.6},{(float)-.9,( + float).5},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,( + float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float).6,( + float)-.6},{(float)-.9,(float).5},{(float).7,(float)-.6},{(float) + .1,(float)-.5},{(float)0.,(float)0.},{(float)0.,(float)0.},{( + float)0.,(float)0.},{(float).7,(float)-.8},{(float)0.,(float)0.},{ + (float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{ + (float)0.,(float)0.},{(float)0.,(float)0.},{(float).6,(float)-.6}, + {(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.}, + {(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.}, + {(float).7,(float)-.6},{(float)-.4,(float)-.7},{(float).6,(float) + -.6},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,( + float)0.},{(float)0.,(float)0.},{(float).8,(float)-.7},{(float) + -.4,(float)-.7},{(float)-.1,(float)-.2},{(float).2,(float)-.8},{( + float).7,(float)-.6},{(float).1,(float).4},{(float).6,(float)-.6}, + {(float).7,(float)-.8},{(float)0.,(float)0.},{(float)0.,(float)0.} + ,{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.} + ,{(float)0.,(float)0.},{(float).6,(float)-.6},{(float)0.,(float) + 0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float) + 0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)-.9,( + float).5},{(float)-.4,(float)-.7},{(float).6,(float)-.6},{(float) + 0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float) + 0.,(float)0.},{(float).1,(float)-.5},{(float)-.4,(float)-.7},{( + float).7,(float)-.6},{(float).2,(float)-.8},{(float)-.9,(float).5} + ,{(float).1,(float).4},{(float).6,(float)-.6},{(float).7,(float) + -.8},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,( + float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,( + float)0.},{(float).6,(float)-.6},{(float)0.,(float)0.},{(float)0., + (float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0., + (float)0.},{(float)0.,(float)0.},{(float).6,(float)-.6},{(float) + .7,(float)-.6},{(float)0.,(float)0.},{(float)0.,(float)0.},{( + float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{( + float).6,(float)-.6},{(float).7,(float)-.6},{(float)-.1,(float) + -.2},{(float).8,(float)-.7},{(float)0.,(float)0.},{(float)0.,( + float)0.},{(float)0.,(float)0.} }; + static complex ct10y[112] /* was [7][4][4] */ = { {(float).6,(float)-.6} + ,{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.} + ,{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.} + ,{(float).7,(float)-.8},{(float)0.,(float)0.},{(float)0.,(float) + 0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float) + 0.},{(float)0.,(float)0.},{(float).7,(float)-.8},{(float)-.4,( + float)-.7},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0., + (float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float).7, + (float)-.8},{(float)-.4,(float)-.7},{(float)-.1,(float)-.9},{( + float).2,(float)-.8},{(float)0.,(float)0.},{(float)0.,(float)0.},{ + (float)0.,(float)0.},{(float).6,(float)-.6},{(float)0.,(float)0.}, + {(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.}, + {(float)0.,(float)0.},{(float)0.,(float)0.},{(float).7,(float)-.8} + ,{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.} + ,{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.} + ,{(float)-.1,(float)-.9},{(float)-.9,(float).5},{(float).7,(float) + -.8},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,( + float)0.},{(float)0.,(float)0.},{(float)-.6,(float).6},{(float) + -.9,(float).5},{(float)-.9,(float)-.4},{(float).1,(float)-.5},{( + float)-.1,(float)-.9},{(float)-.5,(float)-.3},{(float).7,(float) + -.8},{(float).6,(float)-.6},{(float)0.,(float)0.},{(float)0.,( + float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,( + float)0.},{(float)0.,(float)0.},{(float).7,(float)-.8},{(float)0., + (float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0., + (float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float) + -.1,(float)-.9},{(float).7,(float)-.8},{(float)0.,(float)0.},{( + float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{( + float)0.,(float)0.},{(float)-.6,(float).6},{(float)-.9,(float)-.4} + ,{(float)-.1,(float)-.9},{(float).7,(float)-.8},{(float)0.,(float) + 0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float).6,(float) + -.6},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,( + float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,( + float)0.},{(float).7,(float)-.8},{(float)0.,(float)0.},{(float)0., + (float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0., + (float)0.},{(float)0.,(float)0.},{(float).7,(float)-.8},{(float) + -.9,(float).5},{(float)-.4,(float)-.7},{(float)0.,(float)0.},{( + float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{( + float).7,(float)-.8},{(float)-.9,(float).5},{(float)-.4,(float) + -.7},{(float).1,(float)-.5},{(float)-.1,(float)-.9},{(float)-.5,( + float)-.3},{(float).2,(float)-.8} }; + static complex csize1[4] = { {(float)0.,(float)0.},{(float).9,(float).9},{ + (float)1.63,(float)1.73},{(float)2.9,(float)2.78} }; + static complex csize3[14] = { {(float)0.,(float)0.},{(float)0.,(float)0.}, + {(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.}, + {(float)0.,(float)0.},{(float)0.,(float)0.},{(float)1.17,(float) + 1.17},{(float)1.17,(float)1.17},{(float)1.17,(float)1.17},{(float) + 1.17,(float)1.17},{(float)1.17,(float)1.17},{(float)1.17,(float) + 1.17},{(float)1.17,(float)1.17} }; + static complex csize2[14] /* was [7][2] */ = { {(float)0.,(float)0.},{( + float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{( + float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{( + float)1.54,(float)1.54},{(float)1.54,(float)1.54},{(float)1.54,( + float)1.54},{(float)1.54,(float)1.54},{(float)1.54,(float)1.54},{( + float)1.54,(float)1.54},{(float)1.54,(float)1.54} }; + + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + static complex cdot[1]; + static integer lenx, leny, i__; + static complex ctemp; + extern /* Subroutine */ int ctest_(); + static integer ksize; + extern /* Subroutine */ int cdotctest_(), ccopytest_(), cdotutest_(), + cswaptest_(), caxpytest_(); + static integer ki, kn; + static complex cx[7], cy[7]; + static integer mx, my; + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Scalars in Common .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ +/* .. Executable Statements .. */ + for (ki = 1; ki <= 4; ++ki) { + combla_1.incx = incxs[ki - 1]; + combla_1.incy = incys[ki - 1]; + mx = abs(combla_1.incx); + my = abs(combla_1.incy); + + for (kn = 1; kn <= 4; ++kn) { + combla_1.n = ns[kn - 1]; + ksize = f2cmin(2,kn); + lenx = lens[kn + (mx << 2) - 5]; + leny = lens[kn + (my << 2) - 5]; +/* .. initialize all argument arrays .. */ + for (i__ = 1; i__ <= 7; ++i__) { + i__1 = i__ - 1; + i__2 = i__ - 1; + cx[i__1].r = cx1[i__2].r, cx[i__1].i = cx1[i__2].i; + i__1 = i__ - 1; + i__2 = i__ - 1; + cy[i__1].r = cy1[i__2].r, cy[i__1].i = cy1[i__2].i; +/* L20: */ + } + if (combla_1.icase == 1) { +/* .. CDOTCTEST .. */ + cdotctest_(&combla_1.n, cx, &combla_1.incx, cy, & + combla_1.incy, &ctemp); + cdot[0].r = ctemp.r, cdot[0].i = ctemp.i; + ctest_(&c__1, cdot, &ct6[kn + (ki << 2) - 5], &csize1[kn - 1], + sfac); + } else if (combla_1.icase == 2) { +/* .. CDOTUTEST .. */ + cdotutest_(&combla_1.n, cx, &combla_1.incx, cy, & + combla_1.incy, &ctemp); + cdot[0].r = ctemp.r, cdot[0].i = ctemp.i; + ctest_(&c__1, cdot, &ct7[kn + (ki << 2) - 5], &csize1[kn - 1], + sfac); + } else if (combla_1.icase == 3) { +/* .. CAXPYTEST .. */ + caxpytest_(&combla_1.n, &ca, cx, &combla_1.incx, cy, & + combla_1.incy); + ctest_(&leny, cy, &ct8[(kn + (ki << 2)) * 7 - 35], &csize2[ + ksize * 7 - 7], sfac); + } else if (combla_1.icase == 4) { +/* .. CCOPYTEST .. */ + ccopytest_(&combla_1.n, cx, &combla_1.incx, cy, & + combla_1.incy); + ctest_(&leny, cy, &ct10y[(kn + (ki << 2)) * 7 - 35], csize3, & + c_b43); + } else if (combla_1.icase == 5) { +/* .. CSWAPTEST .. */ + cswaptest_(&combla_1.n, cx, &combla_1.incx, cy, & + combla_1.incy); + ctest_(&lenx, cx, &ct10x[(kn + (ki << 2)) * 7 - 35], csize3, & + c_b43); + ctest_(&leny, cy, &ct10y[(kn + (ki << 2)) * 7 - 35], csize3, & + c_b43); + } else { + fprintf(stderr,"Shouldn't be here in CHECK2\n"); + exit(0); + } + +/* L40: */ + } +/* L60: */ + } + return 0; +} /* check2_ */ + +/* Subroutine */ int stest_(len, scomp, strue, ssize, sfac) +integer *len; +real *scomp, *strue, *ssize, *sfac; +{ + /* System generated locals */ + integer i__1; + real r__1, r__2, r__3, r__4, r__5; + + /* Local variables */ + static integer i__; + extern doublereal sdiff_(); + static real sd; + +/* ********************************* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Scalars in Common .. */ +/* .. Local Scalars .. */ +/* .. External Functions .. */ +/* .. Intrinsic Functions .. */ +/* .. Common blocks .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --ssize; + --strue; + --scomp; + + /* Function Body */ + i__1 = *len; + for (i__ = 1; i__ <= i__1; ++i__) { + sd = scomp[i__] - strue[i__]; + r__4 = (r__1 = ssize[i__], dabs(r__1)) + (r__2 = *sfac * sd, dabs( + r__2)); + r__5 = (r__3 = ssize[i__], dabs(r__3)); + if (sdiff_(&r__4, &r__5) == (float)0.) { + goto L40; + } + +/* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I). */ + + if (! combla_1.pass) { + goto L20; + } +/* PRINT FAIL MESSAGE AND HEADER. */ + combla_1.pass = FALSE_; + printf(" FAIL\n"); + printf("CASE N INCX INCY MODE I COMP(I) TRUE(I) DIFFERENCE SIZE(I)\n"); +L20: + printf("%4d %3d %5d %5d %5d %3d %36.8e %36.8e %12.4e %12.4e\n",combla_1.icase, combla_1.n, combla_1.incx, combla_1.incy, + combla_1.mode, i__, scomp[i__], strue[i__], sd, ssize[i__]); +L40: + ; + } + return 0; + +} /* stest_ */ + +/* Subroutine */ int stest1_(scomp1, strue1, ssize, sfac) +real *scomp1, *strue1, *ssize, *sfac; +{ + static real scomp[1], strue[1]; + extern /* Subroutine */ int stest_(); + +/* ************************* STEST1 ***************************** */ + +/* THIS IS AN INTERFACE SUBROUTINE TO ACCOMMODATE 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 .. */ +/* .. Array Arguments .. */ +/* .. Local Arrays .. */ +/* .. External Subroutines .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --ssize; + + /* Function Body */ + scomp[0] = *scomp1; + strue[0] = *strue1; + stest_(&c__1, scomp, strue, &ssize[1], sfac); + + return 0; +} /* stest1_ */ + +doublereal sdiff_(sa, sb) +real *sa, *sb; +{ + /* System generated locals */ + real ret_val; + +/* ********************************* SDIFF ************************** */ +/* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15 */ + +/* .. Scalar Arguments .. */ +/* .. Executable Statements .. */ + ret_val = *sa - *sb; + return ret_val; +} /* sdiff_ */ + +/* Subroutine */ int ctest_(len, ccomp, ctrue, csize, sfac) +integer *len; +complex *ccomp, *ctrue, *csize; +real *sfac; +{ + /* System generated locals */ + integer i__1, i__2; + + /* Builtin functions */ +// double r_imag(); + + /* Local variables */ + static integer i__; + static real scomp[20], ssize[20], strue[20]; + extern /* Subroutine */ int stest_(); + +/* **************************** CTEST ***************************** */ + +/* C.L. LAWSON, JPL, 1978 DEC 6 */ + +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + --csize; + --ctrue; + --ccomp; + + /* Function Body */ + i__1 = *len; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + scomp[(i__ << 1) - 2] = ccomp[i__2].r; + scomp[(i__ << 1) - 1] = r_imag(&ccomp[i__]); + i__2 = i__; + strue[(i__ << 1) - 2] = ctrue[i__2].r; + strue[(i__ << 1) - 1] = r_imag(&ctrue[i__]); + i__2 = i__; + ssize[(i__ << 1) - 2] = csize[i__2].r; + ssize[(i__ << 1) - 1] = r_imag(&csize[i__]); +/* L20: */ + } + + i__1 = *len << 1; + stest_(&i__1, scomp, strue, ssize, sfac); + return 0; +} /* ctest_ */ + +/* Subroutine */ int itest1_(icomp, itrue) +integer *icomp, *itrue; +{ + /* Local variables */ + static integer id; + +/* ********************************* ITEST1 ************************* */ + +/* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR */ +/* EQUALITY. */ +/* C. L. LAWSON, JPL, 1974 DEC 10 */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Scalars in Common .. */ +/* .. Local Scalars .. */ +/* .. Common blocks .. */ +/* .. Executable Statements .. */ + if (*icomp == *itrue) { + goto L40; + } + +/* HERE ICOMP IS NOT EQUAL TO ITRUE. */ + + if (! combla_1.pass) { + goto L20; + } +/* PRINT FAIL MESSAGE AND HEADER. */ + combla_1.pass = FALSE_; + printf(" FAIL\n"); + printf(" CASE N INCX INCY MODE COMP TRUE DIFFERENCE\n"); +L20: + id = *icomp - *itrue; + printf("%4d %3d %5d %5d %5d %36d %36d %12d\n",combla_1.icase, combla_1.n, combla_1.incx, combla_1.incy, + combla_1.mode, *icomp, *itrue, id); +L40: + return 0; + +} /* itest1_ */ + diff --git a/ctest/c_cblat2c.c b/ctest/c_cblat2c.c new file mode 100644 index 000000000..1fda09381 --- /dev/null +++ b/ctest/c_cblat2c.c @@ -0,0 +1,4464 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif +#if 0 +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +#endif +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i= 0; + if (trace) { +/* o__1.oerr = 0; + o__1.ounit = ntra; + o__1.ofnmlen = 32; + o__1.ofnm = snaps; + o__1.orl = 0; + o__1.osta = 0; + o__1.oacc = 0; + o__1.ofm = 0; + o__1.oblnk = 0; + f_open(&o__1);*/ + } +/* Read the flag that directs rewinding of the snapshot file. */ + fgets(line,80,stdin); + sscanf(line,"%d",&rewi); + rewi = rewi && trace; +/* Read the flag that directs stopping on any failure. */ + fgets(line,80,stdin); + sscanf(line,"%c",&tmpchar); +/* Read the flag that indicates whether error exits are to be tested. */ + sfatal=FALSE_; + if (tmpchar=='T')sfatal=TRUE_; + fgets(line,80,stdin); + sscanf(line,"%c",&tmpchar); +/* Read the flag that indicates whether error exits are to be tested. */ + tsterr=FALSE_; + if (tmpchar=='T')tsterr=TRUE_; +/* Read the flag that indicates whether row-major data layout to be tested. */ + fgets(line,80,stdin); + sscanf(line,"%d",&layout); +/* Read the threshold value of the test ratio */ + fgets(line,80,stdin); + sscanf(line,"%f",&thresh); + +/* Read and check the parameter values for the tests. */ + +/* Values of N */ + fgets(line,80,stdin); + sscanf(line,"%d",&nidim); + + if (nidim < 1 || nidim > 9) { + fprintf(stderr,"NUMBER OF VALUES OF N IS LESS THAN 1 OR GREATER THAN 9"); + goto L230; + } + fgets(line,80,stdin); + sscanf(line,"%d %d %d %d %d %d %d %d %d",&idim[0],&idim[1],&idim[2], + &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]); + i__1 = nidim; + for (i__ = 1; i__ <= i__1; ++i__) { + if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) { + fprintf(stderr,"VALUE OF N IS LESS THAN 0 OR GREATER THAN 65\n"); + goto L230; + } +/* L10: */ + } +/* Values of K */ + fgets(line,80,stdin); + sscanf(line,"%d",&nkb); + + if (nkb < 1 || nkb > 7) { + fprintf(stderr,"NUMBER OF VALUES OF K IS LESS THAN 1 OR GREATER THAN 7"); + goto L230; + } + fgets(line,80,stdin); + sscanf(line,"%d %d %d %d %d %d %d",&kb[0],&kb[1],&kb[2],&kb[3],&kb[4],&kb[5],&kb[6]); + i__1 = nkb; + for (i__ = 1; i__ <= i__1; ++i__) { + if (kb[i__ - 1] < 0 ) { + fprintf(stderr,"VALUE OF K IS LESS THAN 0\n"); + goto L230; + } +/* L20: */ + } +/* Values of INCX and INCY */ + fgets(line,80,stdin); + sscanf(line,"%d",&ninc); + + if (ninc < 1 || ninc > 7) { + fprintf(stderr,"NUMBER OF VALUES OF INCX AND INCY IS LESS THAN 1 OR GREATER THAN 7"); + goto L230; + } + + fgets(line,80,stdin); + sscanf(line,"%d %d %d %d %d %d %d",&inc[0],&inc[1],&inc[2],&inc[3],&inc[4],&inc[5],&inc[6]); + i__1 = ninc; + for (i__ = 1; i__ <= i__1; ++i__) { + if (inc[i__ - 1] == 0 || (i__2 = inc[i__ - 1], abs(i__2)) > 2) { + fprintf (stderr,"ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN 2\n"); + goto L230; + } +/* L30: */ + } +/* Values of ALPHA */ + fgets(line,80,stdin); + sscanf(line,"%d",&nalf); + if (nalf < 1 || nalf > 7) { + fprintf(stderr,"VALUE OF ALPHA IS LESS THAN 0 OR GREATER THAN 7\n"); + goto L230; + } + fgets(line,80,stdin); + sscanf(line,"(%f,%f) (%f,%f) (%f,%f) (%f,%f) (%f,%f) (%f,%f) (%f,%f)",&alf[0].r,&alf[0].i,&alf[1].r,&alf[1].i,&alf[2].r,&alf[2].i,&alf[3].r,&alf[3].i, + &alf[4].r,&alf[4].i,&alf[5].r,&alf[5].i,&alf[6].r,&alf[6].i); + +/* Values of BETA */ + fgets(line,80,stdin); + sscanf(line,"%d",&nbet); + if (nbet < 1 || nbet > 7) { + fprintf(stderr,"VALUE OF BETA IS LESS THAN 0 OR GREATER THAN 7\n"); + goto L230; + } + fgets(line,80,stdin); + sscanf(line,"(%f,%f) (%f,%f) (%f,%f) (%f,%f) (%f,%f) (%f,%f) (%f,%f)",&bet[0].r,&bet[0].i,&bet[1].r,&bet[1].i,&bet[2].r,&bet[2].i,&bet[3].r,&bet[3].i, + &bet[4].r,&bet[4].i,&bet[5].r,&bet[5].i,&bet[6].r,&bet[6].i); + +/* Report values of parameters. */ + printf("TESTS OF THE REAL LEVEL 2 BLAS\nTHE FOLLOWING PARAMETER VALUES WILL BE USED:\n"); + printf(" FOR N"); + for (i__ =1; i__ <=nidim;++i__) printf(" %d",idim[i__-1]); + printf("\n"); + + printf(" FOR K"); + for (i__ =1; i__ <=nkb;++i__) printf(" %d",kb[i__-1]); + printf("\n"); + + printf(" FOR INCX AND INCY"); + for (i__ =1; i__ <=ninc;++i__) printf(" %d",inc[i__-1]); + printf("\n"); + + printf(" FOR ALPHA"); + for (i__ =1; i__ <=nalf;++i__) printf(" (%f,%f)",alf[i__-1].r,alf[i__-1].i); + printf("\n"); + printf(" FOR BETA"); + for (i__ =1; i__ <=nbet;++i__) printf(" (%f,%f)",bet[i__-1].r,bet[i__-1].i); + printf("\n"); + + if (! tsterr) { + printf(" ERROR-EXITS WILL NOT BE TESTED\n"); + } + printf("ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LESS THAN %f\n",thresh); + + rorder = FALSE_; + corder = FALSE_; + if (layout == 2) { + rorder = TRUE_; + corder = TRUE_; + printf("COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED\n"); + } else if (layout == 1) { + rorder = TRUE_; + printf("ROW-MAJOR DATA LAYOUT IS TESTED\n"); + } else if (layout == 0) { + corder = TRUE_; + printf("COLUMN-MAJOR DATA LAYOUT IS TESTED\n"); + } + +/* Read names of subroutines and flags which indicate */ +/* whether they are to be tested. */ + + for (i__ = 1; i__ <= 17; ++i__) { + ltest[i__ - 1] = FALSE_; +/* L40: */ + } +L50: + if (! fgets(line,80,stdin)) { + goto L80; + } + i__1 = sscanf(line,"%12c %c",snamet,&tmpchar); + ltestt=FALSE_; + if (tmpchar=='T')ltestt=TRUE_; + if (i__1 < 2) { + goto L80; + } + for (i__ = 1; i__ <= 17; ++i__) { + if (s_cmp(snamet, snames[i__ - 1], (ftnlen)12, (ftnlen)12) == + 0) { + goto L70; + } +/* L60: */ + } + printf("SUBPROGRAM NAME %s NOT RECOGNIZED\n****** TESTS ABANDONED ******\n",snamet); + exit(1); +L70: + ltest[i__ - 1] = ltestt; + goto L50; + +L80: +/* cl__1.cerr = 0; + cl__1.cunit = 5; + cl__1.csta = 0; + f_clos(&cl__1);*/ + +/* Compute EPS (the machine precision). */ + + eps = (float)1.; +L90: + r__1 = eps + (float)1.; + if (sdiff_(&r__1, &c_b125) == (float)0.) { + goto L100; + } + eps *= (float).5; + goto L90; +L100: + eps += eps; + printf("RELATIVE MACHINE PRECISION IS TAKEN TO BE %9.1g\n",eps); + +/* Check the reliability of CMVCH using exact data. */ + + n = 32; + i__1 = n; + for (j = 1; j <= i__1; ++j) { + i__2 = n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * 65 - 66; +/* Computing MAX */ + i__5 = i__ - j + 1; + i__4 = f2cmax(i__5,0); + a[i__3].r = (real) i__4, a[i__3].i = (float)0.; +/* L110: */ + } + i__2 = j - 1; + x[i__2].r = (real) j, x[i__2].i = (float)0.; + i__2 = j - 1; + y[i__2].r = (float)0., y[i__2].i = (float)0.; +/* L120: */ + } + i__1 = n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + i__3 = j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3; + yy[i__2].r = (real) i__3, yy[i__2].i = (float)0.; +/* L130: */ + } +/* YY holds the exact result. On exit from CMVCH YT holds */ +/* the result computed by CMVCH. */ + *(unsigned char *)trans = 'N'; + cmvch_(trans, &n, &n, &c_b2, a, &c__65, x, &c__1, &c_b1, y, &c__1, yt, g, + yy, &eps, &err, &fatal, &c__6, &c_true, (ftnlen)1); + same = lce_(yy, yt, &n); + if (! same || err != (float)0.) { + printf("ERROR IN CMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); + printf("CMVCH WAS CALLED WITH TRANS = %s ", trans); + printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); + printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); + printf("****** TESTS ABANDONED ******\n"); + exit(1); + } + *(unsigned char *)trans = 'T'; + cmvch_(trans, &n, &n, &c_b2, a, &c__65, x, &c_n1, &c_b1, y, &c_n1, yt, g, + yy, &eps, &err, &fatal, &c__6, &c_true, (ftnlen)1); + same = lce_(yy, yt, &n); + if (! same || err != (float)0.) { + printf("ERROR IN CMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); + printf("CMVCH WAS CALLED WITH TRANS = %s ", trans); + printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); + printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); + printf("****** TESTS ABANDONED ******\n"); + exit(1); + } + +/* Test each subroutine in turn. */ + + for (isnum = 1; isnum <= 17; ++isnum) { + if (! ltest[isnum - 1]) { +/* Subprogram is not to be tested. */ + printf("%12s WAS NOT TESTED\n",snames[isnum-1]); + } else { + s_copy(srnamc_1.srnamt, snames[isnum - 1], (ftnlen)12, ( + ftnlen)12); +/* Test error exits. */ + if (tsterr) { + cc2chke_(snames[isnum - 1], (ftnlen)12); + } +/* Test computations. */ + infoc_1.infot = 0; + infoc_1.ok = TRUE_; + fatal = FALSE_; + switch ((int)isnum) { + case 1: goto L140; + case 2: goto L140; + case 3: goto L150; + case 4: goto L150; + case 5: goto L150; + case 6: goto L160; + case 7: goto L160; + case 8: goto L160; + case 9: goto L160; + case 10: goto L160; + case 11: goto L160; + case 12: goto L170; + case 13: goto L170; + case 14: goto L180; + case 15: goto L180; + case 16: goto L190; + case 17: goto L190; + } +/* Test CGEMV, 01, and CGBMV, 02. */ +L140: + if (corder) { + cchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, + alf, &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, + as, x, xx, xs, y, yy, ys, yt, g, &c__0, (ftnlen)12); + } + if (rorder) { + cchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, + alf, &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, + as, x, xx, xs, y, yy, ys, yt, g, &c__1, (ftnlen)12); + } + goto L200; +/* Test CHEMV, 03, CHBMV, 04, and CHPMV, 05. */ +L150: + if (corder) { + cchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, + alf, &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, + as, x, xx, xs, y, yy, ys, yt, g, &c__0, (ftnlen)12); + } + if (rorder) { + cchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, + alf, &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, + as, x, xx, xs, y, yy, ys, yt, g, &c__1, (ftnlen)12); + } + goto L200; +/* Test CTRMV, 06, CTBMV, 07, CTPMV, 08, */ +/* CTRSV, 09, CTBSV, 10, and CTPSV, 11. */ +L160: + if (corder) { + cchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &ninc, + inc, &c__65, &c__2, a, aa, as, y, yy, ys, yt, g, z__, + &c__0, (ftnlen)12); + } + if (rorder) { + cchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &ninc, + inc, &c__65, &c__2, a, aa, as, y, yy, ys, yt, g, z__, + &c__1, (ftnlen)12); + } + goto L200; +/* Test CGERC, 12, CGERU, 13. */ +L170: + if (corder) { + cchk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, + ys, yt, g, z__, &c__0, (ftnlen)12); + } + if (rorder) { + cchk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, + ys, yt, g, z__, &c__1, (ftnlen)12); + } + goto L200; +/* Test CHER, 14, and CHPR, 15. */ +L180: + if (corder) { + cchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, + ys, yt, g, z__, &c__0, (ftnlen)12); + } + if (rorder) { + cchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, + ys, yt, g, z__, &c__1, (ftnlen)12); + } + goto L200; +/* Test CHER2, 16, and CHPR2, 17. */ +L190: + if (corder) { + cchk6_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, + ys, yt, g, z__, &c__0, (ftnlen)12); + } + if (rorder) { + cchk6_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, + ys, yt, g, z__, &c__1, (ftnlen)12); + } + +L200: + if (fatal && sfatal) { + goto L220; + } + } +/* L210: */ + } + printf("\nEND OF TESTS\n"); + goto L240; + +L220: + printf("\n****** FATAL ERROR - TESTS ABANDONED ******\n"); + goto L240; + +L230: + printf("AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM\n"); + printf("****** TESTS ABANDONED ******\n"); + +L240: + if (trace) { +/* cl__1.cerr = 0; + cl__1.cunit = ntra; + cl__1.csta = 0; + f_clos(&cl__1);*/ + } +/* cl__1.cerr = 0; + cl__1.cunit = 6; + cl__1.csta = 0; + f_clos(&cl__1);*/ + exit(0); + + +/* End of CBLAT2. */ + +} /* MAIN__ */ + +/* Subroutine */ int 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, sname_len) +char *sname; +real *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nkb, *kb, *nalf; +complex *alf; +integer *nbet; +complex *bet; +integer *ninc, *inc, *nmax, *incmax; +complex *a, *aa, *as, *x, *xx, *xs, *y, *yy, *ys, *yt; +real *g; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ich[3+1] = "NTC"; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, + i__9; + + /* Local variables */ + static complex beta; + static integer ldas; + static logical same; + static integer incx, incy; + static logical full, tran, null; + static integer i__, m, n; + extern /* Subroutine */ int cmake_(); + static complex alpha; + static logical isame[13]; + extern /* Subroutine */ int cmvch_(); + static integer nargs; + static logical reset; + static integer incxs, incys; + static char trans[1]; + static integer ia, ib, ic; + static logical banded; + static integer nc, nd, im, in, kl, ml, nk, nl, ku, ix, iy, ms, lx, ly, ns; + extern /* Subroutine */ int ccgbmv_(), ccgemv_(); + extern logical lceres_(); + static char ctrans[14]; + static real errmax; + static complex transl; + static char transs[1]; + static integer laa, lda; + extern logical lce_(); + static complex als, bls; + static real err; + static integer iku, kls, kus; + +/* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --kb; + --alf; + --bet; + --inc; + --g; + --yt; + --y; + --x; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ys; + --yy; + --xs; + --xx; + + /* Function Body */ +/* .. Executable Statements .. */ + full = *(unsigned char *)&sname[8] == 'e'; + banded = *(unsigned char *)&sname[8] == 'b'; +/* Define the number of arguments. */ + if (full) { + nargs = 11; + } else if (banded) { + nargs = 13; + } + + nc = 0; + reset = TRUE_; + errmax = (float)0.; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; + nd = n / 2 + 1; + + for (im = 1; im <= 2; ++im) { + if (im == 1) { +/* Computing MAX */ + i__2 = n - nd; + m = f2cmax(i__2,0); + } + if (im == 2) { +/* Computing MIN */ + i__2 = n + nd; + m = f2cmin(i__2,*nmax); + } + + if (banded) { + nk = *nkb; + } else { + nk = 1; + } + i__2 = nk; + for (iku = 1; iku <= i__2; ++iku) { + if (banded) { + ku = kb[iku]; +/* Computing MAX */ + i__3 = ku - 1; + kl = f2cmax(i__3,0); + } else { + ku = n - 1; + kl = m - 1; + } +/* Set LDA to 1 more than minimum value if room. */ + if (banded) { + lda = kl + ku + 1; + } else { + lda = m; + } + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L100; + } + laa = lda * n; + null = n <= 0 || m <= 0; + +/* Generate the matrix A. */ + + transl.r = (float)0., transl.i = (float)0.; + cmake_(sname + 7, " ", " ", &m, &n, &a[a_offset], nmax, &aa[1] + , &lda, &kl, &ku, &reset, &transl, (ftnlen)2, (ftnlen) + 1, (ftnlen)1); + + for (ic = 1; ic <= 3; ++ic) { + *(unsigned char *)trans = *(unsigned char *)&ich[ic - 1]; + if (*(unsigned char *)trans == 'N') { + s_copy(ctrans, " CblasNoTrans", (ftnlen)14, (ftnlen) + 14); + } else if (*(unsigned char *)trans == 'T') { + s_copy(ctrans, " CblasTrans", (ftnlen)14, (ftnlen) + 14); + } else { + s_copy(ctrans, "CblasConjTrans", (ftnlen)14, (ftnlen) + 14); + } + tran = *(unsigned char *)trans == 'T' || *(unsigned char * + )trans == 'C'; + + if (tran) { + ml = n; + nl = m; + } else { + ml = m; + nl = n; + } + + i__3 = *ninc; + for (ix = 1; ix <= i__3; ++ix) { + incx = inc[ix]; + lx = abs(incx) * nl; + +/* Generate the vector X. */ + + transl.r = (float).5, transl.i = (float)0.; + i__4 = abs(incx); + i__5 = nl - 1; + cmake_("ge", " ", " ", &c__1, &nl, &x[1], &c__1, &xx[ + 1], &i__4, &c__0, &i__5, &reset, &transl, ( + ftnlen)2, (ftnlen)1, (ftnlen)1); + if (nl > 1) { + i__4 = nl / 2; + x[i__4].r = (float)0., x[i__4].i = (float)0.; + i__4 = abs(incx) * (nl / 2 - 1) + 1; + xx[i__4].r = (float)0., xx[i__4].i = (float)0.; + } + + i__4 = *ninc; + for (iy = 1; iy <= i__4; ++iy) { + incy = inc[iy]; + ly = abs(incy) * ml; + + i__5 = *nalf; + for (ia = 1; ia <= i__5; ++ia) { + i__6 = ia; + alpha.r = alf[i__6].r, alpha.i = alf[i__6].i; + + i__6 = *nbet; + for (ib = 1; ib <= i__6; ++ib) { + i__7 = ib; + beta.r = bet[i__7].r, beta.i = bet[i__7] + .i; + +/* Generate the vector Y. */ + + transl.r = (float)0., transl.i = (float) + 0.; + i__7 = abs(incy); + i__8 = ml - 1; + cmake_("ge", " ", " ", &c__1, &ml, &y[1], + &c__1, &yy[1], &i__7, &c__0, & + i__8, &reset, &transl, (ftnlen)2, + (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the */ +/* subroutine. */ + + *(unsigned char *)transs = *(unsigned + char *)trans; + ms = m; + ns = n; + kls = kl; + kus = ku; + als.r = alpha.r, als.i = alpha.i; + i__7 = laa; + for (i__ = 1; i__ <= i__7; ++i__) { + i__8 = i__; + i__9 = i__; + as[i__8].r = aa[i__9].r, as[i__8].i = + aa[i__9].i; +/* L10: */ + } + ldas = lda; + i__7 = lx; + for (i__ = 1; i__ <= i__7; ++i__) { + i__8 = i__; + i__9 = i__; + xs[i__8].r = xx[i__9].r, xs[i__8].i = + xx[i__9].i; +/* L20: */ + } + incxs = incx; + bls.r = beta.r, bls.i = beta.i; + i__7 = ly; + for (i__ = 1; i__ <= i__7; ++i__) { + i__8 = i__; + i__9 = i__; + ys[i__8].r = yy[i__9].r, ys[i__8].i = + yy[i__9].i; +/* L30: */ + } + incys = incy; + +/* Call the subroutine. */ + + if (full) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s %3d %3d (%4.1f,%4.1f) A\n %3d, X, %2d, (%4.1f,%4.1f), Y, %2d).\n", + nc,sname,ctrans,m,n,alpha.r,alpha.i,lda,incx,beta.r,beta.i,incy); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + ccgemv_(iorder, trans, &m, &n, &alpha, + &aa[1], &lda, &xx[1], &incx, + &beta, &yy[1], &incy, (ftnlen) + 1); + } else if (banded) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s %3d %3d %3d %3d (%4.1f,%4.1f) A\n %3d, X, %2d, (%4.1f,%4.1f), Y, %2d).\n", + nc,sname,ctrans,m,n,kl,ku,alpha.r,alpha.i,lda,incx,beta.r,beta.i,incy); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + ccgbmv_(iorder, trans, &m, &n, &kl, & + ku, &alpha, &aa[1], &lda, &xx[ + 1], &incx, &beta, &yy[1], & + incy, (ftnlen)1); + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf("******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******\n"); + *fatal = TRUE_; + goto L130; + } + +/* See what data changed inside subroutines. */ + +/* IF(TRANS .NE. 'C' .OR. (INCX .GT. 0 .AND. INCY .GT. 0)) THEN */ + isame[0] = *(unsigned char *)trans == *( + unsigned char *)transs; + isame[1] = ms == m; + isame[2] = ns == n; + if (full) { + isame[3] = als.r == alpha.r && als.i + == alpha.i; + isame[4] = lce_(&as[1], &aa[1], &laa); + isame[5] = ldas == lda; + isame[6] = lce_(&xs[1], &xx[1], &lx); + isame[7] = incxs == incx; + isame[8] = bls.r == beta.r && bls.i == + beta.i; + if (null) { + isame[9] = lce_(&ys[1], &yy[1], & + ly); + } else { + i__7 = abs(incy); + isame[9] = lceres_("ge", " ", & + c__1, &ml, &ys[1], &yy[1], + &i__7, (ftnlen)2, ( + ftnlen)1); + } + isame[10] = incys == incy; + } else if (banded) { + isame[3] = kls == kl; + isame[4] = kus == ku; + isame[5] = als.r == alpha.r && als.i + == alpha.i; + isame[6] = lce_(&as[1], &aa[1], &laa); + isame[7] = ldas == lda; + isame[8] = lce_(&xs[1], &xx[1], &lx); + isame[9] = incxs == incx; + isame[10] = bls.r == beta.r && bls.i + == beta.i; + if (null) { + isame[11] = lce_(&ys[1], &yy[1], & + ly); + } else { + i__7 = abs(incy); + isame[11] = lceres_("ge", " ", & + c__1, &ml, &ys[1], &yy[1], + &i__7, (ftnlen)2, ( + ftnlen)1); + } + isame[12] = incys == incy; + } + +/* If data was incorrectly changed, report */ +/* and return. */ + + same = TRUE_; + i__7 = nargs; + for (i__ = 1; i__ <= i__7; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L130; + } + + if (! null) { + +/* Check the result. */ + + cmvch_(trans, &m, &n, &alpha, &a[ + a_offset], nmax, &x[1], &incx, + &beta, &y[1], &incy, &yt[1], + &g[1], &yy[1], eps, &err, + fatal, nout, &c_true, (ftnlen) + 1); + errmax = dmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L130; + } + } else { +/* Avoid repeating tests with M.le.0 or */ +/* N.le.0. */ + goto L110; + } +/* END IF */ + +/* L50: */ + } + +/* L60: */ + } + +/* L70: */ + } + +/* L80: */ + } + +/* L90: */ + } + +L100: + ; + } + +L110: + ; + } + +/* L120: */ + } + +/* Report result. */ + + if (errmax < *thresh) { + printf("%12s PASSED THE COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } else { + printf("%12s COMPLETED THE COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + printf("******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",errmax); + } + goto L140; + +L130: + printf("******* %12s FAILED ON CALL NUMBER:\n",sname); + if (full) { + printf("%6d: %12s (%14s %3d %3d (%4.1f,%4.1f) A\n %3d, X, %2d, (%4.1f,%4.1f), Y, %2d).\n", + nc,sname,ctrans,m,n,alpha.r,alpha.i,lda,incx,beta.r,beta.i,incy); + } else if (banded) { + printf("%6d: %12s (%14s %3d %3d %3d %3d (%4.1f,%4.1f) A\n %3d, X, %2d, (%4.1f,%4.1f), Y, %2d).\n", + nc,sname,ctrans,m,n,kl,ku,alpha.r,alpha.i,lda,incx,beta.r,beta.i,incy); + } + +L140: + return 0; + + +/* End of CCHK1. */ + +} /* cchk1_ */ + +/* Subroutine */ int 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, sname_len) +char *sname; +real *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nkb, *kb, *nalf; +complex *alf; +integer *nbet; +complex *bet; +integer *ninc, *inc, *nmax, *incmax; +complex *a, *aa, *as, *x, *xx, *xs, *y, *yy, *ys, *yt; +real *g; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ich[2+1] = "UL"; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, + i__9; + + /* Local variables */ + static complex beta; + static integer ldas; + static logical same; + static integer incx, incy; + static logical full, null; + static char uplo[1]; + static integer i__, k, n; + extern /* Subroutine */ int cmake_(); + static complex alpha; + static logical isame[13]; + extern /* Subroutine */ int cmvch_(); + static integer nargs; + static logical reset; + static char cuplo[14]; + static integer incxs, incys; + static char uplos[1]; + static integer ia, ib, ic; + static logical banded; + static integer nc, ik, in; + static logical packed; + static integer nk, ks, ix, iy, ns, lx, ly; + extern /* Subroutine */ int cchbmv_(), cchemv_(); + extern logical lceres_(); + extern /* Subroutine */ int cchpmv_(); + static real errmax; + static complex transl; + static integer laa, lda; + extern logical lce_(); + static complex als, bls; + static real err; + +/* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --kb; + --alf; + --bet; + --inc; + --g; + --yt; + --y; + --x; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ys; + --yy; + --xs; + --xx; + + /* Function Body */ +/* .. Executable Statements .. */ + full = *(unsigned char *)&sname[8] == 'e'; + banded = *(unsigned char *)&sname[8] == 'b'; + packed = *(unsigned char *)&sname[8] == 'p'; +/* Define the number of arguments. */ + if (full) { + nargs = 10; + } else if (banded) { + nargs = 11; + } else if (packed) { + nargs = 9; + } + + nc = 0; + reset = TRUE_; + errmax = (float)0.; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; + + if (banded) { + nk = *nkb; + } else { + nk = 1; + } + i__2 = nk; + for (ik = 1; ik <= i__2; ++ik) { + if (banded) { + k = kb[ik]; + } else { + k = n - 1; + } +/* Set LDA to 1 more than minimum value if room. */ + if (banded) { + lda = k + 1; + } else { + lda = n; + } + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L100; + } + if (packed) { + laa = n * (n + 1) / 2; + } else { + laa = lda * n; + } + null = n <= 0; + + for (ic = 1; ic <= 2; ++ic) { + *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1]; + if (*(unsigned char *)uplo == 'U') { + s_copy(cuplo, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cuplo, " CblasLower", (ftnlen)14, (ftnlen)14); + } + +/* Generate the matrix A. */ + + transl.r = (float)0., transl.i = (float)0.; + cmake_(sname + 7, uplo, " ", &n, &n, &a[a_offset], nmax, &aa[ + 1], &lda, &k, &k, &reset, &transl, (ftnlen)2, (ftnlen) + 1, (ftnlen)1); + + i__3 = *ninc; + for (ix = 1; ix <= i__3; ++ix) { + incx = inc[ix]; + lx = abs(incx) * n; + +/* Generate the vector X. */ + + transl.r = (float).5, transl.i = (float)0.; + i__4 = abs(incx); + i__5 = n - 1; + cmake_("ge", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], & + i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, ( + ftnlen)1, (ftnlen)1); + if (n > 1) { + i__4 = n / 2; + x[i__4].r = (float)0., x[i__4].i = (float)0.; + i__4 = abs(incx) * (n / 2 - 1) + 1; + xx[i__4].r = (float)0., xx[i__4].i = (float)0.; + } + + i__4 = *ninc; + for (iy = 1; iy <= i__4; ++iy) { + incy = inc[iy]; + ly = abs(incy) * n; + + i__5 = *nalf; + for (ia = 1; ia <= i__5; ++ia) { + i__6 = ia; + alpha.r = alf[i__6].r, alpha.i = alf[i__6].i; + + i__6 = *nbet; + for (ib = 1; ib <= i__6; ++ib) { + i__7 = ib; + beta.r = bet[i__7].r, beta.i = bet[i__7].i; + +/* Generate the vector Y. */ + + transl.r = (float)0., transl.i = (float)0.; + i__7 = abs(incy); + i__8 = n - 1; + cmake_("ge", " ", " ", &c__1, &n, &y[1], & + c__1, &yy[1], &i__7, &c__0, &i__8, & + reset, &transl, (ftnlen)2, (ftnlen)1, + (ftnlen)1); + + ++nc; + +/* Save every datum before calling the */ +/* subroutine. */ + + *(unsigned char *)uplos = *(unsigned char *) + uplo; + ns = n; + ks = k; + als.r = alpha.r, als.i = alpha.i; + i__7 = laa; + for (i__ = 1; i__ <= i__7; ++i__) { + i__8 = i__; + i__9 = i__; + as[i__8].r = aa[i__9].r, as[i__8].i = aa[ + i__9].i; +/* L10: */ + } + ldas = lda; + i__7 = lx; + for (i__ = 1; i__ <= i__7; ++i__) { + i__8 = i__; + i__9 = i__; + xs[i__8].r = xx[i__9].r, xs[i__8].i = xx[ + i__9].i; +/* L20: */ + } + incxs = incx; + bls.r = beta.r, bls.i = beta.i; + i__7 = ly; + for (i__ = 1; i__ <= i__7; ++i__) { + i__8 = i__; + i__9 = i__; + ys[i__8].r = yy[i__9].r, ys[i__8].i = yy[ + i__9].i; +/* L30: */ + } + incys = incy; + +/* Call the subroutine. */ + + if (full) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %3d, (%4.1f,%4.1f) A, %3d, X, %2d (%4.1f,%4.1f), Y, %2d ).\n", + nc,sname,cuplo,n,alpha.r,alpha.i,lda,incx,beta.r,beta.i,incy); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cchemv_(iorder, uplo, &n, &alpha, &aa[1], + &lda, &xx[1], &incx, &beta, &yy[1] + , &incy, (ftnlen)1); + } else if (banded) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %3d %3d, (%4.1f,%4.1f) A, %3d, X, %2d (%4.1f,%4.1f), Y, %2d ).\n", + nc,sname,cuplo,n,k, alpha.r,alpha.i,lda,incx,beta.r,beta.i,incy); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cchbmv_(iorder, uplo, &n, &k, &alpha, &aa[ + 1], &lda, &xx[1], &incx, &beta, & + yy[1], &incy, (ftnlen)1); + } else if (packed) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %3d, (%4.1f,%4.1f) AP, X, %2d (%4.1f,%4.1f), Y, %2d ).\n", + nc,sname,cuplo,n, alpha.r,alpha.i,incx,beta.r,beta.i,incy); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cchpmv_(iorder, uplo, &n, &alpha, &aa[1], + &xx[1], &incx, &beta, &yy[1], & + incy, (ftnlen)1); + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf("******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******\n"); + *fatal = TRUE_; + goto L120; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)uplo == *( + unsigned char *)uplos; + isame[1] = ns == n; + if (full) { + isame[2] = als.r == alpha.r && als.i == + alpha.i; + isame[3] = lce_(&as[1], &aa[1], &laa); + isame[4] = ldas == lda; + isame[5] = lce_(&xs[1], &xx[1], &lx); + isame[6] = incxs == incx; + isame[7] = bls.r == beta.r && bls.i == + beta.i; + if (null) { + isame[8] = lce_(&ys[1], &yy[1], &ly); + } else { + i__7 = abs(incy); + isame[8] = lceres_("ge", " ", &c__1, & + n, &ys[1], &yy[1], &i__7, ( + ftnlen)2, (ftnlen)1); + } + isame[9] = incys == incy; + } else if (banded) { + isame[2] = ks == k; + isame[3] = als.r == alpha.r && als.i == + alpha.i; + isame[4] = lce_(&as[1], &aa[1], &laa); + isame[5] = ldas == lda; + isame[6] = lce_(&xs[1], &xx[1], &lx); + isame[7] = incxs == incx; + isame[8] = bls.r == beta.r && bls.i == + beta.i; + if (null) { + isame[9] = lce_(&ys[1], &yy[1], &ly); + } else { + i__7 = abs(incy); + isame[9] = lceres_("ge", " ", &c__1, & + n, &ys[1], &yy[1], &i__7, ( + ftnlen)2, (ftnlen)1); + } + isame[10] = incys == incy; + } else if (packed) { + isame[2] = als.r == alpha.r && als.i == + alpha.i; + isame[3] = lce_(&as[1], &aa[1], &laa); + isame[4] = lce_(&xs[1], &xx[1], &lx); + isame[5] = incxs == incx; + isame[6] = bls.r == beta.r && bls.i == + beta.i; + if (null) { + isame[7] = lce_(&ys[1], &yy[1], &ly); + } else { + i__7 = abs(incy); + isame[7] = lceres_("ge", " ", &c__1, & + n, &ys[1], &yy[1], &i__7, ( + ftnlen)2, (ftnlen)1); + } + isame[8] = incys == incy; + } + +/* If data was incorrectly changed, report and */ +/* return. */ + + same = TRUE_; + i__7 = nargs; + for (i__ = 1; i__ <= i__7; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L120; + } + + if (! null) { + +/* Check the result. */ + + cmvch_("N", &n, &n, &alpha, &a[a_offset], + nmax, &x[1], &incx, &beta, &y[1], + &incy, &yt[1], &g[1], &yy[1], eps, + &err, fatal, nout, &c_true, ( + ftnlen)1); + errmax = dmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L120; + } + } else { +/* Avoid repeating tests with N.le.0 */ + goto L110; + } + +/* L50: */ + } + +/* L60: */ + } + +/* L70: */ + } + +/* L80: */ + } + +/* L90: */ + } + +L100: + ; + } + +L110: + ; + } + +/* Report result. */ + + if (errmax < *thresh) { + printf("%12s PASSED THE COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } else { + printf("%12s COMPLETED THE COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + printf("******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",errmax); + } + goto L130; + +L120: + printf("******* %12s FAILED ON CALL NUMBER:\n",sname); + if (full) { + printf("%6d: %12s (%14s, %3d, (%4.1f,%4.1f) A, %3d, X, %2d (%4.1f,%4.1f), Y, %2d ).\n", + nc,sname,cuplo,n, alpha.r,alpha.i,lda,incx,beta.r,beta.i,incy); + } else if (banded) { + printf("%6d: %12s (%14s, %3d, %3d, (%4.1f,%4.1f) A, %3d, X, %2d (%4.1f,%4.1f), Y, %2d ).\n", + nc,sname,cuplo,n, k, alpha.r,alpha.i,lda,incx,beta.r,beta.i,incy); + } else if (packed) { + printf("%6d: %12s (%14s, %3d, (%4.1f,%4.1f) AP, X, %2d (%4.1f,%4.1f), Y, %2d ).\n", + nc,sname,cuplo,n, alpha.r,alpha.i,incx,beta.r,beta.i,incy); + } + +L130: + return 0; + + +/* End of CCHK2. */ + +} /* cchk2_ */ + +/* Subroutine */ int 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, sname_len) +char *sname; +real *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nkb, *kb, *ninc, *inc, *nmax, *incmax; +complex *a, *aa, *as, *x, *xx, *xs, *xt; +real *g; +complex *z__; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ichu[2+1] = "UL"; + static char icht[3+1] = "NTC"; + static char ichd[2+1] = "UN"; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; + + /* Local variables */ + static char diag[1]; + static integer ldas; + static logical same; + static integer incx; + static logical full, null; + static char uplo[1], cdiag[14]; + static integer i__, k, n; + extern /* Subroutine */ int cmake_(); + static char diags[1]; + static logical isame[13]; + extern /* Subroutine */ int cmvch_(); + static integer nargs; + static logical reset; + static char cuplo[14]; + static integer incxs; + static char trans[1], uplos[1]; + static logical banded; + static integer nc, ik, in; + static logical packed; + static integer nk, ks, ix, ns, lx; + extern logical lceres_(); + extern /* Subroutine */ int cctbmv_(), cctbsv_(); + static char ctrans[14]; + extern /* Subroutine */ int cctpmv_(); + static real errmax; + extern /* Subroutine */ int cctrmv_(), cctpsv_(); + static complex transl; + extern /* Subroutine */ int cctrsv_(); + static char transs[1]; + static integer laa, icd, lda; + extern logical lce_(); + static integer ict, icu; + static real err; + +/* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --kb; + --inc; + --z__; + --g; + --xt; + --x; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --xs; + --xx; + + /* Function Body */ +/* .. Executable Statements .. */ + full = *(unsigned char *)&sname[8] == 'r'; + banded = *(unsigned char *)&sname[8] == 'b'; + packed = *(unsigned char *)&sname[8] == 'p'; +/* Define the number of arguments. */ + if (full) { + nargs = 8; + } else if (banded) { + nargs = 9; + } else if (packed) { + nargs = 7; + } + + nc = 0; + reset = TRUE_; + errmax = (float)0.; +/* Set up zero vector for CMVCH. */ + i__1 = *nmax; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + z__[i__2].r = (float)0., z__[i__2].i = (float)0.; +/* L10: */ + } + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; + + if (banded) { + nk = *nkb; + } else { + nk = 1; + } + i__2 = nk; + for (ik = 1; ik <= i__2; ++ik) { + if (banded) { + k = kb[ik]; + } else { + k = n - 1; + } +/* Set LDA to 1 more than minimum value if room. */ + if (banded) { + lda = k + 1; + } else { + lda = n; + } + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L100; + } + if (packed) { + laa = n * (n + 1) / 2; + } else { + laa = lda * n; + } + null = n <= 0; + + for (icu = 1; icu <= 2; ++icu) { + *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; + if (*(unsigned char *)uplo == 'U') { + s_copy(cuplo, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cuplo, " CblasLower", (ftnlen)14, (ftnlen)14); + } + + for (ict = 1; ict <= 3; ++ict) { + *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1] + ; + if (*(unsigned char *)trans == 'N') { + s_copy(ctrans, " CblasNoTrans", (ftnlen)14, (ftnlen) + 14); + } else if (*(unsigned char *)trans == 'T') { + s_copy(ctrans, " CblasTrans", (ftnlen)14, (ftnlen) + 14); + } else { + s_copy(ctrans, "CblasConjTrans", (ftnlen)14, (ftnlen) + 14); + } + + for (icd = 1; icd <= 2; ++icd) { + *(unsigned char *)diag = *(unsigned char *)&ichd[icd + - 1]; + if (*(unsigned char *)diag == 'N') { + s_copy(cdiag, " CblasNonUnit", (ftnlen)14, ( + ftnlen)14); + } else { + s_copy(cdiag, " CblasUnit", (ftnlen)14, ( + ftnlen)14); + } + +/* Generate the matrix A. */ + + transl.r = (float)0., transl.i = (float)0.; + cmake_(sname + 7, uplo, diag, &n, &n, &a[a_offset], + nmax, &aa[1], &lda, &k, &k, &reset, &transl, ( + ftnlen)2, (ftnlen)1, (ftnlen)1); + + i__3 = *ninc; + for (ix = 1; ix <= i__3; ++ix) { + incx = inc[ix]; + lx = abs(incx) * n; + +/* Generate the vector X. */ + + transl.r = (float).5, transl.i = (float)0.; + i__4 = abs(incx); + i__5 = n - 1; + cmake_("ge", " ", " ", &c__1, &n, &x[1], &c__1, & + xx[1], &i__4, &c__0, &i__5, &reset, & + transl, (ftnlen)2, (ftnlen)1, (ftnlen)1); + if (n > 1) { + i__4 = n / 2; + x[i__4].r = (float)0., x[i__4].i = (float)0.; + i__4 = abs(incx) * (n / 2 - 1) + 1; + xx[i__4].r = (float)0., xx[i__4].i = (float) + 0.; + } + + ++nc; + +/* Save every datum before calling the subroutine. */ + + *(unsigned char *)uplos = *(unsigned char *)uplo; + *(unsigned char *)transs = *(unsigned char *) + trans; + *(unsigned char *)diags = *(unsigned char *)diag; + ns = n; + ks = k; + i__4 = laa; + for (i__ = 1; i__ <= i__4; ++i__) { + i__5 = i__; + i__6 = i__; + as[i__5].r = aa[i__6].r, as[i__5].i = aa[i__6] + .i; +/* L20: */ + } + ldas = lda; + i__4 = lx; + for (i__ = 1; i__ <= i__4; ++i__) { + i__5 = i__; + i__6 = i__; + xs[i__5].r = xx[i__6].r, xs[i__5].i = xx[i__6] + .i; +/* L30: */ + } + incxs = incx; + +/* Call the subroutine. */ + + if (s_cmp(sname + 9, "mv", (ftnlen)2, (ftnlen)2) + == 0) { + if (full) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %14s, %14s, %3d, A, %3d, X, %2d).\n", + nc, sname, cuplo, ctrans, cdiag, n, lda, incx); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cctrmv_(iorder, uplo, trans, diag, &n, & + aa[1], &lda, &xx[1], &incx, ( + ftnlen)1, (ftnlen)1, (ftnlen)1); + } else if (banded) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %14s, %14s, %3d, %3d, A, %3d, X, %2d).\n", + nc, sname, cuplo, ctrans, cdiag, n, k, lda, incx); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cctbmv_(iorder, uplo, trans, diag, &n, &k, + &aa[1], &lda, &xx[1], &incx, ( + ftnlen)1, (ftnlen)1, (ftnlen)1); + } else if (packed) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %14s, %14s, %3d, AP X, %2d).\n", + nc, sname, cuplo, ctrans, cdiag, n, incx); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cctpmv_(iorder, uplo, trans, diag, &n, & + aa[1], &xx[1], &incx, (ftnlen)1, ( + ftnlen)1, (ftnlen)1); + } + } else if (s_cmp(sname + 9, "sv", (ftnlen)2, ( + ftnlen)2) == 0) { + if (full) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %14s, %14s, %3d, A, %3d, X, %2d).\n", + nc, sname, cuplo, ctrans, cdiag, n, lda, incx); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cctrsv_(iorder, uplo, trans, diag, &n, & + aa[1], &lda, &xx[1], &incx, ( + ftnlen)1, (ftnlen)1, (ftnlen)1); + } else if (banded) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %14s, %14s, %3d, %3d, A, %3d, X, %2d).\n", + nc, sname, cuplo, ctrans, cdiag, n, k, lda, incx); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cctbsv_(iorder, uplo, trans, diag, &n, &k, + &aa[1], &lda, &xx[1], &incx, ( + ftnlen)1, (ftnlen)1, (ftnlen)1); + } else if (packed) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %14s, %14s, %3d, AP X, %2d).\n", + nc, sname, cuplo, ctrans, cdiag, n, incx); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cctpsv_(iorder, uplo, trans, diag, &n, & + aa[1], &xx[1], &incx, (ftnlen)1, ( + ftnlen)1, (ftnlen)1); + } + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf("******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******\n"); + *fatal = TRUE_; + goto L120; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)uplo == *(unsigned + char *)uplos; + isame[1] = *(unsigned char *)trans == *(unsigned + char *)transs; + isame[2] = *(unsigned char *)diag == *(unsigned + char *)diags; + isame[3] = ns == n; + if (full) { + isame[4] = lce_(&as[1], &aa[1], &laa); + isame[5] = ldas == lda; + if (null) { + isame[6] = lce_(&xs[1], &xx[1], &lx); + } else { + i__4 = abs(incx); + isame[6] = lceres_("ge", " ", &c__1, &n, & + xs[1], &xx[1], &i__4, (ftnlen)2, ( + ftnlen)1); + } + isame[7] = incxs == incx; + } else if (banded) { + isame[4] = ks == k; + isame[5] = lce_(&as[1], &aa[1], &laa); + isame[6] = ldas == lda; + if (null) { + isame[7] = lce_(&xs[1], &xx[1], &lx); + } else { + i__4 = abs(incx); + isame[7] = lceres_("ge", " ", &c__1, &n, & + xs[1], &xx[1], &i__4, (ftnlen)2, ( + ftnlen)1); + } + isame[8] = incxs == incx; + } else if (packed) { + isame[4] = lce_(&as[1], &aa[1], &laa); + if (null) { + isame[5] = lce_(&xs[1], &xx[1], &lx); + } else { + i__4 = abs(incx); + isame[5] = lceres_("ge", " ", &c__1, &n, & + xs[1], &xx[1], &i__4, (ftnlen)2, ( + ftnlen)1); + } + isame[6] = incxs == incx; + } + +/* If data was incorrectly changed, report and */ +/* return. */ + + same = TRUE_; + i__4 = nargs; + for (i__ = 1; i__ <= i__4; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L120; + } + + if (! null) { + if (s_cmp(sname + 9, "mv", (ftnlen)2, (ftnlen) + 2) == 0) { + +/* Check the result. */ + + cmvch_(trans, &n, &n, &c_b2, &a[a_offset], + nmax, &x[1], &incx, &c_b1, &z__[ + 1], &incx, &xt[1], &g[1], &xx[1], + eps, &err, fatal, nout, &c_true, ( + ftnlen)1); + } else if (s_cmp(sname + 9, "sv", (ftnlen)2, ( + ftnlen)2) == 0) { + +/* Compute approximation to original vector. */ + + i__4 = n; + for (i__ = 1; i__ <= i__4; ++i__) { + i__5 = i__; + i__6 = (i__ - 1) * abs(incx) + 1; + z__[i__5].r = xx[i__6].r, z__[i__5].i + = xx[i__6].i; + i__5 = (i__ - 1) * abs(incx) + 1; + i__6 = i__; + xx[i__5].r = x[i__6].r, xx[i__5].i = + x[i__6].i; +/* L50: */ + } + cmvch_(trans, &n, &n, &c_b2, &a[a_offset], + nmax, &z__[1], &incx, &c_b1, &x[ + 1], &incx, &xt[1], &g[1], &xx[1], + eps, &err, fatal, nout, &c_false, + (ftnlen)1); + } + errmax = dmax(errmax,err); +/* If got really bad answer, report and return. */ + if (*fatal) { + goto L120; + } + } else { +/* Avoid repeating tests with N.le.0. */ + goto L110; + } + +/* L60: */ + } + +/* L70: */ + } + +/* L80: */ + } + +/* L90: */ + } + +L100: + ; + } + +L110: + ; + } + +/* Report result. */ + + if (errmax < *thresh) { + printf("%12s PASSED THE COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } else { + printf("%12s COMPLETED THE COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + printf("******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",errmax); + } + goto L130; + +L120: + printf("******* %12s FAILED ON CALL NUMBER:\n",sname); + if (full) { + printf("%6d: %12s (%14s, %14s, %14s, %3d, A, %3d, X, %2d).\n", + nc, sname, cuplo, ctrans, cdiag, n, lda, incx); + } else if (banded) { + printf("%6d: %12s (%14s, %14s, %14s, %3d, %3d, A, %3d, X, %2d).\n", + nc, sname, cuplo, ctrans, cdiag, n, k, lda, incx); + } else if (packed) { + + printf("%6d: %12s (%14s, %14s, %14s, %3d, AP X, %2d).\n", + nc, sname, cuplo, ctrans, cdiag, n, incx); + } + +L130: + return 0; + + +/* End of CCHK3. */ + +} /* cchk3_ */ + +/* Subroutine */ int 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, sname_len) +char *sname; +real *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nalf; +complex *alf; +integer *ninc, *inc, *nmax, *incmax; +complex *a, *aa, *as, *x, *xx, *xs, *y, *yy, *ys, *yt; +real *g; +complex *z__; +integer *iorder; +ftnlen sname_len; +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7; + complex q__1; + + /* Local variables */ + static integer ldas; + static logical same, conj; + static integer incx, incy; + static logical null; + static integer i__, j, m, n; + extern /* Subroutine */ int cmake_(); + static complex alpha, w[1]; + static logical isame[13]; + extern /* Subroutine */ int cmvch_(); + static integer nargs; + static logical reset; + static integer incxs, incys, ia, nc, nd, im, in; + extern /* Subroutine */ int ccgerc_(); + static integer ms, ix, iy, ns, lx, ly; + extern /* Subroutine */ int ccgeru_(); + extern logical lceres_(); + static real errmax; + static complex transl; + static integer laa, lda; + extern logical lce_(); + static complex als; + static real err; + +/* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + --idim; + --alf; + --inc; + --z__; + --g; + --yt; + --y; + --x; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ys; + --yy; + --xs; + --xx; + + /* Function Body */ + conj = *(unsigned char *)&sname[10] == 'c'; +/* Define the number of arguments. */ + nargs = 9; + + nc = 0; + reset = TRUE_; + errmax = (float)0.; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; + nd = n / 2 + 1; + + for (im = 1; im <= 2; ++im) { + if (im == 1) { +/* Computing MAX */ + i__2 = n - nd; + m = f2cmax(i__2,0); + } + if (im == 2) { +/* Computing MIN */ + i__2 = n + nd; + m = f2cmin(i__2,*nmax); + } + +/* Set LDA to 1 more than minimum value if room. */ + lda = m; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L110; + } + laa = lda * n; + null = n <= 0 || m <= 0; + + i__2 = *ninc; + for (ix = 1; ix <= i__2; ++ix) { + incx = inc[ix]; + lx = abs(incx) * m; + +/* Generate the vector X. */ + + transl.r = (float).5, transl.i = (float)0.; + i__3 = abs(incx); + i__4 = m - 1; + cmake_("ge", " ", " ", &c__1, &m, &x[1], &c__1, &xx[1], &i__3, + &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1, + (ftnlen)1); + if (m > 1) { + i__3 = m / 2; + x[i__3].r = (float)0., x[i__3].i = (float)0.; + i__3 = abs(incx) * (m / 2 - 1) + 1; + xx[i__3].r = (float)0., xx[i__3].i = (float)0.; + } + + i__3 = *ninc; + for (iy = 1; iy <= i__3; ++iy) { + incy = inc[iy]; + ly = abs(incy) * n; + +/* Generate the vector Y. */ + + transl.r = (float)0., transl.i = (float)0.; + i__4 = abs(incy); + i__5 = n - 1; + cmake_("ge", " ", " ", &c__1, &n, &y[1], &c__1, &yy[1], & + i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, ( + ftnlen)1, (ftnlen)1); + if (n > 1) { + i__4 = n / 2; + y[i__4].r = (float)0., y[i__4].i = (float)0.; + i__4 = abs(incy) * (n / 2 - 1) + 1; + yy[i__4].r = (float)0., yy[i__4].i = (float)0.; + } + + i__4 = *nalf; + for (ia = 1; ia <= i__4; ++ia) { + i__5 = ia; + alpha.r = alf[i__5].r, alpha.i = alf[i__5].i; + +/* Generate the matrix A. */ + + transl.r = (float)0., transl.i = (float)0.; + i__5 = m - 1; + i__6 = n - 1; + cmake_(sname + 7, " ", " ", &m, &n, &a[a_offset], + nmax, &aa[1], &lda, &i__5, &i__6, &reset, & + transl, (ftnlen)2, (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the subroutine. */ + + ms = m; + ns = n; + als.r = alpha.r, als.i = alpha.i; + i__5 = laa; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7].i; +/* L10: */ + } + ldas = lda; + i__5 = lx; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + xs[i__6].r = xx[i__7].r, xs[i__6].i = xx[i__7].i; +/* L20: */ + } + incxs = incx; + i__5 = ly; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + ys[i__6].r = yy[i__7].r, ys[i__6].i = yy[i__7].i; +/* L30: */ + } + incys = incy; + +/* Call the subroutine. */ + + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%3d, %3d, (%4.1f,%4.1f), X, %3d, Y, %3d, A, %3d).\n", + nc, sname, m, n, alpha.r, alpha.i, incx, incy, lda); +*/ + } + if (conj) { + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + ccgerc_(iorder, &m, &n, &alpha, &xx[1], &incx, & + yy[1], &incy, &aa[1], &lda); + } else { + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + ccgeru_(iorder, &m, &n, &alpha, &xx[1], &incx, & + yy[1], &incy, &aa[1], &lda); + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf("******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******\n"); + *fatal = TRUE_; + goto L140; + } + +/* See what data changed inside subroutine. */ + + isame[0] = ms == m; + isame[1] = ns == n; + isame[2] = als.r == alpha.r && als.i == alpha.i; + isame[3] = lce_(&xs[1], &xx[1], &lx); + isame[4] = incxs == incx; + isame[5] = lce_(&ys[1], &yy[1], &ly); + isame[6] = incys == incy; + if (null) { + isame[7] = lce_(&as[1], &aa[1], &laa); + } else { + isame[7] = lceres_("ge", " ", &m, &n, &as[1], &aa[ + 1], &lda, (ftnlen)2, (ftnlen)1); + } + isame[8] = ldas == lda; + +/* If data was incorrectly changed, report and return. */ + + same = TRUE_; + i__5 = nargs; + for (i__ = 1; i__ <= i__5; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L140; + } + + if (! null) { + +/* Check the result column by column. */ + + if (incx > 0) { + i__5 = m; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + z__[i__6].r = x[i__7].r, z__[i__6].i = x[ + i__7].i; +/* L50: */ + } + } else { + i__5 = m; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = m - i__ + 1; + z__[i__6].r = x[i__7].r, z__[i__6].i = x[ + i__7].i; +/* L60: */ + } + } + i__5 = n; + for (j = 1; j <= i__5; ++j) { + if (incy > 0) { + i__6 = j; + w[0].r = y[i__6].r, w[0].i = y[i__6].i; + } else { + i__6 = n - j + 1; + w[0].r = y[i__6].r, w[0].i = y[i__6].i; + } + if (conj) { + r_cnjg(&q__1, w); + w[0].r = q__1.r, w[0].i = q__1.i; + } + cmvch_("N", &m, &c__1, &alpha, &z__[1], nmax, + w, &c__1, &c_b2, &a[j * a_dim1 + 1], & + c__1, &yt[1], &g[1], &aa[(j - 1) * + lda + 1], eps, &err, fatal, nout, & + c_true, (ftnlen)1); + errmax = dmax(errmax,err); +/* If got really bad answer, report and return. */ + if (*fatal) { + goto L130; + } +/* L70: */ + } + } else { +/* Avoid repeating tests with M.le.0 or N.le.0. */ + goto L110; + } + +/* L80: */ + } + +/* L90: */ + } + +/* L100: */ + } + +L110: + ; + } + +/* L120: */ + } + +/* Report result. */ + + if (errmax < *thresh) { + printf("%12s PASSED THE COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } else { + printf("%12s COMPLETED THE COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + printf("******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",errmax); + } + goto L150; + +L130: + printf(" THESE ARE THE RESULTS FOR COLUMN %3d\n",j); + +L140: + printf("******* %12s FAILED ON CALL NUMBER:\n",sname); + printf("%6d: %12s (%3d, %3d, (%4.1f,%4.1f), X, %3d, Y, %3d, A, %3d).\n", + nc, sname, m, n, alpha.r, alpha.i, incx, incy, lda); + +L150: + return 0; + + +/* End of CCHK4. */ + +} /* cchk4_ */ + +/* Subroutine */ int 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, sname_len) +char *sname; +real *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nalf; +complex *alf; +integer *ninc, *inc, *nmax, *incmax; +complex *a, *aa, *as, *x, *xx, *xs, *y, *yy, *ys, *yt; +real *g; +complex *z__; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ich[2+1] = "UL"; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; + complex q__1; + + /* Local variables */ + static integer ldas; + static logical same; + static real rals; + static integer incx; + static logical full, null; + static char uplo[1]; + static integer i__, j, n; + extern /* Subroutine */ int cmake_(), ccher_(); + static complex alpha, w[1]; + static logical isame[13]; + extern /* Subroutine */ int cchpr_(), cmvch_(); + static integer nargs; + static logical reset; + static char cuplo[14]; + static integer incxs; + static logical upper; + static char uplos[1]; + static integer ia, ja, ic, nc, jj, lj, in; + static logical packed; + static integer ix, ns, lx; + static real ralpha; + extern logical lceres_(); + static real errmax; + static complex transl; + static integer laa, lda; + extern logical lce_(); + static real err; + +/* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --alf; + --inc; + --z__; + --g; + --yt; + --y; + --x; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ys; + --yy; + --xs; + --xx; + + /* Function Body */ +/* .. Executable Statements .. */ + full = *(unsigned char *)&sname[8] == 'e'; + packed = *(unsigned char *)&sname[8] == 'p'; +/* Define the number of arguments. */ + if (full) { + nargs = 7; + } else if (packed) { + nargs = 6; + } + + nc = 0; + reset = TRUE_; + errmax = (float)0.; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; +/* Set LDA to 1 more than minimum value if room. */ + lda = n; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L100; + } + if (packed) { + laa = n * (n + 1) / 2; + } else { + laa = lda * n; + } + + for (ic = 1; ic <= 2; ++ic) { + *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1]; + if (*(unsigned char *)uplo == 'U') { + s_copy(cuplo, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cuplo, " CblasLower", (ftnlen)14, (ftnlen)14); + } + upper = *(unsigned char *)uplo == 'U'; + + i__2 = *ninc; + for (ix = 1; ix <= i__2; ++ix) { + incx = inc[ix]; + lx = abs(incx) * n; + +/* Generate the vector X. */ + + transl.r = (float).5, transl.i = (float)0.; + i__3 = abs(incx); + i__4 = n - 1; + cmake_("ge", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &i__3, + &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1, + (ftnlen)1); + if (n > 1) { + i__3 = n / 2; + x[i__3].r = (float)0., x[i__3].i = (float)0.; + i__3 = abs(incx) * (n / 2 - 1) + 1; + xx[i__3].r = (float)0., xx[i__3].i = (float)0.; + } + + i__3 = *nalf; + for (ia = 1; ia <= i__3; ++ia) { + i__4 = ia; + ralpha = alf[i__4].r; + q__1.r = ralpha, q__1.i = (float)0.; + alpha.r = q__1.r, alpha.i = q__1.i; + null = n <= 0 || ralpha == (float)0.; + +/* Generate the matrix A. */ + + transl.r = (float)0., transl.i = (float)0.; + i__4 = n - 1; + i__5 = n - 1; + cmake_(sname + 7, uplo, " ", &n, &n, &a[a_offset], nmax, & + aa[1], &lda, &i__4, &i__5, &reset, &transl, ( + ftnlen)2, (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the subroutine. */ + + *(unsigned char *)uplos = *(unsigned char *)uplo; + ns = n; + rals = ralpha; + i__4 = laa; + for (i__ = 1; i__ <= i__4; ++i__) { + i__5 = i__; + i__6 = i__; + as[i__5].r = aa[i__6].r, as[i__5].i = aa[i__6].i; +/* L10: */ + } + ldas = lda; + i__4 = lx; + for (i__ = 1; i__ <= i__4; ++i__) { + i__5 = i__; + i__6 = i__; + xs[i__5].r = xx[i__6].r, xs[i__5].i = xx[i__6].i; +/* L20: */ + } + incxs = incx; + +/* Call the subroutine. */ + + if (full) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %3d, %4.1f, X, %2d, A, %3d).\n", + nc, sname, cuplo, n, ralpha, incx, lda); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + ccher_(iorder, uplo, &n, &ralpha, &xx[1], &incx, &aa[ + 1], &lda, (ftnlen)1); + } else if (packed) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %3d, %4.1f, X, %2d, AP).\n", + nc, sname, cuplo, n, ralpha, incx); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cchpr_(iorder, uplo, &n, &ralpha, &xx[1], &incx, &aa[ + 1], (ftnlen)1); + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf("******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******\n"); + *fatal = TRUE_; + goto L120; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)uplo == *(unsigned char *) + uplos; + isame[1] = ns == n; + isame[2] = rals == ralpha; + isame[3] = lce_(&xs[1], &xx[1], &lx); + isame[4] = incxs == incx; + if (null) { + isame[5] = lce_(&as[1], &aa[1], &laa); + } else { + isame[5] = lceres_(sname + 7, uplo, &n, &n, &as[1], & + aa[1], &lda, (ftnlen)2, (ftnlen)1); + } + if (! packed) { + isame[6] = ldas == lda; + } + +/* If data was incorrectly changed, report and return. */ + + same = TRUE_; + i__4 = nargs; + for (i__ = 1; i__ <= i__4; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L30: */ + } + if (! same) { + *fatal = TRUE_; + goto L120; + } + + if (! null) { + +/* Check the result column by column. */ + + if (incx > 0) { + i__4 = n; + for (i__ = 1; i__ <= i__4; ++i__) { + i__5 = i__; + i__6 = i__; + z__[i__5].r = x[i__6].r, z__[i__5].i = x[i__6] + .i; +/* L40: */ + } + } else { + i__4 = n; + for (i__ = 1; i__ <= i__4; ++i__) { + i__5 = i__; + i__6 = n - i__ + 1; + z__[i__5].r = x[i__6].r, z__[i__5].i = x[i__6] + .i; +/* L50: */ + } + } + ja = 1; + i__4 = n; + for (j = 1; j <= i__4; ++j) { + r_cnjg(&q__1, &z__[j]); + w[0].r = q__1.r, w[0].i = q__1.i; + if (upper) { + jj = 1; + lj = j; + } else { + jj = j; + lj = n - j + 1; + } + cmvch_("N", &lj, &c__1, &alpha, &z__[jj], &lj, w, + &c__1, &c_b2, &a[jj + j * a_dim1], &c__1, + &yt[1], &g[1], &aa[ja], eps, &err, fatal, + nout, &c_true, (ftnlen)1); + if (full) { + if (upper) { + ja += lda; + } else { + ja = ja + lda + 1; + } + } else { + ja += lj; + } + errmax = dmax(errmax,err); +/* If got really bad answer, report and return. */ + if (*fatal) { + goto L110; + } +/* L60: */ + } + } else { +/* Avoid repeating tests if N.le.0. */ + if (n <= 0) { + goto L100; + } + } + +/* L70: */ + } + +/* L80: */ + } + +/* L90: */ + } + +L100: + ; + } + +/* Report result. */ + + if (errmax < *thresh) { + printf("%12s PASSED THE COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } else { + printf("%12s COMPLETED THE COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + printf("******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",errmax); + } + goto L130; + +L110: + printf(" THESE ARE THE RESULTS FOR COLUMN %3d\n",j); + +L120: + printf("******* %12s FAILED ON CALL NUMBER:\n",sname); + if (full) { + printf("%6d: %12s (%14s, %3d, %4.1f, X, %2d, A, %3d).\n", + nc, sname, cuplo, n, ralpha, incx, lda); + } else if (packed) { + printf("%6d: %12s (%14s, %3d, %4.1f, X, %2d, AP).\n", + nc, sname, cuplo, n, ralpha, incx); + } + +L130: + return 0; + + +/* End of CCHK5. */ + +} /* cchk5_ */ + +/* Subroutine */ int 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, sname_len) +char *sname; +real *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nalf; +complex *alf; +integer *ninc, *inc, *nmax, *incmax; +complex *a, *aa, *as, *x, *xx, *xs, *y, *yy, *ys, *yt; +real *g; +complex *z__; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ich[2+1] = "UL"; + + /* System generated locals */ + integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, + i__6, i__7; + complex q__1, q__2, q__3; + + /* Local variables */ + static integer ldas; + static logical same; + static integer incx, incy; + static logical full, null; + static char uplo[1]; + static integer i__, j, n; + extern /* Subroutine */ int cmake_(); + static complex alpha, w[2]; + static logical isame[13]; + extern /* Subroutine */ int cmvch_(); + static integer nargs; + static logical reset; + static char cuplo[14]; + static integer incxs, incys; + static logical upper; + static char uplos[1]; + extern /* Subroutine */ int ccher2_(), cchpr2_(); + static integer ia, ja, ic, nc, jj, lj, in; + static logical packed; + static integer ix, iy, ns, lx, ly; + extern logical lceres_(); + static real errmax; + static complex transl; + static integer laa, lda; + extern logical lce_(); + static complex als; + static real err; + +/* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --alf; + --inc; + z_dim1 = *nmax; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --g; + --yt; + --y; + --x; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ys; + --yy; + --xs; + --xx; + + /* Function Body */ +/* .. Executable Statements .. */ + full = *(unsigned char *)&sname[8] == 'e'; + packed = *(unsigned char *)&sname[8] == 'p'; +/* Define the number of arguments. */ + if (full) { + nargs = 9; + } else if (packed) { + nargs = 8; + } + + nc = 0; + reset = TRUE_; + errmax = (float)0.; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; +/* Set LDA to 1 more than minimum value if room. */ + lda = n; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L140; + } + if (packed) { + laa = n * (n + 1) / 2; + } else { + laa = lda * n; + } + + for (ic = 1; ic <= 2; ++ic) { + *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1]; + if (*(unsigned char *)uplo == 'U') { + s_copy(cuplo, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cuplo, " CblasLower", (ftnlen)14, (ftnlen)14); + } + upper = *(unsigned char *)uplo == 'U'; + + i__2 = *ninc; + for (ix = 1; ix <= i__2; ++ix) { + incx = inc[ix]; + lx = abs(incx) * n; + +/* Generate the vector X. */ + + transl.r = (float).5, transl.i = (float)0.; + i__3 = abs(incx); + i__4 = n - 1; + cmake_("ge", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &i__3, + &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1, + (ftnlen)1); + if (n > 1) { + i__3 = n / 2; + x[i__3].r = (float)0., x[i__3].i = (float)0.; + i__3 = abs(incx) * (n / 2 - 1) + 1; + xx[i__3].r = (float)0., xx[i__3].i = (float)0.; + } + + i__3 = *ninc; + for (iy = 1; iy <= i__3; ++iy) { + incy = inc[iy]; + ly = abs(incy) * n; + +/* Generate the vector Y. */ + + transl.r = (float)0., transl.i = (float)0.; + i__4 = abs(incy); + i__5 = n - 1; + cmake_("ge", " ", " ", &c__1, &n, &y[1], &c__1, &yy[1], & + i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, ( + ftnlen)1, (ftnlen)1); + if (n > 1) { + i__4 = n / 2; + y[i__4].r = (float)0., y[i__4].i = (float)0.; + i__4 = abs(incy) * (n / 2 - 1) + 1; + yy[i__4].r = (float)0., yy[i__4].i = (float)0.; + } + + i__4 = *nalf; + for (ia = 1; ia <= i__4; ++ia) { + i__5 = ia; + alpha.r = alf[i__5].r, alpha.i = alf[i__5].i; + null = n <= 0 || (alpha.r == (float)0. && alpha.i == (float)0.); + +/* Generate the matrix A. */ + + transl.r = (float)0., transl.i = (float)0.; + i__5 = n - 1; + i__6 = n - 1; + cmake_(sname + 7, uplo, " ", &n, &n, &a[a_offset], + nmax, &aa[1], &lda, &i__5, &i__6, &reset, & + transl, (ftnlen)2, (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the subroutine. */ + + *(unsigned char *)uplos = *(unsigned char *)uplo; + ns = n; + als.r = alpha.r, als.i = alpha.i; + i__5 = laa; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7].i; +/* L10: */ + } + ldas = lda; + i__5 = lx; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + xs[i__6].r = xx[i__7].r, xs[i__6].i = xx[i__7].i; +/* L20: */ + } + incxs = incx; + i__5 = ly; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + ys[i__6].r = yy[i__7].r, ys[i__6].i = yy[i__7].i; +/* L30: */ + } + incys = incy; + +/* Call the subroutine. */ + + if (full) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %3d, (%4.1f,%4.1f), X, %2d, Y, %2d, A, %3d).\n", + nc, sname, cuplo, n, alpha.r,alpha.i, incx, incy, lda); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + ccher2_(iorder, uplo, &n, &alpha, &xx[1], &incx, & + yy[1], &incy, &aa[1], &lda, (ftnlen)1); + } else if (packed) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %3d, (%4.1f,%4.1f), X, %2d, Y, %2d, AP).\n", + nc, sname, cuplo, n, alpha.r,alpha.i, incx, incy; +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cchpr2_(iorder, uplo, &n, &alpha, &xx[1], &incx, & + yy[1], &incy, &aa[1], (ftnlen)1); + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf("******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******\n"); + *fatal = TRUE_; + goto L160; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)uplo == *(unsigned char * + )uplos; + isame[1] = ns == n; + isame[2] = als.r == alpha.r && als.i == alpha.i; + isame[3] = lce_(&xs[1], &xx[1], &lx); + isame[4] = incxs == incx; + isame[5] = lce_(&ys[1], &yy[1], &ly); + isame[6] = incys == incy; + if (null) { + isame[7] = lce_(&as[1], &aa[1], &laa); + } else { + isame[7] = lceres_(sname + 7, uplo, &n, &n, &as[1] + , &aa[1], &lda, (ftnlen)2, (ftnlen)1); + } + if (! packed) { + isame[8] = ldas == lda; + } + +/* If data was incorrectly changed, report and return. */ + + same = TRUE_; + i__5 = nargs; + for (i__ = 1; i__ <= i__5; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L160; + } + + if (! null) { + +/* Check the result column by column. */ + + if (incx > 0) { + i__5 = n; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__ + z_dim1; + i__7 = i__; + z__[i__6].r = x[i__7].r, z__[i__6].i = x[ + i__7].i; +/* L50: */ + } + } else { + i__5 = n; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__ + z_dim1; + i__7 = n - i__ + 1; + z__[i__6].r = x[i__7].r, z__[i__6].i = x[ + i__7].i; +/* L60: */ + } + } + if (incy > 0) { + i__5 = n; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__ + (z_dim1 << 1); + i__7 = i__; + z__[i__6].r = y[i__7].r, z__[i__6].i = y[ + i__7].i; +/* L70: */ + } + } else { + i__5 = n; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__ + (z_dim1 << 1); + i__7 = n - i__ + 1; + z__[i__6].r = y[i__7].r, z__[i__6].i = y[ + i__7].i; +/* L80: */ + } + } + ja = 1; + i__5 = n; + for (j = 1; j <= i__5; ++j) { + r_cnjg(&q__2, &z__[j + (z_dim1 << 1)]); + q__1.r = alpha.r * q__2.r - alpha.i * q__2.i, + q__1.i = alpha.r * q__2.i + alpha.i * + q__2.r; + w[0].r = q__1.r, w[0].i = q__1.i; + r_cnjg(&q__2, &alpha); + r_cnjg(&q__3, &z__[j + z_dim1]); + q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, + q__1.i = q__2.r * q__3.i + q__2.i * + q__3.r; + w[1].r = q__1.r, w[1].i = q__1.i; + if (upper) { + jj = 1; + lj = j; + } else { + jj = j; + lj = n - j + 1; + } + cmvch_("N", &lj, &c__2, &c_b2, &z__[jj + + z_dim1], nmax, w, &c__1, &c_b2, &a[jj + + j * a_dim1], &c__1, &yt[1], &g[1], & + aa[ja], eps, &err, fatal, nout, & + c_true, (ftnlen)1); + if (full) { + if (upper) { + ja += lda; + } else { + ja = ja + lda + 1; + } + } else { + ja += lj; + } + errmax = dmax(errmax,err); +/* If got really bad answer, report and return. */ + if (*fatal) { + goto L150; + } +/* L90: */ + } + } else { +/* Avoid repeating tests with N.le.0. */ + if (n <= 0) { + goto L140; + } + } + +/* L100: */ + } + +/* L110: */ + } + +/* L120: */ + } + +/* L130: */ + } + +L140: + ; + } + +/* Report result. */ + + if (errmax < *thresh) { + printf("%12s PASSED THE COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } else { + printf("%12s COMPLETED THE COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + printf("******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",errmax); + } + goto L170; + +L150: + printf(" THESE ARE THE RESULTS FOR COLUMN %3d\n",j); + +L160: + printf("******* %12s FAILED ON CALL NUMBER:\n",sname); + if (full) { + printf("%6d: %12s (%14s, %3d, (%4.1f,%4.1f), X, %2d, Y, %2d, A, %3d).\n", + nc, sname, cuplo, n, alpha.r,alpha.i, incx, incy,lda); + } else if (packed) { + printf("%6d: %12s (%14s, %3d, (%4.1f,%4.1f), X, %2d, Y, %2d, AP).\n", + nc, sname, cuplo, n, alpha.r,alpha.i, incx, incy); + } + +L170: + return 0; + + +/* End of CCHK6. */ + +} /* cchk6_ */ + +/* Subroutine */ int cmvch_(trans, m, n, alpha, a, nmax, x, incx, beta, y, + incy, yt, g, yy, eps, err, fatal, nout, mv, trans_len) +char *trans; +integer *m, *n; +complex *alpha, *a; +integer *nmax; +complex *x; +integer *incx; +complex *beta, *y; +integer *incy; +complex *yt; +real *g; +complex *yy; +real *eps, *err; +logical *fatal; +integer *nout; +logical *mv; +ftnlen trans_len; +{ + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; + real r__1, r__2, r__3, r__4, r__5, r__6; + complex q__1, q__2, q__3; + + /* Local variables */ + static real erri; + static logical tran; + static integer i__, j; + static logical ctran; + static integer incxl, incyl, ml, nl, iy, jx, kx, ky; + +/* Checks the results of the computational tests. */ + +/* Auxiliary routine for test program for Level 2 Blas. */ + +/* -- Written on 10-August-1987. */ +/* Richard Hanson, Sandia National Labs. */ +/* Jeremy Du Croz, NAG Central Office. */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Intrinsic Functions .. */ +/* .. Statement Functions .. */ +/* .. Statement Function definitions .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --x; + --y; + --yt; + --g; + --yy; + + /* Function Body */ + tran = *(unsigned char *)trans == 'T'; + ctran = *(unsigned char *)trans == 'C'; + if (tran || ctran) { + ml = *n; + nl = *m; + } else { + ml = *m; + nl = *n; + } + if (*incx < 0) { + kx = nl; + incxl = -1; + } else { + kx = 1; + incxl = 1; + } + if (*incy < 0) { + ky = ml; + incyl = -1; + } else { + ky = 1; + incyl = 1; + } + +/* Compute expected result in YT using data in A, X and Y. */ +/* Compute gauges in G. */ + + iy = ky; + i__1 = ml; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + yt[i__2].r = (float)0., yt[i__2].i = (float)0.; + g[iy] = (float)0.; + jx = kx; + if (tran) { + i__2 = nl; + for (j = 1; j <= i__2; ++j) { + i__3 = iy; + i__4 = iy; + i__5 = j + i__ * a_dim1; + i__6 = jx; + q__2.r = a[i__5].r * x[i__6].r - a[i__5].i * x[i__6].i, + q__2.i = a[i__5].r * x[i__6].i + a[i__5].i * x[i__6] + .r; + q__1.r = yt[i__4].r + q__2.r, q__1.i = yt[i__4].i + q__2.i; + yt[i__3].r = q__1.r, yt[i__3].i = q__1.i; + i__3 = j + i__ * a_dim1; + i__4 = jx; + g[iy] += ((r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[ + j + i__ * a_dim1]), dabs(r__2))) * ((r__3 = x[i__4].r, + dabs(r__3)) + (r__4 = r_imag(&x[jx]), dabs(r__4))); + jx += incxl; +/* L10: */ + } + } else if (ctran) { + i__2 = nl; + for (j = 1; j <= i__2; ++j) { + i__3 = iy; + i__4 = iy; + r_cnjg(&q__3, &a[j + i__ * a_dim1]); + i__5 = jx; + q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i, q__2.i = + q__3.r * x[i__5].i + q__3.i * x[i__5].r; + q__1.r = yt[i__4].r + q__2.r, q__1.i = yt[i__4].i + q__2.i; + yt[i__3].r = q__1.r, yt[i__3].i = q__1.i; + i__3 = j + i__ * a_dim1; + i__4 = jx; + g[iy] += ((r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[ + j + i__ * a_dim1]), dabs(r__2))) * ((r__3 = x[i__4].r, + dabs(r__3)) + (r__4 = r_imag(&x[jx]), dabs(r__4))); + jx += incxl; +/* L20: */ + } + } else { + i__2 = nl; + for (j = 1; j <= i__2; ++j) { + i__3 = iy; + i__4 = iy; + i__5 = i__ + j * a_dim1; + i__6 = jx; + q__2.r = a[i__5].r * x[i__6].r - a[i__5].i * x[i__6].i, + q__2.i = a[i__5].r * x[i__6].i + a[i__5].i * x[i__6] + .r; + q__1.r = yt[i__4].r + q__2.r, q__1.i = yt[i__4].i + q__2.i; + yt[i__3].r = q__1.r, yt[i__3].i = q__1.i; + i__3 = i__ + j * a_dim1; + i__4 = jx; + g[iy] += ((r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[ + i__ + j * a_dim1]), dabs(r__2))) * ((r__3 = x[i__4].r, + dabs(r__3)) + (r__4 = r_imag(&x[jx]), dabs(r__4))); + jx += incxl; +/* L30: */ + } + } + i__2 = iy; + i__3 = iy; + q__2.r = alpha->r * yt[i__3].r - alpha->i * yt[i__3].i, q__2.i = + alpha->r * yt[i__3].i + alpha->i * yt[i__3].r; + i__4 = iy; + q__3.r = beta->r * y[i__4].r - beta->i * y[i__4].i, q__3.i = beta->r * + y[i__4].i + beta->i * y[i__4].r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + yt[i__2].r = q__1.r, yt[i__2].i = q__1.i; + i__2 = iy; + g[iy] = ((r__1 = alpha->r, dabs(r__1)) + (r__2 = r_imag(alpha), dabs( + r__2))) * g[iy] + ((r__3 = beta->r, dabs(r__3)) + (r__4 = + r_imag(beta), dabs(r__4))) * ((r__5 = y[i__2].r, dabs(r__5)) + + (r__6 = r_imag(&y[iy]), dabs(r__6))); + iy += incyl; +/* L40: */ + } + +/* Compute the error ratio for this result. */ + + *err = (float)0.; + i__1 = ml; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = (i__ - 1) * abs(*incy) + 1; + q__1.r = yt[i__2].r - yy[i__3].r, q__1.i = yt[i__2].i - yy[i__3].i; + erri = c_abs(&q__1) / *eps; + if (g[i__] != (float)0.) { + erri /= g[i__]; + } + *err = dmax(*err,erri); + if (*err * sqrt(*eps) >= (float)1.) { + goto L60; + } +/* L50: */ + } +/* If the loop completes, all results are at least half accurate. */ + goto L80; + +/* Report fatal error. */ + +L60: + *fatal = TRUE_; + printf(" ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HALF ACCURATE *******\n EXPECTED RESULT COMPUTED RESULT\n"); + i__1 = ml; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*mv) { + printf("%7d (%15.6g,%15.6g) (%15.6g,%15.6g)\n",i__,yt[i__].r,yt[i__].i, yy[(i__ - 1) * abs(*incy) + 1].r, yy[(i__ - 1) * abs(*incy) + 1].i); + } else { + printf("%7d (%15.6g,%15.6g) (%15.6g,%15.6g),\n",i__, yy[(i__ - 1) * abs(*incy) + 1].r, yy[(i__ - 1) * abs(*incy) + 1].i, yt[i__].r,yt[i__].i); + } +/* L70: */ + } + +L80: + return 0; + + +/* End of CMVCH. */ + +} /* cmvch_ */ + +logical lce_(ri, rj, lr) +complex *ri, *rj; +integer *lr; +{ + /* System generated locals */ + integer i__1, i__2, i__3; + logical ret_val; + + /* Local variables */ + static integer i__; + + +/* Tests if two arrays are identical. */ + +/* Auxiliary routine for test program for Level 2 Blas. */ + +/* -- Written on 10-August-1987. */ +/* Richard Hanson, Sandia National Labs. */ +/* Jeremy Du Croz, NAG Central Office. */ + +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + --rj; + --ri; + + /* Function Body */ + i__1 = *lr; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + if (ri[i__2].r != rj[i__3].r || ri[i__2].i != rj[i__3].i) { + goto L20; + } +/* L10: */ + } + ret_val = TRUE_; + goto L30; +L20: + ret_val = FALSE_; +L30: + return ret_val; + +/* End of LCE. */ + +} /* lce_ */ + +logical lceres_(type__, uplo, m, n, aa, as, lda, type_len, uplo_len) +char *type__, *uplo; +integer *m, *n; +complex *aa, *as; +integer *lda; +ftnlen type_len; +ftnlen uplo_len; +{ + /* System generated locals */ + integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2, i__3, i__4; + logical ret_val; + + /* Local variables */ + static integer ibeg, iend, i__, j; + static logical upper; + + +/* Tests if selected elements in two arrays are equal. */ + +/* TYPE is 'ge', '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 .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + as_dim1 = *lda; + as_offset = 1 + as_dim1 * 1; + as -= as_offset; + aa_dim1 = *lda; + aa_offset = 1 + aa_dim1 * 1; + aa -= aa_offset; + + /* Function Body */ + upper = *(unsigned char *)uplo == 'U'; + if (s_cmp(type__, "ge", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *lda; + for (i__ = *m + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * aa_dim1; + i__4 = i__ + j * as_dim1; + if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) { + goto L70; + } +/* L10: */ + } +/* L20: */ + } + } else if (s_cmp(type__, "he", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (upper) { + ibeg = 1; + iend = j; + } else { + ibeg = j; + iend = *n; + } + i__2 = ibeg - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * aa_dim1; + i__4 = i__ + j * as_dim1; + if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) { + goto L70; + } +/* L30: */ + } + i__2 = *lda; + for (i__ = iend + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * aa_dim1; + i__4 = i__ + j * as_dim1; + if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) { + goto L70; + } +/* L40: */ + } +/* L50: */ + } + } + +/* 60 CONTINUE */ + ret_val = TRUE_; + goto L80; +L70: + ret_val = FALSE_; +L80: + return ret_val; + +/* End of LCERES. */ + +} /* lceres_ */ + +/* Complex */ VOID cbeg_( ret_val, reset) +complex * ret_val; +logical *reset; +{ + /* System generated locals */ + real r__1, r__2; + complex q__1; + + /* Local variables */ + static integer i__, j, ic, mi, mj; + + +/* Generates complex numbers as pairs of random numbers uniformly */ +/* distributed between -0.5 and 0.5. */ + +/* Auxiliary routine for test program for Level 2 Blas. */ + +/* -- Written on 10-August-1987. */ +/* Richard Hanson, Sandia National Labs. */ +/* Jeremy Du Croz, NAG Central Office. */ + +/* .. Scalar Arguments .. */ +/* .. Local Scalars .. */ +/* .. Save statement .. */ +/* .. Intrinsic Functions .. */ +/* .. Executable Statements .. */ + if (*reset) { +/* Initialize local variables. */ + mi = 891; + mj = 457; + i__ = 7; + j = 7; + ic = 0; + *reset = FALSE_; + } + +/* The sequence of values of I or J is bounded between 1 and 999. */ +/* If initial I or J = 1,2,3,6,7 or 9, the period will be 50. */ +/* If initial I or J = 4 or 8, the period will be 25. */ +/* If initial I or J = 5, the period will be 10. */ +/* IC is used to break up the period by skipping 1 value of I or J */ +/* in 6. */ + + ++ic; +L10: + i__ *= mi; + j *= mj; + i__ -= i__ / 1000 * 1000; + j -= j / 1000 * 1000; + if (ic >= 5) { + ic = 0; + goto L10; + } + r__1 = (i__ - 500) / (float)1001.; + r__2 = (j - 500) / (float)1001.; + q__1.r = r__1, q__1.i = r__2; + ret_val->r = q__1.r, ret_val->i = q__1.i; + return ; + +/* End of CBEG. */ + +} /* cbeg_ */ + +doublereal sdiff_(x, y) +real *x, *y; +{ + /* System generated locals */ + real ret_val; + + +/* Auxiliary routine for test program for Level 2 Blas. */ + +/* -- Written on 10-August-1987. */ +/* Richard Hanson, Sandia National Labs. */ + +/* .. Scalar Arguments .. */ +/* .. Executable Statements .. */ + ret_val = *x - *y; + return ret_val; + +/* End of SDIFF. */ + +} /* sdiff_ */ + +/* Subroutine */ int cmake_(type__, uplo, diag, m, n, a, nmax, aa, lda, kl, + ku, reset, transl, type_len, uplo_len, diag_len) +char *type__, *uplo, *diag; +integer *m, *n; +complex *a; +integer *nmax; +complex *aa; +integer *lda, *kl, *ku; +logical *reset; +complex *transl; +ftnlen type_len; +ftnlen uplo_len; +ftnlen diag_len; +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + real r__1; + complex q__1, q__2; + + /* Local variables */ + extern /* Complex */ VOID cbeg_(); + static integer ibeg, iend, ioff; + static logical unit; + static integer i__, j; + static logical lower; + static integer i1, i2, i3; + static logical upper; + static integer jj, kk; + static logical gen, tri, sym; + + +/* Generates values for an M by N matrix A within the bandwidth */ +/* defined by KL and KU. */ +/* Stores the values in the array AA in the data structure required */ +/* by the routine, with unwanted elements set to rogue value. */ + +/* TYPE is 'ge', 'gb', 'he', 'hb', 'hp', 'tr', 'tb' OR 'tp'. */ + +/* Auxiliary routine for test program for Level 2 Blas. */ + +/* -- Written on 10-August-1987. */ +/* Richard Hanson, Sandia National Labs. */ +/* Jeremy Du Croz, NAG Central Office. */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. External Functions .. */ +/* .. Intrinsic Functions .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --aa; + + /* Function Body */ + gen = *(unsigned char *)type__ == 'g'; + sym = *(unsigned char *)type__ == 'h'; + tri = *(unsigned char *)type__ == 't'; + upper = (sym || tri) && *(unsigned char *)uplo == 'U'; + lower = (sym || tri) && *(unsigned char *)uplo == 'L'; + unit = tri && *(unsigned char *)diag == 'U'; + +/* Generate data in array A. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + if (gen || (upper && i__ <= j) || (lower && i__ >= j)) { + if ((i__ <= j) && ((j - i__ <= *ku) || (i__ >= j && i__ - j <= *kl))) + { + i__3 = i__ + j * a_dim1; + cbeg_(&q__2, reset); + q__1.r = q__2.r + transl->r, q__1.i = q__2.i + transl->i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } else { + i__3 = i__ + j * a_dim1; + a[i__3].r = (float)0., a[i__3].i = (float)0.; + } + if (i__ != j) { + if (sym) { + i__3 = j + i__ * a_dim1; + r_cnjg(&q__1, &a[i__ + j * a_dim1]); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } else if (tri) { + i__3 = j + i__ * a_dim1; + a[i__3].r = (float)0., a[i__3].i = (float)0.; + } + } + } +/* L10: */ + } + if (sym) { + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + r__1 = a[i__3].r; + q__1.r = r__1, q__1.i = (float)0.; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + } + if (tri) { + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + q__1.r = a[i__3].r + (float)1., q__1.i = a[i__3].i + (float)0.; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + } + if (unit) { + i__2 = j + j * a_dim1; + a[i__2].r = (float)1., a[i__2].i = (float)0.; + } +/* L20: */ + } + +/* Store elements in array AS in data structure required by routine. */ + + if (s_cmp(type__, "ge", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (j - 1) * *lda; + i__4 = i__ + j * a_dim1; + aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i; +/* L30: */ + } + i__2 = *lda; + for (i__ = *m + 1; i__ <= i__2; ++i__) { + i__3 = i__ + (j - 1) * *lda; + aa[i__3].r = (float)-1e10, aa[i__3].i = (float)1e10; +/* L40: */ + } +/* L50: */ + } + } else if (s_cmp(type__, "gb", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *ku + 1 - j; + for (i1 = 1; i1 <= i__2; ++i1) { + i__3 = i1 + (j - 1) * *lda; + aa[i__3].r = (float)-1e10, aa[i__3].i = (float)1e10; +/* L60: */ + } +/* Computing MIN */ + i__3 = *kl + *ku + 1, i__4 = *ku + 1 + *m - j; + i__2 = f2cmin(i__3,i__4); + for (i2 = i1; i2 <= i__2; ++i2) { + i__3 = i2 + (j - 1) * *lda; + i__4 = i2 + j - *ku - 1 + j * a_dim1; + aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i; +/* L70: */ + } + i__2 = *lda; + for (i3 = i2; i3 <= i__2; ++i3) { + i__3 = i3 + (j - 1) * *lda; + aa[i__3].r = (float)-1e10, aa[i__3].i = (float)1e10; +/* L80: */ + } +/* L90: */ + } + } else if (s_cmp(type__, "he", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__, + "tr", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (upper) { + ibeg = 1; + if (unit) { + iend = j - 1; + } else { + iend = j; + } + } else { + if (unit) { + ibeg = j + 1; + } else { + ibeg = j; + } + iend = *n; + } + i__2 = ibeg - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (j - 1) * *lda; + aa[i__3].r = (float)-1e10, aa[i__3].i = (float)1e10; +/* L100: */ + } + i__2 = iend; + for (i__ = ibeg; i__ <= i__2; ++i__) { + i__3 = i__ + (j - 1) * *lda; + i__4 = i__ + j * a_dim1; + aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i; +/* L110: */ + } + i__2 = *lda; + for (i__ = iend + 1; i__ <= i__2; ++i__) { + i__3 = i__ + (j - 1) * *lda; + aa[i__3].r = (float)-1e10, aa[i__3].i = (float)1e10; +/* L120: */ + } + if (sym) { + jj = j + (j - 1) * *lda; + i__2 = jj; + i__3 = jj; + r__1 = aa[i__3].r; + q__1.r = r__1, q__1.i = (float)-1e10; + aa[i__2].r = q__1.r, aa[i__2].i = q__1.i; + } +/* L130: */ + } + } else if (s_cmp(type__, "hb", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__, + "tb", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (upper) { + kk = *kl + 1; +/* Computing MAX */ + i__2 = 1, i__3 = *kl + 2 - j; + ibeg = f2cmax(i__2,i__3); + if (unit) { + iend = *kl; + } else { + iend = *kl + 1; + } + } else { + kk = 1; + if (unit) { + ibeg = 2; + } else { + ibeg = 1; + } +/* Computing MIN */ + i__2 = *kl + 1, i__3 = *m + 1 - j; + iend = f2cmin(i__2,i__3); + } + i__2 = ibeg - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (j - 1) * *lda; + aa[i__3].r = (float)-1e10, aa[i__3].i = (float)1e10; +/* L140: */ + } + i__2 = iend; + for (i__ = ibeg; i__ <= i__2; ++i__) { + i__3 = i__ + (j - 1) * *lda; + i__4 = i__ + j - kk + j * a_dim1; + aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i; +/* L150: */ + } + i__2 = *lda; + for (i__ = iend + 1; i__ <= i__2; ++i__) { + i__3 = i__ + (j - 1) * *lda; + aa[i__3].r = (float)-1e10, aa[i__3].i = (float)1e10; +/* L160: */ + } + if (sym) { + jj = kk + (j - 1) * *lda; + i__2 = jj; + i__3 = jj; + r__1 = aa[i__3].r; + q__1.r = r__1, q__1.i = (float)-1e10; + aa[i__2].r = q__1.r, aa[i__2].i = q__1.i; + } +/* L170: */ + } + } else if (s_cmp(type__, "hp", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__, + "tp", (ftnlen)2, (ftnlen)2) == 0) { + ioff = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (upper) { + ibeg = 1; + iend = j; + } else { + ibeg = j; + iend = *n; + } + i__2 = iend; + for (i__ = ibeg; i__ <= i__2; ++i__) { + ++ioff; + i__3 = ioff; + i__4 = i__ + j * a_dim1; + aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i; + if (i__ == j) { + if (unit) { + i__3 = ioff; + aa[i__3].r = (float)-1e10, aa[i__3].i = (float)1e10; + } + if (sym) { + i__3 = ioff; + i__4 = ioff; + r__1 = aa[i__4].r; + q__1.r = r__1, q__1.i = (float)-1e10; + aa[i__3].r = q__1.r, aa[i__3].i = q__1.i; + } + } +/* L180: */ + } +/* L190: */ + } + } + return 0; + +/* End of CMAKE. */ + +} /* cmake_ */ + diff --git a/ctest/c_cblat3c.c b/ctest/c_cblat3c.c new file mode 100644 index 000000000..4bee17d7e --- /dev/null +++ b/ctest/c_cblat3c.c @@ -0,0 +1,4187 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif +#if 0 +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +#endif +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i= 0; + if (trace) { +/* o__1.oerr = 0; + o__1.ounit = ntra; + o__1.ofnmlen = 32; + o__1.ofnm = snaps; + o__1.orl = 0; + o__1.osta = 0; + o__1.oacc = 0; + o__1.ofm = 0; + o__1.oblnk = 0; + f_open(&o__1);*/ + } +/* Read the flag that directs rewinding of the snapshot file. */ + fgets(line,80,stdin); + sscanf(line,"%d",&rewi); + rewi = rewi && trace; +/* Read the flag that directs stopping on any failure. */ + fgets(line,80,stdin); + sscanf(line,"%c",&tmpchar); + sfatal=FALSE_; + if (tmpchar=='T')sfatal=TRUE_; + fgets(line,80,stdin); + sscanf(line,"%c",&tmpchar); + tsterr=FALSE_; + if (tmpchar=='T')tsterr=TRUE_; + fgets(line,80,stdin); + sscanf(line,"%d",&layout); + fgets(line,80,stdin); + sscanf(line,"%f",&thresh); + + +/* Read and check the parameter values for the tests. */ + +/* Values of N */ + fgets(line,80,stdin); + sscanf(line,"%d",&nidim); + + if (nidim < 1 || nidim > 9) { + fprintf(stderr,"NUMBER OF VALUES OF N IS LESS THAN 1 OR GREATER THAN 9"); + goto L220; + } + fgets(line,80,stdin); + sscanf(line,"%d %d %d %d %d %d %d %d %d",&idim[0],&idim[1],&idim[2], + &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]); + i__1 = nidim; + for (i__ = 1; i__ <= i__1; ++i__) { + if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) { + fprintf(stderr,"VALUE OF N IS LESS THAN 0 OR GREATER THAN 65\n"); + goto L220; + } +/* L10: */ + } +/* Values of ALPHA */ + fgets(line,80,stdin); + sscanf(line,"%d",&nalf); + if (nalf < 1 || nalf > 7) { + fprintf(stderr,"VALUE OF ALPHA IS LESS THAN 0 OR GREATER THAN 7\n"); + goto L220; + } + fgets(line,80,stdin); + sscanf(line,"(%f,%f) (%f,%f) (%f,%f) (%f,%f) (%f,%f) (%f,%f) (%f,%f)",&alf[0].r,&alf[0].i,&alf[1].r,&alf[1].i,&alf[2].r,&alf[2].i,&alf[3].r,&alf[3].i, + &alf[4].r,&alf[4].i,&alf[5].r,&alf[5].i,&alf[6].r,&alf[6].i); + +// i__1 = nalf; +// for (i__ = 1; i__ <= i__1; ++i__) { +// do_lio(&c__6, &c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(complex)); +// } +/* Values of BETA */ + fgets(line,80,stdin); + sscanf(line,"%d",&nbet); + if (nalf < 1 || nbet > 7) { + fprintf(stderr,"VALUE OF BETA IS LESS THAN 0 OR GREATER THAN 7\n"); + goto L220; + } + fgets(line,80,stdin); + sscanf(line,"(%f,%f) (%f,%f) (%f,%f) (%f,%f) (%f,%f) (%f,%f) (%f,%f)",&bet[0].r,&bet[0].i,&bet[1].r,&bet[1].i,&bet[2].r,&bet[2].i,&bet[3].r,&bet[3].i, + &bet[4].r,&bet[4].i,&bet[5].r,&bet[5].i,&bet[6].r,&bet[6].i); + + +/* Report values of parameters. */ + + printf("TESTS OF THE COMPLEX LEVEL 3 BLAS\nTHE FOLLOWING PARAMETER VALUES WILL BE USED:\n"); + printf(" FOR N"); + for (i__ =1; i__ <=nidim;++i__) printf(" %d",idim[i__-1]); + printf("\n"); + printf(" FOR ALPHA"); + for (i__ =1; i__ <=nalf;++i__) printf(" (%f,%f)",alf[i__-1].r,alf[i__-1].i); + printf("\n"); + printf(" FOR BETA"); + for (i__ =1; i__ <=nbet;++i__) printf(" (%f,%f)",bet[i__-1].r,bet[i__-1].i); + printf("\n"); + + if (! tsterr) { + printf(" ERROR-EXITS WILL NOT BE TESTED\n"); + } + printf("ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LESS THAN %f\n",thresh); + rorder = FALSE_; + corder = FALSE_; + if (layout == 2) { + rorder = TRUE_; + corder = TRUE_; + printf("COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED\n"); + } else if (layout == 1) { + rorder = TRUE_; + printf("ROW-MAJOR DATA LAYOUT IS TESTED\n"); + } else if (layout == 0) { + corder = TRUE_; + printf("COLUMN-MAJOR DATA LAYOUT IS TESTED\n"); + } + +/* Read names of subroutines and flags which indicate */ +/* whether they are to be tested. */ + + for (i__ = 1; i__ <= 9; ++i__) { + ltest[i__ - 1] = FALSE_; +/* L20: */ + } +L30: + if (! fgets(line,80,stdin)) { + goto L60; + } + i__1 = sscanf(line,"%12c %c",snamet,&tmpchar); + ltestt=FALSE_; + if (tmpchar=='T')ltestt=TRUE_; + if (i__1 < 2) { + goto L60; + } + for (i__ = 1; i__ <= 9; ++i__) { + if (s_cmp(snamet, snames[i__ - 1] , (ftnlen)12, (ftnlen)12) == + 0) { + goto L50; + } +/* L40: */ + } + printf("SUBPROGRAM NAME %s NOT RECOGNIZED\n****** TESTS ABANDONED ******\n",snamet); + exit(1); +L50: + ltest[i__ - 1] = ltestt; + goto L30; + +L60: +/* cl__1.cerr = 0; + cl__1.cunit = 5; + cl__1.csta = 0; + f_clos(&cl__1);*/ + +/* Compute EPS (the machine precision). */ + + eps = 1.f; +L70: + r__1 = eps + 1.f; + if (sdiff_(&r__1, &c_b91) == 0.f) { + goto L80; + } + eps *= .5f; + goto L70; +L80: + eps += eps; + printf("RELATIVE MACHINE PRECISION IS TAKEN TO BE %9.1g\n",eps); + +/* Check the reliability of CMMCH using exact data. */ + + n = 32; + i__1 = n; + for (j = 1; j <= i__1; ++j) { + i__2 = n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * 65 - 66; +/* Computing MAX */ + i__5 = i__ - j + 1; + i__4 = f2cmax(i__5,0); + ab[i__3].r = (real) i__4, ab[i__3].i = 0.f; +/* L90: */ + } + i__2 = j + 4224; + ab[i__2].r = (real) j, ab[i__2].i = 0.f; + i__2 = (j + 65) * 65 - 65; + ab[i__2].r = (real) j, ab[i__2].i = 0.f; + i__2 = j - 1; + c__[i__2].r = 0.f, c__[i__2].i = 0.f; +/* L100: */ + } + i__1 = n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + i__3 = j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3; + cc[i__2].r = (real) i__3, cc[i__2].i = 0.f; +/* L110: */ + } +/* CC holds the exact result. On exit from CMMCH CT holds */ +/* the result computed by CMMCH. */ + *(unsigned char *)transa = 'N'; + *(unsigned char *)transb = 'N'; + cmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], & + c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal, + &c__6, &c_true); + same = lce_(cc, ct, &n); + if (! same || err != 0.f) { + printf("ERROR IN CMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); + printf("CMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); + printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); + printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); + printf("****** TESTS ABANDONED ******\n"); + exit(1); + } + *(unsigned char *)transb = 'C'; + cmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], & + c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal, + &c__6, &c_true); + same = lce_(cc, ct, &n); + if (! same || err != 0.f) { + printf("ERROR IN CMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); + printf("CMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); + printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); + printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); + printf("****** TESTS ABANDONED ******\n"); + exit(1); + } + i__1 = n; + for (j = 1; j <= i__1; ++j) { + i__2 = j + 4224; + i__3 = n - j + 1; + ab[i__2].r = (real) i__3, ab[i__2].i = 0.f; + i__2 = (j + 65) * 65 - 65; + i__3 = n - j + 1; + ab[i__2].r = (real) i__3, ab[i__2].i = 0.f; +/* L120: */ + } + i__1 = n; + for (j = 1; j <= i__1; ++j) { + i__2 = n - j; + i__3 = j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3; + cc[i__2].r = (real) i__3, cc[i__2].i = 0.f; +/* L130: */ + } + *(unsigned char *)transa = 'C'; + *(unsigned char *)transb = 'N'; + cmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], & + c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal, + &c__6, &c_true); + same = lce_(cc, ct, &n); + if (! same || err != 0.f) { + printf("ERROR IN CMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); + printf("CMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); + printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); + printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); + printf("****** TESTS ABANDONED ******\n"); + exit(1); + } + *(unsigned char *)transb = 'C'; + cmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], & + c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal, + &c__6, &c_true); + same = lce_(cc, ct, &n); + if (! same || err != 0.f) { + printf("ERROR IN CMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); + printf("CMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); + printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); + printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); + printf("****** TESTS ABANDONED ******\n"); + exit(1); + } + +/* Test each subroutine in turn. */ + + for (isnum = 1; isnum <= 9; ++isnum) { + if (! ltest[isnum - 1]) { +/* Subprogram is not to be tested. */ + printf("%12s WAS NOT TESTED\n",snames[isnum-1]); + } else { + s_copy(srnamc_1.srnamt, snames[isnum - 1], (ftnlen)12, ( + ftnlen)12); +/* Test error exits. */ + if (tsterr) { + cc3chke_(snames[isnum - 1]); + } +/* Test computations. */ + infoc_1.infot = 0; + infoc_1.ok = TRUE_; + fatal = FALSE_; + switch (isnum) { + case 1: goto L140; + case 2: goto L150; + case 3: goto L150; + case 4: goto L160; + case 5: goto L160; + case 6: goto L170; + case 7: goto L170; + case 8: goto L180; + case 9: goto L180; + } +/* Test CGEMM, 01. */ +L140: + if (corder) { + cchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__0); + } + if (rorder) { + cchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__1); + } + goto L190; +/* Test CHEMM, 02, CSYMM, 03. */ +L150: + if (corder) { + cchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__0); + } + if (rorder) { + cchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__1); + } + goto L190; +/* Test CTRMM, 04, CTRSM, 05. */ +L160: + if (corder) { + cchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, & + c__0); + } + if (rorder) { + cchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, & + c__1); + } + goto L190; +/* Test CHERK, 06, CSYRK, 07. */ +L170: + if (corder) { + cchk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__0); + } + if (rorder) { + cchk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__1); + } + goto L190; +/* Test CHER2K, 08, CSYR2K, 09. */ +L180: + if (corder) { + cchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, + ct, g, w, &c__0); + } + if (rorder) { + cchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, + ct, g, w, &c__1); + } + goto L190; + +L190: + if (fatal && sfatal) { + goto L210; + } + } +/* L200: */ + } + printf("\nEND OF TESTS\n"); + goto L230; + +L210: + printf("\n****** FATAL ERROR - TESTS ABANDONED ******\n"); + goto L230; + +L220: + printf("AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM\n"); + printf("****** TESTS ABANDONED ******\n"); +L230: + if (trace) { +/* cl__1.cerr = 0; + cl__1.cunit = ntra; + cl__1.csta = 0; + f_clos(&cl__1);*/ + } +/* cl__1.cerr = 0; + cl__1.cunit = 6; + cl__1.csta = 0; + f_clos(&cl__1); + s_stop("", (ftnlen)0);*/ + exit(0); + +/* End of CBLAT3. */ + + return 0; +} /* MAIN__ */ + +/* Subroutine */ int cchk1_(char *sname, real *eps, real *thresh, integer * + nout, integer *ntra, logical *trace, logical *rewi, logical *fatal, + integer *nidim, integer *idim, integer *nalf, complex *alf, integer * + nbet, complex *bet, integer *nmax, complex *a, complex *aa, complex * + as, complex *b, complex *bb, complex *bs, complex *c__, complex *cc, + complex *cs, complex *ct, real *g, integer *iorder) +{ + /* Initialized data */ + + static char ich[3] = "NTC"; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5, i__6, i__7, i__8; + + /* Local variables */ + complex beta; + integer ldas, ldbs, ldcs; + logical same, null; + integer i__, k, m, n; + extern /* Subroutine */ int cmake_(char *, char *, char *, integer *, + integer *, complex *, integer *, complex *, integer *, logical *, + complex *); + complex alpha; + extern /* Subroutine */ int cmmch_(char *, char *, integer *, integer *, + integer *, complex *, complex *, integer *, complex *, integer *, + complex *, complex *, integer *, complex *, real *, complex *, + integer *, real *, real *, logical *, integer *, logical *); + logical isame[13], trana, tranb; + integer nargs; + logical reset; + extern /* Subroutine */ int cprcn1_(integer *, integer *, char *, integer + *, char *, char *, integer *, integer *, integer *, complex *, + integer *, integer *, complex *, integer *); + integer ia, ib, ma, mb, na, nb, nc, ik, im, in; + extern /* Subroutine */ int ccgemm_(integer *, char *, char *, integer *, + integer *, integer *, complex *, complex *, integer *, complex *, + integer *, complex *, complex *, integer *); + integer ks, ms, ns; + extern logical lceres_(char *, char *, integer *, integer *, complex *, + complex *, integer *); + char tranas[1], tranbs[1], transa[1], transb[1]; + real errmax; + integer ica, icb, laa, lbb, lda, lcc, ldb, ldc; + extern logical lce_(complex *, complex *, integer *); + complex als, bls; + real err; + +/* Tests CGEMM. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + /* Parameter adjustments */ + --idim; + --alf; + --bet; + --g; + --ct; + --cs; + --cc; + c_dim1 = *nmax; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --bs; + --bb; + b_dim1 = *nmax; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + + nargs = 13; + nc = 0; + reset = TRUE_; + errmax = 0.f; + + i__1 = *nidim; + for (im = 1; im <= i__1; ++im) { + m = idim[im]; + + i__2 = *nidim; + for (in = 1; in <= i__2; ++in) { + n = idim[in]; +/* Set LDC to 1 more than minimum value if room. */ + ldc = m; + if (ldc < *nmax) { + ++ldc; + } +/* Skip tests if not enough room. */ + if (ldc > *nmax) { + goto L100; + } + lcc = ldc * n; + null = n <= 0 || m <= 0; + + i__3 = *nidim; + for (ik = 1; ik <= i__3; ++ik) { + k = idim[ik]; + + for (ica = 1; ica <= 3; ++ica) { + *(unsigned char *)transa = *(unsigned char *)&ich[ica - 1] + ; + trana = *(unsigned char *)transa == 'T' || *(unsigned + char *)transa == 'C'; + + if (trana) { + ma = k; + na = m; + } else { + ma = m; + na = k; + } +/* Set LDA to 1 more than minimum value if room. */ + lda = ma; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L80; + } + laa = lda * na; + +/* Generate the matrix A. */ + + cmake_("ge", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[ + 1], &lda, &reset, &c_b1); + + for (icb = 1; icb <= 3; ++icb) { + *(unsigned char *)transb = *(unsigned char *)&ich[icb + - 1]; + tranb = *(unsigned char *)transb == 'T' || *(unsigned + char *)transb == 'C'; + + if (tranb) { + mb = n; + nb = k; + } else { + mb = k; + nb = n; + } +/* Set LDB to 1 more than minimum value if room. */ + ldb = mb; + if (ldb < *nmax) { + ++ldb; + } +/* Skip tests if not enough room. */ + if (ldb > *nmax) { + goto L70; + } + lbb = ldb * nb; + +/* Generate the matrix B. */ + + cmake_("ge", " ", " ", &mb, &nb, &b[b_offset], nmax, & + bb[1], &ldb, &reset, &c_b1); + + i__4 = *nalf; + for (ia = 1; ia <= i__4; ++ia) { + i__5 = ia; + alpha.r = alf[i__5].r, alpha.i = alf[i__5].i; + + i__5 = *nbet; + for (ib = 1; ib <= i__5; ++ib) { + i__6 = ib; + beta.r = bet[i__6].r, beta.i = bet[i__6].i; + +/* Generate the matrix C. */ + + cmake_("ge", " ", " ", &m, &n, &c__[c_offset], + nmax, &cc[1], &ldc, &reset, &c_b1); + + ++nc; + +/* Save every datum before calling the */ +/* subroutine. */ + + *(unsigned char *)tranas = *(unsigned char *) + transa; + *(unsigned char *)tranbs = *(unsigned char *) + transb; + ms = m; + ns = n; + ks = k; + als.r = alpha.r, als.i = alpha.i; + i__6 = laa; + for (i__ = 1; i__ <= i__6; ++i__) { + i__7 = i__; + i__8 = i__; + as[i__7].r = aa[i__8].r, as[i__7].i = aa[ + i__8].i; +/* L10: */ + } + ldas = lda; + i__6 = lbb; + for (i__ = 1; i__ <= i__6; ++i__) { + i__7 = i__; + i__8 = i__; + bs[i__7].r = bb[i__8].r, bs[i__7].i = bb[ + i__8].i; +/* L20: */ + } + ldbs = ldb; + bls.r = beta.r, bls.i = beta.i; + i__6 = lcc; + for (i__ = 1; i__ <= i__6; ++i__) { + i__7 = i__; + i__8 = i__; + cs[i__7].r = cc[i__8].r, cs[i__7].i = cc[ + i__8].i; +/* L30: */ + } + ldcs = ldc; + +/* Call the subroutine. */ + + if (*trace) { + cprcn1_(ntra, &nc, sname, iorder, transa, + transb, &m, &n, &k, &alpha, &lda, + &ldb, &beta, &ldc); + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1); */ + } + ccgemm_(iorder, transa, transb, &m, &n, &k, & + alpha, &aa[1], &lda, &bb[1], &ldb, & + beta, &cc[1], &ldc); + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { +// io___128.ciunit = *nout; +// s_wsfe(&io___128); +// e_wsfe(); + printf(" *** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + *fatal = TRUE_; + goto L120; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)transa == *( + unsigned char *)tranas; + isame[1] = *(unsigned char *)transb == *( + unsigned char *)tranbs; + isame[2] = ms == m; + isame[3] = ns == n; + isame[4] = ks == k; + isame[5] = als.r == alpha.r && als.i == + alpha.i; + isame[6] = lce_(&as[1], &aa[1], &laa); + isame[7] = ldas == lda; + isame[8] = lce_(&bs[1], &bb[1], &lbb); + isame[9] = ldbs == ldb; + isame[10] = bls.r == beta.r && bls.i == + beta.i; + if (null) { + isame[11] = lce_(&cs[1], &cc[1], &lcc); + } else { + isame[11] = lceres_("ge", " ", &m, &n, & + cs[1], &cc[1], &ldc); + } + isame[12] = ldcs == ldc; + +/* If data was incorrectly changed, report */ +/* and return. */ + + same = TRUE_; + i__6 = nargs; + for (i__ = 1; i__ <= i__6; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);; + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L120; + } + + if (! null) { + +/* Check the result. */ + + cmmch_(transa, transb, &m, &n, &k, &alpha, + &a[a_offset], nmax, &b[b_offset], + nmax, &beta, &c__[c_offset], + nmax, &ct[1], &g[1], &cc[1], &ldc, + eps, &err, fatal, nout, &c_true); + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L120; + } + } + +/* L50: */ + } + +/* L60: */ + } + +L70: + ; + } + +L80: + ; + } + +/* L90: */ + } + +L100: + ; + } + +/* L110: */ + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + if (*iorder == 1) { + printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + } + goto L130; + +L120: + printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + cprcn1_(nout, &nc, sname, iorder, transa, transb, &m, &n, &k, &alpha, & + lda, &ldb, &beta, &ldc); + +L130: + return 0; + +/* 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',', */ +/* $ 3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, */ +/* $ ',(', F4.1, ',', F4.1, '), C,', I3, ').' ) */ + +/* End of CCHK1. */ + +} /* cchk1_ */ + + +/* Subroutine */ int cprcn1_(integer *nout, integer *nc, char *sname, integer + *iorder, char *transa, char *transb, integer *m, integer *n, integer * + k, complex *alpha, integer *lda, integer *ldb, complex *beta, integer + *ldc) +{ + /* Local variables */ + char crc[14], cta[14], ctb[14]; + + if (*(unsigned char *)transa == 'N') { + s_copy(cta, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transa == 'T') { + s_copy(cta, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cta, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)transb == 'N') { + s_copy(ctb, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transb == 'T') { + s_copy(ctb, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(ctb, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*iorder == 1) { + s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); + } else { + s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); + } + printf("%6d: %s %s %s %s\n",*nc,sname,crc,cta,ctb); + printf("%d %d %d (%4.1f,%4.1f) , A, %d, B, %d, (%4.1f,%4.1f) , C, %d.\n",*m,*n,*k,alpha->r,alpha->i,*lda,*ldb,beta->r,beta->i,*ldc); + return 0; +} /* cprcn1_ */ + + +/* Subroutine */ int cchk2_(char *sname, real *eps, real *thresh, integer * + nout, integer *ntra, logical *trace, logical *rewi, logical *fatal, + integer *nidim, integer *idim, integer *nalf, complex *alf, integer * + nbet, complex *bet, integer *nmax, complex *a, complex *aa, complex * + as, complex *b, complex *bb, complex *bs, complex *c__, complex *cc, + complex *cs, complex *ct, real *g, integer *iorder) +{ + /* Initialized data */ + + static char ichs[2] = "LR"; + static char ichu[2] = "UL"; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5, i__6, i__7; + + /* Local variables */ + complex beta; + integer ldas, ldbs, ldcs; + logical same; + char side[1]; + logical conj, left, null; + char uplo[1]; + integer i__, m, n; + extern /* Subroutine */ int cmake_(char *, char *, char *, integer *, + integer *, complex *, integer *, complex *, integer *, logical *, + complex *); + complex alpha; + extern /* Subroutine */ int cmmch_(char *, char *, integer *, integer *, + integer *, complex *, complex *, integer *, complex *, integer *, + complex *, complex *, integer *, complex *, real *, complex *, + integer *, real *, real *, logical *, integer *, logical *); + logical isame[13]; + char sides[1]; + integer nargs; + logical reset; + char uplos[1]; + extern /* Subroutine */ int cprcn2_(integer *, integer *, char *, integer + *, char *, char *, integer *, integer *, complex *, integer *, + integer *, complex *, integer *); + integer ia, ib, na, nc, im, in; + extern /* Subroutine */ int cchemm_(integer *, char *, char *, integer *, + integer *, complex *, complex *, integer *, complex *, integer *, + complex *, complex *, integer *); + integer ms, ns; + extern logical lceres_(char *, char *, integer *, integer *, complex *, + complex *, integer *); + extern /* Subroutine */ int ccsymm_(integer *, char *, char *, integer *, + integer *, complex *, complex *, integer *, complex *, integer *, + complex *, complex *, integer *); + real errmax; + integer laa, lbb, lda, lcc, ldb, ldc; + extern logical lce_(complex *, complex *, integer *); + integer ics; + complex als, bls; + integer icu; + real err; + +/* Tests CHEMM and CSYMM. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + /* Parameter adjustments */ + --idim; + --alf; + --bet; + --g; + --ct; + --cs; + --cc; + c_dim1 = *nmax; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --bs; + --bb; + b_dim1 = *nmax; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + conj = s_cmp(sname + 7, "he", (ftnlen)2, (ftnlen)2) == 0; + + nargs = 12; + nc = 0; + reset = TRUE_; + errmax = 0.f; + + i__1 = *nidim; + for (im = 1; im <= i__1; ++im) { + m = idim[im]; + + i__2 = *nidim; + for (in = 1; in <= i__2; ++in) { + n = idim[in]; +/* Set LDC to 1 more than minimum value if room. */ + ldc = m; + if (ldc < *nmax) { + ++ldc; + } +/* Skip tests if not enough room. */ + if (ldc > *nmax) { + goto L90; + } + lcc = ldc * n; + null = n <= 0 || m <= 0; +/* Set LDB to 1 more than minimum value if room. */ + ldb = m; + if (ldb < *nmax) { + ++ldb; + } +/* Skip tests if not enough room. */ + if (ldb > *nmax) { + goto L90; + } + lbb = ldb * n; + +/* Generate the matrix B. */ + + cmake_("ge", " ", " ", &m, &n, &b[b_offset], nmax, &bb[1], &ldb, & + reset, &c_b1); + + for (ics = 1; ics <= 2; ++ics) { + *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1]; + left = *(unsigned char *)side == 'L'; + + if (left) { + na = m; + } else { + na = n; + } +/* Set LDA to 1 more than minimum value if room. */ + lda = na; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L80; + } + laa = lda * na; + + for (icu = 1; icu <= 2; ++icu) { + *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; + +/* Generate the hermitian or symmetric matrix A. */ + + cmake_(sname + 7, uplo, " ", &na, &na, &a[a_offset], nmax, + &aa[1], &lda, &reset, &c_b1); + + i__3 = *nalf; + for (ia = 1; ia <= i__3; ++ia) { + i__4 = ia; + alpha.r = alf[i__4].r, alpha.i = alf[i__4].i; + + i__4 = *nbet; + for (ib = 1; ib <= i__4; ++ib) { + i__5 = ib; + beta.r = bet[i__5].r, beta.i = bet[i__5].i; + +/* Generate the matrix C. */ + + cmake_("ge", " ", " ", &m, &n, &c__[c_offset], + nmax, &cc[1], &ldc, &reset, &c_b1); + + ++nc; + +/* Save every datum before calling the */ +/* subroutine. */ + + *(unsigned char *)sides = *(unsigned char *)side; + *(unsigned char *)uplos = *(unsigned char *)uplo; + ms = m; + ns = n; + als.r = alpha.r, als.i = alpha.i; + i__5 = laa; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7] + .i; +/* L10: */ + } + ldas = lda; + i__5 = lbb; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + bs[i__6].r = bb[i__7].r, bs[i__6].i = bb[i__7] + .i; +/* L20: */ + } + ldbs = ldb; + bls.r = beta.r, bls.i = beta.i; + i__5 = lcc; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + cs[i__6].r = cc[i__7].r, cs[i__6].i = cc[i__7] + .i; +/* L30: */ + } + ldcs = ldc; + +/* Call the subroutine. */ + + if (*trace) { + cprcn2_(ntra, &nc, sname, iorder, side, uplo, + &m, &n, &alpha, &lda, &ldb, &beta, & + ldc) + ; + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + if (conj) { + cchemm_(iorder, side, uplo, &m, &n, &alpha, & + aa[1], &lda, &bb[1], &ldb, &beta, &cc[ + 1], &ldc); + } else { + ccsymm_(iorder, side, uplo, &m, &n, &alpha, & + aa[1], &lda, &bb[1], &ldb, &beta, &cc[ + 1], &ldc); + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + *fatal = TRUE_; + goto L110; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)sides == *(unsigned + char *)side; + isame[1] = *(unsigned char *)uplos == *(unsigned + char *)uplo; + isame[2] = ms == m; + isame[3] = ns == n; + isame[4] = als.r == alpha.r && als.i == alpha.i; + isame[5] = lce_(&as[1], &aa[1], &laa); + isame[6] = ldas == lda; + isame[7] = lce_(&bs[1], &bb[1], &lbb); + isame[8] = ldbs == ldb; + isame[9] = bls.r == beta.r && bls.i == beta.i; + if (null) { + isame[10] = lce_(&cs[1], &cc[1], &lcc); + } else { + isame[10] = lceres_("ge", " ", &m, &n, &cs[1], + &cc[1], &ldc); + } + isame[11] = ldcs == ldc; + +/* If data was incorrectly changed, report and */ +/* return. */ + + same = TRUE_; + i__5 = nargs; + for (i__ = 1; i__ <= i__5; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L110; + } + + if (! null) { + +/* Check the result. */ + + if (left) { + cmmch_("N", "N", &m, &n, &m, &alpha, &a[ + a_offset], nmax, &b[b_offset], + nmax, &beta, &c__[c_offset], nmax, + &ct[1], &g[1], &cc[1], &ldc, eps, + &err, fatal, nout, &c_true); + } else { + cmmch_("N", "N", &m, &n, &n, &alpha, &b[ + b_offset], nmax, &a[a_offset], + nmax, &beta, &c__[c_offset], nmax, + &ct[1], &g[1], &cc[1], &ldc, eps, + &err, fatal, nout, &c_true); + } + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L110; + } + } + +/* L50: */ + } + +/* L60: */ + } + +/* L70: */ + } + +L80: + ; + } + +L90: + ; + } + +/* L100: */ + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + if (*iorder == 1) { + printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + } + goto L120; + +L110: + printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + cprcn2_(nout, &nc, sname, iorder, side, uplo, &m, &n, &alpha, &lda, &ldb, + &beta, &ldc); + +L120: + return 0; + +/* 9995 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ +/* $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1, */ +/* $ ',', F4.1, '), C,', I3, ') .' ) */ + +/* End of CCHK2. */ + +} /* cchk2_ */ + + +/* Subroutine */ int cprcn2_(integer *nout, integer *nc, char *sname, integer + *iorder, char *side, char *uplo, integer *m, integer *n, complex * + alpha, integer *lda, integer *ldb, complex *beta, integer *ldc) +{ + /* Local variables */ + char cs[14], cu[14], crc[14]; + + if (*(unsigned char *)side == 'L') { + s_copy(cs, " CblasLeft", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cs, " CblasRight", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)uplo == 'U') { + s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); + } + if (*iorder == 1) { + s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); + } else { + s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); + } + printf("%6d: %s %s %s %s\n",*nc,sname,crc,cs,cu); + printf("%d %d (%4.1f,%4.1f) , A, %d, B, %d, (%4.1f,%4.1f) , C, %d.\n",*m,*n,alpha->r,alpha->i,*lda,*ldb,beta->r,beta->i,*ldc); + return 0; +} /* cprcn2_ */ + + +/* Subroutine */ int cchk3_(char *sname, real *eps, real *thresh, integer * + nout, integer *ntra, logical *trace, logical *rewi, logical *fatal, + integer *nidim, integer *idim, integer *nalf, complex *alf, integer * + nmax, complex *a, complex *aa, complex *as, complex *b, complex *bb, + complex *bs, complex *ct, real *g, complex *c__, integer *iorder) +{ + /* Initialized data */ + + static char ichu[2] = "UL"; + static char icht[3] = "NTC"; + static char ichd[2] = "UN"; + static char ichs[2] = "LR"; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5, i__6, i__7; + complex q__1; + + /* Local variables */ + char diag[1]; + integer ldas, ldbs; + logical same; + char side[1]; + logical left, null; + char uplo[1]; + integer i__, j, m, n; + extern /* Subroutine */ int cmake_(char *, char *, char *, integer *, + integer *, complex *, integer *, complex *, integer *, logical *, + complex *); + complex alpha; + char diags[1]; + extern /* Subroutine */ int cmmch_(char *, char *, integer *, integer *, + integer *, complex *, complex *, integer *, complex *, integer *, + complex *, complex *, integer *, complex *, real *, complex *, + integer *, real *, real *, logical *, integer *, logical *); + logical isame[13]; + char sides[1]; + integer nargs; + logical reset; + char uplos[1]; + extern /* Subroutine */ int cprcn3_(integer *, integer *, char *, integer + *, char *, char *, char *, char *, integer *, integer *, complex * + , integer *, integer *); + integer ia, na, nc, im, in, ms, ns; + extern logical lceres_(char *, char *, integer *, integer *, complex *, + complex *, integer *); + extern /* Subroutine */ int cctrmm_(integer *, char *, char *, char *, + char *, integer *, integer *, complex *, complex *, integer *, + complex *, integer *); + char tranas[1], transa[1]; + extern /* Subroutine */ int cctrsm_(integer *, char *, char *, char *, + char *, integer *, integer *, complex *, complex *, integer *, + complex *, integer *); + real errmax; + integer laa, icd, lbb, lda, ldb; + extern logical lce_(complex *, complex *, integer *); + integer ics; + complex als; + integer ict, icu; + real err; + +/* Tests CTRMM and CTRSM. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + /* Parameter adjustments */ + --idim; + --alf; + c_dim1 = *nmax; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --g; + --ct; + --bs; + --bb; + b_dim1 = *nmax; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + + nargs = 11; + nc = 0; + reset = TRUE_; + errmax = 0.f; +/* Set up zero matrix for CMMCH. */ + i__1 = *nmax; + for (j = 1; j <= i__1; ++j) { + i__2 = *nmax; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0.f, c__[i__3].i = 0.f; +/* L10: */ + } +/* L20: */ + } + + i__1 = *nidim; + for (im = 1; im <= i__1; ++im) { + m = idim[im]; + + i__2 = *nidim; + for (in = 1; in <= i__2; ++in) { + n = idim[in]; +/* Set LDB to 1 more than minimum value if room. */ + ldb = m; + if (ldb < *nmax) { + ++ldb; + } +/* Skip tests if not enough room. */ + if (ldb > *nmax) { + goto L130; + } + lbb = ldb * n; + null = m <= 0 || n <= 0; + + for (ics = 1; ics <= 2; ++ics) { + *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1]; + left = *(unsigned char *)side == 'L'; + if (left) { + na = m; + } else { + na = n; + } +/* Set LDA to 1 more than minimum value if room. */ + lda = na; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L130; + } + laa = lda * na; + + for (icu = 1; icu <= 2; ++icu) { + *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; + + for (ict = 1; ict <= 3; ++ict) { + *(unsigned char *)transa = *(unsigned char *)&icht[ + ict - 1]; + + for (icd = 1; icd <= 2; ++icd) { + *(unsigned char *)diag = *(unsigned char *)&ichd[ + icd - 1]; + + i__3 = *nalf; + for (ia = 1; ia <= i__3; ++ia) { + i__4 = ia; + alpha.r = alf[i__4].r, alpha.i = alf[i__4].i; + +/* Generate the matrix A. */ + + cmake_("tr", uplo, diag, &na, &na, &a[ + a_offset], nmax, &aa[1], &lda, &reset, + &c_b1); + +/* Generate the matrix B. */ + + cmake_("ge", " ", " ", &m, &n, &b[b_offset], + nmax, &bb[1], &ldb, &reset, &c_b1); + + ++nc; + +/* Save every datum before calling the */ +/* subroutine. */ + + *(unsigned char *)sides = *(unsigned char *) + side; + *(unsigned char *)uplos = *(unsigned char *) + uplo; + *(unsigned char *)tranas = *(unsigned char *) + transa; + *(unsigned char *)diags = *(unsigned char *) + diag; + ms = m; + ns = n; + als.r = alpha.r, als.i = alpha.i; + i__4 = laa; + for (i__ = 1; i__ <= i__4; ++i__) { + i__5 = i__; + i__6 = i__; + as[i__5].r = aa[i__6].r, as[i__5].i = aa[ + i__6].i; +/* L30: */ + } + ldas = lda; + i__4 = lbb; + for (i__ = 1; i__ <= i__4; ++i__) { + i__5 = i__; + i__6 = i__; + bs[i__5].r = bb[i__6].r, bs[i__5].i = bb[ + i__6].i; +/* L40: */ + } + ldbs = ldb; + +/* Call the subroutine. */ + + if (s_cmp(sname + 9, "mm", (ftnlen)2, (ftnlen) + 2) == 0) { + if (*trace) { + cprcn3_(ntra, &nc, sname, iorder, + side, uplo, transa, diag, &m, + &n, &alpha, &lda, &ldb/*, ( + ftnlen)12, (ftnlen)1, (ftnlen) + 1, (ftnlen)1, (ftnlen)1*/); + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cctrmm_(iorder, side, uplo, transa, diag, + &m, &n, &alpha, &aa[1], &lda, &bb[ + 1], &ldb); + } else if (s_cmp(sname + 9, "sm", (ftnlen)2, ( + ftnlen)2) == 0) { + if (*trace) { + cprcn3_(ntra, &nc, sname, iorder, + side, uplo, transa, diag, &m, + &n, &alpha, &lda, &ldb/*, ( + ftnlen)12, (ftnlen)1, (ftnlen) + 1, (ftnlen)1, (ftnlen)1*/); + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cctrsm_(iorder, side, uplo, transa, diag, + &m, &n, &alpha, &aa[1], &lda, &bb[ + 1], &ldb); + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + *fatal = TRUE_; + goto L150; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)sides == *( + unsigned char *)side; + isame[1] = *(unsigned char *)uplos == *( + unsigned char *)uplo; + isame[2] = *(unsigned char *)tranas == *( + unsigned char *)transa; + isame[3] = *(unsigned char *)diags == *( + unsigned char *)diag; + isame[4] = ms == m; + isame[5] = ns == n; + isame[6] = als.r == alpha.r && als.i == + alpha.i; + isame[7] = lce_(&as[1], &aa[1], &laa); + isame[8] = ldas == lda; + if (null) { + isame[9] = lce_(&bs[1], &bb[1], &lbb); + } else { + isame[9] = lceres_("ge", " ", &m, &n, &bs[ + 1], &bb[1], &ldb); + } + isame[10] = ldbs == ldb; + +/* If data was incorrectly changed, report and */ +/* return. */ + + same = TRUE_; + i__4 = nargs; + for (i__ = 1; i__ <= i__4; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L50: */ + } + if (! same) { + *fatal = TRUE_; + goto L150; + } + + if (! null) { + if (s_cmp(sname + 9, "mm", (ftnlen)2, ( + ftnlen)2) == 0) { + +/* Check the result. */ + + if (left) { + cmmch_(transa, "N", &m, &n, &m, & + alpha, &a[a_offset], nmax, + &b[b_offset], nmax, & + c_b1, &c__[c_offset], + nmax, &ct[1], &g[1], &bb[ + 1], &ldb, eps, &err, + fatal, nout, &c_true/*, ( + ftnlen)1, (ftnlen)1*/); + } else { + cmmch_("N", transa, &m, &n, &n, & + alpha, &b[b_offset], nmax, + &a[a_offset], nmax, & + c_b1, &c__[c_offset], + nmax, &ct[1], &g[1], &bb[ + 1], &ldb, eps, &err, + fatal, nout, &c_true); + } + } else if (s_cmp(sname + 9, "sm", (ftnlen) + 2, (ftnlen)2) == 0) { + +/* Compute approximation to original */ +/* matrix. */ + + i__4 = n; + for (j = 1; j <= i__4; ++j) { + i__5 = m; + for (i__ = 1; i__ <= i__5; ++i__) + { + i__6 = i__ + j * c_dim1; + i__7 = i__ + (j - 1) * ldb; + c__[i__6].r = bb[i__7].r, c__[i__6].i = bb[i__7].i; + i__6 = i__ + (j - 1) * ldb; + i__7 = i__ + j * b_dim1; + q__1.r = alpha.r * b[i__7].r - alpha.i * b[i__7].i, + q__1.i = alpha.r * b[i__7].i + alpha.i * b[ + i__7].r; + bb[i__6].r = q__1.r, bb[i__6].i = q__1.i; +/* L60: */ + } +/* L70: */ + } + + if (left) { + cmmch_(transa, "N", &m, &n, &m, & + c_b2, &a[a_offset], nmax, + &c__[c_offset], nmax, & + c_b1, &b[b_offset], nmax, + &ct[1], &g[1], &bb[1], & + ldb, eps, &err, fatal, + nout, &c_false); + } else { + cmmch_("N", transa, &m, &n, &n, & + c_b2, &c__[c_offset], + nmax, &a[a_offset], nmax, + &c_b1, &b[b_offset], nmax, + &ct[1], &g[1], &bb[1], & + ldb, eps, &err, fatal, + nout, &c_false); + } + } + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L150; + } + } + +/* L80: */ + } + +/* L90: */ + } + +/* L100: */ + } + +/* L110: */ + } + +/* L120: */ + } + +L130: + ; + } + +/* L140: */ + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + if (*iorder == 1) { + printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + } + goto L160; + +L150: + printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + if (*trace) { + cprcn3_(ntra, &nc, sname, iorder, side, uplo, transa, diag, &m, &n, & + alpha, &lda, &ldb); + } + +L160: + return 0; + +/* 9995 FORMAT(1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( I3, ',' ), */ +/* $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ') ', */ +/* $ ' .' ) */ + +/* End of CCHK3. */ + +} /* cchk3_ */ + + +/* Subroutine */ int cprcn3_(integer *nout, integer *nc, char *sname, integer + *iorder, char *side, char *uplo, char *transa, char *diag, integer *m, + integer *n, complex *alpha, integer *lda, integer *ldb) +{ + /* Local variables */ + char ca[14], cd[14], cs[14], cu[14], crc[14]; + + if (*(unsigned char *)side == 'L') { + s_copy(cs, " CblasLeft", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cs, " CblasRight", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)uplo == 'U') { + s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)transa == 'N') { + s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transa == 'T') { + s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)diag == 'N') { + s_copy(cd, " CblasNonUnit", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cd, " CblasUnit", (ftnlen)14, (ftnlen)14); + } + if (*iorder == 1) { + s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); + } else { + s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); + } + printf("%6d: %s %s %s %s\n",*nc,sname,crc,cs,cu); + printf(" %s %s %d %d (%4.1f,%4.1f) A %d B %d\n",ca,cd,*m,*n,alpha->r,alpha->i,*lda,*ldb); + + return 0; +} /* cprcn3_ */ + + +/* Subroutine */ int cchk4_(char *sname, real *eps, real *thresh, integer * + nout, integer *ntra, logical *trace, logical *rewi, logical *fatal, + integer *nidim, integer *idim, integer *nalf, complex *alf, integer * + nbet, complex *bet, integer *nmax, complex *a, complex *aa, complex * + as, complex *b, complex *bb, complex *bs, complex *c__, complex *cc, + complex *cs, complex *ct, real *g, integer *iorder) +{ + /* Initialized data */ + + static char icht[2] = "NC"; + static char ichu[2] = "UL"; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5, i__6, i__7; + complex q__1; + + /* Local variables */ + complex beta; + integer ldas, ldcs; + logical same, conj; + complex bets; + real rals; + logical tran, null; + char uplo[1]; + integer i__, j, k, n; + extern /* Subroutine */ int cmake_(char *, char *, char *, integer *, + integer *, complex *, integer *, complex *, integer *, logical *, + complex *); + complex alpha; + extern /* Subroutine */ int cmmch_(char *, char *, integer *, integer *, + integer *, complex *, complex *, integer *, complex *, integer *, + complex *, complex *, integer *, complex *, real *, complex *, + integer *, real *, real *, logical *, integer *, logical *); + real rbeta; + logical isame[13]; + integer nargs; + real rbets; + logical reset; + char trans[1]; + logical upper; + char uplos[1]; + extern /* Subroutine */ int cprcn4_(integer *, integer *, char *, integer + *, char *, char *, integer *, integer *, complex *, integer *, + complex *, integer *), cprcn6_(integer *, + integer *, char *, integer *, char *, char *, integer *, integer * + , real *, integer *, real *, integer *); + integer ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks; + extern /* Subroutine */ int ccherk_(integer *, char *, char *, integer *, + integer *, real *, complex *, integer *, real *, complex *, + integer *); + integer ns; + real ralpha; + extern logical lceres_(char *, char *, integer *, integer *, complex *, + complex *, integer *); + real errmax; + extern /* Subroutine */ int ccsyrk_(integer *, char *, char *, integer *, + integer *, complex *, complex *, integer *, complex *, complex *, + integer *); + char transs[1], transt[1]; + integer laa, lda, lcc, ldc; + extern logical lce_(complex *, complex *, integer *); + complex als; + integer ict, icu; + real err; + +/* Tests CHERK and CSYRK. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + /* Parameter adjustments */ + --idim; + --alf; + --bet; + --g; + --ct; + --cs; + --cc; + c_dim1 = *nmax; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --bs; + --bb; + b_dim1 = *nmax; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + conj = s_cmp(sname + 7, "he", (ftnlen)2, (ftnlen)2) == 0; + + nargs = 10; + nc = 0; + reset = TRUE_; + errmax = 0.f; + rals = 1.f; + rbets = 1.f; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; +/* Set LDC to 1 more than minimum value if room. */ + ldc = n; + if (ldc < *nmax) { + ++ldc; + } +/* Skip tests if not enough room. */ + if (ldc > *nmax) { + goto L100; + } + lcc = ldc * n; + + i__2 = *nidim; + for (ik = 1; ik <= i__2; ++ik) { + k = idim[ik]; + + for (ict = 1; ict <= 2; ++ict) { + *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1]; + tran = *(unsigned char *)trans == 'C'; + if (tran && ! conj) { + *(unsigned char *)trans = 'T'; + } + if (tran) { + ma = k; + na = n; + } else { + ma = n; + na = k; + } +/* Set LDA to 1 more than minimum value if room. */ + lda = ma; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L80; + } + laa = lda * na; + +/* Generate the matrix A. */ + + cmake_("ge", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[1], & + lda, &reset, &c_b1); + + for (icu = 1; icu <= 2; ++icu) { + *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; + upper = *(unsigned char *)uplo == 'U'; + + i__3 = *nalf; + for (ia = 1; ia <= i__3; ++ia) { + i__4 = ia; + alpha.r = alf[i__4].r, alpha.i = alf[i__4].i; + if (conj) { + ralpha = alpha.r; + q__1.r = ralpha, q__1.i = 0.f; + alpha.r = q__1.r, alpha.i = q__1.i; + } + + i__4 = *nbet; + for (ib = 1; ib <= i__4; ++ib) { + i__5 = ib; + beta.r = bet[i__5].r, beta.i = bet[i__5].i; + if (conj) { + rbeta = beta.r; + q__1.r = rbeta, q__1.i = 0.f; + beta.r = q__1.r, beta.i = q__1.i; + } + null = n <= 0; + if (conj) { + null = null || ((k <= 0 || ralpha == 0.f) && + rbeta == 1.f); + } + +/* Generate the matrix C. */ + + cmake_(sname + 7, uplo, " ", &n, &n, &c__[ + c_offset], nmax, &cc[1], &ldc, &reset, & + c_b1); + + ++nc; + +/* Save every datum before calling the subroutine. */ + + *(unsigned char *)uplos = *(unsigned char *)uplo; + *(unsigned char *)transs = *(unsigned char *) + trans; + ns = n; + ks = k; + if (conj) { + rals = ralpha; + } else { + als.r = alpha.r, als.i = alpha.i; + } + i__5 = laa; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7] + .i; +/* L10: */ + } + ldas = lda; + if (conj) { + rbets = rbeta; + } else { + bets.r = beta.r, bets.i = beta.i; + } + i__5 = lcc; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + cs[i__6].r = cc[i__7].r, cs[i__6].i = cc[i__7] + .i; +/* L20: */ + } + ldcs = ldc; + +/* Call the subroutine. */ + + if (conj) { + if (*trace) { + cprcn6_(ntra, &nc, sname, iorder, uplo, + trans, &n, &k, &ralpha, &lda, & + rbeta, &ldc); + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + ccherk_(iorder, uplo, trans, &n, &k, &ralpha, + &aa[1], &lda, &rbeta, &cc[1], &ldc); + } else { + if (*trace) { + cprcn4_(ntra, &nc, sname, iorder, uplo, + trans, &n, &k, &alpha, &lda, & + beta, &ldc); + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + ccsyrk_(iorder, uplo, trans, &n, &k, &alpha, & + aa[1], &lda, &beta, &cc[1], &ldc); + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + *fatal = TRUE_; + goto L120; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)uplos == *(unsigned + char *)uplo; + isame[1] = *(unsigned char *)transs == *(unsigned + char *)trans; + isame[2] = ns == n; + isame[3] = ks == k; + if (conj) { + isame[4] = rals == ralpha; + } else { + isame[4] = als.r == alpha.r && als.i == + alpha.i; + } + isame[5] = lce_(&as[1], &aa[1], &laa); + isame[6] = ldas == lda; + if (conj) { + isame[7] = rbets == rbeta; + } else { + isame[7] = bets.r == beta.r && bets.i == + beta.i; + } + if (null) { + isame[8] = lce_(&cs[1], &cc[1], &lcc); + } else { + isame[8] = lceres_(sname + 7, uplo, &n, &n, & + cs[1], &cc[1], &ldc); + } + isame[9] = ldcs == ldc; + +/* If data was incorrectly changed, report and */ +/* return. */ + + same = TRUE_; + i__5 = nargs; + for (i__ = 1; i__ <= i__5; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L30: */ + } + if (! same) { + *fatal = TRUE_; + goto L120; + } + + if (! null) { + +/* Check the result column by column. */ + + if (conj) { + *(unsigned char *)transt = 'C'; + } else { + *(unsigned char *)transt = 'T'; + } + jc = 1; + i__5 = n; + for (j = 1; j <= i__5; ++j) { + if (upper) { + jj = 1; + lj = j; + } else { + jj = j; + lj = n - j + 1; + } + if (tran) { + cmmch_(transt, "N", &lj, &c__1, &k, & + alpha, &a[jj * a_dim1 + 1], + nmax, &a[j * a_dim1 + 1], + nmax, &beta, &c__[jj + j * + c_dim1], nmax, &ct[1], &g[1], + &cc[jc], &ldc, eps, &err, + fatal, nout, &c_true); + } else { + cmmch_("N", transt, &lj, &c__1, &k, & + alpha, &a[jj + a_dim1], nmax, + &a[j + a_dim1], nmax, &beta, & + c__[jj + j * c_dim1], nmax, & + ct[1], &g[1], &cc[jc], &ldc, + eps, &err, fatal, nout, & + c_true); + } + if (upper) { + jc += ldc; + } else { + jc = jc + ldc + 1; + } + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L110; + } +/* L40: */ + } + } + +/* L50: */ + } + +/* L60: */ + } + +/* L70: */ + } + +L80: + ; + } + +/* L90: */ + } + +L100: + ; + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + if (*iorder == 1) { + printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + } + goto L130; + +L110: + if (n > 1) { + printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j); + } + +L120: + printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + if (conj) { + cprcn6_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &ralpha, &lda, + &rbeta, &ldc); + } else { + cprcn4_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, & + beta, &ldc); + } + +L130: + return 0; + +/* 9994 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ +/* $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') ', */ +/* $ ' .' ) */ +/* 9993 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ +/* $ '(', F4.1, ',', F4.1, ') , A,', I3, ',(', F4.1, ',', F4.1, */ +/* $ '), C,', I3, ') .' ) */ + +/* End of CCHK4. */ + +} /* cchk4_ */ + + +/* Subroutine */ int cprcn4_(integer *nout, integer *nc, char *sname, integer + *iorder, char *uplo, char *transa, integer *n, integer *k, complex * + alpha, integer *lda, complex *beta, integer *ldc) +{ + /* Local variables */ + char ca[14], cu[14], crc[14]; + + if (*(unsigned char *)uplo == 'U') { + s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)transa == 'N') { + s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transa == 'T') { + s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*iorder == 1) { + s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); + } else { + s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); + } + printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); + printf("( %d %d (%4.1f,%4.1f) A %d (%4.1f,%4.1f) C %d\n",*n,*k,alpha->r,alpha->i,*lda,beta->r,beta->i,*ldc); + return 0; +} /* cprcn4_ */ + + + +/* Subroutine */ int cprcn6_(integer *nout, integer *nc, char *sname, integer + *iorder, char *uplo, char *transa, integer *n, integer *k, real * + alpha, integer *lda, real *beta, integer *ldc) +{ + /* Local variables */ + char ca[14], cu[14], crc[14]; + + if (*(unsigned char *)uplo == 'U') { + s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)transa == 'N') { + s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transa == 'T') { + s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*iorder == 1) { + s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); + } else { + s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); + } + printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); + printf("( %d %d %4.1f A %d %4.1f C %d\n",*n,*k,*alpha,*lda,*beta,*ldc); + return 0; +} /* cprcn6_ */ + + +/* Subroutine */ int cchk5_(char *sname, real *eps, real *thresh, integer * + nout, integer *ntra, logical *trace, logical *rewi, logical *fatal, + integer *nidim, integer *idim, integer *nalf, complex *alf, integer * + nbet, complex *bet, integer *nmax, complex *ab, complex *aa, complex * + as, complex *bb, complex *bs, complex *c__, complex *cc, complex *cs, + complex *ct, real *g, complex *w, integer *iorder) +{ + /* Initialized data */ + + static char icht[2] = "NC"; + static char ichu[2] = "UL"; + + + /* System generated locals */ + integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8; + complex q__1, q__2; + + /* Local variables */ + integer jjab; + complex beta; + integer ldas, ldbs, ldcs; + logical same, conj; + complex bets; + logical tran, null; + char uplo[1]; + integer i__, j, k, n; + extern /* Subroutine */ int cmake_(char *, char *, char *, integer *, + integer *, complex *, integer *, complex *, integer *, logical *, + complex *); + complex alpha; + extern /* Subroutine */ int cmmch_(char *, char *, integer *, integer *, + integer *, complex *, complex *, integer *, complex *, integer *, + complex *, complex *, integer *, complex *, real *, complex *, + integer *, real *, real *, logical *, integer *, logical *); + real rbeta; + logical isame[13]; + integer nargs; + real rbets; + logical reset; + char trans[1]; + logical upper; + char uplos[1]; + extern /* Subroutine */ int cprcn5_(integer *, integer *, char *, integer + *, char *, char *, integer *, integer *, complex *, integer *, + integer *, complex *, integer *), cprcn7_( + integer *, integer *, char *, integer *, char *, char *, integer * + , integer *, complex *, integer *, integer *, real *, integer *); + integer ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns; + extern logical lceres_(char *, char *, integer *, integer *, complex *, + complex *, integer *); + real errmax; + char transs[1], transt[1]; + extern /* Subroutine */ int ccher2k_(integer *, char *, char *, integer *, + integer *, complex *, complex *, integer *, complex *, integer *, + real *, complex *, integer *); + integer laa, lbb, lda, lcc, ldb, ldc; + extern logical lce_(complex *, complex *, integer *); + extern /* Subroutine */ int ccsyr2k_(integer *, char *, char *, integer *, + integer *, complex *, complex *, integer *, complex *, integer *, + complex *, complex *, integer *); + complex als; + integer ict, icu; + real err; + +/* Tests CHER2K and CSYR2K. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + /* Parameter adjustments */ + --idim; + --alf; + --bet; + --w; + --g; + --ct; + --cs; + --cc; + c_dim1 = *nmax; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --bs; + --bb; + --as; + --aa; + --ab; + + /* Function Body */ + conj = s_cmp(sname + 7, "he", (ftnlen)2, (ftnlen)2) == 0; + + nargs = 12; + nc = 0; + reset = TRUE_; + errmax = 0.f; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; +/* Set LDC to 1 more than minimum value if room. */ + ldc = n; + if (ldc < *nmax) { + ++ldc; + } +/* Skip tests if not enough room. */ + if (ldc > *nmax) { + goto L130; + } + lcc = ldc * n; + + i__2 = *nidim; + for (ik = 1; ik <= i__2; ++ik) { + k = idim[ik]; + + for (ict = 1; ict <= 2; ++ict) { + *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1]; + tran = *(unsigned char *)trans == 'C'; + if (tran && ! conj) { + *(unsigned char *)trans = 'T'; + } + if (tran) { + ma = k; + na = n; + } else { + ma = n; + na = k; + } +/* Set LDA to 1 more than minimum value if room. */ + lda = ma; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L110; + } + laa = lda * na; + +/* Generate the matrix A. */ + + if (tran) { + i__3 = *nmax << 1; + cmake_("ge", " ", " ", &ma, &na, &ab[1], &i__3, &aa[1], & + lda, &reset, &c_b1); + } else { + cmake_("ge", " ", " ", &ma, &na, &ab[1], nmax, &aa[1], & + lda, &reset, &c_b1); + } + +/* Generate the matrix B. */ + + ldb = lda; + lbb = laa; + if (tran) { + i__3 = *nmax << 1; + cmake_("ge", " ", " ", &ma, &na, &ab[k + 1], &i__3, &bb[1] + , &ldb, &reset, &c_b1); + } else { + cmake_("ge", " ", " ", &ma, &na, &ab[k * *nmax + 1], nmax, + &bb[1], &ldb, &reset, &c_b1); + } + + for (icu = 1; icu <= 2; ++icu) { + *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; + upper = *(unsigned char *)uplo == 'U'; + + i__3 = *nalf; + for (ia = 1; ia <= i__3; ++ia) { + i__4 = ia; + alpha.r = alf[i__4].r, alpha.i = alf[i__4].i; + + i__4 = *nbet; + for (ib = 1; ib <= i__4; ++ib) { + i__5 = ib; + beta.r = bet[i__5].r, beta.i = bet[i__5].i; + if (conj) { + rbeta = beta.r; + q__1.r = rbeta, q__1.i = 0.f; + beta.r = q__1.r, beta.i = q__1.i; + } + null = n <= 0; + if (conj) { + null = null || ((k <= 0 || (alpha.r == 0.f && + alpha.i == 0.f)) && rbeta == 1.f); + } + +/* Generate the matrix C. */ + + cmake_(sname + 7, uplo, " ", &n, &n, &c__[ + c_offset], nmax, &cc[1], &ldc, &reset, & + c_b1); + + ++nc; + +/* Save every datum before calling the subroutine. */ + + *(unsigned char *)uplos = *(unsigned char *)uplo; + *(unsigned char *)transs = *(unsigned char *) + trans; + ns = n; + ks = k; + als.r = alpha.r, als.i = alpha.i; + i__5 = laa; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7] + .i; +/* L10: */ + } + ldas = lda; + i__5 = lbb; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + bs[i__6].r = bb[i__7].r, bs[i__6].i = bb[i__7] + .i; +/* L20: */ + } + ldbs = ldb; + if (conj) { + rbets = rbeta; + } else { + bets.r = beta.r, bets.i = beta.i; + } + i__5 = lcc; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + cs[i__6].r = cc[i__7].r, cs[i__6].i = cc[i__7] + .i; +/* L30: */ + } + ldcs = ldc; + +/* Call the subroutine. */ + + if (conj) { + if (*trace) { + cprcn7_(ntra, &nc, sname, iorder, uplo, + trans, &n, &k, &alpha, &lda, &ldb, + &rbeta, &ldc); + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + ccher2k_(iorder, uplo, trans, &n, &k, &alpha, + &aa[1], &lda, &bb[1], &ldb, &rbeta, & + cc[1], &ldc); + } else { + if (*trace) { + cprcn5_(ntra, &nc, sname, iorder, uplo, + trans, &n, &k, &alpha, &lda, &ldb, + &beta, &ldc); + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + ccsyr2k_(iorder, uplo, trans, &n, &k, &alpha, + &aa[1], &lda, &bb[1], &ldb, &beta, & + cc[1], &ldc); + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + *fatal = TRUE_; + goto L150; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)uplos == *(unsigned + char *)uplo; + isame[1] = *(unsigned char *)transs == *(unsigned + char *)trans; + isame[2] = ns == n; + isame[3] = ks == k; + isame[4] = als.r == alpha.r && als.i == alpha.i; + isame[5] = lce_(&as[1], &aa[1], &laa); + isame[6] = ldas == lda; + isame[7] = lce_(&bs[1], &bb[1], &lbb); + isame[8] = ldbs == ldb; + if (conj) { + isame[9] = rbets == rbeta; + } else { + isame[9] = bets.r == beta.r && bets.i == + beta.i; + } + if (null) { + isame[10] = lce_(&cs[1], &cc[1], &lcc); + } else { + isame[10] = lceres_("he", uplo, &n, &n, &cs[1] + , &cc[1], &ldc); + } + isame[11] = ldcs == ldc; + +/* If data was incorrectly changed, report and */ +/* return. */ + + same = TRUE_; + i__5 = nargs; + for (i__ = 1; i__ <= i__5; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L150; + } + + if (! null) { + +/* Check the result column by column. */ + + if (conj) { + *(unsigned char *)transt = 'C'; + } else { + *(unsigned char *)transt = 'T'; + } + jjab = 1; + jc = 1; + i__5 = n; + for (j = 1; j <= i__5; ++j) { + if (upper) { + jj = 1; + lj = j; + } else { + jj = j; + lj = n - j + 1; + } + if (tran) { + i__6 = k; + for (i__ = 1; i__ <= i__6; ++i__) { + i__7 = i__; + i__8 = ((j - 1) << 1) * *nmax + k + + i__; + q__1.r = alpha.r * ab[i__8].r - + alpha.i * ab[i__8].i, + q__1.i = alpha.r * ab[ + i__8].i + alpha.i * ab[ + i__8].r; + w[i__7].r = q__1.r, w[i__7].i = + q__1.i; + if (conj) { + i__7 = k + i__; + r_cnjg(&q__2, &alpha); + i__8 = ((j - 1) << 1) * *nmax + i__; + q__1.r = q__2.r * ab[i__8].r - q__2.i * ab[i__8].i, + q__1.i = q__2.r * ab[i__8].i + q__2.i * ab[ + i__8].r; + w[i__7].r = q__1.r, w[i__7].i = q__1.i; + } else { + i__7 = k + i__; + i__8 = ((j - 1) << 1) * *nmax + i__; + q__1.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8] + .i, q__1.i = alpha.r * ab[i__8].i + alpha.i + * ab[i__8].r; + w[i__7].r = q__1.r, w[i__7].i = q__1.i; + } +/* L50: */ + } + i__6 = k << 1; + i__7 = *nmax << 1; + i__8 = *nmax << 1; + cmmch_(transt, "N", &lj, &c__1, &i__6, + &c_b2, &ab[jjab], &i__7, &w[ + 1], &i__8, &beta, &c__[jj + j + * c_dim1], nmax, &ct[1], &g[1] + , &cc[jc], &ldc, eps, &err, + fatal, nout, &c_true); + } else { + i__6 = k; + for (i__ = 1; i__ <= i__6; ++i__) { + if (conj) { + i__7 = i__; + r_cnjg(&q__2, &ab[(k + i__ - 1) * *nmax + j]); + q__1.r = alpha.r * q__2.r - alpha.i * q__2.i, + q__1.i = alpha.r * q__2.i + alpha.i * + q__2.r; + w[i__7].r = q__1.r, w[i__7].i = q__1.i; + i__7 = k + i__; + i__8 = (i__ - 1) * *nmax + j; + q__2.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8] + .i, q__2.i = alpha.r * ab[i__8].i + alpha.i + * ab[i__8].r; + r_cnjg(&q__1, &q__2); + w[i__7].r = q__1.r, w[i__7].i = q__1.i; + } else { + i__7 = i__; + i__8 = (k + i__ - 1) * *nmax + j; + q__1.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8] + .i, q__1.i = alpha.r * ab[i__8].i + alpha.i + * ab[i__8].r; + w[i__7].r = q__1.r, w[i__7].i = q__1.i; + i__7 = k + i__; + i__8 = (i__ - 1) * *nmax + j; + q__1.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8] + .i, q__1.i = alpha.r * ab[i__8].i + alpha.i + * ab[i__8].r; + w[i__7].r = q__1.r, w[i__7].i = q__1.i; + } +/* L60: */ + } + i__6 = k << 1; + i__7 = *nmax << 1; + cmmch_("N", "N", &lj, &c__1, &i__6, & + c_b2, &ab[jj], nmax, &w[1], & + i__7, &beta, &c__[jj + j * + c_dim1], nmax, &ct[1], &g[1], + &cc[jc], &ldc, eps, &err, + fatal, nout, &c_true); + } + if (upper) { + jc += ldc; + } else { + jc = jc + ldc + 1; + if (tran) { + jjab += *nmax << 1; + } + } + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L140; + } +/* L70: */ + } + } + +/* L80: */ + } + +/* L90: */ + } + +/* L100: */ + } + +L110: + ; + } + +/* L120: */ + } + +L130: + ; + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + if (*iorder == 1) { + printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + } + goto L160; + +L140: + if (n > 1) { + printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j); + } + +L150: + printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + if (conj) { + cprcn7_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, & + ldb, &rbeta, &ldc); + } else { + cprcn5_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, & + ldb, &beta, &ldc); + } + +L160: + return 0; + +/* 9994 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ +/* $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',', F4.1, */ +/* $ ', C,', I3, ') .' ) */ +/* 9993 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ +/* $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1, */ +/* $ ',', F4.1, '), C,', I3, ') .' ) */ + +/* End of CCHK5. */ + +} /* cchk5_ */ + + +/* Subroutine */ int cprcn5_(integer *nout, integer *nc, char *sname, integer + *iorder, char *uplo, char *transa, integer *n, integer *k, complex * + alpha, integer *lda, integer *ldb, complex *beta, integer *ldc) +{ + + /* Local variables */ + char ca[14], cu[14], crc[14]; + + if (*(unsigned char *)uplo == 'U') { + s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)transa == 'N') { + s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transa == 'T') { + s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*iorder == 1) { + s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); + } else { + s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); + } + printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); + printf("%d %d (%4.1f,%4.1f) , A, %d, B, %d, (%4.1f,%4.1f) , C, %d.\n",*n,*k,alpha->r,alpha->i,*lda,*ldb,beta->r,beta->i,*ldc); + return 0; +} /* cprcn5_ */ + + + +/* Subroutine */ int cprcn7_(integer *nout, integer *nc, char *sname, integer + *iorder, char *uplo, char *transa, integer *n, integer *k, complex * + alpha, integer *lda, integer *ldb, real *beta, integer *ldc) +{ + + /* Local variables */ + char ca[14], cu[14], crc[14]; + + if (*(unsigned char *)uplo == 'U') { + s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)transa == 'N') { + s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transa == 'T') { + s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*iorder == 1) { + s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); + } else { + s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); + } + printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); + printf("%d %d (%4.1f,%4.1f), A, %d, B, %d, %4.1f, C, %d.\n",*n,*k,alpha->r,alpha->i,*lda,*ldb,*beta,*ldc); + return 0; +} /* cprcn7_ */ + + +/* Subroutine */ int cmake_(char *type__, char *uplo, char *diag, integer *m, + integer *n, complex *a, integer *nmax, complex *aa, integer *lda, + logical *reset, complex *transl) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + real r__1; + complex q__1, q__2; + + /* Local variables */ + extern /* Complex */ VOID cbeg_(complex *, logical *); + integer ibeg, iend; + logical unit; + integer i__, j; + logical lower, upper; + integer jj; + logical gen, her, tri, sym; + + +/* Generates values for an M by N matrix A. */ +/* Stores the values in the array AA in the data structure required */ +/* by the routine, with unwanted elements set to rogue value. */ + +/* TYPE is 'ge', 'he', 'sy' or 'tr'. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + /* Parameter adjustments */ + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --aa; + + /* Function Body */ + gen = s_cmp(type__, "ge", (ftnlen)2, (ftnlen)2) == 0; + her = s_cmp(type__, "he", (ftnlen)2, (ftnlen)2) == 0; + sym = s_cmp(type__, "sy", (ftnlen)2, (ftnlen)2) == 0; + tri = s_cmp(type__, "tr", (ftnlen)2, (ftnlen)2) == 0; + upper = (her || sym || tri) && *(unsigned char *)uplo == 'U'; + lower = (her || sym || tri) && *(unsigned char *)uplo == 'L'; + unit = tri && *(unsigned char *)diag == 'U'; + +/* Generate data in array A. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + if (gen || (upper && i__ <= j) || (lower && i__ >= j)) { + i__3 = i__ + j * a_dim1; + cbeg_(&q__2, reset); + q__1.r = q__2.r + transl->r, q__1.i = q__2.i + transl->i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + if (i__ != j) { +/* Set some elements to zero */ + if (*n > 3 && j == *n / 2) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; + } + if (her) { + i__3 = j + i__ * a_dim1; + r_cnjg(&q__1, &a[i__ + j * a_dim1]); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } else if (sym) { + i__3 = j + i__ * a_dim1; + i__4 = i__ + j * a_dim1; + a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i; + } else if (tri) { + i__3 = j + i__ * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; + } + } + } +/* L10: */ + } + if (her) { + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + r__1 = a[i__3].r; + q__1.r = r__1, q__1.i = 0.f; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + } + if (tri) { + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + q__1.r = a[i__3].r + 1.f, q__1.i = a[i__3].i + 0.f; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + } + if (unit) { + i__2 = j + j * a_dim1; + a[i__2].r = 1.f, a[i__2].i = 0.f; + } +/* L20: */ + } + +/* Store elements in array AS in data structure required by routine. */ + + if (s_cmp(type__, "ge", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (j - 1) * *lda; + i__4 = i__ + j * a_dim1; + aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i; +/* L30: */ + } + i__2 = *lda; + for (i__ = *m + 1; i__ <= i__2; ++i__) { + i__3 = i__ + (j - 1) * *lda; + aa[i__3].r = -1e10f, aa[i__3].i = 1e10f; +/* L40: */ + } +/* L50: */ + } + } else if (s_cmp(type__, "he", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__, + "sy", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__, "tr", (ftnlen) + 2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (upper) { + ibeg = 1; + if (unit) { + iend = j - 1; + } else { + iend = j; + } + } else { + if (unit) { + ibeg = j + 1; + } else { + ibeg = j; + } + iend = *n; + } + i__2 = ibeg - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (j - 1) * *lda; + aa[i__3].r = -1e10f, aa[i__3].i = 1e10f; +/* L60: */ + } + i__2 = iend; + for (i__ = ibeg; i__ <= i__2; ++i__) { + i__3 = i__ + (j - 1) * *lda; + i__4 = i__ + j * a_dim1; + aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i; +/* L70: */ + } + i__2 = *lda; + for (i__ = iend + 1; i__ <= i__2; ++i__) { + i__3 = i__ + (j - 1) * *lda; + aa[i__3].r = -1e10f, aa[i__3].i = 1e10f; +/* L80: */ + } + if (her) { + jj = j + (j - 1) * *lda; + i__2 = jj; + i__3 = jj; + r__1 = aa[i__3].r; + q__1.r = r__1, q__1.i = -1e10f; + aa[i__2].r = q__1.r, aa[i__2].i = q__1.i; + } +/* L90: */ + } + } + return 0; + +/* End of CMAKE. */ + +} /* cmake_ */ + +/* Subroutine */ int cmmch_(char *transa, char *transb, integer *m, integer * + n, integer *kk, complex *alpha, complex *a, integer *lda, complex *b, + integer *ldb, complex *beta, complex *c__, integer *ldc, complex *ct, + real *g, complex *cc, integer *ldcc, real *eps, real *err, logical * + fatal, integer *nout, logical *mv) +{ + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, cc_dim1, + cc_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7; + real r__1, r__2, r__3, r__4, r__5, r__6; + complex q__1, q__2, q__3, q__4; + + /* Local variables */ + real erri; + integer i__, j, k; + logical trana, tranb, ctrana, ctranb; + +/* Checks the results of the computational tests. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --ct; + --g; + cc_dim1 = *ldcc; + cc_offset = 1 + cc_dim1 * 1; + cc -= cc_offset; + + /* Function Body */ + trana = *(unsigned char *)transa == 'T' || *(unsigned char *)transa == + 'C'; + tranb = *(unsigned char *)transb == 'T' || *(unsigned char *)transb == + 'C'; + ctrana = *(unsigned char *)transa == 'C'; + ctranb = *(unsigned char *)transb == 'C'; + +/* Compute expected result, one column at a time, in CT using data */ +/* in A, B and C. */ +/* Compute gauges in G. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + ct[i__3].r = 0.f, ct[i__3].i = 0.f; + g[i__] = 0.f; +/* L10: */ + } + if (! trana && ! tranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + i__6 = i__ + k * a_dim1; + i__7 = k + j * b_dim1; + q__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[i__7].i, + q__2.i = a[i__6].r * b[i__7].i + a[i__6].i * b[ + i__7].r; + q__1.r = ct[i__5].r + q__2.r, q__1.i = ct[i__5].i + + q__2.i; + ct[i__4].r = q__1.r, ct[i__4].i = q__1.i; + i__4 = i__ + k * a_dim1; + i__5 = k + j * b_dim1; + g[i__] += ((r__1 = a[i__4].r, abs(r__1)) + (r__2 = r_imag( + &a[i__ + k * a_dim1]), abs(r__2))) * ((r__3 = b[ + i__5].r, abs(r__3)) + (r__4 = r_imag(&b[k + j * + b_dim1]), abs(r__4))); +/* L20: */ + } +/* L30: */ + } + } else if (trana && ! tranb) { + if (ctrana) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + r_cnjg(&q__3, &a[k + i__ * a_dim1]); + i__6 = k + j * b_dim1; + q__2.r = q__3.r * b[i__6].r - q__3.i * b[i__6].i, + q__2.i = q__3.r * b[i__6].i + q__3.i * b[i__6] + .r; + q__1.r = ct[i__5].r + q__2.r, q__1.i = ct[i__5].i + + q__2.i; + ct[i__4].r = q__1.r, ct[i__4].i = q__1.i; + i__4 = k + i__ * a_dim1; + i__5 = k + j * b_dim1; + g[i__] += ((r__1 = a[i__4].r, abs(r__1)) + (r__2 = + r_imag(&a[k + i__ * a_dim1]), abs(r__2))) * (( + r__3 = b[i__5].r, abs(r__3)) + (r__4 = r_imag( + &b[k + j * b_dim1]), abs(r__4))); +/* L40: */ + } +/* L50: */ + } + } else { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + i__6 = k + i__ * a_dim1; + i__7 = k + j * b_dim1; + q__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[i__7] + .i, q__2.i = a[i__6].r * b[i__7].i + a[i__6] + .i * b[i__7].r; + q__1.r = ct[i__5].r + q__2.r, q__1.i = ct[i__5].i + + q__2.i; + ct[i__4].r = q__1.r, ct[i__4].i = q__1.i; + i__4 = k + i__ * a_dim1; + i__5 = k + j * b_dim1; + g[i__] += ((r__1 = a[i__4].r, abs(r__1)) + (r__2 = + r_imag(&a[k + i__ * a_dim1]), abs(r__2))) * (( + r__3 = b[i__5].r, abs(r__3)) + (r__4 = r_imag( + &b[k + j * b_dim1]), abs(r__4))); +/* L60: */ + } +/* L70: */ + } + } + } else if (! trana && tranb) { + if (ctranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + i__6 = i__ + k * a_dim1; + r_cnjg(&q__3, &b[j + k * b_dim1]); + q__2.r = a[i__6].r * q__3.r - a[i__6].i * q__3.i, + q__2.i = a[i__6].r * q__3.i + a[i__6].i * + q__3.r; + q__1.r = ct[i__5].r + q__2.r, q__1.i = ct[i__5].i + + q__2.i; + ct[i__4].r = q__1.r, ct[i__4].i = q__1.i; + i__4 = i__ + k * a_dim1; + i__5 = j + k * b_dim1; + g[i__] += ((r__1 = a[i__4].r, abs(r__1)) + (r__2 = + r_imag(&a[i__ + k * a_dim1]), abs(r__2))) * (( + r__3 = b[i__5].r, abs(r__3)) + (r__4 = r_imag( + &b[j + k * b_dim1]), abs(r__4))); +/* L80: */ + } +/* L90: */ + } + } else { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + i__6 = i__ + k * a_dim1; + i__7 = j + k * b_dim1; + q__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[i__7] + .i, q__2.i = a[i__6].r * b[i__7].i + a[i__6] + .i * b[i__7].r; + q__1.r = ct[i__5].r + q__2.r, q__1.i = ct[i__5].i + + q__2.i; + ct[i__4].r = q__1.r, ct[i__4].i = q__1.i; + i__4 = i__ + k * a_dim1; + i__5 = j + k * b_dim1; + g[i__] += ((r__1 = a[i__4].r, abs(r__1)) + (r__2 = + r_imag(&a[i__ + k * a_dim1]), abs(r__2))) * (( + r__3 = b[i__5].r, abs(r__3)) + (r__4 = r_imag( + &b[j + k * b_dim1]), abs(r__4))); +/* L100: */ + } +/* L110: */ + } + } + } else if (trana && tranb) { + if (ctrana) { + if (ctranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + r_cnjg(&q__3, &a[k + i__ * a_dim1]); + r_cnjg(&q__4, &b[j + k * b_dim1]); + q__2.r = q__3.r * q__4.r - q__3.i * q__4.i, + q__2.i = q__3.r * q__4.i + q__3.i * + q__4.r; + q__1.r = ct[i__5].r + q__2.r, q__1.i = ct[i__5].i + + q__2.i; + ct[i__4].r = q__1.r, ct[i__4].i = q__1.i; + i__4 = k + i__ * a_dim1; + i__5 = j + k * b_dim1; + g[i__] += ((r__1 = a[i__4].r, abs(r__1)) + (r__2 = + r_imag(&a[k + i__ * a_dim1]), abs(r__2))) + * ((r__3 = b[i__5].r, abs(r__3)) + (r__4 + = r_imag(&b[j + k * b_dim1]), abs(r__4))); +/* L120: */ + } +/* L130: */ + } + } else { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + r_cnjg(&q__3, &a[k + i__ * a_dim1]); + i__6 = j + k * b_dim1; + q__2.r = q__3.r * b[i__6].r - q__3.i * b[i__6].i, + q__2.i = q__3.r * b[i__6].i + q__3.i * b[ + i__6].r; + q__1.r = ct[i__5].r + q__2.r, q__1.i = ct[i__5].i + + q__2.i; + ct[i__4].r = q__1.r, ct[i__4].i = q__1.i; + i__4 = k + i__ * a_dim1; + i__5 = j + k * b_dim1; + g[i__] += ((r__1 = a[i__4].r, abs(r__1)) + (r__2 = + r_imag(&a[k + i__ * a_dim1]), abs(r__2))) + * ((r__3 = b[i__5].r, abs(r__3)) + (r__4 + = r_imag(&b[j + k * b_dim1]), abs(r__4))); +/* L140: */ + } +/* L150: */ + } + } + } else { + if (ctranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + i__6 = k + i__ * a_dim1; + r_cnjg(&q__3, &b[j + k * b_dim1]); + q__2.r = a[i__6].r * q__3.r - a[i__6].i * q__3.i, + q__2.i = a[i__6].r * q__3.i + a[i__6].i * + q__3.r; + q__1.r = ct[i__5].r + q__2.r, q__1.i = ct[i__5].i + + q__2.i; + ct[i__4].r = q__1.r, ct[i__4].i = q__1.i; + i__4 = k + i__ * a_dim1; + i__5 = j + k * b_dim1; + g[i__] += ((r__1 = a[i__4].r, abs(r__1)) + (r__2 = + r_imag(&a[k + i__ * a_dim1]), abs(r__2))) + * ((r__3 = b[i__5].r, abs(r__3)) + (r__4 + = r_imag(&b[j + k * b_dim1]), abs(r__4))); +/* L160: */ + } +/* L170: */ + } + } else { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + i__6 = k + i__ * a_dim1; + i__7 = j + k * b_dim1; + q__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[ + i__7].i, q__2.i = a[i__6].r * b[i__7].i + + a[i__6].i * b[i__7].r; + q__1.r = ct[i__5].r + q__2.r, q__1.i = ct[i__5].i + + q__2.i; + ct[i__4].r = q__1.r, ct[i__4].i = q__1.i; + i__4 = k + i__ * a_dim1; + i__5 = j + k * b_dim1; + g[i__] += ((r__1 = a[i__4].r, abs(r__1)) + (r__2 = + r_imag(&a[k + i__ * a_dim1]), abs(r__2))) + * ((r__3 = b[i__5].r, abs(r__3)) + (r__4 + = r_imag(&b[j + k * b_dim1]), abs(r__4))); +/* L180: */ + } +/* L190: */ + } + } + } + } + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + q__2.r = alpha->r * ct[i__4].r - alpha->i * ct[i__4].i, q__2.i = + alpha->r * ct[i__4].i + alpha->i * ct[i__4].r; + i__5 = i__ + j * c_dim1; + q__3.r = beta->r * c__[i__5].r - beta->i * c__[i__5].i, q__3.i = + beta->r * c__[i__5].i + beta->i * c__[i__5].r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + ct[i__3].r = q__1.r, ct[i__3].i = q__1.i; + i__3 = i__ + j * c_dim1; + g[i__] = ((r__1 = alpha->r, abs(r__1)) + (r__2 = r_imag(alpha), + abs(r__2))) * g[i__] + ((r__3 = beta->r, abs(r__3)) + ( + r__4 = r_imag(beta), abs(r__4))) * ((r__5 = c__[i__3].r, + abs(r__5)) + (r__6 = r_imag(&c__[i__ + j * c_dim1]), abs( + r__6))); +/* L200: */ + } + +/* Compute the error ratio for this result. */ + + *err = 0.f; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__ + j * cc_dim1; + q__2.r = ct[i__3].r - cc[i__4].r, q__2.i = ct[i__3].i - cc[i__4] + .i; + q__1.r = q__2.r, q__1.i = q__2.i; + erri = ((r__1 = q__1.r, abs(r__1)) + (r__2 = r_imag(&q__1), abs( + r__2))) / *eps; + if (g[i__] != 0.f) { + erri /= g[i__]; + } + *err = f2cmax(*err,erri); + if (*err * sqrt(*eps) >= 1.f) { + goto L230; + } +/* L210: */ + } + +/* L220: */ + } + +/* If the loop completes, all results are at least half accurate. */ + goto L250; + +/* Report fatal error. */ + +L230: + *fatal = TRUE_; + printf(" ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HALF ACCURATE *******\n"); + printf(" EXPECTED RESULT COMPUTED RESULT\n"); + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*mv) { + printf("%7d (%15.6g,%15.6g) (%15.6g,%15.6g)\n",i__,ct[i__].r,ct[i__].i,cc[i__+j*cc_dim1].r,cc[i__+j*cc_dim1].i); + } else { + printf("%7d (%15.6g,%15.6g) (%15.6g,%15.6g)\n",i__,cc[i__+j*cc_dim1].r,cc[i__+j*cc_dim1].i,ct[i__].r,ct[i__].i); + } +/* L240: */ + } + if (*n > 1) { + printf(" THESE ARE THE RESULTS FOR COLUMN %d\n",j); + } + +L250: + return 0; + + +/* End of CMMCH. */ + +} /* cmmch_ */ + +logical lce_(complex *ri, complex *rj, integer *lr) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + logical ret_val; + + /* Local variables */ + integer i__; + + +/* Tests if two arrays are identical. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + /* Parameter adjustments */ + --rj; + --ri; + + /* Function Body */ + i__1 = *lr; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + if (ri[i__2].r != rj[i__3].r || ri[i__2].i != rj[i__3].i) { + goto L20; + } +/* L10: */ + } + ret_val = TRUE_; + goto L30; +L20: + ret_val = FALSE_; +L30: + return ret_val; + +/* End of LCE. */ + +} /* lce_ */ + +logical lceres_(char *type__, char *uplo, integer *m, integer *n, complex *aa, + complex *as, integer *lda) +{ + /* System generated locals */ + integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2, i__3, i__4; + logical ret_val; + + /* Local variables */ + integer ibeg, iend, i__, j; + logical upper; + + +/* Tests if selected elements in two arrays are equal. */ + +/* TYPE is 'ge' or 'he' or 'sy'. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + /* Parameter adjustments */ + as_dim1 = *lda; + as_offset = 1 + as_dim1 * 1; + as -= as_offset; + aa_dim1 = *lda; + aa_offset = 1 + aa_dim1 * 1; + aa -= aa_offset; + + /* Function Body */ + upper = *(unsigned char *)uplo == 'U'; + if (s_cmp(type__, "ge", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *lda; + for (i__ = *m + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * aa_dim1; + i__4 = i__ + j * as_dim1; + if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) { + goto L70; + } +/* L10: */ + } +/* L20: */ + } + } else if (s_cmp(type__, "he", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__, + "sy", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (upper) { + ibeg = 1; + iend = j; + } else { + ibeg = j; + iend = *n; + } + i__2 = ibeg - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * aa_dim1; + i__4 = i__ + j * as_dim1; + if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) { + goto L70; + } +/* L30: */ + } + i__2 = *lda; + for (i__ = iend + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * aa_dim1; + i__4 = i__ + j * as_dim1; + if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) { + goto L70; + } +/* L40: */ + } +/* L50: */ + } + } + +/* 60 CONTINUE */ + ret_val = TRUE_; + goto L80; +L70: + ret_val = FALSE_; +L80: + return ret_val; + +/* End of LCERES. */ + +} /* lceres_ */ + +/* Complex */ VOID cbeg_(complex * ret_val, logical *reset) +{ + /* System generated locals */ + real r__1, r__2; + complex q__1; + + /* Local variables */ + static integer i__, j, ic, mi, mj; + + +/* Generates complex numbers as pairs of random numbers uniformly */ +/* distributed between -0.5 and 0.5. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + if (*reset) { +/* Initialize local variables. */ + mi = 891; + mj = 457; + i__ = 7; + j = 7; + ic = 0; + *reset = FALSE_; + } + +/* The sequence of values of I or J is bounded between 1 and 999. */ +/* If initial I or J = 1,2,3,6,7 or 9, the period will be 50. */ +/* If initial I or J = 4 or 8, the period will be 25. */ +/* If initial I or J = 5, the period will be 10. */ +/* IC is used to break up the period by skipping 1 value of I or J */ +/* in 6. */ + + ++ic; +L10: + i__ *= mi; + j *= mj; + i__ -= i__ / 1000 * 1000; + j -= j / 1000 * 1000; + if (ic >= 5) { + ic = 0; + goto L10; + } + r__1 = (i__ - 500) / 1001.f; + r__2 = (j - 500) / 1001.f; + q__1.r = r__1, q__1.i = r__2; + ret_val->r = q__1.r, ret_val->i = q__1.i; + return ; + +/* End of CBEG. */ + +} /* cbeg_ */ + +real sdiff_(real *x, real *y) +{ + /* System generated locals */ + real ret_val; + + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + ret_val = *x - *y; + return ret_val; + +/* End of SDIFF. */ + +} /* sdiff_ */ + +/* Main program alias */ /*int cblat3_ () { MAIN__ (); return 0; }*/ diff --git a/ctest/c_dblat1c.c b/ctest/c_dblat1c.c new file mode 100644 index 000000000..b2efc2384 --- /dev/null +++ b/ctest/c_dblat1c.c @@ -0,0 +1,1331 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif +#if 0 +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +#endif +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i 8) { + goto L40; + } + sa = da1[k - 1]; + sb = db1[k - 1]; + drotgtest_(&sa, &sb, &sc, &ss); + stest1_(&sa, &datrue[k - 1], &datrue[k - 1], sfac); + stest1_(&sb, &dbtrue[k - 1], &dbtrue[k - 1], sfac); + stest1_(&sc, &dc1[k - 1], &dc1[k - 1], sfac); + stest1_(&ss, &ds1[k - 1], &ds1[k - 1], sfac); + } else { + fprintf(stderr, " Shouldn't be here in CHECK0\n"); + exit(0); + } +/* L20: */ + } +L40: + return 0; +} /* check0_ */ + +/* Subroutine */ int check1_(sfac) +doublereal *sfac; +{ + /* Initialized data */ + + static doublereal sa[10] = { .3,-1.,0.,1.,.3,.3,.3,.3,.3,.3 }; + static doublereal dv[80] /* was [8][5][2] */ = { .1,2.,2.,2.,2.,2.,2., + 2.,.3,3.,3.,3.,3.,3.,3.,3.,.3,-.4,4.,4.,4.,4.,4.,4.,.2,-.6,.3,5., + 5.,5.,5.,5.,.1,-.3,.5,-.1,6.,6.,6.,6.,.1,8.,8.,8.,8.,8.,8.,8.,.3, + 9.,9.,9.,9.,9.,9.,9.,.3,2.,-.4,2.,2.,2.,2.,2.,.2,3.,-.6,5.,.3,2., + 2.,2.,.1,4.,-.3,6.,-.5,7.,-.1,3. }; + static doublereal dtrue1[5] = { 0.,.3,.5,.7,.6 }; + static doublereal dtrue3[5] = { 0.,.3,.7,1.1,1. }; + static doublereal dtrue5[80] /* was [8][5][2] */ = { .1,2.,2.,2., + 2.,2.,2.,2.,-.3,3.,3.,3.,3.,3.,3.,3.,0.,0.,4.,4.,4.,4.,4.,4.,.2, + -.6,.3,5.,5.,5.,5.,5.,.03,-.09,.15,-.03,6.,6.,6.,6.,.1,8.,8.,8., + 8.,8.,8.,8.,.09,9.,9.,9.,9.,9.,9.,9.,.09,2.,-.12,2.,2.,2.,2.,2., + .06,3.,-.18,5.,.09,2.,2.,2.,.03,4.,-.09,6.,-.15,7.,-.03,3. }; + static integer itrue2[5] = { 0,1,2,2,3 }; + + /* System generated locals */ + integer i__1; + doublereal d__1; + + /* Local variables */ + static integer i__; + extern doublereal dnrm2test_(); + static doublereal stemp[1], strue[8]; + extern /* Subroutine */ int stest_(), dscaltest_(); + extern doublereal dasumtest_(); + extern /* Subroutine */ int itest1_(), stest1_(); + static doublereal sx[8]; + static integer np1; + extern integer idamaxtest_(); + static integer len; + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Scalars in Common .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ +/* .. Executable Statements .. */ + for (combla_1.incx = 1; combla_1.incx <= 2; ++combla_1.incx) { + for (np1 = 1; np1 <= 5; ++np1) { + combla_1.n = np1 - 1; + len = f2cmax(combla_1.n,1) << 1; +/* .. Set vector arguments .. */ + i__1 = len; + for (i__ = 1; i__ <= i__1; ++i__) { + sx[i__ - 1] = dv[i__ + (np1 + combla_1.incx * 5 << 3) - 49]; +/* L20: */ + } + + if (combla_1.icase == 7) { +/* .. DNRM2TEST .. */ + stemp[0] = dtrue1[np1 - 1]; + d__1 = dnrm2test_(&combla_1.n, sx, &combla_1.incx); + stest1_(&d__1, stemp, stemp, sfac); + } else if (combla_1.icase == 8) { +/* .. DASUMTEST .. */ + stemp[0] = dtrue3[np1 - 1]; + d__1 = dasumtest_(&combla_1.n, sx, &combla_1.incx); + stest1_(&d__1, stemp, stemp, sfac); + } else if (combla_1.icase == 9) { +/* .. DSCALTEST .. */ + dscaltest_(&combla_1.n, &sa[(combla_1.incx - 1) * 5 + np1 - 1] + , sx, &combla_1.incx); + i__1 = len; + for (i__ = 1; i__ <= i__1; ++i__) { + strue[i__ - 1] = dtrue5[i__ + (np1 + combla_1.incx * 5 << + 3) - 49]; +/* L40: */ + } + stest_(&len, sx, strue, strue, sfac); + } else if (combla_1.icase == 10) { +/* .. IDAMAXTEST .. */ + i__1 = idamaxtest_(&combla_1.n, sx, &combla_1.incx); + itest1_(&i__1, &itrue2[np1 - 1]); + } else { + fprintf(stderr, " Shouldn't be here in CHECK1\n"); + exit(0); + } +/* L60: */ + } +/* L80: */ + } + return 0; +} /* check1_ */ + +/* Subroutine */ int check2_(sfac) +doublereal *sfac; +{ + /* Initialized data */ + + static doublereal sa = .3; + static integer incxs[4] = { 1,2,-2,-1 }; + static integer incys[4] = { 1,-2,1,-2 }; + static integer lens[8] /* was [4][2] */ = { 1,1,2,4,1,1,3,7 }; + static integer ns[4] = { 0,1,2,4 }; + static doublereal dx1[7] = { .6,.1,-.5,.8,.9,-.3,-.4 }; + static doublereal dy1[7] = { .5,-.9,.3,.7,-.6,.2,.8 }; + static doublereal dt7[16] /* was [4][4] */ = { 0.,.3,.21,.62,0.,.3,-.07, + .85,0.,.3,-.79,-.74,0.,.3,.33,1.27 }; + static doublereal dt8[112] /* was [7][4][4] */ = { .5,0.,0.,0.,0.,0.,0., + .68,0.,0.,0.,0.,0.,0.,.68,-.87,0.,0.,0.,0.,0.,.68,-.87,.15,.94,0., + 0.,0.,.5,0.,0.,0.,0.,0.,0.,.68,0.,0.,0.,0.,0.,0.,.35,-.9,.48,0., + 0.,0.,0.,.38,-.9,.57,.7,-.75,.2,.98,.5,0.,0.,0.,0.,0.,0.,.68,0., + 0.,0.,0.,0.,0.,.35,-.72,0.,0.,0.,0.,0.,.38,-.63,.15,.88,0.,0.,0., + .5,0.,0.,0.,0.,0.,0.,.68,0.,0.,0.,0.,0.,0.,.68,-.9,.33,0.,0.,0., + 0.,.68,-.9,.33,.7,-.75,.2,1.04 }; + static doublereal dt10x[112] /* was [7][4][4] */ = { .6,0.,0.,0., + 0.,0.,0.,.5,0.,0.,0.,0.,0.,0.,.5,-.9,0.,0.,0.,0.,0.,.5,-.9,.3,.7, + 0.,0.,0.,.6,0.,0.,0.,0.,0.,0.,.5,0.,0.,0.,0.,0.,0.,.3,.1,.5,0.,0., + 0.,0.,.8,.1,-.6,.8,.3,-.3,.5,.6,0.,0.,0.,0.,0.,0.,.5,0.,0.,0.,0., + 0.,0.,-.9,.1,.5,0.,0.,0.,0.,.7,.1,.3,.8,-.9,-.3,.5,.6,0.,0.,0.,0., + 0.,0.,.5,0.,0.,0.,0.,0.,0.,.5,.3,0.,0.,0.,0.,0.,.5,.3,-.6,.8,0., + 0.,0. }; + static doublereal dt10y[112] /* was [7][4][4] */ = { .5,0.,0.,0., + 0.,0.,0.,.6,0.,0.,0.,0.,0.,0.,.6,.1,0.,0.,0.,0.,0.,.6,.1,-.5,.8, + 0.,0.,0.,.5,0.,0.,0.,0.,0.,0.,.6,0.,0.,0.,0.,0.,0.,-.5,-.9,.6,0., + 0.,0.,0.,-.4,-.9,.9,.7,-.5,.2,.6,.5,0.,0.,0.,0.,0.,0.,.6,0.,0.,0., + 0.,0.,0.,-.5,.6,0.,0.,0.,0.,0.,-.4,.9,-.5,.6,0.,0.,0.,.5,0.,0.,0., + 0.,0.,0.,.6,0.,0.,0.,0.,0.,0.,.6,-.9,.1,0.,0.,0.,0.,.6,-.9,.1,.7, + -.5,.2,.8 }; + static doublereal ssize1[4] = { 0.,.3,1.6,3.2 }; + static doublereal ssize2[28] /* was [14][2] */ = { 0.,0.,0.,0.,0., + 0.,0.,0.,0.,0.,0.,0.,0.,0.,1.17,1.17,1.17,1.17,1.17,1.17,1.17, + 1.17,1.17,1.17,1.17,1.17,1.17,1.17 }; + + /* System generated locals */ + integer i__1; + doublereal d__1; + + /* Local variables */ + static integer lenx, leny; + extern doublereal ddottest_(); + static integer i__, j, ksize; + extern /* Subroutine */ int stest_(), dcopytest_(), dswaptest_(), + daxpytest_(), stest1_(); + static integer ki, kn, mx, my; + static doublereal sx[7], sy[7], stx[7], sty[7]; + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Scalars in Common .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ +/* .. Executable Statements .. */ + + for (ki = 1; ki <= 4; ++ki) { + combla_1.incx = incxs[ki - 1]; + combla_1.incy = incys[ki - 1]; + mx = abs(combla_1.incx); + my = abs(combla_1.incy); + + for (kn = 1; kn <= 4; ++kn) { + combla_1.n = ns[kn - 1]; + ksize = f2cmin(2,kn); + lenx = lens[kn + (mx << 2) - 5]; + leny = lens[kn + (my << 2) - 5]; +/* .. Initialize all argument arrays .. */ + for (i__ = 1; i__ <= 7; ++i__) { + sx[i__ - 1] = dx1[i__ - 1]; + sy[i__ - 1] = dy1[i__ - 1]; +/* L20: */ + } + + if (combla_1.icase == 1) { +/* .. DDOTTEST .. */ + d__1 = ddottest_(&combla_1.n, sx, &combla_1.incx, sy, & + combla_1.incy); + stest1_(&d__1, &dt7[kn + (ki << 2) - 5], &ssize1[kn - 1], + sfac); + } else if (combla_1.icase == 2) { +/* .. DAXPYTEST .. */ + daxpytest_(&combla_1.n, &sa, sx, &combla_1.incx, sy, & + combla_1.incy); + i__1 = leny; + for (j = 1; j <= i__1; ++j) { + sty[j - 1] = dt8[j + (kn + (ki << 2)) * 7 - 36]; +/* L40: */ + } + stest_(&leny, sy, sty, &ssize2[ksize * 14 - 14], sfac); + } else if (combla_1.icase == 5) { +/* .. DCOPYTEST .. */ + for (i__ = 1; i__ <= 7; ++i__) { + sty[i__ - 1] = dt10y[i__ + (kn + (ki << 2)) * 7 - 36]; +/* L60: */ + } + dcopytest_(&combla_1.n, sx, &combla_1.incx, sy, & + combla_1.incy); + stest_(&leny, sy, sty, ssize2, &c_b34); + } else if (combla_1.icase == 6) { +/* .. DSWAPTEST .. */ + dswaptest_(&combla_1.n, sx, &combla_1.incx, sy, & + combla_1.incy); + for (i__ = 1; i__ <= 7; ++i__) { + stx[i__ - 1] = dt10x[i__ + (kn + (ki << 2)) * 7 - 36]; + sty[i__ - 1] = dt10y[i__ + (kn + (ki << 2)) * 7 - 36]; +/* L80: */ + } + stest_(&lenx, sx, stx, ssize2, &c_b34); + stest_(&leny, sy, sty, ssize2, &c_b34); + } else { + fprintf(stderr," Shouldn't be here in CHECK2\n"); + exit(0); + } +/* L100: */ + } +/* L120: */ + } + return 0; +} /* check2_ */ + +/* Subroutine */ int check3_(sfac) +doublereal *sfac; +{ + /* Initialized data */ + + static integer incxs[7] = { 1,1,2,2,-2,-1,-2 }; + static integer incys[7] = { 1,2,2,-2,1,-2,-2 }; + static integer ns[5] = { 0,1,2,4,5 }; + static doublereal dx[10] = { .6,.1,-.5,.8,.9,-.3,-.4,.7,.5,.2 }; + static doublereal dy[10] = { .5,-.9,.3,.7,-.6,.2,.8,-.5,.1,-.3 }; + static doublereal sc = .8; + static doublereal ss = .6; + static integer len = 10; + static doublereal param[20] /* was [5][4] */ = { -2.,1.,0.,0.,1.,-1.,.2, + .3,.4,.5,0.,1.,.3,.4,1.,1.,.2,-1.,1.,.5 }; + static doublereal ssize2[20] /* was [10][2] */ = { 0.,0.,0.,0.,0., + 0.,0.,0.,0.,0.,1.17,1.17,1.17,1.17,1.17,1.17,1.17,1.17,1.17,1.17 } + ; + + /* Local variables */ + extern /* Subroutine */ int drot_(), drottest_(); + static integer i__, k, ksize; + extern /* Subroutine */ int drotm_(), stest_(), drotmtest_(); + static integer ki, kn; + static doublereal dparam[5], sx[10], sy[10], stx[10], sty[10]; + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Scalars in Common .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ +/* .. Executable Statements .. */ + + for (ki = 1; ki <= 7; ++ki) { + combla_1.incx = incxs[ki - 1]; + combla_1.incy = incys[ki - 1]; + + for (kn = 1; kn <= 5; ++kn) { + combla_1.n = ns[kn - 1]; + ksize = f2cmin(2,kn); + + if (combla_1.icase == 4) { +/* .. DROTTEST .. */ + for (i__ = 1; i__ <= 10; ++i__) { + sx[i__ - 1] = dx[i__ - 1]; + sy[i__ - 1] = dy[i__ - 1]; + stx[i__ - 1] = dx[i__ - 1]; + sty[i__ - 1] = dy[i__ - 1]; +/* L20: */ + } + drottest_(&combla_1.n, sx, &combla_1.incx, sy, &combla_1.incy, + &sc, &ss); + drot_(&combla_1.n, stx, &combla_1.incx, sty, &combla_1.incy, & + sc, &ss); + stest_(&len, sx, stx, &ssize2[ksize * 10 - 10], sfac); + stest_(&len, sy, sty, &ssize2[ksize * 10 - 10], sfac); + } else if (combla_1.icase == 11) { +/* .. DROTMTEST .. */ + for (i__ = 1; i__ <= 10; ++i__) { + sx[i__ - 1] = dx[i__ - 1]; + sy[i__ - 1] = dy[i__ - 1]; + stx[i__ - 1] = dx[i__ - 1]; + sty[i__ - 1] = dy[i__ - 1]; +/* L90: */ + } + for (i__ = 1; i__ <= 4; ++i__) { + for (k = 1; k <= 5; ++k) { + dparam[k - 1] = param[k + i__ * 5 - 6]; +/* L80: */ + } + drotmtest_(&combla_1.n, sx, &combla_1.incx, sy, & + combla_1.incy, dparam); + drotm_(&combla_1.n, stx, &combla_1.incx, sty, & + combla_1.incy, dparam); + stest_(&len, sx, stx, &ssize2[ksize * 10 - 10], sfac); + stest_(&len, sy, sty, &ssize2[ksize * 10 - 10], sfac); +/* L70: */ + } + } else { + fprintf(stderr," Shouldn't be here in CHECK3\n"); + exit(0); + } +/* L40: */ + } +/* L60: */ + } + return 0; +} /* check3_ */ + +/* Subroutine */ int stest_(len, scomp, strue, ssize, sfac) +integer *len; +doublereal *scomp, *strue, *ssize, *sfac; +{ + /* System generated locals */ + integer i__1; + doublereal d__1, d__2, d__3, d__4, d__5; + + /* Local variables */ + static integer i__; + extern doublereal sdiff_(); + static doublereal sd; + +/* ********************************* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Scalars in Common .. */ +/* .. Local Scalars .. */ +/* .. External Functions .. */ +/* .. Intrinsic Functions .. */ +/* .. Common blocks .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --ssize; + --strue; + --scomp; + + /* Function Body */ + i__1 = *len; + for (i__ = 1; i__ <= i__1; ++i__) { + sd = scomp[i__] - strue[i__]; + d__4 = (d__1 = ssize[i__], abs(d__1)) + (d__2 = *sfac * sd, abs(d__2)) + ; + d__5 = (d__3 = ssize[i__], abs(d__3)); + if (sdiff_(&d__4, &d__5) == 0.) { + goto L40; + } + +/* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I). */ + + if (! combla_1.pass) { + goto L20; + } +/* PRINT FAIL MESSAGE AND HEADER. */ + combla_1.pass = FALSE_; + printf(" FAIL\n"); + printf("CASE N INCX INCY MODE I COMP(I) TRUE(I) DIFFERENCE SIZE(I)\n"); +L20: + printf("%4d %3d %5d %5d %5d %3d %36.8f %36.8f %12.4f %12.4f\n",combla_1.icase, combla_1.n, combla_1.incx, combla_1.incy, combla_1.mode, + i__, scomp[i__], strue[i__], sd, ssize[i__]); +L40: + ; + } + return 0; + +} /* stest_ */ + +/* Subroutine */ int stest1_(scomp1, strue1, ssize, sfac) +doublereal *scomp1, *strue1, *ssize, *sfac; +{ + static doublereal scomp[1], strue[1]; + extern /* Subroutine */ int stest_(); + +/* ************************* STEST1 ***************************** */ + +/* THIS IS AN INTERFACE SUBROUTINE TO ACCOMMODATE 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 .. */ +/* .. Array Arguments .. */ +/* .. Local Arrays .. */ +/* .. External Subroutines .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --ssize; + + /* Function Body */ + scomp[0] = *scomp1; + strue[0] = *strue1; + stest_(&c__1, scomp, strue, &ssize[1], sfac); + + return 0; +} /* stest1_ */ + +doublereal sdiff_(sa, sb) +doublereal *sa, *sb; +{ + /* System generated locals */ + doublereal ret_val; + +/* ********************************* SDIFF ************************** */ +/* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15 */ + +/* .. Scalar Arguments .. */ +/* .. Executable Statements .. */ + ret_val = *sa - *sb; + return ret_val; +} /* sdiff_ */ + +/* Subroutine */ int itest1_(icomp, itrue) +integer *icomp, *itrue; +{ + /* Local variables */ + static integer id; + +/* ********************************* ITEST1 ************************* */ + +/* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR */ +/* EQUALITY. */ +/* C. L. LAWSON, JPL, 1974 DEC 10 */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Scalars in Common .. */ +/* .. Local Scalars .. */ +/* .. Common blocks .. */ +/* .. Executable Statements .. */ + + if (*icomp == *itrue) { + goto L40; + } + +/* HERE ICOMP IS NOT EQUAL TO ITRUE. */ + + if (! combla_1.pass) { + goto L20; + } +/* PRINT FAIL MESSAGE AND HEADER. */ + combla_1.pass = FALSE_; + printf(" FAILn"); + printf("(CASE N INCX INCY MODE COMP TRUE DIFFERENCE\n"); +L20: + id = *icomp - *itrue; + printf("%4d %3d %5d %5d %5d %36d %36d %12d\n",combla_1.icase, combla_1.n, combla_1.incx, combla_1.incy, + combla_1.mode, *icomp, *itrue, id); +L40: + return 0; + +} /* itest1_ */ + +/* Subroutine */ int drot_(n, dx, incx, dy, incy, c__, s) +integer *n; +doublereal *dx; +integer *incx; +doublereal *dy; +integer *incy; +doublereal *c__, *s; +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + static integer i__; + static doublereal dtemp; + static integer ix, iy; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ +/* applies a plane rotation. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + +/* .. Local Scalars .. */ +/* .. */ + /* Parameter adjustments */ + --dy; + --dx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp = *c__ * dx[ix] + *s * dy[iy]; + dy[iy] = *c__ * dy[iy] - *s * dx[ix]; + dx[ix] = dtemp; + ix += *incx; + iy += *incy; +/* L10: */ + } + return 0; +L20: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp = *c__ * dx[i__] + *s * dy[i__]; + dy[i__] = *c__ * dy[i__] - *s * dx[i__]; + dx[i__] = dtemp; +/* L30: */ + } + return 0; +} /* drot_ */ + +/* Subroutine */ int drotm_(n, dx, incx, dy, incy, dparam) +integer *n; +doublereal *dx; +integer *incx; +doublereal *dy; +integer *incy; +doublereal *dparam; +{ + /* Initialized data */ + + static doublereal zero = 0.; + static doublereal two = 2.; + + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + static integer i__; + static doublereal dflag, w, z__; + static integer kx, ky, nsteps; + static doublereal dh11, dh12, dh21, dh22; + + +/* -- Reference BLAS level1 routine (version 3.8.0) -- */ +/* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --dparam; + --dy; + --dx; + + /* Function Body */ +/* .. */ + + dflag = dparam[1]; + if (*n <= 0 || dflag + two == zero) { + return 0; + } + if (*incx == *incy && *incx > 0) { + + nsteps = *n * *incx; + if (dflag < zero) { + dh11 = dparam[2]; + dh12 = dparam[4]; + dh21 = dparam[3]; + dh22 = dparam[5]; + i__1 = nsteps; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + w = dx[i__]; + z__ = dy[i__]; + dx[i__] = w * dh11 + z__ * dh12; + dy[i__] = w * dh21 + z__ * dh22; + } + } else if (dflag == zero) { + dh12 = dparam[4]; + dh21 = dparam[3]; + i__2 = nsteps; + i__1 = *incx; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { + w = dx[i__]; + z__ = dy[i__]; + dx[i__] = w + z__ * dh12; + dy[i__] = w * dh21 + z__; + } + } else { + dh11 = dparam[2]; + dh22 = dparam[5]; + i__1 = nsteps; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + w = dx[i__]; + z__ = dy[i__]; + dx[i__] = w * dh11 + z__; + dy[i__] = -w + dh22 * z__; + } + } + } else { + kx = 1; + ky = 1; + if (*incx < 0) { + kx = (1 - *n) * *incx + 1; + } + if (*incy < 0) { + ky = (1 - *n) * *incy + 1; + } + + if (dflag < zero) { + dh11 = dparam[2]; + dh12 = dparam[4]; + dh21 = dparam[3]; + dh22 = dparam[5]; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + w = dx[kx]; + z__ = dy[ky]; + dx[kx] = w * dh11 + z__ * dh12; + dy[ky] = w * dh21 + z__ * dh22; + kx += *incx; + ky += *incy; + } + } else if (dflag == zero) { + dh12 = dparam[4]; + dh21 = dparam[3]; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + w = dx[kx]; + z__ = dy[ky]; + dx[kx] = w + z__ * dh12; + dy[ky] = w * dh21 + z__; + kx += *incx; + ky += *incy; + } + } else { + dh11 = dparam[2]; + dh22 = dparam[5]; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + w = dx[kx]; + z__ = dy[ky]; + dx[kx] = w * dh11 + z__; + dy[ky] = -w + dh22 * z__; + kx += *incx; + ky += *incy; + } + } + } + return 0; +} /* drotm_ */ + diff --git a/ctest/c_dblat2c.c b/ctest/c_dblat2c.c new file mode 100644 index 000000000..7800c34d0 --- /dev/null +++ b/ctest/c_dblat2c.c @@ -0,0 +1,4230 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif +#if 0 +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +#endif +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i= 0; + + if (trace) { +/* o__1.oerr = 0; + o__1.ounit = ntra; + o__1.ofnmlen = 32; + o__1.ofnm = snaps; + o__1.orl = 0; + o__1.osta = 0; + o__1.oacc = 0; + o__1.ofm = 0; + o__1.oblnk = 0; + f_open(&o__1);*/ + } +/* Read the flag that directs rewinding of the snapshot file. */ + fgets(line,80,stdin); + sscanf(line,"%d",&rewi); + rewi = rewi && trace; +/* Read the flag that directs stopping on any failure. */ + fgets(line,80,stdin); + sscanf(line,"%c",&tmpchar); +/* Read the flag that indicates whether error exits are to be tested. */ + sfatal=FALSE_; + if (tmpchar=='T')sfatal=TRUE_; + fgets(line,80,stdin); + sscanf(line,"%c",&tmpchar); +/* Read the flag that indicates whether error exits are to be tested. */ + tsterr=FALSE_; + if (tmpchar=='T')tsterr=TRUE_; +/* Read the flag that indicates whether row-major data layout to be tested. */ + fgets(line,80,stdin); + sscanf(line,"%d",&layout); +/* Read the threshold value of the test ratio */ + fgets(line,80,stdin); + sscanf(line,"%lf",&thresh); + +/* Read and check the parameter values for the tests. */ + +/* Values of N */ + fgets(line,80,stdin); + sscanf(line,"%d",&nidim); + + if (nidim < 1 || nidim > 9) { + fprintf(stderr,"NUMBER OF VALUES OF N IS LESS THAN 1 OR GREATER THAN 9"); + goto L220; + } + fgets(line,80,stdin); + sscanf(line,"%d %d %d %d %d %d %d %d %d",&idim[0],&idim[1],&idim[2], + &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]); + i__1 = nidim; + for (i__ = 1; i__ <= i__1; ++i__) { + if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) { + fprintf(stderr,"VALUE OF N IS LESS THAN 0 OR GREATER THAN 65\n"); + goto L220; + } +/* L10: */ + } +/* Values of K */ + fgets(line,80,stdin); + sscanf(line,"%d",&nkb); + + if (nkb < 1 || nkb > 7) { + fprintf(stderr,"NUMBER OF VALUES OF K IS LESS THAN 1 OR GREATER THAN 7"); + goto L220; + } + fgets(line,80,stdin); + sscanf(line,"%d %d %d %d %d %d %d",&kb[0],&kb[1],&kb[2],&kb[3],&kb[4],&kb[5],&kb[6]); + i__1 = nkb; + for (i__ = 1; i__ <= i__1; ++i__) { + if (kb[i__ - 1] < 0 ) { + fprintf(stderr,"VALUE OF K IS LESS THAN 0\n"); + goto L230; + } +/* L20: */ + } +/* Values of INCX and INCY */ + fgets(line,80,stdin); + sscanf(line,"%d",&ninc); + + if (ninc < 1 || ninc > 7) { + fprintf(stderr,"NUMBER OF VALUES OF INCX AND INCY IS LESS THAN 1 OR GREATER THAN 7"); + goto L230; + } + + fgets(line,80,stdin); + sscanf(line,"%d %d %d %d %d %d %d",&inc[0],&inc[1],&inc[2],&inc[3],&inc[4],&inc[5],&inc[6]); + i__1 = ninc; + for (i__ = 1; i__ <= i__1; ++i__) { + if (inc[i__ - 1] == 0 || (i__2 = inc[i__ - 1], abs(i__2)) > 2) { + fprintf (stderr,"ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN 2\n"); + goto L230; + } +/* L30: */ + } +/* Values of ALPHA */ + fgets(line,80,stdin); + sscanf(line,"%d",&nalf); + if (nalf < 1 || nalf > 7) { + fprintf(stderr,"VALUE OF ALPHA IS LESS THAN 0 OR GREATER THAN 7\n"); + goto L230; + } + fgets(line,80,stdin); + sscanf(line,"%lf %lf %lf %lf %lf %lf %lf",&alf[0],&alf[1],&alf[2],&alf[3],&alf[4],&alf[5],&alf[6]); + +/* Values of BETA */ + fgets(line,80,stdin); + sscanf(line,"%d",&nbet); + if (nbet < 1 || nbet > 7) { + fprintf(stderr,"VALUE OF BETA IS LESS THAN 0 OR GREATER THAN 7\n"); + goto L230; + } + fgets(line,80,stdin); + sscanf(line,"%lf %lf %lf %lf %lf %lf %lf",&bet[0],&bet[1],&bet[2],&bet[3],&bet[4],&bet[5],&bet[6]); + +/* Report values of parameters. */ + printf("TESTS OF THE DOUBLE PRECISION LEVEL 2 BLAS\nTHE FOLLOWING PARAMETER VALUES WILL BE USED:\n"); + printf(" FOR N"); + for (i__ =1; i__ <=nidim;++i__) printf(" %d",idim[i__-1]); + printf("\n"); + + printf(" FOR K"); + for (i__ =1; i__ <=nkb;++i__) printf(" %d",kb[i__-1]); + printf("\n"); + + printf(" FOR INCX AND INCY"); + for (i__ =1; i__ <=ninc;++i__) printf(" %d",inc[i__-1]); + printf("\n"); + + printf(" FOR ALPHA"); + for (i__ =1; i__ <=nalf;++i__) printf(" %f",alf[i__-1]); + printf("\n"); + printf(" FOR BETA"); + for (i__ =1; i__ <=nbet;++i__) printf(" %f",bet[i__-1]); + printf("\n"); + + if (! tsterr) { + printf(" ERROR-EXITS WILL NOT BE TESTED\n"); + } + printf("ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LESS THAN %f\n",thresh); + + rorder = FALSE_; + corder = FALSE_; + if (layout == 2) { + rorder = TRUE_; + corder = TRUE_; + printf("COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED\n"); + } else if (layout == 1) { + rorder = TRUE_; + printf("ROW-MAJOR DATA LAYOUT IS TESTED\n"); + } else if (layout == 0) { + corder = TRUE_; + printf("COLUMN-MAJOR DATA LAYOUT IS TESTED\n"); + } + +/* Read names of subroutines and flags which indicate */ +/* whether they are to be tested. */ + + for (i__ = 1; i__ <= 16; ++i__) { + ltest[i__ - 1] = FALSE_; +/* L40: */ + } +L50: + if (! fgets(line,80,stdin)) { + goto L80; + } + i__1 = sscanf(line,"%12c %c",snamet,&tmpchar); + ltestt=FALSE_; + if (tmpchar=='T')ltestt=TRUE_; + if (i__1 < 2) { + goto L80; + } + + for (i__ = 1; i__ <= 16; ++i__) { + if (s_cmp(snamet, snames[i__ - 1], (ftnlen)12, (ftnlen)12) == + 0) { + goto L70; + } +/* L60: */ + } + printf("SUBPROGRAM NAME %s NOT RECOGNIZED\n****** TESTS ABANDONED ******\n",snamet); + exit(1); +L70: + ltest[i__ - 1] = ltestt; + goto L50; + +L80: +/* cl__1.cerr = 0; + cl__1.cunit = 5; + cl__1.csta = 0; + f_clos(&cl__1);*/ + +/* Compute EPS (the machine precision). */ + + eps = 1.; +L90: + d__1 = eps + 1.; + if (ddiff_(&d__1, &c_b123) == 0.) { + goto L100; + } + eps *= .5; + goto L90; +L100: + eps += eps; + printf("RELATIVE MACHINE PRECISION IS TAKEN TO BE %9.1g\n",eps); + +/* Check the reliability of DMVCH using exact data. */ + + n = 32; + i__1 = n; + for (j = 1; j <= i__1; ++j) { + i__2 = n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + i__3 = i__ - j + 1; + a[i__ + j * 65 - 66] = (doublereal) f2cmax(i__3,0); +/* L110: */ + } + x[j - 1] = (doublereal) j; + y[j - 1] = 0.; +/* L120: */ + } + i__1 = n; + for (j = 1; j <= i__1; ++j) { + yy[j - 1] = (doublereal) (j * ((j + 1) * j) / 2 - (j + 1) * j * (j - + 1) / 3); +/* L130: */ + } +/* YY holds the exact result. On exit from DMVCH YT holds */ +/* the result computed by DMVCH. */ + *(unsigned char *)trans = 'N'; + dmvch_(trans, &n, &n, &c_b123, a, &c__65, x, &c__1, &c_b135, y, &c__1, yt, + g, yy, &eps, &err, &fatal, &c__6, &c_true, (ftnlen)1); + same = lde_(yy, yt, &n); + if (! same || err != 0.) { + printf("ERROR IN DMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); + printf("DMVCH WAS CALLED WITH TRANS = %s ", trans); + printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); + printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); + printf("****** TESTS ABANDONED ******\n"); + exit(1); + } + *(unsigned char *)trans = 'T'; + dmvch_(trans, &n, &n, &c_b123, a, &c__65, x, &c_n1, &c_b135, y, &c_n1, yt, + g, yy, &eps, &err, &fatal, &c__6, &c_true, (ftnlen)1); + same = lde_(yy, yt, &n); + if (! same || err != 0.) { + printf("ERROR IN DMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); + printf("DMVCH WAS CALLED WITH TRANS = %s ", trans); + printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); + printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); + printf("****** TESTS ABANDONED ******\n"); + exit(1); + } + +/* Test each subroutine in turn. */ + + for (isnum = 1; isnum <= 16; ++isnum) { + if (! ltest[isnum - 1]) { +/* Subprogram is not to be tested. */ + printf("%12s WAS NOT TESTED\n",snames[isnum-1]); + } else { + s_copy(srnamc_1.srnamt, snames[isnum - 1], (ftnlen)12, ( + ftnlen)12); +/* Test error exits. */ + if (tsterr) { + cd2chke_(snames[isnum - 1], (ftnlen)12); + } +/* Test computations. */ + infoc_1.infot = 0; + infoc_1.ok = TRUE_; + fatal = FALSE_; + switch ((int)isnum) { + case 1: goto L140; + case 2: goto L140; + case 3: goto L150; + case 4: goto L150; + case 5: goto L150; + case 6: goto L160; + case 7: goto L160; + case 8: goto L160; + case 9: goto L160; + case 10: goto L160; + case 11: goto L160; + case 12: goto L170; + case 13: goto L180; + case 14: goto L180; + case 15: goto L190; + case 16: goto L190; + } +/* Test DGEMV, 01, and DGBMV, 02. */ +L140: + if (corder) { + dchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, + alf, &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, + as, x, xx, xs, y, yy, ys, yt, g, &c__0, (ftnlen)12); + } + if (rorder) { + dchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, + alf, &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, + as, x, xx, xs, y, yy, ys, yt, g, &c__1, (ftnlen)12); + } + goto L200; +/* Test DSYMV, 03, DSBMV, 04, and DSPMV, 05. */ +L150: + if (corder) { + dchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, + alf, &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, + as, x, xx, xs, y, yy, ys, yt, g, &c__0, (ftnlen)12); + } + if (rorder) { + dchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, + alf, &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, + as, x, xx, xs, y, yy, ys, yt, g, &c__1, (ftnlen)12); + } + goto L200; +/* Test DTRMV, 06, DTBMV, 07, DTPMV, 08, */ +/* DTRSV, 09, DTBSV, 10, and DTPSV, 11. */ +L160: + if (corder) { + dchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &ninc, + inc, &c__65, &c__2, a, aa, as, y, yy, ys, yt, g, z__, + &c__0, (ftnlen)12); + } + if (rorder) { + dchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &ninc, + inc, &c__65, &c__2, a, aa, as, y, yy, ys, yt, g, z__, + &c__1, (ftnlen)12); + } + goto L200; +/* Test DGER, 12. */ +L170: + if (corder) { + dchk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, + ys, yt, g, z__, &c__0, (ftnlen)12); + } + if (rorder) { + dchk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, + ys, yt, g, z__, &c__1, (ftnlen)12); + } + goto L200; +/* Test DSYR, 13, and DSPR, 14. */ +L180: + if (corder) { + dchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, + ys, yt, g, z__, &c__0, (ftnlen)12); + } + if (rorder) { + dchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, + ys, yt, g, z__, &c__1, (ftnlen)12); + } + goto L200; +/* Test DSYR2, 15, and DSPR2, 16. */ +L190: + if (corder) { + dchk6_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, + ys, yt, g, z__, &c__0, (ftnlen)12); + } + if (rorder) { + dchk6_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, + ys, yt, g, z__, &c__1, (ftnlen)12); + } + +L200: + if (fatal && sfatal) { + goto L220; + } + } +/* L210: */ + } + printf("\nEND OF TESTS\n"); + goto L240; + +L220: + printf("\n****** FATAL ERROR - TESTS ABANDONED ******\n"); + goto L240; + +L230: + printf("AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM\n"); + printf("****** TESTS ABANDONED ******\n"); + +L240: + if (trace) { +/* cl__1.cerr = 0; + cl__1.cunit = ntra; + cl__1.csta = 0; + f_clos(&cl__1);*/ + } +/* cl__1.cerr = 0; + cl__1.cunit = 6; + cl__1.csta = 0; + f_clos(&cl__1); + s_stop("", (ftnlen)0);*/ + exit(0); + + +/* End of DBLAT2. */ + +} /* MAIN__ */ + +/* Subroutine */ int 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, sname_len) +char *sname; +doublereal *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nkb, *kb, *nalf; +doublereal *alf; +integer *nbet; +doublereal *bet; +integer *ninc, *inc, *nmax, *incmax; +doublereal *a, *aa, *as, *x, *xx, *xs, *y, *yy, *ys, *yt, *g; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ich[3+1] = "NTC"; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8; + + /* Local variables */ + static doublereal beta; + static integer ldas; + static logical same; + static integer incx, incy; + static logical full, tran, null; + static integer i__, m, n; + extern /* Subroutine */ int dmake_(); + static doublereal alpha; + static logical isame[13]; + extern /* Subroutine */ int dmvch_(); + static integer nargs; + static logical reset; + static integer incxs, incys; + static char trans[1]; + static integer ia, ib, ic; + static logical banded; + static integer nc, nd, im, in, kl, ml, nk, nl, ku, ix, iy, ms, lx, ly, ns; + extern /* Subroutine */ int cdgbmv_(), cdgemv_(); + extern logical lderes_(); + static char ctrans[14]; + static doublereal errmax, transl; + static char transs[1]; + static integer laa, lda; + extern logical lde_(); + static doublereal als, bls, err; + static integer iku, kls, kus; + +/* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --kb; + --alf; + --bet; + --inc; + --g; + --yt; + --y; + --x; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ys; + --yy; + --xs; + --xx; + + /* Function Body */ +/* .. Executable Statements .. */ + full = *(unsigned char *)&sname[8] == 'e'; + banded = *(unsigned char *)&sname[8] == 'b'; +/* Define the number of arguments. */ + if (full) { + nargs = 11; + } else if (banded) { + nargs = 13; + } + + nc = 0; + reset = TRUE_; + errmax = 0.; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; + nd = n / 2 + 1; + + for (im = 1; im <= 2; ++im) { + if (im == 1) { +/* Computing MAX */ + i__2 = n - nd; + m = f2cmax(i__2,0); + } + if (im == 2) { +/* Computing MIN */ + i__2 = n + nd; + m = f2cmin(i__2,*nmax); + } + + if (banded) { + nk = *nkb; + } else { + nk = 1; + } + i__2 = nk; + for (iku = 1; iku <= i__2; ++iku) { + if (banded) { + ku = kb[iku]; +/* Computing MAX */ + i__3 = ku - 1; + kl = f2cmax(i__3,0); + } else { + ku = n - 1; + kl = m - 1; + } +/* Set LDA to 1 more than minimum value if room. */ + if (banded) { + lda = kl + ku + 1; + } else { + lda = m; + } + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L100; + } + laa = lda * n; + null = n <= 0 || m <= 0; + +/* Generate the matrix A. */ + + transl = 0.; + dmake_(sname + 7, " ", " ", &m, &n, &a[a_offset], nmax, &aa[1] + , &lda, &kl, &ku, &reset, &transl, (ftnlen)2, (ftnlen) + 1, (ftnlen)1); + + for (ic = 1; ic <= 3; ++ic) { + *(unsigned char *)trans = *(unsigned char *)&ich[ic - 1]; + if (*(unsigned char *)trans == 'N') { + s_copy(ctrans, " CblasNoTrans", (ftnlen)14, (ftnlen) + 14); + } else if (*(unsigned char *)trans == 'T') { + s_copy(ctrans, " CblasTrans", (ftnlen)14, (ftnlen) + 14); + } else { + s_copy(ctrans, "CblasConjTrans", (ftnlen)14, (ftnlen) + 14); + } + tran = *(unsigned char *)trans == 'T' || *(unsigned char * + )trans == 'C'; + + if (tran) { + ml = n; + nl = m; + } else { + ml = m; + nl = n; + } + + i__3 = *ninc; + for (ix = 1; ix <= i__3; ++ix) { + incx = inc[ix]; + lx = abs(incx) * nl; + +/* Generate the vector X. */ + + transl = .5; + i__4 = abs(incx); + i__5 = nl - 1; + dmake_("ge", " ", " ", &c__1, &nl, &x[1], &c__1, &xx[ + 1], &i__4, &c__0, &i__5, &reset, &transl, ( + ftnlen)2, (ftnlen)1, (ftnlen)1); + if (nl > 1) { + x[nl / 2] = 0.; + xx[abs(incx) * (nl / 2 - 1) + 1] = 0.; + } + + i__4 = *ninc; + for (iy = 1; iy <= i__4; ++iy) { + incy = inc[iy]; + ly = abs(incy) * ml; + + i__5 = *nalf; + for (ia = 1; ia <= i__5; ++ia) { + alpha = alf[ia]; + + i__6 = *nbet; + for (ib = 1; ib <= i__6; ++ib) { + beta = bet[ib]; + +/* Generate the vector Y. */ + + transl = 0.; + i__7 = abs(incy); + i__8 = ml - 1; + dmake_("ge", " ", " ", &c__1, &ml, &y[1], + &c__1, &yy[1], &i__7, &c__0, & + i__8, &reset, &transl, (ftnlen)2, + (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the */ +/* subroutine. */ + + *(unsigned char *)transs = *(unsigned + char *)trans; + ms = m; + ns = n; + kls = kl; + kus = ku; + als = alpha; + i__7 = laa; + for (i__ = 1; i__ <= i__7; ++i__) { + as[i__] = aa[i__]; +/* L10: */ + } + ldas = lda; + i__7 = lx; + for (i__ = 1; i__ <= i__7; ++i__) { + xs[i__] = xx[i__]; +/* L20: */ + } + incxs = incx; + bls = beta; + i__7 = ly; + for (i__ = 1; i__ <= i__7; ++i__) { + ys[i__] = yy[i__]; +/* L30: */ + } + incys = incy; + +/* Call the subroutine. */ + + if (full) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s %14s %3d %3d %4.1f A %3d X %2d %4.1f Y %2d .\n", + nc,sname,ctrans,m,n,alpha,lda,incx,beta,incy); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cdgemv_(iorder, trans, &m, &n, &alpha, + &aa[1], &lda, &xx[1], &incx, + &beta, &yy[1], &incy, (ftnlen) + 1); + } else if (banded) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s %14s %3d %3d %3d %3d %4.1f A %3d %2d %4.1f Y %2d\n", + nc,sname,ctrans,m,n,kl,ku,alpha,lda,incx,beta,incy); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cdgbmv_(iorder, trans, &m, &n, &kl, & + ku, &alpha, &aa[1], &lda, &xx[ + 1], &incx, &beta, &yy[1], & + incy, (ftnlen)1); + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf(" ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******n"); + *fatal = TRUE_; + goto L130; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)trans == *( + unsigned char *)transs; + isame[1] = ms == m; + isame[2] = ns == n; + if (full) { + isame[3] = als == alpha; + isame[4] = lde_(&as[1], &aa[1], &laa); + isame[5] = ldas == lda; + isame[6] = lde_(&xs[1], &xx[1], &lx); + isame[7] = incxs == incx; + isame[8] = bls == beta; + if (null) { + isame[9] = lde_(&ys[1], &yy[1], & + ly); + } else { + i__7 = abs(incy); + isame[9] = lderes_("ge", " ", & + c__1, &ml, &ys[1], &yy[1], + &i__7, (ftnlen)2, ( + ftnlen)1); + } + isame[10] = incys == incy; + } else if (banded) { + isame[3] = kls == kl; + isame[4] = kus == ku; + isame[5] = als == alpha; + isame[6] = lde_(&as[1], &aa[1], &laa); + isame[7] = ldas == lda; + isame[8] = lde_(&xs[1], &xx[1], &lx); + isame[9] = incxs == incx; + isame[10] = bls == beta; + if (null) { + isame[11] = lde_(&ys[1], &yy[1], & + ly); + } else { + i__7 = abs(incy); + isame[11] = lderes_("ge", " ", & + c__1, &ml, &ys[1], &yy[1], + &i__7, (ftnlen)2, ( + ftnlen)1); + } + isame[12] = incys == incy; + } + +/* If data was incorrectly changed, report */ +/* and return. */ + + same = TRUE_; + i__7 = nargs; + for (i__ = 1; i__ <= i__7; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L130; + } + + if (! null) { + +/* Check the result. */ + + dmvch_(trans, &m, &n, &alpha, &a[ + a_offset], nmax, &x[1], &incx, + &beta, &y[1], &incy, &yt[1], + &g[1], &yy[1], eps, &err, + fatal, nout, &c_true, (ftnlen) + 1); + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L130; + } + } else { +/* Avoid repeating tests with M.le.0 or */ +/* N.le.0. */ + goto L110; + } + +/* L50: */ + } + +/* L60: */ + } + +/* L70: */ + } + +/* L80: */ + } + +/* L90: */ + } + +L100: + ; + } + +L110: + ; + } + +/* L120: */ + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%12s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%12s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%12s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);; + } + if (*iorder == 1) { + printf("%12s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);; + } + } + goto L140; + +L130: + printf("******* %12s FAILED ON CALL NUMBER:",sname); + if (full) { + printf("%6d: %12s %14s %3d %3d %4.1f A %3d X %2d %4.1f Y %2d .\n", + nc,sname,ctrans,m,n,alpha,lda,incx,beta,incy); + } else if (banded) { + printf("%6d: %12s %14s %3d %3d %3d %3d %4.1f A %3d %2d %4.1f Y %2d\n", + nc,sname,ctrans,m,n,kl,ku,alpha,lda,incx,beta,incy); + } + +L140: + return 0; + +/* 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', */ +/* $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, */ +/* $ ' - SUSPECT *******' ) */ + +/* End of DCHK1. */ + +} /* dchk1_ */ + +/* Subroutine */ int 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, sname_len) +char *sname; +doublereal *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nkb, *kb, *nalf; +doublereal *alf; +integer *nbet; +doublereal *bet; +integer *ninc, *inc, *nmax, *incmax; +doublereal *a, *aa, *as, *x, *xx, *xs, *y, *yy, *ys, *yt, *g; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ich[2+1] = "UL"; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8; + + /* Local variables */ + static doublereal beta; + static integer ldas; + static logical same; + static integer incx, incy; + static logical full, null; + static char uplo[1]; + static integer i__, k, n; + extern /* Subroutine */ int dmake_(); + static doublereal alpha; + static logical isame[13]; + extern /* Subroutine */ int dmvch_(); + static integer nargs; + static logical reset; + static char cuplo[14]; + static integer incxs, incys; + static char uplos[1]; + static integer ia, ib, ic; + static logical banded; + static integer nc, ik, in; + static logical packed; + static integer nk, ks, ix, iy, ns, lx, ly; + extern logical lderes_(); + extern /* Subroutine */ int cdsbmv_(), cdspmv_(); + static doublereal errmax, transl; + extern /* Subroutine */ int cdsymv_(); + static integer laa, lda; + extern logical lde_(); + static doublereal als, bls, err; + + + + + +/* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --kb; + --alf; + --bet; + --inc; + --g; + --yt; + --y; + --x; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ys; + --yy; + --xs; + --xx; + + /* Function Body */ +/* .. Executable Statements .. */ + full = *(unsigned char *)&sname[8] == 'y'; + banded = *(unsigned char *)&sname[8] == 'b'; + packed = *(unsigned char *)&sname[8] == 'p'; +/* Define the number of arguments. */ + if (full) { + nargs = 10; + } else if (banded) { + nargs = 11; + } else if (packed) { + nargs = 9; + } + + nc = 0; + reset = TRUE_; + errmax = 0.; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; + + if (banded) { + nk = *nkb; + } else { + nk = 1; + } + i__2 = nk; + for (ik = 1; ik <= i__2; ++ik) { + if (banded) { + k = kb[ik]; + } else { + k = n - 1; + } +/* Set LDA to 1 more than minimum value if room. */ + if (banded) { + lda = k + 1; + } else { + lda = n; + } + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L100; + } + if (packed) { + laa = n * (n + 1) / 2; + } else { + laa = lda * n; + } + null = n <= 0; + + for (ic = 1; ic <= 2; ++ic) { + *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1]; + if (*(unsigned char *)uplo == 'U') { + s_copy(cuplo, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cuplo, " CblasLower", (ftnlen)14, (ftnlen)14); + } + +/* Generate the matrix A. */ + + transl = 0.; + dmake_(sname + 7, uplo, " ", &n, &n, &a[a_offset], nmax, &aa[ + 1], &lda, &k, &k, &reset, &transl, (ftnlen)2, (ftnlen) + 1, (ftnlen)1); + + i__3 = *ninc; + for (ix = 1; ix <= i__3; ++ix) { + incx = inc[ix]; + lx = abs(incx) * n; + +/* Generate the vector X. */ + + transl = .5; + i__4 = abs(incx); + i__5 = n - 1; + dmake_("ge", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], & + i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, ( + ftnlen)1, (ftnlen)1); + if (n > 1) { + x[n / 2] = 0.; + xx[abs(incx) * (n / 2 - 1) + 1] = 0.; + } + + i__4 = *ninc; + for (iy = 1; iy <= i__4; ++iy) { + incy = inc[iy]; + ly = abs(incy) * n; + + i__5 = *nalf; + for (ia = 1; ia <= i__5; ++ia) { + alpha = alf[ia]; + + i__6 = *nbet; + for (ib = 1; ib <= i__6; ++ib) { + beta = bet[ib]; + +/* Generate the vector Y. */ + + transl = 0.; + i__7 = abs(incy); + i__8 = n - 1; + dmake_("ge", " ", " ", &c__1, &n, &y[1], & + c__1, &yy[1], &i__7, &c__0, &i__8, & + reset, &transl, (ftnlen)2, (ftnlen)1, + (ftnlen)1); + + ++nc; + +/* Save every datum before calling the */ +/* subroutine. */ + + *(unsigned char *)uplos = *(unsigned char *) + uplo; + ns = n; + ks = k; + als = alpha; + i__7 = laa; + for (i__ = 1; i__ <= i__7; ++i__) { + as[i__] = aa[i__]; +/* L10: */ + } + ldas = lda; + i__7 = lx; + for (i__ = 1; i__ <= i__7; ++i__) { + xs[i__] = xx[i__]; +/* L20: */ + } + incxs = incx; + bls = beta; + i__7 = ly; + for (i__ = 1; i__ <= i__7; ++i__) { + ys[i__] = yy[i__]; +/* L30: */ + } + incys = incy; + +/* Call the subroutine. */ + + if (full) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %3d, %4.1f, A %3d, X %2d, %4.1f Y %2d )..\n", + nc,sname,cuplo,n,alpha,lda,incx,beta,incy); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cdsymv_(iorder, uplo, &n, &alpha, &aa[1], + &lda, &xx[1], &incx, &beta, &yy[1] + , &incy, (ftnlen)1); + } else if (banded) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s %3d, %3d, %4.1f, A %3d, X %2d, %4.1f, Y, %2d ).\n", + nc,sname,cuplo,n,k,alpha,lda,incx,beta,incy); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cdsbmv_(iorder, uplo, &n, &k, &alpha, &aa[ + 1], &lda, &xx[1], &incx, &beta, & + yy[1], &incy, (ftnlen)1); + } else if (packed) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s ( %14s %3d, %4.1f, AP X %2d, %4.1f, Y, %2d ).\n", + nc,sname,cuplo,n,alpha,incx,beta,incy); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cdspmv_(iorder, uplo, &n, &alpha, &aa[1], + &xx[1], &incx, &beta, &yy[1], & + incy, (ftnlen)1); + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf(" ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******n"); + *fatal = TRUE_; + goto L120; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)uplo == *( + unsigned char *)uplos; + isame[1] = ns == n; + if (full) { + isame[2] = als == alpha; + isame[3] = lde_(&as[1], &aa[1], &laa); + isame[4] = ldas == lda; + isame[5] = lde_(&xs[1], &xx[1], &lx); + isame[6] = incxs == incx; + isame[7] = bls == beta; + if (null) { + isame[8] = lde_(&ys[1], &yy[1], &ly); + } else { + i__7 = abs(incy); + isame[8] = lderes_("ge", " ", &c__1, & + n, &ys[1], &yy[1], &i__7, ( + ftnlen)2, (ftnlen)1); + } + isame[9] = incys == incy; + } else if (banded) { + isame[2] = ks == k; + isame[3] = als == alpha; + isame[4] = lde_(&as[1], &aa[1], &laa); + isame[5] = ldas == lda; + isame[6] = lde_(&xs[1], &xx[1], &lx); + isame[7] = incxs == incx; + isame[8] = bls == beta; + if (null) { + isame[9] = lde_(&ys[1], &yy[1], &ly); + } else { + i__7 = abs(incy); + isame[9] = lderes_("ge", " ", &c__1, & + n, &ys[1], &yy[1], &i__7, ( + ftnlen)2, (ftnlen)1); + } + isame[10] = incys == incy; + } else if (packed) { + isame[2] = als == alpha; + isame[3] = lde_(&as[1], &aa[1], &laa); + isame[4] = lde_(&xs[1], &xx[1], &lx); + isame[5] = incxs == incx; + isame[6] = bls == beta; + if (null) { + isame[7] = lde_(&ys[1], &yy[1], &ly); + } else { + i__7 = abs(incy); + isame[7] = lderes_("ge", " ", &c__1, & + n, &ys[1], &yy[1], &i__7, ( + ftnlen)2, (ftnlen)1); + } + isame[8] = incys == incy; + } + +/* If data was incorrectly changed, report and */ +/* return. */ + + same = TRUE_; + i__7 = nargs; + for (i__ = 1; i__ <= i__7; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L120; + } + + if (! null) { + +/* Check the result. */ + + dmvch_("N", &n, &n, &alpha, &a[a_offset], + nmax, &x[1], &incx, &beta, &y[1], + &incy, &yt[1], &g[1], &yy[1], eps, + &err, fatal, nout, &c_true, ( + ftnlen)1); + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L120; + } + } else { +/* Avoid repeating tests with N.le.0 */ + goto L110; + } + +/* L50: */ + } + +/* L60: */ + } + +/* L70: */ + } + +/* L80: */ + } + +/* L90: */ + } + +L100: + ; + } + +L110: + ; + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%12s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%12s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%12s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);; + } + if (*iorder == 1) { + printf("%12s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);; + } + } + goto L130; + +L120: + printf("******* %12s FAILED ON CALL NUMBER:",sname); + + if (full) { + printf("%6d: %12s (%14s, %3d, %4.1f, A %3d, X %2d, %4.1f Y %2d )..\n", + nc,sname,cuplo,n,alpha,lda,incx,beta,incy); + } else if (banded) { + + printf("%6d: %12s (%14s %3d, %3d, %4.1f, A %3d, X %2d, %4.1f, Y, %2d ).\n", + nc,sname,cuplo,n,k,alpha,lda,incx,beta,incy); + } else if (packed) { + printf("%6d: %12s ( %14s %3d, %4.1f, AP X %2d, %4.1f, Y, %2d ).\n", + nc,sname,cuplo,n,alpha,incx,beta,incy); + } + +L130: + return 0; + +/* 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', */ +/* $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, */ +/* $ ' - SUSPECT *******' ) */ + +/* End of DCHK2. */ + +} /* dchk2_ */ + +/* Subroutine */ int 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, sname_len) +char *sname; +doublereal *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nkb, *kb, *ninc, *inc, *nmax, *incmax; +doublereal *a, *aa, *as, *x, *xx, *xs, *xt, *g, *z__; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ichu[2+1] = "UL"; + static char icht[3+1] = "NTC"; + static char ichd[2+1] = "UN"; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + + /* Local variables */ + static char diag[1]; + static integer ldas; + static logical same; + static integer incx; + static logical full, null; + static char uplo[1], cdiag[14]; + static integer i__, k, n; + extern /* Subroutine */ int dmake_(); + static char diags[1]; + static logical isame[13]; + extern /* Subroutine */ int dmvch_(); + static integer nargs; + static logical reset; + static char cuplo[14]; + static integer incxs; + static char trans[1], uplos[1]; + static logical banded; + static integer nc, ik, in; + static logical packed; + static integer nk, ks, ix, ns, lx; + extern logical lderes_(); + extern /* Subroutine */ int cdtbmv_(), cdtbsv_(); + static char ctrans[14]; + static doublereal errmax; + extern /* Subroutine */ int cdtpmv_(), cdtrmv_(); + static doublereal transl; + extern /* Subroutine */ int cdtpsv_(), cdtrsv_(); + static char transs[1]; + static integer laa, icd, lda; + extern logical lde_(); + static integer ict, icu; + static doublereal err; + +/* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --kb; + --inc; + --z__; + --g; + --xt; + --x; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --xs; + --xx; + + /* Function Body */ +/* .. Executable Statements .. */ + full = *(unsigned char *)&sname[8] == 'r'; + banded = *(unsigned char *)&sname[8] == 'b'; + packed = *(unsigned char *)&sname[8] == 'p'; +/* Define the number of arguments. */ + if (full) { + nargs = 8; + } else if (banded) { + nargs = 9; + } else if (packed) { + nargs = 7; + } + + nc = 0; + reset = TRUE_; + errmax = 0.; +/* Set up zero vector for DMVCH. */ + i__1 = *nmax; + for (i__ = 1; i__ <= i__1; ++i__) { + z__[i__] = 0.; +/* L10: */ + } + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; + + if (banded) { + nk = *nkb; + } else { + nk = 1; + } + i__2 = nk; + for (ik = 1; ik <= i__2; ++ik) { + if (banded) { + k = kb[ik]; + } else { + k = n - 1; + } +/* Set LDA to 1 more than minimum value if room. */ + if (banded) { + lda = k + 1; + } else { + lda = n; + } + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L100; + } + if (packed) { + laa = n * (n + 1) / 2; + } else { + laa = lda * n; + } + null = n <= 0; + + for (icu = 1; icu <= 2; ++icu) { + *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; + if (*(unsigned char *)uplo == 'U') { + s_copy(cuplo, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cuplo, " CblasLower", (ftnlen)14, (ftnlen)14); + } + + for (ict = 1; ict <= 3; ++ict) { + *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1] + ; + if (*(unsigned char *)trans == 'N') { + s_copy(ctrans, " CblasNoTrans", (ftnlen)14, (ftnlen) + 14); + } else if (*(unsigned char *)trans == 'T') { + s_copy(ctrans, " CblasTrans", (ftnlen)14, (ftnlen) + 14); + } else { + s_copy(ctrans, "CblasConjTrans", (ftnlen)14, (ftnlen) + 14); + } + + for (icd = 1; icd <= 2; ++icd) { + *(unsigned char *)diag = *(unsigned char *)&ichd[icd + - 1]; + if (*(unsigned char *)diag == 'N') { + s_copy(cdiag, " CblasNonUnit", (ftnlen)14, ( + ftnlen)14); + } else { + s_copy(cdiag, " CblasUnit", (ftnlen)14, ( + ftnlen)14); + } + +/* Generate the matrix A. */ + + transl = 0.; + dmake_(sname + 7, uplo, diag, &n, &n, &a[a_offset], + nmax, &aa[1], &lda, &k, &k, &reset, &transl, ( + ftnlen)2, (ftnlen)1, (ftnlen)1); + + i__3 = *ninc; + for (ix = 1; ix <= i__3; ++ix) { + incx = inc[ix]; + lx = abs(incx) * n; + +/* Generate the vector X. */ + + transl = .5; + i__4 = abs(incx); + i__5 = n - 1; + dmake_("ge", " ", " ", &c__1, &n, &x[1], &c__1, & + xx[1], &i__4, &c__0, &i__5, &reset, & + transl, (ftnlen)2, (ftnlen)1, (ftnlen)1); + if (n > 1) { + x[n / 2] = 0.; + xx[abs(incx) * (n / 2 - 1) + 1] = 0.; + } + + ++nc; + +/* Save every datum before calling the subroutine. */ + + *(unsigned char *)uplos = *(unsigned char *)uplo; + *(unsigned char *)transs = *(unsigned char *) + trans; + *(unsigned char *)diags = *(unsigned char *)diag; + ns = n; + ks = k; + i__4 = laa; + for (i__ = 1; i__ <= i__4; ++i__) { + as[i__] = aa[i__]; +/* L20: */ + } + ldas = lda; + i__4 = lx; + for (i__ = 1; i__ <= i__4; ++i__) { + xs[i__] = xx[i__]; +/* L30: */ + } + incxs = incx; + +/* Call the subroutine. */ + + if (s_cmp(sname + 9, "mv", (ftnlen)2, (ftnlen)2) + == 0) { + if (full) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s,%14s,%14s %3d ,A, %3d, X, %2d ).\n", + nc,sname,cuplo,ctrans,cdiag,n,lda,incx); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cdtrmv_(iorder, uplo, trans, diag, &n, & + aa[1], &lda, &xx[1], &incx, ( + ftnlen)1, (ftnlen)1, (ftnlen)1); + } else if (banded) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s,%14s,%14s %3d, %3d ,A, %3d, X, %2d ).\n", + nc,sname,cuplo,ctrans,cdiag,n,k,lda,incx); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cdtbmv_(iorder, uplo, trans, diag, &n, &k, + &aa[1], &lda, &xx[1], &incx, ( + ftnlen)1, (ftnlen)1, (ftnlen)1); + } else if (packed) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s,%14s,%14s %3d ,AP, X, %2d ).\n", + nc,sname,cuplo,ctrans,cdiag,n,incx); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cdtpmv_(iorder, uplo, trans, diag, &n, & + aa[1], &xx[1], &incx, (ftnlen)1, ( + ftnlen)1, (ftnlen)1); + } + } else if (s_cmp(sname + 9, "sv", (ftnlen)2, ( + ftnlen)2) == 0) { + if (full) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s,%14s,%14s %3d ,A, %3d, X, %2d ).\n", + nc,sname,cuplo,ctrans,cdiag,n,lda,incx); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cdtrsv_(iorder, uplo, trans, diag, &n, & + aa[1], &lda, &xx[1], &incx, ( + ftnlen)1, (ftnlen)1, (ftnlen)1); + } else if (banded) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s,%14s,%14s %3d, %3d ,A, %3d, X, %2d ).\n", + nc,sname,cuplo,ctrans,cdiag,n,k,lda,incx); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cdtbsv_(iorder, uplo, trans, diag, &n, &k, + &aa[1], &lda, &xx[1], &incx, ( + ftnlen)1, (ftnlen)1, (ftnlen)1); + } else if (packed) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s,%14s,%14s %3d ,AP, X, %2d ).\n", + nc,sname,cuplo,ctrans,cdiag,n,incx); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cdtpsv_(iorder, uplo, trans, diag, &n, & + aa[1], &xx[1], &incx, (ftnlen)1, ( + ftnlen)1, (ftnlen)1); + } + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf(" ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******n"); + *fatal = TRUE_; + goto L120; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)uplo == *(unsigned + char *)uplos; + isame[1] = *(unsigned char *)trans == *(unsigned + char *)transs; + isame[2] = *(unsigned char *)diag == *(unsigned + char *)diags; + isame[3] = ns == n; + if (full) { + isame[4] = lde_(&as[1], &aa[1], &laa); + isame[5] = ldas == lda; + if (null) { + isame[6] = lde_(&xs[1], &xx[1], &lx); + } else { + i__4 = abs(incx); + isame[6] = lderes_("ge", " ", &c__1, &n, & + xs[1], &xx[1], &i__4, (ftnlen)2, ( + ftnlen)1); + } + isame[7] = incxs == incx; + } else if (banded) { + isame[4] = ks == k; + isame[5] = lde_(&as[1], &aa[1], &laa); + isame[6] = ldas == lda; + if (null) { + isame[7] = lde_(&xs[1], &xx[1], &lx); + } else { + i__4 = abs(incx); + isame[7] = lderes_("ge", " ", &c__1, &n, & + xs[1], &xx[1], &i__4, (ftnlen)2, ( + ftnlen)1); + } + isame[8] = incxs == incx; + } else if (packed) { + isame[4] = lde_(&as[1], &aa[1], &laa); + if (null) { + isame[5] = lde_(&xs[1], &xx[1], &lx); + } else { + i__4 = abs(incx); + isame[5] = lderes_("ge", " ", &c__1, &n, & + xs[1], &xx[1], &i__4, (ftnlen)2, ( + ftnlen)1); + } + isame[6] = incxs == incx; + } + +/* If data was incorrectly changed, report and */ +/* return. */ + + same = TRUE_; + i__4 = nargs; + for (i__ = 1; i__ <= i__4; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L120; + } + + if (! null) { + if (s_cmp(sname + 9, "mv", (ftnlen)2, (ftnlen) + 2) == 0) { + +/* Check the result. */ + + dmvch_(trans, &n, &n, &c_b123, &a[ + a_offset], nmax, &x[1], &incx, & + c_b135, &z__[1], &incx, &xt[1], & + g[1], &xx[1], eps, &err, fatal, + nout, &c_true, (ftnlen)1); + } else if (s_cmp(sname + 9, "sv", (ftnlen)2, ( + ftnlen)2) == 0) { + +/* Compute approximation to original vector. */ + + i__4 = n; + for (i__ = 1; i__ <= i__4; ++i__) { + z__[i__] = xx[(i__ - 1) * abs(incx) + + 1]; + xx[(i__ - 1) * abs(incx) + 1] = x[i__] + ; +/* L50: */ + } + dmvch_(trans, &n, &n, &c_b123, &a[ + a_offset], nmax, &z__[1], &incx, & + c_b135, &x[1], &incx, &xt[1], &g[ + 1], &xx[1], eps, &err, fatal, + nout, &c_false, (ftnlen)1); + } + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and return. */ + if (*fatal) { + goto L120; + } + } else { +/* Avoid repeating tests with N.le.0. */ + goto L110; + } + +/* L60: */ + } + +/* L70: */ + } + +/* L80: */ + } + +/* L90: */ + } + +L100: + ; + } + +L110: + ; + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%12s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%12s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%12s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);; + } + if (*iorder == 1) { + printf("%12s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);; + } + } + goto L130; + +L120: + printf("******* %12s FAILED ON CALL NUMBER:",sname); + if (full) { + printf("%6d: %12s (%14s,%14s,%14s %3d ,A, %3d, X, %2d ).\n", + nc,sname,cuplo,ctrans,cdiag,n,lda,incx); + } else if (banded) { + printf("%6d: %12s (%14s,%14s,%14s %3d, %3d ,A, %3d, X, %2d ).\n", + nc,sname,cuplo,ctrans,cdiag,n,k,lda,incx); + } else if (packed) { + printf("%6d: %12s (%14s,%14s,%14s %3d ,AP, X, %2d ).\n", + nc,sname,cuplo,ctrans,cdiag,n,incx); + } + +L130: + return 0; + +/* 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', */ +/* $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, */ +/* $ ' - SUSPECT *******' ) */ + +/* End of DCHK3. */ + +} /* dchk3_ */ + +/* Subroutine */ int 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, sname_len) +char *sname; +doublereal *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nalf; +doublereal *alf; +integer *ninc, *inc, *nmax, *incmax; +doublereal *a, *aa, *as, *x, *xx, *xs, *y, *yy, *ys, *yt, *g, *z__; +integer *iorder; +ftnlen sname_len; +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; + + /* Local variables */ + static integer ldas; + static logical same; + static integer incx, incy; + static logical null; + static integer i__, j, m, n; + extern /* Subroutine */ int dmake_(), cdger_(); + static doublereal alpha, w[1]; + static logical isame[13]; + extern /* Subroutine */ int dmvch_(); + static integer nargs; + static logical reset; + static integer incxs, incys, ia, nc, nd, im, in, ms, ix, iy, ns, lx, ly; + extern logical lderes_(); + static doublereal errmax, transl; + static integer laa, lda; + extern logical lde_(); + static doublereal als, err; + + +/* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Executable Statements .. */ +/* Define the number of arguments. */ + /* Parameter adjustments */ + --idim; + --alf; + --inc; + --z__; + --g; + --yt; + --y; + --x; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ys; + --yy; + --xs; + --xx; + + /* Function Body */ + nargs = 9; + + nc = 0; + reset = TRUE_; + errmax = 0.; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; + nd = n / 2 + 1; + + for (im = 1; im <= 2; ++im) { + if (im == 1) { +/* Computing MAX */ + i__2 = n - nd; + m = f2cmax(i__2,0); + } + if (im == 2) { +/* Computing MIN */ + i__2 = n + nd; + m = f2cmin(i__2,*nmax); + } + +/* Set LDA to 1 more than minimum value if room. */ + lda = m; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L110; + } + laa = lda * n; + null = n <= 0 || m <= 0; + + i__2 = *ninc; + for (ix = 1; ix <= i__2; ++ix) { + incx = inc[ix]; + lx = abs(incx) * m; + +/* Generate the vector X. */ + + transl = .5; + i__3 = abs(incx); + i__4 = m - 1; + dmake_("ge", " ", " ", &c__1, &m, &x[1], &c__1, &xx[1], &i__3, + &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1, + (ftnlen)1); + if (m > 1) { + x[m / 2] = 0.; + xx[abs(incx) * (m / 2 - 1) + 1] = 0.; + } + + i__3 = *ninc; + for (iy = 1; iy <= i__3; ++iy) { + incy = inc[iy]; + ly = abs(incy) * n; + +/* Generate the vector Y. */ + + transl = 0.; + i__4 = abs(incy); + i__5 = n - 1; + dmake_("ge", " ", " ", &c__1, &n, &y[1], &c__1, &yy[1], & + i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, ( + ftnlen)1, (ftnlen)1); + if (n > 1) { + y[n / 2] = 0.; + yy[abs(incy) * (n / 2 - 1) + 1] = 0.; + } + + i__4 = *nalf; + for (ia = 1; ia <= i__4; ++ia) { + alpha = alf[ia]; + +/* Generate the matrix A. */ + + transl = 0.; + i__5 = m - 1; + i__6 = n - 1; + dmake_(sname + 7, " ", " ", &m, &n, &a[a_offset], + nmax, &aa[1], &lda, &i__5, &i__6, &reset, & + transl, (ftnlen)2, (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the subroutine. */ + + ms = m; + ns = n; + als = alpha; + i__5 = laa; + for (i__ = 1; i__ <= i__5; ++i__) { + as[i__] = aa[i__]; +/* L10: */ + } + ldas = lda; + i__5 = lx; + for (i__ = 1; i__ <= i__5; ++i__) { + xs[i__] = xx[i__]; +/* L20: */ + } + incxs = incx; + i__5 = ly; + for (i__ = 1; i__ <= i__5; ++i__) { + ys[i__] = yy[i__]; +/* L30: */ + } + incys = incy; + +/* Call the subroutine. */ + + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%3d, %3d) %4.1f, X, %2d, Y, %2d, A, %3d).\n", + nc,sname,m,n,alpha,incx,incy,lda); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cdger_(iorder, &m, &n, &alpha, &xx[1], &incx, &yy[1], + &incy, &aa[1], &lda); + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf(" ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******n"); + *fatal = TRUE_; + goto L140; + } + +/* See what data changed inside subroutine. */ + + isame[0] = ms == m; + isame[1] = ns == n; + isame[2] = als == alpha; + isame[3] = lde_(&xs[1], &xx[1], &lx); + isame[4] = incxs == incx; + isame[5] = lde_(&ys[1], &yy[1], &ly); + isame[6] = incys == incy; + if (null) { + isame[7] = lde_(&as[1], &aa[1], &laa); + } else { + isame[7] = lderes_("ge", " ", &m, &n, &as[1], &aa[ + 1], &lda, (ftnlen)2, (ftnlen)1); + } + isame[8] = ldas == lda; + +/* If data was incorrectly changed, report and return. */ + + same = TRUE_; + i__5 = nargs; + for (i__ = 1; i__ <= i__5; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L140; + } + + if (! null) { + +/* Check the result column by column. */ + + if (incx > 0) { + i__5 = m; + for (i__ = 1; i__ <= i__5; ++i__) { + z__[i__] = x[i__]; +/* L50: */ + } + } else { + i__5 = m; + for (i__ = 1; i__ <= i__5; ++i__) { + z__[i__] = x[m - i__ + 1]; +/* L60: */ + } + } + i__5 = n; + for (j = 1; j <= i__5; ++j) { + if (incy > 0) { + w[0] = y[j]; + } else { + w[0] = y[n - j + 1]; + } + dmvch_("N", &m, &c__1, &alpha, &z__[1], nmax, + w, &c__1, &c_b123, &a[j * a_dim1 + 1], + &c__1, &yt[1], &g[1], &aa[(j - 1) * + lda + 1], eps, &err, fatal, nout, & + c_true, (ftnlen)1); + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and return. */ + if (*fatal) { + goto L130; + } +/* L70: */ + } + } else { +/* Avoid repeating tests with M.le.0 or N.le.0. */ + goto L110; + } + +/* L80: */ + } + +/* L90: */ + } + +/* L100: */ + } + +L110: + ; + } + +/* L120: */ + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%12s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%12s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%12s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);; + } + if (*iorder == 1) { + printf("%12s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);; + } + } + goto L150; + +L130: + printf(" THESE ARE THE RESULTS FOR COLUMN %3d:\n",j); + +L140: + printf("******* %12s FAILED ON CALL NUMBER:\n",sname); + printf("%6d: %12s (%3d, %3d) %4.1f, X, %2d, Y, %2d, A, %3d).\n", + nc,sname,m,n,alpha,incx,incy,lda); + +L150: + return 0; + +/* 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', */ +/* $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, */ +/* $ ' - SUSPECT *******' ) */ + +/* End of DCHK4. */ + +} /* dchk4_ */ + +/* Subroutine */ int 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, sname_len) +char *sname; +doublereal *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nalf; +doublereal *alf; +integer *ninc, *inc, *nmax, *incmax; +doublereal *a, *aa, *as, *x, *xx, *xs, *y, *yy, *ys, *yt, *g, *z__; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ich[2+1] = "UL"; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + + /* Builtin functions */ + + /* Local variables */ + static integer ldas; + static logical same; + static integer incx; + static logical full, null; + static char uplo[1]; + static integer i__, j, n; + extern /* Subroutine */ int dmake_(); + static doublereal alpha, w[1]; + static logical isame[13]; + extern /* Subroutine */ int dmvch_(); + static integer nargs; + extern /* Subroutine */ int cdspr_(); + static logical reset; + static char cuplo[14]; + static integer incxs; + extern /* Subroutine */ int cdsyr_(); + static logical upper; + static char uplos[1]; + static integer ia, ja, ic, nc, jj, lj, in; + static logical packed; + static integer ix, ns, lx; + extern logical lderes_(); + static doublereal errmax, transl; + static integer laa, lda; + extern logical lde_(); + static doublereal als, err; + + +/* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --alf; + --inc; + --z__; + --g; + --yt; + --y; + --x; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ys; + --yy; + --xs; + --xx; + + /* Function Body */ +/* .. Executable Statements .. */ + full = *(unsigned char *)&sname[8] == 'y'; + packed = *(unsigned char *)&sname[8] == 'p'; +/* Define the number of arguments. */ + if (full) { + nargs = 7; + } else if (packed) { + nargs = 6; + } + + nc = 0; + reset = TRUE_; + errmax = 0.; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; +/* Set LDA to 1 more than minimum value if room. */ + lda = n; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L100; + } + if (packed) { + laa = n * (n + 1) / 2; + } else { + laa = lda * n; + } + + for (ic = 1; ic <= 2; ++ic) { + *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1]; + if (*(unsigned char *)uplo == 'U') { + s_copy(cuplo, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cuplo, " CblasLower", (ftnlen)14, (ftnlen)14); + } + upper = *(unsigned char *)uplo == 'U'; + + i__2 = *ninc; + for (ix = 1; ix <= i__2; ++ix) { + incx = inc[ix]; + lx = abs(incx) * n; + +/* Generate the vector X. */ + + transl = .5; + i__3 = abs(incx); + i__4 = n - 1; + dmake_("ge", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &i__3, + &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1, + (ftnlen)1); + if (n > 1) { + x[n / 2] = 0.; + xx[abs(incx) * (n / 2 - 1) + 1] = 0.; + } + + i__3 = *nalf; + for (ia = 1; ia <= i__3; ++ia) { + alpha = alf[ia]; + null = n <= 0 || alpha == 0.; + +/* Generate the matrix A. */ + + transl = 0.; + i__4 = n - 1; + i__5 = n - 1; + dmake_(sname + 7, uplo, " ", &n, &n, &a[a_offset], nmax, & + aa[1], &lda, &i__4, &i__5, &reset, &transl, ( + ftnlen)2, (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the subroutine. */ + + *(unsigned char *)uplos = *(unsigned char *)uplo; + ns = n; + als = alpha; + i__4 = laa; + for (i__ = 1; i__ <= i__4; ++i__) { + as[i__] = aa[i__]; +/* L10: */ + } + ldas = lda; + i__4 = lx; + for (i__ = 1; i__ <= i__4; ++i__) { + xs[i__] = xx[i__]; +/* L20: */ + } + incxs = incx; + +/* Call the subroutine. */ + + if (full) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %3d, %4.1f, X, %2d, A, %3d).\n", + nc,sname,cuplo,alpha,incx,lda); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cdsyr_(iorder, uplo, &n, &alpha, &xx[1], &incx, &aa[1] + , &lda, (ftnlen)1); + } else if (packed) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %3d, %4.1f, X, %2d, AP).\n", + nc,sname,cuplo,n,alpha,incx); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cdspr_(iorder, uplo, &n, &alpha, &xx[1], &incx, &aa[1] + , (ftnlen)1); + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf(" ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******n"); + *fatal = TRUE_; + goto L120; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)uplo == *(unsigned char *) + uplos; + isame[1] = ns == n; + isame[2] = als == alpha; + isame[3] = lde_(&xs[1], &xx[1], &lx); + isame[4] = incxs == incx; + if (null) { + isame[5] = lde_(&as[1], &aa[1], &laa); + } else { + isame[5] = lderes_(sname + 7, uplo, &n, &n, &as[1], & + aa[1], &lda, (ftnlen)2, (ftnlen)1); + } + if (! packed) { + isame[6] = ldas == lda; + } + +/* If data was incorrectly changed, report and return. */ + + same = TRUE_; + i__4 = nargs; + for (i__ = 1; i__ <= i__4; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L30: */ + } + if (! same) { + *fatal = TRUE_; + goto L120; + } + + if (! null) { + +/* Check the result column by column. */ + + if (incx > 0) { + i__4 = n; + for (i__ = 1; i__ <= i__4; ++i__) { + z__[i__] = x[i__]; +/* L40: */ + } + } else { + i__4 = n; + for (i__ = 1; i__ <= i__4; ++i__) { + z__[i__] = x[n - i__ + 1]; +/* L50: */ + } + } + ja = 1; + i__4 = n; + for (j = 1; j <= i__4; ++j) { + w[0] = z__[j]; + if (upper) { + jj = 1; + lj = j; + } else { + jj = j; + lj = n - j + 1; + } + dmvch_("N", &lj, &c__1, &alpha, &z__[jj], &lj, w, + &c__1, &c_b123, &a[jj + j * a_dim1], & + c__1, &yt[1], &g[1], &aa[ja], eps, &err, + fatal, nout, &c_true, (ftnlen)1); + if (full) { + if (upper) { + ja += lda; + } else { + ja = ja + lda + 1; + } + } else { + ja += lj; + } + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and return. */ + if (*fatal) { + goto L110; + } +/* L60: */ + } + } else { +/* Avoid repeating tests if N.le.0. */ + if (n <= 0) { + goto L100; + } + } + +/* L70: */ + } + +/* L80: */ + } + +/* L90: */ + } + +L100: + ; + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%12s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%12s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%12s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);; + } + if (*iorder == 1) { + printf("%12s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);; + } + } + goto L130; + +L110: + printf(" THESE ARE THE RESULTS FOR COLUMN %3d:\n",j); + +L120: + printf("******* %12s FAILED ON CALL NUMBER:\n",sname); + if (full) { + printf("%6d: %12s (%14s, %3d, %4.1f, X, %2d, A, %3d).\n", + nc,sname,cuplo,n,alpha,incx,lda); + } else if (packed) { + printf("%6d: %12s (%14s, %3d, %4.1f, X, %2d, AP).\n", + nc,sname,cuplo,n,alpha,incx); + } + +L130: + return 0; + +/* 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', */ +/* $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, */ +/* $ ' - SUSPECT *******' ) */ + +/* End of DCHK5. */ + +} /* dchk5_ */ + +/* Subroutine */ int 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, sname_len) +char *sname; +doublereal *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nalf; +doublereal *alf; +integer *ninc, *inc, *nmax, *incmax; +doublereal *a, *aa, *as, *x, *xx, *xs, *y, *yy, *ys, *yt, *g, *z__; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ich[2+1] = "UL"; + + /* System generated locals */ + integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, + i__6; + + /* Local variables */ + static integer ldas; + static logical same; + static integer incx, incy; + static logical full, null; + static char uplo[1]; + static integer i__, j, n; + extern /* Subroutine */ int dmake_(); + static doublereal alpha, w[2]; + static logical isame[13]; + extern /* Subroutine */ int dmvch_(); + static integer nargs; + static logical reset; + static char cuplo[14]; + static integer incxs, incys; + static logical upper; + static char uplos[1]; + extern /* Subroutine */ int cdspr2_(), cdsyr2_(); + static integer ia, ja, ic, nc, jj, lj, in; + static logical packed; + static integer ix, iy, ns, lx, ly; + extern logical lderes_(); + static doublereal errmax, transl; + static integer laa, lda; + extern logical lde_(); + static doublereal als, err; + +/* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --alf; + --inc; + z_dim1 = *nmax; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --g; + --yt; + --y; + --x; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ys; + --yy; + --xs; + --xx; + + /* Function Body */ +/* .. Executable Statements .. */ + full = *(unsigned char *)&sname[8] == 'y'; + packed = *(unsigned char *)&sname[8] == 'p'; +/* Define the number of arguments. */ + if (full) { + nargs = 9; + } else if (packed) { + nargs = 8; + } + + nc = 0; + reset = TRUE_; + errmax = 0.; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; +/* Set LDA to 1 more than minimum value if room. */ + lda = n; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L140; + } + if (packed) { + laa = n * (n + 1) / 2; + } else { + laa = lda * n; + } + + for (ic = 1; ic <= 2; ++ic) { + *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1]; + if (*(unsigned char *)uplo == 'U') { + s_copy(cuplo, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cuplo, " CblasLower", (ftnlen)14, (ftnlen)14); + } + upper = *(unsigned char *)uplo == 'U'; + + i__2 = *ninc; + for (ix = 1; ix <= i__2; ++ix) { + incx = inc[ix]; + lx = abs(incx) * n; + +/* Generate the vector X. */ + + transl = .5; + i__3 = abs(incx); + i__4 = n - 1; + dmake_("ge", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &i__3, + &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1, + (ftnlen)1); + if (n > 1) { + x[n / 2] = 0.; + xx[abs(incx) * (n / 2 - 1) + 1] = 0.; + } + + i__3 = *ninc; + for (iy = 1; iy <= i__3; ++iy) { + incy = inc[iy]; + ly = abs(incy) * n; + +/* Generate the vector Y. */ + + transl = 0.; + i__4 = abs(incy); + i__5 = n - 1; + dmake_("ge", " ", " ", &c__1, &n, &y[1], &c__1, &yy[1], & + i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, ( + ftnlen)1, (ftnlen)1); + if (n > 1) { + y[n / 2] = 0.; + yy[abs(incy) * (n / 2 - 1) + 1] = 0.; + } + + i__4 = *nalf; + for (ia = 1; ia <= i__4; ++ia) { + alpha = alf[ia]; + null = n <= 0 || alpha == 0.; + +/* Generate the matrix A. */ + + transl = 0.; + i__5 = n - 1; + i__6 = n - 1; + dmake_(sname + 7, uplo, " ", &n, &n, &a[a_offset], + nmax, &aa[1], &lda, &i__5, &i__6, &reset, & + transl, (ftnlen)2, (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the subroutine. */ + + *(unsigned char *)uplos = *(unsigned char *)uplo; + ns = n; + als = alpha; + i__5 = laa; + for (i__ = 1; i__ <= i__5; ++i__) { + as[i__] = aa[i__]; +/* L10: */ + } + ldas = lda; + i__5 = lx; + for (i__ = 1; i__ <= i__5; ++i__) { + xs[i__] = xx[i__]; +/* L20: */ + } + incxs = incx; + i__5 = ly; + for (i__ = 1; i__ <= i__5; ++i__) { + ys[i__] = yy[i__]; +/* L30: */ + } + incys = incy; + +/* Call the subroutine. */ + + if (full) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %3d, %4.1f, X, %2d, Y, %2d, A, %3d).\n", + nc,sname,cuplo,n,alpha,incx,incy,lda); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cdsyr2_(iorder, uplo, &n, &alpha, &xx[1], &incx, & + yy[1], &incy, &aa[1], &lda, (ftnlen)1); + } else if (packed) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %3d, %4.1f, X, %2d, Y, %2d, AP).\n", + nc,sname,cuplo,n,alpha,incx,incy); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cdspr2_(iorder, uplo, &n, &alpha, &xx[1], &incx, & + yy[1], &incy, &aa[1], (ftnlen)1); + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf(" ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******n"); + *fatal = TRUE_; + goto L160; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)uplo == *(unsigned char * + )uplos; + isame[1] = ns == n; + isame[2] = als == alpha; + isame[3] = lde_(&xs[1], &xx[1], &lx); + isame[4] = incxs == incx; + isame[5] = lde_(&ys[1], &yy[1], &ly); + isame[6] = incys == incy; + if (null) { + isame[7] = lde_(&as[1], &aa[1], &laa); + } else { + isame[7] = lderes_(sname + 7, uplo, &n, &n, &as[1] + , &aa[1], &lda, (ftnlen)2, (ftnlen)1); + } + if (! packed) { + isame[8] = ldas == lda; + } + +/* If data was incorrectly changed, report and return. */ + + same = TRUE_; + i__5 = nargs; + for (i__ = 1; i__ <= i__5; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L160; + } + + if (! null) { + +/* Check the result column by column. */ + + if (incx > 0) { + i__5 = n; + for (i__ = 1; i__ <= i__5; ++i__) { + z__[i__ + z_dim1] = x[i__]; +/* L50: */ + } + } else { + i__5 = n; + for (i__ = 1; i__ <= i__5; ++i__) { + z__[i__ + z_dim1] = x[n - i__ + 1]; +/* L60: */ + } + } + if (incy > 0) { + i__5 = n; + for (i__ = 1; i__ <= i__5; ++i__) { + z__[i__ + (z_dim1 << 1)] = y[i__]; +/* L70: */ + } + } else { + i__5 = n; + for (i__ = 1; i__ <= i__5; ++i__) { + z__[i__ + (z_dim1 << 1)] = y[n - i__ + 1]; +/* L80: */ + } + } + ja = 1; + i__5 = n; + for (j = 1; j <= i__5; ++j) { + w[0] = z__[j + (z_dim1 << 1)]; + w[1] = z__[j + z_dim1]; + if (upper) { + jj = 1; + lj = j; + } else { + jj = j; + lj = n - j + 1; + } + dmvch_("N", &lj, &c__2, &alpha, &z__[jj + + z_dim1], nmax, w, &c__1, &c_b123, &a[ + jj + j * a_dim1], &c__1, &yt[1], &g[1] + , &aa[ja], eps, &err, fatal, nout, & + c_true, (ftnlen)1); + if (full) { + if (upper) { + ja += lda; + } else { + ja = ja + lda + 1; + } + } else { + ja += lj; + } + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and return. */ + if (*fatal) { + goto L150; + } +/* L90: */ + } + } else { +/* Avoid repeating tests with N.le.0. */ + if (n <= 0) { + goto L140; + } + } + +/* L100: */ + } + +/* L110: */ + } + +/* L120: */ + } + +/* L130: */ + } + +L140: + ; + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%12s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%12s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%12s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);; + } + if (*iorder == 1) { + printf("%12s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);; + } + } + goto L170; + +L150: + printf(" THESE ARE THE RESULTS FOR COLUMN %3d:\n",j); + +L160: + printf("******* %12s FAILED ON CALL NUMBER:\n",sname); + if (full) { + printf("%6d: %12s (%14s, %3d, %4.1f, X, %2d, Y, %2d, A, %3d).\n", + nc,sname,cuplo,n,alpha,incx,incy,lda); + } else if (packed) { + printf("%6d: %12s (%14s, %3d, %4.1f, X, %2d, Y, %2d, AP).\n", + nc,sname,cuplo,n,alpha,incx,incy); + } + +L170: + return 0; + +/* 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', */ +/* $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, */ +/* $ ' - SUSPECT *******' ) */ + +/* End of DCHK6. */ + +} /* dchk6_ */ + +/* Subroutine */ int dmake_(type__, uplo, diag, m, n, a, nmax, aa, lda, kl, + ku, reset, transl, type_len, uplo_len, diag_len) +char *type__, *uplo, *diag; +integer *m, *n; +doublereal *a; +integer *nmax; +doublereal *aa; +integer *lda, *kl, *ku; +logical *reset; +doublereal *transl; +ftnlen type_len; +ftnlen uplo_len; +ftnlen diag_len; +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + extern doublereal dbeg_(); + static integer ibeg, iend, ioff; + static logical unit; + static integer i__, j; + static logical lower; + static integer i1, i2, i3; + static logical upper; + static integer kk; + static logical gen, tri, sym; + + +/* Generates values for an M by N matrix A within the bandwidth */ +/* defined by KL and KU. */ +/* Stores the values in the array AA in the data structure required */ +/* by the routine, with unwanted elements set to rogue value. */ + +/* TYPE is 'ge', 'gb', 'sy', 'sb', 'sp', 'tr', 'tb' OR 'tp'. */ + +/* Auxiliary routine for test program for Level 2 Blas. */ + +/* -- Written on 10-August-1987. */ +/* Richard Hanson, Sandia National Labs. */ +/* Jeremy Du Croz, NAG Central Office. */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. External Functions .. */ +/* .. Intrinsic Functions .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --aa; + + /* Function Body */ + gen = *(unsigned char *)type__ == 'g'; + sym = *(unsigned char *)type__ == 's'; + tri = *(unsigned char *)type__ == 't'; + upper = (sym || tri) && *(unsigned char *)uplo == 'U'; + lower = (sym || tri) && *(unsigned char *)uplo == 'L'; + unit = tri && *(unsigned char *)diag == 'U'; + +/* Generate data in array A. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + if (gen || (upper && i__ <= j) || (lower && i__ >= j)) { + if ((i__ <= j && (j - i__ <= *ku)) || (i__ >= j && i__ - j <= *kl)) + { + a[i__ + j * a_dim1] = dbeg_(reset) + *transl; + } else { + a[i__ + j * a_dim1] = 0.; + } + if (i__ != j) { + if (sym) { + a[j + i__ * a_dim1] = a[i__ + j * a_dim1]; + } else if (tri) { + a[j + i__ * a_dim1] = 0.; + } + } + } +/* L10: */ + } + if (tri) { + a[j + j * a_dim1] += 1.; + } + if (unit) { + a[j + j * a_dim1] = 1.; + } +/* L20: */ + } + +/* Store elements in array AS in data structure required by routine. */ + + if (s_cmp(type__, "ge", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + aa[i__ + (j - 1) * *lda] = a[i__ + j * a_dim1]; +/* L30: */ + } + i__2 = *lda; + for (i__ = *m + 1; i__ <= i__2; ++i__) { + aa[i__ + (j - 1) * *lda] = -1e10; +/* L40: */ + } +/* L50: */ + } + } else if (s_cmp(type__, "gb", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *ku + 1 - j; + for (i1 = 1; i1 <= i__2; ++i1) { + aa[i1 + (j - 1) * *lda] = -1e10; +/* L60: */ + } +/* Computing MIN */ + i__3 = *kl + *ku + 1, i__4 = *ku + 1 + *m - j; + i__2 = f2cmin(i__3,i__4); + for (i2 = i1; i2 <= i__2; ++i2) { + aa[i2 + (j - 1) * *lda] = a[i2 + j - *ku - 1 + j * a_dim1]; +/* L70: */ + } + i__2 = *lda; + for (i3 = i2; i3 <= i__2; ++i3) { + aa[i3 + (j - 1) * *lda] = -1e10; +/* L80: */ + } +/* L90: */ + } + } else if (s_cmp(type__, "sy", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__, + "tr", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (upper) { + ibeg = 1; + if (unit) { + iend = j - 1; + } else { + iend = j; + } + } else { + if (unit) { + ibeg = j + 1; + } else { + ibeg = j; + } + iend = *n; + } + i__2 = ibeg - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + aa[i__ + (j - 1) * *lda] = -1e10; +/* L100: */ + } + i__2 = iend; + for (i__ = ibeg; i__ <= i__2; ++i__) { + aa[i__ + (j - 1) * *lda] = a[i__ + j * a_dim1]; +/* L110: */ + } + i__2 = *lda; + for (i__ = iend + 1; i__ <= i__2; ++i__) { + aa[i__ + (j - 1) * *lda] = -1e10; +/* L120: */ + } +/* L130: */ + } + } else if (s_cmp(type__, "sb", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__, + "tb", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (upper) { + kk = *kl + 1; +/* Computing MAX */ + i__2 = 1, i__3 = *kl + 2 - j; + ibeg = f2cmax(i__2,i__3); + if (unit) { + iend = *kl; + } else { + iend = *kl + 1; + } + } else { + kk = 1; + if (unit) { + ibeg = 2; + } else { + ibeg = 1; + } +/* Computing MIN */ + i__2 = *kl + 1, i__3 = *m + 1 - j; + iend = f2cmin(i__2,i__3); + } + i__2 = ibeg - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + aa[i__ + (j - 1) * *lda] = -1e10; +/* L140: */ + } + i__2 = iend; + for (i__ = ibeg; i__ <= i__2; ++i__) { + aa[i__ + (j - 1) * *lda] = a[i__ + j - kk + j * a_dim1]; +/* L150: */ + } + i__2 = *lda; + for (i__ = iend + 1; i__ <= i__2; ++i__) { + aa[i__ + (j - 1) * *lda] = -1e10; +/* L160: */ + } +/* L170: */ + } + } else if (s_cmp(type__, "sp", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__, + "tp", (ftnlen)2, (ftnlen)2) == 0) { + ioff = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (upper) { + ibeg = 1; + iend = j; + } else { + ibeg = j; + iend = *n; + } + i__2 = iend; + for (i__ = ibeg; i__ <= i__2; ++i__) { + ++ioff; + aa[ioff] = a[i__ + j * a_dim1]; + if (i__ == j) { + if (unit) { + aa[ioff] = -1e10; + } + } +/* L180: */ + } +/* L190: */ + } + } + return 0; + +/* End of DMAKE. */ + +} /* dmake_ */ + +/* Subroutine */ int dmvch_(trans, m, n, alpha, a, nmax, x, incx, beta, y, + incy, yt, g, yy, eps, err, fatal, nout, mv, trans_len) +char *trans; +integer *m, *n; +doublereal *alpha, *a; +integer *nmax; +doublereal *x; +integer *incx; +doublereal *beta, *y; +integer *incy; +doublereal *yt, *g, *yy, *eps, *err; +logical *fatal; +integer *nout; +logical *mv; +ftnlen trans_len; +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + doublereal d__1; + + /* Builtin functions */ + double sqrt(); + + /* Local variables */ + static doublereal erri; + static logical tran; + static integer i__, j, incxl, incyl, ml, nl, iy, jx, kx, ky; + +/* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Intrinsic Functions .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --x; + --y; + --yt; + --g; + --yy; + + /* Function Body */ + tran = *(unsigned char *)trans == 'T' || *(unsigned char *)trans == 'C'; + if (tran) { + ml = *n; + nl = *m; + } else { + ml = *m; + nl = *n; + } + if (*incx < 0) { + kx = nl; + incxl = -1; + } else { + kx = 1; + incxl = 1; + } + if (*incy < 0) { + ky = ml; + incyl = -1; + } else { + ky = 1; + incyl = 1; + } + +/* Compute expected result in YT using data in A, X and Y. */ +/* Compute gauges in G. */ + + iy = ky; + i__1 = ml; + for (i__ = 1; i__ <= i__1; ++i__) { + yt[iy] = 0.; + g[iy] = 0.; + jx = kx; + if (tran) { + i__2 = nl; + for (j = 1; j <= i__2; ++j) { + yt[iy] += a[j + i__ * a_dim1] * x[jx]; + g[iy] += (d__1 = a[j + i__ * a_dim1] * x[jx], abs(d__1)); + jx += incxl; +/* L10: */ + } + } else { + i__2 = nl; + for (j = 1; j <= i__2; ++j) { + yt[iy] += a[i__ + j * a_dim1] * x[jx]; + g[iy] += (d__1 = a[i__ + j * a_dim1] * x[jx], abs(d__1)); + jx += incxl; +/* L20: */ + } + } + yt[iy] = *alpha * yt[iy] + *beta * y[iy]; + g[iy] = abs(*alpha) * g[iy] + (d__1 = *beta * y[iy], abs(d__1)); + iy += incyl; +/* L30: */ + } + +/* Compute the error ratio for this result. */ + + *err = 0.; + i__1 = ml; + for (i__ = 1; i__ <= i__1; ++i__) { + erri = (d__1 = yt[i__] - yy[(i__ - 1) * abs(*incy) + 1], abs(d__1)) / + *eps; + if (g[i__] != 0.) { + erri /= g[i__]; + } + *err = f2cmax(*err,erri); + if (*err * sqrt(*eps) >= 1.) { + goto L50; + } +/* L40: */ + } +/* If the loop completes, all results are at least half accurate. */ + goto L70; + +/* Report fatal error. */ + +L50: + *fatal = TRUE_; + printf(" ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HALF ACCURATE *******\n EXPECTED RESULT COMPUTED RESULT\n"); + i__1 = ml; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*mv) { + printf("%7d %18.6g %18.6g\n",i__,yt[i__],yy[(i__ - 1) * abs(*incy) + 1]); + } else { + printf("%7d %18.6g %18.6g\n",i__,yy[(i__ - 1) * abs(*incy) + 1], yt[i__]); + } +/* L60: */ + } + +L70: + return 0; + + +/* End of DMVCH. */ + +} /* dmvch_ */ + +logical lde_(ri, rj, lr) +doublereal *ri, *rj; +integer *lr; +{ + /* System generated locals */ + integer i__1; + logical ret_val; + + /* Local variables */ + static integer i__; + + +/* Tests if two arrays are identical. */ + +/* Auxiliary routine for test program for Level 2 Blas. */ + +/* -- Written on 10-August-1987. */ +/* Richard Hanson, Sandia National Labs. */ +/* Jeremy Du Croz, NAG Central Office. */ + +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + --rj; + --ri; + + /* Function Body */ + i__1 = *lr; + for (i__ = 1; i__ <= i__1; ++i__) { + if (ri[i__] != rj[i__]) { + goto L20; + } +/* L10: */ + } + ret_val = TRUE_; + goto L30; +L20: + ret_val = FALSE_; +L30: + return ret_val; + +/* End of LDE. */ + +} /* lde_ */ + +logical lderes_(type__, uplo, m, n, aa, as, lda, type_len, uplo_len) +char *type__, *uplo; +integer *m, *n; +doublereal *aa, *as; +integer *lda; +ftnlen type_len; +ftnlen uplo_len; +{ + /* System generated locals */ + integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2; + logical ret_val; + + /* Local variables */ + static integer ibeg, iend, i__, j; + static logical upper; + + +/* Tests if selected elements in two arrays are equal. */ + +/* TYPE is 'ge', '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 .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + as_dim1 = *lda; + as_offset = 1 + as_dim1 * 1; + as -= as_offset; + aa_dim1 = *lda; + aa_offset = 1 + aa_dim1 * 1; + aa -= aa_offset; + + /* Function Body */ + upper = *(unsigned char *)uplo == 'U'; + if (s_cmp(type__, "ge", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *lda; + for (i__ = *m + 1; i__ <= i__2; ++i__) { + if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) { + goto L70; + } +/* L10: */ + } +/* L20: */ + } + } else if (s_cmp(type__, "sy", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (upper) { + ibeg = 1; + iend = j; + } else { + ibeg = j; + iend = *n; + } + i__2 = ibeg - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) { + goto L70; + } +/* L30: */ + } + i__2 = *lda; + for (i__ = iend + 1; i__ <= i__2; ++i__) { + if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) { + goto L70; + } +/* L40: */ + } +/* L50: */ + } + } + +/* 60 CONTINUE */ + ret_val = TRUE_; + goto L80; +L70: + ret_val = FALSE_; +L80: + return ret_val; + +/* End of LDERES. */ + +} /* lderes_ */ + +doublereal dbeg_(reset) +logical *reset; +{ + /* System generated locals */ + doublereal ret_val; + + /* Local variables */ + static integer i__, ic, mi; + + +/* 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 .. */ +/* .. Local Scalars .. */ +/* .. Save statement .. */ +/* .. Intrinsic Functions .. */ +/* .. Executable Statements .. */ + if (*reset) { +/* Initialize local variables. */ + mi = 891; + i__ = 7; + ic = 0; + *reset = FALSE_; + } + +/* The sequence of values of I is bounded between 1 and 999. */ +/* If initial I = 1,2,3,6,7 or 9, the period will be 50. */ +/* If initial I = 4 or 8, the period will be 25. */ +/* If initial I = 5, the period will be 10. */ +/* IC is used to break up the period by skipping 1 value of I in 6. */ + + ++ic; +L10: + i__ *= mi; + i__ -= i__ / 1000 * 1000; + if (ic >= 5) { + ic = 0; + goto L10; + } + ret_val = (doublereal) (i__ - 500) / 1001.; + return ret_val; + +/* End of DBEG. */ + +} /* dbeg_ */ + +doublereal ddiff_(x, y) +doublereal *x, *y; +{ + /* System generated locals */ + doublereal ret_val; + + +/* Auxiliary routine for test program for Level 2 Blas. */ + +/* -- Written on 10-August-1987. */ +/* Richard Hanson, Sandia National Labs. */ + +/* .. Scalar Arguments .. */ +/* .. Executable Statements .. */ + ret_val = *x - *y; + return ret_val; + +/* End of DDIFF. */ + +} /* ddiff_ */ + diff --git a/ctest/c_dblat3c.c b/ctest/c_dblat3c.c new file mode 100644 index 000000000..7575d8ee3 --- /dev/null +++ b/ctest/c_dblat3c.c @@ -0,0 +1,3777 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif +#if 0 +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +#endif +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i= 0; + if (trace) { +/* o__1.oerr = 0; + o__1.ounit = ntra; + o__1.ofnmlen = 32; + o__1.ofnm = snaps; + o__1.orl = 0; + o__1.osta = "NEW"; + o__1.oacc = 0; + o__1.ofm = 0; + o__1.oblnk = 0; + f_open(&o__1);*/ + } +/* Read the flag that directs rewinding of the snapshot file. */ + fgets(line,80,stdin); + sscanf(line,"%d",&rewi); + rewi = rewi && trace; +/* Read the flag that directs stopping on any failure. */ + fgets(line,80,stdin); + sscanf(line,"%c",&tmpchar); +/* Read the flag that indicates whether error exits are to be tested. */ + sfatal=FALSE_; + if (tmpchar=='T')sfatal=TRUE_; + fgets(line,80,stdin); + sscanf(line,"%c",&tmpchar); +/* Read the flag that indicates whether error exits are to be tested. */ + tsterr=FALSE_; + if (tmpchar=='T')tsterr=TRUE_; +/* Read the flag that indicates whether row-major data layout to be tested. */ + fgets(line,80,stdin); + sscanf(line,"%d",&layout); +/* Read the threshold value of the test ratio */ + fgets(line,80,stdin); + sscanf(line,"%lf",&thresh); +/* Read and check the parameter values for the tests. */ + +/* Values of N */ + fgets(line,80,stdin); + sscanf(line,"%d",&nidim); + + if (nidim < 1 || nidim > 9) { + fprintf(stderr,"NUMBER OF VALUES OF N IS LESS THAN 1 OR GREATER THAN 9"); + goto L220; + } + fgets(line,80,stdin); + sscanf(line,"%d %d %d %d %d %d %d %d %d",&idim[0],&idim[1],&idim[2], + &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]); + i__1 = nidim; + for (i__ = 1; i__ <= i__1; ++i__) { + if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) { + fprintf(stderr,"VALUE OF N IS LESS THAN 0 OR GREATER THAN 65\n"); + goto L220; + } +/* L10: */ + } +/* Values of ALPHA */ + fgets(line,80,stdin); + sscanf(line,"%d",&nalf); + if (nalf < 1 || nalf > 7) { + fprintf(stderr,"VALUE OF ALPHA IS LESS THAN 0 OR GREATER THAN 7\n"); + goto L220; + } + fgets(line,80,stdin); + sscanf(line,"%lf %lf %lf %lf %lf %lf %lf",&alf[0],&alf[1],&alf[2],&alf[3],&alf[4],&alf[5],&alf[6]); + +/* Values of BETA */ + fgets(line,80,stdin); + sscanf(line,"%d",&nbet); + if (nalf < 1 || nbet > 7) { + fprintf(stderr,"VALUE OF BETA IS LESS THAN 0 OR GREATER THAN 7\n"); + goto L220; + } + fgets(line,80,stdin); + sscanf(line,"%lf %lf %lf %lf %lf %lf %lf",&bet[0],&bet[1],&bet[2],&bet[3],&bet[4],&bet[5],&bet[6]); + +/* Report values of parameters. */ + + printf("TESTS OF THE DOUBLE PRECISION LEVEL 3 BLAS\nTHE FOLLOWING PARAMETER VALUES WILL BE USED:\n"); + printf(" FOR N"); + for (i__ =1; i__ <=nidim;++i__) printf(" %d",idim[i__-1]); + printf("\n"); + printf(" FOR ALPHA"); + for (i__ =1; i__ <=nalf;++i__) printf(" %f",alf[i__-1]); + printf("\n"); + printf(" FOR BETA"); + for (i__ =1; i__ <=nbet;++i__) printf(" %f",bet[i__-1]); + printf("\n"); + + if (! tsterr) { + printf(" ERROR-EXITS WILL NOT BE TESTED\n"); + } + printf("ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LESS THAN %f\n",thresh); + + rorder = FALSE_; + corder = FALSE_; + if (layout == 2) { + rorder = TRUE_; + corder = TRUE_; + printf("COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED\n"); + } else if (layout == 1) { + rorder = TRUE_; + printf("ROW-MAJOR DATA LAYOUT IS TESTED\n"); + } else if (layout == 0) { + corder = TRUE_; + printf("COLUMN-MAJOR DATA LAYOUT IS TESTED\n"); + } + +/* Read names of subroutines and flags which indicate */ +/* whether they are to be tested. */ + + for (i__ = 1; i__ <= 6; ++i__) { + ltest[i__ - 1] = FALSE_; +/* L20: */ + } +L30: + if (! fgets(line,80,stdin)) { + goto L60; + } + i__1 = sscanf(line,"%12c %c",snamet,&tmpchar); + ltestt=FALSE_; + if (tmpchar=='T')ltestt=TRUE_; + if (i__1 < 2) { + goto L60; + } + for (i__ = 1; i__ <= 6; ++i__) { + if (s_cmp(snamet, snames[i__ - 1] , (ftnlen)12, (ftnlen)12) == + 0) { + goto L50; + } +/* L40: */ + } + printf("SUBPROGRAM NAME %s NOT RECOGNIZED\n****** TESTS ABANDONED ******\n",snamet); + exit(1); + + +L50: + ltest[i__ - 1] = ltestt; + goto L30; + +L60: +/* cl__1.cerr = 0; + cl__1.cunit = 5; + cl__1.csta = 0; + f_clos(&cl__1);*/ + +/* Compute EPS (the machine precision). */ + + eps = 1.; +L70: + d__1 = eps + 1.; + if (ddiff_(&d__1, &c_b90) == 0.) { + goto L80; + } + eps *= .5; + goto L70; +L80: + eps += eps; + printf("RELATIVE MACHINE PRECISION IS TAKEN TO BE %9.1g\n",eps); + +/* Check the reliability of DMMCH using exact data. */ + + n = 32; + i__1 = n; + for (j = 1; j <= i__1; ++j) { + i__2 = n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + i__3 = i__ - j + 1; + ab[i__ + j * 65 - 66] = (doublereal) f2cmax(i__3,0); +/* L90: */ + } + ab[j + 4224] = (doublereal) j; + ab[(j + 65) * 65 - 65] = (doublereal) j; + c__[j - 1] = 0.; +/* L100: */ + } + i__1 = n; + for (j = 1; j <= i__1; ++j) { + cc[j - 1] = (doublereal) (j * ((j + 1) * j) / 2 - (j + 1) * j * (j - + 1) / 3); +/* L110: */ + } +/* CC holds the exact result. On exit from DMMCH CT holds */ +/* the result computed by DMMCH. */ + *(unsigned char *)transa = 'N'; + *(unsigned char *)transb = 'N'; + dmmch_(transa, transb, &n, &c__1, &n, &c_b90, ab, &c__65, &ab[4225], & + c__65, &c_b104, c__, &c__65, ct, g, cc, &c__65, &eps, &err, & + fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1); + same = lde_(cc, ct, &n); + if (! same || err != 0.) { + printf("ERROR IN DMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); + printf("DMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); + printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); + printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); + printf("****** TESTS ABANDONED ******\n"); + exit(1); + } + *(unsigned char *)transb = 'T'; + dmmch_(transa, transb, &n, &c__1, &n, &c_b90, ab, &c__65, &ab[4225], & + c__65, &c_b104, c__, &c__65, ct, g, cc, &c__65, &eps, &err, & + fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1); + same = lde_(cc, ct, &n); + if (! same || err != 0.) { + printf("ERROR IN DMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); + printf("DMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); + printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); + printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); + printf("****** TESTS ABANDONED ******\n"); + exit(1); + } + i__1 = n; + for (j = 1; j <= i__1; ++j) { + ab[j + 4224] = (doublereal) (n - j + 1); + ab[(j + 65) * 65 - 65] = (doublereal) (n - j + 1); +/* L120: */ + } + i__1 = n; + for (j = 1; j <= i__1; ++j) { + cc[n - j] = (doublereal) (j * ((j + 1) * j) / 2 - (j + 1) * j * (j - + 1) / 3); +/* L130: */ + } + *(unsigned char *)transa = 'T'; + *(unsigned char *)transb = 'N'; + dmmch_(transa, transb, &n, &c__1, &n, &c_b90, ab, &c__65, &ab[4225], & + c__65, &c_b104, c__, &c__65, ct, g, cc, &c__65, &eps, &err, & + fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1); + same = lde_(cc, ct, &n); + if (! same || err != 0.) { + printf("ERROR IN DMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); + printf("DMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); + printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); + printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); + printf("****** TESTS ABANDONED ******\n"); + exit(1); + } + *(unsigned char *)transb = 'T'; + dmmch_(transa, transb, &n, &c__1, &n, &c_b90, ab, &c__65, &ab[4225], & + c__65, &c_b104, c__, &c__65, ct, g, cc, &c__65, &eps, &err, & + fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1); + same = lde_(cc, ct, &n); + if (! same || err != 0.) { + } + +/* Test each subroutine in turn. */ + + for (isnum = 1; isnum <= 6; ++isnum) { + if (! ltest[isnum - 1]) { +/* Subprogram is not to be tested. */ + printf("%12s WAS NOT TESTED\n",snames[isnum-1]); + } else { + s_copy(srnamc_1.srnamt, snames[isnum - 1], (ftnlen)12, ( + ftnlen)12); +/* Test error exits. */ + if (tsterr) { + cd3chke_(snames[isnum - 1], (ftnlen)12); + } +/* Test computations. */ + infoc_1.infot = 0; + infoc_1.ok = TRUE_; + fatal = FALSE_; + switch ((int)isnum) { + case 1: goto L140; + case 2: goto L150; + case 3: goto L160; + case 4: goto L160; + case 5: goto L170; + case 6: goto L180; + } +/* Test DGEMM, 01. */ +L140: + if (corder) { + dchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__0, (ftnlen)12); + } + if (rorder) { + dchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__1, (ftnlen)12); + } + goto L190; +/* Test DSYMM, 02. */ +L150: + if (corder) { + dchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__0, (ftnlen)12); + } + if (rorder) { + dchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__1, (ftnlen)12); + } + goto L190; +/* Test DTRMM, 03, DTRSM, 04. */ +L160: + if (corder) { + dchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, & + c__0, (ftnlen)12); + } + if (rorder) { + dchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, & + c__1, (ftnlen)12); + } + goto L190; +/* Test DSYRK, 05. */ +L170: + if (corder) { + dchk4_(snames[isnum -1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__0, (ftnlen)12); + } + if (rorder) { + dchk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__1, (ftnlen)12); + } + goto L190; +/* Test DSYR2K, 06. */ +L180: + if (corder) { + dchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, + ct, g, w, &c__0, (ftnlen)12); + } + if (rorder) { + dchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, + ct, g, w, &c__1, (ftnlen)12); + } + goto L190; + +L190: + if (fatal && sfatal) { + goto L210; + } + } +/* L200: */ + } + printf("\nEND OF TESTS\n"); + goto L230; + +L210: + printf("\n****** FATAL ERROR - TESTS ABANDONED ******\n"); + goto L230; + +L220: + printf("AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM\n"); + printf("****** TESTS ABANDONED ******\n"); + +L230: + if (trace) { +/* cl__1.cerr = 0; + cl__1.cunit = ntra; + cl__1.csta = 0; + f_clos(&cl__1);*/ + } +/* cl__1.cerr = 0; + cl__1.cunit = 6; + cl__1.csta = 0; + f_clos(&cl__1);*/ + exit(0); + +/* End of DBLAT3. */ + +} /* MAIN__ */ + +/* Subroutine */ int dchk1_(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, sname_len) +char *sname; +doublereal *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nalf; +doublereal *alf; +integer *nbet; +doublereal *bet; +integer *nmax; +doublereal *a, *aa, *as, *b, *bb, *bs, *c__, *cc, *cs, *ct, *g; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ich[3+1] = "NTC"; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5, i__6; + + /* Builtin functions */ + integer f_rew(), s_wsfe(), e_wsfe(), do_fio(); + + /* Local variables */ + static doublereal beta; + static integer ldas, ldbs, ldcs; + static logical same, null; + static integer i__, k, m, n; + extern /* Subroutine */ int dmake_(); + static doublereal alpha; + extern /* Subroutine */ int dmmch_(); + static logical isame[13], trana, tranb; + static integer nargs; + static logical reset; + extern /* Subroutine */ void dprcn1_(); + static integer ia, ib, ma, mb, na, nb, nc, ik, im, in; + extern /* Subroutine */ int cdgemm_(); + static integer ks, ms, ns; + extern logical lderes_(); + static char tranas[1], tranbs[1], transa[1], transb[1]; + static doublereal errmax; + static integer ica, icb, laa, lbb, lda, lcc, ldb, ldc; + extern logical lde_(); + static doublereal als, bls, err; + +/* Tests DGEMM. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --alf; + --bet; + --g; + --ct; + --cs; + --cc; + c_dim1 = *nmax; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --bs; + --bb; + b_dim1 = *nmax; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ +/* .. Executable Statements .. */ + + nargs = 13; + nc = 0; + reset = TRUE_; + errmax = 0.; + + i__1 = *nidim; + for (im = 1; im <= i__1; ++im) { + m = idim[im]; + + i__2 = *nidim; + for (in = 1; in <= i__2; ++in) { + n = idim[in]; +/* Set LDC to 1 more than minimum value if room. */ + ldc = m; + if (ldc < *nmax) { + ++ldc; + } +/* Skip tests if not enough room. */ + if (ldc > *nmax) { + goto L100; + } + lcc = ldc * n; + null = n <= 0 || m <= 0; + + i__3 = *nidim; + for (ik = 1; ik <= i__3; ++ik) { + k = idim[ik]; + + for (ica = 1; ica <= 3; ++ica) { + *(unsigned char *)transa = *(unsigned char *)&ich[ica - 1] + ; + trana = *(unsigned char *)transa == 'T' || *(unsigned + char *)transa == 'C'; + + if (trana) { + ma = k; + na = m; + } else { + ma = m; + na = k; + } +/* Set LDA to 1 more than minimum value if room. */ + lda = ma; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L80; + } + laa = lda * na; + +/* Generate the matrix A. */ + + dmake_("GE", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[ + 1], &lda, &reset, &c_b104, (ftnlen)2, (ftnlen)1, ( + ftnlen)1); + + for (icb = 1; icb <= 3; ++icb) { + *(unsigned char *)transb = *(unsigned char *)&ich[icb + - 1]; + tranb = *(unsigned char *)transb == 'T' || *(unsigned + char *)transb == 'C'; + + if (tranb) { + mb = n; + nb = k; + } else { + mb = k; + nb = n; + } +/* Set LDB to 1 more than minimum value if room. */ + ldb = mb; + if (ldb < *nmax) { + ++ldb; + } +/* Skip tests if not enough room. */ + if (ldb > *nmax) { + goto L70; + } + lbb = ldb * nb; + +/* Generate the matrix B. */ + + dmake_("GE", " ", " ", &mb, &nb, &b[b_offset], nmax, & + bb[1], &ldb, &reset, &c_b104, (ftnlen)2, ( + ftnlen)1, (ftnlen)1); + + i__4 = *nalf; + for (ia = 1; ia <= i__4; ++ia) { + alpha = alf[ia]; + + i__5 = *nbet; + for (ib = 1; ib <= i__5; ++ib) { + beta = bet[ib]; + +/* Generate the matrix C. */ + + dmake_("GE", " ", " ", &m, &n, &c__[c_offset], + nmax, &cc[1], &ldc, &reset, &c_b104, + (ftnlen)2, (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the */ +/* subroutine. */ + + *(unsigned char *)tranas = *(unsigned char *) + transa; + *(unsigned char *)tranbs = *(unsigned char *) + transb; + ms = m; + ns = n; + ks = k; + als = alpha; + i__6 = laa; + for (i__ = 1; i__ <= i__6; ++i__) { + as[i__] = aa[i__]; +/* L10: */ + } + ldas = lda; + i__6 = lbb; + for (i__ = 1; i__ <= i__6; ++i__) { + bs[i__] = bb[i__]; +/* L20: */ + } + ldbs = ldb; + bls = beta; + i__6 = lcc; + for (i__ = 1; i__ <= i__6; ++i__) { + cs[i__] = cc[i__]; +/* L30: */ + } + ldcs = ldc; + +/* Call the subroutine. */ + + if (*trace) { + dprcn1_(ntra, &nc, sname, iorder, transa, + transb, &m, &n, &k, &alpha, &lda, + &ldb, &beta, &ldc, (ftnlen)12, ( + ftnlen)1, (ftnlen)1); + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cdgemm_(iorder, transa, transb, &m, &n, &k, & + alpha, &aa[1], &lda, &bb[1], &ldb, & + beta, &cc[1], &ldc, (ftnlen)1, ( + ftnlen)1); + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf(" *** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + *fatal = TRUE_; + goto L120; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)transa == *( + unsigned char *)tranas; + isame[1] = *(unsigned char *)transb == *( + unsigned char *)tranbs; + isame[2] = ms == m; + isame[3] = ns == n; + isame[4] = ks == k; + isame[5] = als == alpha; + isame[6] = lde_(&as[1], &aa[1], &laa); + isame[7] = ldas == lda; + isame[8] = lde_(&bs[1], &bb[1], &lbb); + isame[9] = ldbs == ldb; + isame[10] = bls == beta; + if (null) { + isame[11] = lde_(&cs[1], &cc[1], &lcc); + } else { + isame[11] = lderes_("GE", " ", &m, &n, & + cs[1], &cc[1], &ldc, (ftnlen)2, ( + ftnlen)1); + } + isame[12] = ldcs == ldc; + +/* If data was incorrectly changed, report */ +/* and return. */ + + same = TRUE_; + i__6 = nargs; + for (i__ = 1; i__ <= i__6; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L120; + } + + if (! null) { + +/* Check the result. */ + + dmmch_(transa, transb, &m, &n, &k, &alpha, + &a[a_offset], nmax, &b[b_offset], + nmax, &beta, &c__[c_offset], + nmax, &ct[1], &g[1], &cc[1], &ldc, + eps, &err, fatal, nout, &c_true, + (ftnlen)1, (ftnlen)1); + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L120; + } + } + +/* L50: */ + } + +/* L60: */ + } + +L70: + ; + } + +L80: + ; + } + +/* L90: */ + } + +L100: + ; + } + +/* L110: */ + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + if (*iorder == 1) { + printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + } + goto L130; + +L120: + printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + dprcn1_(nout, &nc, sname, iorder, transa, transb, &m, &n, &k, &alpha, & + lda, &ldb, &beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); + +L130: + return 0; + +/* 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',', */ +/* $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ', */ +/* $ 'C,', I3, ').' ) */ + +/* End of DCHK1. */ + +} /* dchk1_ */ + +/* Subroutine */ void dprcn1_(nout, nc, sname, iorder, transa, transb, m, n, k, + alpha, lda, ldb, beta, ldc, sname_len, transa_len, transb_len) +integer *nout, *nc; +char *sname; +integer *iorder; +char *transa, *transb; +integer *m, *n, *k; +doublereal *alpha; +integer *lda, *ldb; +doublereal *beta; +integer *ldc; +ftnlen sname_len; +ftnlen transa_len; +ftnlen transb_len; +{ + /* Builtin functions */ + integer s_wsfe(), do_fio(), e_wsfe(); + + /* Local variables */ + static char crc[14], cta[14], ctb[14]; + + if (*(unsigned char *)transa == 'N') { + s_copy(cta, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transa == 'T') { + s_copy(cta, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cta, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)transb == 'N') { + s_copy(ctb, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transb == 'T') { + s_copy(ctb, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(ctb, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*iorder == 1) { + s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); + } else { + s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); + } + printf("%6d: %s %s %s %s\n",*nc,sname,crc,cta,ctb); + printf("%d %d %d %4.1f A, %d, B, %d, %4.1f, C, %d.\n",*m,*n,*k,*alpha,*lda,*ldb,*beta,*ldc); +} /* dprcn1_ */ + + +/* Subroutine */ int dchk2_(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, sname_len) +char *sname; +doublereal *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nalf; +doublereal *alf; +integer *nbet; +doublereal *bet; +integer *nmax; +doublereal *a, *aa, *as, *b, *bb, *bs, *c__, *cc, *cs, *ct, *g; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ichs[2+1] = "LR"; + static char ichu[2+1] = "UL"; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5; + + /* Builtin functions */ + integer f_rew(), s_wsfe(), e_wsfe(), do_fio(); + + /* Local variables */ + static doublereal beta; + static integer ldas, ldbs, ldcs; + static logical same; + static char side[1]; + static logical left, null; + static char uplo[1]; + static integer i__, m, n; + extern /* Subroutine */ int dmake_(); + static doublereal alpha; + extern /* Subroutine */ int dmmch_(); + static logical isame[13]; + static char sides[1]; + static integer nargs; + static logical reset; + static char uplos[1]; + extern /* Subroutine */ void dprcn2_(); + static integer ia, ib, na, nc, im, in, ms, ns; + extern logical lderes_(); + extern /* Subroutine */ int cdsymm_(); + static doublereal errmax; + static integer laa, lbb, lda, lcc, ldb, ldc; + extern logical lde_(); + static integer ics; + static doublereal als, bls; + static integer icu; + static doublereal err; + +/* Tests DSYMM. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --alf; + --bet; + --g; + --ct; + --cs; + --cc; + c_dim1 = *nmax; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --bs; + --bb; + b_dim1 = *nmax; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ +/* .. Executable Statements .. */ + + nargs = 12; + nc = 0; + reset = TRUE_; + errmax = 0.; + + i__1 = *nidim; + for (im = 1; im <= i__1; ++im) { + m = idim[im]; + + i__2 = *nidim; + for (in = 1; in <= i__2; ++in) { + n = idim[in]; +/* Set LDC to 1 more than minimum value if room. */ + ldc = m; + if (ldc < *nmax) { + ++ldc; + } +/* Skip tests if not enough room. */ + if (ldc > *nmax) { + goto L90; + } + lcc = ldc * n; + null = n <= 0 || m <= 0; + +/* Set LDB to 1 more than minimum value if room. */ + ldb = m; + if (ldb < *nmax) { + ++ldb; + } +/* Skip tests if not enough room. */ + if (ldb > *nmax) { + goto L90; + } + lbb = ldb * n; + +/* Generate the matrix B. */ + + dmake_("GE", " ", " ", &m, &n, &b[b_offset], nmax, &bb[1], &ldb, & + reset, &c_b104, (ftnlen)2, (ftnlen)1, (ftnlen)1); + + for (ics = 1; ics <= 2; ++ics) { + *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1]; + left = *(unsigned char *)side == 'L'; + + if (left) { + na = m; + } else { + na = n; + } +/* Set LDA to 1 more than minimum value if room. */ + lda = na; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L80; + } + laa = lda * na; + + for (icu = 1; icu <= 2; ++icu) { + *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; + +/* Generate the symmetric matrix A. */ + + dmake_("SY", uplo, " ", &na, &na, &a[a_offset], nmax, &aa[ + 1], &lda, &reset, &c_b104, (ftnlen)2, (ftnlen)1, ( + ftnlen)1); + + i__3 = *nalf; + for (ia = 1; ia <= i__3; ++ia) { + alpha = alf[ia]; + + i__4 = *nbet; + for (ib = 1; ib <= i__4; ++ib) { + beta = bet[ib]; + +/* Generate the matrix C. */ + + dmake_("GE", " ", " ", &m, &n, &c__[c_offset], + nmax, &cc[1], &ldc, &reset, &c_b104, ( + ftnlen)2, (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the */ +/* subroutine. */ + + *(unsigned char *)sides = *(unsigned char *)side; + *(unsigned char *)uplos = *(unsigned char *)uplo; + ms = m; + ns = n; + als = alpha; + i__5 = laa; + for (i__ = 1; i__ <= i__5; ++i__) { + as[i__] = aa[i__]; +/* L10: */ + } + ldas = lda; + i__5 = lbb; + for (i__ = 1; i__ <= i__5; ++i__) { + bs[i__] = bb[i__]; +/* L20: */ + } + ldbs = ldb; + bls = beta; + i__5 = lcc; + for (i__ = 1; i__ <= i__5; ++i__) { + cs[i__] = cc[i__]; +/* L30: */ + } + ldcs = ldc; + +/* Call the subroutine. */ + + if (*trace) { + dprcn2_(ntra, &nc, sname, iorder, side, uplo, + &m, &n, &alpha, &lda, &ldb, &beta, & + ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1) + ; + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cdsymm_(iorder, side, uplo, &m, &n, &alpha, &aa[1] + , &lda, &bb[1], &ldb, &beta, &cc[1], &ldc, + (ftnlen)1, (ftnlen)1); + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + *fatal = TRUE_; + goto L110; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)sides == *(unsigned + char *)side; + isame[1] = *(unsigned char *)uplos == *(unsigned + char *)uplo; + isame[2] = ms == m; + isame[3] = ns == n; + isame[4] = als == alpha; + isame[5] = lde_(&as[1], &aa[1], &laa); + isame[6] = ldas == lda; + isame[7] = lde_(&bs[1], &bb[1], &lbb); + isame[8] = ldbs == ldb; + isame[9] = bls == beta; + if (null) { + isame[10] = lde_(&cs[1], &cc[1], &lcc); + } else { + isame[10] = lderes_("GE", " ", &m, &n, &cs[1], + &cc[1], &ldc, (ftnlen)2, (ftnlen)1); + } + isame[11] = ldcs == ldc; + +/* If data was incorrectly changed, report and */ +/* return. */ + + same = TRUE_; + i__5 = nargs; + for (i__ = 1; i__ <= i__5; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L110; + } + + if (! null) { + +/* Check the result. */ + + if (left) { + dmmch_("N", "N", &m, &n, &m, &alpha, &a[ + a_offset], nmax, &b[b_offset], + nmax, &beta, &c__[c_offset], nmax, + &ct[1], &g[1], &cc[1], &ldc, eps, + &err, fatal, nout, &c_true, ( + ftnlen)1, (ftnlen)1); + } else { + dmmch_("N", "N", &m, &n, &n, &alpha, &b[ + b_offset], nmax, &a[a_offset], + nmax, &beta, &c__[c_offset], nmax, + &ct[1], &g[1], &cc[1], &ldc, eps, + &err, fatal, nout, &c_true, ( + ftnlen)1, (ftnlen)1); + } + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L110; + } + } + +/* L50: */ + } + +/* L60: */ + } + +/* L70: */ + } + +L80: + ; + } + +L90: + ; + } + +/* L100: */ + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + if (*iorder == 1) { + printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + } + goto L120; + +L110: + printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + dprcn2_(nout, &nc, sname, iorder, side, uplo, &m, &n, &alpha, &lda, &ldb, + &beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); + +L120: + return 0; + +/* 9995 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ +/* $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', */ +/* $ ' .' ) */ + +/* End of DCHK2. */ + +} /* dchk2_ */ + + +/* Subroutine */ void dprcn2_(nout, nc, sname, iorder, side, uplo, m, n, alpha, + lda, ldb, beta, ldc, sname_len, side_len, uplo_len) +integer *nout, *nc; +char *sname; +integer *iorder; +char *side, *uplo; +integer *m, *n; +doublereal *alpha; +integer *lda, *ldb; +doublereal *beta; +integer *ldc; +ftnlen sname_len; +ftnlen side_len; +ftnlen uplo_len; +{ + /* Builtin functions */ + integer s_wsfe(), do_fio(), e_wsfe(); + + /* Local variables */ + static char cs[14], cu[14], crc[14]; + + if (*(unsigned char *)side == 'L') { + s_copy(cs, " CblasLeft", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cs, " CblasRight", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)uplo == 'U') { + s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); + } + if (*iorder == 1) { + s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); + } else { + s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); + } + printf("%6d: %s %s %s %s\n",*nc,sname,crc,cs,cu); + printf("%d %d %4.1f A, %d, B, %d, %4.1f C, %d.\n",*m,*n,*alpha,*lda,*ldb,*beta,*ldc); +} /* dprcn2_ */ + + +/* Subroutine */ int dchk3_(sname, eps, thresh, nout, ntra, trace, rewi, + fatal, nidim, idim, nalf, alf, nmax, a, aa, as, b, bb, bs, ct, g, c__, + iorder, sname_len) +char *sname; +doublereal *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nalf; +doublereal *alf; +integer *nmax; +doublereal *a, *aa, *as, *b, *bb, *bs, *ct, *g, *c__; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ichu[2+1] = "UL"; + static char icht[3+1] = "NTC"; + static char ichd[2+1] = "UN"; + static char ichs[2+1] = "LR"; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5; + + /* Local variables */ + static char diag[1]; + static integer ldas, ldbs; + static logical same; + static char side[1]; + static logical left, null; + static char uplo[1]; + static integer i__, j, m, n; + extern /* Subroutine */ int dmake_(); + static doublereal alpha; + static char diags[1]; + extern /* Subroutine */ int dmmch_(); + static logical isame[13]; + static char sides[1]; + static integer nargs; + static logical reset; + static char uplos[1]; + extern /* Subroutine */ void dprcn3_(); + static integer ia, na, nc, im, in, ms, ns; + extern logical lderes_(); + extern /* Subroutine */ int cdtrmm_(); + static char tranas[1], transa[1]; + extern /* Subroutine */ int cdtrsm_(); + static doublereal errmax; + static integer laa, icd, lbb, lda, ldb; + extern logical lde_(); + static integer ics; + static doublereal als; + static integer ict, icu; + static doublereal err; + +/* Tests DTRMM and DTRSM. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --alf; + c_dim1 = *nmax; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --g; + --ct; + --bs; + --bb; + b_dim1 = *nmax; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ +/* .. Executable Statements .. */ + + nargs = 11; + nc = 0; + reset = TRUE_; + errmax = 0.; +/* Set up zero matrix for DMMCH. */ + i__1 = *nmax; + for (j = 1; j <= i__1; ++j) { + i__2 = *nmax; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; +/* L10: */ + } +/* L20: */ + } + + i__1 = *nidim; + for (im = 1; im <= i__1; ++im) { + m = idim[im]; + + i__2 = *nidim; + for (in = 1; in <= i__2; ++in) { + n = idim[in]; +/* Set LDB to 1 more than minimum value if room. */ + ldb = m; + if (ldb < *nmax) { + ++ldb; + } +/* Skip tests if not enough room. */ + if (ldb > *nmax) { + goto L130; + } + lbb = ldb * n; + null = m <= 0 || n <= 0; + + for (ics = 1; ics <= 2; ++ics) { + *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1]; + left = *(unsigned char *)side == 'L'; + if (left) { + na = m; + } else { + na = n; + } +/* Set LDA to 1 more than minimum value if room. */ + lda = na; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L130; + } + laa = lda * na; + + for (icu = 1; icu <= 2; ++icu) { + *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; + + for (ict = 1; ict <= 3; ++ict) { + *(unsigned char *)transa = *(unsigned char *)&icht[ + ict - 1]; + + for (icd = 1; icd <= 2; ++icd) { + *(unsigned char *)diag = *(unsigned char *)&ichd[ + icd - 1]; + + i__3 = *nalf; + for (ia = 1; ia <= i__3; ++ia) { + alpha = alf[ia]; + +/* Generate the matrix A. */ + + dmake_("TR", uplo, diag, &na, &na, &a[ + a_offset], nmax, &aa[1], &lda, &reset, + &c_b104, (ftnlen)2, (ftnlen)1, ( + ftnlen)1); + +/* Generate the matrix B. */ + + dmake_("GE", " ", " ", &m, &n, &b[b_offset], + nmax, &bb[1], &ldb, &reset, &c_b104, ( + ftnlen)2, (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the */ +/* subroutine. */ + + *(unsigned char *)sides = *(unsigned char *) + side; + *(unsigned char *)uplos = *(unsigned char *) + uplo; + *(unsigned char *)tranas = *(unsigned char *) + transa; + *(unsigned char *)diags = *(unsigned char *) + diag; + ms = m; + ns = n; + als = alpha; + i__4 = laa; + for (i__ = 1; i__ <= i__4; ++i__) { + as[i__] = aa[i__]; +/* L30: */ + } + ldas = lda; + i__4 = lbb; + for (i__ = 1; i__ <= i__4; ++i__) { + bs[i__] = bb[i__]; +/* L40: */ + } + ldbs = ldb; + +/* Call the subroutine. */ + + if (s_cmp(sname + 9, "mm", (ftnlen)2, (ftnlen) + 2) == 0) { + if (*trace) { + dprcn3_(ntra, &nc, sname, iorder, + side, uplo, transa, diag, &m, + &n, &alpha, &lda, &ldb, ( + ftnlen)12, (ftnlen)1, (ftnlen) + 1, (ftnlen)1, (ftnlen)1); + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cdtrmm_(iorder, side, uplo, transa, diag, + &m, &n, &alpha, &aa[1], &lda, &bb[ + 1], &ldb, (ftnlen)1, (ftnlen)1, ( + ftnlen)1, (ftnlen)1); + } else if (s_cmp(sname + 9, "sm", (ftnlen)2, ( + ftnlen)2) == 0) { + if (*trace) { + dprcn3_(ntra, &nc, sname, iorder, + side, uplo, transa, diag, &m, + &n, &alpha, &lda, &ldb, ( + ftnlen)12, (ftnlen)1, (ftnlen) + 1, (ftnlen)1, (ftnlen)1); + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cdtrsm_(iorder, side, uplo, transa, diag, + &m, &n, &alpha, &aa[1], &lda, &bb[ + 1], &ldb, (ftnlen)1, (ftnlen)1, ( + ftnlen)1, (ftnlen)1); + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + *fatal = TRUE_; + goto L150; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)sides == *( + unsigned char *)side; + isame[1] = *(unsigned char *)uplos == *( + unsigned char *)uplo; + isame[2] = *(unsigned char *)tranas == *( + unsigned char *)transa; + isame[3] = *(unsigned char *)diags == *( + unsigned char *)diag; + isame[4] = ms == m; + isame[5] = ns == n; + isame[6] = als == alpha; + isame[7] = lde_(&as[1], &aa[1], &laa); + isame[8] = ldas == lda; + if (null) { + isame[9] = lde_(&bs[1], &bb[1], &lbb); + } else { + isame[9] = lderes_("GE", " ", &m, &n, &bs[ + 1], &bb[1], &ldb, (ftnlen)2, ( + ftnlen)1); + } + isame[10] = ldbs == ldb; + +/* If data was incorrectly changed, report and */ +/* return. */ + + same = TRUE_; + i__4 = nargs; + for (i__ = 1; i__ <= i__4; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L50: */ + } + if (! same) { + *fatal = TRUE_; + goto L150; + } + + if (! null) { + if (s_cmp(sname + 9, "mm", (ftnlen)2, ( + ftnlen)2) == 0) { + +/* Check the result. */ + + if (left) { + dmmch_(transa, "N", &m, &n, &m, & + alpha, &a[a_offset], nmax, + &b[b_offset], nmax, & + c_b104, &c__[c_offset], + nmax, &ct[1], &g[1], &bb[ + 1], &ldb, eps, &err, + fatal, nout, &c_true, ( + ftnlen)1, (ftnlen)1); + } else { + dmmch_("N", transa, &m, &n, &n, & + alpha, &b[b_offset], nmax, + &a[a_offset], nmax, & + c_b104, &c__[c_offset], + nmax, &ct[1], &g[1], &bb[ + 1], &ldb, eps, &err, + fatal, nout, &c_true, ( + ftnlen)1, (ftnlen)1); + } + } else if (s_cmp(sname + 9, "sm", (ftnlen) + 2, (ftnlen)2) == 0) { + +/* Compute approximation to original */ +/* matrix. */ + + i__4 = n; + for (j = 1; j <= i__4; ++j) { + i__5 = m; + for (i__ = 1; i__ <= i__5; ++i__) + { + c__[i__ + j * c_dim1] = bb[i__ + (j - 1) * ldb]; + bb[i__ + (j - 1) * ldb] = alpha * b[i__ + j * + b_dim1]; +/* L60: */ + } +/* L70: */ + } + + if (left) { + dmmch_(transa, "N", &m, &n, &m, & + c_b90, &a[a_offset], nmax, + &c__[c_offset], nmax, & + c_b104, &b[b_offset], + nmax, &ct[1], &g[1], &bb[ + 1], &ldb, eps, &err, + fatal, nout, &c_false, ( + ftnlen)1, (ftnlen)1); + } else { + dmmch_("N", transa, &m, &n, &n, & + c_b90, &c__[c_offset], + nmax, &a[a_offset], nmax, + &c_b104, &b[b_offset], + nmax, &ct[1], &g[1], &bb[ + 1], &ldb, eps, &err, + fatal, nout, &c_false, ( + ftnlen)1, (ftnlen)1); + } + } + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L150; + } + } + +/* L80: */ + } + +/* L90: */ + } + +/* L100: */ + } + +/* L110: */ + } + +/* L120: */ + } + +L130: + ; + } + +/* L140: */ + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + if (*iorder == 1) { + printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + } + goto L160; + +L150: + printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + if (*trace) { + dprcn3_(ntra, &nc, sname, iorder, side, uplo, transa, diag, &m, &n, & + alpha, &lda, &ldb, (ftnlen)12, (ftnlen)1, (ftnlen)1, (ftnlen) + 1, (ftnlen)1); + } + +L160: + return 0; + +/* 9995 FORMAT( 1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( I3, ',' ), */ +/* $ F4.1, ', A,', I3, ', B,', I3, ') .' ) */ + +/* End of DCHK3. */ + +} /* dchk3_ */ + + +/* Subroutine */ void dprcn3_(nout, nc, sname, iorder, side, uplo, transa, + diag, m, n, alpha, lda, ldb, sname_len, side_len, uplo_len, + transa_len, diag_len) +integer *nout, *nc; +char *sname; +integer *iorder; +char *side, *uplo, *transa, *diag; +integer *m, *n; +doublereal *alpha; +integer *lda, *ldb; +ftnlen sname_len; +ftnlen side_len; +ftnlen uplo_len; +ftnlen transa_len; +ftnlen diag_len; +{ + /* Builtin functions */ + integer s_wsfe(), do_fio(), e_wsfe(); + + /* Local variables */ + static char ca[14], cd[14], cs[14], cu[14], crc[14]; + + if (*(unsigned char *)side == 'L') { + s_copy(cs, " CblasLeft", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cs, " CblasRight", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)uplo == 'U') { + s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)transa == 'N') { + s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transa == 'T') { + s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)diag == 'N') { + s_copy(cd, " CblasNonUnit", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cd, " CblasUnit", (ftnlen)14, (ftnlen)14); + } + if (*iorder == 1) { + s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); + } else { + s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); + } + printf("%6d: %s %s %s %s\n",*nc,sname,crc,cs,cu); + printf(" %s %s %d %d %4.1f A %d B %d\n",ca,cd,*m,*n,*alpha,*lda,*ldb); +} /* dprcn3_ */ + + +/* Subroutine */ int dchk4_(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, sname_len) +char *sname; +doublereal *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nalf; +doublereal *alf; +integer *nbet; +doublereal *bet; +integer *nmax; +doublereal *a, *aa, *as, *b, *bb, *bs, *c__, *cc, *cs, *ct, *g; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char icht[3+1] = "NTC"; + static char ichu[2+1] = "UL"; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5; + + /* Builtin functions */ + integer f_rew(), s_wsfe(), e_wsfe(), do_fio(); + + /* Local variables */ + static doublereal beta; + static integer ldas, ldcs; + static logical same; + static doublereal bets; + static logical tran, null; + static char uplo[1]; + static integer i__, j, k, n; + extern /* Subroutine */ int dmake_(); + static doublereal alpha; + extern /* Subroutine */ int dmmch_(); + static logical isame[13]; + static integer nargs; + static logical reset; + static char trans[1]; + static logical upper; + static char uplos[1]; + extern /* Subroutine */ void dprcn4_(); + static integer ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns; + extern logical lderes_(); + static doublereal errmax; + extern /* Subroutine */ int cdsyrk_(); + static char transs[1]; + static integer laa, lda, lcc, ldc; + extern logical lde_(); + static doublereal als; + static integer ict, icu; + static doublereal err; + +/* Tests DSYRK. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --alf; + --bet; + --g; + --ct; + --cs; + --cc; + c_dim1 = *nmax; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --bs; + --bb; + b_dim1 = *nmax; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ +/* .. Executable Statements .. */ + + nargs = 10; + nc = 0; + reset = TRUE_; + errmax = 0.; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; +/* Set LDC to 1 more than minimum value if room. */ + ldc = n; + if (ldc < *nmax) { + ++ldc; + } +/* Skip tests if not enough room. */ + if (ldc > *nmax) { + goto L100; + } + lcc = ldc * n; + null = n <= 0; + + i__2 = *nidim; + for (ik = 1; ik <= i__2; ++ik) { + k = idim[ik]; + + for (ict = 1; ict <= 3; ++ict) { + *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1]; + tran = *(unsigned char *)trans == 'T' || *(unsigned char *) + trans == 'C'; + if (tran) { + ma = k; + na = n; + } else { + ma = n; + na = k; + } +/* Set LDA to 1 more than minimum value if room. */ + lda = ma; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L80; + } + laa = lda * na; + +/* Generate the matrix A. */ + + dmake_("GE", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[1], & + lda, &reset, &c_b104, (ftnlen)2, (ftnlen)1, (ftnlen)1) + ; + + for (icu = 1; icu <= 2; ++icu) { + *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; + upper = *(unsigned char *)uplo == 'U'; + + i__3 = *nalf; + for (ia = 1; ia <= i__3; ++ia) { + alpha = alf[ia]; + + i__4 = *nbet; + for (ib = 1; ib <= i__4; ++ib) { + beta = bet[ib]; + +/* Generate the matrix C. */ + + dmake_("SY", uplo, " ", &n, &n, &c__[c_offset], + nmax, &cc[1], &ldc, &reset, &c_b104, ( + ftnlen)2, (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the subroutine. */ + + *(unsigned char *)uplos = *(unsigned char *)uplo; + *(unsigned char *)transs = *(unsigned char *) + trans; + ns = n; + ks = k; + als = alpha; + i__5 = laa; + for (i__ = 1; i__ <= i__5; ++i__) { + as[i__] = aa[i__]; +/* L10: */ + } + ldas = lda; + bets = beta; + i__5 = lcc; + for (i__ = 1; i__ <= i__5; ++i__) { + cs[i__] = cc[i__]; +/* L20: */ + } + ldcs = ldc; + +/* Call the subroutine. */ + + if (*trace) { + dprcn4_(ntra, &nc, sname, iorder, uplo, trans, + &n, &k, &alpha, &lda, &beta, &ldc, ( + ftnlen)12, (ftnlen)1, (ftnlen)1); + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cdsyrk_(iorder, uplo, trans, &n, &k, &alpha, &aa[ + 1], &lda, &beta, &cc[1], &ldc, (ftnlen)1, + (ftnlen)1); + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + *fatal = TRUE_; + goto L120; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)uplos == *(unsigned + char *)uplo; + isame[1] = *(unsigned char *)transs == *(unsigned + char *)trans; + isame[2] = ns == n; + isame[3] = ks == k; + isame[4] = als == alpha; + isame[5] = lde_(&as[1], &aa[1], &laa); + isame[6] = ldas == lda; + isame[7] = bets == beta; + if (null) { + isame[8] = lde_(&cs[1], &cc[1], &lcc); + } else { + isame[8] = lderes_("SY", uplo, &n, &n, &cs[1], + &cc[1], &ldc, (ftnlen)2, (ftnlen)1); + } + isame[9] = ldcs == ldc; + +/* If data was incorrectly changed, report and */ +/* return. */ + + same = TRUE_; + i__5 = nargs; + for (i__ = 1; i__ <= i__5; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L30: */ + } + if (! same) { + *fatal = TRUE_; + goto L120; + } + + if (! null) { + +/* Check the result column by column. */ + + jc = 1; + i__5 = n; + for (j = 1; j <= i__5; ++j) { + if (upper) { + jj = 1; + lj = j; + } else { + jj = j; + lj = n - j + 1; + } + if (tran) { + dmmch_("T", "N", &lj, &c__1, &k, & + alpha, &a[jj * a_dim1 + 1], + nmax, &a[j * a_dim1 + 1], + nmax, &beta, &c__[jj + j * + c_dim1], nmax, &ct[1], &g[1], + &cc[jc], &ldc, eps, &err, + fatal, nout, &c_true, (ftnlen) + 1, (ftnlen)1); + } else { + dmmch_("N", "T", &lj, &c__1, &k, & + alpha, &a[jj + a_dim1], nmax, + &a[j + a_dim1], nmax, &beta, & + c__[jj + j * c_dim1], nmax, & + ct[1], &g[1], &cc[jc], &ldc, + eps, &err, fatal, nout, & + c_true, (ftnlen)1, (ftnlen)1); + } + if (upper) { + jc += ldc; + } else { + jc = jc + ldc + 1; + } + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L110; + } +/* L40: */ + } + } + +/* L50: */ + } + +/* L60: */ + } + +/* L70: */ + } + +L80: + ; + } + +/* L90: */ + } + +L100: + ; + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + if (*iorder == 1) { + printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + } + goto L130; + +L110: + if (n > 1) { + printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j); + } + +L120: + printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + dprcn4_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, & + beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); + +L130: + return 0; + +/* 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ +/* $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' ) */ + +/* End of DCHK4. */ + +} /* dchk4_ */ + + +/* Subroutine */ void dprcn4_(nout, nc, sname, iorder, uplo, transa, n, k, + alpha, lda, beta, ldc, sname_len, uplo_len, transa_len) +integer *nout, *nc; +char *sname; +integer *iorder; +char *uplo, *transa; +integer *n, *k; +doublereal *alpha; +integer *lda; +doublereal *beta; +integer *ldc; +ftnlen sname_len; +ftnlen uplo_len; +ftnlen transa_len; +{ + /* Builtin functions */ + integer s_wsfe(), do_fio(), e_wsfe(); + + /* Local variables */ + static char ca[14], cu[14], crc[14]; + + if (*(unsigned char *)uplo == 'U') { + s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)transa == 'N') { + s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transa == 'T') { + s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*iorder == 1) { + s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); + } else { + s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); + } + printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); + printf("( %d %d %4.1f A %d %4.1f C %d\n",*n,*k,*alpha,*lda,*beta,*ldc); +} /* dprcn4_ */ + + +/* Subroutine */ int dchk5_(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, sname_len) +char *sname; +doublereal *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nalf; +doublereal *alf; +integer *nbet; +doublereal *bet; +integer *nmax; +doublereal *ab, *aa, *as, *bb, *bs, *c__, *cc, *cs, *ct, *g, *w; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char icht[3+1] = "NTC"; + static char ichu[2+1] = "UL"; + + /* System generated locals */ + integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8; + + /* Builtin functions */ + integer f_rew(), s_wsfe(), e_wsfe(), do_fio(); + + /* Local variables */ + static integer jjab; + static doublereal beta; + static integer ldas, ldbs, ldcs; + static logical same; + static doublereal bets; + static logical tran, null; + static char uplo[1]; + static integer i__, j, k, n; + extern /* Subroutine */ int dmake_(); + static doublereal alpha; + extern /* Subroutine */ int dmmch_(); + static logical isame[13]; + static integer nargs; + static logical reset; + static char trans[1]; + static logical upper; + static char uplos[1]; + extern /* Subroutine */ void dprcn5_(); + static integer ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns; + extern logical lderes_(); + static doublereal errmax; + static char transs[1]; + static integer laa, lbb, lda, lcc, ldb, ldc; + extern logical lde_(); + extern /* Subroutine */ int cdsyr2k_(); + static doublereal als; + static integer ict, icu; + static doublereal err; + +/* Tests DSYR2K. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --alf; + --bet; + --w; + --g; + --ct; + --cs; + --cc; + c_dim1 = *nmax; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --bs; + --bb; + --as; + --aa; + --ab; + + /* Function Body */ +/* .. Executable Statements .. */ + + nargs = 12; + nc = 0; + reset = TRUE_; + errmax = 0.; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; +/* Set LDC to 1 more than minimum value if room. */ + ldc = n; + if (ldc < *nmax) { + ++ldc; + } +/* Skip tests if not enough room. */ + if (ldc > *nmax) { + goto L130; + } + lcc = ldc * n; + null = n <= 0; + + i__2 = *nidim; + for (ik = 1; ik <= i__2; ++ik) { + k = idim[ik]; + + for (ict = 1; ict <= 3; ++ict) { + *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1]; + tran = *(unsigned char *)trans == 'T' || *(unsigned char *) + trans == 'C'; + if (tran) { + ma = k; + na = n; + } else { + ma = n; + na = k; + } +/* Set LDA to 1 more than minimum value if room. */ + lda = ma; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L110; + } + laa = lda * na; + +/* Generate the matrix A. */ + + if (tran) { + i__3 = *nmax << 1; + dmake_("GE", " ", " ", &ma, &na, &ab[1], &i__3, &aa[1], & + lda, &reset, &c_b104, (ftnlen)2, (ftnlen)1, ( + ftnlen)1); + } else { + dmake_("GE", " ", " ", &ma, &na, &ab[1], nmax, &aa[1], & + lda, &reset, &c_b104, (ftnlen)2, (ftnlen)1, ( + ftnlen)1); + } + +/* Generate the matrix B. */ + + ldb = lda; + lbb = laa; + if (tran) { + i__3 = *nmax << 1; + dmake_("GE", " ", " ", &ma, &na, &ab[k + 1], &i__3, &bb[1] + , &ldb, &reset, &c_b104, (ftnlen)2, (ftnlen)1, ( + ftnlen)1); + } else { + dmake_("GE", " ", " ", &ma, &na, &ab[k * *nmax + 1], nmax, + &bb[1], &ldb, &reset, &c_b104, (ftnlen)2, ( + ftnlen)1, (ftnlen)1); + } + + for (icu = 1; icu <= 2; ++icu) { + *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; + upper = *(unsigned char *)uplo == 'U'; + + i__3 = *nalf; + for (ia = 1; ia <= i__3; ++ia) { + alpha = alf[ia]; + + i__4 = *nbet; + for (ib = 1; ib <= i__4; ++ib) { + beta = bet[ib]; + +/* Generate the matrix C. */ + + dmake_("SY", uplo, " ", &n, &n, &c__[c_offset], + nmax, &cc[1], &ldc, &reset, &c_b104, ( + ftnlen)2, (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the subroutine. */ + + *(unsigned char *)uplos = *(unsigned char *)uplo; + *(unsigned char *)transs = *(unsigned char *) + trans; + ns = n; + ks = k; + als = alpha; + i__5 = laa; + for (i__ = 1; i__ <= i__5; ++i__) { + as[i__] = aa[i__]; +/* L10: */ + } + ldas = lda; + i__5 = lbb; + for (i__ = 1; i__ <= i__5; ++i__) { + bs[i__] = bb[i__]; +/* L20: */ + } + ldbs = ldb; + bets = beta; + i__5 = lcc; + for (i__ = 1; i__ <= i__5; ++i__) { + cs[i__] = cc[i__]; +/* L30: */ + } + ldcs = ldc; + +/* Call the subroutine. */ + + if (*trace) { + dprcn5_(ntra, &nc, sname, iorder, uplo, trans, + &n, &k, &alpha, &lda, &ldb, &beta, & + ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1) + ; + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cdsyr2k_(iorder, uplo, trans, &n, &k, &alpha, &aa[ + 1], &lda, &bb[1], &ldb, &beta, &cc[1], & + ldc, (ftnlen)1, (ftnlen)1); + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + *fatal = TRUE_; + goto L150; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)uplos == *(unsigned + char *)uplo; + isame[1] = *(unsigned char *)transs == *(unsigned + char *)trans; + isame[2] = ns == n; + isame[3] = ks == k; + isame[4] = als == alpha; + isame[5] = lde_(&as[1], &aa[1], &laa); + isame[6] = ldas == lda; + isame[7] = lde_(&bs[1], &bb[1], &lbb); + isame[8] = ldbs == ldb; + isame[9] = bets == beta; + if (null) { + isame[10] = lde_(&cs[1], &cc[1], &lcc); + } else { + isame[10] = lderes_("SY", uplo, &n, &n, &cs[1] + , &cc[1], &ldc, (ftnlen)2, (ftnlen)1); + } + isame[11] = ldcs == ldc; + +/* If data was incorrectly changed, report and */ +/* return. */ + + same = TRUE_; + i__5 = nargs; + for (i__ = 1; i__ <= i__5; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L150; + } + + if (! null) { + +/* Check the result column by column. */ + + jjab = 1; + jc = 1; + i__5 = n; + for (j = 1; j <= i__5; ++j) { + if (upper) { + jj = 1; + lj = j; + } else { + jj = j; + lj = n - j + 1; + } + if (tran) { + i__6 = k; + for (i__ = 1; i__ <= i__6; ++i__) { + w[i__] = ab[((j - 1) << 1) * *nmax + + k + i__]; + w[k + i__] = ab[((j - 1) << 1) * * + nmax + i__]; +/* L50: */ + } + i__6 = k << 1; + i__7 = *nmax << 1; + i__8 = *nmax << 1; + dmmch_("T", "N", &lj, &c__1, &i__6, & + alpha, &ab[jjab], &i__7, &w[1] + , &i__8, &beta, &c__[jj + j * + c_dim1], nmax, &ct[1], &g[1], + &cc[jc], &ldc, eps, &err, + fatal, nout, &c_true, (ftnlen) + 1, (ftnlen)1); + } else { + i__6 = k; + for (i__ = 1; i__ <= i__6; ++i__) { + w[i__] = ab[(k + i__ - 1) * *nmax + + j]; + w[k + i__] = ab[(i__ - 1) * *nmax + + j]; +/* L60: */ + } + i__6 = k << 1; + i__7 = *nmax << 1; + dmmch_("N", "N", &lj, &c__1, &i__6, & + alpha, &ab[jj], nmax, &w[1], & + i__7, &beta, &c__[jj + j * + c_dim1], nmax, &ct[1], &g[1], + &cc[jc], &ldc, eps, &err, + fatal, nout, &c_true, (ftnlen) + 1, (ftnlen)1); + } + if (upper) { + jc += ldc; + } else { + jc = jc + ldc + 1; + if (tran) { + jjab += *nmax << 1; + } + } + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L140; + } +/* L70: */ + } + } + +/* L80: */ + } + +/* L90: */ + } + +/* L100: */ + } + +L110: + ; + } + +/* L120: */ + } + +L130: + ; + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + if (*iorder == 1) { + printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + } + goto L160; + +L140: + if (n > 1) { + printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j); + } + +L150: + printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + dprcn5_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &ldb, + &beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); + +L160: + return 0; + +/* 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ +/* $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', */ +/* $ ' .' ) */ + +/* End of DCHK5. */ + +} /* dchk5_ */ + + +/* Subroutine */ void dprcn5_(nout, nc, sname, iorder, uplo, transa, n, k, + alpha, lda, ldb, beta, ldc, sname_len, uplo_len, transa_len) +integer *nout, *nc; +char *sname; +integer *iorder; +char *uplo, *transa; +integer *n, *k; +doublereal *alpha; +integer *lda, *ldb; +doublereal *beta; +integer *ldc; +ftnlen sname_len; +ftnlen uplo_len; +ftnlen transa_len; +{ + /* Builtin functions */ + integer s_wsfe(), do_fio(), e_wsfe(); + + /* Local variables */ + static char ca[14], cu[14], crc[14]; + + if (*(unsigned char *)uplo == 'U') { + s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)transa == 'N') { + s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transa == 'T') { + s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*iorder == 1) { + s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); + } else { + s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); + } + printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); + printf("%d %d %4.1f , A, %d, B, %d, %4.1f , C, %d.\n",*n,*k,*alpha,*lda,*ldb,*beta,*ldc); +} /* dprcn5_ */ + + +/* Subroutine */ int dmake_(type__, uplo, diag, m, n, a, nmax, aa, lda, reset, + transl, type_len, uplo_len, diag_len) +char *type__, *uplo, *diag; +integer *m, *n; +doublereal *a; +integer *nmax; +doublereal *aa; +integer *lda; +logical *reset; +doublereal *transl; +ftnlen type_len; +ftnlen uplo_len; +ftnlen diag_len; +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + extern doublereal dbeg_(); + static integer ibeg, iend; + static logical unit; + static integer i__, j; + static logical lower, upper, gen, tri, sym; + + +/* Generates values for an M by N matrix A. */ +/* Stores the values in the array AA in the data structure required */ +/* by the routine, with unwanted elements set to rogue value. */ + +/* TYPE is 'GE', 'SY' or 'TR'. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. External Functions .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --aa; + + /* Function Body */ + gen = s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0; + sym = s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0; + tri = s_cmp(type__, "TR", (ftnlen)2, (ftnlen)2) == 0; + upper = (sym || tri) && *(unsigned char *)uplo == 'U'; + lower = (sym || tri) && *(unsigned char *)uplo == 'L'; + unit = tri && *(unsigned char *)diag == 'U'; + +/* Generate data in array A. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + if (gen || (upper && i__ <= j) || (lower && i__ >= j)) { + a[i__ + j * a_dim1] = dbeg_(reset) + *transl; + if (i__ != j) { +/* Set some elements to zero */ + if (*n > 3 && j == *n / 2) { + a[i__ + j * a_dim1] = 0.; + } + if (sym) { + a[j + i__ * a_dim1] = a[i__ + j * a_dim1]; + } else if (tri) { + a[j + i__ * a_dim1] = 0.; + } + } + } +/* L10: */ + } + if (tri) { + a[j + j * a_dim1] += 1.; + } + if (unit) { + a[j + j * a_dim1] = 1.; + } +/* L20: */ + } + +/* Store elements in array AS in data structure required by routine. */ + + if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + aa[i__ + (j - 1) * *lda] = a[i__ + j * a_dim1]; +/* L30: */ + } + i__2 = *lda; + for (i__ = *m + 1; i__ <= i__2; ++i__) { + aa[i__ + (j - 1) * *lda] = -1e10; +/* L40: */ + } +/* L50: */ + } + } else if (s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__, + "TR", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (upper) { + ibeg = 1; + if (unit) { + iend = j - 1; + } else { + iend = j; + } + } else { + if (unit) { + ibeg = j + 1; + } else { + ibeg = j; + } + iend = *n; + } + i__2 = ibeg - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + aa[i__ + (j - 1) * *lda] = -1e10; +/* L60: */ + } + i__2 = iend; + for (i__ = ibeg; i__ <= i__2; ++i__) { + aa[i__ + (j - 1) * *lda] = a[i__ + j * a_dim1]; +/* L70: */ + } + i__2 = *lda; + for (i__ = iend + 1; i__ <= i__2; ++i__) { + aa[i__ + (j - 1) * *lda] = -1e10; +/* L80: */ + } +/* L90: */ + } + } + return 0; + +/* End of DMAKE. */ + +} /* dmake_ */ + +/* Subroutine */ int dmmch_(transa, transb, m, n, kk, alpha, a, lda, b, ldb, + beta, c__, ldc, ct, g, cc, ldcc, eps, err, fatal, nout, mv, + transa_len, transb_len) +char *transa, *transb; +integer *m, *n, *kk; +doublereal *alpha, *a; +integer *lda; +doublereal *b; +integer *ldb; +doublereal *beta, *c__; +integer *ldc; +doublereal *ct, *g, *cc; +integer *ldcc; +doublereal *eps, *err; +logical *fatal; +integer *nout; +logical *mv; +ftnlen transa_len; +ftnlen transb_len; +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, cc_dim1, + cc_offset, i__1, i__2, i__3; + doublereal d__1, d__2; + + /* Builtin functions */ + double sqrt(); + integer s_wsfe(), e_wsfe(), do_fio(); + + /* Local variables */ + static doublereal erri; + static integer i__, j, k; + static logical trana, tranb; + +/* Checks the results of the computational tests. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Intrinsic Functions .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --ct; + --g; + cc_dim1 = *ldcc; + cc_offset = 1 + cc_dim1 * 1; + cc -= cc_offset; + + /* Function Body */ + trana = *(unsigned char *)transa == 'T' || *(unsigned char *)transa == + 'C'; + tranb = *(unsigned char *)transb == 'T' || *(unsigned char *)transb == + 'C'; + +/* Compute expected result, one column at a time, in CT using data */ +/* in A, B and C. */ +/* Compute gauges in G. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + ct[i__] = 0.; + g[i__] = 0.; +/* L10: */ + } + if (! trana && ! tranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + ct[i__] += a[i__ + k * a_dim1] * b[k + j * b_dim1]; + g[i__] += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (d__2 + = b[k + j * b_dim1], abs(d__2)); +/* L20: */ + } +/* L30: */ + } + } else if (trana && ! tranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + ct[i__] += a[k + i__ * a_dim1] * b[k + j * b_dim1]; + g[i__] += (d__1 = a[k + i__ * a_dim1], abs(d__1)) * (d__2 + = b[k + j * b_dim1], abs(d__2)); +/* L40: */ + } +/* L50: */ + } + } else if (! trana && tranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + ct[i__] += a[i__ + k * a_dim1] * b[j + k * b_dim1]; + g[i__] += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (d__2 + = b[j + k * b_dim1], abs(d__2)); +/* L60: */ + } +/* L70: */ + } + } else if (trana && tranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + ct[i__] += a[k + i__ * a_dim1] * b[j + k * b_dim1]; + g[i__] += (d__1 = a[k + i__ * a_dim1], abs(d__1)) * (d__2 + = b[j + k * b_dim1], abs(d__2)); +/* L80: */ + } +/* L90: */ + } + } + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + ct[i__] = *alpha * ct[i__] + *beta * c__[i__ + j * c_dim1]; + g[i__] = abs(*alpha) * g[i__] + abs(*beta) * (d__1 = c__[i__ + j * + c_dim1], abs(d__1)); +/* L100: */ + } + +/* Compute the error ratio for this result. */ + + *err = 0.; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + erri = (d__1 = ct[i__] - cc[i__ + j * cc_dim1], abs(d__1)) / *eps; + if (g[i__] != 0.) { + erri /= g[i__]; + } + *err = f2cmax(*err,erri); + if (*err * sqrt(*eps) >= 1.) { + goto L130; + } +/* L110: */ + } + +/* L120: */ + } + +/* If the loop completes, all results are at least half accurate. */ + goto L150; + +/* Report fatal error. */ + +L130: + *fatal = TRUE_; + printf(" ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HALF ACCURATE *******\n"); + printf(" EXPECTED RESULT COMPUTED RESULT\n"); + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*mv) { + printf("%7d %15.6g %15.6g\n",i__,ct[i__],cc[i__+j*cc_dim1]); + } else { + printf("%7d %15.6g %15.6g\n",i__,cc[i__+j*cc_dim1],ct[i__]); + } +/* L140: */ + } + if (*n > 1) { + printf(" THESE ARE THE RESULTS FOR COLUMN %d\n",j); + } + +L150: + return 0; + + +/* End of DMMCH. */ + +} /* dmmch_ */ + +logical lde_(ri, rj, lr) +doublereal *ri, *rj; +integer *lr; +{ + /* System generated locals */ + integer i__1; + logical ret_val; + + /* Local variables */ + static integer i__; + + +/* Tests if two arrays are identical. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + --rj; + --ri; + + /* Function Body */ + i__1 = *lr; + for (i__ = 1; i__ <= i__1; ++i__) { + if (ri[i__] != rj[i__]) { + goto L20; + } +/* L10: */ + } + ret_val = TRUE_; + goto L30; +L20: + ret_val = FALSE_; +L30: + return ret_val; + +/* End of LDE. */ + +} /* lde_ */ + +logical lderes_(type__, uplo, m, n, aa, as, lda, type_len, uplo_len) +char *type__, *uplo; +integer *m, *n; +doublereal *aa, *as; +integer *lda; +ftnlen type_len; +ftnlen uplo_len; +{ + /* System generated locals */ + integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2; + logical ret_val; + + /* Local variables */ + static integer ibeg, iend, i__, j; + static logical upper; + + +/* Tests if selected elements in two arrays are equal. */ + +/* TYPE is 'GE' or 'SY'. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + as_dim1 = *lda; + as_offset = 1 + as_dim1 * 1; + as -= as_offset; + aa_dim1 = *lda; + aa_offset = 1 + aa_dim1 * 1; + aa -= aa_offset; + + /* Function Body */ + upper = *(unsigned char *)uplo == 'U'; + if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *lda; + for (i__ = *m + 1; i__ <= i__2; ++i__) { + if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) { + goto L70; + } +/* L10: */ + } +/* L20: */ + } + } else if (s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (upper) { + ibeg = 1; + iend = j; + } else { + ibeg = j; + iend = *n; + } + i__2 = ibeg - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) { + goto L70; + } +/* L30: */ + } + i__2 = *lda; + for (i__ = iend + 1; i__ <= i__2; ++i__) { + if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) { + goto L70; + } +/* L40: */ + } +/* L50: */ + } + } + +/* 60 CONTINUE */ + ret_val = TRUE_; + goto L80; +L70: + ret_val = FALSE_; +L80: + return ret_val; + +/* End of LDERES. */ + +} /* lderes_ */ + +doublereal dbeg_(reset) +logical *reset; +{ + /* System generated locals */ + doublereal ret_val; + + /* Local variables */ + static integer i__, ic, mi; + + +/* 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 .. */ +/* .. Local Scalars .. */ +/* .. Save statement .. */ +/* .. Executable Statements .. */ + if (*reset) { +/* Initialize local variables. */ + mi = 891; + i__ = 7; + ic = 0; + *reset = FALSE_; + } + +/* The sequence of values of I is bounded between 1 and 999. */ +/* If initial I = 1,2,3,6,7 or 9, the period will be 50. */ +/* If initial I = 4 or 8, the period will be 25. */ +/* If initial I = 5, the period will be 10. */ +/* IC is used to break up the period by skipping 1 value of I in 6. */ + + ++ic; +L10: + i__ *= mi; + i__ -= i__ / 1000 * 1000; + if (ic >= 5) { + ic = 0; + goto L10; + } + ret_val = (i__ - 500) / 1001.; + return ret_val; + +/* End of DBEG. */ + +} /* dbeg_ */ + +doublereal ddiff_(x, y) +doublereal *x, *y; +{ + /* System generated locals */ + doublereal ret_val; + + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Scalar Arguments .. */ +/* .. Executable Statements .. */ + ret_val = *x - *y; + return ret_val; + +/* End of DDIFF. */ + +} /* ddiff_ */ + +/* Main program alias */ /*int dblat3_ () { MAIN__ (); }*/ diff --git a/ctest/c_sblat1c.c b/ctest/c_sblat1c.c new file mode 100644 index 000000000..d6062b245 --- /dev/null +++ b/ctest/c_sblat1c.c @@ -0,0 +1,1420 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif +#if 0 +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +#endif +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i 8) { + goto L40; + } + sa = da1[k - 1]; + sb = db1[k - 1]; + srotgtest_(&sa, &sb, &sc, &ss); + stest1_(&sa, &datrue[k - 1], &datrue[k - 1], sfac); + stest1_(&sb, &dbtrue[k - 1], &dbtrue[k - 1], sfac); + stest1_(&sc, &dc1[k - 1], &dc1[k - 1], sfac); + stest1_(&ss, &ds1[k - 1], &ds1[k - 1], sfac); + } else { + fprintf (stderr,"Shouldn't be here in CHECK0\n"); + exit(0); + } +/* L20: */ + } +L40: + return 0; +} /* check0_ */ + +/* Subroutine */ int check1_(sfac) +real *sfac; +{ + /* Initialized data */ + + static real sa[10] = { (float).3,(float)-1.,(float)0.,(float)1.,(float).3, + (float).3,(float).3,(float).3,(float).3,(float).3 }; + static real dv[80] /* was [8][5][2] */ = { (float).1,(float)2.,(float)2., + (float)2.,(float)2.,(float)2.,(float)2.,(float)2.,(float).3,( + float)3.,(float)3.,(float)3.,(float)3.,(float)3.,(float)3.,(float) + 3.,(float).3,(float)-.4,(float)4.,(float)4.,(float)4.,(float)4.,( + float)4.,(float)4.,(float).2,(float)-.6,(float).3,(float)5.,( + float)5.,(float)5.,(float)5.,(float)5.,(float).1,(float)-.3,( + float).5,(float)-.1,(float)6.,(float)6.,(float)6.,(float)6.,( + float).1,(float)8.,(float)8.,(float)8.,(float)8.,(float)8.,(float) + 8.,(float)8.,(float).3,(float)9.,(float)9.,(float)9.,(float)9.,( + float)9.,(float)9.,(float)9.,(float).3,(float)2.,(float)-.4,( + float)2.,(float)2.,(float)2.,(float)2.,(float)2.,(float).2,(float) + 3.,(float)-.6,(float)5.,(float).3,(float)2.,(float)2.,(float)2.,( + float).1,(float)4.,(float)-.3,(float)6.,(float)-.5,(float)7.,( + float)-.1,(float)3. }; + static real dtrue1[5] = { (float)0.,(float).3,(float).5,(float).7,(float) + .6 }; + static real dtrue3[5] = { (float)0.,(float).3,(float).7,(float)1.1,(float) + 1. }; + static real dtrue5[80] /* was [8][5][2] */ = { (float).1,(float)2.,( + float)2.,(float)2.,(float)2.,(float)2.,(float)2.,(float)2.,(float) + -.3,(float)3.,(float)3.,(float)3.,(float)3.,(float)3.,(float)3.,( + float)3.,(float)0.,(float)0.,(float)4.,(float)4.,(float)4.,(float) + 4.,(float)4.,(float)4.,(float).2,(float)-.6,(float).3,(float)5.,( + float)5.,(float)5.,(float)5.,(float)5.,(float).03,(float)-.09,( + float).15,(float)-.03,(float)6.,(float)6.,(float)6.,(float)6.,( + float).1,(float)8.,(float)8.,(float)8.,(float)8.,(float)8.,(float) + 8.,(float)8.,(float).09,(float)9.,(float)9.,(float)9.,(float)9.,( + float)9.,(float)9.,(float)9.,(float).09,(float)2.,(float)-.12,( + float)2.,(float)2.,(float)2.,(float)2.,(float)2.,(float).06,( + float)3.,(float)-.18,(float)5.,(float).09,(float)2.,(float)2.,( + float)2.,(float).03,(float)4.,(float)-.09,(float)6.,(float)-.15,( + float)7.,(float)-.03,(float)3. }; + static integer itrue2[5] = { 0,1,2,2,3 }; + + /* System generated locals */ + integer i__1; + real r__1; + + /* Local variables */ + static integer i__; + extern real snrm2test_(); + static real stemp[1], strue[8]; + extern /* Subroutine */ int stest_(), sscaltest_(); + extern real sasumtest_(); + extern /* Subroutine */ int itest1_(), stest1_(); + static real sx[8]; + static integer np1; + extern integer isamaxtest_(); + static integer len; + + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Scalars in Common .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ +/* .. Executable Statements .. */ + for (combla_1.incx = 1; combla_1.incx <= 2; ++combla_1.incx) { + for (np1 = 1; np1 <= 5; ++np1) { + combla_1.n = np1 - 1; + len = f2cmax(combla_1.n,1) << 1; +/* .. Set vector arguments .. */ + i__1 = len; + for (i__ = 1; i__ <= i__1; ++i__) { + sx[i__ - 1] = dv[i__ + (np1 + combla_1.incx * 5 << 3) - 49]; +/* L20: */ + } + + if (combla_1.icase == 7) { +/* .. SNRM2TEST .. */ + stemp[0] = dtrue1[np1 - 1]; + r__1 = snrm2test_(&combla_1.n, sx, &combla_1.incx); + stest1_(&r__1, stemp, stemp, sfac); + } else if (combla_1.icase == 8) { +/* .. SASUMTEST .. */ + stemp[0] = dtrue3[np1 - 1]; + r__1 = sasumtest_(&combla_1.n, sx, &combla_1.incx); + stest1_(&r__1, stemp, stemp, sfac); + } else if (combla_1.icase == 9) { +/* .. SSCALTEST .. */ + sscaltest_(&combla_1.n, &sa[(combla_1.incx - 1) * 5 + np1 - 1] + , sx, &combla_1.incx); + i__1 = len; + for (i__ = 1; i__ <= i__1; ++i__) { + strue[i__ - 1] = dtrue5[i__ + (np1 + combla_1.incx * 5 << + 3) - 49]; +/* L40: */ + } + stest_(&len, sx, strue, strue, sfac); + } else if (combla_1.icase == 10) { +/* .. ISAMAXTEST .. */ + i__1 = isamaxtest_(&combla_1.n, sx, &combla_1.incx); + itest1_(&i__1, &itrue2[np1 - 1]); + } else { + fprintf(stderr, " Shouldn't be here in CHECK1\n"); + exit(0); + } +/* L60: */ + } +/* L80: */ + } + return 0; +} /* check1_ */ + +/* Subroutine */ int check2_(sfac) +real *sfac; +{ + /* Initialized data */ + + static real sa = (float).3; + static integer incxs[4] = { 1,2,-2,-1 }; + static integer incys[4] = { 1,-2,1,-2 }; + static integer lens[8] /* was [4][2] */ = { 1,1,2,4,1,1,3,7 }; + static integer ns[4] = { 0,1,2,4 }; + static real dx1[7] = { (float).6,(float).1,(float)-.5,(float).8,(float).9, + (float)-.3,(float)-.4 }; + static real dy1[7] = { (float).5,(float)-.9,(float).3,(float).7,(float) + -.6,(float).2,(float).8 }; + static real dt7[16] /* was [4][4] */ = { (float)0.,(float).3,(float).21,( + float).62,(float)0.,(float).3,(float)-.07,(float).85,(float)0.,( + float).3,(float)-.79,(float)-.74,(float)0.,(float).3,(float).33,( + float)1.27 }; + static real dt8[112] /* was [7][4][4] */ = { (float).5,(float)0.,( + float)0.,(float)0.,(float)0.,(float)0.,(float)0.,(float).68,( + float)0.,(float)0.,(float)0.,(float)0.,(float)0.,(float)0.,(float) + .68,(float)-.87,(float)0.,(float)0.,(float)0.,(float)0.,(float)0., + (float).68,(float)-.87,(float).15,(float).94,(float)0.,(float)0.,( + float)0.,(float).5,(float)0.,(float)0.,(float)0.,(float)0.,(float) + 0.,(float)0.,(float).68,(float)0.,(float)0.,(float)0.,(float)0.,( + float)0.,(float)0.,(float).35,(float)-.9,(float).48,(float)0.,( + float)0.,(float)0.,(float)0.,(float).38,(float)-.9,(float).57,( + float).7,(float)-.75,(float).2,(float).98,(float).5,(float)0.,( + float)0.,(float)0.,(float)0.,(float)0.,(float)0.,(float).68,( + float)0.,(float)0.,(float)0.,(float)0.,(float)0.,(float)0.,(float) + .35,(float)-.72,(float)0.,(float)0.,(float)0.,(float)0.,(float)0., + (float).38,(float)-.63,(float).15,(float).88,(float)0.,(float)0.,( + float)0.,(float).5,(float)0.,(float)0.,(float)0.,(float)0.,(float) + 0.,(float)0.,(float).68,(float)0.,(float)0.,(float)0.,(float)0.,( + float)0.,(float)0.,(float).68,(float)-.9,(float).33,(float)0.,( + float)0.,(float)0.,(float)0.,(float).68,(float)-.9,(float).33,( + float).7,(float)-.75,(float).2,(float)1.04 }; + static real dt10x[112] /* was [7][4][4] */ = { (float).6,(float)0.,( + float)0.,(float)0.,(float)0.,(float)0.,(float)0.,(float).5,(float) + 0.,(float)0.,(float)0.,(float)0.,(float)0.,(float)0.,(float).5,( + float)-.9,(float)0.,(float)0.,(float)0.,(float)0.,(float)0.,( + float).5,(float)-.9,(float).3,(float).7,(float)0.,(float)0.,( + float)0.,(float).6,(float)0.,(float)0.,(float)0.,(float)0.,(float) + 0.,(float)0.,(float).5,(float)0.,(float)0.,(float)0.,(float)0.,( + float)0.,(float)0.,(float).3,(float).1,(float).5,(float)0.,(float) + 0.,(float)0.,(float)0.,(float).8,(float).1,(float)-.6,(float).8,( + float).3,(float)-.3,(float).5,(float).6,(float)0.,(float)0.,( + float)0.,(float)0.,(float)0.,(float)0.,(float).5,(float)0.,(float) + 0.,(float)0.,(float)0.,(float)0.,(float)0.,(float)-.9,(float).1,( + float).5,(float)0.,(float)0.,(float)0.,(float)0.,(float).7,(float) + .1,(float).3,(float).8,(float)-.9,(float)-.3,(float).5,(float).6,( + float)0.,(float)0.,(float)0.,(float)0.,(float)0.,(float)0.,(float) + .5,(float)0.,(float)0.,(float)0.,(float)0.,(float)0.,(float)0.,( + float).5,(float).3,(float)0.,(float)0.,(float)0.,(float)0.,(float) + 0.,(float).5,(float).3,(float)-.6,(float).8,(float)0.,(float)0.,( + float)0. }; + static real dt10y[112] /* was [7][4][4] */ = { (float).5,(float)0.,( + float)0.,(float)0.,(float)0.,(float)0.,(float)0.,(float).6,(float) + 0.,(float)0.,(float)0.,(float)0.,(float)0.,(float)0.,(float).6,( + float).1,(float)0.,(float)0.,(float)0.,(float)0.,(float)0.,(float) + .6,(float).1,(float)-.5,(float).8,(float)0.,(float)0.,(float)0.,( + float).5,(float)0.,(float)0.,(float)0.,(float)0.,(float)0.,(float) + 0.,(float).6,(float)0.,(float)0.,(float)0.,(float)0.,(float)0.,( + float)0.,(float)-.5,(float)-.9,(float).6,(float)0.,(float)0.,( + float)0.,(float)0.,(float)-.4,(float)-.9,(float).9,(float).7,( + float)-.5,(float).2,(float).6,(float).5,(float)0.,(float)0.,( + float)0.,(float)0.,(float)0.,(float)0.,(float).6,(float)0.,(float) + 0.,(float)0.,(float)0.,(float)0.,(float)0.,(float)-.5,(float).6,( + float)0.,(float)0.,(float)0.,(float)0.,(float)0.,(float)-.4,( + float).9,(float)-.5,(float).6,(float)0.,(float)0.,(float)0.,( + float).5,(float)0.,(float)0.,(float)0.,(float)0.,(float)0.,(float) + 0.,(float).6,(float)0.,(float)0.,(float)0.,(float)0.,(float)0.,( + float)0.,(float).6,(float)-.9,(float).1,(float)0.,(float)0.,( + float)0.,(float)0.,(float).6,(float)-.9,(float).1,(float).7,( + float)-.5,(float).2,(float).8 }; + static real ssize1[4] = { (float)0.,(float).3,(float)1.6,(float)3.2 }; + static real ssize2[28] /* was [14][2] */ = { (float)0.,(float)0.,( + float)0.,(float)0.,(float)0.,(float)0.,(float)0.,(float)0.,(float) + 0.,(float)0.,(float)0.,(float)0.,(float)0.,(float)0.,(float)1.17,( + float)1.17,(float)1.17,(float)1.17,(float)1.17,(float)1.17,(float) + 1.17,(float)1.17,(float)1.17,(float)1.17,(float)1.17,(float)1.17,( + float)1.17,(float)1.17 }; + + /* System generated locals */ + integer i__1; + real r__1; + + /* Local variables */ + static integer lenx, leny; + extern doublereal sdottest_(); + static integer i__, j, ksize; + extern /* Subroutine */ int stest_(), scopytest_(), sswaptest_(), + saxpytest_(); + static integer ki; + extern /* Subroutine */ int stest1_(); + static integer kn, mx, my; + static real sx[7], sy[7], stx[7], sty[7]; + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Scalars in Common .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ +/* .. Executable Statements .. */ + + for (ki = 1; ki <= 4; ++ki) { + combla_1.incx = incxs[ki - 1]; + combla_1.incy = incys[ki - 1]; + mx = abs(combla_1.incx); + my = abs(combla_1.incy); + + for (kn = 1; kn <= 4; ++kn) { + combla_1.n = ns[kn - 1]; + ksize = f2cmin(2,kn); + lenx = lens[kn + (mx << 2) - 5]; + leny = lens[kn + (my << 2) - 5]; +/* .. Initialize all argument arrays .. */ + for (i__ = 1; i__ <= 7; ++i__) { + sx[i__ - 1] = dx1[i__ - 1]; + sy[i__ - 1] = dy1[i__ - 1]; +/* L20: */ + } + + if (combla_1.icase == 1) { +/* .. SDOTTEST .. */ + r__1 = sdottest_(&combla_1.n, sx, &combla_1.incx, sy, & + combla_1.incy); + stest1_(&r__1, &dt7[kn + (ki << 2) - 5], &ssize1[kn - 1], + sfac); + } else if (combla_1.icase == 2) { +/* .. SAXPYTEST .. */ + saxpytest_(&combla_1.n, &sa, sx, &combla_1.incx, sy, & + combla_1.incy); + i__1 = leny; + for (j = 1; j <= i__1; ++j) { + sty[j - 1] = dt8[j + (kn + (ki << 2)) * 7 - 36]; +/* L40: */ + } + stest_(&leny, sy, sty, &ssize2[ksize * 14 - 14], sfac); + } else if (combla_1.icase == 5) { +/* .. SCOPYTEST .. */ + for (i__ = 1; i__ <= 7; ++i__) { + sty[i__ - 1] = dt10y[i__ + (kn + (ki << 2)) * 7 - 36]; +/* L60: */ + } + scopytest_(&combla_1.n, sx, &combla_1.incx, sy, & + combla_1.incy); + stest_(&leny, sy, sty, ssize2, &c_b34); + } else if (combla_1.icase == 6) { +/* .. SSWAPTEST .. */ + sswaptest_(&combla_1.n, sx, &combla_1.incx, sy, & + combla_1.incy); + for (i__ = 1; i__ <= 7; ++i__) { + stx[i__ - 1] = dt10x[i__ + (kn + (ki << 2)) * 7 - 36]; + sty[i__ - 1] = dt10y[i__ + (kn + (ki << 2)) * 7 - 36]; +/* L80: */ + } + stest_(&lenx, sx, stx, ssize2, &c_b34); + stest_(&leny, sy, sty, ssize2, &c_b34); + } else { + fprintf(stderr,"Shouldn't be here in CHECK2\n"); + exit(0); + } +/* L100: */ + } +/* L120: */ + } + return 0; +} /* check2_ */ + +/* Subroutine */ int check3_(sfac) +real *sfac; +{ + /* Initialized data */ + + static integer incxs[7] = { 1,1,2,2,-2,-1,-2 }; + static integer incys[7] = { 1,2,2,-2,1,-2,-2 }; + static integer ns[7] = { 0,1,2,4,5,8,9 }; + static real dx[19] = { (float).6,(float).1,(float)-.5,(float).8,(float).9, + (float)-.3,(float)-.4,(float).5,(float)-.9,(float).3,(float).7,( + float)-.6,(float).2,(float).8,(float)-.46,(float).78,(float)-.46,( + float)-.22,(float)1.06 }; + static real dy[19] = { (float).5,(float)-.9,(float).3,(float).7,(float) + -.6,(float).2,(float).6,(float).1,(float)-.5,(float).8,(float).9,( + float)-.3,(float).96,(float).1,(float)-.76,(float).8,(float).9,( + float).66,(float).8 }; + static real sc = (float).8; + static real ss = (float).6; + static real param[20] /* was [5][4] */ = { (float)-2.,(float)1.,( + float)0.,(float)0.,(float)1.,(float)-1.,(float).2,(float).3,( + float).4,(float).5,(float)0.,(float)1.,(float).3,(float).4,(float) + 1.,(float)1.,(float).2,(float)-1.,(float)1.,(float).5 }; + static integer len = 19; + static real ssize2[38] /* was [19][2] */ = { (float)0.,(float)0.,( + float)0.,(float)0.,(float)0.,(float)0.,(float)0.,(float)0.,(float) + 0.,(float)0.,(float)0.,(float)0.,(float)0.,(float)0.,(float)0.,( + float)0.,(float)0.,(float)0.,(float)0.,(float)1.17,(float)1.17,( + float)1.17,(float)1.17,(float)1.17,(float)1.17,(float)1.17,(float) + 1.17,(float)1.17,(float)1.17,(float)1.17,(float)1.17,(float)1.17,( + float)1.17,(float)1.17,(float)1.17,(float)1.17,(float)1.17,(float) + 1.17 }; + + /* Local variables */ + extern /* Subroutine */ int srot_(), srottest_(); + static integer i__, k, ksize; + extern /* Subroutine */ int stest_(), srotm_(), srotmtest_(); + static integer ki, kn; + static real sx[19], sy[19], sparam[5], stx[19], sty[19]; + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Scalars in Common .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ +/* .. Executable Statements .. */ + + for (ki = 1; ki <= 7; ++ki) { + combla_1.incx = incxs[ki - 1]; + combla_1.incy = incys[ki - 1]; + + for (kn = 1; kn <= 7; ++kn) { + combla_1.n = ns[kn - 1]; + ksize = f2cmin(2,kn); + + if (combla_1.icase == 4) { +/* .. SROTTEST .. */ + for (i__ = 1; i__ <= 19; ++i__) { + sx[i__ - 1] = dx[i__ - 1]; + sy[i__ - 1] = dy[i__ - 1]; + stx[i__ - 1] = dx[i__ - 1]; + sty[i__ - 1] = dy[i__ - 1]; +/* L20: */ + } + srottest_(&combla_1.n, sx, &combla_1.incx, sy, &combla_1.incy, + &sc, &ss); + srot_(&combla_1.n, stx, &combla_1.incx, sty, &combla_1.incy, & + sc, &ss); + stest_(&len, sx, stx, &ssize2[ksize * 19 - 19], sfac); + stest_(&len, sy, sty, &ssize2[ksize * 19 - 19], sfac); + } else if (combla_1.icase == 11) { +/* .. SROTMTEST .. */ + for (i__ = 1; i__ <= 19; ++i__) { + sx[i__ - 1] = dx[i__ - 1]; + sy[i__ - 1] = dy[i__ - 1]; + stx[i__ - 1] = dx[i__ - 1]; + sty[i__ - 1] = dy[i__ - 1]; +/* L90: */ + } + for (i__ = 1; i__ <= 4; ++i__) { + for (k = 1; k <= 5; ++k) { + sparam[k - 1] = param[k + i__ * 5 - 6]; +/* L80: */ + } + srotmtest_(&combla_1.n, sx, &combla_1.incx, sy, & + combla_1.incy, sparam); + srotm_(&combla_1.n, stx, &combla_1.incx, sty, & + combla_1.incy, sparam); + stest_(&len, sx, stx, &ssize2[ksize * 19 - 19], sfac); + stest_(&len, sy, sty, &ssize2[ksize * 19 - 19], sfac); +/* L70: */ + } + } else { + fprintf(stderr,"Shouldn't be here in CHECK3\n"); + exit(0); + } +/* L40: */ + } +/* L60: */ + } + return 0; +} /* check3_ */ + +/* Subroutine */ int stest_(len, scomp, strue, ssize, sfac) +integer *len; +real *scomp, *strue, *ssize, *sfac; +{ + integer i__1; + real r__1, r__2, r__3, r__4, r__5; + + /* Local variables */ + static integer i__; + extern doublereal sdiff_(); + static real sd; + +/* ********************************* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Scalars in Common .. */ +/* .. Local Scalars .. */ +/* .. External Functions .. */ +/* .. Intrinsic Functions .. */ +/* .. Common blocks .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --ssize; + --strue; + --scomp; + + /* Function Body */ + i__1 = *len; + for (i__ = 1; i__ <= i__1; ++i__) { + sd = scomp[i__] - strue[i__]; + r__4 = (r__1 = ssize[i__], dabs(r__1)) + (r__2 = *sfac * sd, dabs( + r__2)); + r__5 = (r__3 = ssize[i__], dabs(r__3)); + if (sdiff_(&r__4, &r__5) == (float)0.) { + goto L40; + } + +/* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I). */ + + if (! combla_1.pass) { + goto L20; + } +/* PRINT FAIL MESSAGE AND HEADER. */ + combla_1.pass = FALSE_; + printf(" FAIL\n"); + printf("CASE N INCX INCY MODE I COMP(I) TRUE(I) DIFFERENCE SIZE(I)\n"); +L20: + printf("%4d %3d %5d %5d %5d %3d %36.8f %36.8f %12.4f %12.4f\n",combla_1.icase, combla_1.n, + combla_1.incx, combla_1.incy, combla_1.mode, i__, scomp[i__], strue[i__], sd, ssize[i__]); +L40: + ; + } + return 0; + +} /* stest_ */ + +/* Subroutine */ int stest1_(scomp1, strue1, ssize, sfac) +real *scomp1, *strue1, *ssize, *sfac; +{ + static real scomp[1], strue[1]; + extern /* Subroutine */ int stest_(); + +/* ************************* STEST1 ***************************** */ + +/* THIS IS AN INTERFACE SUBROUTINE TO ACCOMMODATE 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 .. */ +/* .. Array Arguments .. */ +/* .. Local Arrays .. */ +/* .. External Subroutines .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --ssize; + + /* Function Body */ + scomp[0] = *scomp1; + strue[0] = *strue1; + stest_(&c__1, scomp, strue, &ssize[1], sfac); + + return 0; +} /* stest1_ */ + +doublereal sdiff_(sa, sb) +real *sa, *sb; +{ + /* System generated locals */ + real ret_val; + +/* ********************************* SDIFF ************************** */ +/* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15 */ + +/* .. Scalar Arguments .. */ +/* .. Executable Statements .. */ + ret_val = *sa - *sb; + return ret_val; +} /* sdiff_ */ + +/* Subroutine */ int itest1_(icomp, itrue) +integer *icomp, *itrue; +{ + /* Local variables */ + static integer id; + + +/* ********************************* ITEST1 ************************* */ + +/* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR */ +/* EQUALITY. */ +/* C. L. LAWSON, JPL, 1974 DEC 10 */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Scalars in Common .. */ +/* .. Local Scalars .. */ +/* .. Common blocks .. */ +/* .. Executable Statements .. */ + + if (*icomp == *itrue) { + goto L40; + } + +/* HERE ICOMP IS NOT EQUAL TO ITRUE. */ + + if (! combla_1.pass) { + goto L20; + } +/* PRINT FAIL MESSAGE AND HEADER. */ + combla_1.pass = FALSE_; + printf(" FAIL\n"); + printf("CASE N INCX INCY MODE COMP TRUE DIFFERENCE\n"); +L20: + id = *icomp - *itrue; + printf("%4d %3d %5d %5d %5d %36d %36d %12d\n", + combla_1.icase, combla_1.n, combla_1.incx, combla_1.incy, combla_1.mode, *icomp,*itrue,id); +L40: + return 0; + +} /* itest1_ */ + +/* Subroutine */ int srot_(n, sx, incx, sy, incy, c__, s) +integer *n; +real *sx; +integer *incx; +real *sy; +integer *incy; +real *c__, *s; +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + static integer i__; + static real stemp; + static integer ix, iy; + + +/* --Reference BLAS level1 routine (version 3.8.0) -- */ +/* --Reference BLAS is a software package provided by Univ. of Tennessee, -- */ +/* --Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ + /* Parameter adjustments */ + --sy; + --sx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + stemp = *c__ * sx[i__] + *s * sy[i__]; + sy[i__] = *c__ * sy[i__] - *s * sx[i__]; + sx[i__] = stemp; + } + } else { + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + stemp = *c__ * sx[ix] + *s * sy[iy]; + sy[iy] = *c__ * sy[iy] - *s * sx[ix]; + sx[ix] = stemp; + ix += *incx; + iy += *incy; + } + } + return 0; +} /* srot_ */ + +/* Subroutine */ int srotm_(n, sx, incx, sy, incy, sparam) +integer *n; +real *sx; +integer *incx; +real *sy; +integer *incy; +real *sparam; +{ + /* Initialized data */ + + static real zero = (float)0.; + static real two = (float)2.; + + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + static integer i__; + static real w, z__, sflag; + static integer kx, ky, nsteps; + static real sh11, sh12, sh21, sh22; + + +/* --Reference BLAS level1 routine (version 3.8.0) -- */ +/* --Reference BLAS is a software package provided by Univ. of Tennessee, -- */ +/* --Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* ==================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --sparam; + --sy; + --sx; + + /* Function Body */ +/* .. */ + + sflag = sparam[1]; + if (*n <= 0 || sflag + two == zero) { + return 0; + } + if (*incx == *incy && *incx > 0) { + + nsteps = *n * *incx; + if (sflag < zero) { + sh11 = sparam[2]; + sh12 = sparam[4]; + sh21 = sparam[3]; + sh22 = sparam[5]; + i__1 = nsteps; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + w = sx[i__]; + z__ = sy[i__]; + sx[i__] = w * sh11 + z__ * sh12; + sy[i__] = w * sh21 + z__ * sh22; + } + } else if (sflag == zero) { + sh12 = sparam[4]; + sh21 = sparam[3]; + i__2 = nsteps; + i__1 = *incx; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { + w = sx[i__]; + z__ = sy[i__]; + sx[i__] = w + z__ * sh12; + sy[i__] = w * sh21 + z__; + } + } else { + sh11 = sparam[2]; + sh22 = sparam[5]; + i__1 = nsteps; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + w = sx[i__]; + z__ = sy[i__]; + sx[i__] = w * sh11 + z__; + sy[i__] = -w + sh22 * z__; + } + } + } else { + kx = 1; + ky = 1; + if (*incx < 0) { + kx = (1 - *n) * *incx + 1; + } + if (*incy < 0) { + ky = (1 - *n) * *incy + 1; + } + + if (sflag < zero) { + sh11 = sparam[2]; + sh12 = sparam[4]; + sh21 = sparam[3]; + sh22 = sparam[5]; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + w = sx[kx]; + z__ = sy[ky]; + sx[kx] = w * sh11 + z__ * sh12; + sy[ky] = w * sh21 + z__ * sh22; + kx += *incx; + ky += *incy; + } + } else if (sflag == zero) { + sh12 = sparam[4]; + sh21 = sparam[3]; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + w = sx[kx]; + z__ = sy[ky]; + sx[kx] = w + z__ * sh12; + sy[ky] = w * sh21 + z__; + kx += *incx; + ky += *incy; + } + } else { + sh11 = sparam[2]; + sh22 = sparam[5]; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + w = sx[kx]; + z__ = sy[ky]; + sx[kx] = w * sh11 + z__; + sy[ky] = -w + sh22 * z__; + kx += *incx; + ky += *incy; + } + } + } + return 0; +} /* srotm_ */ + diff --git a/ctest/c_sblat2c.c b/ctest/c_sblat2c.c new file mode 100644 index 000000000..7eac109f9 --- /dev/null +++ b/ctest/c_sblat2c.c @@ -0,0 +1,4234 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif +#if 0 +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +#endif +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i= 0; + + if (trace) { +/* o__1.oerr = 0; + o__1.ounit = ntra; + o__1.ofnmlen = 32; + o__1.ofnm = snaps; + o__1.orl = 0; + o__1.osta = 0; + o__1.oacc = 0; + o__1.ofm = 0; + o__1.oblnk = 0; + f_open(&o__1);*/ + } +/* Read the flag that directs rewinding of the snapshot file. */ + fgets(line,80,stdin); + sscanf(line,"%d",&rewi); + rewi = rewi && trace; +/* Read the flag that directs stopping on any failure. */ + fgets(line,80,stdin); + sscanf(line,"%c",&tmpchar); +/* Read the flag that indicates whether error exits are to be tested. */ + sfatal=FALSE_; + if (tmpchar=='T')sfatal=TRUE_; + fgets(line,80,stdin); + sscanf(line,"%c",&tmpchar); +/* Read the flag that indicates whether error exits are to be tested. */ + tsterr=FALSE_; + if (tmpchar=='T')tsterr=TRUE_; +/* Read the flag that indicates whether row-major data layout to be tested. */ + fgets(line,80,stdin); + sscanf(line,"%d",&layout); +/* Read the threshold value of the test ratio */ + fgets(line,80,stdin); + sscanf(line,"%f",&thresh); + +/* Read and check the parameter values for the tests. */ + +/* Values of N */ + fgets(line,80,stdin); + sscanf(line,"%d",&nidim); + + if (nidim < 1 || nidim > 9) { + fprintf(stderr,"NUMBER OF VALUES OF N IS LESS THAN 1 OR GREATER THAN 9"); + goto L220; + } + fgets(line,80,stdin); + sscanf(line,"%d %d %d %d %d %d %d %d %d",&idim[0],&idim[1],&idim[2], + &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]); + i__1 = nidim; + for (i__ = 1; i__ <= i__1; ++i__) { + if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) { + fprintf(stderr,"VALUE OF N IS LESS THAN 0 OR GREATER THAN 65\n"); + goto L220; + } +/* L10: */ + } +/* Values of K */ + fgets(line,80,stdin); + sscanf(line,"%d",&nkb); + + if (nkb < 1 || nkb > 7) { + fprintf(stderr,"NUMBER OF VALUES OF K IS LESS THAN 1 OR GREATER THAN 7"); + goto L220; + } + fgets(line,80,stdin); + sscanf(line,"%d %d %d %d %d %d %d",&kb[0],&kb[1],&kb[2],&kb[3],&kb[4],&kb[5],&kb[6]); + i__1 = nkb; + for (i__ = 1; i__ <= i__1; ++i__) { + if (kb[i__ - 1] < 0 ) { + fprintf(stderr,"VALUE OF K IS LESS THAN 0\n"); + goto L230; + } +/* L20: */ + } +/* Values of INCX and INCY */ + fgets(line,80,stdin); + sscanf(line,"%d",&ninc); + + if (ninc < 1 || ninc > 7) { + fprintf(stderr,"NUMBER OF VALUES OF INCX AND INCY IS LESS THAN 1 OR GREATER THAN 7"); + goto L230; + } + + fgets(line,80,stdin); + sscanf(line,"%d %d %d %d %d %d %d",&inc[0],&inc[1],&inc[2],&inc[3],&inc[4],&inc[5],&inc[6]); + i__1 = ninc; + for (i__ = 1; i__ <= i__1; ++i__) { + if (inc[i__ - 1] == 0 || (i__2 = inc[i__ - 1], abs(i__2)) > 2) { + fprintf (stderr,"ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN 2\n"); + goto L230; + } +/* L30: */ + } +/* Values of ALPHA */ + fgets(line,80,stdin); + sscanf(line,"%d",&nalf); + if (nalf < 1 || nalf > 7) { + fprintf(stderr,"VALUE OF ALPHA IS LESS THAN 0 OR GREATER THAN 7\n"); + goto L230; + } + fgets(line,80,stdin); + sscanf(line,"%f %f %f %f %f %f %f",&alf[0],&alf[1],&alf[2],&alf[3],&alf[4],&alf[5],&alf[6]); + +/* Values of BETA */ + fgets(line,80,stdin); + sscanf(line,"%d",&nbet); + if (nbet < 1 || nbet > 7) { + fprintf(stderr,"VALUE OF BETA IS LESS THAN 0 OR GREATER THAN 7\n"); + goto L230; + } + fgets(line,80,stdin); + sscanf(line,"%f %f %f %f %f %f %f",&bet[0],&bet[1],&bet[2],&bet[3],&bet[4],&bet[5],&bet[6]); + +/* Report values of parameters. */ + printf("TESTS OF THE REAL LEVEL 2 BLAS\nTHE FOLLOWING PARAMETER VALUES WILL BE USED:\n"); + printf(" FOR N"); + for (i__ =1; i__ <=nidim;++i__) printf(" %d",idim[i__-1]); + printf("\n"); + + printf(" FOR K"); + for (i__ =1; i__ <=nkb;++i__) printf(" %d",kb[i__-1]); + printf("\n"); + + printf(" FOR INCX AND INCY"); + for (i__ =1; i__ <=ninc;++i__) printf(" %d",inc[i__-1]); + printf("\n"); + + printf(" FOR ALPHA"); + for (i__ =1; i__ <=nalf;++i__) printf(" %f",alf[i__-1]); + printf("\n"); + printf(" FOR BETA"); + for (i__ =1; i__ <=nbet;++i__) printf(" %f",bet[i__-1]); + printf("\n"); + + if (! tsterr) { + printf(" ERROR-EXITS WILL NOT BE TESTED\n"); + } + printf("ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LESS THAN %f\n",thresh); + + rorder = FALSE_; + corder = FALSE_; + if (layout == 2) { + rorder = TRUE_; + corder = TRUE_; + printf("COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED\n"); + } else if (layout == 1) { + rorder = TRUE_; + printf("ROW-MAJOR DATA LAYOUT IS TESTED\n"); + } else if (layout == 0) { + corder = TRUE_; + printf("COLUMN-MAJOR DATA LAYOUT IS TESTED\n"); + } + +/* Read names of subroutines and flags which indicate */ +/* whether they are to be tested. */ + + for (i__ = 1; i__ <= 16; ++i__) { + ltest[i__ - 1] = FALSE_; +/* L40: */ + } +L50: + if (! fgets(line,80,stdin)) { + goto L80; + } + i__1 = sscanf(line,"%12c %c",snamet,&tmpchar); + ltestt=FALSE_; + if (tmpchar=='T')ltestt=TRUE_; + if (i__1 < 2) { + goto L80; + } + + for (i__ = 1; i__ <= 16; ++i__) { + if (s_cmp(snamet, snames[i__ - 1], (ftnlen)12, (ftnlen)12) == + 0) { + goto L70; + } +/* L60: */ + } + printf("SUBPROGRAM NAME %s NOT RECOGNIZED\n****** TESTS ABANDONED ******\n",snamet); + exit(1); +L70: + ltest[i__ - 1] = ltestt; + goto L50; + +L80: +/* cl__1.cerr = 0; + cl__1.cunit = 5; + cl__1.csta = 0; + f_clos(&cl__1);*/ + +/* Compute EPS (the machine precision). */ + + eps = (float)1.; +L90: + r__1 = eps + (float)1.; + if (sdiff_(&r__1, &c_b123) == (float)0.) { + goto L100; + } + eps *= (float).5; + goto L90; +L100: + eps += eps; + printf("RELATIVE MACHINE PRECISION IS TAKEN TO BE %9.1g\n",eps); + +/* Check the reliability of SMVCH using exact data. */ + + n = 32; + i__1 = n; + for (j = 1; j <= i__1; ++j) { + i__2 = n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + i__3 = i__ - j + 1; + a[i__ + j * 65 - 66] = (real) f2cmax(i__3,0); +/* L110: */ + } + x[j - 1] = (real) j; + y[j - 1] = (float)0.; +/* L120: */ + } + i__1 = n; + for (j = 1; j <= i__1; ++j) { + yy[j - 1] = (real) (j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3) + ; +/* L130: */ + } +/* YY holds the exact result. On exit from SMVCH YT holds */ +/* the result computed by SMVCH. */ + *(unsigned char *)trans = 'N'; + smvch_(trans, &n, &n, &c_b123, a, &c__65, x, &c__1, &c_b135, y, &c__1, yt, + g, yy, &eps, &err, &fatal, &c__6, &c_true, (ftnlen)1); + same = lse_(yy, yt, &n); + if (! same || err != (float)0.) { + printf("ERROR IN SMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); + printf("SMVCH WAS CALLED WITH TRANS = %s ", trans); + printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); + printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); + printf("****** TESTS ABANDONED ******\n"); + exit(1); + } + *(unsigned char *)trans = 'T'; + smvch_(trans, &n, &n, &c_b123, a, &c__65, x, &c_n1, &c_b135, y, &c_n1, yt, + g, yy, &eps, &err, &fatal, &c__6, &c_true, (ftnlen)1); + same = lse_(yy, yt, &n); + if (! same || err != (float)0.) { + printf("ERROR IN SMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); + printf("SMVCH WAS CALLED WITH TRANS = %s ", trans); + printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); + printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); + printf("****** TESTS ABANDONED ******\n"); + exit(1); + } + +/* Test each subroutine in turn. */ + + for (isnum = 1; isnum <= 16; ++isnum) { + if (! ltest[isnum - 1]) { +/* Subprogram is not to be tested. */ + printf("%12s WAS NOT TESTED\n",snames[isnum-1]); + } else { + s_copy(srnamc_1.srnamt, snames[isnum - 1], (ftnlen)12, ( + ftnlen)12); +/* Test error exits. */ + if (tsterr) { + cs2chke_(snames[isnum - 1], (ftnlen)12); + } +/* Test computations. */ + infoc_1.infot = 0; + infoc_1.ok = TRUE_; + fatal = FALSE_; + switch ((int)isnum) { + case 1: goto L140; + case 2: goto L140; + case 3: goto L150; + case 4: goto L150; + case 5: goto L150; + case 6: goto L160; + case 7: goto L160; + case 8: goto L160; + case 9: goto L160; + case 10: goto L160; + case 11: goto L160; + case 12: goto L170; + case 13: goto L180; + case 14: goto L180; + case 15: goto L190; + case 16: goto L190; + } +/* Test SGEMV, 01, and SGBMV, 02. */ +L140: + if (corder) { + schk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, + alf, &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, + as, x, xx, xs, y, yy, ys, yt, g, &c__0, (ftnlen)12); + } + if (rorder) { + schk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, + alf, &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, + as, x, xx, xs, y, yy, ys, yt, g, &c__1, (ftnlen)12); + } + goto L200; +/* Test SSYMV, 03, SSBMV, 04, and SSPMV, 05. */ +L150: + if (corder) { + schk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, + alf, &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, + as, x, xx, xs, y, yy, ys, yt, g, &c__0, (ftnlen)12); + } + if (rorder) { + schk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, + alf, &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, + as, x, xx, xs, y, yy, ys, yt, g, &c__1, (ftnlen)12); + } + goto L200; +/* Test STRMV, 06, STBMV, 07, STPMV, 08, */ +/* STRSV, 09, STBSV, 10, and STPSV, 11. */ +L160: + if (corder) { + schk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &ninc, + inc, &c__65, &c__2, a, aa, as, y, yy, ys, yt, g, z__, + &c__0, (ftnlen)12); + } + if (rorder) { + schk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &ninc, + inc, &c__65, &c__2, a, aa, as, y, yy, ys, yt, g, z__, + &c__1, (ftnlen)12); + } + goto L200; +/* Test SGER, 12. */ +L170: + if (corder) { + schk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, + ys, yt, g, z__, &c__0, (ftnlen)12); + } + if (rorder) { + schk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, + ys, yt, g, z__, &c__1, (ftnlen)12); + } + goto L200; +/* Test SSYR, 13, and SSPR, 14. */ +L180: + if (corder) { + schk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, + ys, yt, g, z__, &c__0, (ftnlen)12); + } + if (rorder) { + schk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, + ys, yt, g, z__, &c__1, (ftnlen)12); + } + goto L200; +/* Test SSYR2, 15, and SSPR2, 16. */ +L190: + if (corder) { + schk6_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, + ys, yt, g, z__, &c__0, (ftnlen)12); + } + if (rorder) { + schk6_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, + ys, yt, g, z__, &c__1, (ftnlen)12); + } + +L200: + if (fatal && sfatal) { + goto L220; + } + } +/* L210: */ + } + printf("\nEND OF TESTS\n"); + goto L240; + +L220: + printf("\n****** FATAL ERROR - TESTS ABANDONED ******\n"); + goto L240; + +L230: + printf("AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM\n"); + printf("****** TESTS ABANDONED ******\n"); + +L240: + if (trace) { +/* cl__1.cerr = 0; + cl__1.cunit = ntra; + cl__1.csta = 0; + f_clos(&cl__1);*/ + } +/* cl__1.cerr = 0; + cl__1.cunit = 6; + cl__1.csta = 0; + f_clos(&cl__1); + s_stop("", (ftnlen)0);*/ + exit(0); + +/* End of SBLAT2. */ + +} /* MAIN__ */ + +/* Subroutine */ int 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, sname_len) +char *sname; +real *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nkb, *kb, *nalf; +real *alf; +integer *nbet; +real *bet; +integer *ninc, *inc, *nmax, *incmax; +real *a, *aa, *as, *x, *xx, *xs, *y, *yy, *ys, *yt, *g; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ich[3+1] = "NTC"; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8; + + /* Local variables */ + static real beta; + static integer ldas; + static logical same; + static integer incx, incy; + static logical full, tran, null; + static integer i__, m, n; + static real alpha; + static logical isame[13]; + extern /* Subroutine */ int smake_(); + static integer nargs; + extern /* Subroutine */ int smvch_(); + static logical reset; + static integer incxs, incys; + static char trans[1]; + static integer ia, ib, ic; + static logical banded; + static integer nc, nd, im, in, kl, ml, nk, nl, ku, ix, iy, ms, lx, ly, ns; + extern /* Subroutine */ int csgbmv_(), csgemv_(); + static char ctrans[14]; + static real errmax; + extern logical lseres_(); + static real transl; + static char transs[1]; + static integer laa, lda; + static real als, bls; + extern logical lse_(); + static real err; + static integer iku, kls, kus; + +/* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --kb; + --alf; + --bet; + --inc; + --g; + --yt; + --y; + --x; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ys; + --yy; + --xs; + --xx; + + /* Function Body */ +/* .. Executable Statements .. */ + full = *(unsigned char *)&sname[8] == 'e'; + banded = *(unsigned char *)&sname[8] == 'b'; +/* Define the number of arguments. */ + if (full) { + nargs = 11; + } else if (banded) { + nargs = 13; + } + + nc = 0; + reset = TRUE_; + errmax = (float)0.; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; + nd = n / 2 + 1; + + for (im = 1; im <= 2; ++im) { + if (im == 1) { +/* Computing MAX */ + i__2 = n - nd; + m = f2cmax(i__2,0); + } + if (im == 2) { +/* Computing MIN */ + i__2 = n + nd; + m = f2cmin(i__2,*nmax); + } + + if (banded) { + nk = *nkb; + } else { + nk = 1; + } + i__2 = nk; + for (iku = 1; iku <= i__2; ++iku) { + if (banded) { + ku = kb[iku]; +/* Computing MAX */ + i__3 = ku - 1; + kl = f2cmax(i__3,0); + } else { + ku = n - 1; + kl = m - 1; + } +/* Set LDA to 1 more than minimum value if room. */ + if (banded) { + lda = kl + ku + 1; + } else { + lda = m; + } + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L100; + } + laa = lda * n; + null = n <= 0 || m <= 0; + +/* Generate the matrix A. */ + + transl = (float)0.; + smake_(sname + 7, " ", " ", &m, &n, &a[a_offset], nmax, &aa[1] + , &lda, &kl, &ku, &reset, &transl, (ftnlen)2, (ftnlen) + 1, (ftnlen)1); + + for (ic = 1; ic <= 3; ++ic) { + *(unsigned char *)trans = *(unsigned char *)&ich[ic - 1]; + if (*(unsigned char *)trans == 'N') { + s_copy(ctrans, " CblasNoTrans", (ftnlen)14, (ftnlen) + 14); + } else if (*(unsigned char *)trans == 'T') { + s_copy(ctrans, " CblasTrans", (ftnlen)14, (ftnlen) + 14); + } else { + s_copy(ctrans, "CblasConjTrans", (ftnlen)14, (ftnlen) + 14); + } + tran = *(unsigned char *)trans == 'T' || *(unsigned char * + )trans == 'C'; + + if (tran) { + ml = n; + nl = m; + } else { + ml = m; + nl = n; + } + + i__3 = *ninc; + for (ix = 1; ix <= i__3; ++ix) { + incx = inc[ix]; + lx = abs(incx) * nl; + +/* Generate the vector X. */ + + transl = (float).5; + i__4 = abs(incx); + i__5 = nl - 1; + smake_("ge", " ", " ", &c__1, &nl, &x[1], &c__1, &xx[ + 1], &i__4, &c__0, &i__5, &reset, &transl, ( + ftnlen)2, (ftnlen)1, (ftnlen)1); + if (nl > 1) { + x[nl / 2] = (float)0.; + xx[abs(incx) * (nl / 2 - 1) + 1] = (float)0.; + } + + i__4 = *ninc; + for (iy = 1; iy <= i__4; ++iy) { + incy = inc[iy]; + ly = abs(incy) * ml; + + i__5 = *nalf; + for (ia = 1; ia <= i__5; ++ia) { + alpha = alf[ia]; + + i__6 = *nbet; + for (ib = 1; ib <= i__6; ++ib) { + beta = bet[ib]; + +/* Generate the vector Y. */ + + transl = (float)0.; + i__7 = abs(incy); + i__8 = ml - 1; + smake_("ge", " ", " ", &c__1, &ml, &y[1], + &c__1, &yy[1], &i__7, &c__0, & + i__8, &reset, &transl, (ftnlen)2, + (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the */ +/* subroutine. */ + + *(unsigned char *)transs = *(unsigned + char *)trans; + ms = m; + ns = n; + kls = kl; + kus = ku; + als = alpha; + i__7 = laa; + for (i__ = 1; i__ <= i__7; ++i__) { + as[i__] = aa[i__]; +/* L10: */ + } + ldas = lda; + i__7 = lx; + for (i__ = 1; i__ <= i__7; ++i__) { + xs[i__] = xx[i__]; +/* L20: */ + } + incxs = incx; + bls = beta; + i__7 = ly; + for (i__ = 1; i__ <= i__7; ++i__) { + ys[i__] = yy[i__]; +/* L30: */ + } + incys = incy; + +/* Call the subroutine. */ + + if (full) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s %14s %3d %3d %4.1f A %3d X %2d %4.1f Y %2d .\n", + nc,sname,ctrans,m,n,alpha,lda,incx,beta,incy); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + csgemv_(iorder, trans, &m, &n, &alpha, + &aa[1], &lda, &xx[1], &incx, + &beta, &yy[1], &incy, (ftnlen) + 1); + } else if (banded) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s %14s %3d %3d %3d %3d %4.1f A %3d %2d %4.1f Y %2d\n", + nc,sname,ctrans,m,n,kl,ku,alpha,lda,incx,beta,incy); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + csgbmv_(iorder, trans, &m, &n, &kl, & + ku, &alpha, &aa[1], &lda, &xx[ + 1], &incx, &beta, &yy[1], & + incy, (ftnlen)1); + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf(" ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******n"); + *fatal = TRUE_; + goto L130; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)trans == *( + unsigned char *)transs; + isame[1] = ms == m; + isame[2] = ns == n; + if (full) { + isame[3] = als == alpha; + isame[4] = lse_(&as[1], &aa[1], &laa); + isame[5] = ldas == lda; + isame[6] = lse_(&xs[1], &xx[1], &lx); + isame[7] = incxs == incx; + isame[8] = bls == beta; + if (null) { + isame[9] = lse_(&ys[1], &yy[1], & + ly); + } else { + i__7 = abs(incy); + isame[9] = lseres_("ge", " ", & + c__1, &ml, &ys[1], &yy[1], + &i__7, (ftnlen)2, ( + ftnlen)1); + } + isame[10] = incys == incy; + } else if (banded) { + isame[3] = kls == kl; + isame[4] = kus == ku; + isame[5] = als == alpha; + isame[6] = lse_(&as[1], &aa[1], &laa); + isame[7] = ldas == lda; + isame[8] = lse_(&xs[1], &xx[1], &lx); + isame[9] = incxs == incx; + isame[10] = bls == beta; + if (null) { + isame[11] = lse_(&ys[1], &yy[1], & + ly); + } else { + i__7 = abs(incy); + isame[11] = lseres_("ge", " ", & + c__1, &ml, &ys[1], &yy[1], + &i__7, (ftnlen)2, ( + ftnlen)1); + } + isame[12] = incys == incy; + } + +/* If data was incorrectly changed, report */ +/* and return. */ + + same = TRUE_; + i__7 = nargs; + for (i__ = 1; i__ <= i__7; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L130; + } + + if (! null) { + +/* Check the result. */ + + smvch_(trans, &m, &n, &alpha, &a[ + a_offset], nmax, &x[1], &incx, + &beta, &y[1], &incy, &yt[1], + &g[1], &yy[1], eps, &err, + fatal, nout, &c_true, (ftnlen) + 1); + errmax = dmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L130; + } + } else { +/* Avoid repeating tests with M.le.0 or */ +/* N.le.0. */ + goto L110; + } + +/* L50: */ + } + +/* L60: */ + } + +/* L70: */ + } + +/* L80: */ + } + +/* L90: */ + } + +L100: + ; + } + +L110: + ; + } + +/* L120: */ + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%12s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%12s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%12s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);; + } + if (*iorder == 1) { + printf("%12s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);; + } + } + goto L140; + +L130: + printf("******* %12s FAILED ON CALL NUMBER:",sname); + if (full) { + printf("%6d: %12s %14s %3d %3d %4.1f A %3d X %2d %4.1f Y %2d .\n", + nc,sname,ctrans,m,n,alpha,lda,incx,beta,incy); + } else if (banded) { + printf("%6d: %12s %14s %3d %3d %3d %3d %4.1f A %3d %2d %4.1f Y %2d\n", + nc,sname,ctrans,m,n,kl,ku,alpha,lda,incx,beta,incy); + } + +L140: + return 0; + +/* 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', */ +/* $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, */ +/* $ ' - SUSPECT *******' ) */ + +/* End of SCHK1. */ + +} /* schk1_ */ + +/* Subroutine */ int 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, sname_len) +char *sname; +real *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nkb, *kb, *nalf; +real *alf; +integer *nbet; +real *bet; +integer *ninc, *inc, *nmax, *incmax; +real *a, *aa, *as, *x, *xx, *xs, *y, *yy, *ys, *yt, *g; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ich[2+1] = "UL"; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8; + + /* Local variables */ + static real beta; + static integer ldas; + static logical same; + static integer incx, incy; + static logical full, null; + static char uplo[1]; + static integer i__, k, n; + static real alpha; + static logical isame[13]; + extern /* Subroutine */ int smake_(); + static integer nargs; + extern /* Subroutine */ int smvch_(); + static logical reset; + static char cuplo[14]; + static integer incxs, incys; + static char uplos[1]; + static integer ia, ib, ic; + static logical banded; + static integer nc, ik, in; + static logical packed; + static integer nk, ks, ix, iy, ns, lx, ly; + static real errmax; + extern logical lseres_(); + extern /* Subroutine */ int cssbmv_(); + static real transl; + extern /* Subroutine */ int csspmv_(), cssymv_(); + static integer laa, lda; + static real als, bls; + extern logical lse_(); + static real err; + +/* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --kb; + --alf; + --bet; + --inc; + --g; + --yt; + --y; + --x; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ys; + --yy; + --xs; + --xx; + + /* Function Body */ +/* .. Executable Statements .. */ + full = *(unsigned char *)&sname[8] == 'y'; + banded = *(unsigned char *)&sname[8] == 'b'; + packed = *(unsigned char *)&sname[8] == 'p'; +/* Define the number of arguments. */ + if (full) { + nargs = 10; + } else if (banded) { + nargs = 11; + } else if (packed) { + nargs = 9; + } + + nc = 0; + reset = TRUE_; + errmax = (float)0.; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; + + if (banded) { + nk = *nkb; + } else { + nk = 1; + } + i__2 = nk; + for (ik = 1; ik <= i__2; ++ik) { + if (banded) { + k = kb[ik]; + } else { + k = n - 1; + } +/* Set LDA to 1 more than minimum value if room. */ + if (banded) { + lda = k + 1; + } else { + lda = n; + } + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L100; + } + if (packed) { + laa = n * (n + 1) / 2; + } else { + laa = lda * n; + } + null = n <= 0; + + for (ic = 1; ic <= 2; ++ic) { + *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1]; + if (*(unsigned char *)uplo == 'U') { + s_copy(cuplo, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cuplo, " CblasLower", (ftnlen)14, (ftnlen)14); + } + +/* Generate the matrix A. */ + + transl = (float)0.; + smake_(sname + 7, uplo, " ", &n, &n, &a[a_offset], nmax, &aa[ + 1], &lda, &k, &k, &reset, &transl, (ftnlen)2, (ftnlen) + 1, (ftnlen)1); + + i__3 = *ninc; + for (ix = 1; ix <= i__3; ++ix) { + incx = inc[ix]; + lx = abs(incx) * n; + +/* Generate the vector X. */ + + transl = (float).5; + i__4 = abs(incx); + i__5 = n - 1; + smake_("ge", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], & + i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, ( + ftnlen)1, (ftnlen)1); + if (n > 1) { + x[n / 2] = (float)0.; + xx[abs(incx) * (n / 2 - 1) + 1] = (float)0.; + } + + i__4 = *ninc; + for (iy = 1; iy <= i__4; ++iy) { + incy = inc[iy]; + ly = abs(incy) * n; + + i__5 = *nalf; + for (ia = 1; ia <= i__5; ++ia) { + alpha = alf[ia]; + + i__6 = *nbet; + for (ib = 1; ib <= i__6; ++ib) { + beta = bet[ib]; + +/* Generate the vector Y. */ + + transl = (float)0.; + i__7 = abs(incy); + i__8 = n - 1; + smake_("ge", " ", " ", &c__1, &n, &y[1], & + c__1, &yy[1], &i__7, &c__0, &i__8, & + reset, &transl, (ftnlen)2, (ftnlen)1, + (ftnlen)1); + + ++nc; + +/* Save every datum before calling the */ +/* subroutine. */ + + *(unsigned char *)uplos = *(unsigned char *) + uplo; + ns = n; + ks = k; + als = alpha; + i__7 = laa; + for (i__ = 1; i__ <= i__7; ++i__) { + as[i__] = aa[i__]; +/* L10: */ + } + ldas = lda; + i__7 = lx; + for (i__ = 1; i__ <= i__7; ++i__) { + xs[i__] = xx[i__]; +/* L20: */ + } + incxs = incx; + bls = beta; + i__7 = ly; + for (i__ = 1; i__ <= i__7; ++i__) { + ys[i__] = yy[i__]; +/* L30: */ + } + incys = incy; + +/* Call the subroutine. */ + + if (full) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %3d, %4.1f, A %3d, X %2d, %4.1f Y %2d )..\n", + nc,sname,cuplo,n,alpha,lda,incx,beta,incy); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cssymv_(iorder, uplo, &n, &alpha, &aa[1], + &lda, &xx[1], &incx, &beta, &yy[1] + , &incy, (ftnlen)1); + } else if (banded) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s %3d, %3d, %4.1f, A %3d, X %2d, %4.1f, Y, %2d ).\n", + nc,sname,cuplo,n,k,alpha,lda,incx,beta,incy); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cssbmv_(iorder, uplo, &n, &k, &alpha, &aa[ + 1], &lda, &xx[1], &incx, &beta, & + yy[1], &incy, (ftnlen)1); + } else if (packed) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s ( %14s %3d, %4.1f, AP X %2d, %4.1f, Y, %2d ).\n", + nc,sname,cuplo,n,alpha,incx,beta,incy); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + csspmv_(iorder, uplo, &n, &alpha, &aa[1], + &xx[1], &incx, &beta, &yy[1], & + incy, (ftnlen)1); + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf(" ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******n"); + *fatal = TRUE_; + goto L120; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)uplo == *( + unsigned char *)uplos; + isame[1] = ns == n; + if (full) { + isame[2] = als == alpha; + isame[3] = lse_(&as[1], &aa[1], &laa); + isame[4] = ldas == lda; + isame[5] = lse_(&xs[1], &xx[1], &lx); + isame[6] = incxs == incx; + isame[7] = bls == beta; + if (null) { + isame[8] = lse_(&ys[1], &yy[1], &ly); + } else { + i__7 = abs(incy); + isame[8] = lseres_("ge", " ", &c__1, & + n, &ys[1], &yy[1], &i__7, ( + ftnlen)2, (ftnlen)1); + } + isame[9] = incys == incy; + } else if (banded) { + isame[2] = ks == k; + isame[3] = als == alpha; + isame[4] = lse_(&as[1], &aa[1], &laa); + isame[5] = ldas == lda; + isame[6] = lse_(&xs[1], &xx[1], &lx); + isame[7] = incxs == incx; + isame[8] = bls == beta; + if (null) { + isame[9] = lse_(&ys[1], &yy[1], &ly); + } else { + i__7 = abs(incy); + isame[9] = lseres_("ge", " ", &c__1, & + n, &ys[1], &yy[1], &i__7, ( + ftnlen)2, (ftnlen)1); + } + isame[10] = incys == incy; + } else if (packed) { + isame[2] = als == alpha; + isame[3] = lse_(&as[1], &aa[1], &laa); + isame[4] = lse_(&xs[1], &xx[1], &lx); + isame[5] = incxs == incx; + isame[6] = bls == beta; + if (null) { + isame[7] = lse_(&ys[1], &yy[1], &ly); + } else { + i__7 = abs(incy); + isame[7] = lseres_("ge", " ", &c__1, & + n, &ys[1], &yy[1], &i__7, ( + ftnlen)2, (ftnlen)1); + } + isame[8] = incys == incy; + } + +/* If data was incorrectly changed, report and */ +/* return. */ + + same = TRUE_; + i__7 = nargs; + for (i__ = 1; i__ <= i__7; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L120; + } + + if (! null) { + +/* Check the result. */ + + smvch_("N", &n, &n, &alpha, &a[a_offset], + nmax, &x[1], &incx, &beta, &y[1], + &incy, &yt[1], &g[1], &yy[1], eps, + &err, fatal, nout, &c_true, ( + ftnlen)1); + errmax = dmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L120; + } + } else { +/* Avoid repeating tests with N.le.0 */ + goto L110; + } + +/* L50: */ + } + +/* L60: */ + } + +/* L70: */ + } + +/* L80: */ + } + +/* L90: */ + } + +L100: + ; + } + +L110: + ; + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%12s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%12s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%12s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);; + } + if (*iorder == 1) { + printf("%12s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);; + } + } + goto L130; + +L120: + printf("******* %12s FAILED ON CALL NUMBER:",sname); + + if (full) { + printf("%6d: %12s (%14s, %3d, %4.1f, A %3d, X %2d, %4.1f Y %2d )..\n", + nc,sname,cuplo,n,alpha,lda,incx,beta,incy); + } else if (banded) { + + printf("%6d: %12s (%14s %3d, %3d, %4.1f, A %3d, X %2d, %4.1f, Y, %2d ).\n", + nc,sname,cuplo,n,k,alpha,lda,incx,beta,incy); + } else if (packed) { + printf("%6d: %12s ( %14s %3d, %4.1f, AP X %2d, %4.1f, Y, %2d ).\n", + nc,sname,cuplo,n,alpha,incx,beta,incy); + } + +L130: + return 0; + +/* 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', */ +/* $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, */ +/* $ ' - SUSPECT *******' ) */ + +/* End of SCHK2. */ + +} /* schk2_ */ + +/* Subroutine */ int 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, sname_len) +char *sname; +real *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nkb, *kb, *ninc, *inc, *nmax, *incmax; +real *a, *aa, *as, *x, *xx, *xs, *xt, *g, *z__; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ichu[2+1] = "UL"; + static char icht[3+1] = "NTC"; + static char ichd[2+1] = "UN"; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + + /* Local variables */ + static char diag[1]; + static integer ldas; + static logical same; + static integer incx; + static logical full, null; + static char uplo[1], cdiag[14]; + static integer i__, k, n; + static char diags[1]; + static logical isame[13]; + extern /* Subroutine */ int smake_(); + static integer nargs; + extern /* Subroutine */ int smvch_(); + static logical reset; + static char cuplo[14]; + static integer incxs; + static char trans[1], uplos[1]; + static logical banded; + static integer nc, ik, in; + static logical packed; + static integer nk, ks, ix, ns, lx; + static char ctrans[14]; + static real errmax; + extern logical lseres_(); + extern /* Subroutine */ int cstbmv_(); + static real transl; + extern /* Subroutine */ int cstbsv_(); + static char transs[1]; + extern /* Subroutine */ int cstpmv_(), cstrmv_(), cstpsv_(), cstrsv_(); + static integer laa, icd, lda, ict, icu; + extern logical lse_(); + static real err; + +/* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --kb; + --inc; + --z__; + --g; + --xt; + --x; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --xs; + --xx; + + /* Function Body */ +/* .. Executable Statements .. */ + full = *(unsigned char *)&sname[8] == 'r'; + banded = *(unsigned char *)&sname[8] == 'b'; + packed = *(unsigned char *)&sname[8] == 'p'; +/* Define the number of arguments. */ + if (full) { + nargs = 8; + } else if (banded) { + nargs = 9; + } else if (packed) { + nargs = 7; + } + + nc = 0; + reset = TRUE_; + errmax = (float)0.; +/* Set up zero vector for SMVCH. */ + i__1 = *nmax; + for (i__ = 1; i__ <= i__1; ++i__) { + z__[i__] = (float)0.; +/* L10: */ + } + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; + + if (banded) { + nk = *nkb; + } else { + nk = 1; + } + i__2 = nk; + for (ik = 1; ik <= i__2; ++ik) { + if (banded) { + k = kb[ik]; + } else { + k = n - 1; + } +/* Set LDA to 1 more than minimum value if room. */ + if (banded) { + lda = k + 1; + } else { + lda = n; + } + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L100; + } + if (packed) { + laa = n * (n + 1) / 2; + } else { + laa = lda * n; + } + null = n <= 0; + + for (icu = 1; icu <= 2; ++icu) { + *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; + if (*(unsigned char *)uplo == 'U') { + s_copy(cuplo, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cuplo, " CblasLower", (ftnlen)14, (ftnlen)14); + } + + for (ict = 1; ict <= 3; ++ict) { + *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1] + ; + if (*(unsigned char *)trans == 'N') { + s_copy(ctrans, " CblasNoTrans", (ftnlen)14, (ftnlen) + 14); + } else if (*(unsigned char *)trans == 'T') { + s_copy(ctrans, " CblasTrans", (ftnlen)14, (ftnlen) + 14); + } else { + s_copy(ctrans, "CblasConjTrans", (ftnlen)14, (ftnlen) + 14); + } + + for (icd = 1; icd <= 2; ++icd) { + *(unsigned char *)diag = *(unsigned char *)&ichd[icd + - 1]; + if (*(unsigned char *)diag == 'N') { + s_copy(cdiag, " CblasNonUnit", (ftnlen)14, ( + ftnlen)14); + } else { + s_copy(cdiag, " CblasUnit", (ftnlen)14, ( + ftnlen)14); + } + +/* Generate the matrix A. */ + + transl = (float)0.; + smake_(sname + 7, uplo, diag, &n, &n, &a[a_offset], + nmax, &aa[1], &lda, &k, &k, &reset, &transl, ( + ftnlen)2, (ftnlen)1, (ftnlen)1); + + i__3 = *ninc; + for (ix = 1; ix <= i__3; ++ix) { + incx = inc[ix]; + lx = abs(incx) * n; + +/* Generate the vector X. */ + + transl = (float).5; + i__4 = abs(incx); + i__5 = n - 1; + smake_("ge", " ", " ", &c__1, &n, &x[1], &c__1, & + xx[1], &i__4, &c__0, &i__5, &reset, & + transl, (ftnlen)2, (ftnlen)1, (ftnlen)1); + if (n > 1) { + x[n / 2] = (float)0.; + xx[abs(incx) * (n / 2 - 1) + 1] = (float)0.; + } + + ++nc; + +/* Save every datum before calling the subroutine. */ + + *(unsigned char *)uplos = *(unsigned char *)uplo; + *(unsigned char *)transs = *(unsigned char *) + trans; + *(unsigned char *)diags = *(unsigned char *)diag; + ns = n; + ks = k; + i__4 = laa; + for (i__ = 1; i__ <= i__4; ++i__) { + as[i__] = aa[i__]; +/* L20: */ + } + ldas = lda; + i__4 = lx; + for (i__ = 1; i__ <= i__4; ++i__) { + xs[i__] = xx[i__]; +/* L30: */ + } + incxs = incx; + +/* Call the subroutine. */ + + if (s_cmp(sname + 9, "mv", (ftnlen)2, (ftnlen)2) + == 0) { + if (full) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s,%14s,%14s %3d ,A, %3d, X, %2d ).\n", + nc,sname,cuplo,ctrans,cdiag,n,lda,incx); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cstrmv_(iorder, uplo, trans, diag, &n, & + aa[1], &lda, &xx[1], &incx, ( + ftnlen)1, (ftnlen)1, (ftnlen)1); + } else if (banded) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s,%14s,%14s %3d, %3d ,A, %3d, X, %2d ).\n", + nc,sname,cuplo,ctrans,cdiag,n,k,lda,incx); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cstbmv_(iorder, uplo, trans, diag, &n, &k, + &aa[1], &lda, &xx[1], &incx, ( + ftnlen)1, (ftnlen)1, (ftnlen)1); + } else if (packed) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s,%14s,%14s %3d ,AP, X, %2d ).\n", + nc,sname,cuplo,ctrans,cdiag,n,incx); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cstpmv_(iorder, uplo, trans, diag, &n, & + aa[1], &xx[1], &incx, (ftnlen)1, ( + ftnlen)1, (ftnlen)1); + } + } else if (s_cmp(sname + 9, "sv", (ftnlen)2, ( + ftnlen)2) == 0) { + if (full) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s,%14s,%14s %3d ,A, %3d, X, %2d ).\n", + nc,sname,cuplo,ctrans,cdiag,n,lda,incx); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cstrsv_(iorder, uplo, trans, diag, &n, & + aa[1], &lda, &xx[1], &incx, ( + ftnlen)1, (ftnlen)1, (ftnlen)1); + } else if (banded) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s,%14s,%14s %3d, %3d ,A, %3d, X, %2d ).\n", + nc,sname,cuplo,ctrans,cdiag,n,k,lda,incx); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cstbsv_(iorder, uplo, trans, diag, &n, &k, + &aa[1], &lda, &xx[1], &incx, ( + ftnlen)1, (ftnlen)1, (ftnlen)1); + } else if (packed) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s,%14s,%14s %3d ,AP, X, %2d ).\n", + nc,sname,cuplo,ctrans,cdiag,n,incx); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cstpsv_(iorder, uplo, trans, diag, &n, & + aa[1], &xx[1], &incx, (ftnlen)1, ( + ftnlen)1, (ftnlen)1); + } + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf(" ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******n"); + *fatal = TRUE_; + goto L120; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)uplo == *(unsigned + char *)uplos; + isame[1] = *(unsigned char *)trans == *(unsigned + char *)transs; + isame[2] = *(unsigned char *)diag == *(unsigned + char *)diags; + isame[3] = ns == n; + if (full) { + isame[4] = lse_(&as[1], &aa[1], &laa); + isame[5] = ldas == lda; + if (null) { + isame[6] = lse_(&xs[1], &xx[1], &lx); + } else { + i__4 = abs(incx); + isame[6] = lseres_("ge", " ", &c__1, &n, & + xs[1], &xx[1], &i__4, (ftnlen)2, ( + ftnlen)1); + } + isame[7] = incxs == incx; + } else if (banded) { + isame[4] = ks == k; + isame[5] = lse_(&as[1], &aa[1], &laa); + isame[6] = ldas == lda; + if (null) { + isame[7] = lse_(&xs[1], &xx[1], &lx); + } else { + i__4 = abs(incx); + isame[7] = lseres_("ge", " ", &c__1, &n, & + xs[1], &xx[1], &i__4, (ftnlen)2, ( + ftnlen)1); + } + isame[8] = incxs == incx; + } else if (packed) { + isame[4] = lse_(&as[1], &aa[1], &laa); + if (null) { + isame[5] = lse_(&xs[1], &xx[1], &lx); + } else { + i__4 = abs(incx); + isame[5] = lseres_("ge", " ", &c__1, &n, & + xs[1], &xx[1], &i__4, (ftnlen)2, ( + ftnlen)1); + } + isame[6] = incxs == incx; + } + +/* If data was incorrectly changed, report and */ +/* return. */ + + same = TRUE_; + i__4 = nargs; + for (i__ = 1; i__ <= i__4; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L120; + } + + if (! null) { + if (s_cmp(sname + 9, "mv", (ftnlen)2, (ftnlen) + 2) == 0) { + +/* Check the result. */ + + smvch_(trans, &n, &n, &c_b123, &a[ + a_offset], nmax, &x[1], &incx, & + c_b135, &z__[1], &incx, &xt[1], & + g[1], &xx[1], eps, &err, fatal, + nout, &c_true, (ftnlen)1); + } else if (s_cmp(sname + 9, "sv", (ftnlen)2, ( + ftnlen)2) == 0) { + +/* Compute approximation to original vector. */ + + i__4 = n; + for (i__ = 1; i__ <= i__4; ++i__) { + z__[i__] = xx[(i__ - 1) * abs(incx) + + 1]; + xx[(i__ - 1) * abs(incx) + 1] = x[i__] + ; +/* L50: */ + } + smvch_(trans, &n, &n, &c_b123, &a[ + a_offset], nmax, &z__[1], &incx, & + c_b135, &x[1], &incx, &xt[1], &g[ + 1], &xx[1], eps, &err, fatal, + nout, &c_false, (ftnlen)1); + } + errmax = dmax(errmax,err); +/* If got really bad answer, report and return. */ + if (*fatal) { + goto L120; + } + } else { +/* Avoid repeating tests with N.le.0. */ + goto L110; + } + +/* L60: */ + } + +/* L70: */ + } + +/* L80: */ + } + +/* L90: */ + } + +L100: + ; + } + +L110: + ; + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%12s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%12s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%12s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);; + } + if (*iorder == 1) { + printf("%12s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);; + } + } + goto L130; + +L120: + printf("******* %12s FAILED ON CALL NUMBER:",sname); + if (full) { + printf("%6d: %12s (%14s,%14s,%14s %3d ,A, %3d, X, %2d ).\n", + nc,sname,cuplo,ctrans,cdiag,n,lda,incx); + } else if (banded) { + printf("%6d: %12s (%14s,%14s,%14s %3d, %3d ,A, %3d, X, %2d ).\n", + nc,sname,cuplo,ctrans,cdiag,n,k,lda,incx); + } else if (packed) { + printf("%6d: %12s (%14s,%14s,%14s %3d ,AP, X, %2d ).\n", + nc,sname,cuplo,ctrans,cdiag,n,incx); + } + +L130: + return 0; + +/* 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', */ +/* $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, */ +/* $ ' - SUSPECT *******' ) */ + +/* End of SCHK3. */ + +} /* schk3_ */ + +/* Subroutine */ int 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, sname_len) +char *sname; +real *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nalf; +real *alf; +integer *ninc, *inc, *nmax, *incmax; +real *a, *aa, *as, *x, *xx, *xs, *y, *yy, *ys, *yt, *g, *z__; +integer *iorder; +ftnlen sname_len; +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; + + /* Local variables */ + static integer ldas; + static logical same; + static integer incx, incy; + static logical null; + static integer i__, j, m, n; + static real alpha, w[1]; + static logical isame[13]; + extern /* Subroutine */ int smake_(), csger_(); + static integer nargs; + extern /* Subroutine */ int smvch_(); + static logical reset; + static integer incxs, incys, ia, nc, nd, im, in, ms, ix, iy, ns, lx, ly; + static real errmax; + extern logical lseres_(); + static real transl; + static integer laa, lda; + static real als; + extern logical lse_(); + static real err; + +/* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Executable Statements .. */ +/* Define the number of arguments. */ + /* Parameter adjustments */ + --idim; + --alf; + --inc; + --z__; + --g; + --yt; + --y; + --x; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ys; + --yy; + --xs; + --xx; + + /* Function Body */ + nargs = 9; + + nc = 0; + reset = TRUE_; + errmax = (float)0.; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; + nd = n / 2 + 1; + + for (im = 1; im <= 2; ++im) { + if (im == 1) { +/* Computing MAX */ + i__2 = n - nd; + m = f2cmax(i__2,0); + } + if (im == 2) { +/* Computing MIN */ + i__2 = n + nd; + m = f2cmin(i__2,*nmax); + } + +/* Set LDA to 1 more than minimum value if room. */ + lda = m; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L110; + } + laa = lda * n; + null = n <= 0 || m <= 0; + + i__2 = *ninc; + for (ix = 1; ix <= i__2; ++ix) { + incx = inc[ix]; + lx = abs(incx) * m; + +/* Generate the vector X. */ + + transl = (float).5; + i__3 = abs(incx); + i__4 = m - 1; + smake_("ge", " ", " ", &c__1, &m, &x[1], &c__1, &xx[1], &i__3, + &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1, + (ftnlen)1); + if (m > 1) { + x[m / 2] = (float)0.; + xx[abs(incx) * (m / 2 - 1) + 1] = (float)0.; + } + + i__3 = *ninc; + for (iy = 1; iy <= i__3; ++iy) { + incy = inc[iy]; + ly = abs(incy) * n; + +/* Generate the vector Y. */ + + transl = (float)0.; + i__4 = abs(incy); + i__5 = n - 1; + smake_("ge", " ", " ", &c__1, &n, &y[1], &c__1, &yy[1], & + i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, ( + ftnlen)1, (ftnlen)1); + if (n > 1) { + y[n / 2] = (float)0.; + yy[abs(incy) * (n / 2 - 1) + 1] = (float)0.; + } + + i__4 = *nalf; + for (ia = 1; ia <= i__4; ++ia) { + alpha = alf[ia]; + +/* Generate the matrix A. */ + + transl = (float)0.; + i__5 = m - 1; + i__6 = n - 1; + smake_(sname + 7, " ", " ", &m, &n, &a[a_offset], + nmax, &aa[1], &lda, &i__5, &i__6, &reset, & + transl, (ftnlen)2, (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the subroutine. */ + + ms = m; + ns = n; + als = alpha; + i__5 = laa; + for (i__ = 1; i__ <= i__5; ++i__) { + as[i__] = aa[i__]; +/* L10: */ + } + ldas = lda; + i__5 = lx; + for (i__ = 1; i__ <= i__5; ++i__) { + xs[i__] = xx[i__]; +/* L20: */ + } + incxs = incx; + i__5 = ly; + for (i__ = 1; i__ <= i__5; ++i__) { + ys[i__] = yy[i__]; +/* L30: */ + } + incys = incy; + +/* Call the subroutine. */ + + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%3d, %3d) %4.1f, X, %2d, Y, %2d, A, %3d).\n", + nc,sname,m,n,alpha,incx,incy,lda); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + csger_(iorder, &m, &n, &alpha, &xx[1], &incx, &yy[1], + &incy, &aa[1], &lda); + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf(" ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******n"); + *fatal = TRUE_; + goto L140; + } + +/* See what data changed inside subroutine. */ + + isame[0] = ms == m; + isame[1] = ns == n; + isame[2] = als == alpha; + isame[3] = lse_(&xs[1], &xx[1], &lx); + isame[4] = incxs == incx; + isame[5] = lse_(&ys[1], &yy[1], &ly); + isame[6] = incys == incy; + if (null) { + isame[7] = lse_(&as[1], &aa[1], &laa); + } else { + isame[7] = lseres_("ge", " ", &m, &n, &as[1], &aa[ + 1], &lda, (ftnlen)2, (ftnlen)1); + } + isame[8] = ldas == lda; + +/* If data was incorrectly changed, report and return. */ + + same = TRUE_; + i__5 = nargs; + for (i__ = 1; i__ <= i__5; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L140; + } + + if (! null) { + +/* Check the result column by column. */ + + if (incx > 0) { + i__5 = m; + for (i__ = 1; i__ <= i__5; ++i__) { + z__[i__] = x[i__]; +/* L50: */ + } + } else { + i__5 = m; + for (i__ = 1; i__ <= i__5; ++i__) { + z__[i__] = x[m - i__ + 1]; +/* L60: */ + } + } + i__5 = n; + for (j = 1; j <= i__5; ++j) { + if (incy > 0) { + w[0] = y[j]; + } else { + w[0] = y[n - j + 1]; + } + smvch_("N", &m, &c__1, &alpha, &z__[1], nmax, + w, &c__1, &c_b123, &a[j * a_dim1 + 1], + &c__1, &yt[1], &g[1], &aa[(j - 1) * + lda + 1], eps, &err, fatal, nout, & + c_true, (ftnlen)1); + errmax = dmax(errmax,err); +/* If got really bad answer, report and return. */ + if (*fatal) { + goto L130; + } +/* L70: */ + } + } else { +/* Avoid repeating tests with M.le.0 or N.le.0. */ + goto L110; + } + +/* L80: */ + } + +/* L90: */ + } + +/* L100: */ + } + +L110: + ; + } + +/* L120: */ + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%12s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%12s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%12s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);; + } + if (*iorder == 1) { + printf("%12s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);; + } + } + goto L150; + +L130: + printf(" THESE ARE THE RESULTS FOR COLUMN %3d:\n",j); + +L140: + printf("******* %12s FAILED ON CALL NUMBER:\n",sname); + printf("%6d: %12s (%3d, %3d) %4.1f, X, %2d, Y, %2d, A, %3d).\n", + nc,sname,m,n,alpha,incx,incy,lda); + +L150: + return 0; + +/* 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', */ +/* $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, */ +/* $ ' - SUSPECT *******' ) */ + +/* End of SCHK4. */ + +} /* schk4_ */ + +/* Subroutine */ int 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, sname_len) +char *sname; +real *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nalf; +real *alf; +integer *ninc, *inc, *nmax, *incmax; +real *a, *aa, *as, *x, *xx, *xs, *y, *yy, *ys, *yt, *g, *z__; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ich[2+1] = "UL"; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + + /* Builtin functions */ + + /* Local variables */ + static integer ldas; + static logical same; + static integer incx; + static logical full, null; + static char uplo[1]; + static integer i__, j, n; + static real alpha, w[1]; + static logical isame[13]; + extern /* Subroutine */ int smake_(); + static integer nargs; + extern /* Subroutine */ int smvch_(); + static logical reset; + static char cuplo[14]; + static integer incxs; + extern /* Subroutine */ int csspr_(); + static logical upper; + static char uplos[1]; + extern /* Subroutine */ int cssyr_(); + static integer ia, ja, ic, nc, jj, lj, in; + static logical packed; + static integer ix, ns, lx; + static real errmax; + extern logical lseres_(); + static real transl; + static integer laa, lda; + static real als; + extern logical lse_(); + static real err; + +/* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --alf; + --inc; + --z__; + --g; + --yt; + --y; + --x; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ys; + --yy; + --xs; + --xx; + + /* Function Body */ +/* .. Executable Statements .. */ + full = *(unsigned char *)&sname[8] == 'y'; + packed = *(unsigned char *)&sname[8] == 'p'; +/* Define the number of arguments. */ + if (full) { + nargs = 7; + } else if (packed) { + nargs = 6; + } + + nc = 0; + reset = TRUE_; + errmax = (float)0.; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; +/* Set LDA to 1 more than minimum value if room. */ + lda = n; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L100; + } + if (packed) { + laa = n * (n + 1) / 2; + } else { + laa = lda * n; + } + + for (ic = 1; ic <= 2; ++ic) { + *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1]; + if (*(unsigned char *)uplo == 'U') { + s_copy(cuplo, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cuplo, " CblasLower", (ftnlen)14, (ftnlen)14); + } + upper = *(unsigned char *)uplo == 'U'; + + i__2 = *ninc; + for (ix = 1; ix <= i__2; ++ix) { + incx = inc[ix]; + lx = abs(incx) * n; + +/* Generate the vector X. */ + + transl = (float).5; + i__3 = abs(incx); + i__4 = n - 1; + smake_("ge", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &i__3, + &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1, + (ftnlen)1); + if (n > 1) { + x[n / 2] = (float)0.; + xx[abs(incx) * (n / 2 - 1) + 1] = (float)0.; + } + + i__3 = *nalf; + for (ia = 1; ia <= i__3; ++ia) { + alpha = alf[ia]; + null = n <= 0 || alpha == (float)0.; + +/* Generate the matrix A. */ + + transl = (float)0.; + i__4 = n - 1; + i__5 = n - 1; + smake_(sname + 7, uplo, " ", &n, &n, &a[a_offset], nmax, & + aa[1], &lda, &i__4, &i__5, &reset, &transl, ( + ftnlen)2, (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the subroutine. */ + + *(unsigned char *)uplos = *(unsigned char *)uplo; + ns = n; + als = alpha; + i__4 = laa; + for (i__ = 1; i__ <= i__4; ++i__) { + as[i__] = aa[i__]; +/* L10: */ + } + ldas = lda; + i__4 = lx; + for (i__ = 1; i__ <= i__4; ++i__) { + xs[i__] = xx[i__]; +/* L20: */ + } + incxs = incx; + +/* Call the subroutine. */ + + if (full) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %3d, %4.1f, X, %2d, A, %3d).\n", + nc,sname,cuplo,alpha,incx,lda); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cssyr_(iorder, uplo, &n, &alpha, &xx[1], &incx, &aa[1] + , &lda, (ftnlen)1); + } else if (packed) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %3d, %4.1f, X, %2d, AP).\n", + nc,sname,cuplo,n,alpha,incx); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + csspr_(iorder, uplo, &n, &alpha, &xx[1], &incx, &aa[1] + , (ftnlen)1); + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf(" ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******n"); + *fatal = TRUE_; + goto L120; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)uplo == *(unsigned char *) + uplos; + isame[1] = ns == n; + isame[2] = als == alpha; + isame[3] = lse_(&xs[1], &xx[1], &lx); + isame[4] = incxs == incx; + if (null) { + isame[5] = lse_(&as[1], &aa[1], &laa); + } else { + isame[5] = lseres_(sname + 7, uplo, &n, &n, &as[1], & + aa[1], &lda, (ftnlen)2, (ftnlen)1); + } + if (! packed) { + isame[6] = ldas == lda; + } + +/* If data was incorrectly changed, report and return. */ + + same = TRUE_; + i__4 = nargs; + for (i__ = 1; i__ <= i__4; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L30: */ + } + if (! same) { + *fatal = TRUE_; + goto L120; + } + + if (! null) { + +/* Check the result column by column. */ + + if (incx > 0) { + i__4 = n; + for (i__ = 1; i__ <= i__4; ++i__) { + z__[i__] = x[i__]; +/* L40: */ + } + } else { + i__4 = n; + for (i__ = 1; i__ <= i__4; ++i__) { + z__[i__] = x[n - i__ + 1]; +/* L50: */ + } + } + ja = 1; + i__4 = n; + for (j = 1; j <= i__4; ++j) { + w[0] = z__[j]; + if (upper) { + jj = 1; + lj = j; + } else { + jj = j; + lj = n - j + 1; + } + smvch_("N", &lj, &c__1, &alpha, &z__[jj], &lj, w, + &c__1, &c_b123, &a[jj + j * a_dim1], & + c__1, &yt[1], &g[1], &aa[ja], eps, &err, + fatal, nout, &c_true, (ftnlen)1); + if (full) { + if (upper) { + ja += lda; + } else { + ja = ja + lda + 1; + } + } else { + ja += lj; + } + errmax = dmax(errmax,err); +/* If got really bad answer, report and return. */ + if (*fatal) { + goto L110; + } +/* L60: */ + } + } else { +/* Avoid repeating tests if N.le.0. */ + if (n <= 0) { + goto L100; + } + } + +/* L70: */ + } + +/* L80: */ + } + +/* L90: */ + } + +L100: + ; + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%12s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%12s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%12s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);; + } + if (*iorder == 1) { + printf("%12s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);; + } + } + goto L130; + +L110: + printf(" THESE ARE THE RESULTS FOR COLUMN %3d:\n",j); + +L120: + printf("******* %12s FAILED ON CALL NUMBER:\n",sname); + if (full) { + printf("%6d: %12s (%14s, %3d, %4.1f, X, %2d, A, %3d).\n", + nc,sname,cuplo,n,alpha,incx,lda); + } else if (packed) { + printf("%6d: %12s (%14s, %3d, %4.1f, X, %2d, AP).\n", + nc,sname,cuplo,n,alpha,incx); + } + +L130: + return 0; + +/* 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', */ +/* $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, */ +/* $ ' - SUSPECT *******' ) */ + +/* End of SCHK5. */ + +} /* schk5_ */ + +/* Subroutine */ int 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, sname_len) +char *sname; +real *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nalf; +real *alf; +integer *ninc, *inc, *nmax, *incmax; +real *a, *aa, *as, *x, *xx, *xs, *y, *yy, *ys, *yt, *g, *z__; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ich[2+1] = "UL"; + + /* System generated locals */ + integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, + i__6; + + /* Local variables */ + static integer ldas; + static logical same; + static integer incx, incy; + static logical full, null; + static char uplo[1]; + static integer i__, j, n; + static real alpha, w[2]; + static logical isame[13]; + extern /* Subroutine */ int smake_(); + static integer nargs; + extern /* Subroutine */ int smvch_(); + static logical reset; + static char cuplo[14]; + static integer incxs, incys; + static logical upper; + static char uplos[1]; + static integer ia, ja, ic; + extern /* Subroutine */ int csspr2_(); + static integer nc, jj, lj, in; + static logical packed; + extern /* Subroutine */ int cssyr2_(); + static integer ix, iy, ns, lx, ly; + static real errmax; + extern logical lseres_(); + static real transl; + static integer laa, lda; + static real als; + extern logical lse_(); + static real err; + +/* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --alf; + --inc; + z_dim1 = *nmax; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --g; + --yt; + --y; + --x; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ys; + --yy; + --xs; + --xx; + + /* Function Body */ +/* .. Executable Statements .. */ + full = *(unsigned char *)&sname[8] == 'y'; + packed = *(unsigned char *)&sname[8] == 'p'; +/* Define the number of arguments. */ + if (full) { + nargs = 9; + } else if (packed) { + nargs = 8; + } + + nc = 0; + reset = TRUE_; + errmax = (float)0.; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; +/* Set LDA to 1 more than minimum value if room. */ + lda = n; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L140; + } + if (packed) { + laa = n * (n + 1) / 2; + } else { + laa = lda * n; + } + + for (ic = 1; ic <= 2; ++ic) { + *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1]; + if (*(unsigned char *)uplo == 'U') { + s_copy(cuplo, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cuplo, " CblasLower", (ftnlen)14, (ftnlen)14); + } + upper = *(unsigned char *)uplo == 'U'; + + i__2 = *ninc; + for (ix = 1; ix <= i__2; ++ix) { + incx = inc[ix]; + lx = abs(incx) * n; + +/* Generate the vector X. */ + + transl = (float).5; + i__3 = abs(incx); + i__4 = n - 1; + smake_("ge", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &i__3, + &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1, + (ftnlen)1); + if (n > 1) { + x[n / 2] = (float)0.; + xx[abs(incx) * (n / 2 - 1) + 1] = (float)0.; + } + + i__3 = *ninc; + for (iy = 1; iy <= i__3; ++iy) { + incy = inc[iy]; + ly = abs(incy) * n; + +/* Generate the vector Y. */ + + transl = (float)0.; + i__4 = abs(incy); + i__5 = n - 1; + smake_("ge", " ", " ", &c__1, &n, &y[1], &c__1, &yy[1], & + i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, ( + ftnlen)1, (ftnlen)1); + if (n > 1) { + y[n / 2] = (float)0.; + yy[abs(incy) * (n / 2 - 1) + 1] = (float)0.; + } + + i__4 = *nalf; + for (ia = 1; ia <= i__4; ++ia) { + alpha = alf[ia]; + null = n <= 0 || alpha == (float)0.; + +/* Generate the matrix A. */ + + transl = (float)0.; + i__5 = n - 1; + i__6 = n - 1; + smake_(sname + 7, uplo, " ", &n, &n, &a[a_offset], + nmax, &aa[1], &lda, &i__5, &i__6, &reset, & + transl, (ftnlen)2, (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the subroutine. */ + + *(unsigned char *)uplos = *(unsigned char *)uplo; + ns = n; + als = alpha; + i__5 = laa; + for (i__ = 1; i__ <= i__5; ++i__) { + as[i__] = aa[i__]; +/* L10: */ + } + ldas = lda; + i__5 = lx; + for (i__ = 1; i__ <= i__5; ++i__) { + xs[i__] = xx[i__]; +/* L20: */ + } + incxs = incx; + i__5 = ly; + for (i__ = 1; i__ <= i__5; ++i__) { + ys[i__] = yy[i__]; +/* L30: */ + } + incys = incy; + +/* Call the subroutine. */ + + if (full) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %3d, %4.1f, X, %2d, Y, %2d, A, %3d).\n", + nc,sname,cuplo,n,alpha,incx,incy,lda); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cssyr2_(iorder, uplo, &n, &alpha, &xx[1], &incx, & + yy[1], &incy, &aa[1], &lda, (ftnlen)1); + } else if (packed) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %3d, %4.1f, X, %2d, Y, %2d, AP).\n", + nc,sname,cuplo,n,alpha,incx,incy); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + csspr2_(iorder, uplo, &n, &alpha, &xx[1], &incx, & + yy[1], &incy, &aa[1], (ftnlen)1); + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf(" ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******n"); + *fatal = TRUE_; + goto L160; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)uplo == *(unsigned char * + )uplos; + isame[1] = ns == n; + isame[2] = als == alpha; + isame[3] = lse_(&xs[1], &xx[1], &lx); + isame[4] = incxs == incx; + isame[5] = lse_(&ys[1], &yy[1], &ly); + isame[6] = incys == incy; + if (null) { + isame[7] = lse_(&as[1], &aa[1], &laa); + } else { + isame[7] = lseres_(sname + 7, uplo, &n, &n, &as[1] + , &aa[1], &lda, (ftnlen)2, (ftnlen)1); + } + if (! packed) { + isame[8] = ldas == lda; + } + +/* If data was incorrectly changed, report and return. */ + + same = TRUE_; + i__5 = nargs; + for (i__ = 1; i__ <= i__5; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L160; + } + + if (! null) { + +/* Check the result column by column. */ + + if (incx > 0) { + i__5 = n; + for (i__ = 1; i__ <= i__5; ++i__) { + z__[i__ + z_dim1] = x[i__]; +/* L50: */ + } + } else { + i__5 = n; + for (i__ = 1; i__ <= i__5; ++i__) { + z__[i__ + z_dim1] = x[n - i__ + 1]; +/* L60: */ + } + } + if (incy > 0) { + i__5 = n; + for (i__ = 1; i__ <= i__5; ++i__) { + z__[i__ + (z_dim1 << 1)] = y[i__]; +/* L70: */ + } + } else { + i__5 = n; + for (i__ = 1; i__ <= i__5; ++i__) { + z__[i__ + (z_dim1 << 1)] = y[n - i__ + 1]; +/* L80: */ + } + } + ja = 1; + i__5 = n; + for (j = 1; j <= i__5; ++j) { + w[0] = z__[j + (z_dim1 << 1)]; + w[1] = z__[j + z_dim1]; + if (upper) { + jj = 1; + lj = j; + } else { + jj = j; + lj = n - j + 1; + } + smvch_("N", &lj, &c__2, &alpha, &z__[jj + + z_dim1], nmax, w, &c__1, &c_b123, &a[ + jj + j * a_dim1], &c__1, &yt[1], &g[1] + , &aa[ja], eps, &err, fatal, nout, & + c_true, (ftnlen)1); + if (full) { + if (upper) { + ja += lda; + } else { + ja = ja + lda + 1; + } + } else { + ja += lj; + } + errmax = dmax(errmax,err); +/* If got really bad answer, report and return. */ + if (*fatal) { + goto L150; + } +/* L90: */ + } + } else { +/* Avoid repeating tests with N.le.0. */ + if (n <= 0) { + goto L140; + } + } + +/* L100: */ + } + +/* L110: */ + } + +/* L120: */ + } + +/* L130: */ + } + +L140: + ; + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%12s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%12s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%12s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);; + } + if (*iorder == 1) { + printf("%12s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);; + } + } + goto L170; + +L150: + printf(" THESE ARE THE RESULTS FOR COLUMN %3d:\n",j); + +L160: + printf("******* %12s FAILED ON CALL NUMBER:\n",sname); + if (full) { + printf("%6d: %12s (%14s, %3d, %4.1f, X, %2d, Y, %2d, A, %3d).\n", + nc,sname,cuplo,n,alpha,incx,incy,lda); + } else if (packed) { + printf("%6d: %12s (%14s, %3d, %4.1f, X, %2d, Y, %2d, AP).\n", + nc,sname,cuplo,n,alpha,incx,incy); + } + +L170: + return 0; + +/* 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', */ +/* $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, */ +/* $ ' - SUSPECT *******' ) */ + +/* End of SCHK6. */ + +} /* schk6_ */ + +/* Subroutine */ int smake_(type__, uplo, diag, m, n, a, nmax, aa, lda, kl, + ku, reset, transl, type_len, uplo_len, diag_len) +char *type__, *uplo, *diag; +integer *m, *n; +real *a; +integer *nmax; +real *aa; +integer *lda, *kl, *ku; +logical *reset; +real *transl; +ftnlen type_len; +ftnlen uplo_len; +ftnlen diag_len; +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + static integer ibeg, iend; + extern doublereal sbeg_(); + static integer ioff; + static logical unit; + static integer i__, j; + static logical lower; + static integer i1, i2, i3; + static logical upper; + static integer kk; + static logical gen, tri, sym; + + +/* Generates values for an M by N matrix A within the bandwidth */ +/* defined by KL and KU. */ +/* Stores the values in the array AA in the data structure required */ +/* by the routine, with unwanted elements set to rogue value. */ + +/* TYPE is 'ge', 'gb', 'sy', 'sb', 'sp', 'tr', 'tb' OR 'tp'. */ + +/* Auxiliary routine for test program for Level 2 Blas. */ + +/* -- Written on 10-August-1987. */ +/* Richard Hanson, Sandia National Labs. */ +/* Jeremy Du Croz, NAG Central Office. */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. External Functions .. */ +/* .. Intrinsic Functions .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --aa; + + /* Function Body */ + gen = *(unsigned char *)type__ == 'g'; + sym = *(unsigned char *)type__ == 's'; + tri = *(unsigned char *)type__ == 't'; + upper = (sym || tri) && *(unsigned char *)uplo == 'U'; + lower = (sym || tri) && *(unsigned char *)uplo == 'L'; + unit = tri && *(unsigned char *)diag == 'U'; + +/* Generate data in array A. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + if (gen || (upper && i__ <= j) || (lower && i__ >= j)) { + if (i__ <= j && (j - i__ <= *ku || i__ >= j && i__ - j <= *kl)) + { + a[i__ + j * a_dim1] = sbeg_(reset) + *transl; + } else { + a[i__ + j * a_dim1] = (float)0.; + } + if (i__ != j) { + if (sym) { + a[j + i__ * a_dim1] = a[i__ + j * a_dim1]; + } else if (tri) { + a[j + i__ * a_dim1] = (float)0.; + } + } + } +/* L10: */ + } + if (tri) { + a[j + j * a_dim1] += (float)1.; + } + if (unit) { + a[j + j * a_dim1] = (float)1.; + } +/* L20: */ + } + +/* Store elements in array AS in data structure required by routine. */ + + if (s_cmp(type__, "ge", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + aa[i__ + (j - 1) * *lda] = a[i__ + j * a_dim1]; +/* L30: */ + } + i__2 = *lda; + for (i__ = *m + 1; i__ <= i__2; ++i__) { + aa[i__ + (j - 1) * *lda] = (float)-1e10; +/* L40: */ + } +/* L50: */ + } + } else if (s_cmp(type__, "gb", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *ku + 1 - j; + for (i1 = 1; i1 <= i__2; ++i1) { + aa[i1 + (j - 1) * *lda] = (float)-1e10; +/* L60: */ + } +/* Computing MIN */ + i__3 = *kl + *ku + 1, i__4 = *ku + 1 + *m - j; + i__2 = f2cmin(i__3,i__4); + for (i2 = i1; i2 <= i__2; ++i2) { + aa[i2 + (j - 1) * *lda] = a[i2 + j - *ku - 1 + j * a_dim1]; +/* L70: */ + } + i__2 = *lda; + for (i3 = i2; i3 <= i__2; ++i3) { + aa[i3 + (j - 1) * *lda] = (float)-1e10; +/* L80: */ + } +/* L90: */ + } + } else if (s_cmp(type__, "sy", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__, + "tr", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (upper) { + ibeg = 1; + if (unit) { + iend = j - 1; + } else { + iend = j; + } + } else { + if (unit) { + ibeg = j + 1; + } else { + ibeg = j; + } + iend = *n; + } + i__2 = ibeg - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + aa[i__ + (j - 1) * *lda] = (float)-1e10; +/* L100: */ + } + i__2 = iend; + for (i__ = ibeg; i__ <= i__2; ++i__) { + aa[i__ + (j - 1) * *lda] = a[i__ + j * a_dim1]; +/* L110: */ + } + i__2 = *lda; + for (i__ = iend + 1; i__ <= i__2; ++i__) { + aa[i__ + (j - 1) * *lda] = (float)-1e10; +/* L120: */ + } +/* L130: */ + } + } else if (s_cmp(type__, "sb", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__, + "tb", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (upper) { + kk = *kl + 1; +/* Computing MAX */ + i__2 = 1, i__3 = *kl + 2 - j; + ibeg = f2cmax(i__2,i__3); + if (unit) { + iend = *kl; + } else { + iend = *kl + 1; + } + } else { + kk = 1; + if (unit) { + ibeg = 2; + } else { + ibeg = 1; + } +/* Computing MIN */ + i__2 = *kl + 1, i__3 = *m + 1 - j; + iend = f2cmin(i__2,i__3); + } + i__2 = ibeg - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + aa[i__ + (j - 1) * *lda] = (float)-1e10; +/* L140: */ + } + i__2 = iend; + for (i__ = ibeg; i__ <= i__2; ++i__) { + aa[i__ + (j - 1) * *lda] = a[i__ + j - kk + j * a_dim1]; +/* L150: */ + } + i__2 = *lda; + for (i__ = iend + 1; i__ <= i__2; ++i__) { + aa[i__ + (j - 1) * *lda] = (float)-1e10; +/* L160: */ + } +/* L170: */ + } + } else if (s_cmp(type__, "sp", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__, + "tp", (ftnlen)2, (ftnlen)2) == 0) { + ioff = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (upper) { + ibeg = 1; + iend = j; + } else { + ibeg = j; + iend = *n; + } + i__2 = iend; + for (i__ = ibeg; i__ <= i__2; ++i__) { + ++ioff; + aa[ioff] = a[i__ + j * a_dim1]; + if (i__ == j) { + if (unit) { + aa[ioff] = (float)-1e10; + } + } +/* L180: */ + } +/* L190: */ + } + } + return 0; + +/* End of SMAKE. */ + +} /* smake_ */ + +/* Subroutine */ int smvch_(trans, m, n, alpha, a, nmax, x, incx, beta, y, + incy, yt, g, yy, eps, err, fatal, nout, mv, trans_len) +char *trans; +integer *m, *n; +real *alpha, *a; +integer *nmax; +real *x; +integer *incx; +real *beta, *y; +integer *incy; +real *yt, *g, *yy, *eps, *err; +logical *fatal; +integer *nout; +logical *mv; +ftnlen trans_len; +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + real r__1; + + /* Builtin functions */ + double sqrt(); + + /* Local variables */ + static real erri; + static logical tran; + static integer i__, j, incxl, incyl, ml, nl, iy, jx, kx, ky; + +/* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Intrinsic Functions .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --x; + --y; + --yt; + --g; + --yy; + + /* Function Body */ + tran = *(unsigned char *)trans == 'T' || *(unsigned char *)trans == 'C'; + if (tran) { + ml = *n; + nl = *m; + } else { + ml = *m; + nl = *n; + } + if (*incx < 0) { + kx = nl; + incxl = -1; + } else { + kx = 1; + incxl = 1; + } + if (*incy < 0) { + ky = ml; + incyl = -1; + } else { + ky = 1; + incyl = 1; + } + +/* Compute expected result in YT using data in A, X and Y. */ +/* Compute gauges in G. */ + + iy = ky; + i__1 = ml; + for (i__ = 1; i__ <= i__1; ++i__) { + yt[iy] = (float)0.; + g[iy] = (float)0.; + jx = kx; + if (tran) { + i__2 = nl; + for (j = 1; j <= i__2; ++j) { + yt[iy] += a[j + i__ * a_dim1] * x[jx]; + g[iy] += (r__1 = a[j + i__ * a_dim1] * x[jx], dabs(r__1)); + jx += incxl; +/* L10: */ + } + } else { + i__2 = nl; + for (j = 1; j <= i__2; ++j) { + yt[iy] += a[i__ + j * a_dim1] * x[jx]; + g[iy] += (r__1 = a[i__ + j * a_dim1] * x[jx], dabs(r__1)); + jx += incxl; +/* L20: */ + } + } + yt[iy] = *alpha * yt[iy] + *beta * y[iy]; + g[iy] = dabs(*alpha) * g[iy] + (r__1 = *beta * y[iy], dabs(r__1)); + iy += incyl; +/* L30: */ + } + +/* Compute the error ratio for this result. */ + + *err = (float)0.; + i__1 = ml; + for (i__ = 1; i__ <= i__1; ++i__) { + erri = (r__1 = yt[i__] - yy[(i__ - 1) * abs(*incy) + 1], dabs(r__1)) / + *eps; + if (g[i__] != (float)0.) { + erri /= g[i__]; + } + *err = dmax(*err,erri); + if (*err * sqrt(*eps) >= (float)1.) { + goto L50; + } +/* L40: */ + } +/* If the loop completes, all results are at least half accurate. */ + goto L70; + +/* Report fatal error. */ + +L50: + *fatal = TRUE_; + printf(" ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HALF ACCURATE *******\n EXPECTED RESULT COMPUTED RESULT\n"); + i__1 = ml; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*mv) { + printf("%7d %18.6g %18.6g\n",i__,yt[i__],yy[(i__ - 1) * abs(*incy) + 1]); + } else { + printf("%7d %18.6g %18.6g\n",i__,yy[(i__ - 1) * abs(*incy) + 1], yt[i__]); + } +/* L60: */ + } + +L70: + return 0; + + +/* End of SMVCH. */ + +} /* smvch_ */ + +logical lse_(ri, rj, lr) +real *ri, *rj; +integer *lr; +{ + /* System generated locals */ + integer i__1; + logical ret_val; + + /* Local variables */ + static integer i__; + + +/* Tests if two arrays are identical. */ + +/* Auxiliary routine for test program for Level 2 Blas. */ + +/* -- Written on 10-August-1987. */ +/* Richard Hanson, Sandia National Labs. */ +/* Jeremy Du Croz, NAG Central Office. */ + +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + --rj; + --ri; + + /* Function Body */ + i__1 = *lr; + for (i__ = 1; i__ <= i__1; ++i__) { + if (ri[i__] != rj[i__]) { + goto L20; + } +/* L10: */ + } + ret_val = TRUE_; + goto L30; +L20: + ret_val = FALSE_; +L30: + return ret_val; + +/* End of LSE. */ + +} /* lse_ */ + +logical lseres_(type__, uplo, m, n, aa, as, lda, type_len, uplo_len) +char *type__, *uplo; +integer *m, *n; +real *aa, *as; +integer *lda; +ftnlen type_len; +ftnlen uplo_len; +{ + /* System generated locals */ + integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2; + logical ret_val; + + /* Local variables */ + static integer ibeg, iend, i__, j; + static logical upper; + + +/* Tests if selected elements in two arrays are equal. */ + +/* TYPE is 'ge', '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 .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + as_dim1 = *lda; + as_offset = 1 + as_dim1 * 1; + as -= as_offset; + aa_dim1 = *lda; + aa_offset = 1 + aa_dim1 * 1; + aa -= aa_offset; + + /* Function Body */ + upper = *(unsigned char *)uplo == 'U'; + if (s_cmp(type__, "ge", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *lda; + for (i__ = *m + 1; i__ <= i__2; ++i__) { + if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) { + goto L70; + } +/* L10: */ + } +/* L20: */ + } + } else if (s_cmp(type__, "sy", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (upper) { + ibeg = 1; + iend = j; + } else { + ibeg = j; + iend = *n; + } + i__2 = ibeg - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) { + goto L70; + } +/* L30: */ + } + i__2 = *lda; + for (i__ = iend + 1; i__ <= i__2; ++i__) { + if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) { + goto L70; + } +/* L40: */ + } +/* L50: */ + } + } + +/* 60 CONTINUE */ + ret_val = TRUE_; + goto L80; +L70: + ret_val = FALSE_; +L80: + return ret_val; + +/* End of LSERES. */ + +} /* lseres_ */ + +doublereal sbeg_(reset) +logical *reset; +{ + /* System generated locals */ + real ret_val; + + /* Local variables */ + static integer i__, ic, mi; + + +/* 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 .. */ +/* .. Local Scalars .. */ +/* .. Save statement .. */ +/* .. Intrinsic Functions .. */ +/* .. Executable Statements .. */ + if (*reset) { +/* Initialize local variables. */ + mi = 891; + i__ = 7; + ic = 0; + *reset = FALSE_; + } + +/* The sequence of values of I is bounded between 1 and 999. */ +/* If initial I = 1,2,3,6,7 or 9, the period will be 50. */ +/* If initial I = 4 or 8, the period will be 25. */ +/* If initial I = 5, the period will be 10. */ +/* IC is used to break up the period by skipping 1 value of I in 6. */ + + ++ic; +L10: + i__ *= mi; + i__ -= i__ / 1000 * 1000; + if (ic >= 5) { + ic = 0; + goto L10; + } + ret_val = (real) (i__ - 500) / (float)1001.; + return ret_val; + +/* End of SBEG. */ + +} /* sbeg_ */ + +doublereal sdiff_(x, y) +real *x, *y; +{ + /* System generated locals */ + real ret_val; + + +/* Auxiliary routine for test program for Level 2 Blas. */ + +/* -- Written on 10-August-1987. */ +/* Richard Hanson, Sandia National Labs. */ + +/* .. Scalar Arguments .. */ +/* .. Executable Statements .. */ + ret_val = *x - *y; + return ret_val; + +/* End of SDIFF. */ + +} /* sdiff_ */ + diff --git a/ctest/c_sblat3c.c b/ctest/c_sblat3c.c new file mode 100644 index 000000000..850b3fe15 --- /dev/null +++ b/ctest/c_sblat3c.c @@ -0,0 +1,3773 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif +#if 0 +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +#endif +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i= 0; + if (trace) { +/* OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' ) */ +/* o__1.ounit = ntra; + o__1.ofnmlen = 32; + o__1.ofnm = snaps; + o__1.orl = 0; + o__1.osta = 0; + o__1.oacc = 0; + o__1.ofm = 0; + o__1.oblnk = 0; + f_open(&o__1);*/ + } +/* Read the flag that directs rewinding of the snapshot file. */ + fgets(line,80,stdin); + sscanf(line,"%d",&rewi); + rewi = rewi && trace; +/* Read the flag that directs stopping on any failure. */ + fgets(line,80,stdin); + sscanf(line,"%c",&tmpchar); +/* Read the flag that indicates whether error exits are to be tested. */ + sfatal=FALSE_; + if (tmpchar=='T')sfatal=TRUE_; + fgets(line,80,stdin); + sscanf(line,"%c",&tmpchar); +/* Read the flag that indicates whether error exits are to be tested. */ + tsterr=FALSE_; + if (tmpchar=='T')tsterr=TRUE_; +/* Read the flag that indicates whether row-major data layout to be tested. */ + fgets(line,80,stdin); + sscanf(line,"%d",&layout); +/* Read the threshold value of the test ratio */ + fgets(line,80,stdin); + sscanf(line,"%f",&thresh); + +/* Read and check the parameter values for the tests. */ + +/* Values of N */ + fgets(line,80,stdin); + sscanf(line,"%d",&nidim); + + if (nidim < 1 || nidim > 9) { + fprintf(stderr,"NUMBER OF VALUES OF N IS LESS THAN 1 OR GREATER THAN 9"); + goto L220; + } + fgets(line,80,stdin); + sscanf(line,"%d %d %d %d %d %d %d %d %d",&idim[0],&idim[1],&idim[2], + &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]); + i__1 = nidim; + for (i__ = 1; i__ <= i__1; ++i__) { + if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) { + fprintf(stderr,"VALUE OF N IS LESS THAN 0 OR GREATER THAN 65\n"); + goto L220; + } +/* L10: */ + } +/* Values of ALPHA */ + fgets(line,80,stdin); + sscanf(line,"%d",&nalf); + if (nalf < 1 || nalf > 7) { + fprintf(stderr,"VALUE OF ALPHA IS LESS THAN 0 OR GREATER THAN 7\n"); + goto L220; + } + fgets(line,80,stdin); + sscanf(line,"%f %f %f %f %f %f %f",&alf[0],&alf[1],&alf[2],&alf[3],&alf[4],&alf[5],&alf[6]); + +/* Values of BETA */ + fgets(line,80,stdin); + sscanf(line,"%d",&nbet); + if (nalf < 1 || nbet > 7) { + fprintf(stderr,"VALUE OF BETA IS LESS THAN 0 OR GREATER THAN 7\n"); + goto L220; + } + fgets(line,80,stdin); + sscanf(line,"%f %f %f %f %f %f %f",&bet[0],&bet[1],&bet[2],&bet[3],&bet[4],&bet[5],&bet[6]); + +/* Report values of parameters. */ + printf("TESTS OF THE REAL LEVEL 3 BLAS\nTHE FOLLOWING PARAMETER VALUES WILL BE USED:\n"); + printf(" FOR N"); + for (i__ =1; i__ <=nidim;++i__) printf(" %d",idim[i__-1]); + printf("\n"); + printf(" FOR ALPHA"); + for (i__ =1; i__ <=nalf;++i__) printf(" %f",alf[i__-1]); + printf("\n"); + printf(" FOR BETA"); + for (i__ =1; i__ <=nbet;++i__) printf(" %f",bet[i__-1]); + printf("\n"); + + if (! tsterr) { + printf(" ERROR-EXITS WILL NOT BE TESTED\n"); + } + printf("ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LESS THAN %f\n",thresh); + rorder = FALSE_; + corder = FALSE_; + if (layout == 2) { + rorder = TRUE_; + corder = TRUE_; + printf("COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED\n"); + } else if (layout == 1) { + rorder = TRUE_; + printf("ROW-MAJOR DATA LAYOUT IS TESTED\n"); + } else if (layout == 0) { + corder = TRUE_; + printf("COLUMN-MAJOR DATA LAYOUT IS TESTED\n"); + } + + +/* Read names of subroutines and flags which indicate */ +/* whether they are to be tested. */ + + for (i__ = 1; i__ <= 6; ++i__) { + ltest[i__ - 1] = FALSE_; +/* L20: */ + } +L30: + if (! fgets(line,80,stdin)) { + goto L60; + } + i__1 = sscanf(line,"%12c %c",snamet,&tmpchar); + ltestt=FALSE_; + if (tmpchar=='T')ltestt=TRUE_; + if (i__1 < 2) { + goto L60; + } + for (i__ = 1; i__ <= 9; ++i__) { + if (s_cmp(snamet, snames[i__ - 1] , (ftnlen)12, (ftnlen)12) == + 0) { + goto L50; + } +/* L40: */ + } + printf("SUBPROGRAM NAME %s NOT RECOGNIZED\n****** TESTS ABANDONED ******\n",snamet); + exit(1); + +L50: + ltest[i__ - 1] = ltestt; + goto L30; + +L60: +// f_clos(&cl__1); + +/* Compute EPS (the machine precision). */ + + eps = (float)1.; +L70: + r__1 = eps + (float)1.; + if (sdiff_(&r__1, &c_b89) == (float)0.) { + goto L80; + } + eps *= (float).5; + goto L70; +L80: + eps += eps; + printf("RELATIVE MACHINE PRECISION IS TAKEN TO BE %9.1g\n",eps); + +/* Check the reliability of SMMCH using exact data. */ + + n = 32; + i__1 = n; + for (j = 1; j <= i__1; ++j) { + i__2 = n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + i__3 = i__ - j + 1; + ab[i__ + j * 65 - 66] = (real) f2cmax(i__3,0); +/* L90: */ + } + ab[j + 4224] = (real) j; + ab[(j + 65) * 65 - 65] = (real) j; + c__[j - 1] = (float)0.; +/* L100: */ + } + i__1 = n; + for (j = 1; j <= i__1; ++j) { + cc[j - 1] = (real) (j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3) + ; +/* L110: */ + } +/* CC holds the exact result. On exit from SMMCH CT holds */ +/* the result computed by SMMCH. */ + *(unsigned char *)transa = 'N'; + *(unsigned char *)transb = 'N'; + smmch_(transa, transb, &n, &c__1, &n, &c_b89, ab, &c__65, &ab[4225], & + c__65, &c_b103, c__, &c__65, ct, g, cc, &c__65, &eps, &err, & + fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1); + same = lse_(cc, ct, &n); + if (! same || err != (float)0.) { + printf("ERROR IN SMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); + printf("SMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); + printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); + printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); + printf("****** TESTS ABANDONED ******\n"); + exit(1); + } + *(unsigned char *)transb = 'T'; + smmch_(transa, transb, &n, &c__1, &n, &c_b89, ab, &c__65, &ab[4225], & + c__65, &c_b103, c__, &c__65, ct, g, cc, &c__65, &eps, &err, & + fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1); + same = lse_(cc, ct, &n); + if (! same || err != (float)0.) { + printf("ERROR IN SMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); + printf("SMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); + printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); + printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); + printf("****** TESTS ABANDONED ******\n"); + exit(1); + } + i__1 = n; + for (j = 1; j <= i__1; ++j) { + ab[j + 4224] = (real) (n - j + 1); + ab[(j + 65) * 65 - 65] = (real) (n - j + 1); +/* L120: */ + } + i__1 = n; + for (j = 1; j <= i__1; ++j) { + cc[n - j] = (real) (j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3) + ; +/* L130: */ + } + *(unsigned char *)transa = 'T'; + *(unsigned char *)transb = 'N'; + smmch_(transa, transb, &n, &c__1, &n, &c_b89, ab, &c__65, &ab[4225], & + c__65, &c_b103, c__, &c__65, ct, g, cc, &c__65, &eps, &err, & + fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1); + same = lse_(cc, ct, &n); + if (! same || err != (float)0.) { + printf("ERROR IN SMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); + printf("SMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); + printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); + printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); + printf("****** TESTS ABANDONED ******\n"); + exit(1); + } + *(unsigned char *)transb = 'T'; + smmch_(transa, transb, &n, &c__1, &n, &c_b89, ab, &c__65, &ab[4225], & + c__65, &c_b103, c__, &c__65, ct, g, cc, &c__65, &eps, &err, & + fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1); + same = lse_(cc, ct, &n); + if (! same || err != (float)0.) { + printf("ERROR IN SMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); + printf("SMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); + printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); + printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); + printf("****** TESTS ABANDONED ******\n"); + exit(1); + } + +/* Test each subroutine in turn. */ + + for (isnum = 1; isnum <= 6; ++isnum) { + if (! ltest[isnum - 1]) { +/* Subprogram is not to be tested. */ + printf("%12s WAS NOT TESTED\n",snames[isnum-1]); + } else { + s_copy(srnamc_1.srnamt, snames[isnum - 1], (ftnlen)12, ( + ftnlen)12); +/* Test error exits. */ + if (tsterr) { + cs3chke_(snames[isnum - 1], (ftnlen)12); + } +/* Test computations. */ + infoc_1.infot = 0; + infoc_1.ok = TRUE_; + fatal = FALSE_; + switch ((int)isnum) { + case 1: goto L140; + case 2: goto L150; + case 3: goto L160; + case 4: goto L160; + case 5: goto L170; + case 6: goto L180; + } +/* Test SGEMM, 01. */ +L140: + if (corder) { + schk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__0, (ftnlen)12); + } + if (rorder) { + schk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__1, (ftnlen)12); + } + goto L190; +/* Test SSYMM, 02. */ +L150: + if (corder) { + schk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__0, (ftnlen)12); + } + if (rorder) { + schk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__1, (ftnlen)12); + } + goto L190; +/* Test STRMM, 03, STRSM, 04. */ +L160: + if (corder) { + schk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, & + c__0, (ftnlen)12); + } + if (rorder) { + schk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, & + c__1, (ftnlen)12); + } + goto L190; +/* Test SSYRK, 05. */ +L170: + if (corder) { + schk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__0, (ftnlen)12); + } + if (rorder) { + schk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__1, (ftnlen)12); + } + goto L190; +/* Test SSYR2K, 06. */ +L180: + if (corder) { + schk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, + ct, g, w, &c__0, (ftnlen)12); + } + if (rorder) { + schk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, + ct, g, w, &c__1, (ftnlen)12); + } + goto L190; + +L190: + if (fatal && sfatal) { + goto L210; + } + } +/* L200: */ + } + printf("\nEND OF TESTS\n"); + goto L230; + +L210: + printf("\n****** FATAL ERROR - TESTS ABANDONED ******\n"); + goto L230; + +L220: + printf("AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM\n"); + printf("****** TESTS ABANDONED ******\n"); + +L230: + if (trace) { +// f_clos(&cl__1); + } +// f_clos(&cl__1); + exit(0); + +/* End of SBLAT3. */ + +} /* MAIN__ */ + +/* Subroutine */ int schk1_(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, sname_len) +char *sname; +real *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nalf; +real *alf; +integer *nbet; +real *bet; +integer *nmax; +real *a, *aa, *as, *b, *bb, *bs, *c__, *cc, *cs, *ct, *g; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ich[3+1] = "NTC"; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5, i__6; + + /* Builtin functions */ + integer f_rew(), s_wsfe(), e_wsfe(), do_fio(); + + /* Local variables */ + static real beta; + static integer ldas, ldbs, ldcs; + static logical same, null; + static integer i__, k, m, n; + static real alpha; + static logical isame[13]; + static logical trana, tranb; + static integer nargs; + static logical reset; + extern /* Subroutine */ void sprcn1_(); + extern /* Subroutine */ int smake_(); + extern /* Subroutine */ int smmch_(); + static integer ia, ib, ma, mb, na, nb, nc, ik, im, in, ks, ms, ns; + extern /* Subroutine */ int csgemm_(); + static char tranas[1], tranbs[1], transa[1], transb[1]; + static real errmax; + extern logical lseres_(); + extern logical lse_(); + static integer ica, icb, laa, lbb, lda, lcc, ldb, ldc; + static real als, bls; + extern logical lse_(); + static real err; + +/* Tests SGEMM. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --alf; + --bet; + --g; + --ct; + --cs; + --cc; + c_dim1 = *nmax; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --bs; + --bb; + b_dim1 = *nmax; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ +/* .. Executable Statements .. */ + + nargs = 13; + nc = 0; + reset = TRUE_; + errmax = (float)0.; + + i__1 = *nidim; + for (im = 1; im <= i__1; ++im) { + m = idim[im]; + + i__2 = *nidim; + for (in = 1; in <= i__2; ++in) { + n = idim[in]; +/* Set LDC to 1 more than minimum value if room. */ + ldc = m; + if (ldc < *nmax) { + ++ldc; + } +/* Skip tests if not enough room. */ + if (ldc > *nmax) { + goto L100; + } + lcc = ldc * n; + null = n <= 0 || m <= 0; + + i__3 = *nidim; + for (ik = 1; ik <= i__3; ++ik) { + k = idim[ik]; + + for (ica = 1; ica <= 3; ++ica) { + *(unsigned char *)transa = *(unsigned char *)&ich[ica - 1] + ; + trana = *(unsigned char *)transa == 'T' || *(unsigned + char *)transa == 'C'; + + if (trana) { + ma = k; + na = m; + } else { + ma = m; + na = k; + } +/* Set LDA to 1 more than minimum value if room. */ + lda = ma; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L80; + } + laa = lda * na; + +/* Generate the matrix A. */ + + smake_("GE", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[ + 1], &lda, &reset, &c_b103, (ftnlen)2, (ftnlen)1, ( + ftnlen)1); + + for (icb = 1; icb <= 3; ++icb) { + *(unsigned char *)transb = *(unsigned char *)&ich[icb + - 1]; + tranb = *(unsigned char *)transb == 'T' || *(unsigned + char *)transb == 'C'; + + if (tranb) { + mb = n; + nb = k; + } else { + mb = k; + nb = n; + } +/* Set LDB to 1 more than minimum value if room. */ + ldb = mb; + if (ldb < *nmax) { + ++ldb; + } +/* Skip tests if not enough room. */ + if (ldb > *nmax) { + goto L70; + } + lbb = ldb * nb; + +/* Generate the matrix B. */ + + smake_("GE", " ", " ", &mb, &nb, &b[b_offset], nmax, & + bb[1], &ldb, &reset, &c_b103, (ftnlen)2, ( + ftnlen)1, (ftnlen)1); + + i__4 = *nalf; + for (ia = 1; ia <= i__4; ++ia) { + alpha = alf[ia]; + + i__5 = *nbet; + for (ib = 1; ib <= i__5; ++ib) { + beta = bet[ib]; + +/* Generate the matrix C. */ + + smake_("GE", " ", " ", &m, &n, &c__[c_offset], + nmax, &cc[1], &ldc, &reset, &c_b103, + (ftnlen)2, (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the */ +/* subroutine. */ + + *(unsigned char *)tranas = *(unsigned char *) + transa; + *(unsigned char *)tranbs = *(unsigned char *) + transb; + ms = m; + ns = n; + ks = k; + als = alpha; + i__6 = laa; + for (i__ = 1; i__ <= i__6; ++i__) { + as[i__] = aa[i__]; +/* L10: */ + } + ldas = lda; + i__6 = lbb; + for (i__ = 1; i__ <= i__6; ++i__) { + bs[i__] = bb[i__]; +/* L20: */ + } + ldbs = ldb; + bls = beta; + i__6 = lcc; + for (i__ = 1; i__ <= i__6; ++i__) { + cs[i__] = cc[i__]; +/* L30: */ + } + ldcs = ldc; + +/* Call the subroutine. */ + + if (*trace) { + sprcn1_(ntra, &nc, sname, iorder, transa, + transb, &m, &n, &k, &alpha, &lda, + &ldb, &beta, &ldc, (ftnlen)12, ( + ftnlen)1, (ftnlen)1); + } + if (*rewi) { +// f_rew(&al__1); + } + csgemm_(iorder, transa, transb, &m, &n, &k, & + alpha, &aa[1], &lda, &bb[1], &ldb, & + beta, &cc[1], &ldc, (ftnlen)1, ( + ftnlen)1); + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf(" *** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + *fatal = TRUE_; + goto L120; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)transa == *( + unsigned char *)tranas; + isame[1] = *(unsigned char *)transb == *( + unsigned char *)tranbs; + isame[2] = ms == m; + isame[3] = ns == n; + isame[4] = ks == k; + isame[5] = als == alpha; + isame[6] = lse_(&as[1], &aa[1], &laa); + isame[7] = ldas == lda; + isame[8] = lse_(&bs[1], &bb[1], &lbb); + isame[9] = ldbs == ldb; + isame[10] = bls == beta; + if (null) { + isame[11] = lse_(&cs[1], &cc[1], &lcc); + } else { + isame[11] = lseres_("GE", " ", &m, &n, & + cs[1], &cc[1], &ldc, (ftnlen)2, ( + ftnlen)1); + } + isame[12] = ldcs == ldc; + +/* If data was incorrectly changed, report */ +/* and return. */ + + same = TRUE_; + i__6 = nargs; + for (i__ = 1; i__ <= i__6; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L120; + } + + if (! null) { + +/* Check the result. */ + + smmch_(transa, transb, &m, &n, &k, &alpha, + &a[a_offset], nmax, &b[b_offset], + nmax, &beta, &c__[c_offset], + nmax, &ct[1], &g[1], &cc[1], &ldc, + eps, &err, fatal, nout, &c_true, + (ftnlen)1, (ftnlen)1); + errmax = dmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L120; + } + } + +/* L50: */ + } + +/* L60: */ + } + +L70: + ; + } + +L80: + ; + } + +/* L90: */ + } + +L100: + ; + } + +/* L110: */ + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + if (*iorder == 1) { + printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + } + goto L130; + +L120: + printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + sprcn1_(nout, &nc, sname, iorder, transa, transb, &m, &n, &k, &alpha, & + lda, &ldb, &beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); + +L130: + return 0; + +/* 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',', */ +/* $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ', */ +/* $ 'C,', I3, ').' ) */ + +/* End of SCHK1. */ + +} /* schk1_ */ + + + + +/* Subroutine */ void sprcn1_(nout, nc, sname, iorder, transa, transb, m, n, k, + alpha, lda, ldb, beta, ldc, sname_len, transa_len, transb_len) +integer *nout, *nc; +char *sname; +integer *iorder; +char *transa, *transb; +integer *m, *n, *k; +real *alpha; +integer *lda, *ldb; +real *beta; +integer *ldc; +ftnlen sname_len; +ftnlen transa_len; +ftnlen transb_len; +{ + /* Builtin functions */ + integer s_wsfe(), do_fio(), e_wsfe(); + + /* Local variables */ + static char crc[14], cta[14], ctb[14]; + + if (*(unsigned char *)transa == 'N') { + s_copy(cta, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transa == 'T') { + s_copy(cta, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cta, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)transb == 'N') { + s_copy(ctb, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transb == 'T') { + s_copy(ctb, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(ctb, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*iorder == 1) { + s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); + } else { + s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); + } + printf("%6d: %s %s %s %s\n",*nc,sname,crc,cta,ctb); + printf("%d %d %d %4.1f A, %d, B, %d, %4.1f, C, %d.\n",*m,*n,*k,*alpha,*lda,*ldb,*beta,*ldc); + +} /* sprcn1_ */ + + +/* Subroutine */ int schk2_(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, sname_len) +char *sname; +real *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nalf; +real *alf; +integer *nbet; +real *bet; +integer *nmax; +real *a, *aa, *as, *b, *bb, *bs, *c__, *cc, *cs, *ct, *g; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ichs[2+1] = "LR"; + static char ichu[2+1] = "UL"; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5; + + /* Builtin functions */ + integer f_rew(), s_wsfe(), e_wsfe(), do_fio(); + + /* Local variables */ + static real beta; + static integer ldas, ldbs, ldcs; + static logical same; + static char side[1]; + static logical left, null; + static char uplo[1]; + static integer i__, m, n; + static real alpha; + static logical isame[13]; + static char sides[1]; + static integer nargs; + static logical reset; + static char uplos[1]; + static integer ia, ib, na, nc, im, in, ms, ns; + static real errmax; + extern logical lseres_(); + extern /* Subroutine */ int cssymm_(); + extern void sprcn2_(); + extern int smake_(); + extern int smmch_(); + static integer laa, lbb, lda, lcc, ldb, ldc, ics; + static real als, bls; + static integer icu; + extern logical lse_(); + static real err; + +/* Tests SSYMM. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --alf; + --bet; + --g; + --ct; + --cs; + --cc; + c_dim1 = *nmax; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --bs; + --bb; + b_dim1 = *nmax; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ +/* .. Executable Statements .. */ + + nargs = 12; + nc = 0; + reset = TRUE_; + errmax = (float)0.; + + i__1 = *nidim; + for (im = 1; im <= i__1; ++im) { + m = idim[im]; + + i__2 = *nidim; + for (in = 1; in <= i__2; ++in) { + n = idim[in]; +/* Set LDC to 1 more than minimum value if room. */ + ldc = m; + if (ldc < *nmax) { + ++ldc; + } +/* Skip tests if not enough room. */ + if (ldc > *nmax) { + goto L90; + } + lcc = ldc * n; + null = n <= 0 || m <= 0; + +/* Set LDB to 1 more than minimum value if room. */ + ldb = m; + if (ldb < *nmax) { + ++ldb; + } +/* Skip tests if not enough room. */ + if (ldb > *nmax) { + goto L90; + } + lbb = ldb * n; + +/* Generate the matrix B. */ + + smake_("GE", " ", " ", &m, &n, &b[b_offset], nmax, &bb[1], &ldb, & + reset, &c_b103, (ftnlen)2, (ftnlen)1, (ftnlen)1); + + for (ics = 1; ics <= 2; ++ics) { + *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1]; + left = *(unsigned char *)side == 'L'; + + if (left) { + na = m; + } else { + na = n; + } +/* Set LDA to 1 more than minimum value if room. */ + lda = na; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L80; + } + laa = lda * na; + + for (icu = 1; icu <= 2; ++icu) { + *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; + +/* Generate the symmetric matrix A. */ + + smake_("SY", uplo, " ", &na, &na, &a[a_offset], nmax, &aa[ + 1], &lda, &reset, &c_b103, (ftnlen)2, (ftnlen)1, ( + ftnlen)1); + + i__3 = *nalf; + for (ia = 1; ia <= i__3; ++ia) { + alpha = alf[ia]; + + i__4 = *nbet; + for (ib = 1; ib <= i__4; ++ib) { + beta = bet[ib]; + +/* Generate the matrix C. */ + + smake_("GE", " ", " ", &m, &n, &c__[c_offset], + nmax, &cc[1], &ldc, &reset, &c_b103, ( + ftnlen)2, (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the */ +/* subroutine. */ + + *(unsigned char *)sides = *(unsigned char *)side; + *(unsigned char *)uplos = *(unsigned char *)uplo; + ms = m; + ns = n; + als = alpha; + i__5 = laa; + for (i__ = 1; i__ <= i__5; ++i__) { + as[i__] = aa[i__]; +/* L10: */ + } + ldas = lda; + i__5 = lbb; + for (i__ = 1; i__ <= i__5; ++i__) { + bs[i__] = bb[i__]; +/* L20: */ + } + ldbs = ldb; + bls = beta; + i__5 = lcc; + for (i__ = 1; i__ <= i__5; ++i__) { + cs[i__] = cc[i__]; +/* L30: */ + } + ldcs = ldc; + +/* Call the subroutine. */ + + if (*trace) { + sprcn2_(ntra, &nc, sname, iorder, side, uplo, + &m, &n, &alpha, &lda, &ldb, &beta, & + ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1) + ; + } + if (*rewi) { +// f_rew(&al__1); + } + cssymm_(iorder, side, uplo, &m, &n, &alpha, &aa[1] + , &lda, &bb[1], &ldb, &beta, &cc[1], &ldc, + (ftnlen)1, (ftnlen)1); + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + *fatal = TRUE_; + goto L110; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)sides == *(unsigned + char *)side; + isame[1] = *(unsigned char *)uplos == *(unsigned + char *)uplo; + isame[2] = ms == m; + isame[3] = ns == n; + isame[4] = als == alpha; + isame[5] = lse_(&as[1], &aa[1], &laa); + isame[6] = ldas == lda; + isame[7] = lse_(&bs[1], &bb[1], &lbb); + isame[8] = ldbs == ldb; + isame[9] = bls == beta; + if (null) { + isame[10] = lse_(&cs[1], &cc[1], &lcc); + } else { + isame[10] = lseres_("GE", " ", &m, &n, &cs[1], + &cc[1], &ldc, (ftnlen)2, (ftnlen)1); + } + isame[11] = ldcs == ldc; + +/* If data was incorrectly changed, report and */ +/* return. */ + + same = TRUE_; + i__5 = nargs; + for (i__ = 1; i__ <= i__5; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L110; + } + + if (! null) { + +/* Check the result. */ + + if (left) { + smmch_("N", "N", &m, &n, &m, &alpha, &a[ + a_offset], nmax, &b[b_offset], + nmax, &beta, &c__[c_offset], nmax, + &ct[1], &g[1], &cc[1], &ldc, eps, + &err, fatal, nout, &c_true, ( + ftnlen)1, (ftnlen)1); + } else { + smmch_("N", "N", &m, &n, &n, &alpha, &b[ + b_offset], nmax, &a[a_offset], + nmax, &beta, &c__[c_offset], nmax, + &ct[1], &g[1], &cc[1], &ldc, eps, + &err, fatal, nout, &c_true, ( + ftnlen)1, (ftnlen)1); + } + errmax = dmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L110; + } + } + +/* L50: */ + } + +/* L60: */ + } + +/* L70: */ + } + +L80: + ; + } + +L90: + ; + } + +/* L100: */ + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + if (*iorder == 1) { + printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + } + goto L120; + +L110: + printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + sprcn2_(nout, &nc, sname, iorder, side, uplo, &m, &n, &alpha, &lda, &ldb, + &beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); + +L120: + return 0; + +/* 9995 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ +/* $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', */ +/* $ ' .' ) */ + +/* End of SCHK2. */ + +} /* schk2_ */ + + +/* Subroutine */ void sprcn2_(nout, nc, sname, iorder, side, uplo, m, n, alpha, + lda, ldb, beta, ldc, sname_len, side_len, uplo_len) +integer *nout, *nc; +char *sname; +integer *iorder; +char *side, *uplo; +integer *m, *n; +real *alpha; +integer *lda, *ldb; +real *beta; +integer *ldc; +ftnlen sname_len; +ftnlen side_len; +ftnlen uplo_len; +{ + /* Builtin functions */ + integer s_wsfe(), do_fio(), e_wsfe(); + + /* Local variables */ + static char cs[14], cu[14], crc[14]; + + if (*(unsigned char *)side == 'L') { + s_copy(cs, " CblasLeft", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cs, " CblasRight", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)uplo == 'U') { + s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); + } + if (*iorder == 1) { + s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); + } else { + s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); + } + printf("%6d: %s %s %s %s\n",*nc,sname,crc,cs,cu); + printf("%d %d %4.1f A, %d, B, %d, %4.1f C, %d.\n",*m,*n,*alpha,*lda,*ldb,*beta,*ldc); +} /* sprcn2_ */ + + +/* Subroutine */ int schk3_(sname, eps, thresh, nout, ntra, trace, rewi, + fatal, nidim, idim, nalf, alf, nmax, a, aa, as, b, bb, bs, ct, g, c__, + iorder, sname_len) +char *sname; +real *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nalf; +real *alf; +integer *nmax; +real *a, *aa, *as, *b, *bb, *bs, *ct, *g, *c__; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ichu[2+1] = "UL"; + static char icht[3+1] = "NTC"; + static char ichd[2+1] = "UN"; + static char ichs[2+1] = "LR"; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5; + + /* Builtin functions */ + integer f_rew(), s_wsfe(), e_wsfe(), do_fio(); + + /* Local variables */ + static char diag[1]; + static integer ldas, ldbs; + static logical same; + static char side[1]; + static logical left, null; + static char uplo[1]; + static integer i__, j, m, n; + static real alpha; + static char diags[1]; + static logical isame[13]; + static char sides[1]; + static integer nargs; + static logical reset; + static char uplos[1]; + extern /* Subroutine */ void sprcn3_(); + static integer ia, na, nc, im, in, ms, ns; + static char tranas[1], transa[1]; + static real errmax; + extern int smake_(); + extern int smmch_(); + extern logical lseres_(); + extern /* Subroutine */ int cstrmm_(), cstrsm_(); + static integer laa, icd, lbb, lda, ldb, ics; + static real als; + static integer ict, icu; + extern logical lse_(); + static real err; + +/* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --alf; + c_dim1 = *nmax; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --g; + --ct; + --bs; + --bb; + b_dim1 = *nmax; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ +/* .. Executable Statements .. */ + + nargs = 11; + nc = 0; + reset = TRUE_; + errmax = (float)0.; +/* Set up zero matrix for SMMCH. */ + i__1 = *nmax; + for (j = 1; j <= i__1; ++j) { + i__2 = *nmax; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = (float)0.; +/* L10: */ + } +/* L20: */ + } + + i__1 = *nidim; + for (im = 1; im <= i__1; ++im) { + m = idim[im]; + + i__2 = *nidim; + for (in = 1; in <= i__2; ++in) { + n = idim[in]; +/* Set LDB to 1 more than minimum value if room. */ + ldb = m; + if (ldb < *nmax) { + ++ldb; + } +/* Skip tests if not enough room. */ + if (ldb > *nmax) { + goto L130; + } + lbb = ldb * n; + null = m <= 0 || n <= 0; + + for (ics = 1; ics <= 2; ++ics) { + *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1]; + left = *(unsigned char *)side == 'L'; + if (left) { + na = m; + } else { + na = n; + } +/* Set LDA to 1 more than minimum value if room. */ + lda = na; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L130; + } + laa = lda * na; + + for (icu = 1; icu <= 2; ++icu) { + *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; + + for (ict = 1; ict <= 3; ++ict) { + *(unsigned char *)transa = *(unsigned char *)&icht[ + ict - 1]; + + for (icd = 1; icd <= 2; ++icd) { + *(unsigned char *)diag = *(unsigned char *)&ichd[ + icd - 1]; + + i__3 = *nalf; + for (ia = 1; ia <= i__3; ++ia) { + alpha = alf[ia]; + +/* Generate the matrix A. */ + + smake_("TR", uplo, diag, &na, &na, &a[ + a_offset], nmax, &aa[1], &lda, &reset, + &c_b103, (ftnlen)2, (ftnlen)1, ( + ftnlen)1); + +/* Generate the matrix B. */ + + smake_("GE", " ", " ", &m, &n, &b[b_offset], + nmax, &bb[1], &ldb, &reset, &c_b103, ( + ftnlen)2, (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the */ +/* subroutine. */ + + *(unsigned char *)sides = *(unsigned char *) + side; + *(unsigned char *)uplos = *(unsigned char *) + uplo; + *(unsigned char *)tranas = *(unsigned char *) + transa; + *(unsigned char *)diags = *(unsigned char *) + diag; + ms = m; + ns = n; + als = alpha; + i__4 = laa; + for (i__ = 1; i__ <= i__4; ++i__) { + as[i__] = aa[i__]; +/* L30: */ + } + ldas = lda; + i__4 = lbb; + for (i__ = 1; i__ <= i__4; ++i__) { + bs[i__] = bb[i__]; +/* L40: */ + } + ldbs = ldb; + +/* Call the subroutine. */ + + if (s_cmp(sname + 9, "mm", (ftnlen)2, (ftnlen) + 2) == 0) { + if (*trace) { + sprcn3_(ntra, &nc, sname, iorder, + side, uplo, transa, diag, &m, + &n, &alpha, &lda, &ldb, ( + ftnlen)12, (ftnlen)1, (ftnlen) + 1, (ftnlen)1, (ftnlen)1); + } + if (*rewi) { +// f_rew(&al__1); + } + cstrmm_(iorder, side, uplo, transa, diag, + &m, &n, &alpha, &aa[1], &lda, &bb[ + 1], &ldb, (ftnlen)1, (ftnlen)1, ( + ftnlen)1, (ftnlen)1); + } else if (s_cmp(sname + 9, "sm", (ftnlen)2, ( + ftnlen)2) == 0) { + if (*trace) { + sprcn3_(ntra, &nc, sname, iorder, + side, uplo, transa, diag, &m, + &n, &alpha, &lda, &ldb, ( + ftnlen)12, (ftnlen)1, (ftnlen) + 1, (ftnlen)1, (ftnlen)1); + } + if (*rewi) { +// f_rew(&al__1); + } + cstrsm_(iorder, side, uplo, transa, diag, + &m, &n, &alpha, &aa[1], &lda, &bb[ + 1], &ldb, (ftnlen)1, (ftnlen)1, ( + ftnlen)1, (ftnlen)1); + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + *fatal = TRUE_; + goto L150; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)sides == *( + unsigned char *)side; + isame[1] = *(unsigned char *)uplos == *( + unsigned char *)uplo; + isame[2] = *(unsigned char *)tranas == *( + unsigned char *)transa; + isame[3] = *(unsigned char *)diags == *( + unsigned char *)diag; + isame[4] = ms == m; + isame[5] = ns == n; + isame[6] = als == alpha; + isame[7] = lse_(&as[1], &aa[1], &laa); + isame[8] = ldas == lda; + if (null) { + isame[9] = lse_(&bs[1], &bb[1], &lbb); + } else { + isame[9] = lseres_("GE", " ", &m, &n, &bs[ + 1], &bb[1], &ldb, (ftnlen)2, ( + ftnlen)1); + } + isame[10] = ldbs == ldb; + +/* If data was incorrectly changed, report and */ +/* return. */ + + same = TRUE_; + i__4 = nargs; + for (i__ = 1; i__ <= i__4; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L50: */ + } + if (! same) { + *fatal = TRUE_; + goto L150; + } + + if (! null) { + if (s_cmp(sname + 9, "mm", (ftnlen)2, ( + ftnlen)2) == 0) { + +/* Check the result. */ + + if (left) { + smmch_(transa, "N", &m, &n, &m, & + alpha, &a[a_offset], nmax, + &b[b_offset], nmax, & + c_b103, &c__[c_offset], + nmax, &ct[1], &g[1], &bb[ + 1], &ldb, eps, &err, + fatal, nout, &c_true, ( + ftnlen)1, (ftnlen)1); + } else { + smmch_("N", transa, &m, &n, &n, & + alpha, &b[b_offset], nmax, + &a[a_offset], nmax, & + c_b103, &c__[c_offset], + nmax, &ct[1], &g[1], &bb[ + 1], &ldb, eps, &err, + fatal, nout, &c_true, ( + ftnlen)1, (ftnlen)1); + } + } else if (s_cmp(sname + 9, "sm", (ftnlen) + 2, (ftnlen)2) == 0) { + +/* Compute approximation to original */ +/* matrix. */ + + i__4 = n; + for (j = 1; j <= i__4; ++j) { + i__5 = m; + for (i__ = 1; i__ <= i__5; ++i__) + { + c__[i__ + j * c_dim1] = bb[i__ + (j - 1) * ldb]; + bb[i__ + (j - 1) * ldb] = alpha * b[i__ + j * + b_dim1]; +/* L60: */ + } +/* L70: */ + } + + if (left) { + smmch_(transa, "N", &m, &n, &m, & + c_b89, &a[a_offset], nmax, + &c__[c_offset], nmax, & + c_b103, &b[b_offset], + nmax, &ct[1], &g[1], &bb[ + 1], &ldb, eps, &err, + fatal, nout, &c_false, ( + ftnlen)1, (ftnlen)1); + } else { + smmch_("N", transa, &m, &n, &n, & + c_b89, &c__[c_offset], + nmax, &a[a_offset], nmax, + &c_b103, &b[b_offset], + nmax, &ct[1], &g[1], &bb[ + 1], &ldb, eps, &err, + fatal, nout, &c_false, ( + ftnlen)1, (ftnlen)1); + } + } + errmax = dmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L150; + } + } + +/* L80: */ + } + +/* L90: */ + } + +/* L100: */ + } + +/* L110: */ + } + +/* L120: */ + } + +L130: + ; + } + +/* L140: */ + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + if (*iorder == 1) { + printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + } + goto L160; + +L150: + printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + if (*trace) { + sprcn3_(ntra, &nc, sname, iorder, side, uplo, transa, diag, &m, &n, & + alpha, &lda, &ldb, (ftnlen)12, (ftnlen)1, (ftnlen)1, (ftnlen) + 1, (ftnlen)1); + } + +L160: + return 0; + +/* 9995 FORMAT( 1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( I3, ',' ), */ +/* $ F4.1, ', A,', I3, ', B,', I3, ') .' ) */ + +/* End of SCHK3. */ + +} /* schk3_ */ + + +/* Subroutine */ void sprcn3_(nout, nc, sname, iorder, side, uplo, transa, + diag, m, n, alpha, lda, ldb, sname_len, side_len, uplo_len, + transa_len, diag_len) +integer *nout, *nc; +char *sname; +integer *iorder; +char *side, *uplo, *transa, *diag; +integer *m, *n; +real *alpha; +integer *lda, *ldb; +ftnlen sname_len; +ftnlen side_len; +ftnlen uplo_len; +ftnlen transa_len; +ftnlen diag_len; +{ + /* Builtin functions */ + integer s_wsfe(), do_fio(), e_wsfe(); + + /* Local variables */ + static char ca[14], cd[14], cs[14], cu[14], crc[14]; + + if (*(unsigned char *)side == 'L') { + s_copy(cs, " CblasLeft", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cs, " CblasRight", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)uplo == 'U') { + s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)transa == 'N') { + s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transa == 'T') { + s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)diag == 'N') { + s_copy(cd, " CblasNonUnit", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cd, " CblasUnit", (ftnlen)14, (ftnlen)14); + } + if (*iorder == 1) { + s_copy(crc, "CblasRowMajor", (ftnlen)14, (ftnlen)13); + } else { + s_copy(crc, "CblasColMajor", (ftnlen)14, (ftnlen)13); + } + printf("%6d: %s %s %s %s\n",*nc,sname,crc,cs,cu); + printf(" %s %s %d %d %4.1f A %d B %d\n",ca,cd,*m,*n,*alpha,*lda,*ldb); + +} /* sprcn3_ */ + + +/* Subroutine */ int 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, sname_len) +char *sname; +real *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nalf; +real *alf; +integer *nbet; +real *bet; +integer *nmax; +real *a, *aa, *as, *b, *bb, *bs, *c__, *cc, *cs, *ct, *g; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char icht[3+1] = "NTC"; + static char ichu[2+1] = "UL"; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5; + + /* Builtin functions */ + integer f_rew(), s_wsfe(), e_wsfe(), do_fio(); + + /* Local variables */ + static real beta; + static integer ldas, ldcs; + static logical same; + static real bets; + static logical tran, null; + static char uplo[1]; + static integer i__, j, k, n; + static real alpha; + static logical isame[13]; + static integer nargs; + static logical reset; + static char trans[1]; + static logical upper; + static char uplos[1]; + extern /* Subroutine */ void sprcn4_(); + extern /* Subroutine */ int smake_(); + extern /* Subroutine */ int smmch_(); + static integer ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns; + static real errmax; + extern logical lseres_(); + static char transs[1]; + extern /* Subroutine */ int cssyrk_(); + static integer laa, lda, lcc, ldc; + static real als; + static integer ict, icu; + extern logical lse_(); + static real err; + +/* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --alf; + --bet; + --g; + --ct; + --cs; + --cc; + c_dim1 = *nmax; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --bs; + --bb; + b_dim1 = *nmax; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ +/* .. Executable Statements .. */ + + nargs = 10; + nc = 0; + reset = TRUE_; + errmax = (float)0.; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; +/* Set LDC to 1 more than minimum value if room. */ + ldc = n; + if (ldc < *nmax) { + ++ldc; + } +/* Skip tests if not enough room. */ + if (ldc > *nmax) { + goto L100; + } + lcc = ldc * n; + null = n <= 0; + + i__2 = *nidim; + for (ik = 1; ik <= i__2; ++ik) { + k = idim[ik]; + + for (ict = 1; ict <= 3; ++ict) { + *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1]; + tran = *(unsigned char *)trans == 'T' || *(unsigned char *) + trans == 'C'; + if (tran) { + ma = k; + na = n; + } else { + ma = n; + na = k; + } +/* Set LDA to 1 more than minimum value if room. */ + lda = ma; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L80; + } + laa = lda * na; + +/* Generate the matrix A. */ + + smake_("GE", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[1], & + lda, &reset, &c_b103, (ftnlen)2, (ftnlen)1, (ftnlen)1) + ; + + for (icu = 1; icu <= 2; ++icu) { + *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; + upper = *(unsigned char *)uplo == 'U'; + + i__3 = *nalf; + for (ia = 1; ia <= i__3; ++ia) { + alpha = alf[ia]; + + i__4 = *nbet; + for (ib = 1; ib <= i__4; ++ib) { + beta = bet[ib]; + +/* Generate the matrix C. */ + + smake_("SY", uplo, " ", &n, &n, &c__[c_offset], + nmax, &cc[1], &ldc, &reset, &c_b103, ( + ftnlen)2, (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the subroutine. */ + + *(unsigned char *)uplos = *(unsigned char *)uplo; + *(unsigned char *)transs = *(unsigned char *) + trans; + ns = n; + ks = k; + als = alpha; + i__5 = laa; + for (i__ = 1; i__ <= i__5; ++i__) { + as[i__] = aa[i__]; +/* L10: */ + } + ldas = lda; + bets = beta; + i__5 = lcc; + for (i__ = 1; i__ <= i__5; ++i__) { + cs[i__] = cc[i__]; +/* L20: */ + } + ldcs = ldc; + +/* Call the subroutine. */ + + if (*trace) { + sprcn4_(ntra, &nc, sname, iorder, uplo, trans, + &n, &k, &alpha, &lda, &beta, &ldc, ( + ftnlen)12, (ftnlen)1, (ftnlen)1); + } + if (*rewi) { +// f_rew(&al__1); + } + cssyrk_(iorder, uplo, trans, &n, &k, &alpha, &aa[ + 1], &lda, &beta, &cc[1], &ldc, (ftnlen)1, + (ftnlen)1); + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + *fatal = TRUE_; + goto L120; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)uplos == *(unsigned + char *)uplo; + isame[1] = *(unsigned char *)transs == *(unsigned + char *)trans; + isame[2] = ns == n; + isame[3] = ks == k; + isame[4] = als == alpha; + isame[5] = lse_(&as[1], &aa[1], &laa); + isame[6] = ldas == lda; + isame[7] = bets == beta; + if (null) { + isame[8] = lse_(&cs[1], &cc[1], &lcc); + } else { + isame[8] = lseres_("SY", uplo, &n, &n, &cs[1], + &cc[1], &ldc, (ftnlen)2, (ftnlen)1); + } + isame[9] = ldcs == ldc; + +/* If data was incorrectly changed, report and */ +/* return. */ + + same = TRUE_; + i__5 = nargs; + for (i__ = 1; i__ <= i__5; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L30: */ + } + if (! same) { + *fatal = TRUE_; + goto L120; + } + + if (! null) { + +/* Check the result column by column. */ + + jc = 1; + i__5 = n; + for (j = 1; j <= i__5; ++j) { + if (upper) { + jj = 1; + lj = j; + } else { + jj = j; + lj = n - j + 1; + } + if (tran) { + smmch_("T", "N", &lj, &c__1, &k, & + alpha, &a[jj * a_dim1 + 1], + nmax, &a[j * a_dim1 + 1], + nmax, &beta, &c__[jj + j * + c_dim1], nmax, &ct[1], &g[1], + &cc[jc], &ldc, eps, &err, + fatal, nout, &c_true, (ftnlen) + 1, (ftnlen)1); + } else { + smmch_("N", "T", &lj, &c__1, &k, & + alpha, &a[jj + a_dim1], nmax, + &a[j + a_dim1], nmax, &beta, & + c__[jj + j * c_dim1], nmax, & + ct[1], &g[1], &cc[jc], &ldc, + eps, &err, fatal, nout, & + c_true, (ftnlen)1, (ftnlen)1); + } + if (upper) { + jc += ldc; + } else { + jc = jc + ldc + 1; + } + errmax = dmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L110; + } +/* L40: */ + } + } + +/* L50: */ + } + +/* L60: */ + } + +/* L70: */ + } + +L80: + ; + } + +/* L90: */ + } + +L100: + ; + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + if (*iorder == 1) { + printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + } + goto L130; + +L110: + if (n > 1) { + printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j); + } + +L120: + printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + sprcn4_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, & + beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); + +L130: + return 0; + +/* 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ +/* $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' ) */ + +/* End of SCHK4. */ + +} /* schk4_ */ + + +/* Subroutine */ void sprcn4_(nout, nc, sname, iorder, uplo, transa, n, k, + alpha, lda, beta, ldc, sname_len, uplo_len, transa_len) +integer *nout, *nc; +char *sname; +integer *iorder; +char *uplo, *transa; +integer *n, *k; +real *alpha; +integer *lda; +real *beta; +integer *ldc; +ftnlen sname_len; +ftnlen uplo_len; +ftnlen transa_len; +{ + /* Builtin functions */ + integer s_wsfe(), do_fio(), e_wsfe(); + + /* Local variables */ + static char ca[14], cu[14], crc[14]; + + if (*(unsigned char *)uplo == 'U') { + s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)transa == 'N') { + s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transa == 'T') { + s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*iorder == 1) { + s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); + } else { + s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); + } + printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); + printf("( %d %d %4.1f A %d %4.1f C %d\n",*n,*k,*alpha,*lda,*beta,*ldc); + +} /* sprcn4_ */ + + +/* Subroutine */ int schk5_(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, sname_len) +char *sname; +real *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nalf; +real *alf; +integer *nbet; +real *bet; +integer *nmax; +real *ab, *aa, *as, *bb, *bs, *c__, *cc, *cs, *ct, *g, *w; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char icht[3+1] = "NTC"; + static char ichu[2+1] = "UL"; + + /* System generated locals */ + integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8; + + /* Builtin functions */ + integer f_rew(), s_wsfe(), e_wsfe(), do_fio(); + + /* Local variables */ + static integer jjab; + static real beta; + static integer ldas, ldbs, ldcs; + static logical same; + static real bets; + static logical tran, null; + static char uplo[1]; + static integer i__, j, k, n; + static real alpha; + static logical isame[13]; + static integer nargs; + static logical reset; + static char trans[1]; + static logical upper; + static char uplos[1]; + static integer ia, ib; + extern /* Subroutine */ void sprcn5_(); + static integer jc, ma, na, nc, ik, in, jj, lj, ks, ns; + static real errmax; + extern logical lseres_(); + extern int smake_(); + static char transs[1]; + static integer laa, lbb, lda, lcc, ldb, ldc; + static real als; + static integer ict, icu; + extern /* Subroutine */ int cssyr2k_(); + extern logical lse_(); + extern int smmch_(); + static real err; + +/* Tests SSYR2K. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --alf; + --bet; + --w; + --g; + --ct; + --cs; + --cc; + c_dim1 = *nmax; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --bs; + --bb; + --as; + --aa; + --ab; + + /* Function Body */ +/* .. Executable Statements .. */ + + nargs = 12; + nc = 0; + reset = TRUE_; + errmax = (float)0.; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; +/* Set LDC to 1 more than minimum value if room. */ + ldc = n; + if (ldc < *nmax) { + ++ldc; + } +/* Skip tests if not enough room. */ + if (ldc > *nmax) { + goto L130; + } + lcc = ldc * n; + null = n <= 0; + + i__2 = *nidim; + for (ik = 1; ik <= i__2; ++ik) { + k = idim[ik]; + + for (ict = 1; ict <= 3; ++ict) { + *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1]; + tran = *(unsigned char *)trans == 'T' || *(unsigned char *) + trans == 'C'; + if (tran) { + ma = k; + na = n; + } else { + ma = n; + na = k; + } +/* Set LDA to 1 more than minimum value if room. */ + lda = ma; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L110; + } + laa = lda * na; + +/* Generate the matrix A. */ + + if (tran) { + i__3 = *nmax << 1; + smake_("GE", " ", " ", &ma, &na, &ab[1], &i__3, &aa[1], & + lda, &reset, &c_b103, (ftnlen)2, (ftnlen)1, ( + ftnlen)1); + } else { + smake_("GE", " ", " ", &ma, &na, &ab[1], nmax, &aa[1], & + lda, &reset, &c_b103, (ftnlen)2, (ftnlen)1, ( + ftnlen)1); + } + +/* Generate the matrix B. */ + + ldb = lda; + lbb = laa; + if (tran) { + i__3 = *nmax << 1; + smake_("GE", " ", " ", &ma, &na, &ab[k + 1], &i__3, &bb[1] + , &ldb, &reset, &c_b103, (ftnlen)2, (ftnlen)1, ( + ftnlen)1); + } else { + smake_("GE", " ", " ", &ma, &na, &ab[k * *nmax + 1], nmax, + &bb[1], &ldb, &reset, &c_b103, (ftnlen)2, ( + ftnlen)1, (ftnlen)1); + } + + for (icu = 1; icu <= 2; ++icu) { + *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; + upper = *(unsigned char *)uplo == 'U'; + + i__3 = *nalf; + for (ia = 1; ia <= i__3; ++ia) { + alpha = alf[ia]; + + i__4 = *nbet; + for (ib = 1; ib <= i__4; ++ib) { + beta = bet[ib]; + +/* Generate the matrix C. */ + + smake_("SY", uplo, " ", &n, &n, &c__[c_offset], + nmax, &cc[1], &ldc, &reset, &c_b103, ( + ftnlen)2, (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the subroutine. */ + + *(unsigned char *)uplos = *(unsigned char *)uplo; + *(unsigned char *)transs = *(unsigned char *) + trans; + ns = n; + ks = k; + als = alpha; + i__5 = laa; + for (i__ = 1; i__ <= i__5; ++i__) { + as[i__] = aa[i__]; +/* L10: */ + } + ldas = lda; + i__5 = lbb; + for (i__ = 1; i__ <= i__5; ++i__) { + bs[i__] = bb[i__]; +/* L20: */ + } + ldbs = ldb; + bets = beta; + i__5 = lcc; + for (i__ = 1; i__ <= i__5; ++i__) { + cs[i__] = cc[i__]; +/* L30: */ + } + ldcs = ldc; + +/* Call the subroutine. */ + + if (*trace) { + sprcn5_(ntra, &nc, sname, iorder, uplo, trans, + &n, &k, &alpha, &lda, &ldb, &beta, & + ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1) + ; + } + if (*rewi) { +// f_rew(&al__1); + } + cssyr2k_(iorder, uplo, trans, &n, &k, &alpha, &aa[ + 1], &lda, &bb[1], &ldb, &beta, &cc[1], & + ldc, (ftnlen)1, (ftnlen)1); + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + *fatal = TRUE_; + goto L150; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)uplos == *(unsigned + char *)uplo; + isame[1] = *(unsigned char *)transs == *(unsigned + char *)trans; + isame[2] = ns == n; + isame[3] = ks == k; + isame[4] = als == alpha; + isame[5] = lse_(&as[1], &aa[1], &laa); + isame[6] = ldas == lda; + isame[7] = lse_(&bs[1], &bb[1], &lbb); + isame[8] = ldbs == ldb; + isame[9] = bets == beta; + if (null) { + isame[10] = lse_(&cs[1], &cc[1], &lcc); + } else { + isame[10] = lseres_("SY", uplo, &n, &n, &cs[1] + , &cc[1], &ldc, (ftnlen)2, (ftnlen)1); + } + isame[11] = ldcs == ldc; + +/* If data was incorrectly changed, report and */ +/* return. */ + + same = TRUE_; + i__5 = nargs; + for (i__ = 1; i__ <= i__5; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L150; + } + + if (! null) { + +/* Check the result column by column. */ + + jjab = 1; + jc = 1; + i__5 = n; + for (j = 1; j <= i__5; ++j) { + if (upper) { + jj = 1; + lj = j; + } else { + jj = j; + lj = n - j + 1; + } + if (tran) { + i__6 = k; + for (i__ = 1; i__ <= i__6; ++i__) { + w[i__] = ab[((j - 1) << 1) * *nmax + + k + i__]; + w[k + i__] = ab[((j - 1) << 1) * * + nmax + i__]; +/* L50: */ + } + i__6 = k << 1; + i__7 = *nmax << 1; + i__8 = *nmax << 1; + smmch_("T", "N", &lj, &c__1, &i__6, & + alpha, &ab[jjab], &i__7, &w[1] + , &i__8, &beta, &c__[jj + j * + c_dim1], nmax, &ct[1], &g[1], + &cc[jc], &ldc, eps, &err, + fatal, nout, &c_true, (ftnlen) + 1, (ftnlen)1); + } else { + i__6 = k; + for (i__ = 1; i__ <= i__6; ++i__) { + w[i__] = ab[(k + i__ - 1) * *nmax + + j]; + w[k + i__] = ab[(i__ - 1) * *nmax + + j]; +/* L60: */ + } + i__6 = k << 1; + i__7 = *nmax << 1; + smmch_("N", "N", &lj, &c__1, &i__6, & + alpha, &ab[jj], nmax, &w[1], & + i__7, &beta, &c__[jj + j * + c_dim1], nmax, &ct[1], &g[1], + &cc[jc], &ldc, eps, &err, + fatal, nout, &c_true, (ftnlen) + 1, (ftnlen)1); + } + if (upper) { + jc += ldc; + } else { + jc = jc + ldc + 1; + if (tran) { + jjab += *nmax << 1; + } + } + errmax = dmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L140; + } +/* L70: */ + } + } + +/* L80: */ + } + +/* L90: */ + } + +/* L100: */ + } + +L110: + ; + } + +/* L120: */ + } + +L130: + ; + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + if (*iorder == 1) { + printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + } + goto L160; + +L140: + if (n > 1) { + printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j); + } + +L150: + printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + sprcn5_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &ldb, + &beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); + +L160: + return 0; + +/* 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ +/* $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', */ +/* $ ' .' ) */ + +/* End of SCHK5. */ + +} /* schk5_ */ + + +/* Subroutine */ void sprcn5_(nout, nc, sname, iorder, uplo, transa, n, k, + alpha, lda, ldb, beta, ldc, sname_len, uplo_len, transa_len) +integer *nout, *nc; +char *sname; +integer *iorder; +char *uplo, *transa; +integer *n, *k; +real *alpha; +integer *lda, *ldb; +real *beta; +integer *ldc; +ftnlen sname_len; +ftnlen uplo_len; +ftnlen transa_len; +{ + /* Builtin functions */ + integer s_wsfe(), do_fio(), e_wsfe(); + + /* Local variables */ + static char ca[14], cu[14], crc[14]; + + if (*(unsigned char *)uplo == 'U') { + s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)transa == 'N') { + s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transa == 'T') { + s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*iorder == 1) { + s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); + } else { + s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); + } + printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); + printf("%d %d %4.1f , A, %d, B, %d, %4.1f , C, %d.\n",*n,*k,*alpha,*lda,*ldb,*beta,*ldc); + +} /* sprcn5_ */ + + +/* Subroutine */ int smake_(type__, uplo, diag, m, n, a, nmax, aa, lda, reset, + transl, type_len, uplo_len, diag_len) +char *type__, *uplo, *diag; +integer *m, *n; +real *a; +integer *nmax; +real *aa; +integer *lda; +logical *reset; +real *transl; +ftnlen type_len; +ftnlen uplo_len; +ftnlen diag_len; +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Builtin functions */ + + /* Local variables */ + static integer ibeg, iend; + extern doublereal sbeg_(); + static logical unit; + static integer i__, j; + static logical lower, upper, gen, tri, sym; + + +/* Generates values for an M by N matrix A. */ +/* Stores the values in the array AA in the data structure required */ +/* by the routine, with unwanted elements set to rogue value. */ + +/* TYPE is 'GE', 'SY' or 'TR'. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. External Functions .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --aa; + + /* Function Body */ + gen = s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0; + sym = s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0; + tri = s_cmp(type__, "TR", (ftnlen)2, (ftnlen)2) == 0; + upper = (sym || tri) && *(unsigned char *)uplo == 'U'; + lower = (sym || tri) && *(unsigned char *)uplo == 'L'; + unit = tri && *(unsigned char *)diag == 'U'; + +/* Generate data in array A. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + if (gen || (upper && i__ <= j) || (lower && i__ >= j)) { + a[i__ + j * a_dim1] = sbeg_(reset) + *transl; + if (i__ != j) { +/* Set some elements to zero */ + if (*n > 3 && j == *n / 2) { + a[i__ + j * a_dim1] = (float)0.; + } + if (sym) { + a[j + i__ * a_dim1] = a[i__ + j * a_dim1]; + } else if (tri) { + a[j + i__ * a_dim1] = (float)0.; + } + } + } +/* L10: */ + } + if (tri) { + a[j + j * a_dim1] += (float)1.; + } + if (unit) { + a[j + j * a_dim1] = (float)1.; + } +/* L20: */ + } + +/* Store elements in array AS in data structure required by routine. */ + + if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + aa[i__ + (j - 1) * *lda] = a[i__ + j * a_dim1]; +/* L30: */ + } + i__2 = *lda; + for (i__ = *m + 1; i__ <= i__2; ++i__) { + aa[i__ + (j - 1) * *lda] = (float)-1e10; +/* L40: */ + } +/* L50: */ + } + } else if (s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__, + "TR", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (upper) { + ibeg = 1; + if (unit) { + iend = j - 1; + } else { + iend = j; + } + } else { + if (unit) { + ibeg = j + 1; + } else { + ibeg = j; + } + iend = *n; + } + i__2 = ibeg - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + aa[i__ + (j - 1) * *lda] = (float)-1e10; +/* L60: */ + } + i__2 = iend; + for (i__ = ibeg; i__ <= i__2; ++i__) { + aa[i__ + (j - 1) * *lda] = a[i__ + j * a_dim1]; +/* L70: */ + } + i__2 = *lda; + for (i__ = iend + 1; i__ <= i__2; ++i__) { + aa[i__ + (j - 1) * *lda] = (float)-1e10; +/* L80: */ + } +/* L90: */ + } + } + return 0; + +/* End of SMAKE. */ + +} /* smake_ */ + +/* Subroutine */ int smmch_(transa, transb, m, n, kk, alpha, a, lda, b, ldb, + beta, c__, ldc, ct, g, cc, ldcc, eps, err, fatal, nout, mv, + transa_len, transb_len) +char *transa, *transb; +integer *m, *n, *kk; +real *alpha, *a; +integer *lda; +real *b; +integer *ldb; +real *beta, *c__; +integer *ldc; +real *ct, *g, *cc; +integer *ldcc; +real *eps, *err; +logical *fatal; +integer *nout; +logical *mv; +ftnlen transa_len; +ftnlen transb_len; +{ + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, cc_dim1, + cc_offset, i__1, i__2, i__3; + real r__1, r__2; + + /* Builtin functions */ + double sqrt(); + integer s_wsfe(), e_wsfe(), do_fio(); + + /* Local variables */ + static real erri; + static integer i__, j, k; + static logical trana, tranb; + +/* Checks the results of the computational tests. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Intrinsic Functions .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --ct; + --g; + cc_dim1 = *ldcc; + cc_offset = 1 + cc_dim1 * 1; + cc -= cc_offset; + + /* Function Body */ + trana = *(unsigned char *)transa == 'T' || *(unsigned char *)transa == + 'C'; + tranb = *(unsigned char *)transb == 'T' || *(unsigned char *)transb == + 'C'; + +/* Compute expected result, one column at a time, in CT using data */ +/* in A, B and C. */ +/* Compute gauges in G. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + ct[i__] = (float)0.; + g[i__] = (float)0.; +/* L10: */ + } + if (! trana && ! tranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + ct[i__] += a[i__ + k * a_dim1] * b[k + j * b_dim1]; + g[i__] += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) * ( + r__2 = b[k + j * b_dim1], dabs(r__2)); +/* L20: */ + } +/* L30: */ + } + } else if (trana && ! tranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + ct[i__] += a[k + i__ * a_dim1] * b[k + j * b_dim1]; + g[i__] += (r__1 = a[k + i__ * a_dim1], dabs(r__1)) * ( + r__2 = b[k + j * b_dim1], dabs(r__2)); +/* L40: */ + } +/* L50: */ + } + } else if (! trana && tranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + ct[i__] += a[i__ + k * a_dim1] * b[j + k * b_dim1]; + g[i__] += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) * ( + r__2 = b[j + k * b_dim1], dabs(r__2)); +/* L60: */ + } +/* L70: */ + } + } else if (trana && tranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + ct[i__] += a[k + i__ * a_dim1] * b[j + k * b_dim1]; + g[i__] += (r__1 = a[k + i__ * a_dim1], dabs(r__1)) * ( + r__2 = b[j + k * b_dim1], dabs(r__2)); +/* L80: */ + } +/* L90: */ + } + } + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + ct[i__] = *alpha * ct[i__] + *beta * c__[i__ + j * c_dim1]; + g[i__] = dabs(*alpha) * g[i__] + dabs(*beta) * (r__1 = c__[i__ + + j * c_dim1], dabs(r__1)); +/* L100: */ + } + +/* Compute the error ratio for this result. */ + + *err = (float)0.; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + erri = (r__1 = ct[i__] - cc[i__ + j * cc_dim1], dabs(r__1)) / * + eps; + if (g[i__] != (float)0.) { + erri /= g[i__]; + } + *err = dmax(*err,erri); + if (*err * sqrt(*eps) >= (float)1.) { + goto L130; + } +/* L110: */ + } + +/* L120: */ + } + +/* If the loop completes, all results are at least half accurate. */ + goto L150; + +/* Report fatal error. */ + +L130: + *fatal = TRUE_; + printf(" ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HALF ACCURATE *******\n"); + printf(" EXPECTED RESULT COMPUTED RESULT\n"); + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*mv) { + printf("%7d %15.6g %15.6g\n",i__,ct[i__],cc[i__+j*cc_dim1]); + } else { + printf("%7d %15.6g %15.6g\n",i__,cc[i__+j*cc_dim1],ct[i__]); + } +/* L140: */ + } + if (*n > 1) { + printf(" THESE ARE THE RESULTS FOR COLUMN %d\n",j); + } + +L150: + return 0; + + +/* End of SMMCH. */ + +} /* smmch_ */ + +logical lse_(ri, rj, lr) +real *ri, *rj; +integer *lr; +{ + /* System generated locals */ + integer i__1; + logical ret_val; + + /* Local variables */ + static integer i__; + + +/* Tests if two arrays are identical. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + --rj; + --ri; + + /* Function Body */ + i__1 = *lr; + for (i__ = 1; i__ <= i__1; ++i__) { + if (ri[i__] != rj[i__]) { + goto L20; + } +/* L10: */ + } + ret_val = TRUE_; + goto L30; +L20: + ret_val = FALSE_; +L30: + return ret_val; + +/* End of LSE. */ + +} /* lse_ */ + +logical lseres_(type__, uplo, m, n, aa, as, lda, type_len, uplo_len) +char *type__, *uplo; +integer *m, *n; +real *aa, *as; +integer *lda; +ftnlen type_len; +ftnlen uplo_len; +{ + /* System generated locals */ + integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2; + logical ret_val; + + /* Builtin functions */ + + /* Local variables */ + static integer ibeg, iend, i__, j; + static logical upper; + + +/* Tests if selected elements in two arrays are equal. */ + +/* TYPE is 'GE' or 'SY'. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + as_dim1 = *lda; + as_offset = 1 + as_dim1 * 1; + as -= as_offset; + aa_dim1 = *lda; + aa_offset = 1 + aa_dim1 * 1; + aa -= aa_offset; + + /* Function Body */ + upper = *(unsigned char *)uplo == 'U'; + if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *lda; + for (i__ = *m + 1; i__ <= i__2; ++i__) { + if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) { + goto L70; + } +/* L10: */ + } +/* L20: */ + } + } else if (s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (upper) { + ibeg = 1; + iend = j; + } else { + ibeg = j; + iend = *n; + } + i__2 = ibeg - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) { + goto L70; + } +/* L30: */ + } + i__2 = *lda; + for (i__ = iend + 1; i__ <= i__2; ++i__) { + if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) { + goto L70; + } +/* L40: */ + } +/* L50: */ + } + } + +/* 60 CONTINUE */ + ret_val = TRUE_; + goto L80; +L70: + ret_val = FALSE_; +L80: + return ret_val; + +/* End of LSERES. */ + +} /* lseres_ */ + +doublereal sbeg_(reset) +logical *reset; +{ + /* System generated locals */ + real ret_val; + + /* Local variables */ + static integer i__, ic, mi; + + +/* 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 .. */ +/* .. Local Scalars .. */ +/* .. Save statement .. */ +/* .. Executable Statements .. */ + if (*reset) { +/* Initialize local variables. */ + mi = 891; + i__ = 7; + ic = 0; + *reset = FALSE_; + } + +/* The sequence of values of I is bounded between 1 and 999. */ +/* If initial I = 1,2,3,6,7 or 9, the period will be 50. */ +/* If initial I = 4 or 8, the period will be 25. */ +/* If initial I = 5, the period will be 10. */ +/* IC is used to break up the period by skipping 1 value of I in 6. */ + + ++ic; +L10: + i__ *= mi; + i__ -= i__ / 1000 * 1000; + if (ic >= 5) { + ic = 0; + goto L10; + } + ret_val = (i__ - 500) / (float)1001.; + return ret_val; + +/* End of SBEG. */ + +} /* sbeg_ */ + +doublereal sdiff_(x, y) +real *x, *y; +{ + /* System generated locals */ + real ret_val; + + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Scalar Arguments .. */ +/* .. Executable Statements .. */ + ret_val = *x - *y; + return ret_val; + +/* End of SDIFF. */ + +} /* sdiff_ */ + +/* Main program alias */ /*int sblat3_ () { MAIN__ (); }*/ diff --git a/ctest/c_zblat1c.c b/ctest/c_zblat1c.c new file mode 100644 index 000000000..d6c723ea7 --- /dev/null +++ b/ctest/c_zblat1c.c @@ -0,0 +1,1144 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif +#if 0 +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +#endif +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i= 6) { + check1_(&sfac); + } +/* -- Print */ + if (combla_1.pass) { + printf(" ----- PASS -----\n"); + } +/* L20: */ + } + exit(0); +} /* MAIN__ */ + +/* Subroutine */ int header_() +{ + /* Initialized data */ + + static char l[15][13] = { "CBLAS_ZDOTC " , "CBLAS_ZDOTU " , "CBLAS_ZAXPY " , + "CBLAS_ZCOPY " , "CBLAS_ZSWAP " , "CBLAS_DZNRM2" , "CBLAS_DZASUM" , + "CBLAS_ZSCAL " , "CBLAS_ZDSCAL" , "CBLAS_IZAMAX" }; + +/* .. Parameters .. */ +/* .. Scalars in Common .. */ +/* .. Local Arrays .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ +/* .. Executable Statements .. */ + printf("Test of subprogram number %3d %15s\n", combla_1.icase, l[combla_1.icase-1]); + return 0; + +} /* header_ */ + +/* Subroutine */ int check1_(sfac) +doublereal *sfac; +{ + /* Initialized data */ + + static doublereal strue2[5] = { 0.,.5,.6,.7,.7 }; + static doublereal strue4[5] = { 0.,.7,1.,1.3,1.7 }; + static doublecomplex ctrue5[80] /* was [8][5][2] */ = { {.1,.1},{1., + 2.},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{-.16,-.37},{ + 3.,4.},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{-.17,-.19} + ,{.13,-.39},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{.11, + -.03},{-.17,.46},{-.17,-.19},{7.,8.},{7.,8.},{7.,8.},{7.,8.},{7., + 8.},{.19,-.17},{.32,.09},{.23,-.24},{.18,.01},{2.,3.},{2.,3.},{2., + 3.},{2.,3.},{.1,.1},{4.,5.},{4.,5.},{4.,5.},{4.,5.},{4.,5.},{4., + 5.},{4.,5.},{-.16,-.37},{6.,7.},{6.,7.},{6.,7.},{6.,7.},{6.,7.},{ + 6.,7.},{6.,7.},{-.17,-.19},{8.,9.},{.13,-.39},{2.,5.},{2.,5.},{2., + 5.},{2.,5.},{2.,5.},{.11,-.03},{3.,6.},{-.17,.46},{4.,7.},{-.17, + -.19},{7.,2.},{7.,2.},{7.,2.},{.19,-.17},{5.,8.},{.32,.09},{6.,9.} + ,{.23,-.24},{8.,3.},{.18,.01},{9.,4.} }; + static doublecomplex ctrue6[80] /* was [8][5][2] */ = { {.1,.1},{1., + 2.},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{.09,-.12},{ + 3.,4.},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{.03,-.09}, + {.15,-.03},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{.03, + .03},{-.18,.03},{.03,-.09},{7.,8.},{7.,8.},{7.,8.},{7.,8.},{7.,8.} + ,{.09,.03},{.03,.12},{.12,.03},{.03,.06},{2.,3.},{2.,3.},{2.,3.},{ + 2.,3.},{.1,.1},{4.,5.},{4.,5.},{4.,5.},{4.,5.},{4.,5.},{4.,5.},{ + 4.,5.},{.09,-.12},{6.,7.},{6.,7.},{6.,7.},{6.,7.},{6.,7.},{6.,7.}, + {6.,7.},{.03,-.09},{8.,9.},{.15,-.03},{2.,5.},{2.,5.},{2.,5.},{2., + 5.},{2.,5.},{.03,.03},{3.,6.},{-.18,.03},{4.,7.},{.03,-.09},{7., + 2.},{7.,2.},{7.,2.},{.09,.03},{5.,8.},{.03,.12},{6.,9.},{.12,.03}, + {8.,3.},{.03,.06},{9.,4.} }; + static integer itrue3[5] = { 0,1,2,2,2 }; + static doublereal sa = .3; + static doublecomplex ca = {.4,-.7}; + static doublecomplex cv[80] /* was [8][5][2] */ = { {.1,.1},{1.,2.},{1., + 2.},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{.3,-.4},{3.,4.},{3., + 4.},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{.1,-.3},{.5,-.1},{5., + 6.},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{.1,.1},{-.6,.1},{.1, + -.3},{7.,8.},{7.,8.},{7.,8.},{7.,8.},{7.,8.},{.3,.1},{.1,.4},{.4, + .1},{.1,.2},{2.,3.},{2.,3.},{2.,3.},{2.,3.},{.1,.1},{4.,5.},{4., + 5.},{4.,5.},{4.,5.},{4.,5.},{4.,5.},{4.,5.},{.3,-.4},{6.,7.},{6., + 7.},{6.,7.},{6.,7.},{6.,7.},{6.,7.},{6.,7.},{.1,-.3},{8.,9.},{.5, + -.1},{2.,5.},{2.,5.},{2.,5.},{2.,5.},{2.,5.},{.1,.1},{3.,6.},{-.6, + .1},{4.,7.},{.1,-.3},{7.,2.},{7.,2.},{7.,2.},{.3,.1},{5.,8.},{.1, + .4},{6.,9.},{.4,.1},{8.,3.},{.1,.2},{9.,4.} }; + + /* System generated locals */ + integer i__1, i__2, i__3; + doublereal d__1; + doublecomplex z__1; + + /* Local variables */ + static integer i__; + extern /* Subroutine */ int ctest_(); + static doublecomplex mwpcs[5], mwpct[5]; + extern /* Subroutine */ int zscaltest_(), itest1_(), stest1_(); + static doublecomplex cx[8]; + extern doublereal dznrm2test_(); + static integer np1; + extern /* Subroutine */ int zdscaltest_(); + extern integer izamaxtest_(); + extern doublereal dzasumtest_(); + static integer len; + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Scalars in Common .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ +/* .. Executable Statements .. */ + for (combla_1.incx = 1; combla_1.incx <= 2; ++combla_1.incx) { + for (np1 = 1; np1 <= 5; ++np1) { + combla_1.n = np1 - 1; + len = f2cmax(combla_1.n,1) << 1; +/* .. Set vector arguments .. */ + i__1 = len; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ - 1; + i__3 = i__ + (np1 + combla_1.incx * 5 << 3) - 49; + cx[i__2].r = cv[i__3].r, cx[i__2].i = cv[i__3].i; +/* L20: */ + } + if (combla_1.icase == 6) { +/* .. DZNRM2TEST .. */ + d__1 = dznrm2test_(&combla_1.n, cx, &combla_1.incx); + stest1_(&d__1, &strue2[np1 - 1], &strue2[np1 - 1], sfac); + } else if (combla_1.icase == 7) { +/* .. DZASUMTEST .. */ + d__1 = dzasumtest_(&combla_1.n, cx, &combla_1.incx); + stest1_(&d__1, &strue4[np1 - 1], &strue4[np1 - 1], sfac); + } else if (combla_1.icase == 8) { +/* .. ZSCALTEST .. */ + zscaltest_(&combla_1.n, &ca, cx, &combla_1.incx); + ctest_(&len, cx, &ctrue5[(np1 + combla_1.incx * 5 << 3) - 48], + &ctrue5[(np1 + combla_1.incx * 5 << 3) - 48], sfac); + } else if (combla_1.icase == 9) { +/* .. ZDSCALTEST .. */ + zdscaltest_(&combla_1.n, &sa, cx, &combla_1.incx); + ctest_(&len, cx, &ctrue6[(np1 + combla_1.incx * 5 << 3) - 48], + &ctrue6[(np1 + combla_1.incx * 5 << 3) - 48], sfac); + } else if (combla_1.icase == 10) { +/* .. IZAMAXTEST .. */ + i__1 = izamaxtest_(&combla_1.n, cx, &combla_1.incx); + itest1_(&i__1, &itrue3[np1 - 1]); + } else { + fprintf(stderr,"Shouldn't be here in CHECK1\n"); + exit(0); + } + +/* L40: */ + } +/* L60: */ + } + + combla_1.incx = 1; + if (combla_1.icase == 8) { +/* ZSCALTEST */ +/* Add a test for alpha equal to zero. */ + ca.r = 0., ca.i = 0.; + for (i__ = 1; i__ <= 5; ++i__) { + i__1 = i__ - 1; + mwpct[i__1].r = 0., mwpct[i__1].i = 0.; + i__1 = i__ - 1; + mwpcs[i__1].r = 1., mwpcs[i__1].i = 1.; +/* L80: */ + } + zscaltest_(&c__5, &ca, cx, &combla_1.incx); + ctest_(&c__5, cx, mwpct, mwpcs, sfac); + } else if (combla_1.icase == 9) { +/* ZDSCALTEST */ +/* Add a test for alpha equal to zero. */ + sa = 0.; + for (i__ = 1; i__ <= 5; ++i__) { + i__1 = i__ - 1; + mwpct[i__1].r = 0., mwpct[i__1].i = 0.; + i__1 = i__ - 1; + mwpcs[i__1].r = 1., mwpcs[i__1].i = 1.; +/* L100: */ + } + zdscaltest_(&c__5, &sa, cx, &combla_1.incx); + ctest_(&c__5, cx, mwpct, mwpcs, sfac); +/* Add a test for alpha equal to one. */ + sa = 1.; + for (i__ = 1; i__ <= 5; ++i__) { + i__1 = i__ - 1; + i__2 = i__ - 1; + mwpct[i__1].r = cx[i__2].r, mwpct[i__1].i = cx[i__2].i; + i__1 = i__ - 1; + i__2 = i__ - 1; + mwpcs[i__1].r = cx[i__2].r, mwpcs[i__1].i = cx[i__2].i; +/* L120: */ + } + zdscaltest_(&c__5, &sa, cx, &combla_1.incx); + ctest_(&c__5, cx, mwpct, mwpcs, sfac); +/* Add a test for alpha equal to minus one. */ + sa = -1.; + for (i__ = 1; i__ <= 5; ++i__) { + i__1 = i__ - 1; + i__2 = i__ - 1; + z__1.r = -cx[i__2].r, z__1.i = -cx[i__2].i; + mwpct[i__1].r = z__1.r, mwpct[i__1].i = z__1.i; + i__1 = i__ - 1; + i__2 = i__ - 1; + z__1.r = -cx[i__2].r, z__1.i = -cx[i__2].i; + mwpcs[i__1].r = z__1.r, mwpcs[i__1].i = z__1.i; +/* L140: */ + } + zdscaltest_(&c__5, &sa, cx, &combla_1.incx); + ctest_(&c__5, cx, mwpct, mwpcs, sfac); + } + return 0; +} /* check1_ */ + +/* Subroutine */ int check2_(sfac) +doublereal *sfac; +{ + /* Initialized data */ + + static doublecomplex ca = {.4,-.7}; + static integer incxs[4] = { 1,2,-2,-1 }; + static integer incys[4] = { 1,-2,1,-2 }; + static integer lens[8] /* was [4][2] */ = { 1,1,2,4,1,1,3,7 }; + static integer ns[4] = { 0,1,2,4 }; + static doublecomplex cx1[7] = { {.7,-.8},{-.4,-.7},{-.1,-.9},{.2,-.8},{ + -.9,-.4},{.1,.4},{-.6,.6} }; + static doublecomplex cy1[7] = { {.6,-.6},{-.9,.5},{.7,-.6},{.1,-.5},{-.1, + -.2},{-.5,-.3},{.8,-.7} }; + static doublecomplex ct8[112] /* was [7][4][4] */ = { {.6,-.6},{0., + 0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.32,-1.41},{0.,0.},{ + 0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.32,-1.41},{-1.55,.5},{0., + 0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.32,-1.41},{-1.55,.5},{.03, + -.89},{-.38,-.96},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{0.,0.},{0.,0.} + ,{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.32,-1.41},{0.,0.},{0.,0.},{0., + 0.},{0.,0.},{0.,0.},{0.,0.},{-.07,-.89},{-.9,.5},{.42,-1.41},{0., + 0.},{0.,0.},{0.,0.},{0.,0.},{.78,.06},{-.9,.5},{.06,-.13},{.1,-.5} + ,{-.77,-.49},{-.5,-.3},{.52,-1.51},{.6,-.6},{0.,0.},{0.,0.},{0., + 0.},{0.,0.},{0.,0.},{0.,0.},{.32,-1.41},{0.,0.},{0.,0.},{0.,0.},{ + 0.,0.},{0.,0.},{0.,0.},{-.07,-.89},{-1.18,-.31},{0.,0.},{0.,0.},{ + 0.,0.},{0.,0.},{0.,0.},{.78,.06},{-1.54,.97},{.03,-.89},{-.18, + -1.31},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{0.,0.},{0.,0.},{0.,0.},{ + 0.,0.},{0.,0.},{0.,0.},{.32,-1.41},{0.,0.},{0.,0.},{0.,0.},{0.,0.} + ,{0.,0.},{0.,0.},{.32,-1.41},{-.9,.5},{.05,-.6},{0.,0.},{0.,0.},{ + 0.,0.},{0.,0.},{.32,-1.41},{-.9,.5},{.05,-.6},{.1,-.5},{-.77,-.49} + ,{-.5,-.3},{.32,-1.16} }; + static doublecomplex ct7[16] /* was [4][4] */ = { {0.,0.},{-.06, + -.9},{.65,-.47},{-.34,-1.22},{0.,0.},{-.06,-.9},{-.59,-1.46},{ + -1.04,-.04},{0.,0.},{-.06,-.9},{-.83,.59},{.07,-.37},{0.,0.},{ + -.06,-.9},{-.76,-1.15},{-1.33,-1.82} }; + static doublecomplex ct6[16] /* was [4][4] */ = { {0.,0.},{.9,.06}, + {.91,-.77},{1.8,-.1},{0.,0.},{.9,.06},{1.45,.74},{.2,.9},{0.,0.},{ + .9,.06},{-.55,.23},{.83,-.39},{0.,0.},{.9,.06},{1.04,.79},{1.95, + 1.22} }; + static doublecomplex ct10x[112] /* was [7][4][4] */ = { {.7,-.8},{0., + 0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{0.,0.},{0., + 0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{-.9,.5},{0.,0.},{0., + 0.},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{-.9,.5},{.7,-.6},{.1,-.5},{ + 0.,0.},{0.,0.},{0.,0.},{.7,-.8},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{ + 0.,0.},{0.,0.},{.6,-.6},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{ + 0.,0.},{.7,-.6},{-.4,-.7},{.6,-.6},{0.,0.},{0.,0.},{0.,0.},{0.,0.} + ,{.8,-.7},{-.4,-.7},{-.1,-.2},{.2,-.8},{.7,-.6},{.1,.4},{.6,-.6},{ + .7,-.8},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{ + 0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{-.9,.5},{-.4,-.7}, + {.6,-.6},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.1,-.5},{-.4,-.7},{.7, + -.6},{.2,-.8},{-.9,.5},{.1,.4},{.6,-.6},{.7,-.8},{0.,0.},{0.,0.},{ + 0.,0.},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{0.,0.},{0.,0.},{0.,0.},{ + 0.,0.},{0.,0.},{0.,0.},{.6,-.6},{.7,-.6},{0.,0.},{0.,0.},{0.,0.},{ + 0.,0.},{0.,0.},{.6,-.6},{.7,-.6},{-.1,-.2},{.8,-.7},{0.,0.},{0., + 0.},{0.,0.} }; + static doublecomplex ct10y[112] /* was [7][4][4] */ = { {.6,-.6},{0., + 0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.7,-.8},{0.,0.},{0., + 0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.7,-.8},{-.4,-.7},{0.,0.},{ + 0.,0.},{0.,0.},{0.,0.},{0.,0.},{.7,-.8},{-.4,-.7},{-.1,-.9},{.2, + -.8},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{0.,0.},{0.,0.},{0.,0.},{0., + 0.},{0.,0.},{0.,0.},{.7,-.8},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0., + 0.},{0.,0.},{-.1,-.9},{-.9,.5},{.7,-.8},{0.,0.},{0.,0.},{0.,0.},{ + 0.,0.},{-.6,.6},{-.9,.5},{-.9,-.4},{.1,-.5},{-.1,-.9},{-.5,-.3},{ + .7,-.8},{.6,-.6},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{ + .7,-.8},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{-.1,-.9}, + {.7,-.8},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{-.6,.6},{-.9, + -.4},{-.1,-.9},{.7,-.8},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{0.,0.},{ + 0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.7,-.8},{0.,0.},{0.,0.},{ + 0.,0.},{0.,0.},{0.,0.},{0.,0.},{.7,-.8},{-.9,.5},{-.4,-.7},{0.,0.} + ,{0.,0.},{0.,0.},{0.,0.},{.7,-.8},{-.9,.5},{-.4,-.7},{.1,-.5},{ + -.1,-.9},{-.5,-.3},{.2,-.8} }; + static doublecomplex csize1[4] = { {0.,0.},{.9,.9},{1.63,1.73},{2.9,2.78} + }; + static doublecomplex csize3[14] = { {0.,0.},{0.,0.},{0.,0.},{0.,0.},{0., + 0.},{0.,0.},{0.,0.},{1.17,1.17},{1.17,1.17},{1.17,1.17},{1.17, + 1.17},{1.17,1.17},{1.17,1.17},{1.17,1.17} }; + static doublecomplex csize2[14] /* was [7][2] */ = { {0.,0.},{0.,0.},{ + 0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{1.54,1.54},{1.54,1.54},{ + 1.54,1.54},{1.54,1.54},{1.54,1.54},{1.54,1.54},{1.54,1.54} }; + + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + static doublecomplex cdot[1]; + static integer lenx, leny, i__; + extern /* Subroutine */ int ctest_(); + static integer ksize; + static doublecomplex ztemp; + extern /* Subroutine */ int zdotctest_(), zcopytest_(); + static integer ki; + extern /* Subroutine */ int zdotutest_(), zswaptest_(); + static integer kn; + extern /* Subroutine */ int zaxpytest_(); + static doublecomplex cx[7], cy[7]; + static integer mx, my; + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Scalars in Common .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ +/* .. Executable Statements .. */ + for (ki = 1; ki <= 4; ++ki) { + combla_1.incx = incxs[ki - 1]; + combla_1.incy = incys[ki - 1]; + mx = abs(combla_1.incx); + my = abs(combla_1.incy); + + for (kn = 1; kn <= 4; ++kn) { + combla_1.n = ns[kn - 1]; + ksize = f2cmin(2,kn); + lenx = lens[kn + (mx << 2) - 5]; + leny = lens[kn + (my << 2) - 5]; +/* .. initialize all argument arrays .. */ + for (i__ = 1; i__ <= 7; ++i__) { + i__1 = i__ - 1; + i__2 = i__ - 1; + cx[i__1].r = cx1[i__2].r, cx[i__1].i = cx1[i__2].i; + i__1 = i__ - 1; + i__2 = i__ - 1; + cy[i__1].r = cy1[i__2].r, cy[i__1].i = cy1[i__2].i; +/* L20: */ + } + if (combla_1.icase == 1) { +/* .. ZDOTCTEST .. */ + zdotctest_(&combla_1.n, cx, &combla_1.incx, cy, & + combla_1.incy, &ztemp); + cdot[0].r = ztemp.r, cdot[0].i = ztemp.i; + ctest_(&c__1, cdot, &ct6[kn + (ki << 2) - 5], &csize1[kn - 1], + sfac); + } else if (combla_1.icase == 2) { +/* .. ZDOTUTEST .. */ + zdotutest_(&combla_1.n, cx, &combla_1.incx, cy, & + combla_1.incy, &ztemp); + cdot[0].r = ztemp.r, cdot[0].i = ztemp.i; + ctest_(&c__1, cdot, &ct7[kn + (ki << 2) - 5], &csize1[kn - 1], + sfac); + } else if (combla_1.icase == 3) { +/* .. ZAXPYTEST .. */ + zaxpytest_(&combla_1.n, &ca, cx, &combla_1.incx, cy, & + combla_1.incy); + ctest_(&leny, cy, &ct8[(kn + (ki << 2)) * 7 - 35], &csize2[ + ksize * 7 - 7], sfac); + } else if (combla_1.icase == 4) { +/* .. ZCOPYTEST .. */ + zcopytest_(&combla_1.n, cx, &combla_1.incx, cy, & + combla_1.incy); + ctest_(&leny, cy, &ct10y[(kn + (ki << 2)) * 7 - 35], csize3, & + c_b43); + } else if (combla_1.icase == 5) { +/* .. ZSWAPTEST .. */ + zswaptest_(&combla_1.n, cx, &combla_1.incx, cy, & + combla_1.incy); + ctest_(&lenx, cx, &ct10x[(kn + (ki << 2)) * 7 - 35], csize3, & + c_b43); + ctest_(&leny, cy, &ct10y[(kn + (ki << 2)) * 7 - 35], csize3, & + c_b43); + } else { + fprintf(stderr,"Shouldn't be here in CHECK2\n"); + exit(0); + } + +/* L40: */ + } +/* L60: */ + } + return 0; +} /* check2_ */ + +/* Subroutine */ int stest_(len, scomp, strue, ssize, sfac) +integer *len; +doublereal *scomp, *strue, *ssize, *sfac; +{ + /* System generated locals */ + integer i__1; + doublereal d__1, d__2, d__3, d__4, d__5; + + /* Builtin functions */ + integer s_wsfe(), e_wsfe(), do_fio(); + + /* Local variables */ + static integer i__; + extern doublereal sdiff_(); + static doublereal sd; + +/* ********************************* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Scalars in Common .. */ +/* .. Local Scalars .. */ +/* .. External Functions .. */ +/* .. Intrinsic Functions .. */ +/* .. Common blocks .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --ssize; + --strue; + --scomp; + + /* Function Body */ + i__1 = *len; + for (i__ = 1; i__ <= i__1; ++i__) { + sd = scomp[i__] - strue[i__]; + d__4 = (d__1 = ssize[i__], abs(d__1)) + (d__2 = *sfac * sd, abs(d__2)) + ; + d__5 = (d__3 = ssize[i__], abs(d__3)); + if (sdiff_(&d__4, &d__5) == 0.) { + goto L40; + } + +/* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I). */ + + if (! combla_1.pass) { + goto L20; + } +/* PRINT FAIL MESSAGE AND HEADER. */ + combla_1.pass = FALSE_; + printf(" FAIL\n"); + printf("CASE N INCX INCY MODE I COMP(I) TRUE(I) DIFFERENCE SIZE(I)\n"); +L20: + printf("%4d %3d %5d %5d %5d %3d %36.8f %36.8f %12.4f %12.4f\n",combla_1.icase, combla_1.n, combla_1.incx, combla_1.incy, + combla_1.mode, i__, scomp[i__], strue[i__], sd, ssize[i__]); +L40: + ; + } + return 0; + +} /* stest_ */ + +/* Subroutine */ int stest1_(scomp1, strue1, ssize, sfac) +doublereal *scomp1, *strue1, *ssize, *sfac; +{ + static doublereal scomp[1], strue[1]; + extern /* Subroutine */ int stest_(); + +/* ************************* STEST1 ***************************** */ + +/* THIS IS AN INTERFACE SUBROUTINE TO ACCOMMODATE 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 .. */ +/* .. Array Arguments .. */ +/* .. Local Arrays .. */ +/* .. External Subroutines .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --ssize; + + /* Function Body */ + scomp[0] = *scomp1; + strue[0] = *strue1; + stest_(&c__1, scomp, strue, &ssize[1], sfac); + + return 0; +} /* stest1_ */ + +doublereal sdiff_(sa, sb) +doublereal *sa, *sb; +{ + /* System generated locals */ + doublereal ret_val; + +/* ********************************* SDIFF ************************** */ +/* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15 */ + +/* .. Scalar Arguments .. */ +/* .. Executable Statements .. */ + ret_val = *sa - *sb; + return ret_val; +} /* sdiff_ */ + +/* Subroutine */ int ctest_(len, ccomp, ctrue, csize, sfac) +integer *len; +doublecomplex *ccomp, *ctrue, *csize; +doublereal *sfac; +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + static integer i__; + static doublereal scomp[20], ssize[20], strue[20]; + extern /* Subroutine */ int stest_(); + +/* **************************** CTEST ***************************** */ + +/* C.L. LAWSON, JPL, 1978 DEC 6 */ + +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + --csize; + --ctrue; + --ccomp; + + /* Function Body */ + i__1 = *len; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + scomp[(i__ << 1) - 2] = ccomp[i__2].r; + scomp[(i__ << 1) - 1] = d_imag(&ccomp[i__]); + i__2 = i__; + strue[(i__ << 1) - 2] = ctrue[i__2].r; + strue[(i__ << 1) - 1] = d_imag(&ctrue[i__]); + i__2 = i__; + ssize[(i__ << 1) - 2] = csize[i__2].r; + ssize[(i__ << 1) - 1] = d_imag(&csize[i__]); +/* L20: */ + } + + i__1 = *len << 1; + stest_(&i__1, scomp, strue, ssize, sfac); + return 0; +} /* ctest_ */ + +/* Subroutine */ int itest1_(icomp, itrue) +integer *icomp, *itrue; +{ + static integer id; + +/* ********************************* ITEST1 ************************* */ + +/* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR */ +/* EQUALITY. */ +/* C. L. LAWSON, JPL, 1974 DEC 10 */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Scalars in Common .. */ +/* .. Local Scalars .. */ +/* .. Common blocks .. */ +/* .. Executable Statements .. */ + if (*icomp == *itrue) { + goto L40; + } + +/* HERE ICOMP IS NOT EQUAL TO ITRUE. */ + + if (! combla_1.pass) { + goto L20; + } +/* PRINT FAIL MESSAGE AND HEADER. */ + combla_1.pass = FALSE_; + printf(" FAIL\n"); + printf("CASE N INCX INCY MODE COMP TRUE DIFFERENCE\n"); +L20: + id = *icomp - *itrue; + printf("%4d %3d %5d %5d %5d %36d %36d %12d\n",combla_1.icase, combla_1.n, combla_1.incx, combla_1.incy, + combla_1.mode, *icomp, *itrue, id); +L40: + return 0; + +} /* itest1_ */ + diff --git a/ctest/c_zblat2c.c b/ctest/c_zblat2c.c new file mode 100644 index 000000000..363591910 --- /dev/null +++ b/ctest/c_zblat2c.c @@ -0,0 +1,4471 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif +#if 0 +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +#endif +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i= 0; + if (trace) { +/* o__1.oerr = 0; + o__1.ounit = ntra; + o__1.ofnmlen = 32; + o__1.ofnm = snaps; + o__1.orl = 0; + o__1.osta = 0; + o__1.oacc = 0; + o__1.ofm = 0; + o__1.oblnk = 0; + f_open(&o__1);*/ + } +/* Read the flag that directs rewinding of the snapshot file. */ + fgets(line,80,stdin); + sscanf(line,"%d",&rewi); + rewi = rewi && trace; +/* Read the flag that directs stopping on any failure. */ + fgets(line,80,stdin); + sscanf(line,"%c",&tmpchar); +/* Read the flag that indicates whether error exits are to be tested. */ + sfatal=FALSE_; + if (tmpchar=='T')sfatal=TRUE_; + fgets(line,80,stdin); + sscanf(line,"%c",&tmpchar); +/* Read the flag that indicates whether error exits are to be tested. */ + tsterr=FALSE_; + if (tmpchar=='T')tsterr=TRUE_; +/* Read the flag that indicates whether row-major data layout to be tested. */ + fgets(line,80,stdin); + sscanf(line,"%d",&layout); +/* Read the threshold value of the test ratio */ + fgets(line,80,stdin); + sscanf(line,"%lf",&thresh); + +/* Read and check the parameter values for the tests. */ + +/* Values of N */ + fgets(line,80,stdin); + sscanf(line,"%d",&nidim); + + if (nidim < 1 || nidim > 9) { + fprintf(stderr,"NUMBER OF VALUES OF N IS LESS THAN 1 OR GREATER THAN 9"); + goto L230; + } + fgets(line,80,stdin); + sscanf(line,"%d %d %d %d %d %d %d %d %d",&idim[0],&idim[1],&idim[2], + &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]); + i__1 = nidim; + for (i__ = 1; i__ <= i__1; ++i__) { + if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) { + fprintf(stderr,"VALUE OF N IS LESS THAN 0 OR GREATER THAN 65\n"); + goto L230; + } +/* L10: */ + } +/* Values of K */ + fgets(line,80,stdin); + sscanf(line,"%d",&nkb); + + if (nkb < 1 || nkb > 7) { + fprintf(stderr,"NUMBER OF VALUES OF K IS LESS THAN 1 OR GREATER THAN 7"); + goto L230; + } + fgets(line,80,stdin); + sscanf(line,"%d %d %d %d %d %d %d",&kb[0],&kb[1],&kb[2],&kb[3],&kb[4],&kb[5],&kb[6]); + i__1 = nkb; + for (i__ = 1; i__ <= i__1; ++i__) { + if (kb[i__ - 1] < 0 ) { + fprintf(stderr,"VALUE OF K IS LESS THAN 0\n"); + goto L230; + } +/* L20: */ + } +/* Values of INCX and INCY */ + fgets(line,80,stdin); + sscanf(line,"%d",&ninc); + + if (ninc < 1 || ninc > 7) { + fprintf(stderr,"NUMBER OF VALUES OF INCX AND INCY IS LESS THAN 1 OR GREATER THAN 7"); + goto L230; + } + + fgets(line,80,stdin); + sscanf(line,"%d %d %d %d %d %d %d",&inc[0],&inc[1],&inc[2],&inc[3],&inc[4],&inc[5],&inc[6]); + i__1 = ninc; + for (i__ = 1; i__ <= i__1; ++i__) { + if (inc[i__ - 1] == 0 || (i__2 = inc[i__ - 1], abs(i__2)) > 2) { + fprintf (stderr,"ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN 2\n"); + goto L230; + } +/* L30: */ + } +/* Values of ALPHA */ + fgets(line,80,stdin); + sscanf(line,"%d",&nalf); + if (nalf < 1 || nalf > 7) { + fprintf(stderr,"VALUE OF ALPHA IS LESS THAN 0 OR GREATER THAN 7\n"); + goto L230; + } + fgets(line,80,stdin); + sscanf(line,"(%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf)",&alf[0].r,&alf[0].i,&alf[1].r,&alf[1].i,&alf[2].r,&alf[2].i,&alf[3].r,&alf[3].i, + &alf[4].r,&alf[4].i,&alf[5].r,&alf[5].i,&alf[6].r,&alf[6].i); + +/* Values of BETA */ + fgets(line,80,stdin); + sscanf(line,"%d",&nbet); + if (nbet < 1 || nbet > 7) { + fprintf(stderr,"VALUE OF BETA IS LESS THAN 0 OR GREATER THAN 7\n"); + goto L230; + } + fgets(line,80,stdin); + sscanf(line,"(%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf)",&bet[0].r,&bet[0].i,&bet[1].r,&bet[1].i,&bet[2].r,&bet[2].i,&bet[3].r,&bet[3].i, + &bet[4].r,&bet[4].i,&bet[5].r,&bet[5].i,&bet[6].r,&bet[6].i); + +/* Report values of parameters. */ + printf("TESTS OF THE DOUBLE PRECISION COMPLEX LEVEL 2 BLAS\nTHE FOLLOWING PARAMETER VALUES WILL BE USED:\n"); + printf(" FOR N"); + for (i__ =1; i__ <=nidim;++i__) printf(" %d",idim[i__-1]); + printf("\n"); + + printf(" FOR K"); + for (i__ =1; i__ <=nkb;++i__) printf(" %d",kb[i__-1]); + printf("\n"); + + printf(" FOR INCX AND INCY"); + for (i__ =1; i__ <=ninc;++i__) printf(" %d",inc[i__-1]); + printf("\n"); + + printf(" FOR ALPHA"); + for (i__ =1; i__ <=nalf;++i__) printf(" (%f,%f)",alf[i__-1].r,alf[i__-1].i); + printf("\n"); + printf(" FOR BETA"); + for (i__ =1; i__ <=nbet;++i__) printf(" (%f,%f)",bet[i__-1].r,bet[i__-1].i); + printf("\n"); + + if (! tsterr) { + printf(" ERROR-EXITS WILL NOT BE TESTED\n"); + } + printf("ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LESS THAN %f\n",thresh); + + rorder = FALSE_; + corder = FALSE_; + if (layout == 2) { + rorder = TRUE_; + corder = TRUE_; + printf("COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED\n"); + } else if (layout == 1) { + rorder = TRUE_; + printf("ROW-MAJOR DATA LAYOUT IS TESTED\n"); + } else if (layout == 0) { + corder = TRUE_; + printf("COLUMN-MAJOR DATA LAYOUT IS TESTED\n"); + } + +/* Read names of subroutines and flags which indicate */ +/* whether they are to be tested. */ + + for (i__ = 1; i__ <= 17; ++i__) { + ltest[i__ - 1] = FALSE_; +/* L40: */ + } +L50: + if (! fgets(line,80,stdin)) { + goto L80; + } + i__1 = sscanf(line,"%12c %c",snamet,&tmpchar); + ltestt=FALSE_; + if (tmpchar=='T')ltestt=TRUE_; + if (i__1 < 2) { + goto L80; + } + for (i__ = 1; i__ <= 17; ++i__) { + if (s_cmp(snamet, snames[i__ - 1], (ftnlen)12, (ftnlen)12) == + 0) { + goto L70; + } +/* L60: */ + } + printf("SUBPROGRAM NAME %s NOT RECOGNIZED\n****** TESTS ABANDONED ******\n",snamet); + exit(1); +L70: + ltest[i__ - 1] = ltestt; + goto L50; + +L80: +/* cl__1.cerr = 0; + cl__1.cunit = 5; + cl__1.csta = 0; + f_clos(&cl__1);*/ + +/* Compute EPS (the machine precision). */ + + eps = 1.; +L90: + d__1 = eps + 1.; + if (ddiff_(&d__1, &c_b125) == 0.) { + goto L100; + } + eps *= .5; + goto L90; +L100: + eps += eps; + printf("RELATIVE MACHINE PRECISION IS TAKEN TO BE %9.1g\n",eps); + +/* Check the reliability of ZMVCH using exact data. */ + + n = 32; + i__1 = n; + for (j = 1; j <= i__1; ++j) { + i__2 = n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * 65 - 66; +/* Computing MAX */ + i__5 = i__ - j + 1; + i__4 = f2cmax(i__5,0); + a[i__3].r = (doublereal) i__4, a[i__3].i = 0.; +/* L110: */ + } + i__2 = j - 1; + x[i__2].r = (doublereal) j, x[i__2].i = 0.; + i__2 = j - 1; + y[i__2].r = 0., y[i__2].i = 0.; +/* L120: */ + } + i__1 = n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + i__3 = j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3; + yy[i__2].r = (doublereal) i__3, yy[i__2].i = 0.; +/* L130: */ + } +/* YY holds the exact result. On exit from CMVCH YT holds */ +/* the result computed by CMVCH. */ + *(unsigned char *)trans = 'N'; + zmvch_(trans, &n, &n, &c_b2, a, &c__65, x, &c__1, &c_b1, y, &c__1, yt, g, + yy, &eps, &err, &fatal, &c__6, &c_true, (ftnlen)1); + same = lze_(yy, yt, &n); + if (! same || err != (float)0.) { + printf("ERROR IN ZMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); + printf("ZMVCH WAS CALLED WITH TRANS = %s ", trans); + printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); + printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); + printf("****** TESTS ABANDONED ******\n"); + exit(1); + } + *(unsigned char *)trans = 'T'; + zmvch_(trans, &n, &n, &c_b2, a, &c__65, x, &c_n1, &c_b1, y, &c_n1, yt, g, + yy, &eps, &err, &fatal, &c__6, &c_true, (ftnlen)1); + same = lze_(yy, yt, &n); + if (! same || err != 0.) { + printf("ERROR IN ZMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); + printf("ZMVCH WAS CALLED WITH TRANS = %s ", trans); + printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); + printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); + printf("****** TESTS ABANDONED ******\n"); + exit(1); + } + +/* Test each subroutine in turn. */ + + for (isnum = 1; isnum <= 17; ++isnum) { + if (! ltest[isnum - 1]) { +/* Subprogram is not to be tested. */ + printf("%12s WAS NOT TESTED\n",snames[isnum-1]); + } else { + s_copy(srnamc_1.srnamt, snames[isnum - 1], (ftnlen)12, ( + ftnlen)12); +/* Test error exits. */ + if (tsterr) { + cz2chke_(snames[isnum - 1], (ftnlen)12); + } +/* Test computations. */ + infoc_1.infot = 0; + infoc_1.ok = TRUE_; + fatal = FALSE_; + switch ((int)isnum) { + case 1: goto L140; + case 2: goto L140; + case 3: goto L150; + case 4: goto L150; + case 5: goto L150; + case 6: goto L160; + case 7: goto L160; + case 8: goto L160; + case 9: goto L160; + case 10: goto L160; + case 11: goto L160; + case 12: goto L170; + case 13: goto L170; + case 14: goto L180; + case 15: goto L180; + case 16: goto L190; + case 17: goto L190; + } +/* Test ZGEMV, 01, and ZGBMV, 02. */ +L140: + if (corder) { + zchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, + alf, &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, + as, x, xx, xs, y, yy, ys, yt, g, &c__0, (ftnlen)12); + } + if (rorder) { + zchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, + alf, &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, + as, x, xx, xs, y, yy, ys, yt, g, &c__1, (ftnlen)12); + } + goto L200; +/* Test ZHEMV, 03, ZHBMV, 04, and ZHPMV, 05. */ +L150: + if (corder) { + zchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, + alf, &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, + as, x, xx, xs, y, yy, ys, yt, g, &c__0, (ftnlen)12); + } + if (rorder) { + zchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, + alf, &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, + as, x, xx, xs, y, yy, ys, yt, g, &c__1, (ftnlen)12); + } + goto L200; +/* Test ZTRMV, 06, ZTBMV, 07, ZTPMV, 08, */ +/* ZTRSV, 09, ZTBSV, 10, and ZTPSV, 11. */ +L160: + if (corder) { + zchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &ninc, + inc, &c__65, &c__2, a, aa, as, y, yy, ys, yt, g, z__, + &c__0, (ftnlen)12); + } + if (rorder) { + zchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &ninc, + inc, &c__65, &c__2, a, aa, as, y, yy, ys, yt, g, z__, + &c__1, (ftnlen)12); + } + goto L200; +/* Test ZGERC, 12, ZGERU, 13. */ +L170: + if (corder) { + zchk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, + ys, yt, g, z__, &c__0, (ftnlen)12); + } + if (rorder) { + zchk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, + ys, yt, g, z__, &c__1, (ftnlen)12); + } + goto L200; +/* Test ZHER, 14, and ZHPR, 15. */ +L180: + if (corder) { + zchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, + ys, yt, g, z__, &c__0, (ftnlen)12); + } + if (rorder) { + zchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, + ys, yt, g, z__, &c__1, (ftnlen)12); + } + goto L200; +/* Test ZHER2, 16, and ZHPR2, 17. */ +L190: + if (corder) { + zchk6_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, + ys, yt, g, z__, &c__0, (ftnlen)12); + } + if (rorder) { + zchk6_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, + ys, yt, g, z__, &c__1, (ftnlen)12); + } + +L200: + if (fatal && sfatal) { + goto L220; + } + } +/* L210: */ + } + printf("\nEND OF TESTS\n"); + goto L240; + +L220: + printf("\n****** FATAL ERROR - TESTS ABANDONED ******\n"); + goto L240; + +L230: + printf("AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM\n"); + printf("****** TESTS ABANDONED ******\n"); + +L240: + if (trace) { +/* cl__1.cerr = 0; + cl__1.cunit = ntra; + cl__1.csta = 0; + f_clos(&cl__1);*/ + } +/* cl__1.cerr = 0; + cl__1.cunit = 6; + cl__1.csta = 0; + f_clos(&cl__1);*/ + exit(0); + + +/* End of ZBLAT2. */ + +} /* MAIN__ */ + +/* Subroutine */ int 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, sname_len) +char *sname; +doublereal *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nkb, *kb, *nalf; +doublecomplex *alf; +integer *nbet; +doublecomplex *bet; +integer *ninc, *inc, *nmax, *incmax; +doublecomplex *a, *aa, *as, *x, *xx, *xs, *y, *yy, *ys, *yt; +doublereal *g; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ich[3+1] = "NTC"; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, + i__9; + + /* Local variables */ + static doublecomplex beta; + static integer ldas; + static logical same; + static integer incx, incy; + static logical full, tran, null; + static integer i__, m, n; + static doublecomplex alpha; + static logical isame[13]; + extern /* Subroutine */ int zmake_(); + static integer nargs; + static logical reset; + static integer incxs, incys; + static char trans[1]; + extern /* Subroutine */ int zmvch_(); + static integer ia, ib, ic; + static logical banded; + static integer nc, nd, im, in, kl, ml, nk, nl, ku, ix, iy, ms, lx, ly, ns; + extern /* Subroutine */ int czgbmv_(); + static char ctrans[14]; + extern /* Subroutine */ int czgemv_(); + static doublereal errmax; + static doublecomplex transl; + extern logical lzeres_(); + static char transs[1]; + static integer laa, lda; + static doublecomplex als, bls; + static doublereal err; + static integer iku, kls; + extern logical lze_(); + static integer kus; + + +/* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --kb; + --alf; + --bet; + --inc; + --g; + --yt; + --y; + --x; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ys; + --yy; + --xs; + --xx; + + /* Function Body */ +/* .. Executable Statements .. */ + full = *(unsigned char *)&sname[8] == 'e'; + banded = *(unsigned char *)&sname[8] == 'b'; +/* Define the number of arguments. */ + if (full) { + nargs = 11; + } else if (banded) { + nargs = 13; + } + + nc = 0; + reset = TRUE_; + errmax = 0.; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; + nd = n / 2 + 1; + + for (im = 1; im <= 2; ++im) { + if (im == 1) { +/* Computing MAX */ + i__2 = n - nd; + m = f2cmax(i__2,0); + } + if (im == 2) { +/* Computing MIN */ + i__2 = n + nd; + m = f2cmin(i__2,*nmax); + } + + if (banded) { + nk = *nkb; + } else { + nk = 1; + } + i__2 = nk; + for (iku = 1; iku <= i__2; ++iku) { + if (banded) { + ku = kb[iku]; +/* Computing MAX */ + i__3 = ku - 1; + kl = f2cmax(i__3,0); + } else { + ku = n - 1; + kl = m - 1; + } +/* Set LDA to 1 more than minimum value if room. */ + if (banded) { + lda = kl + ku + 1; + } else { + lda = m; + } + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L100; + } + laa = lda * n; + null = n <= 0 || m <= 0; + +/* Generate the matrix A. */ + + transl.r = 0., transl.i = 0.; + zmake_(sname + 7, " ", " ", &m, &n, &a[a_offset], nmax, &aa[1] + , &lda, &kl, &ku, &reset, &transl, (ftnlen)2, (ftnlen) + 1, (ftnlen)1); + + for (ic = 1; ic <= 3; ++ic) { + *(unsigned char *)trans = *(unsigned char *)&ich[ic - 1]; + if (*(unsigned char *)trans == 'N') { + s_copy(ctrans, " CblasNoTrans", (ftnlen)14, (ftnlen) + 14); + } else if (*(unsigned char *)trans == 'T') { + s_copy(ctrans, " CblasTrans", (ftnlen)14, (ftnlen) + 14); + } else { + s_copy(ctrans, "CblasConjTrans", (ftnlen)14, (ftnlen) + 14); + } + tran = *(unsigned char *)trans == 'T' || *(unsigned char * + )trans == 'C'; + + if (tran) { + ml = n; + nl = m; + } else { + ml = m; + nl = n; + } + + i__3 = *ninc; + for (ix = 1; ix <= i__3; ++ix) { + incx = inc[ix]; + lx = abs(incx) * nl; + +/* Generate the vector X. */ + + transl.r = .5, transl.i = 0.; + i__4 = abs(incx); + i__5 = nl - 1; + zmake_("ge", " ", " ", &c__1, &nl, &x[1], &c__1, &xx[ + 1], &i__4, &c__0, &i__5, &reset, &transl, ( + ftnlen)2, (ftnlen)1, (ftnlen)1); + if (nl > 1) { + i__4 = nl / 2; + x[i__4].r = 0., x[i__4].i = 0.; + i__4 = abs(incx) * (nl / 2 - 1) + 1; + xx[i__4].r = 0., xx[i__4].i = 0.; + } + + i__4 = *ninc; + for (iy = 1; iy <= i__4; ++iy) { + incy = inc[iy]; + ly = abs(incy) * ml; + + i__5 = *nalf; + for (ia = 1; ia <= i__5; ++ia) { + i__6 = ia; + alpha.r = alf[i__6].r, alpha.i = alf[i__6].i; + + i__6 = *nbet; + for (ib = 1; ib <= i__6; ++ib) { + i__7 = ib; + beta.r = bet[i__7].r, beta.i = bet[i__7] + .i; + +/* Generate the vector Y. */ + + transl.r = 0., transl.i = 0.; + i__7 = abs(incy); + i__8 = ml - 1; + zmake_("ge", " ", " ", &c__1, &ml, &y[1], + &c__1, &yy[1], &i__7, &c__0, & + i__8, &reset, &transl, (ftnlen)2, + (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the */ +/* subroutine. */ + + *(unsigned char *)transs = *(unsigned + char *)trans; + ms = m; + ns = n; + kls = kl; + kus = ku; + als.r = alpha.r, als.i = alpha.i; + i__7 = laa; + for (i__ = 1; i__ <= i__7; ++i__) { + i__8 = i__; + i__9 = i__; + as[i__8].r = aa[i__9].r, as[i__8].i = + aa[i__9].i; +/* L10: */ + } + ldas = lda; + i__7 = lx; + for (i__ = 1; i__ <= i__7; ++i__) { + i__8 = i__; + i__9 = i__; + xs[i__8].r = xx[i__9].r, xs[i__8].i = + xx[i__9].i; +/* L20: */ + } + incxs = incx; + bls.r = beta.r, bls.i = beta.i; + i__7 = ly; + for (i__ = 1; i__ <= i__7; ++i__) { + i__8 = i__; + i__9 = i__; + ys[i__8].r = yy[i__9].r, ys[i__8].i = + yy[i__9].i; +/* L30: */ + } + incys = incy; + +/* Call the subroutine. */ + + if (full) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s %3d %3d (%4.1f,%4.1f) A\n %3d, X, %2d, (%4.1f,%4.1f), Y, %2d).\n", + nc,sname,ctrans,m,n,alpha.r,alpha.i,lda,incx,beta.r,beta.i,incy); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + czgemv_(iorder, trans, &m, &n, &alpha, + &aa[1], &lda, &xx[1], &incx, + &beta, &yy[1], &incy, (ftnlen) + 1); + } else if (banded) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s %3d %3d %3d %3d (%4.1f,%4.1f) A\n %3d, X, %2d, (%4.1f,%4.1f), Y, %2d).\n", + nc,sname,ctrans,m,n,kl,ku,alpha.r,alpha.i,lda,incx,beta.r,beta.i,incy); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + czgbmv_(iorder, trans, &m, &n, &kl, & + ku, &alpha, &aa[1], &lda, &xx[ + 1], &incx, &beta, &yy[1], & + incy, (ftnlen)1); + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf("******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******\n"); + *fatal = TRUE_; + goto L130; + } + +/* See what data changed inside subroutines. */ + +/* IF(TRANS .NE. 'C' .OR. (INCX .GT. 0 .AND. INCY .GT. 0)) THEN */ + isame[0] = *(unsigned char *)trans == *( + unsigned char *)transs; + isame[1] = ms == m; + isame[2] = ns == n; + if (full) { + isame[3] = als.r == alpha.r && als.i + == alpha.i; + isame[4] = lze_(&as[1], &aa[1], &laa); + isame[5] = ldas == lda; + isame[6] = lze_(&xs[1], &xx[1], &lx); + isame[7] = incxs == incx; + isame[8] = bls.r == beta.r && bls.i == + beta.i; + if (null) { + isame[9] = lze_(&ys[1], &yy[1], & + ly); + } else { + i__7 = abs(incy); + isame[9] = lzeres_("ge", " ", & + c__1, &ml, &ys[1], &yy[1], + &i__7, (ftnlen)2, ( + ftnlen)1); + } + isame[10] = incys == incy; + } else if (banded) { + isame[3] = kls == kl; + isame[4] = kus == ku; + isame[5] = als.r == alpha.r && als.i + == alpha.i; + isame[6] = lze_(&as[1], &aa[1], &laa); + isame[7] = ldas == lda; + isame[8] = lze_(&xs[1], &xx[1], &lx); + isame[9] = incxs == incx; + isame[10] = bls.r == beta.r && bls.i + == beta.i; + if (null) { + isame[11] = lze_(&ys[1], &yy[1], & + ly); + } else { + i__7 = abs(incy); + isame[11] = lzeres_("ge", " ", & + c__1, &ml, &ys[1], &yy[1], + &i__7, (ftnlen)2, ( + ftnlen)1); + } + isame[12] = incys == incy; + } + +/* If data was incorrectly changed, report */ +/* and return. */ + + same = TRUE_; + i__7 = nargs; + for (i__ = 1; i__ <= i__7; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L130; + } + + if (! null) { + +/* Check the result. */ + + zmvch_(trans, &m, &n, &alpha, &a[ + a_offset], nmax, &x[1], &incx, + &beta, &y[1], &incy, &yt[1], + &g[1], &yy[1], eps, &err, + fatal, nout, &c_true, (ftnlen) + 1); + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L130; + } + } else { +/* Avoid repeating tests with M.le.0 or */ +/* N.le.0. */ + goto L110; + } +/* END IF */ + +/* L50: */ + } + +/* L60: */ + } + +/* L70: */ + } + +/* L80: */ + } + +/* L90: */ + } + +L100: + ; + } + +L110: + ; + } + +/* L120: */ + } + +/* Report result. */ + + if (errmax < *thresh) { + printf("%12s PASSED THE COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } else { + printf("%12s COMPLETED THE COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + printf("******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",errmax); + } + goto L140; + +L130: + printf("******* %12s FAILED ON CALL NUMBER:\n",sname); + if (full) { + printf("%6d: %12s (%14s %3d %3d (%4.1f,%4.1f) A\n %3d, X, %2d, (%4.1f,%4.1f), Y, %2d).\n", + nc,sname,ctrans,m,n,alpha.r,alpha.i,lda,incx,beta.r,beta.i,incy); + } else if (banded) { + printf("%6d: %12s (%14s %3d %3d %3d %3d (%4.1f,%4.1f) A\n %3d, X, %2d, (%4.1f,%4.1f), Y, %2d).\n", + nc,sname,ctrans,m,n,kl,ku,alpha.r,alpha.i,lda,incx,beta.r,beta.i,incy); + } + +L140: + return 0; + + +/* End of ZCHK1. */ + +} /* zchk1_ */ + +/* Subroutine */ int 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, sname_len) +char *sname; +doublereal *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nkb, *kb, *nalf; +doublecomplex *alf; +integer *nbet; +doublecomplex *bet; +integer *ninc, *inc, *nmax, *incmax; +doublecomplex *a, *aa, *as, *x, *xx, *xs, *y, *yy, *ys, *yt; +doublereal *g; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ich[2+1] = "UL"; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, + i__9; + + /* Local variables */ + static doublecomplex beta; + static integer ldas; + static logical same; + static integer incx, incy; + static logical full, null; + static char uplo[1]; + static integer i__, k, n; + static doublecomplex alpha; + static logical isame[13]; + extern /* Subroutine */ int zmake_(); + static integer nargs; + static logical reset; + static char cuplo[14]; + static integer incxs, incys; + extern /* Subroutine */ int zmvch_(); + static char uplos[1]; + static integer ia, ib, ic; + static logical banded; + static integer nc, ik, in; + static logical packed; + static integer nk, ks, ix, iy, ns, lx, ly; + extern /* Subroutine */ int czhbmv_(), czhemv_(); + static doublereal errmax; + static doublecomplex transl; + extern logical lzeres_(); + extern /* Subroutine */ int czhpmv_(); + static integer laa, lda; + static doublecomplex als, bls; + static doublereal err; + extern logical lze_(); + +/* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --kb; + --alf; + --bet; + --inc; + --g; + --yt; + --y; + --x; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ys; + --yy; + --xs; + --xx; + + /* Function Body */ +/* .. Executable Statements .. */ + full = *(unsigned char *)&sname[8] == 'e'; + banded = *(unsigned char *)&sname[8] == 'b'; + packed = *(unsigned char *)&sname[8] == 'p'; +/* Define the number of arguments. */ + if (full) { + nargs = 10; + } else if (banded) { + nargs = 11; + } else if (packed) { + nargs = 9; + } + + nc = 0; + reset = TRUE_; + errmax = 0.; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; + + if (banded) { + nk = *nkb; + } else { + nk = 1; + } + i__2 = nk; + for (ik = 1; ik <= i__2; ++ik) { + if (banded) { + k = kb[ik]; + } else { + k = n - 1; + } +/* Set LDA to 1 more than minimum value if room. */ + if (banded) { + lda = k + 1; + } else { + lda = n; + } + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L100; + } + if (packed) { + laa = n * (n + 1) / 2; + } else { + laa = lda * n; + } + null = n <= 0; + + for (ic = 1; ic <= 2; ++ic) { + *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1]; + if (*(unsigned char *)uplo == 'U') { + s_copy(cuplo, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cuplo, " CblasLower", (ftnlen)14, (ftnlen)14); + } + +/* Generate the matrix A. */ + + transl.r = 0., transl.i = 0.; + zmake_(sname + 7, uplo, " ", &n, &n, &a[a_offset], nmax, &aa[ + 1], &lda, &k, &k, &reset, &transl, (ftnlen)2, (ftnlen) + 1, (ftnlen)1); + + i__3 = *ninc; + for (ix = 1; ix <= i__3; ++ix) { + incx = inc[ix]; + lx = abs(incx) * n; + +/* Generate the vector X. */ + + transl.r = .5, transl.i = 0.; + i__4 = abs(incx); + i__5 = n - 1; + zmake_("ge", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], & + i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, ( + ftnlen)1, (ftnlen)1); + if (n > 1) { + i__4 = n / 2; + x[i__4].r = 0., x[i__4].i = 0.; + i__4 = abs(incx) * (n / 2 - 1) + 1; + xx[i__4].r = 0., xx[i__4].i = 0.; + } + + i__4 = *ninc; + for (iy = 1; iy <= i__4; ++iy) { + incy = inc[iy]; + ly = abs(incy) * n; + + i__5 = *nalf; + for (ia = 1; ia <= i__5; ++ia) { + i__6 = ia; + alpha.r = alf[i__6].r, alpha.i = alf[i__6].i; + + i__6 = *nbet; + for (ib = 1; ib <= i__6; ++ib) { + i__7 = ib; + beta.r = bet[i__7].r, beta.i = bet[i__7].i; + +/* Generate the vector Y. */ + + transl.r = 0., transl.i = 0.; + i__7 = abs(incy); + i__8 = n - 1; + zmake_("ge", " ", " ", &c__1, &n, &y[1], & + c__1, &yy[1], &i__7, &c__0, &i__8, & + reset, &transl, (ftnlen)2, (ftnlen)1, + (ftnlen)1); + + ++nc; + +/* Save every datum before calling the */ +/* subroutine. */ + + *(unsigned char *)uplos = *(unsigned char *) + uplo; + ns = n; + ks = k; + als.r = alpha.r, als.i = alpha.i; + i__7 = laa; + for (i__ = 1; i__ <= i__7; ++i__) { + i__8 = i__; + i__9 = i__; + as[i__8].r = aa[i__9].r, as[i__8].i = aa[ + i__9].i; +/* L10: */ + } + ldas = lda; + i__7 = lx; + for (i__ = 1; i__ <= i__7; ++i__) { + i__8 = i__; + i__9 = i__; + xs[i__8].r = xx[i__9].r, xs[i__8].i = xx[ + i__9].i; +/* L20: */ + } + incxs = incx; + bls.r = beta.r, bls.i = beta.i; + i__7 = ly; + for (i__ = 1; i__ <= i__7; ++i__) { + i__8 = i__; + i__9 = i__; + ys[i__8].r = yy[i__9].r, ys[i__8].i = yy[ + i__9].i; +/* L30: */ + } + incys = incy; + +/* Call the subroutine. */ + + if (full) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %3d, (%4.1f,%4.1f) A, %3d, X, %2d (%4.1f,%4.1f), Y, %2d ).\n", + nc,sname,cuplo,n,alpha.r,alpha.i,lda,incx,beta.r,beta.i,incy); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + czhemv_(iorder, uplo, &n, &alpha, &aa[1], + &lda, &xx[1], &incx, &beta, &yy[1] + , &incy, (ftnlen)1); + } else if (banded) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %3d %3d, (%4.1f,%4.1f) A, %3d, X, %2d (%4.1f,%4.1f), Y, %2d ).\n", + nc,sname,cuplo,n,k, alpha.r,alpha.i,lda,incx,beta.r,beta.i,incy); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + czhbmv_(iorder, uplo, &n, &k, &alpha, &aa[ + 1], &lda, &xx[1], &incx, &beta, & + yy[1], &incy, (ftnlen)1); + } else if (packed) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %3d, (%4.1f,%4.1f) AP, X, %2d (%4.1f,%4.1f), Y, %2d ).\n", + nc,sname,cuplo,n, alpha.r,alpha.i,incx,beta.r,beta.i,incy); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + czhpmv_(iorder, uplo, &n, &alpha, &aa[1], + &xx[1], &incx, &beta, &yy[1], & + incy, (ftnlen)1); + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf("******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******\n"); + *fatal = TRUE_; + goto L120; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)uplo == *( + unsigned char *)uplos; + isame[1] = ns == n; + if (full) { + isame[2] = als.r == alpha.r && als.i == + alpha.i; + isame[3] = lze_(&as[1], &aa[1], &laa); + isame[4] = ldas == lda; + isame[5] = lze_(&xs[1], &xx[1], &lx); + isame[6] = incxs == incx; + isame[7] = bls.r == beta.r && bls.i == + beta.i; + if (null) { + isame[8] = lze_(&ys[1], &yy[1], &ly); + } else { + i__7 = abs(incy); + isame[8] = lzeres_("ge", " ", &c__1, & + n, &ys[1], &yy[1], &i__7, ( + ftnlen)2, (ftnlen)1); + } + isame[9] = incys == incy; + } else if (banded) { + isame[2] = ks == k; + isame[3] = als.r == alpha.r && als.i == + alpha.i; + isame[4] = lze_(&as[1], &aa[1], &laa); + isame[5] = ldas == lda; + isame[6] = lze_(&xs[1], &xx[1], &lx); + isame[7] = incxs == incx; + isame[8] = bls.r == beta.r && bls.i == + beta.i; + if (null) { + isame[9] = lze_(&ys[1], &yy[1], &ly); + } else { + i__7 = abs(incy); + isame[9] = lzeres_("ge", " ", &c__1, & + n, &ys[1], &yy[1], &i__7, ( + ftnlen)2, (ftnlen)1); + } + isame[10] = incys == incy; + } else if (packed) { + isame[2] = als.r == alpha.r && als.i == + alpha.i; + isame[3] = lze_(&as[1], &aa[1], &laa); + isame[4] = lze_(&xs[1], &xx[1], &lx); + isame[5] = incxs == incx; + isame[6] = bls.r == beta.r && bls.i == + beta.i; + if (null) { + isame[7] = lze_(&ys[1], &yy[1], &ly); + } else { + i__7 = abs(incy); + isame[7] = lzeres_("ge", " ", &c__1, & + n, &ys[1], &yy[1], &i__7, ( + ftnlen)2, (ftnlen)1); + } + isame[8] = incys == incy; + } + +/* If data was incorrectly changed, report and */ +/* return. */ + + same = TRUE_; + i__7 = nargs; + for (i__ = 1; i__ <= i__7; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L120; + } + + if (! null) { + +/* Check the result. */ + + zmvch_("N", &n, &n, &alpha, &a[a_offset], + nmax, &x[1], &incx, &beta, &y[1], + &incy, &yt[1], &g[1], &yy[1], eps, + &err, fatal, nout, &c_true, ( + ftnlen)1); + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L120; + } + } else { +/* Avoid repeating tests with N.le.0 */ + goto L110; + } + +/* L50: */ + } + +/* L60: */ + } + +/* L70: */ + } + +/* L80: */ + } + +/* L90: */ + } + +L100: + ; + } + +L110: + ; + } + +/* Report result. */ + + if (errmax < *thresh) { + printf("%12s PASSED THE COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } else { + printf("%12s COMPLETED THE COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + printf("******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",errmax); + } + goto L130; + +L120: + printf("******* %12s FAILED ON CALL NUMBER:\n",sname); + if (full) { + printf("%6d: %12s (%14s, %3d, (%4.1f,%4.1f) A, %3d, X, %2d (%4.1f,%4.1f), Y, %2d ).\n", + nc,sname,cuplo,n, alpha.r,alpha.i,lda,incx,beta.r,beta.i,incy); + } else if (banded) { + printf("%6d: %12s (%14s, %3d, %3d, (%4.1f,%4.1f) A, %3d, X, %2d (%4.1f,%4.1f), Y, %2d ).\n", + nc,sname,cuplo,n, k, alpha.r,alpha.i,lda,incx,beta.r,beta.i,incy); + } else if (packed) { + printf("%6d: %12s (%14s, %3d, (%4.1f,%4.1f) AP, X, %2d (%4.1f,%4.1f), Y, %2d ).\n", + nc,sname,cuplo,n, alpha.r,alpha.i,incx,beta.r,beta.i,incy); + } + +L130: + return 0; + + +/* End of CZHK2. */ + +} /* zchk2_ */ + +/* Subroutine */ int 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, sname_len) +char *sname; +doublereal *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nkb, *kb, *ninc, *inc, *nmax, *incmax; +doublecomplex *a, *aa, *as, *x, *xx, *xs, *xt; +doublereal *g; +doublecomplex *z__; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ichu[2+1] = "UL"; + static char icht[3+1] = "NTC"; + static char ichd[2+1] = "UN"; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; + + /* Local variables */ + static char diag[1]; + static integer ldas; + static logical same; + static integer incx; + static logical full, null; + static char uplo[1], cdiag[14]; + static integer i__, k, n; + static char diags[1]; + static logical isame[13]; + extern /* Subroutine */ int zmake_(); + static integer nargs; + static logical reset; + static char cuplo[14]; + static integer incxs; + static char trans[1]; + extern /* Subroutine */ int zmvch_(); + static char uplos[1]; + static logical banded; + static integer nc, ik, in; + static logical packed; + static integer nk, ks, ix, ns, lx; + static char ctrans[14]; + static doublereal errmax; + static doublecomplex transl; + extern logical lzeres_(); + extern /* Subroutine */ int cztbmv_(); + static char transs[1]; + extern /* Subroutine */ int cztbsv_(), cztpmv_(), cztrmv_(), cztpsv_(), + cztrsv_(); + static integer laa, icd, lda, ict, icu; + static doublereal err; + extern logical lze_(); + + + + +/* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --kb; + --inc; + --z__; + --g; + --xt; + --x; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --xs; + --xx; + + /* Function Body */ +/* .. Executable Statements .. */ + full = *(unsigned char *)&sname[8] == 'r'; + banded = *(unsigned char *)&sname[8] == 'b'; + packed = *(unsigned char *)&sname[8] == 'p'; +/* Define the number of arguments. */ + if (full) { + nargs = 8; + } else if (banded) { + nargs = 9; + } else if (packed) { + nargs = 7; + } + + nc = 0; + reset = TRUE_; + errmax = 0.; +/* Set up zero vector for ZMVCH. */ + i__1 = *nmax; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + z__[i__2].r = 0., z__[i__2].i = 0.; +/* L10: */ + } + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; + + if (banded) { + nk = *nkb; + } else { + nk = 1; + } + i__2 = nk; + for (ik = 1; ik <= i__2; ++ik) { + if (banded) { + k = kb[ik]; + } else { + k = n - 1; + } +/* Set LDA to 1 more than minimum value if room. */ + if (banded) { + lda = k + 1; + } else { + lda = n; + } + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L100; + } + if (packed) { + laa = n * (n + 1) / 2; + } else { + laa = lda * n; + } + null = n <= 0; + + for (icu = 1; icu <= 2; ++icu) { + *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; + if (*(unsigned char *)uplo == 'U') { + s_copy(cuplo, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cuplo, " CblasLower", (ftnlen)14, (ftnlen)14); + } + + for (ict = 1; ict <= 3; ++ict) { + *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1] + ; + if (*(unsigned char *)trans == 'N') { + s_copy(ctrans, " CblasNoTrans", (ftnlen)14, (ftnlen) + 14); + } else if (*(unsigned char *)trans == 'T') { + s_copy(ctrans, " CblasTrans", (ftnlen)14, (ftnlen) + 14); + } else { + s_copy(ctrans, "CblasConjTrans", (ftnlen)14, (ftnlen) + 14); + } + + for (icd = 1; icd <= 2; ++icd) { + *(unsigned char *)diag = *(unsigned char *)&ichd[icd + - 1]; + if (*(unsigned char *)diag == 'N') { + s_copy(cdiag, " CblasNonUnit", (ftnlen)14, ( + ftnlen)14); + } else { + s_copy(cdiag, " CblasUnit", (ftnlen)14, ( + ftnlen)14); + } + +/* Generate the matrix A. */ + + transl.r = 0., transl.i = 0.; + zmake_(sname + 7, uplo, diag, &n, &n, &a[a_offset], + nmax, &aa[1], &lda, &k, &k, &reset, &transl, ( + ftnlen)2, (ftnlen)1, (ftnlen)1); + + i__3 = *ninc; + for (ix = 1; ix <= i__3; ++ix) { + incx = inc[ix]; + lx = abs(incx) * n; + +/* Generate the vector X. */ + + transl.r = .5, transl.i = 0.; + i__4 = abs(incx); + i__5 = n - 1; + zmake_("ge", " ", " ", &c__1, &n, &x[1], &c__1, & + xx[1], &i__4, &c__0, &i__5, &reset, & + transl, (ftnlen)2, (ftnlen)1, (ftnlen)1); + if (n > 1) { + i__4 = n / 2; + x[i__4].r = 0., x[i__4].i = 0.; + i__4 = abs(incx) * (n / 2 - 1) + 1; + xx[i__4].r = 0., xx[i__4].i = 0.; + } + + ++nc; + +/* Save every datum before calling the subroutine. */ + + *(unsigned char *)uplos = *(unsigned char *)uplo; + *(unsigned char *)transs = *(unsigned char *) + trans; + *(unsigned char *)diags = *(unsigned char *)diag; + ns = n; + ks = k; + i__4 = laa; + for (i__ = 1; i__ <= i__4; ++i__) { + i__5 = i__; + i__6 = i__; + as[i__5].r = aa[i__6].r, as[i__5].i = aa[i__6] + .i; +/* L20: */ + } + ldas = lda; + i__4 = lx; + for (i__ = 1; i__ <= i__4; ++i__) { + i__5 = i__; + i__6 = i__; + xs[i__5].r = xx[i__6].r, xs[i__5].i = xx[i__6] + .i; +/* L30: */ + } + incxs = incx; + +/* Call the subroutine. */ + + if (s_cmp(sname + 9, "mv", (ftnlen)2, (ftnlen)2) + == 0) { + if (full) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %14s, %14s, %3d, A, %3d, X, %2d).\n", + nc, sname, cuplo, ctrans, cdiag, n, lda, incx); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cztrmv_(iorder, uplo, trans, diag, &n, & + aa[1], &lda, &xx[1], &incx, ( + ftnlen)1, (ftnlen)1, (ftnlen)1); + } else if (banded) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %14s, %14s, %3d, %3d, A, %3d, X, %2d).\n", + nc, sname, cuplo, ctrans, cdiag, n, k, lda, incx); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cztbmv_(iorder, uplo, trans, diag, &n, &k, + &aa[1], &lda, &xx[1], &incx, ( + ftnlen)1, (ftnlen)1, (ftnlen)1); + } else if (packed) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %14s, %14s, %3d, AP X, %2d).\n", + nc, sname, cuplo, ctrans, cdiag, n, incx); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cztpmv_(iorder, uplo, trans, diag, &n, & + aa[1], &xx[1], &incx, (ftnlen)1, ( + ftnlen)1, (ftnlen)1); + } + } else if (s_cmp(sname + 9, "sv", (ftnlen)2, ( + ftnlen)2) == 0) { + if (full) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %14s, %14s, %3d, A, %3d, X, %2d).\n", + nc, sname, cuplo, ctrans, cdiag, n, lda, incx); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cztrsv_(iorder, uplo, trans, diag, &n, & + aa[1], &lda, &xx[1], &incx, ( + ftnlen)1, (ftnlen)1, (ftnlen)1); + } else if (banded) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %14s, %14s, %3d, %3d, A, %3d, X, %2d).\n", + nc, sname, cuplo, ctrans, cdiag, n, k, lda, incx); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cztbsv_(iorder, uplo, trans, diag, &n, &k, + &aa[1], &lda, &xx[1], &incx, ( + ftnlen)1, (ftnlen)1, (ftnlen)1); + } else if (packed) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %14s, %14s, %3d, AP X, %2d).\n", + nc, sname, cuplo, ctrans, cdiag, n, incx); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cztpsv_(iorder, uplo, trans, diag, &n, & + aa[1], &xx[1], &incx, (ftnlen)1, ( + ftnlen)1, (ftnlen)1); + } + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf("******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******\n"); + *fatal = TRUE_; + goto L120; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)uplo == *(unsigned + char *)uplos; + isame[1] = *(unsigned char *)trans == *(unsigned + char *)transs; + isame[2] = *(unsigned char *)diag == *(unsigned + char *)diags; + isame[3] = ns == n; + if (full) { + isame[4] = lze_(&as[1], &aa[1], &laa); + isame[5] = ldas == lda; + if (null) { + isame[6] = lze_(&xs[1], &xx[1], &lx); + } else { + i__4 = abs(incx); + isame[6] = lzeres_("ge", " ", &c__1, &n, & + xs[1], &xx[1], &i__4, (ftnlen)2, ( + ftnlen)1); + } + isame[7] = incxs == incx; + } else if (banded) { + isame[4] = ks == k; + isame[5] = lze_(&as[1], &aa[1], &laa); + isame[6] = ldas == lda; + if (null) { + isame[7] = lze_(&xs[1], &xx[1], &lx); + } else { + i__4 = abs(incx); + isame[7] = lzeres_("ge", " ", &c__1, &n, & + xs[1], &xx[1], &i__4, (ftnlen)2, ( + ftnlen)1); + } + isame[8] = incxs == incx; + } else if (packed) { + isame[4] = lze_(&as[1], &aa[1], &laa); + if (null) { + isame[5] = lze_(&xs[1], &xx[1], &lx); + } else { + i__4 = abs(incx); + isame[5] = lzeres_("ge", " ", &c__1, &n, & + xs[1], &xx[1], &i__4, (ftnlen)2, ( + ftnlen)1); + } + isame[6] = incxs == incx; + } + +/* If data was incorrectly changed, report and */ +/* return. */ + + same = TRUE_; + i__4 = nargs; + for (i__ = 1; i__ <= i__4; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L120; + } + + if (! null) { + if (s_cmp(sname + 9, "mv", (ftnlen)2, (ftnlen) + 2) == 0) { + +/* Check the result. */ + + zmvch_(trans, &n, &n, &c_b2, &a[a_offset], + nmax, &x[1], &incx, &c_b1, &z__[ + 1], &incx, &xt[1], &g[1], &xx[1], + eps, &err, fatal, nout, &c_true, ( + ftnlen)1); + } else if (s_cmp(sname + 9, "sv", (ftnlen)2, ( + ftnlen)2) == 0) { + +/* Compute approximation to original vector. */ + + i__4 = n; + for (i__ = 1; i__ <= i__4; ++i__) { + i__5 = i__; + i__6 = (i__ - 1) * abs(incx) + 1; + z__[i__5].r = xx[i__6].r, z__[i__5].i + = xx[i__6].i; + i__5 = (i__ - 1) * abs(incx) + 1; + i__6 = i__; + xx[i__5].r = x[i__6].r, xx[i__5].i = + x[i__6].i; +/* L50: */ + } + zmvch_(trans, &n, &n, &c_b2, &a[a_offset], + nmax, &z__[1], &incx, &c_b1, &x[ + 1], &incx, &xt[1], &g[1], &xx[1], + eps, &err, fatal, nout, &c_false, + (ftnlen)1); + } + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and return. */ + if (*fatal) { + goto L120; + } + } else { +/* Avoid repeating tests with N.le.0. */ + goto L110; + } + +/* L60: */ + } + +/* L70: */ + } + +/* L80: */ + } + +/* L90: */ + } + +L100: + ; + } + +L110: + ; + } + +/* Report result. */ + + if (errmax < *thresh) { + printf("%12s PASSED THE COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } else { + printf("%12s COMPLETED THE COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + printf("******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",errmax); + } + goto L130; + +L120: + printf("******* %12s FAILED ON CALL NUMBER:\n",sname); + if (full) { + printf("%6d: %12s (%14s, %14s, %14s, %3d, A, %3d, X, %2d).\n", + nc, sname, cuplo, ctrans, cdiag, n, lda, incx); + } else if (banded) { + printf("%6d: %12s (%14s, %14s, %14s, %3d, %3d, A, %3d, X, %2d).\n", + nc, sname, cuplo, ctrans, cdiag, n, k, lda, incx); + } else if (packed) { + + printf("%6d: %12s (%14s, %14s, %14s, %3d, AP X, %2d).\n", + nc, sname, cuplo, ctrans, cdiag, n, incx); + } + +L130: + return 0; + + +/* End of ZCHK3. */ + +} /* zchk3_ */ + +/* Subroutine */ int 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, sname_len) +char *sname; +doublereal *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nalf; +doublecomplex *alf; +integer *ninc, *inc, *nmax, *incmax; +doublecomplex *a, *aa, *as, *x, *xx, *xs, *y, *yy, *ys, *yt; +doublereal *g; +doublecomplex *z__; +integer *iorder; +ftnlen sname_len; +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7; + doublecomplex z__1; + + /* Local variables */ + static integer ldas; + static logical same, isconj; + static integer incx, incy; + static logical null; + static integer i__, j, m, n; + static doublecomplex alpha, w[1]; + static logical isame[13]; + extern /* Subroutine */ int zmake_(); + static integer nargs; + static logical reset; + static integer incxs, incys; + extern /* Subroutine */ int zmvch_(); + static integer ia, nc, nd, im, in, ms, ix, iy, ns, lx, ly; + extern /* Subroutine */ int czgerc_(); + static doublereal errmax; + extern /* Subroutine */ int czgeru_(); + static doublecomplex transl; + extern logical lzeres_(); + static integer laa, lda; + static doublecomplex als; + static doublereal err; + extern logical lze_(); + + + + +/* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + --idim; + --alf; + --inc; + --z__; + --g; + --yt; + --y; + --x; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ys; + --yy; + --xs; + --xx; + + /* Function Body */ + isconj = *(unsigned char *)&sname[10] == 'c'; +/* Define the number of arguments. */ + nargs = 9; + + nc = 0; + reset = TRUE_; + errmax = 0.; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; + nd = n / 2 + 1; + + for (im = 1; im <= 2; ++im) { + if (im == 1) { +/* Computing MAX */ + i__2 = n - nd; + m = f2cmax(i__2,0); + } + if (im == 2) { +/* Computing MIN */ + i__2 = n + nd; + m = f2cmin(i__2,*nmax); + } + +/* Set LDA to 1 more than minimum value if room. */ + lda = m; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L110; + } + laa = lda * n; + null = n <= 0 || m <= 0; + + i__2 = *ninc; + for (ix = 1; ix <= i__2; ++ix) { + incx = inc[ix]; + lx = abs(incx) * m; + +/* Generate the vector X. */ + + transl.r = .5, transl.i = 0.; + i__3 = abs(incx); + i__4 = m - 1; + zmake_("ge", " ", " ", &c__1, &m, &x[1], &c__1, &xx[1], &i__3, + &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1, + (ftnlen)1); + if (m > 1) { + i__3 = m / 2; + x[i__3].r = 0., x[i__3].i = 0.; + i__3 = abs(incx) * (m / 2 - 1) + 1; + xx[i__3].r = 0., xx[i__3].i = 0.; + } + + i__3 = *ninc; + for (iy = 1; iy <= i__3; ++iy) { + incy = inc[iy]; + ly = abs(incy) * n; + +/* Generate the vector Y. */ + + transl.r = 0., transl.i = 0.; + i__4 = abs(incy); + i__5 = n - 1; + zmake_("ge", " ", " ", &c__1, &n, &y[1], &c__1, &yy[1], & + i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, ( + ftnlen)1, (ftnlen)1); + if (n > 1) { + i__4 = n / 2; + y[i__4].r = 0., y[i__4].i = 0.; + i__4 = abs(incy) * (n / 2 - 1) + 1; + yy[i__4].r = 0., yy[i__4].i = 0.; + } + + i__4 = *nalf; + for (ia = 1; ia <= i__4; ++ia) { + i__5 = ia; + alpha.r = alf[i__5].r, alpha.i = alf[i__5].i; + +/* Generate the matrix A. */ + + transl.r = 0., transl.i = 0.; + i__5 = m - 1; + i__6 = n - 1; + zmake_(sname + 7, " ", " ", &m, &n, &a[a_offset], + nmax, &aa[1], &lda, &i__5, &i__6, &reset, & + transl, (ftnlen)2, (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the subroutine. */ + + ms = m; + ns = n; + als.r = alpha.r, als.i = alpha.i; + i__5 = laa; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7].i; +/* L10: */ + } + ldas = lda; + i__5 = lx; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + xs[i__6].r = xx[i__7].r, xs[i__6].i = xx[i__7].i; +/* L20: */ + } + incxs = incx; + i__5 = ly; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + ys[i__6].r = yy[i__7].r, ys[i__6].i = yy[i__7].i; +/* L30: */ + } + incys = incy; + +/* Call the subroutine. */ + + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%3d, %3d, (%4.1f,%4.1f), X, %3d, Y, %3d, A, %3d).\n", + nc, sname, m, n, alpha.r, alpha.i, incx, incy, lda); +*/ + } + if (isconj) { + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + czgerc_(iorder, &m, &n, &alpha, &xx[1], &incx, & + yy[1], &incy, &aa[1], &lda); + } else { + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + czgeru_(iorder, &m, &n, &alpha, &xx[1], &incx, & + yy[1], &incy, &aa[1], &lda); + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf("******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******\n"); + *fatal = TRUE_; + goto L140; + } + +/* See what data changed inside subroutine. */ + + isame[0] = ms == m; + isame[1] = ns == n; + isame[2] = als.r == alpha.r && als.i == alpha.i; + isame[3] = lze_(&xs[1], &xx[1], &lx); + isame[4] = incxs == incx; + isame[5] = lze_(&ys[1], &yy[1], &ly); + isame[6] = incys == incy; + if (null) { + isame[7] = lze_(&as[1], &aa[1], &laa); + } else { + isame[7] = lzeres_("ge", " ", &m, &n, &as[1], &aa[ + 1], &lda, (ftnlen)2, (ftnlen)1); + } + isame[8] = ldas == lda; + +/* If data was incorrectly changed, report and return. */ + + same = TRUE_; + i__5 = nargs; + for (i__ = 1; i__ <= i__5; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L140; + } + + if (! null) { + +/* Check the result column by column. */ + + if (incx > 0) { + i__5 = m; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + z__[i__6].r = x[i__7].r, z__[i__6].i = x[ + i__7].i; +/* L50: */ + } + } else { + i__5 = m; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = m - i__ + 1; + z__[i__6].r = x[i__7].r, z__[i__6].i = x[ + i__7].i; +/* L60: */ + } + } + i__5 = n; + for (j = 1; j <= i__5; ++j) { + if (incy > 0) { + i__6 = j; + w[0].r = y[i__6].r, w[0].i = y[i__6].i; + } else { + i__6 = n - j + 1; + w[0].r = y[i__6].r, w[0].i = y[i__6].i; + } + if (isconj) { + d_cnjg(&z__1, w); + w[0].r = z__1.r; w[0].i = z__1.i; + } + zmvch_("N", &m, &c__1, &alpha, &z__[1], nmax, + w, &c__1, &c_b2, &a[j * a_dim1 + 1], & + c__1, &yt[1], &g[1], &aa[(j - 1) * + lda + 1], eps, &err, fatal, nout, & + c_true, (ftnlen)1); + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and return. */ + if (*fatal) { + goto L130; + } +/* L70: */ + } + } else { +/* Avoid repeating tests with M.le.0 or N.le.0. */ + goto L110; + } + +/* L80: */ + } + +/* L90: */ + } + +/* L100: */ + } + +L110: + ; + } + +/* L120: */ + } + +/* Report result. */ + + if (errmax < *thresh) { + printf("%12s PASSED THE COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } else { + printf("%12s COMPLETED THE COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + printf("******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",errmax); + } + goto L150; + +L130: + printf(" THESE ARE THE RESULTS FOR COLUMN %3d\n",j); + +L140: + printf("******* %12s FAILED ON CALL NUMBER:\n",sname); + printf("%6d: %12s (%3d, %3d, (%4.1f,%4.1f), X, %3d, Y, %3d, A, %3d).\n", + nc, sname, m, n, alpha.r, alpha.i, incx, incy, lda); + +L150: + return 0; + + +/* End of ZCHK4. */ + +} /* zchk4_ */ + +/* Subroutine */ int 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, sname_len) +char *sname; +doublereal *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nalf; +doublecomplex *alf; +integer *ninc, *inc, *nmax, *incmax; +doublecomplex *a, *aa, *as, *x, *xx, *xs, *y, *yy, *ys, *yt; +doublereal *g; +doublecomplex *z__; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ich[2+1] = "UL"; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; + doublecomplex z__1; + + /* Local variables */ + static integer ldas; + static logical same; + static doublereal rals; + static integer incx; + static logical full, null; + static char uplo[1]; + static integer i__, j, n; + static doublecomplex alpha, w[1]; + static logical isame[13]; + extern /* Subroutine */ int zmake_(); + static integer nargs; + extern /* Subroutine */ int czher_(); + static logical reset; + static char cuplo[14]; + static integer incxs; + extern /* Subroutine */ int czhpr_(), zmvch_(); + static logical upper; + static char uplos[1]; + static integer ia, ja, ic, nc, jj, lj, in; + static logical packed; + static integer ix, ns, lx; + static doublereal ralpha, errmax; + static doublecomplex transl; + extern logical lzeres_(); + static integer laa, lda; + static doublereal err; + extern logical lze_(); + +/* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --alf; + --inc; + --z__; + --g; + --yt; + --y; + --x; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ys; + --yy; + --xs; + --xx; + + /* Function Body */ +/* .. Executable Statements .. */ + full = *(unsigned char *)&sname[8] == 'e'; + packed = *(unsigned char *)&sname[8] == 'p'; +/* Define the number of arguments. */ + if (full) { + nargs = 7; + } else if (packed) { + nargs = 6; + } + + nc = 0; + reset = TRUE_; + errmax = 0.; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; +/* Set LDA to 1 more than minimum value if room. */ + lda = n; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L100; + } + if (packed) { + laa = n * (n + 1) / 2; + } else { + laa = lda * n; + } + + for (ic = 1; ic <= 2; ++ic) { + *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1]; + if (*(unsigned char *)uplo == 'U') { + s_copy(cuplo, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cuplo, " CblasLower", (ftnlen)14, (ftnlen)14); + } + upper = *(unsigned char *)uplo == 'U'; + + i__2 = *ninc; + for (ix = 1; ix <= i__2; ++ix) { + incx = inc[ix]; + lx = abs(incx) * n; + +/* Generate the vector X. */ + + transl.r = .5, transl.i = 0.; + i__3 = abs(incx); + i__4 = n - 1; + zmake_("ge", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &i__3, + &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1, + (ftnlen)1); + if (n > 1) { + i__3 = n / 2; + x[i__3].r = 0., x[i__3].i = 0.; + i__3 = abs(incx) * (n / 2 - 1) + 1; + xx[i__3].r = 0., xx[i__3].i = 0.; + } + + i__3 = *nalf; + for (ia = 1; ia <= i__3; ++ia) { + i__4 = ia; + ralpha = alf[i__4].r; + z__1.r = ralpha, z__1.i = 0.; + alpha.r = z__1.r, alpha.i = z__1.i; + null = n <= 0 || ralpha == 0.; + +/* Generate the matrix A. */ + + transl.r = 0., transl.i = 0.; + i__4 = n - 1; + i__5 = n - 1; + zmake_(sname + 7, uplo, " ", &n, &n, &a[a_offset], nmax, & + aa[1], &lda, &i__4, &i__5, &reset, &transl, ( + ftnlen)2, (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the subroutine. */ + + *(unsigned char *)uplos = *(unsigned char *)uplo; + ns = n; + rals = ralpha; + i__4 = laa; + for (i__ = 1; i__ <= i__4; ++i__) { + i__5 = i__; + i__6 = i__; + as[i__5].r = aa[i__6].r, as[i__5].i = aa[i__6].i; +/* L10: */ + } + ldas = lda; + i__4 = lx; + for (i__ = 1; i__ <= i__4; ++i__) { + i__5 = i__; + i__6 = i__; + xs[i__5].r = xx[i__6].r, xs[i__5].i = xx[i__6].i; +/* L20: */ + } + incxs = incx; + +/* Call the subroutine. */ + + if (full) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %3d, %4.1f, X, %2d, A, %3d).\n", + nc, sname, cuplo, n, ralpha, incx, lda); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + czher_(iorder, uplo, &n, &ralpha, &xx[1], &incx, &aa[ + 1], &lda, (ftnlen)1); + } else if (packed) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %3d, %4.1f, X, %2d, AP).\n", + nc, sname, cuplo, n, ralpha, incx); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + czhpr_(iorder, uplo, &n, &ralpha, &xx[1], &incx, &aa[ + 1], (ftnlen)1); + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf("******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******\n"); + *fatal = TRUE_; + goto L120; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)uplo == *(unsigned char *) + uplos; + isame[1] = ns == n; + isame[2] = rals == ralpha; + isame[3] = lze_(&xs[1], &xx[1], &lx); + isame[4] = incxs == incx; + if (null) { + isame[5] = lze_(&as[1], &aa[1], &laa); + } else { + isame[5] = lzeres_(sname + 7, uplo, &n, &n, &as[1], & + aa[1], &lda, (ftnlen)2, (ftnlen)1); + } + if (! packed) { + isame[6] = ldas == lda; + } + +/* If data was incorrectly changed, report and return. */ + + same = TRUE_; + i__4 = nargs; + for (i__ = 1; i__ <= i__4; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L30: */ + } + if (! same) { + *fatal = TRUE_; + goto L120; + } + + if (! null) { + +/* Check the result column by column. */ + + if (incx > 0) { + i__4 = n; + for (i__ = 1; i__ <= i__4; ++i__) { + i__5 = i__; + i__6 = i__; + z__[i__5].r = x[i__6].r, z__[i__5].i = x[i__6] + .i; +/* L40: */ + } + } else { + i__4 = n; + for (i__ = 1; i__ <= i__4; ++i__) { + i__5 = i__; + i__6 = n - i__ + 1; + z__[i__5].r = x[i__6].r, z__[i__5].i = x[i__6] + .i; +/* L50: */ + } + } + ja = 1; + i__4 = n; + for (j = 1; j <= i__4; ++j) { + d_cnjg(&z__1, &z__[j]); + w[0].r = z__1.r, w[0].i = z__1.i; + if (upper) { + jj = 1; + lj = j; + } else { + jj = j; + lj = n - j + 1; + } + zmvch_("N", &lj, &c__1, &alpha, &z__[jj], &lj, w, + &c__1, &c_b2, &a[jj + j * a_dim1], &c__1, + &yt[1], &g[1], &aa[ja], eps, &err, fatal, + nout, &c_true, (ftnlen)1); + if (full) { + if (upper) { + ja += lda; + } else { + ja = ja + lda + 1; + } + } else { + ja += lj; + } + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and return. */ + if (*fatal) { + goto L110; + } +/* L60: */ + } + } else { +/* Avoid repeating tests if N.le.0. */ + if (n <= 0) { + goto L100; + } + } + +/* L70: */ + } + +/* L80: */ + } + +/* L90: */ + } + +L100: + ; + } + +/* Report result. */ + + if (errmax < *thresh) { + printf("%12s PASSED THE COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } else { + printf("%12s COMPLETED THE COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + printf("******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",errmax); + } + goto L130; + +L110: + printf(" THESE ARE THE RESULTS FOR COLUMN %3d\n",j); + +L120: + printf("******* %12s FAILED ON CALL NUMBER:\n",sname); + if (full) { + printf("%6d: %12s (%14s, %3d, %4.1f, X, %2d, A, %3d).\n", + nc, sname, cuplo, n, ralpha, incx, lda); + } else if (packed) { + printf("%6d: %12s (%14s, %3d, %4.1f, X, %2d, AP).\n", + nc, sname, cuplo, n, ralpha, incx); + } + +L130: + return 0; + + +/* End of CZHK5. */ + +} /* zchk5_ */ + +/* Subroutine */ int 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, sname_len) +char *sname; +doublereal *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nalf; +doublecomplex *alf; +integer *ninc, *inc, *nmax, *incmax; +doublecomplex *a, *aa, *as, *x, *xx, *xs, *y, *yy, *ys, *yt; +doublereal *g; +doublecomplex *z__; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ich[2+1] = "UL"; + + /* System generated locals */ + integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, + i__6, i__7; + doublecomplex z__1, z__2, z__3; + + /* Local variables */ + static integer ldas; + static logical same; + static integer incx, incy; + static logical full, null; + static char uplo[1]; + static integer i__, j, n; + static doublecomplex alpha, w[2]; + static logical isame[13]; + extern /* Subroutine */ int zmake_(); + static integer nargs; + static logical reset; + static char cuplo[14]; + static integer incxs, incys; + extern /* Subroutine */ int zmvch_(); + static logical upper; + static char uplos[1]; + extern /* Subroutine */ int czher2_(), czhpr2_(); + static integer ia, ja, ic, nc, jj, lj, in; + static logical packed; + static integer ix, iy, ns, lx, ly; + static doublereal errmax; + static doublecomplex transl; + extern logical lzeres_(); + static integer laa, lda; + static doublecomplex als; + static doublereal err; + extern logical lze_(); + +/* 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 .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --alf; + --inc; + z_dim1 = *nmax; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --g; + --yt; + --y; + --x; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ys; + --yy; + --xs; + --xx; + + /* Function Body */ +/* .. Executable Statements .. */ + full = *(unsigned char *)&sname[8] == 'e'; + packed = *(unsigned char *)&sname[8] == 'p'; +/* Define the number of arguments. */ + if (full) { + nargs = 9; + } else if (packed) { + nargs = 8; + } + + nc = 0; + reset = TRUE_; + errmax = 0.; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; +/* Set LDA to 1 more than minimum value if room. */ + lda = n; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L140; + } + if (packed) { + laa = n * (n + 1) / 2; + } else { + laa = lda * n; + } + + for (ic = 1; ic <= 2; ++ic) { + *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1]; + if (*(unsigned char *)uplo == 'U') { + s_copy(cuplo, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cuplo, " CblasLower", (ftnlen)14, (ftnlen)14); + } + upper = *(unsigned char *)uplo == 'U'; + + i__2 = *ninc; + for (ix = 1; ix <= i__2; ++ix) { + incx = inc[ix]; + lx = abs(incx) * n; + +/* Generate the vector X. */ + + transl.r = .5, transl.i = 0.; + i__3 = abs(incx); + i__4 = n - 1; + zmake_("ge", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &i__3, + &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1, + (ftnlen)1); + if (n > 1) { + i__3 = n / 2; + x[i__3].r = 0., x[i__3].i = 0.; + i__3 = abs(incx) * (n / 2 - 1) + 1; + xx[i__3].r = 0., xx[i__3].i = 0.; + } + + i__3 = *ninc; + for (iy = 1; iy <= i__3; ++iy) { + incy = inc[iy]; + ly = abs(incy) * n; + +/* Generate the vector Y. */ + + transl.r = 0., transl.i = 0.; + i__4 = abs(incy); + i__5 = n - 1; + zmake_("ge", " ", " ", &c__1, &n, &y[1], &c__1, &yy[1], & + i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, ( + ftnlen)1, (ftnlen)1); + if (n > 1) { + i__4 = n / 2; + y[i__4].r = 0., y[i__4].i = 0.; + i__4 = abs(incy) * (n / 2 - 1) + 1; + yy[i__4].r = 0., yy[i__4].i = 0.; + } + + i__4 = *nalf; + for (ia = 1; ia <= i__4; ++ia) { + i__5 = ia; + alpha.r = alf[i__5].r, alpha.i = alf[i__5].i; + null = n <= 0 || (alpha.r == 0. && alpha.i == 0.); + +/* Generate the matrix A. */ + + transl.r = 0., transl.i = 0.; + i__5 = n - 1; + i__6 = n - 1; + zmake_(sname + 7, uplo, " ", &n, &n, &a[a_offset], + nmax, &aa[1], &lda, &i__5, &i__6, &reset, & + transl, (ftnlen)2, (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the subroutine. */ + + *(unsigned char *)uplos = *(unsigned char *)uplo; + ns = n; + als.r = alpha.r, als.i = alpha.i; + i__5 = laa; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7].i; +/* L10: */ + } + ldas = lda; + i__5 = lx; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + xs[i__6].r = xx[i__7].r, xs[i__6].i = xx[i__7].i; +/* L20: */ + } + incxs = incx; + i__5 = ly; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + ys[i__6].r = yy[i__7].r, ys[i__6].i = yy[i__7].i; +/* L30: */ + } + incys = incy; + +/* Call the subroutine. */ + + if (full) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %3d, (%4.1f,%4.1f), X, %2d, Y, %2d, A, %3d).\n", + nc, sname, cuplo, n, alpha.r,alpha.i, incx, incy, lda); +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + czher2_(iorder, uplo, &n, &alpha, &xx[1], &incx, & + yy[1], &incy, &aa[1], &lda, (ftnlen)1); + } else if (packed) { + if (*trace) { +/* + sprintf(ntra,"%6d: %12s (%14s, %3d, (%4.1f,%4.1f), X, %2d, Y, %2d, AP).\n", + nc, sname, cuplo, n, alpha.r,alpha.i, incx, incy; +*/ + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + czhpr2_(iorder, uplo, &n, &alpha, &xx[1], &incx, & + yy[1], &incy, &aa[1], (ftnlen)1); + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf("******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******\n"); + *fatal = TRUE_; + goto L160; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)uplo == *(unsigned char * + )uplos; + isame[1] = ns == n; + isame[2] = als.r == alpha.r && als.i == alpha.i; + isame[3] = lze_(&xs[1], &xx[1], &lx); + isame[4] = incxs == incx; + isame[5] = lze_(&ys[1], &yy[1], &ly); + isame[6] = incys == incy; + if (null) { + isame[7] = lze_(&as[1], &aa[1], &laa); + } else { + isame[7] = lzeres_(sname + 7, uplo, &n, &n, &as[1] + , &aa[1], &lda, (ftnlen)2, (ftnlen)1); + } + if (! packed) { + isame[8] = ldas == lda; + } + +/* If data was incorrectly changed, report and return. */ + + same = TRUE_; + i__5 = nargs; + for (i__ = 1; i__ <= i__5; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L160; + } + + if (! null) { + +/* Check the result column by column. */ + + if (incx > 0) { + i__5 = n; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__ + z_dim1; + i__7 = i__; + z__[i__6].r = x[i__7].r, z__[i__6].i = x[ + i__7].i; +/* L50: */ + } + } else { + i__5 = n; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__ + z_dim1; + i__7 = n - i__ + 1; + z__[i__6].r = x[i__7].r, z__[i__6].i = x[ + i__7].i; +/* L60: */ + } + } + if (incy > 0) { + i__5 = n; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__ + (z_dim1 << 1); + i__7 = i__; + z__[i__6].r = y[i__7].r, z__[i__6].i = y[ + i__7].i; +/* L70: */ + } + } else { + i__5 = n; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__ + (z_dim1 << 1); + i__7 = n - i__ + 1; + z__[i__6].r = y[i__7].r, z__[i__6].i = y[ + i__7].i; +/* L80: */ + } + } + ja = 1; + i__5 = n; + for (j = 1; j <= i__5; ++j) { + d_cnjg(&z__2, &z__[j + (z_dim1 << 1)]); + z__1.r = alpha.r * z__2.r - alpha.i * z__2.i, + z__1.i = alpha.r * z__2.i + alpha.i * + z__2.r; + w[0].r = z__1.r, w[0].i = z__1.i; + d_cnjg(&z__2, &alpha); + d_cnjg(&z__3, &z__[j + z_dim1]); + z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, + z__1.i = z__2.r * z__3.i + z__2.i * + z__3.r; + w[1].r = z__1.r, w[1].i = z__1.i; + if (upper) { + jj = 1; + lj = j; + } else { + jj = j; + lj = n - j + 1; + } + zmvch_("N", &lj, &c__2, &c_b2, &z__[jj + + z_dim1], nmax, w, &c__1, &c_b2, &a[jj + + j * a_dim1], &c__1, &yt[1], &g[1], & + aa[ja], eps, &err, fatal, nout, & + c_true, (ftnlen)1); + if (full) { + if (upper) { + ja += lda; + } else { + ja = ja + lda + 1; + } + } else { + ja += lj; + } + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and return. */ + if (*fatal) { + goto L150; + } +/* L90: */ + } + } else { +/* Avoid repeating tests with N.le.0. */ + if (n <= 0) { + goto L140; + } + } + +/* L100: */ + } + +/* L110: */ + } + +/* L120: */ + } + +/* L130: */ + } + +L140: + ; + } + +/* Report result. */ + + if (errmax < *thresh) { + printf("%12s PASSED THE COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + } else { + printf("%12s COMPLETED THE COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc); + printf("******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",errmax); + } + goto L170; + +L150: + printf(" THESE ARE THE RESULTS FOR COLUMN %3d\n",j); + +L160: + printf("******* %12s FAILED ON CALL NUMBER:\n",sname); + if (full) { + printf("%6d: %12s (%14s, %3d, (%4.1f,%4.1f), X, %2d, Y, %2d, A, %3d).\n", + nc, sname, cuplo, n, alpha.r,alpha.i, incx, incy,lda); + } else if (packed) { + printf("%6d: %12s (%14s, %3d, (%4.1f,%4.1f), X, %2d, Y, %2d, AP).\n", + nc, sname, cuplo, n, alpha.r,alpha.i, incx, incy); + } + +L170: + return 0; + + +/* End of ZCHK6. */ + +} /* zchk6_ */ + +/* Subroutine */ int zmvch_(trans, m, n, alpha, a, nmax, x, incx, beta, y, + incy, yt, g, yy, eps, err, fatal, nout, mv, trans_len) +char *trans; +integer *m, *n; +doublecomplex *alpha, *a; +integer *nmax; +doublecomplex *x; +integer *incx; +doublecomplex *beta, *y; +integer *incy; +doublecomplex *yt; +doublereal *g; +doublecomplex *yy; +doublereal *eps, *err; +logical *fatal; +integer *nout; +logical *mv; +ftnlen trans_len; +{ + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; + doublereal d__1, d__2, d__3, d__4, d__5, d__6; + doublecomplex z__1, z__2, z__3; + + /* Local variables */ + static doublereal erri; + static logical tran; + static integer i__, j; + static logical ctran; + static integer incxl, incyl, ml, nl, iy, jx, kx, ky; + +/* Checks the results of the computational tests. */ + +/* Auxiliary routine for test program for Level 2 Blas. */ + +/* -- Written on 10-August-1987. */ +/* Richard Hanson, Sandia National Labs. */ +/* Jeremy Du Croz, NAG Central Office. */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Intrinsic Functions .. */ +/* .. Statement Functions .. */ +/* .. Statement Function definitions .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --x; + --y; + --yt; + --g; + --yy; + + /* Function Body */ + tran = *(unsigned char *)trans == 'T'; + ctran = *(unsigned char *)trans == 'C'; + if (tran || ctran) { + ml = *n; + nl = *m; + } else { + ml = *m; + nl = *n; + } + if (*incx < 0) { + kx = nl; + incxl = -1; + } else { + kx = 1; + incxl = 1; + } + if (*incy < 0) { + ky = ml; + incyl = -1; + } else { + ky = 1; + incyl = 1; + } + +/* Compute expected result in YT using data in A, X and Y. */ +/* Compute gauges in G. */ + + iy = ky; + i__1 = ml; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + yt[i__2].r = 0., yt[i__2].i = 0.; + g[iy] = 0.; + jx = kx; + if (tran) { + i__2 = nl; + for (j = 1; j <= i__2; ++j) { + i__3 = iy; + i__4 = iy; + i__5 = j + i__ * a_dim1; + i__6 = jx; + z__2.r = a[i__5].r * x[i__6].r - a[i__5].i * x[i__6].i, + z__2.i = a[i__5].r * x[i__6].i + a[i__5].i * x[i__6] + .r; + z__1.r = yt[i__4].r + z__2.r, z__1.i = yt[i__4].i + z__2.i; + yt[i__3].r = z__1.r, yt[i__3].i = z__1.i; + i__3 = j + i__ * a_dim1; + i__4 = jx; + g[iy] += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[j + + i__ * a_dim1]), abs(d__2))) * ((d__3 = x[i__4].r, + abs(d__3)) + (d__4 = d_imag(&x[jx]), abs(d__4))); + jx += incxl; +/* L10: */ + } + } else if (ctran) { + i__2 = nl; + for (j = 1; j <= i__2; ++j) { + i__3 = iy; + i__4 = iy; + d_cnjg(&z__3, &a[j + i__ * a_dim1]); + i__5 = jx; + z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i, z__2.i = + z__3.r * x[i__5].i + z__3.i * x[i__5].r; + z__1.r = yt[i__4].r + z__2.r, z__1.i = yt[i__4].i + z__2.i; + yt[i__3].r = z__1.r, yt[i__3].i = z__1.i; + i__3 = j + i__ * a_dim1; + i__4 = jx; + g[iy] += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[j + + i__ * a_dim1]), abs(d__2))) * ((d__3 = x[i__4].r, + abs(d__3)) + (d__4 = d_imag(&x[jx]), abs(d__4))); + jx += incxl; +/* L20: */ + } + } else { + i__2 = nl; + for (j = 1; j <= i__2; ++j) { + i__3 = iy; + i__4 = iy; + i__5 = i__ + j * a_dim1; + i__6 = jx; + z__2.r = a[i__5].r * x[i__6].r - a[i__5].i * x[i__6].i, + z__2.i = a[i__5].r * x[i__6].i + a[i__5].i * x[i__6] + .r; + z__1.r = yt[i__4].r + z__2.r, z__1.i = yt[i__4].i + z__2.i; + yt[i__3].r = z__1.r, yt[i__3].i = z__1.i; + i__3 = i__ + j * a_dim1; + i__4 = jx; + g[iy] += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + i__ + j * a_dim1]), abs(d__2))) * ((d__3 = x[i__4].r, + abs(d__3)) + (d__4 = d_imag(&x[jx]), abs(d__4))); + jx += incxl; +/* L30: */ + } + } + i__2 = iy; + i__3 = iy; + z__2.r = alpha->r * yt[i__3].r - alpha->i * yt[i__3].i, z__2.i = + alpha->r * yt[i__3].i + alpha->i * yt[i__3].r; + i__4 = iy; + z__3.r = beta->r * y[i__4].r - beta->i * y[i__4].i, z__3.i = beta->r * + y[i__4].i + beta->i * y[i__4].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + yt[i__2].r = z__1.r, yt[i__2].i = z__1.i; + i__2 = iy; + g[iy] = ((d__1 = alpha->r, abs(d__1)) + (d__2 = d_imag(alpha), abs( + d__2))) * g[iy] + ((d__3 = beta->r, abs(d__3)) + (d__4 = + d_imag(beta), abs(d__4))) * ((d__5 = y[i__2].r, abs(d__5)) + ( + d__6 = d_imag(&y[iy]), abs(d__6))); + iy += incyl; +/* L40: */ + } + +/* Compute the error ratio for this result. */ + + *err = 0.; + i__1 = ml; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = (i__ - 1) * abs(*incy) + 1; + z__1.r = yt[i__2].r - yy[i__3].r, z__1.i = yt[i__2].i - yy[i__3].i; + erri = z_abs(&z__1) / *eps; + if (g[i__] != 0.) { + erri /= g[i__]; + } + *err = f2cmax(*err,erri); + if (*err * sqrt(*eps) >= 1.) { + goto L60; + } +/* L50: */ + } +/* If the loop completes, all results are at least half accurate. */ + goto L80; + +/* Report fatal error. */ + +L60: + *fatal = TRUE_; + printf(" ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HALF ACCURATE *******\n EXPECTED RESULT COMPUTED RESULT\n"); + i__1 = ml; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*mv) { + printf("%7d (%15.6g,%15.6g) (%15.6g,%15.6g)\n",i__,yt[i__].r,yt[i__].i, yy[(i__ - 1) * abs(*incy) + 1].r, yy[(i__ - 1) * abs(*incy) + 1].i); + } else { + printf("%7d (%15.6g,%15.6g) (%15.6g,%15.6g),\n",i__, yy[(i__ - 1) * abs(*incy) + 1].r, yy[(i__ - 1) * abs(*incy) + 1].i, yt[i__].r,yt[i__].i); + } +/* L70: */ + } + +L80: + return 0; + + +/* End of ZMVCH. */ + +} /* zmvch_ */ + +logical lze_(ri, rj, lr) +doublecomplex *ri, *rj; +integer *lr; +{ + /* System generated locals */ + integer i__1, i__2, i__3; + logical ret_val; + + /* Local variables */ + static integer i__; + + +/* Tests if two arrays are identical. */ + +/* Auxiliary routine for test program for Level 2 Blas. */ + +/* -- Written on 10-August-1987. */ +/* Richard Hanson, Sandia National Labs. */ +/* Jeremy Du Croz, NAG Central Office. */ + +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + --rj; + --ri; + + /* Function Body */ + i__1 = *lr; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + if (ri[i__2].r != rj[i__3].r || ri[i__2].i != rj[i__3].i) { + goto L20; + } +/* L10: */ + } + ret_val = TRUE_; + goto L30; +L20: + ret_val = FALSE_; +L30: + return ret_val; + +/* End of LZE. */ + +} /* lze_ */ + +logical lzeres_(type__, uplo, m, n, aa, as, lda, type_len, uplo_len) +char *type__, *uplo; +integer *m, *n; +doublecomplex *aa, *as; +integer *lda; +ftnlen type_len; +ftnlen uplo_len; +{ + /* System generated locals */ + integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2, i__3, i__4; + logical ret_val; + + /* Local variables */ + static integer ibeg, iend, i__, j; + static logical upper; + + +/* Tests if selected elements in two arrays are equal. */ + +/* TYPE is 'ge', '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 .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + as_dim1 = *lda; + as_offset = 1 + as_dim1 * 1; + as -= as_offset; + aa_dim1 = *lda; + aa_offset = 1 + aa_dim1 * 1; + aa -= aa_offset; + + /* Function Body */ + upper = *(unsigned char *)uplo == 'U'; + if (s_cmp(type__, "ge", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *lda; + for (i__ = *m + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * aa_dim1; + i__4 = i__ + j * as_dim1; + if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) { + goto L70; + } +/* L10: */ + } +/* L20: */ + } + } else if (s_cmp(type__, "he", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (upper) { + ibeg = 1; + iend = j; + } else { + ibeg = j; + iend = *n; + } + i__2 = ibeg - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * aa_dim1; + i__4 = i__ + j * as_dim1; + if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) { + goto L70; + } +/* L30: */ + } + i__2 = *lda; + for (i__ = iend + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * aa_dim1; + i__4 = i__ + j * as_dim1; + if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) { + goto L70; + } +/* L40: */ + } +/* L50: */ + } + } + +/* L60: */ + ret_val = TRUE_; + goto L80; +L70: + ret_val = FALSE_; +L80: + return ret_val; + +/* End of LZERES. */ + +} /* lzeres_ */ + +/* Double Complex */ VOID zbeg_( ret_val, reset) +doublecomplex * ret_val; +logical *reset; +{ + /* System generated locals */ + doublereal d__1, d__2; + doublecomplex z__1; + + /* Local variables */ + static integer i__, j, ic, mi, mj; + + +/* Generates complex numbers as pairs of random numbers uniformly */ +/* distributed between -0.5 and 0.5. */ + +/* Auxiliary routine for test program for Level 2 Blas. */ + +/* -- Written on 10-August-1987. */ +/* Richard Hanson, Sandia National Labs. */ +/* Jeremy Du Croz, NAG Central Office. */ + +/* .. Scalar Arguments .. */ +/* .. Local Scalars .. */ +/* .. Save statement .. */ +/* .. Intrinsic Functions .. */ +/* .. Executable Statements .. */ + if (*reset) { +/* Initialize local variables. */ + mi = 891; + mj = 457; + i__ = 7; + j = 7; + ic = 0; + *reset = FALSE_; + } + +/* The sequence of values of I or J is bounded between 1 and 999. */ +/* If initial I or J = 1,2,3,6,7 or 9, the period will be 50. */ +/* If initial I or J = 4 or 8, the period will be 25. */ +/* If initial I or J = 5, the period will be 10. */ +/* IC is used to break up the period by skipping 1 value of I or J */ +/* in 6. */ + + ++ic; +L10: + i__ *= mi; + j *= mj; + i__ -= i__ / 1000 * 1000; + j -= j / 1000 * 1000; + if (ic >= 5) { + ic = 0; + goto L10; + } + d__1 = (doublereal) ((i__ - 500) / (float)1001.); + d__2 = (doublereal) ((j - 500) / (float)1001.); + z__1.r = d__1, z__1.i = d__2; + ret_val->r = z__1.r, ret_val->i = z__1.i; + return ; + +/* End of ZBEG. */ + +} /* zbeg_ */ + +doublereal ddiff_(x, y) +doublereal *x, *y; +{ + /* System generated locals */ + doublereal ret_val; + + +/* Auxiliary routine for test program for Level 2 Blas. */ + +/* -- Written on 10-August-1987. */ +/* Richard Hanson, Sandia National Labs. */ + +/* .. Scalar Arguments .. */ +/* .. Executable Statements .. */ + ret_val = *x - *y; + return ret_val; + +/* End of DDIFF. */ + +} /* ddiff_ */ + +/* Subroutine */ int zmake_(type__, uplo, diag, m, n, a, nmax, aa, lda, kl, + ku, reset, transl, type_len, uplo_len, diag_len) +char *type__, *uplo, *diag; +integer *m, *n; +doublecomplex *a; +integer *nmax; +doublecomplex *aa; +integer *lda, *kl, *ku; +logical *reset; +doublecomplex *transl; +ftnlen type_len; +ftnlen uplo_len; +ftnlen diag_len; +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + doublereal d__1; + doublecomplex z__1, z__2; + + /* Local variables */ + static integer ibeg, iend, ioff; + extern /* Double Complex */ VOID zbeg_(); + static logical unit; + static integer i__, j; + static logical lower; + static integer i1, i2, i3; + static logical upper; + static integer jj, kk; + static logical gen, tri, sym; + + +/* Generates values for an M by N matrix A within the bandwidth */ +/* defined by KL and KU. */ +/* Stores the values in the array AA in the data structure required */ +/* by the routine, with unwanted elements set to rogue value. */ + +/* TYPE is 'ge', 'gb', 'he', 'hb', 'hp', 'tr', 'tb' OR 'tp'. */ + +/* Auxiliary routine for test program for Level 2 Blas. */ + +/* -- Written on 10-August-1987. */ +/* Richard Hanson, Sandia National Labs. */ +/* Jeremy Du Croz, NAG Central Office. */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. External Functions .. */ +/* .. Intrinsic Functions .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --aa; + + /* Function Body */ + gen = *(unsigned char *)type__ == 'g'; + sym = *(unsigned char *)type__ == 'h'; + tri = *(unsigned char *)type__ == 't'; + upper = (sym || tri) && *(unsigned char *)uplo == 'U'; + lower = (sym || tri) && *(unsigned char *)uplo == 'L'; + unit = tri && *(unsigned char *)diag == 'U'; + +/* Generate data in array A. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + if (gen || (upper && i__ <= j) || (lower && i__ >= j)) { + if ((i__ <= j && j - i__ <= *ku )|| (i__ >= j && i__ - j <= *kl)) + { + i__3 = i__ + j * a_dim1; + zbeg_(&z__2, reset); + z__1.r = z__2.r + transl->r, z__1.i = z__2.i + transl->i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } else { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; + } + if (i__ != j) { + if (sym) { + i__3 = j + i__ * a_dim1; + d_cnjg(&z__1, &a[i__ + j * a_dim1]); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } else if (tri) { + i__3 = j + i__ * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; + } + } + } +/* L10: */ + } + if (sym) { + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + d__1 = a[i__3].r; + z__1.r = d__1, z__1.i = 0.; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + } + if (tri) { + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + z__1.r = a[i__3].r + 1., z__1.i = a[i__3].i + 0.; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + } + if (unit) { + i__2 = j + j * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + } +/* L20: */ + } + +/* Store elements in array AS in data structure required by routine. */ + + if (s_cmp(type__, "ge", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (j - 1) * *lda; + i__4 = i__ + j * a_dim1; + aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i; +/* L30: */ + } + i__2 = *lda; + for (i__ = *m + 1; i__ <= i__2; ++i__) { + i__3 = i__ + (j - 1) * *lda; + aa[i__3].r = -1e10, aa[i__3].i = 1e10; +/* L40: */ + } +/* L50: */ + } + } else if (s_cmp(type__, "gb", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *ku + 1 - j; + for (i1 = 1; i1 <= i__2; ++i1) { + i__3 = i1 + (j - 1) * *lda; + aa[i__3].r = -1e10, aa[i__3].i = 1e10; +/* L60: */ + } +/* Computing MIN */ + i__3 = *kl + *ku + 1, i__4 = *ku + 1 + *m - j; + i__2 = f2cmin(i__3,i__4); + for (i2 = i1; i2 <= i__2; ++i2) { + i__3 = i2 + (j - 1) * *lda; + i__4 = i2 + j - *ku - 1 + j * a_dim1; + aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i; +/* L70: */ + } + i__2 = *lda; + for (i3 = i2; i3 <= i__2; ++i3) { + i__3 = i3 + (j - 1) * *lda; + aa[i__3].r = -1e10, aa[i__3].i = 1e10; +/* L80: */ + } +/* L90: */ + } + } else if (s_cmp(type__, "he", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__, + "tr", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (upper) { + ibeg = 1; + if (unit) { + iend = j - 1; + } else { + iend = j; + } + } else { + if (unit) { + ibeg = j + 1; + } else { + ibeg = j; + } + iend = *n; + } + i__2 = ibeg - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (j - 1) * *lda; + aa[i__3].r = -1e10, aa[i__3].i = 1e10; +/* L100: */ + } + i__2 = iend; + for (i__ = ibeg; i__ <= i__2; ++i__) { + i__3 = i__ + (j - 1) * *lda; + i__4 = i__ + j * a_dim1; + aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i; +/* L110: */ + } + i__2 = *lda; + for (i__ = iend + 1; i__ <= i__2; ++i__) { + i__3 = i__ + (j - 1) * *lda; + aa[i__3].r = -1e10, aa[i__3].i = 1e10; +/* L120: */ + } + if (sym) { + jj = j + (j - 1) * *lda; + i__2 = jj; + i__3 = jj; + d__1 = aa[i__3].r; + z__1.r = d__1, z__1.i = -1e10; + aa[i__2].r = z__1.r, aa[i__2].i = z__1.i; + } +/* L130: */ + } + } else if (s_cmp(type__, "hb", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__, + "tb", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (upper) { + kk = *kl + 1; +/* Computing MAX */ + i__2 = 1, i__3 = *kl + 2 - j; + ibeg = f2cmax(i__2,i__3); + if (unit) { + iend = *kl; + } else { + iend = *kl + 1; + } + } else { + kk = 1; + if (unit) { + ibeg = 2; + } else { + ibeg = 1; + } +/* Computing MIN */ + i__2 = *kl + 1, i__3 = *m + 1 - j; + iend = f2cmin(i__2,i__3); + } + i__2 = ibeg - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (j - 1) * *lda; + aa[i__3].r = -1e10, aa[i__3].i = 1e10; +/* L140: */ + } + i__2 = iend; + for (i__ = ibeg; i__ <= i__2; ++i__) { + i__3 = i__ + (j - 1) * *lda; + i__4 = i__ + j - kk + j * a_dim1; + aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i; +/* L150: */ + } + i__2 = *lda; + for (i__ = iend + 1; i__ <= i__2; ++i__) { + i__3 = i__ + (j - 1) * *lda; + aa[i__3].r = -1e10, aa[i__3].i = 1e10; +/* L160: */ + } + if (sym) { + jj = kk + (j - 1) * *lda; + i__2 = jj; + i__3 = jj; + d__1 = aa[i__3].r; + z__1.r = d__1, z__1.i = -1e10; + aa[i__2].r = z__1.r, aa[i__2].i = z__1.i; + } +/* L170: */ + } + } else if (s_cmp(type__, "hp", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__, + "tp", (ftnlen)2, (ftnlen)2) == 0) { + ioff = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (upper) { + ibeg = 1; + iend = j; + } else { + ibeg = j; + iend = *n; + } + i__2 = iend; + for (i__ = ibeg; i__ <= i__2; ++i__) { + ++ioff; + i__3 = ioff; + i__4 = i__ + j * a_dim1; + aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i; + if (i__ == j) { + if (unit) { + i__3 = ioff; + aa[i__3].r = -1e10, aa[i__3].i = 1e10; + } + if (sym) { + i__3 = ioff; + i__4 = ioff; + d__1 = aa[i__4].r; + z__1.r = d__1, z__1.i = -1e10; + aa[i__3].r = z__1.r, aa[i__3].i = z__1.i; + } + } +/* L180: */ + } +/* L190: */ + } + } + return 0; + +/* End of ZMAKE. */ + +} /* zmake_ */ + diff --git a/ctest/c_zblat3c.c b/ctest/c_zblat3c.c new file mode 100644 index 000000000..c785d24e8 --- /dev/null +++ b/ctest/c_zblat3c.c @@ -0,0 +1,4399 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif +#if 0 +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +#endif +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i= 0; + if (trace) { +/* o__1.oerr = 0; + o__1.ounit = ntra; + o__1.ofnmlen = 32; + o__1.ofnm = snaps; + o__1.orl = 0; + o__1.osta = "NEW"; + o__1.oacc = 0; + o__1.ofm = 0; + o__1.oblnk = 0; + f_open(&o__1);*/ + } +/* Read the flag that directs rewinding of the snapshot file. */ + fgets(line,80,stdin); + sscanf(line,"%d",&rewi); + rewi = rewi && trace; +/* Read the flag that directs stopping on any failure. */ + fgets(line,80,stdin); + sscanf(line,"%c",&tmpchar); + sfatal=FALSE_; + if (tmpchar=='T')sfatal=TRUE_; +/* Read the flag that indicates whether error exits are to be tested. */ + fgets(line,80,stdin); + sscanf(line,"%c",&tmpchar); + tsterr=FALSE_; + if (tmpchar=='T')tsterr=TRUE_; +/* Read the flag that indicates whether row-major data layout to be tested. */ + fgets(line,80,stdin); + sscanf(line,"%d",&layout); +/* Read the threshold value of the test ratio */ + fgets(line,80,stdin); + sscanf(line,"%lf",&thresh); + +/* Read and check the parameter values for the tests. */ + +/* Values of N */ + fgets(line,80,stdin); + sscanf(line,"%d",&nidim); + + if (nidim < 1 || nidim > 9) { + fprintf(stderr,"NUMBER OF VALUES OF N IS LESS THAN 1 OR GREATER THAN 9"); + goto L220; + } + fgets(line,80,stdin); + sscanf(line,"%d %d %d %d %d %d %d %d %d",&idim[0],&idim[1],&idim[2], + &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]); + i__1 = nidim; + for (i__ = 1; i__ <= i__1; ++i__) { + if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) { + fprintf(stderr,"VALUE OF N IS LESS THAN 0 OR GREATER THAN 65\n"); + goto L220; + } +/* L10: */ + } +/* Values of ALPHA */ + fgets(line,80,stdin); + sscanf(line,"%d",&nalf); + if (nalf < 1 || nalf > 7) { + fprintf(stderr,"VALUE OF ALPHA IS LESS THAN 0 OR GREATER THAN 7\n"); + goto L220; + } + fgets(line,80,stdin); + sscanf(line,"(%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf)",&alf[0].r,&alf[0].i,&alf[1].r,&alf[1].i,&alf[2].r,&alf[2].i,&alf[3].r,&alf[3].i, + &alf[4].r,&alf[4].i,&alf[5].r,&alf[5].i,&alf[6].r,&alf[6].i); + +/* Values of BETA */ + fgets(line,80,stdin); + sscanf(line,"%d",&nbet); + if (nalf < 1 || nbet > 7) { + fprintf(stderr,"VALUE OF BETA IS LESS THAN 0 OR GREATER THAN 7\n"); + goto L220; + } + fgets(line,80,stdin); + sscanf(line,"(%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf)",&bet[0].r,&bet[0].i,&bet[1].r,&bet[1].i,&bet[2].r,&bet[2].i,&bet[3].r,&bet[3].i, + &bet[4].r,&bet[4].i,&bet[5].r,&bet[5].i,&bet[6].r,&bet[6].i); + +/* Report values of parameters. */ + + printf("TESTS OF THE DOUBLE PRECISION COMPLEX LEVEL 3 BLAS\nTHE FOLLOWING PARAMETER VALUES WILL BE USED:\n"); + printf(" FOR N"); + for (i__ =1; i__ <=nidim;++i__) printf(" %d",idim[i__-1]); + printf("\n"); + printf(" FOR ALPHA"); + for (i__ =1; i__ <=nalf;++i__) printf(" (%lf,%lf)",alf[i__-1].r,alf[i__-1].i); + printf("\n"); + printf(" FOR BETA"); + for (i__ =1; i__ <=nbet;++i__) printf(" (%lf,%lf)",bet[i__-1].r,bet[i__-1].i); + printf("\n"); + + if (! tsterr) { + printf(" ERROR-EXITS WILL NOT BE TESTED\n"); + } + + printf("ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LESS THAN %lf\n",thresh); + rorder = FALSE_; + corder = FALSE_; + if (layout == 2) { + rorder = TRUE_; + corder = TRUE_; + printf("COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED\n"); + } else if (layout == 1) { + rorder = TRUE_; + printf("ROW-MAJOR DATA LAYOUT IS TESTED\n"); + } else if (layout == 0) { + corder = TRUE_; + printf("COLUMN-MAJOR DATA LAYOUT IS TESTED\n"); + } + +/* Read names of subroutines and flags which indicate */ +/* whether they are to be tested. */ + + for (i__ = 1; i__ <= 9; ++i__) { + ltest[i__ - 1] = FALSE_; +/* L20: */ + } +L30: + if (! fgets(line,80,stdin)) { + goto L60; + } + i__1 = sscanf(line,"%12c %c",snamet,&tmpchar); + ltestt=FALSE_; + if (tmpchar=='T')ltestt=TRUE_; + if (i__1 < 2) { + goto L60; + } + for (i__ = 1; i__ <= 9; ++i__) { + if (s_cmp(snamet, snames[i__ - 1] , (ftnlen)12, (ftnlen)12) == + 0) { + goto L50; + } +/* L40: */ + } + printf("SUBPROGRAM NAME %s NOT RECOGNIZED\n****** TESTS ABANDONED ******\n",snamet); + exit(1); +L50: + ltest[i__ - 1] = ltestt; + goto L30; + +L60: +/* cl__1.cerr = 0; + cl__1.cunit = 5; + cl__1.csta = 0; + f_clos(&cl__1);*/ + +/* Compute EPS (the machine precision). */ + + eps = 1.; +L70: + d__1 = eps + 1.; + if (ddiff_(&d__1, &c_b92) == 0.) { + goto L80; + } + eps *= .5; + goto L70; +L80: + eps += eps; + printf("RELATIVE MACHINE PRECISION IS TAKEN TO BE %9.1g\n",eps); + +/* Check the reliability of ZMMCH using exact data. */ + + n = 32; + i__1 = n; + for (j = 1; j <= i__1; ++j) { + i__2 = n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * 65 - 66; +/* Computing MAX */ + i__5 = i__ - j + 1; + i__4 = f2cmax(i__5,0); + ab[i__3].r = (doublereal) i__4, ab[i__3].i = 0.; +/* L90: */ + } + i__2 = j + 4224; + ab[i__2].r = (doublereal) j, ab[i__2].i = 0.; + i__2 = (j + 65) * 65 - 65; + ab[i__2].r = (doublereal) j, ab[i__2].i = 0.; + i__2 = j - 1; + c__[i__2].r = 0., c__[i__2].i = 0.; +/* L100: */ + } + i__1 = n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + i__3 = j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3; + cc[i__2].r = (doublereal) i__3, cc[i__2].i = 0.; +/* L110: */ + } +/* CC holds the exact result. On exit from ZMMCH CT holds */ +/* the result computed by ZMMCH. */ + *(unsigned char *)transa = 'N'; + *(unsigned char *)transb = 'N'; + zmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], & + c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal, + &c__6, &c_true, (ftnlen)1, (ftnlen)1); + same = lze_(cc, ct, &n); + if (! same || err != 0.) { + printf("ERROR IN ZMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); + printf("ZMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); + printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); + printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); + printf("****** TESTS ABANDONED ******\n"); + exit(1); + } + *(unsigned char *)transb = 'C'; + zmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], & + c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal, + &c__6, &c_true, (ftnlen)1, (ftnlen)1); + same = lze_(cc, ct, &n); + if (! same || err != 0.) { + printf("ERROR IN ZMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); + printf("ZMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); + printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); + printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); + printf("****** TESTS ABANDONED ******\n"); + exit(1); + } + i__1 = n; + for (j = 1; j <= i__1; ++j) { + i__2 = j + 4224; + i__3 = n - j + 1; + ab[i__2].r = (doublereal) i__3, ab[i__2].i = 0.; + i__2 = (j + 65) * 65 - 65; + i__3 = n - j + 1; + ab[i__2].r = (doublereal) i__3, ab[i__2].i = 0.; +/* L120: */ + } + i__1 = n; + for (j = 1; j <= i__1; ++j) { + i__2 = n - j; + i__3 = j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3; + cc[i__2].r = (doublereal) i__3, cc[i__2].i = 0.; +/* L130: */ + } + *(unsigned char *)transa = 'C'; + *(unsigned char *)transb = 'N'; + zmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], & + c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal, + &c__6, &c_true, (ftnlen)1, (ftnlen)1); + same = lze_(cc, ct, &n); + if (! same || err != 0.) { + printf("ERROR IN ZMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); + printf("ZMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); + printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); + printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); + printf("****** TESTS ABANDONED ******\n"); + exit(1); + } + *(unsigned char *)transb = 'C'; + zmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], & + c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal, + &c__6, &c_true, (ftnlen)1, (ftnlen)1); + same = lze_(cc, ct, &n); + if (! same || err != 0.) { + printf("ERROR IN ZMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); + printf("ZMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); + printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); + printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); + printf("****** TESTS ABANDONED ******\n"); + exit(1); + } + +/* Test each subroutine in turn. */ + + for (isnum = 1; isnum <= 9; ++isnum) { + if (! ltest[isnum - 1]) { +/* Subprogram is not to be tested. */ + printf("%12s WAS NOT TESTED\n",snames[isnum-1]); + } else { + s_copy(srnamc_1.srnamt, snames[isnum - 1], (ftnlen)12, ( + ftnlen)12); +/* Test error exits. */ + if (tsterr) { + cz3chke_(snames[isnum - 1], (ftnlen)12); + } +/* Test computations. */ + infoc_1.infot = 0; + infoc_1.ok = TRUE_; + fatal = FALSE_; + switch ((int)isnum) { + case 1: goto L140; + case 2: goto L150; + case 3: goto L150; + case 4: goto L160; + case 5: goto L160; + case 6: goto L170; + case 7: goto L170; + case 8: goto L180; + case 9: goto L180; + } +/* Test ZGEMM, 01. */ +L140: + if (corder) { + zchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__0, (ftnlen)12); + } + if (rorder) { + zchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__1, (ftnlen)12); + } + goto L190; +/* Test ZHEMM, 02, ZSYMM, 03. */ +L150: + if (corder) { + zchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__0, (ftnlen)12); + } + if (rorder) { + zchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__1, (ftnlen)12); + } + goto L190; +/* Test ZTRMM, 04, ZTRSM, 05. */ +L160: + if (corder) { + zchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, & + c__0, (ftnlen)12); + } + if (rorder) { + zchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, & + c__1, (ftnlen)12); + } + goto L190; +/* Test ZHERK, 06, ZSYRK, 07. */ +L170: + if (corder) { + zchk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__0, (ftnlen)12); + } + if (rorder) { + zchk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__1, (ftnlen)12); + } + goto L190; +/* Test ZHER2K, 08, ZSYR2K, 09. */ +L180: + if (corder) { + zchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, + ct, g, w, &c__0, (ftnlen)12); + } + if (rorder) { + zchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, + ct, g, w, &c__1, (ftnlen)12); + } + goto L190; + +L190: + if (fatal && sfatal) { + goto L210; + } + } +/* L200: */ + } + printf("\nEND OF TESTS\n"); + goto L230; + +L210: + printf("\n****** FATAL ERROR - TESTS ABANDONED ******\n"); + goto L230; + +L220: + printf("AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM\n"); + printf("****** TESTS ABANDONED ******\n"); + +L230: + if (trace) { +/* cl__1.cerr = 0; + cl__1.cunit = ntra; + cl__1.csta = 0; + f_clos(&cl__1);*/ + } +/* cl__1.cerr = 0; + cl__1.cunit = 6; + cl__1.csta = 0; + f_clos(&cl__1);*/ + exit(0); + +/* End of ZBLAT3. */ + +} /* MAIN__ */ + +/* Subroutine */ int zchk1_(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, sname_len) +char *sname; +doublereal *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nalf; +doublecomplex *alf; +integer *nbet; +doublecomplex *bet; +integer *nmax; +doublecomplex *a, *aa, *as, *b, *bb, *bs, *c__, *cc, *cs, *ct; +doublereal *g; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ich[3+1] = "NTC"; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5, i__6, i__7, i__8; + + /* Local variables */ + static doublecomplex beta; + static integer ldas, ldbs, ldcs; + static logical same, null; + static integer i__, k, m, n; + static doublecomplex alpha; + static logical isame[13], trana, tranb; + extern /* Subroutine */ int zmake_(); + static integer nargs; + extern /* Subroutine */ int zmmch_(); + static logical reset; + static integer ia, ib; + extern /* Subroutine */ int zprcn1_(); + static integer ma, mb, na, nb, nc, ik, im, in, ks, ms, ns; + extern /* Subroutine */ int czgemm_(); + static char tranas[1], tranbs[1], transa[1], transb[1]; + static doublereal errmax; + extern logical lzeres_(); + static integer ica, icb, laa, lbb, lda, lcc, ldb, ldc; + static doublecomplex als, bls; + static doublereal err; + extern logical lze_(); + +/* Tests ZGEMM. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --alf; + --bet; + --g; + --ct; + --cs; + --cc; + c_dim1 = *nmax; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --bs; + --bb; + b_dim1 = *nmax; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ +/* .. Executable Statements .. */ + + nargs = 13; + nc = 0; + reset = TRUE_; + errmax = 0.; + + i__1 = *nidim; + for (im = 1; im <= i__1; ++im) { + m = idim[im]; + + i__2 = *nidim; + for (in = 1; in <= i__2; ++in) { + n = idim[in]; +/* Set LDC to 1 more than minimum value if room. */ + ldc = m; + if (ldc < *nmax) { + ++ldc; + } +/* Skip tests if not enough room. */ + if (ldc > *nmax) { + goto L100; + } + lcc = ldc * n; + null = n <= 0 || m <= 0; + + i__3 = *nidim; + for (ik = 1; ik <= i__3; ++ik) { + k = idim[ik]; + + for (ica = 1; ica <= 3; ++ica) { + *(unsigned char *)transa = *(unsigned char *)&ich[ica - 1] + ; + trana = *(unsigned char *)transa == 'T' || *(unsigned + char *)transa == 'C'; + + if (trana) { + ma = k; + na = m; + } else { + ma = m; + na = k; + } +/* Set LDA to 1 more than minimum value if room. */ + lda = ma; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L80; + } + laa = lda * na; + +/* Generate the matrix A. */ + + zmake_("ge", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[ + 1], &lda, &reset, &c_b1, (ftnlen)2, (ftnlen)1, ( + ftnlen)1); + + for (icb = 1; icb <= 3; ++icb) { + *(unsigned char *)transb = *(unsigned char *)&ich[icb + - 1]; + tranb = *(unsigned char *)transb == 'T' || *(unsigned + char *)transb == 'C'; + + if (tranb) { + mb = n; + nb = k; + } else { + mb = k; + nb = n; + } +/* Set LDB to 1 more than minimum value if room. */ + ldb = mb; + if (ldb < *nmax) { + ++ldb; + } +/* Skip tests if not enough room. */ + if (ldb > *nmax) { + goto L70; + } + lbb = ldb * nb; + +/* Generate the matrix B. */ + + zmake_("ge", " ", " ", &mb, &nb, &b[b_offset], nmax, & + bb[1], &ldb, &reset, &c_b1, (ftnlen)2, ( + ftnlen)1, (ftnlen)1); + + i__4 = *nalf; + for (ia = 1; ia <= i__4; ++ia) { + i__5 = ia; + alpha.r = alf[i__5].r, alpha.i = alf[i__5].i; + + i__5 = *nbet; + for (ib = 1; ib <= i__5; ++ib) { + i__6 = ib; + beta.r = bet[i__6].r, beta.i = bet[i__6].i; + +/* Generate the matrix C. */ + + zmake_("ge", " ", " ", &m, &n, &c__[c_offset], + nmax, &cc[1], &ldc, &reset, &c_b1, ( + ftnlen)2, (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the */ +/* subroutine. */ + + *(unsigned char *)tranas = *(unsigned char *) + transa; + *(unsigned char *)tranbs = *(unsigned char *) + transb; + ms = m; + ns = n; + ks = k; + als.r = alpha.r, als.i = alpha.i; + i__6 = laa; + for (i__ = 1; i__ <= i__6; ++i__) { + i__7 = i__; + i__8 = i__; + as[i__7].r = aa[i__8].r, as[i__7].i = aa[ + i__8].i; +/* L10: */ + } + ldas = lda; + i__6 = lbb; + for (i__ = 1; i__ <= i__6; ++i__) { + i__7 = i__; + i__8 = i__; + bs[i__7].r = bb[i__8].r, bs[i__7].i = bb[ + i__8].i; +/* L20: */ + } + ldbs = ldb; + bls.r = beta.r, bls.i = beta.i; + i__6 = lcc; + for (i__ = 1; i__ <= i__6; ++i__) { + i__7 = i__; + i__8 = i__; + cs[i__7].r = cc[i__8].r, cs[i__7].i = cc[ + i__8].i; +/* L30: */ + } + ldcs = ldc; + +/* Call the subroutine. */ + + if (*trace) { + zprcn1_(ntra, &nc, sname, iorder, transa, + transb, &m, &n, &k, &alpha, &lda, + &ldb, &beta, &ldc, (ftnlen)12, ( + ftnlen)1, (ftnlen)1); + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + czgemm_(iorder, transa, transb, &m, &n, &k, & + alpha, &aa[1], &lda, &bb[1], &ldb, & + beta, &cc[1], &ldc, (ftnlen)1, ( + ftnlen)1); + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf(" *** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + *fatal = TRUE_; + goto L120; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)transa == *( + unsigned char *)tranas; + isame[1] = *(unsigned char *)transb == *( + unsigned char *)tranbs; + isame[2] = ms == m; + isame[3] = ns == n; + isame[4] = ks == k; + isame[5] = als.r == alpha.r && als.i == + alpha.i; + isame[6] = lze_(&as[1], &aa[1], &laa); + isame[7] = ldas == lda; + isame[8] = lze_(&bs[1], &bb[1], &lbb); + isame[9] = ldbs == ldb; + isame[10] = bls.r == beta.r && bls.i == + beta.i; + if (null) { + isame[11] = lze_(&cs[1], &cc[1], &lcc); + } else { + isame[11] = lzeres_("ge", " ", &m, &n, & + cs[1], &cc[1], &ldc, (ftnlen)2, ( + ftnlen)1); + } + isame[12] = ldcs == ldc; + +/* If data was incorrectly changed, report */ +/* and return. */ + + same = TRUE_; + i__6 = nargs; + for (i__ = 1; i__ <= i__6; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L120; + } + + if (! null) { + +/* Check the result. */ + + zmmch_(transa, transb, &m, &n, &k, &alpha, + &a[a_offset], nmax, &b[b_offset], + nmax, &beta, &c__[c_offset], + nmax, &ct[1], &g[1], &cc[1], &ldc, + eps, &err, fatal, nout, &c_true, + (ftnlen)1, (ftnlen)1); + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L120; + } + } + +/* L50: */ + } + +/* L60: */ + } + +L70: + ; + } + +L80: + ; + } + +/* L90: */ + } + +L100: + ; + } + +/* L110: */ + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + if (*iorder == 1) { + printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + } + goto L130; + +L120: + printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + zprcn1_(nout, &nc, sname, iorder, transa, transb, &m, &n, &k, &alpha, & + lda, &ldb, &beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); + +L130: + return 0; + +/* 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',', */ +/* $ 3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, */ +/* $ ',(', F4.1, ',', F4.1, '), C,', I3, ').' ) */ + +/* End of ZCHK1. */ + +} /* zchk1_ */ + + +/* Subroutine */ int zprcn1_(nout, nc, sname, iorder, transa, transb, m, n, k, + alpha, lda, ldb, beta, ldc, sname_len, transa_len, transb_len) +integer *nout, *nc; +char *sname; +integer *iorder; +char *transa, *transb; +integer *m, *n, *k; +doublecomplex *alpha; +integer *lda, *ldb; +doublecomplex *beta; +integer *ldc; +ftnlen sname_len; +ftnlen transa_len; +ftnlen transb_len; +{ + /* Local variables */ + static char crc[14], cta[14], ctb[14]; + + if (*(unsigned char *)transa == 'N') { + s_copy(cta, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transa == 'T') { + s_copy(cta, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cta, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)transb == 'N') { + s_copy(ctb, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transb == 'T') { + s_copy(ctb, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(ctb, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*iorder == 1) { + s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); + } else { + s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); + } + printf("%6d: %s %s %s %s\n",*nc,sname,crc,cta,ctb); + printf("%d %d %d (%4.1lf,%4.1lf) , A, %d, B, %d, (%4.1lf,%4.1lf) , C, %d.\n",*m,*n,*k,alpha->r,alpha->i,*lda,*ldb,beta->r,beta->i,*ldc); + +return 0; +} /* zprcn1_ */ + + +/* Subroutine */ int zchk2_(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, sname_len) +char *sname; +doublereal *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nalf; +doublecomplex *alf; +integer *nbet; +doublecomplex *bet; +integer *nmax; +doublecomplex *a, *aa, *as, *b, *bb, *bs, *c__, *cc, *cs, *ct; +doublereal *g; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ichs[2+1] = "LR"; + static char ichu[2+1] = "UL"; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5, i__6, i__7; + + /* Local variables */ + static doublecomplex beta; + static integer ldas, ldbs, ldcs; + static logical same; + static char side[1]; + static logical isconj, left, null; + static char uplo[1]; + static integer i__, m, n; + static doublecomplex alpha; + static logical isame[13]; + static char sides[1]; + extern /* Subroutine */ int zmake_(); + static integer nargs; + extern /* Subroutine */ int zmmch_(); + static logical reset; + static char uplos[1]; + static integer ia, ib; + extern /* Subroutine */ int zprcn2_(); + static integer na, nc, im, in, ms, ns; + extern /* Subroutine */ int czhemm_(); + static doublereal errmax; + extern logical lzeres_(); + extern /* Subroutine */ int czsymm_(); + static integer laa, lbb, lda, lcc, ldb, ldc, ics; + static doublecomplex als, bls; + static integer icu; + static doublereal err; + extern logical lze_(); + +/* Tests ZHEMM and ZSYMM. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --alf; + --bet; + --g; + --ct; + --cs; + --cc; + c_dim1 = *nmax; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --bs; + --bb; + b_dim1 = *nmax; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ +/* .. Executable Statements .. */ + isconj = s_cmp(sname + 7, "he", (ftnlen)2, (ftnlen)2) == 0; + + nargs = 12; + nc = 0; + reset = TRUE_; + errmax = 0.; + + i__1 = *nidim; + for (im = 1; im <= i__1; ++im) { + m = idim[im]; + + i__2 = *nidim; + for (in = 1; in <= i__2; ++in) { + n = idim[in]; +/* Set LDC to 1 more than minimum value if room. */ + ldc = m; + if (ldc < *nmax) { + ++ldc; + } +/* Skip tests if not enough room. */ + if (ldc > *nmax) { + goto L90; + } + lcc = ldc * n; + null = n <= 0 || m <= 0; +/* Set LDB to 1 more than minimum value if room. */ + ldb = m; + if (ldb < *nmax) { + ++ldb; + } +/* Skip tests if not enough room. */ + if (ldb > *nmax) { + goto L90; + } + lbb = ldb * n; + +/* Generate the matrix B. */ + + zmake_("ge", " ", " ", &m, &n, &b[b_offset], nmax, &bb[1], &ldb, & + reset, &c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)1); + + for (ics = 1; ics <= 2; ++ics) { + *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1]; + left = *(unsigned char *)side == 'L'; + + if (left) { + na = m; + } else { + na = n; + } +/* Set LDA to 1 more than minimum value if room. */ + lda = na; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L80; + } + laa = lda * na; + + for (icu = 1; icu <= 2; ++icu) { + *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; + +/* Generate the hermitian or symmetric matrix A. */ + + zmake_(sname + 7, uplo, " ", &na, &na, &a[a_offset], nmax, + &aa[1], &lda, &reset, &c_b1, (ftnlen)2, (ftnlen) + 1, (ftnlen)1); + + i__3 = *nalf; + for (ia = 1; ia <= i__3; ++ia) { + i__4 = ia; + alpha.r = alf[i__4].r, alpha.i = alf[i__4].i; + + i__4 = *nbet; + for (ib = 1; ib <= i__4; ++ib) { + i__5 = ib; + beta.r = bet[i__5].r, beta.i = bet[i__5].i; + +/* Generate the matrix C. */ + + zmake_("ge", " ", " ", &m, &n, &c__[c_offset], + nmax, &cc[1], &ldc, &reset, &c_b1, ( + ftnlen)2, (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the */ +/* subroutine. */ + + *(unsigned char *)sides = *(unsigned char *)side; + *(unsigned char *)uplos = *(unsigned char *)uplo; + ms = m; + ns = n; + als.r = alpha.r, als.i = alpha.i; + i__5 = laa; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7] + .i; +/* L10: */ + } + ldas = lda; + i__5 = lbb; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + bs[i__6].r = bb[i__7].r, bs[i__6].i = bb[i__7] + .i; +/* L20: */ + } + ldbs = ldb; + bls.r = beta.r, bls.i = beta.i; + i__5 = lcc; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + cs[i__6].r = cc[i__7].r, cs[i__6].i = cc[i__7] + .i; +/* L30: */ + } + ldcs = ldc; + +/* Call the subroutine. */ + + if (*trace) { + zprcn2_(ntra, &nc, sname, iorder, side, uplo, + &m, &n, &alpha, &lda, &ldb, &beta, & + ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1) + ; + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + if (isconj) { + czhemm_(iorder, side, uplo, &m, &n, &alpha, & + aa[1], &lda, &bb[1], &ldb, &beta, &cc[ + 1], &ldc, (ftnlen)1, (ftnlen)1); + } else { + czsymm_(iorder, side, uplo, &m, &n, &alpha, & + aa[1], &lda, &bb[1], &ldb, &beta, &cc[ + 1], &ldc, (ftnlen)1, (ftnlen)1); + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + *fatal = TRUE_; + goto L110; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)sides == *(unsigned + char *)side; + isame[1] = *(unsigned char *)uplos == *(unsigned + char *)uplo; + isame[2] = ms == m; + isame[3] = ns == n; + isame[4] = als.r == alpha.r && als.i == alpha.i; + isame[5] = lze_(&as[1], &aa[1], &laa); + isame[6] = ldas == lda; + isame[7] = lze_(&bs[1], &bb[1], &lbb); + isame[8] = ldbs == ldb; + isame[9] = bls.r == beta.r && bls.i == beta.i; + if (null) { + isame[10] = lze_(&cs[1], &cc[1], &lcc); + } else { + isame[10] = lzeres_("ge", " ", &m, &n, &cs[1], + &cc[1], &ldc, (ftnlen)2, (ftnlen)1); + } + isame[11] = ldcs == ldc; + +/* If data was incorrectly changed, report and */ +/* return. */ + + same = TRUE_; + i__5 = nargs; + for (i__ = 1; i__ <= i__5; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L110; + } + + if (! null) { + +/* Check the result. */ + + if (left) { + zmmch_("N", "N", &m, &n, &m, &alpha, &a[ + a_offset], nmax, &b[b_offset], + nmax, &beta, &c__[c_offset], nmax, + &ct[1], &g[1], &cc[1], &ldc, eps, + &err, fatal, nout, &c_true, ( + ftnlen)1, (ftnlen)1); + } else { + zmmch_("N", "N", &m, &n, &n, &alpha, &b[ + b_offset], nmax, &a[a_offset], + nmax, &beta, &c__[c_offset], nmax, + &ct[1], &g[1], &cc[1], &ldc, eps, + &err, fatal, nout, &c_true, ( + ftnlen)1, (ftnlen)1); + } + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L110; + } + } + +/* L50: */ + } + +/* L60: */ + } + +/* L70: */ + } + +L80: + ; + } + +L90: + ; + } + +/* L100: */ + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + if (*iorder == 1) { + printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + } + goto L120; + +L110: + printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + zprcn2_(nout, &nc, sname, iorder, side, uplo, &m, &n, &alpha, &lda, &ldb, + &beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); + +L120: + return 0; + +/* 9995 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ +/* $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1, */ +/* $ ',', F4.1, '), C,', I3, ') .' ) */ + +/* End of ZCHK2. */ + +} /* zchk2_ */ + + +/* Subroutine */ int zprcn2_(nout, nc, sname, iorder, side, uplo, m, n, alpha, + lda, ldb, beta, ldc, sname_len, side_len, uplo_len) +integer *nout, *nc; +char *sname; +integer *iorder; +char *side, *uplo; +integer *m, *n; +doublecomplex *alpha; +integer *lda, *ldb; +doublecomplex *beta; +integer *ldc; +ftnlen sname_len; +ftnlen side_len; +ftnlen uplo_len; +{ + /* Local variables */ + static char cs[14], cu[14], crc[14]; + + if (*(unsigned char *)side == 'L') { + s_copy(cs, " CblasLeft", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cs, " CblasRight", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)uplo == 'U') { + s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); + } + if (*iorder == 1) { + s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); + } else { + s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); + } + printf("%6d: %s %s %s %s\n",*nc,sname,crc,cs,cu); + printf("%d %d (%4.1lf,%4.1lf) , A, %d, B, %d, (%4.1lf,%4.1lf) , C, %d.\n",*m,*n,alpha->r,alpha->i,*lda,*ldb,beta->r,beta->i,*ldc); + +return 0; +} /* zprcn2_ */ + + +/* Subroutine */ int zchk3_(sname, eps, thresh, nout, ntra, trace, rewi, + fatal, nidim, idim, nalf, alf, nmax, a, aa, as, b, bb, bs, ct, g, c__, + iorder, sname_len) +char *sname; +doublereal *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nalf; +doublecomplex *alf; +integer *nmax; +doublecomplex *a, *aa, *as, *b, *bb, *bs, *ct; +doublereal *g; +doublecomplex *c__; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char ichu[2+1] = "UL"; + static char icht[3+1] = "NTC"; + static char ichd[2+1] = "UN"; + static char ichs[2+1] = "LR"; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5, i__6, i__7; + doublecomplex z__1; + + /* Local variables */ + static char diag[1]; + static integer ldas, ldbs; + static logical same; + static char side[1]; + static logical left, null; + static char uplo[1]; + static integer i__, j, m, n; + static doublecomplex alpha; + static char diags[1]; + static logical isame[13]; + static char sides[1]; + extern /* Subroutine */ int zmake_(); + static integer nargs; + extern /* Subroutine */ int zmmch_(); + static logical reset; + static char uplos[1]; + static integer ia, na; + extern /* Subroutine */ int zprcn3_(); + static integer nc, im, in, ms, ns; + static char tranas[1], transa[1]; + static doublereal errmax; + extern logical lzeres_(); + extern /* Subroutine */ int cztrmm_(), cztrsm_(); + static integer laa, icd, lbb, lda, ldb, ics; + static doublecomplex als; + static integer ict, icu; + static doublereal err; + extern logical lze_(); + +/* Tests ZTRMM and ZTRSM. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --alf; + c_dim1 = *nmax; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --g; + --ct; + --bs; + --bb; + b_dim1 = *nmax; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ +/* .. Executable Statements .. */ + + nargs = 11; + nc = 0; + reset = TRUE_; + errmax = 0.; +/* Set up zero matrix for ZMMCH. */ + i__1 = *nmax; + for (j = 1; j <= i__1; ++j) { + i__2 = *nmax; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; +/* L10: */ + } +/* L20: */ + } + + i__1 = *nidim; + for (im = 1; im <= i__1; ++im) { + m = idim[im]; + + i__2 = *nidim; + for (in = 1; in <= i__2; ++in) { + n = idim[in]; +/* Set LDB to 1 more than minimum value if room. */ + ldb = m; + if (ldb < *nmax) { + ++ldb; + } +/* Skip tests if not enough room. */ + if (ldb > *nmax) { + goto L130; + } + lbb = ldb * n; + null = m <= 0 || n <= 0; + + for (ics = 1; ics <= 2; ++ics) { + *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1]; + left = *(unsigned char *)side == 'L'; + if (left) { + na = m; + } else { + na = n; + } +/* Set LDA to 1 more than minimum value if room. */ + lda = na; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L130; + } + laa = lda * na; + + for (icu = 1; icu <= 2; ++icu) { + *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; + + for (ict = 1; ict <= 3; ++ict) { + *(unsigned char *)transa = *(unsigned char *)&icht[ + ict - 1]; + + for (icd = 1; icd <= 2; ++icd) { + *(unsigned char *)diag = *(unsigned char *)&ichd[ + icd - 1]; + + i__3 = *nalf; + for (ia = 1; ia <= i__3; ++ia) { + i__4 = ia; + alpha.r = alf[i__4].r, alpha.i = alf[i__4].i; + +/* Generate the matrix A. */ + + zmake_("tr", uplo, diag, &na, &na, &a[ + a_offset], nmax, &aa[1], &lda, &reset, + &c_b1, (ftnlen)2, (ftnlen)1, (ftnlen) + 1); + +/* Generate the matrix B. */ + + zmake_("ge", " ", " ", &m, &n, &b[b_offset], + nmax, &bb[1], &ldb, &reset, &c_b1, ( + ftnlen)2, (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the */ +/* subroutine. */ + + *(unsigned char *)sides = *(unsigned char *) + side; + *(unsigned char *)uplos = *(unsigned char *) + uplo; + *(unsigned char *)tranas = *(unsigned char *) + transa; + *(unsigned char *)diags = *(unsigned char *) + diag; + ms = m; + ns = n; + als.r = alpha.r, als.i = alpha.i; + i__4 = laa; + for (i__ = 1; i__ <= i__4; ++i__) { + i__5 = i__; + i__6 = i__; + as[i__5].r = aa[i__6].r, as[i__5].i = aa[ + i__6].i; +/* L30: */ + } + ldas = lda; + i__4 = lbb; + for (i__ = 1; i__ <= i__4; ++i__) { + i__5 = i__; + i__6 = i__; + bs[i__5].r = bb[i__6].r, bs[i__5].i = bb[ + i__6].i; +/* L40: */ + } + ldbs = ldb; + +/* Call the subroutine. */ + + if (s_cmp(sname + 9, "mm", (ftnlen)2, (ftnlen) + 2) == 0) { + if (*trace) { + zprcn3_(ntra, &nc, sname, iorder, + side, uplo, transa, diag, &m, + &n, &alpha, &lda, &ldb, ( + ftnlen)12, (ftnlen)1, (ftnlen) + 1, (ftnlen)1, (ftnlen)1); + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cztrmm_(iorder, side, uplo, transa, diag, + &m, &n, &alpha, &aa[1], &lda, &bb[ + 1], &ldb, (ftnlen)1, (ftnlen)1, ( + ftnlen)1, (ftnlen)1); + } else if (s_cmp(sname + 9, "sm", (ftnlen)2, ( + ftnlen)2) == 0) { + if (*trace) { + zprcn3_(ntra, &nc, sname, iorder, + side, uplo, transa, diag, &m, + &n, &alpha, &lda, &ldb, ( + ftnlen)12, (ftnlen)1, (ftnlen) + 1, (ftnlen)1, (ftnlen)1); + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + cztrsm_(iorder, side, uplo, transa, diag, + &m, &n, &alpha, &aa[1], &lda, &bb[ + 1], &ldb, (ftnlen)1, (ftnlen)1, ( + ftnlen)1, (ftnlen)1); + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + *fatal = TRUE_; + goto L150; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)sides == *( + unsigned char *)side; + isame[1] = *(unsigned char *)uplos == *( + unsigned char *)uplo; + isame[2] = *(unsigned char *)tranas == *( + unsigned char *)transa; + isame[3] = *(unsigned char *)diags == *( + unsigned char *)diag; + isame[4] = ms == m; + isame[5] = ns == n; + isame[6] = als.r == alpha.r && als.i == + alpha.i; + isame[7] = lze_(&as[1], &aa[1], &laa); + isame[8] = ldas == lda; + if (null) { + isame[9] = lze_(&bs[1], &bb[1], &lbb); + } else { + isame[9] = lzeres_("ge", " ", &m, &n, &bs[ + 1], &bb[1], &ldb, (ftnlen)2, ( + ftnlen)1); + } + isame[10] = ldbs == ldb; + +/* If data was incorrectly changed, report and */ +/* return. */ + + same = TRUE_; + i__4 = nargs; + for (i__ = 1; i__ <= i__4; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L50: */ + } + if (! same) { + *fatal = TRUE_; + goto L150; + } + + if (! null) { + if (s_cmp(sname + 9, "mm", (ftnlen)2, ( + ftnlen)2) == 0) { + +/* Check the result. */ + + if (left) { + zmmch_(transa, "N", &m, &n, &m, & + alpha, &a[a_offset], nmax, + &b[b_offset], nmax, & + c_b1, &c__[c_offset], + nmax, &ct[1], &g[1], &bb[ + 1], &ldb, eps, &err, + fatal, nout, &c_true, ( + ftnlen)1, (ftnlen)1); + } else { + zmmch_("N", transa, &m, &n, &n, & + alpha, &b[b_offset], nmax, + &a[a_offset], nmax, & + c_b1, &c__[c_offset], + nmax, &ct[1], &g[1], &bb[ + 1], &ldb, eps, &err, + fatal, nout, &c_true, ( + ftnlen)1, (ftnlen)1); + } + } else if (s_cmp(sname + 9, "sm", (ftnlen) + 2, (ftnlen)2) == 0) { + +/* Compute approximation to original */ +/* matrix. */ + + i__4 = n; + for (j = 1; j <= i__4; ++j) { + i__5 = m; + for (i__ = 1; i__ <= i__5; ++i__) + { + i__6 = i__ + j * c_dim1; + i__7 = i__ + (j - 1) * ldb; + c__[i__6].r = bb[i__7].r, c__[i__6].i = bb[i__7].i; + i__6 = i__ + (j - 1) * ldb; + i__7 = i__ + j * b_dim1; + z__1.r = alpha.r * b[i__7].r - alpha.i * b[i__7].i, + z__1.i = alpha.r * b[i__7].i + alpha.i * b[ + i__7].r; + bb[i__6].r = z__1.r, bb[i__6].i = z__1.i; +/* L60: */ + } +/* L70: */ + } + + if (left) { + zmmch_(transa, "N", &m, &n, &m, & + c_b2, &a[a_offset], nmax, + &c__[c_offset], nmax, & + c_b1, &b[b_offset], nmax, + &ct[1], &g[1], &bb[1], & + ldb, eps, &err, fatal, + nout, &c_false, (ftnlen)1, + (ftnlen)1); + } else { + zmmch_("N", transa, &m, &n, &n, & + c_b2, &c__[c_offset], + nmax, &a[a_offset], nmax, + &c_b1, &b[b_offset], nmax, + &ct[1], &g[1], &bb[1], & + ldb, eps, &err, fatal, + nout, &c_false, (ftnlen)1, + (ftnlen)1); + } + } + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L150; + } + } + +/* L80: */ + } + +/* L90: */ + } + +/* L100: */ + } + +/* L110: */ + } + +/* L120: */ + } + +L130: + ; + } + +/* L140: */ + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + if (*iorder == 1) { + printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + } + goto L160; + +L150: + printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + if (*trace) { + zprcn3_(ntra, &nc, sname, iorder, side, uplo, transa, diag, &m, &n, & + alpha, &lda, &ldb, (ftnlen)12, (ftnlen)1, (ftnlen)1, (ftnlen) + 1, (ftnlen)1); + } + +L160: + return 0; + +/* 9995 FORMAT(1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( I3, ',' ), */ +/* $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ') ', */ +/* $ ' .' ) */ + +/* End of ZCHK3. */ + +} /* zchk3_ */ + + +/* Subroutine */ int zprcn3_(nout, nc, sname, iorder, side, uplo, transa, + diag, m, n, alpha, lda, ldb, sname_len, side_len, uplo_len, + transa_len, diag_len) +integer *nout, *nc; +char *sname; +integer *iorder; +char *side, *uplo, *transa, *diag; +integer *m, *n; +doublecomplex *alpha; +integer *lda, *ldb; +ftnlen sname_len; +ftnlen side_len; +ftnlen uplo_len; +ftnlen transa_len; +ftnlen diag_len; +{ + + /* Local variables */ + static char ca[14], cd[14], cs[14], cu[14], crc[14]; + + if (*(unsigned char *)side == 'L') { + s_copy(cs, " CblasLeft", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cs, " CblasRight", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)uplo == 'U') { + s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)transa == 'N') { + s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transa == 'T') { + s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)diag == 'N') { + s_copy(cd, " CblasNonUnit", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cd, " CblasUnit", (ftnlen)14, (ftnlen)14); + } + if (*iorder == 1) { + s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); + } else { + s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); + } + printf("%6d: %s %s %s %s\n",*nc,sname,crc,cs,cu); + printf(" %s %s %d %d (%4.1lf,%4.1lf) A %d B %d\n",ca,cd,*m,*n,alpha->r,alpha->i,*lda,*ldb); + +return 0; +} /* zprcn3_ */ + + +/* Subroutine */ int 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, sname_len) +char *sname; +doublereal *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nalf; +doublecomplex *alf; +integer *nbet; +doublecomplex *bet; +integer *nmax; +doublecomplex *a, *aa, *as, *b, *bb, *bs, *c__, *cc, *cs, *ct; +doublereal *g; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char icht[2+1] = "NC"; + static char ichu[2+1] = "UL"; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5, i__6, i__7; + doublecomplex z__1; + + /* Local variables */ + static doublecomplex beta; + static integer ldas, ldcs; + static logical same, isconj; + static doublecomplex bets; + static doublereal rals; + static logical tran, null; + static char uplo[1]; + static integer i__, j, k, n; + static doublecomplex alpha; + static doublereal rbeta; + static logical isame[13]; + extern /* Subroutine */ int zmake_(); + static integer nargs; + extern /* Subroutine */ int zmmch_(); + static doublereal rbets; + static logical reset; + static char trans[1]; + static logical upper; + static char uplos[1]; + static integer ia, ib, jc, ma, na; + extern /* Subroutine */ int zprcn4_(); + static integer nc; + extern /* Subroutine */ int zprcn6_(); + static integer ik, in, jj, lj, ks, ns; + static doublereal ralpha; + extern /* Subroutine */ int czherk_(); + static doublereal errmax; + extern logical lzeres_(); + static char transs[1], transt[1]; + extern /* Subroutine */ int czsyrk_(); + static integer laa, lda, lcc, ldc; + static doublecomplex als; + static integer ict, icu; + static doublereal err; + extern logical lze_(); + +/* Tests ZHERK and ZSYRK. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --alf; + --bet; + --g; + --ct; + --cs; + --cc; + c_dim1 = *nmax; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --bs; + --bb; + b_dim1 = *nmax; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ +/* .. Executable Statements .. */ + isconj = s_cmp(sname + 7, "he", (ftnlen)2, (ftnlen)2) == 0; + + nargs = 10; + nc = 0; + reset = TRUE_; + errmax = 0.; + rals = 1.; + rbets = 1.; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; +/* Set LDC to 1 more than minimum value if room. */ + ldc = n; + if (ldc < *nmax) { + ++ldc; + } +/* Skip tests if not enough room. */ + if (ldc > *nmax) { + goto L100; + } + lcc = ldc * n; + + i__2 = *nidim; + for (ik = 1; ik <= i__2; ++ik) { + k = idim[ik]; + + for (ict = 1; ict <= 2; ++ict) { + *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1]; + tran = *(unsigned char *)trans == 'C'; + if (tran && ! isconj) { + *(unsigned char *)trans = 'T'; + } + if (tran) { + ma = k; + na = n; + } else { + ma = n; + na = k; + } +/* Set LDA to 1 more than minimum value if room. */ + lda = ma; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L80; + } + laa = lda * na; + +/* Generate the matrix A. */ + + zmake_("ge", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[1], & + lda, &reset, &c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)1); + + for (icu = 1; icu <= 2; ++icu) { + *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; + upper = *(unsigned char *)uplo == 'U'; + + i__3 = *nalf; + for (ia = 1; ia <= i__3; ++ia) { + i__4 = ia; + alpha.r = alf[i__4].r, alpha.i = alf[i__4].i; + if (isconj) { + ralpha = alpha.r; + z__1.r = ralpha, z__1.i = 0.; + alpha.r = z__1.r, alpha.i = z__1.i; + } + + i__4 = *nbet; + for (ib = 1; ib <= i__4; ++ib) { + i__5 = ib; + beta.r = bet[i__5].r, beta.i = bet[i__5].i; + if (isconj) { + rbeta = beta.r; + z__1.r = rbeta, z__1.i = 0.; + beta.r = z__1.r, beta.i = z__1.i; + } + null = n <= 0; + if (isconj) { + null = null ||( (k <= 0 || ralpha == 0.) && + rbeta == 1.); + } + +/* Generate the matrix C. */ + + zmake_(sname + 7, uplo, " ", &n, &n, &c__[ + c_offset], nmax, &cc[1], &ldc, &reset, & + c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the subroutine. */ + + *(unsigned char *)uplos = *(unsigned char *)uplo; + *(unsigned char *)transs = *(unsigned char *) + trans; + ns = n; + ks = k; + if (isconj) { + rals = ralpha; + } else { + als.r = alpha.r, als.i = alpha.i; + } + i__5 = laa; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7] + .i; +/* L10: */ + } + ldas = lda; + if (isconj) { + rbets = rbeta; + } else { + bets.r = beta.r, bets.i = beta.i; + } + i__5 = lcc; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + cs[i__6].r = cc[i__7].r, cs[i__6].i = cc[i__7] + .i; +/* L20: */ + } + ldcs = ldc; + +/* Call the subroutine. */ + + if (isconj) { + if (*trace) { + zprcn6_(ntra, &nc, sname, iorder, uplo, + trans, &n, &k, &ralpha, &lda, & + rbeta, &ldc, (ftnlen)12, (ftnlen) + 1, (ftnlen)1); + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + czherk_(iorder, uplo, trans, &n, &k, &ralpha, + &aa[1], &lda, &rbeta, &cc[1], &ldc, ( + ftnlen)1, (ftnlen)1); + } else { + if (*trace) { + zprcn4_(ntra, &nc, sname, iorder, uplo, + trans, &n, &k, &alpha, &lda, & + beta, &ldc, (ftnlen)12, (ftnlen)1, + (ftnlen)1); + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + czsyrk_(iorder, uplo, trans, &n, &k, &alpha, & + aa[1], &lda, &beta, &cc[1], &ldc, ( + ftnlen)1, (ftnlen)1); + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + *fatal = TRUE_; + goto L120; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)uplos == *(unsigned + char *)uplo; + isame[1] = *(unsigned char *)transs == *(unsigned + char *)trans; + isame[2] = ns == n; + isame[3] = ks == k; + if (isconj) { + isame[4] = rals == ralpha; + } else { + isame[4] = als.r == alpha.r && als.i == + alpha.i; + } + isame[5] = lze_(&as[1], &aa[1], &laa); + isame[6] = ldas == lda; + if (isconj) { + isame[7] = rbets == rbeta; + } else { + isame[7] = bets.r == beta.r && bets.i == + beta.i; + } + if (null) { + isame[8] = lze_(&cs[1], &cc[1], &lcc); + } else { + isame[8] = lzeres_(sname + 7, uplo, &n, &n, & + cs[1], &cc[1], &ldc, (ftnlen)2, ( + ftnlen)1); + } + isame[9] = ldcs == ldc; + +/* If data was incorrectly changed, report and */ +/* return. */ + + same = TRUE_; + i__5 = nargs; + for (i__ = 1; i__ <= i__5; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L30: */ + } + if (! same) { + *fatal = TRUE_; + goto L120; + } + + if (! null) { + +/* Check the result column by column. */ + + if (isconj) { + *(unsigned char *)transt = 'C'; + } else { + *(unsigned char *)transt = 'T'; + } + jc = 1; + i__5 = n; + for (j = 1; j <= i__5; ++j) { + if (upper) { + jj = 1; + lj = j; + } else { + jj = j; + lj = n - j + 1; + } + if (tran) { + zmmch_(transt, "N", &lj, &c__1, &k, & + alpha, &a[jj * a_dim1 + 1], + nmax, &a[j * a_dim1 + 1], + nmax, &beta, &c__[jj + j * + c_dim1], nmax, &ct[1], &g[1], + &cc[jc], &ldc, eps, &err, + fatal, nout, &c_true, (ftnlen) + 1, (ftnlen)1); + } else { + zmmch_("N", transt, &lj, &c__1, &k, & + alpha, &a[jj + a_dim1], nmax, + &a[j + a_dim1], nmax, &beta, & + c__[jj + j * c_dim1], nmax, & + ct[1], &g[1], &cc[jc], &ldc, + eps, &err, fatal, nout, & + c_true, (ftnlen)1, (ftnlen)1); + } + if (upper) { + jc += ldc; + } else { + jc = jc + ldc + 1; + } + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L110; + } +/* L40: */ + } + } + +/* L50: */ + } + +/* L60: */ + } + +/* L70: */ + } + +L80: + ; + } + +/* L90: */ + } + +L100: + ; + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + if (*iorder == 1) { + printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + } + goto L130; + +L110: + if (n > 1) { + printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j); + } + +L120: + printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + if (isconj) { + zprcn6_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &ralpha, &lda, + &rbeta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); + } else { + zprcn4_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, & + beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); + } + +L130: + return 0; + +/* 9994 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ +/* $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') ', */ +/* $ ' .' ) */ +/* 9993 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ +/* $ '(', F4.1, ',', F4.1, ') , A,', I3, ',(', F4.1, ',', F4.1, */ +/* $ '), C,', I3, ') .' ) */ + +/* End of CCHK4. */ + +} /* zchk4_ */ + + +/* Subroutine */ int zprcn4_(nout, nc, sname, iorder, uplo, transa, n, k, + alpha, lda, beta, ldc, sname_len, uplo_len, transa_len) +integer *nout, *nc; +char *sname; +integer *iorder; +char *uplo, *transa; +integer *n, *k; +doublecomplex *alpha; +integer *lda; +doublecomplex *beta; +integer *ldc; +ftnlen sname_len; +ftnlen uplo_len; +ftnlen transa_len; +{ + /* Local variables */ + static char ca[14], cu[14], crc[14]; + + if (*(unsigned char *)uplo == 'U') { + s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)transa == 'N') { + s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transa == 'T') { + s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*iorder == 1) { + s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); + } else { + s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); + } + printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); + printf("( %d %d (%4.1lf,%4.1lf) A %d (%4.1lf,%4.1lf) C %d\n",*n,*k,alpha->r,alpha->i,*lda,beta->r,beta->i,*ldc); + +return 0; +} /* zprcn4_ */ + + + +/* Subroutine */ int zprcn6_(nout, nc, sname, iorder, uplo, transa, n, k, + alpha, lda, beta, ldc, sname_len, uplo_len, transa_len) +integer *nout, *nc; +char *sname; +integer *iorder; +char *uplo, *transa; +integer *n, *k; +doublereal *alpha; +integer *lda; +doublereal *beta; +integer *ldc; +ftnlen sname_len; +ftnlen uplo_len; +ftnlen transa_len; +{ + + /* Local variables */ + static char ca[14], cu[14], crc[14]; + + if (*(unsigned char *)uplo == 'U') { + s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)transa == 'N') { + s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transa == 'T') { + s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*iorder == 1) { + s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); + } else { + s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); + } + printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); + printf("( %d %d %4.1lf A %d %4.1lf C %d\n",*n,*k,*alpha,*lda,*beta,*ldc); + +return 0; +} /* zprcn6_ */ + + +/* Subroutine */ int zchk5_(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, sname_len) +char *sname; +doublereal *eps, *thresh; +integer *nout, *ntra; +logical *trace, *rewi, *fatal; +integer *nidim, *idim, *nalf; +doublecomplex *alf; +integer *nbet; +doublecomplex *bet; +integer *nmax; +doublecomplex *ab, *aa, *as, *bb, *bs, *c__, *cc, *cs, *ct; +doublereal *g; +doublecomplex *w; +integer *iorder; +ftnlen sname_len; +{ + /* Initialized data */ + + static char icht[2+1] = "NC"; + static char ichu[2+1] = "UL"; + + /* System generated locals */ + integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8; + doublecomplex z__1, z__2; + + /* Local variables */ + static integer jjab; + static doublecomplex beta; + static integer ldas, ldbs, ldcs; + static logical same, isconj; + static doublecomplex bets; + static logical tran, null; + static char uplo[1]; + static integer i__, j, k, n; + static doublecomplex alpha; + static doublereal rbeta; + static logical isame[13]; + extern /* Subroutine */ int zmake_(); + static integer nargs; + extern /* Subroutine */ int zmmch_(); + static doublereal rbets; + static logical reset; + static char trans[1]; + static logical upper; + static char uplos[1]; + static integer ia, ib, jc, ma, na, nc; + extern /* Subroutine */ int zprcn5_(), zprcn7_(); + static integer ik, in, jj, lj, ks, ns; + static doublereal errmax; + extern logical lzeres_(); + static char transs[1], transt[1]; + extern /* Subroutine */ int czher2k_(); + static integer laa, lbb, lda, lcc, ldb, ldc; + static doublecomplex als; + static integer ict, icu; + extern /* Subroutine */ int czsyr2k_(); + static doublereal err; + extern logical lze_(); + +/* Tests ZHER2K and ZSYR2K. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Local Arrays .. */ +/* .. External Functions .. */ +/* .. External Subroutines .. */ +/* .. Intrinsic Functions .. */ +/* .. Scalars in Common .. */ +/* .. Common blocks .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --idim; + --alf; + --bet; + --w; + --g; + --ct; + --cs; + --cc; + c_dim1 = *nmax; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --bs; + --bb; + --as; + --aa; + --ab; + + /* Function Body */ +/* .. Executable Statements .. */ + isconj = s_cmp(sname + 7, "he", (ftnlen)2, (ftnlen)2) == 0; + + nargs = 12; + nc = 0; + reset = TRUE_; + errmax = 0.; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; +/* Set LDC to 1 more than minimum value if room. */ + ldc = n; + if (ldc < *nmax) { + ++ldc; + } +/* Skip tests if not enough room. */ + if (ldc > *nmax) { + goto L130; + } + lcc = ldc * n; + + i__2 = *nidim; + for (ik = 1; ik <= i__2; ++ik) { + k = idim[ik]; + + for (ict = 1; ict <= 2; ++ict) { + *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1]; + tran = *(unsigned char *)trans == 'C'; + if (tran && ! isconj) { + *(unsigned char *)trans = 'T'; + } + if (tran) { + ma = k; + na = n; + } else { + ma = n; + na = k; + } +/* Set LDA to 1 more than minimum value if room. */ + lda = ma; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L110; + } + laa = lda * na; + +/* Generate the matrix A. */ + + if (tran) { + i__3 = *nmax << 1; + zmake_("ge", " ", " ", &ma, &na, &ab[1], &i__3, &aa[1], & + lda, &reset, &c_b1, (ftnlen)2, (ftnlen)1, (ftnlen) + 1); + } else { + zmake_("ge", " ", " ", &ma, &na, &ab[1], nmax, &aa[1], & + lda, &reset, &c_b1, (ftnlen)2, (ftnlen)1, (ftnlen) + 1); + } + +/* Generate the matrix B. */ + + ldb = lda; + lbb = laa; + if (tran) { + i__3 = *nmax << 1; + zmake_("ge", " ", " ", &ma, &na, &ab[k + 1], &i__3, &bb[1] + , &ldb, &reset, &c_b1, (ftnlen)2, (ftnlen)1, ( + ftnlen)1); + } else { + zmake_("ge", " ", " ", &ma, &na, &ab[k * *nmax + 1], nmax, + &bb[1], &ldb, &reset, &c_b1, (ftnlen)2, (ftnlen) + 1, (ftnlen)1); + } + + for (icu = 1; icu <= 2; ++icu) { + *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; + upper = *(unsigned char *)uplo == 'U'; + + i__3 = *nalf; + for (ia = 1; ia <= i__3; ++ia) { + i__4 = ia; + alpha.r = alf[i__4].r, alpha.i = alf[i__4].i; + + i__4 = *nbet; + for (ib = 1; ib <= i__4; ++ib) { + i__5 = ib; + beta.r = bet[i__5].r, beta.i = bet[i__5].i; + if (isconj) { + rbeta = beta.r; + z__1.r = rbeta, z__1.i = 0.; + beta.r = z__1.r, beta.i = z__1.i; + } + null = n <= 0; + if (isconj) { + null = null ||( (k <= 0 || (alpha.r == 0. && + alpha.i == 0.)) && rbeta == 1.); + } + +/* Generate the matrix C. */ + + zmake_(sname + 7, uplo, " ", &n, &n, &c__[ + c_offset], nmax, &cc[1], &ldc, &reset, & + c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)1); + + ++nc; + +/* Save every datum before calling the subroutine. */ + + *(unsigned char *)uplos = *(unsigned char *)uplo; + *(unsigned char *)transs = *(unsigned char *) + trans; + ns = n; + ks = k; + als.r = alpha.r, als.i = alpha.i; + i__5 = laa; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7] + .i; +/* L10: */ + } + ldas = lda; + i__5 = lbb; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + bs[i__6].r = bb[i__7].r, bs[i__6].i = bb[i__7] + .i; +/* L20: */ + } + ldbs = ldb; + if (isconj) { + rbets = rbeta; + } else { + bets.r = beta.r, bets.i = beta.i; + } + i__5 = lcc; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + cs[i__6].r = cc[i__7].r, cs[i__6].i = cc[i__7] + .i; +/* L30: */ + } + ldcs = ldc; + +/* Call the subroutine. */ + + if (isconj) { + if (*trace) { + zprcn7_(ntra, &nc, sname, iorder, uplo, + trans, &n, &k, &alpha, &lda, &ldb, + &rbeta, &ldc, (ftnlen)12, ( + ftnlen)1, (ftnlen)1); + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + czher2k_(iorder, uplo, trans, &n, &k, &alpha, + &aa[1], &lda, &bb[1], &ldb, &rbeta, & + cc[1], &ldc, (ftnlen)1, (ftnlen)1); + } else { + if (*trace) { + zprcn5_(ntra, &nc, sname, iorder, uplo, + trans, &n, &k, &alpha, &lda, &ldb, + &beta, &ldc, (ftnlen)12, (ftnlen) + 1, (ftnlen)1); + } + if (*rewi) { +/* al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1);*/ + } + czsyr2k_(iorder, uplo, trans, &n, &k, &alpha, + &aa[1], &lda, &bb[1], &ldb, &beta, & + cc[1], &ldc, (ftnlen)1, (ftnlen)1); + } + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + *fatal = TRUE_; + goto L150; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)uplos == *(unsigned + char *)uplo; + isame[1] = *(unsigned char *)transs == *(unsigned + char *)trans; + isame[2] = ns == n; + isame[3] = ks == k; + isame[4] = als.r == alpha.r && als.i == alpha.i; + isame[5] = lze_(&as[1], &aa[1], &laa); + isame[6] = ldas == lda; + isame[7] = lze_(&bs[1], &bb[1], &lbb); + isame[8] = ldbs == ldb; + if (isconj) { + isame[9] = rbets == rbeta; + } else { + isame[9] = bets.r == beta.r && bets.i == + beta.i; + } + if (null) { + isame[10] = lze_(&cs[1], &cc[1], &lcc); + } else { + isame[10] = lzeres_("he", uplo, &n, &n, &cs[1] + , &cc[1], &ldc, (ftnlen)2, (ftnlen)1); + } + isame[11] = ldcs == ldc; + +/* If data was incorrectly changed, report and */ +/* return. */ + + same = TRUE_; + i__5 = nargs; + for (i__ = 1; i__ <= i__5; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L150; + } + + if (! null) { + +/* Check the result column by column. */ + + if (isconj) { + *(unsigned char *)transt = 'C'; + } else { + *(unsigned char *)transt = 'T'; + } + jjab = 1; + jc = 1; + i__5 = n; + for (j = 1; j <= i__5; ++j) { + if (upper) { + jj = 1; + lj = j; + } else { + jj = j; + lj = n - j + 1; + } + if (tran) { + i__6 = k; + for (i__ = 1; i__ <= i__6; ++i__) { + i__7 = i__; + i__8 = ((j - 1) << 1) * *nmax + k + + i__; + z__1.r = alpha.r * ab[i__8].r - + alpha.i * ab[i__8].i, + z__1.i = alpha.r * ab[ + i__8].i + alpha.i * ab[ + i__8].r; + w[i__7].r = z__1.r, w[i__7].i = + z__1.i; + if (isconj) { + i__7 = k + i__; + d_cnjg(&z__2, &alpha); + i__8 = ((j - 1) << 1) * *nmax + i__; + z__1.r = z__2.r * ab[i__8].r - z__2.i * ab[i__8].i, + z__1.i = z__2.r * ab[i__8].i + z__2.i * ab[ + i__8].r; + w[i__7].r = z__1.r, w[i__7].i = z__1.i; + } else { + i__7 = k + i__; + i__8 = ((j - 1) << 1) * *nmax + i__; + z__1.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8] + .i, z__1.i = alpha.r * ab[i__8].i + alpha.i + * ab[i__8].r; + w[i__7].r = z__1.r, w[i__7].i = z__1.i; + } +/* L50: */ + } + i__6 = k << 1; + i__7 = *nmax << 1; + i__8 = *nmax << 1; + zmmch_(transt, "N", &lj, &c__1, &i__6, + &c_b2, &ab[jjab], &i__7, &w[ + 1], &i__8, &beta, &c__[jj + j + * c_dim1], nmax, &ct[1], &g[1] + , &cc[jc], &ldc, eps, &err, + fatal, nout, &c_true, (ftnlen) + 1, (ftnlen)1); + } else { + i__6 = k; + for (i__ = 1; i__ <= i__6; ++i__) { + if (isconj) { + i__7 = i__; + d_cnjg(&z__2, &ab[(k + i__ - 1) * *nmax + j]); + z__1.r = alpha.r * z__2.r - alpha.i * z__2.i, + z__1.i = alpha.r * z__2.i + alpha.i * + z__2.r; + w[i__7].r = z__1.r, w[i__7].i = z__1.i; + i__7 = k + i__; + i__8 = (i__ - 1) * *nmax + j; + z__2.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8] + .i, z__2.i = alpha.r * ab[i__8].i + alpha.i + * ab[i__8].r; + d_cnjg(&z__1, &z__2); + w[i__7].r = z__1.r, w[i__7].i = z__1.i; + } else { + i__7 = i__; + i__8 = (k + i__ - 1) * *nmax + j; + z__1.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8] + .i, z__1.i = alpha.r * ab[i__8].i + alpha.i + * ab[i__8].r; + w[i__7].r = z__1.r, w[i__7].i = z__1.i; + i__7 = k + i__; + i__8 = (i__ - 1) * *nmax + j; + z__1.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8] + .i, z__1.i = alpha.r * ab[i__8].i + alpha.i + * ab[i__8].r; + w[i__7].r = z__1.r, w[i__7].i = z__1.i; + } +/* L60: */ + } + i__6 = k << 1; + i__7 = *nmax << 1; + zmmch_("N", "N", &lj, &c__1, &i__6, & + c_b2, &ab[jj], nmax, &w[1], & + i__7, &beta, &c__[jj + j * + c_dim1], nmax, &ct[1], &g[1], + &cc[jc], &ldc, eps, &err, + fatal, nout, &c_true, (ftnlen) + 1, (ftnlen)1); + } + if (upper) { + jc += ldc; + } else { + jc = jc + ldc + 1; + if (tran) { + jjab += *nmax << 1; + } + } + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L140; + } +/* L70: */ + } + } + +/* L80: */ + } + +/* L90: */ + } + +/* L100: */ + } + +L110: + ; + } + +/* L120: */ + } + +L130: + ; + } + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + if (*iorder == 1) { + printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + } + } else { + if (*iorder == 0) { + printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + if (*iorder == 1) { + printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); + printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + } + } + goto L160; + +L140: + if (n > 1) { + printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j); + } + +L150: + printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + if (isconj) { + zprcn7_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, & + ldb, &rbeta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); + } else { + zprcn5_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, & + ldb, &beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); + } + +L160: + return 0; + +/* 9994 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ +/* $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',', F4.1, */ +/* $ ', C,', I3, ') .' ) */ +/* 9993 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ +/* $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1, */ +/* $ ',', F4.1, '), C,', I3, ') .' ) */ + +/* End of ZCHK5. */ + +} /* zchk5_ */ + + +/* Subroutine */ int zprcn5_(nout, nc, sname, iorder, uplo, transa, n, k, + alpha, lda, ldb, beta, ldc, sname_len, uplo_len, transa_len) +integer *nout, *nc; +char *sname; +integer *iorder; +char *uplo, *transa; +integer *n, *k; +doublecomplex *alpha; +integer *lda, *ldb; +doublecomplex *beta; +integer *ldc; +ftnlen sname_len; +ftnlen uplo_len; +ftnlen transa_len; +{ + /* Local variables */ + static char ca[14], cu[14], crc[14]; + + if (*(unsigned char *)uplo == 'U') { + s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)transa == 'N') { + s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transa == 'T') { + s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*iorder == 1) { + s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); + } else { + s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); + } + printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); + printf("%d %d (%4.1lf,%4.1lf) , A, %d, B, %d, (%4.1lf,%4.1lf) , C, %d.\n",*n,*k,alpha->r,alpha->i,*lda,*ldb,beta->r,beta->i,*ldc); + +return 0; +} /* zprcn5_ */ + + + +/* Subroutine */ int zprcn7_(nout, nc, sname, iorder, uplo, transa, n, k, + alpha, lda, ldb, beta, ldc, sname_len, uplo_len, transa_len) +integer *nout, *nc; +char *sname; +integer *iorder; +char *uplo, *transa; +integer *n, *k; +doublecomplex *alpha; +integer *lda, *ldb; +doublereal *beta; +integer *ldc; +ftnlen sname_len; +ftnlen uplo_len; +ftnlen transa_len; +{ + + /* Local variables */ + static char ca[14], cu[14], crc[14]; + + if (*(unsigned char *)uplo == 'U') { + s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)transa == 'N') { + s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transa == 'T') { + s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*iorder == 1) { + s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); + } else { + s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); + } + printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); + printf("%d %d (%4.1lf,%4.1lf), A, %d, B, %d, %4.1lf, C, %d.\n",*n,*k,alpha->r,alpha->i,*lda,*ldb,*beta,*ldc); + +return 0; +} /* zprcn7_ */ + + +/* Subroutine */ int zmake_(type__, uplo, diag, m, n, a, nmax, aa, lda, reset, + transl, type_len, uplo_len, diag_len) +char *type__, *uplo, *diag; +integer *m, *n; +doublecomplex *a; +integer *nmax; +doublecomplex *aa; +integer *lda; +logical *reset; +doublecomplex *transl; +ftnlen type_len; +ftnlen uplo_len; +ftnlen diag_len; +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + doublereal d__1; + doublecomplex z__1, z__2; + + /* Local variables */ + static integer ibeg, iend; + extern /* Double Complex */ VOID zbeg_(); + static logical unit; + static integer i__, j; + static logical lower, upper; + static integer jj; + static logical gen, her, tri, sym; + + +/* Generates values for an M by N matrix A. */ +/* Stores the values in the array AA in the data structure required */ +/* by the routine, with unwanted elements set to rogue value. */ + +/* TYPE is 'ge', 'he', 'sy' or 'tr'. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. External Functions .. */ +/* .. Intrinsic Functions .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + a_dim1 = *nmax; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --aa; + + /* Function Body */ + gen = s_cmp(type__, "ge", (ftnlen)2, (ftnlen)2) == 0; + her = s_cmp(type__, "he", (ftnlen)2, (ftnlen)2) == 0; + sym = s_cmp(type__, "sy", (ftnlen)2, (ftnlen)2) == 0; + tri = s_cmp(type__, "tr", (ftnlen)2, (ftnlen)2) == 0; + upper = (her || sym || tri) && *(unsigned char *)uplo == 'U'; + lower = (her || sym || tri) && *(unsigned char *)uplo == 'L'; + unit = tri && *(unsigned char *)diag == 'U'; + +/* Generate data in array A. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + if (gen || (upper && i__ <= j) || (lower && i__ >= j)) { + i__3 = i__ + j * a_dim1; + zbeg_(&z__2, reset); + z__1.r = z__2.r + transl->r, z__1.i = z__2.i + transl->i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + if (i__ != j) { +/* Set some elements to zero */ + if (*n > 3 && j == *n / 2) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; + } + if (her) { + i__3 = j + i__ * a_dim1; + d_cnjg(&z__1, &a[i__ + j * a_dim1]); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } else if (sym) { + i__3 = j + i__ * a_dim1; + i__4 = i__ + j * a_dim1; + a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i; + } else if (tri) { + i__3 = j + i__ * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; + } + } + } +/* L10: */ + } + if (her) { + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + d__1 = a[i__3].r; + z__1.r = d__1, z__1.i = 0.; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + } + if (tri) { + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + z__1.r = a[i__3].r + 1., z__1.i = a[i__3].i + 0.; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + } + if (unit) { + i__2 = j + j * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + } +/* L20: */ + } + +/* Store elements in array AS in data structure required by routine. */ + + if (s_cmp(type__, "ge", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (j - 1) * *lda; + i__4 = i__ + j * a_dim1; + aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i; +/* L30: */ + } + i__2 = *lda; + for (i__ = *m + 1; i__ <= i__2; ++i__) { + i__3 = i__ + (j - 1) * *lda; + aa[i__3].r = -1e10, aa[i__3].i = 1e10; +/* L40: */ + } +/* L50: */ + } + } else if (s_cmp(type__, "he", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__, + "sy", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__, "tr", (ftnlen) + 2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (upper) { + ibeg = 1; + if (unit) { + iend = j - 1; + } else { + iend = j; + } + } else { + if (unit) { + ibeg = j + 1; + } else { + ibeg = j; + } + iend = *n; + } + i__2 = ibeg - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (j - 1) * *lda; + aa[i__3].r = -1e10, aa[i__3].i = 1e10; +/* L60: */ + } + i__2 = iend; + for (i__ = ibeg; i__ <= i__2; ++i__) { + i__3 = i__ + (j - 1) * *lda; + i__4 = i__ + j * a_dim1; + aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i; +/* L70: */ + } + i__2 = *lda; + for (i__ = iend + 1; i__ <= i__2; ++i__) { + i__3 = i__ + (j - 1) * *lda; + aa[i__3].r = -1e10, aa[i__3].i = 1e10; +/* L80: */ + } + if (her) { + jj = j + (j - 1) * *lda; + i__2 = jj; + i__3 = jj; + d__1 = aa[i__3].r; + z__1.r = d__1, z__1.i = -1e10; + aa[i__2].r = z__1.r, aa[i__2].i = z__1.i; + } +/* L90: */ + } + } + return 0; + +/* End of ZMAKE. */ + +} /* zmake_ */ + +/* Subroutine */ int zmmch_(transa, transb, m, n, kk, alpha, a, lda, b, ldb, + beta, c__, ldc, ct, g, cc, ldcc, eps, err, fatal, nout, mv, + transa_len, transb_len) +char *transa, *transb; +integer *m, *n, *kk; +doublecomplex *alpha, *a; +integer *lda; +doublecomplex *b; +integer *ldb; +doublecomplex *beta, *c__; +integer *ldc; +doublecomplex *ct; +doublereal *g; +doublecomplex *cc; +integer *ldcc; +doublereal *eps, *err; +logical *fatal; +integer *nout; +logical *mv; +ftnlen transa_len; +ftnlen transb_len; +{ + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, cc_dim1, + cc_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7; + doublereal d__1, d__2, d__3, d__4, d__5, d__6; + doublecomplex z__1, z__2, z__3, z__4; + + double sqrt(); + /* Local variables */ + static doublereal erri; + static integer i__, j, k; + static logical trana, tranb, ctrana, ctranb; + +/* Checks the results of the computational tests. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Parameters .. */ +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Intrinsic Functions .. */ +/* .. Statement Functions .. */ +/* .. Statement Function definitions .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --ct; + --g; + cc_dim1 = *ldcc; + cc_offset = 1 + cc_dim1 * 1; + cc -= cc_offset; + + /* Function Body */ + trana = *(unsigned char *)transa == 'T' || *(unsigned char *)transa == + 'C'; + tranb = *(unsigned char *)transb == 'T' || *(unsigned char *)transb == + 'C'; + ctrana = *(unsigned char *)transa == 'C'; + ctranb = *(unsigned char *)transb == 'C'; + +/* Compute expected result, one column at a time, in CT using data */ +/* in A, B and C. */ +/* Compute gauges in G. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + ct[i__3].r = 0., ct[i__3].i = 0.; + g[i__] = 0.; +/* L10: */ + } + if (! trana && ! tranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + i__6 = i__ + k * a_dim1; + i__7 = k + j * b_dim1; + z__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[i__7].i, + z__2.i = a[i__6].r * b[i__7].i + a[i__6].i * b[ + i__7].r; + z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i + + z__2.i; + ct[i__4].r = z__1.r, ct[i__4].i = z__1.i; + i__4 = i__ + k * a_dim1; + i__5 = k + j * b_dim1; + g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag( + &a[i__ + k * a_dim1]), abs(d__2))) * ((d__3 = b[ + i__5].r, abs(d__3)) + (d__4 = d_imag(&b[k + j * + b_dim1]), abs(d__4))); +/* L20: */ + } +/* L30: */ + } + } else if (trana && ! tranb) { + if (ctrana) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + d_cnjg(&z__3, &a[k + i__ * a_dim1]); + i__6 = k + j * b_dim1; + z__2.r = z__3.r * b[i__6].r - z__3.i * b[i__6].i, + z__2.i = z__3.r * b[i__6].i + z__3.i * b[i__6] + .r; + z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i + + z__2.i; + ct[i__4].r = z__1.r, ct[i__4].i = z__1.i; + i__4 = k + i__ * a_dim1; + i__5 = k + j * b_dim1; + g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = + d_imag(&a[k + i__ * a_dim1]), abs(d__2))) * (( + d__3 = b[i__5].r, abs(d__3)) + (d__4 = d_imag( + &b[k + j * b_dim1]), abs(d__4))); +/* L40: */ + } +/* L50: */ + } + } else { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + i__6 = k + i__ * a_dim1; + i__7 = k + j * b_dim1; + z__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[i__7] + .i, z__2.i = a[i__6].r * b[i__7].i + a[i__6] + .i * b[i__7].r; + z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i + + z__2.i; + ct[i__4].r = z__1.r, ct[i__4].i = z__1.i; + i__4 = k + i__ * a_dim1; + i__5 = k + j * b_dim1; + g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = + d_imag(&a[k + i__ * a_dim1]), abs(d__2))) * (( + d__3 = b[i__5].r, abs(d__3)) + (d__4 = d_imag( + &b[k + j * b_dim1]), abs(d__4))); +/* L60: */ + } +/* L70: */ + } + } + } else if (! trana && tranb) { + if (ctranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + i__6 = i__ + k * a_dim1; + d_cnjg(&z__3, &b[j + k * b_dim1]); + z__2.r = a[i__6].r * z__3.r - a[i__6].i * z__3.i, + z__2.i = a[i__6].r * z__3.i + a[i__6].i * + z__3.r; + z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i + + z__2.i; + ct[i__4].r = z__1.r, ct[i__4].i = z__1.i; + i__4 = i__ + k * a_dim1; + i__5 = j + k * b_dim1; + g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = + d_imag(&a[i__ + k * a_dim1]), abs(d__2))) * (( + d__3 = b[i__5].r, abs(d__3)) + (d__4 = d_imag( + &b[j + k * b_dim1]), abs(d__4))); +/* L80: */ + } +/* L90: */ + } + } else { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + i__6 = i__ + k * a_dim1; + i__7 = j + k * b_dim1; + z__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[i__7] + .i, z__2.i = a[i__6].r * b[i__7].i + a[i__6] + .i * b[i__7].r; + z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i + + z__2.i; + ct[i__4].r = z__1.r, ct[i__4].i = z__1.i; + i__4 = i__ + k * a_dim1; + i__5 = j + k * b_dim1; + g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = + d_imag(&a[i__ + k * a_dim1]), abs(d__2))) * (( + d__3 = b[i__5].r, abs(d__3)) + (d__4 = d_imag( + &b[j + k * b_dim1]), abs(d__4))); +/* L100: */ + } +/* L110: */ + } + } + } else if (trana && tranb) { + if (ctrana) { + if (ctranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + d_cnjg(&z__3, &a[k + i__ * a_dim1]); + d_cnjg(&z__4, &b[j + k * b_dim1]); + z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, + z__2.i = z__3.r * z__4.i + z__3.i * + z__4.r; + z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i + + z__2.i; + ct[i__4].r = z__1.r, ct[i__4].i = z__1.i; + i__4 = k + i__ * a_dim1; + i__5 = j + k * b_dim1; + g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = + d_imag(&a[k + i__ * a_dim1]), abs(d__2))) + * ((d__3 = b[i__5].r, abs(d__3)) + (d__4 + = d_imag(&b[j + k * b_dim1]), abs(d__4))); +/* L120: */ + } +/* L130: */ + } + } else { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + d_cnjg(&z__3, &a[k + i__ * a_dim1]); + i__6 = j + k * b_dim1; + z__2.r = z__3.r * b[i__6].r - z__3.i * b[i__6].i, + z__2.i = z__3.r * b[i__6].i + z__3.i * b[ + i__6].r; + z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i + + z__2.i; + ct[i__4].r = z__1.r, ct[i__4].i = z__1.i; + i__4 = k + i__ * a_dim1; + i__5 = j + k * b_dim1; + g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = + d_imag(&a[k + i__ * a_dim1]), abs(d__2))) + * ((d__3 = b[i__5].r, abs(d__3)) + (d__4 + = d_imag(&b[j + k * b_dim1]), abs(d__4))); +/* L140: */ + } +/* L150: */ + } + } + } else { + if (ctranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + i__6 = k + i__ * a_dim1; + d_cnjg(&z__3, &b[j + k * b_dim1]); + z__2.r = a[i__6].r * z__3.r - a[i__6].i * z__3.i, + z__2.i = a[i__6].r * z__3.i + a[i__6].i * + z__3.r; + z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i + + z__2.i; + ct[i__4].r = z__1.r, ct[i__4].i = z__1.i; + i__4 = k + i__ * a_dim1; + i__5 = j + k * b_dim1; + g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = + d_imag(&a[k + i__ * a_dim1]), abs(d__2))) + * ((d__3 = b[i__5].r, abs(d__3)) + (d__4 + = d_imag(&b[j + k * b_dim1]), abs(d__4))); +/* L160: */ + } +/* L170: */ + } + } else { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + i__6 = k + i__ * a_dim1; + i__7 = j + k * b_dim1; + z__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[ + i__7].i, z__2.i = a[i__6].r * b[i__7].i + + a[i__6].i * b[i__7].r; + z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i + + z__2.i; + ct[i__4].r = z__1.r, ct[i__4].i = z__1.i; + i__4 = k + i__ * a_dim1; + i__5 = j + k * b_dim1; + g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = + d_imag(&a[k + i__ * a_dim1]), abs(d__2))) + * ((d__3 = b[i__5].r, abs(d__3)) + (d__4 + = d_imag(&b[j + k * b_dim1]), abs(d__4))); +/* L180: */ + } +/* L190: */ + } + } + } + } + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + z__2.r = alpha->r * ct[i__4].r - alpha->i * ct[i__4].i, z__2.i = + alpha->r * ct[i__4].i + alpha->i * ct[i__4].r; + i__5 = i__ + j * c_dim1; + z__3.r = beta->r * c__[i__5].r - beta->i * c__[i__5].i, z__3.i = + beta->r * c__[i__5].i + beta->i * c__[i__5].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + ct[i__3].r = z__1.r, ct[i__3].i = z__1.i; + i__3 = i__ + j * c_dim1; + g[i__] = ((d__1 = alpha->r, abs(d__1)) + (d__2 = d_imag(alpha), + abs(d__2))) * g[i__] + ((d__3 = beta->r, abs(d__3)) + ( + d__4 = d_imag(beta), abs(d__4))) * ((d__5 = c__[i__3].r, + abs(d__5)) + (d__6 = d_imag(&c__[i__ + j * c_dim1]), abs( + d__6))); +/* L200: */ + } + +/* Compute the error ratio for this result. */ + + *err = 0.; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__ + j * cc_dim1; + z__2.r = ct[i__3].r - cc[i__4].r, z__2.i = ct[i__3].i - cc[i__4] + .i; + z__1.r = z__2.r, z__1.i = z__2.i; + erri = ((d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), abs( + d__2))) / *eps; + if (g[i__] != 0.) { + erri /= g[i__]; + } + *err = f2cmax(*err,erri); + if (*err * sqrt(*eps) >= 1.) { + goto L230; + } +/* L210: */ + } + +/* L220: */ + } + +/* If the loop completes, all results are at least half accurate. */ + goto L250; + +/* Report fatal error. */ + +L230: + *fatal = TRUE_; + printf(" ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HALF ACCURATE *******\n"); + printf(" EXPECTED RESULT COMPUTED RESULT\n"); + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*mv) { + printf("%7d (%15.6g,%15.6g) (%15.6g,%15.6g)\n",i__,ct[i__].r,ct[i__].i,cc[i__+j*cc_dim1].r,cc[i__+j*cc_dim1].i); + } else { + printf("%7d (%15.6g,%15.6g) (%15.6g,%15.6g)\n",i__,cc[i__+j*cc_dim1].r,cc[i__+j*cc_dim1].i,ct[i__].r,ct[i__].i); + } +/* L240: */ + } + if (*n > 1) { + printf(" THESE ARE THE RESULTS FOR COLUMN %d\n",j); + } + +L250: + return 0; + + +/* End of ZMMCH. */ + +} /* zmmch_ */ + +logical lze_(ri, rj, lr) +doublecomplex *ri, *rj; +integer *lr; +{ + /* System generated locals */ + integer i__1, i__2, i__3; + logical ret_val; + + /* Local variables */ + static integer i__; + + +/* Tests if two arrays are identical. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + --rj; + --ri; + + /* Function Body */ + i__1 = *lr; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + if (ri[i__2].r != rj[i__3].r || ri[i__2].i != rj[i__3].i) { + goto L20; + } +/* L10: */ + } + ret_val = TRUE_; + goto L30; +L20: + ret_val = FALSE_; +L30: + return ret_val; + +/* End of LZE. */ + +} /* lze_ */ + +logical lzeres_(type__, uplo, m, n, aa, as, lda, type_len, uplo_len) +char *type__, *uplo; +integer *m, *n; +doublecomplex *aa, *as; +integer *lda; +ftnlen type_len; +ftnlen uplo_len; +{ + /* System generated locals */ + integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2, i__3, i__4; + logical ret_val; + + /* Local variables */ + static integer ibeg, iend, i__, j; + static logical upper; + + +/* Tests if selected elements in two arrays are equal. */ + +/* TYPE is 'ge' or 'he' or 'sy'. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. Local Scalars .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + as_dim1 = *lda; + as_offset = 1 + as_dim1 * 1; + as -= as_offset; + aa_dim1 = *lda; + aa_offset = 1 + aa_dim1 * 1; + aa -= aa_offset; + + /* Function Body */ + upper = *(unsigned char *)uplo == 'U'; + if (s_cmp(type__, "ge", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *lda; + for (i__ = *m + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * aa_dim1; + i__4 = i__ + j * as_dim1; + if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) { + goto L70; + } +/* L10: */ + } +/* L20: */ + } + } else if (s_cmp(type__, "he", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__, + "sy", (ftnlen)2, (ftnlen)2) == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (upper) { + ibeg = 1; + iend = j; + } else { + ibeg = j; + iend = *n; + } + i__2 = ibeg - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * aa_dim1; + i__4 = i__ + j * as_dim1; + if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) { + goto L70; + } +/* L30: */ + } + i__2 = *lda; + for (i__ = iend + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * aa_dim1; + i__4 = i__ + j * as_dim1; + if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) { + goto L70; + } +/* L40: */ + } +/* L50: */ + } + } + +/* 60 CONTINUE */ + ret_val = TRUE_; + goto L80; +L70: + ret_val = FALSE_; +L80: + return ret_val; + +/* End of LZERES. */ + +} /* lzeres_ */ + +/* Double Complex */ VOID zbeg_( ret_val, reset) +doublecomplex * ret_val; +logical *reset; +{ + /* System generated locals */ + doublereal d__1, d__2; + doublecomplex z__1; + + /* Local variables */ + static integer i__, j, ic, mi, mj; + + +/* Generates complex numbers as pairs of random numbers uniformly */ +/* distributed between -0.5 and 0.5. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Scalar Arguments .. */ +/* .. Local Scalars .. */ +/* .. Save statement .. */ +/* .. Intrinsic Functions .. */ +/* .. Executable Statements .. */ + if (*reset) { +/* Initialize local variables. */ + mi = 891; + mj = 457; + i__ = 7; + j = 7; + ic = 0; + *reset = FALSE_; + } + +/* The sequence of values of I or J is bounded between 1 and 999. */ +/* If initial I or J = 1,2,3,6,7 or 9, the period will be 50. */ +/* If initial I or J = 4 or 8, the period will be 25. */ +/* If initial I or J = 5, the period will be 10. */ +/* IC is used to break up the period by skipping 1 value of I or J */ +/* in 6. */ + + ++ic; +L10: + i__ *= mi; + j *= mj; + i__ -= i__ / 1000 * 1000; + j -= j / 1000 * 1000; + if (ic >= 5) { + ic = 0; + goto L10; + } + d__1 = (i__ - 500) / 1001.; + d__2 = (j - 500) / 1001.; + z__1.r = d__1, z__1.i = d__2; + ret_val->r = z__1.r, ret_val->i = z__1.i; + return ; + +/* End of ZBEG. */ + +} /* zbeg_ */ + +doublereal ddiff_(x, y) +doublereal *x, *y; +{ + /* System generated locals */ + doublereal ret_val; + + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* .. Scalar Arguments .. */ +/* .. Executable Statements .. */ + ret_val = *x - *y; + return ret_val; + +/* End of DDIFF. */ + +} /* ddiff_ */ + +/* Main program alias */ /*int zblat3_ () { MAIN__ (); }*/