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}
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"
)
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)
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
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:
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)
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 $<TARGET_FILE:x${float_char}cblat1>)
#level2
+if (NOT NOFORTRAN)
add_executable(x${float_char}cblat2
c_${float_char}blat2.f
c_${float_char}blas2.c
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} $<TARGET_FILE:x${float_char}cblat2> "${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
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} $<TARGET_FILE:x${float_char}cblat3> "${PROJECT_SOURCE_DIR}/ctest/${float_char}in3")
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
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
--- /dev/null
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#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<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conjf(Cf(&x[i]))._Val[0] * Cf(&y[i])._Val[0];
+ zdotc._Val[1] += conjf(Cf(&x[i]))._Val[1] * Cf(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conjf(Cf(&x[i*incx]))._Val[0] * Cf(&y[i*incy])._Val[0];
+ zdotc._Val[1] += conjf(Cf(&x[i*incx]))._Val[1] * Cf(&y[i*incy])._Val[1];
+ }
+ }
+ pCf(z) = zdotc;
+}
+#else
+ _Complex float zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+ }
+ }
+ pCf(z) = zdotc;
+}
+#endif
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Dcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conj(Cd(&x[i]))._Val[0] * Cd(&y[i])._Val[0];
+ zdotc._Val[1] += conj(Cd(&x[i]))._Val[1] * Cd(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conj(Cd(&x[i*incx]))._Val[0] * Cd(&y[i*incy])._Val[0];
+ zdotc._Val[1] += conj(Cd(&x[i*incx]))._Val[1] * Cd(&y[i*incy])._Val[1];
+ }
+ }
+ pCd(z) = zdotc;
+}
+#else
+ _Complex double zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+ }
+ }
+ pCd(z) = zdotc;
+}
+#endif
+static inline void cdotu_(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<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cf(&x[i])._Val[0] * Cf(&y[i])._Val[0];
+ zdotc._Val[1] += Cf(&x[i])._Val[1] * Cf(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cf(&x[i*incx])._Val[0] * Cf(&y[i*incy])._Val[0];
+ zdotc._Val[1] += Cf(&x[i*incx])._Val[1] * Cf(&y[i*incy])._Val[1];
+ }
+ }
+ pCf(z) = zdotc;
+}
+#else
+ _Complex float zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cf(&x[i]) * Cf(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+ }
+ }
+ pCf(z) = zdotc;
+}
+#endif
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Dcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cd(&x[i])._Val[0] * Cd(&y[i])._Val[0];
+ zdotc._Val[1] += Cd(&x[i])._Val[1] * Cd(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cd(&x[i*incx])._Val[0] * Cd(&y[i*incy])._Val[0];
+ zdotc._Val[1] += Cd(&x[i*incx])._Val[1] * Cd(&y[i*incy])._Val[1];
+ }
+ }
+ pCd(z) = zdotc;
+}
+#else
+ _Complex double zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cd(&x[i]) * Cd(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+ }
+ }
+ pCd(z) = zdotc;
+}
+#endif
+
+/* Common Block Declarations */
+
+struct {
+ integer icase, n, incx, incy, mode;
+ logical pass;
+} combla_;
+
+#define combla_1 combla_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__5 = 5;
+static real c_b43 = (float)1.;
+
+/* Main program */ int main()
+{
+ /* Initialized data */
+
+ static real sfac = (float)9.765625e-4;
+
+ /* Local variables */
+ extern /* Subroutine */ int check1_(), check2_();
+ static integer ic;
+ extern /* Subroutine */ int header_();
+
+/* Test program for the COMPLEX Level 1 CBLAS. */
+/* Based upon the original CBLAS test routine together with: */
+/* F06GAF Example Program Text */
+/* .. Parameters .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. External Subroutines .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+ printf("Complex CBLAS Test Program Results\n");
+ for (ic = 1; ic <= 10; ++ic) {
+ combla_1.icase = ic;
+ header_();
+
+/* Initialize PASS, INCX, INCY, and MODE for a new case. */
+/* The value 9999 for INCX, INCY or MODE will appear in the */
+/* detailed output, if any, for cases that do not involve */
+/* these parameters. */
+
+ combla_1.pass = TRUE_;
+ combla_1.incx = 9999;
+ combla_1.incy = 9999;
+ combla_1.mode = 9999;
+ if (combla_1.icase <= 5) {
+ check2_(&sfac);
+ } else if (combla_1.icase >= 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_ */
+
--- /dev/null
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#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<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conjf(Cf(&x[i]))._Val[0] * Cf(&y[i])._Val[0];
+ zdotc._Val[1] += conjf(Cf(&x[i]))._Val[1] * Cf(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conjf(Cf(&x[i*incx]))._Val[0] * Cf(&y[i*incy])._Val[0];
+ zdotc._Val[1] += conjf(Cf(&x[i*incx]))._Val[1] * Cf(&y[i*incy])._Val[1];
+ }
+ }
+ pCf(z) = zdotc;
+}
+#else
+ _Complex float zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+ }
+ }
+ pCf(z) = zdotc;
+}
+#endif
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Dcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conj(Cd(&x[i]))._Val[0] * Cd(&y[i])._Val[0];
+ zdotc._Val[1] += conj(Cd(&x[i]))._Val[1] * Cd(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conj(Cd(&x[i*incx]))._Val[0] * Cd(&y[i*incy])._Val[0];
+ zdotc._Val[1] += conj(Cd(&x[i*incx]))._Val[1] * Cd(&y[i*incy])._Val[1];
+ }
+ }
+ pCd(z) = zdotc;
+}
+#else
+ _Complex double zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+ }
+ }
+ pCd(z) = zdotc;
+}
+#endif
+static inline void cdotu_(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<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cf(&x[i])._Val[0] * Cf(&y[i])._Val[0];
+ zdotc._Val[1] += Cf(&x[i])._Val[1] * Cf(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cf(&x[i*incx])._Val[0] * Cf(&y[i*incy])._Val[0];
+ zdotc._Val[1] += Cf(&x[i*incx])._Val[1] * Cf(&y[i*incy])._Val[1];
+ }
+ }
+ pCf(z) = zdotc;
+}
+#else
+ _Complex float zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cf(&x[i]) * Cf(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+ }
+ }
+ pCf(z) = zdotc;
+}
+#endif
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Dcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cd(&x[i])._Val[0] * Cd(&y[i])._Val[0];
+ zdotc._Val[1] += Cd(&x[i])._Val[1] * Cd(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cd(&x[i*incx])._Val[0] * Cd(&y[i*incy])._Val[0];
+ zdotc._Val[1] += Cd(&x[i*incx])._Val[1] * Cd(&y[i*incy])._Val[1];
+ }
+ }
+ pCd(z) = zdotc;
+}
+#else
+ _Complex double zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cd(&x[i]) * Cd(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+ }
+ }
+ pCd(z) = zdotc;
+}
+#endif
+/* -- translated by f2c (version 20000121).
+ You must link the resulting object file with the libraries:
+ -lf2c -lm (in that order)
+*/
+
+
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, noutc;
+ logical ok;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[12];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static complex c_b1 = {(float)0.,(float)0.};
+static complex c_b2 = {(float)1.,(float)0.};
+static integer c__1 = 1;
+static integer c__65 = 65;
+static integer c__2 = 2;
+static integer c__6 = 6;
+static real c_b125 = (float)1.;
+static logical c_true = TRUE_;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static logical c_false = FALSE_;
+
+/* Main program */ int main()
+{
+ /* Initialized data */
+
+ static char snames[17][13] = { "cblas_cgemv " , "cblas_cgbmv " , "cblas_chemv ",
+ "cblas_chbmv ", "cblas_chpmv ", "cblas_ctrmv " , "cblas_ctbmv " , "cblas_ctpmv ",
+ "cblas_ctrsv ", "cblas_ctbsv ", "cblas_ctpsv " , "cblas_cgerc " , "cblas_cgeru ",
+ "cblas_cher ", "cblas_chpr ", "cblas_cher2 " , "cblas_chpr2 " };
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ real r__1;
+
+ /* Local variables */
+ static integer nalf, idim[9];
+ static logical same;
+ static integer ninc, nbet, ntra;
+ static logical rewi;
+ extern /* Subroutine */ int cchk1_(), cchk2_(), cchk3_(), cchk4_(),
+ cchk5_(), cchk6_();
+ static complex a[4225] /* was [65][65] */;
+ static real g[65];
+ static integer i__, j, n;
+ static logical fatal;
+ static complex x[65], y[65], z__[130];
+ extern doublereal sdiff_();
+ static logical trace;
+ static integer nidim;
+ extern /* Subroutine */ int cmvch_();
+ static char snaps[32], trans[1];
+ static integer isnum;
+ static logical ltest[17];
+ static complex aa[4225];
+ static integer kb[7];
+ static complex as[4225];
+ static logical sfatal;
+ static complex xs[130], ys[130];
+ static logical corder;
+ static complex xx[130], yt[65], yy[130];
+ static char snamet[12];
+ static real thresh;
+ static logical rorder;
+ extern /* Subroutine */ int cc2chke_();
+ static integer layout;
+ static logical ltestt, tsterr;
+ static complex alf[7];
+ extern logical lce_();
+ static integer inc[7], nkb;
+ static complex bet[7];
+ static real eps, err;
+ char tmpchar;
+
+/* Test program for the COMPLEX Level 2 Blas. */
+
+/* The program must be driven by a short data file. The first 17 records */
+/* of the file are read using list-directed input, the last 17 records */
+/* are read using the format ( A12, L2 ). An annotated example of a data */
+/* file can be obtained by deleting the first 3 characters from the */
+/* following 34 lines: */
+/* 'CBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE */
+/* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) */
+/* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. */
+/* F LOGICAL FLAG, T TO STOP ON FAILURES. */
+/* T LOGICAL FLAG, T TO TEST ERROR EXITS. */
+/* 2 0 TO TEST COLUMN-MAJOR, 1 TO TEST ROW-MAJOR, 2 TO TEST BOTH */
+/* 16.0 THRESHOLD VALUE OF TEST RATIO */
+/* 6 NUMBER OF VALUES OF N */
+/* 0 1 2 3 5 9 VALUES OF N */
+/* 4 NUMBER OF VALUES OF K */
+/* 0 1 2 4 VALUES OF K */
+/* 4 NUMBER OF VALUES OF INCX AND INCY */
+/* 1 2 -1 -2 VALUES OF INCX AND INCY */
+/* 3 NUMBER OF VALUES OF ALPHA */
+/* (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA */
+/* 3 NUMBER OF VALUES OF BETA */
+/* (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA */
+/* cblas_cgemv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_cgbmv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_chemv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_chbmv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_chpmv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_ctrmv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_ctbmv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_ctpmv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_ctrsv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_ctbsv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_ctpsv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_cgerc T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_cgeru T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_cher T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_chpr T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_cher2 T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_chpr2 T PUT F FOR NO TEST. SAME COLUMNS. */
+
+/* See: */
+
+/* Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J.. */
+/* An extended set of Fortran Basic Linear Algebra Subprograms. */
+
+/* Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics */
+/* and Computer Science Division, Argonne National Laboratory, */
+/* 9700 South Cass Avenue, Argonne, Illinois 60439, US. */
+
+/* Or */
+
+/* NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms */
+/* Group Ltd., NAG Central Office, 256 Banbury Road, Oxford */
+/* OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st */
+/* Street, Suite 100, Downers Grove, Illinois 60515-1263, USA. */
+
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+
+ infoc_1.noutc = 6;
+
+/* Read name and unit number for summary output file and open file. */
+
+ char line[80];
+
+ fgets(line,80,stdin);
+ sscanf(line,"'%s'",snaps);
+ fgets(line,80,stdin);
+ sscanf(line,"%d",&ntra);
+ trace = ntra >= 0;
+ if (trace) {
+/* o__1.oerr = 0;
+ o__1.ounit = ntra;
+ o__1.ofnmlen = 32;
+ o__1.ofnm = snaps;
+ o__1.orl = 0;
+ o__1.osta = 0;
+ o__1.oacc = 0;
+ o__1.ofm = 0;
+ o__1.oblnk = 0;
+ f_open(&o__1);*/
+ }
+/* Read the flag that directs rewinding of the snapshot file. */
+ fgets(line,80,stdin);
+ sscanf(line,"%d",&rewi);
+ rewi = rewi && trace;
+/* Read the flag that directs stopping on any failure. */
+ fgets(line,80,stdin);
+ sscanf(line,"%c",&tmpchar);
+/* 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_ */
+
--- /dev/null
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#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<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conjf(Cf(&x[i]))._Val[0] * Cf(&y[i])._Val[0];
+ zdotc._Val[1] += conjf(Cf(&x[i]))._Val[1] * Cf(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conjf(Cf(&x[i*incx]))._Val[0] * Cf(&y[i*incy])._Val[0];
+ zdotc._Val[1] += conjf(Cf(&x[i*incx]))._Val[1] * Cf(&y[i*incy])._Val[1];
+ }
+ }
+ pCf(z) = zdotc;
+}
+#else
+ _Complex float zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+ }
+ }
+ pCf(z) = zdotc;
+}
+#endif
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Dcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conj(Cd(&x[i]))._Val[0] * Cd(&y[i])._Val[0];
+ zdotc._Val[1] += conj(Cd(&x[i]))._Val[1] * Cd(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conj(Cd(&x[i*incx]))._Val[0] * Cd(&y[i*incy])._Val[0];
+ zdotc._Val[1] += conj(Cd(&x[i*incx]))._Val[1] * Cd(&y[i*incy])._Val[1];
+ }
+ }
+ pCd(z) = zdotc;
+}
+#else
+ _Complex double zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+ }
+ }
+ pCd(z) = zdotc;
+}
+#endif
+static inline void cdotu_(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<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cf(&x[i])._Val[0] * Cf(&y[i])._Val[0];
+ zdotc._Val[1] += Cf(&x[i])._Val[1] * Cf(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cf(&x[i*incx])._Val[0] * Cf(&y[i*incy])._Val[0];
+ zdotc._Val[1] += Cf(&x[i*incx])._Val[1] * Cf(&y[i*incy])._Val[1];
+ }
+ }
+ pCf(z) = zdotc;
+}
+#else
+ _Complex float zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cf(&x[i]) * Cf(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+ }
+ }
+ pCf(z) = zdotc;
+}
+#endif
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Dcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cd(&x[i])._Val[0] * Cd(&y[i])._Val[0];
+ zdotc._Val[1] += Cd(&x[i])._Val[1] * Cd(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cd(&x[i*incx])._Val[0] * Cd(&y[i*incy])._Val[0];
+ zdotc._Val[1] += Cd(&x[i*incx])._Val[1] * Cd(&y[i*incy])._Val[1];
+ }
+ }
+ pCd(z) = zdotc;
+}
+#else
+ _Complex double zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cd(&x[i]) * Cd(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+ }
+ }
+ pCd(z) = zdotc;
+}
+#endif
+/* -- translated by f2c (version 20000121).
+ You must link the resulting object file with the libraries:
+ -lf2c -lm (in that order)
+*/
+
+
+
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, noutc;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[12];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c__65 = 65;
+static integer c__6 = 6;
+static real c_b91 = 1.f;
+static logical c_true = TRUE_;
+static integer c__0 = 0;
+static logical c_false = FALSE_;
+
+int /* Main program */ main(void)
+{
+ /* Initialized data */
+
+ static char snames[9][13] = {"cblas_cgemm ", "cblas_chemm ", "cblas_csymm ",
+ "cblas_ctrmm ", "cblas_ctrsm ", "cblas_cherk ", "cblas_csyrk ",
+ "cblas_cher2k", "cblas_csyr2k"};
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ real r__1;
+
+ /* Local variables */
+ integer nalf, idim[9];
+ logical same;
+ integer nbet, ntra;
+ logical rewi;
+ extern /* Subroutine */ int cchk1_(char *, real *, real *, integer *,
+ integer *, logical *, logical *, logical *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ complex *, complex *, complex *, real *, integer *),
+ cchk2_(char *, real *, real *, integer *, integer *, logical *,
+ logical *, logical *, integer *, integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, complex *, complex *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ complex *, real *, integer *), cchk3_(char *, real *,
+ real *, integer *, integer *, logical *, logical *, logical *,
+ integer *, integer *, integer *, complex *, integer *, complex *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ real *, complex *, integer *), cchk4_(char *, real *,
+ real *, integer *, integer *, logical *, logical *, logical *,
+ integer *, integer *, integer *, complex *, integer *, complex *,
+ integer *, complex *, complex *, complex *, complex *, complex *,
+ complex *, complex *, complex *, complex *, complex *, real *,
+ integer *), cchk5_(char *, real *, real *, integer *,
+ integer *, logical *, logical *, logical *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ complex *, complex *, real *, complex *, integer *);
+ complex c__[4225] /* was [65][65] */;
+ real g[65];
+ integer i__, j, n;
+ logical fatal;
+ complex w[130];
+ extern /* Subroutine */ int cmmch_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *, complex *, real *, complex *,
+ integer *, real *, real *, logical *, integer *, logical *);
+ extern real sdiff_(real *, real *);
+ logical trace;
+ integer nidim;
+ char snaps[32];
+ integer isnum;
+ logical ltest[9];
+ complex aa[4225], ab[8450] /* was [65][130] */, bb[4225], cc[4225], as[
+ 4225], bs[4225], cs[4225], ct[65];
+ logical sfatal, corder;
+ char snamet[12], transa[1], transb[1];
+ real thresh;
+ logical rorder;
+ extern /* Subroutine */ int cc3chke_(char *);
+ integer layout;
+ logical ltestt, tsterr;
+ complex alf[7];
+ extern logical lce_(complex *, complex *, integer *);
+ complex bet[7];
+ real eps, err;
+ char tmpchar;
+
+/* Test program for the COMPLEX Level 3 Blas. */
+
+/* The program must be driven by a short data file. The first 13 records */
+/* of the file are read using list-directed input, the last 9 records */
+/* are read using the format ( A12, L2 ). An annotated example of a data */
+/* file can be obtained by deleting the first 3 characters from the */
+/* following 22 lines: */
+/* 'CBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE */
+/* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) */
+/* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. */
+/* F LOGICAL FLAG, T TO STOP ON FAILURES. */
+/* T LOGICAL FLAG, T TO TEST ERROR CALL MYEXITS. */
+/* 2 0 TO TEST COLUMN-MAJOR, 1 TO TEST ROW-MAJOR, 2 TO TEST BOTH */
+/* 16.0 THRESHOLD VALUE OF TEST RATIO */
+/* 6 NUMBER OF VALUES OF N */
+/* 0 1 2 3 5 9 VALUES OF N */
+/* 3 NUMBER OF VALUES OF ALPHA */
+/* (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA */
+/* 3 NUMBER OF VALUES OF BETA */
+/* (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA */
+/* cblas_cgemm T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_chemm T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_csymm T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_ctrmm T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_ctrsm T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_cherk T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_csyrk T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_cher2k T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_csyr2k T PUT F FOR NO TEST. SAME COLUMNS. */
+
+/* See: */
+
+/* Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. */
+/* A Set of Level 3 Basic Linear Algebra Subprograms. */
+
+/* Technical Memorandum No.88 (Revision 1), Mathematics and */
+/* Computer Science Division, Argonne National Laboratory, 9700 */
+/* South Cass Avenue, Argonne, Illinois 60439, US. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+ infoc_1.noutc = 6;
+
+/* Read name and unit number for snapshot output file and open file. */
+ char line[80];
+
+ fgets(line,80,stdin);
+ sscanf(line,"'%s'",snaps);
+ fgets(line,80,stdin);
+ sscanf(line,"%d",&ntra);
+ trace = ntra >= 0;
+ if (trace) {
+/* o__1.oerr = 0;
+ o__1.ounit = ntra;
+ o__1.ofnmlen = 32;
+ o__1.ofnm = snaps;
+ o__1.orl = 0;
+ o__1.osta = 0;
+ o__1.oacc = 0;
+ o__1.ofm = 0;
+ o__1.oblnk = 0;
+ f_open(&o__1);*/
+ }
+/* Read the flag that directs rewinding of the snapshot file. */
+ fgets(line,80,stdin);
+ sscanf(line,"%d",&rewi);
+ rewi = rewi && trace;
+/* Read the flag that directs stopping on any failure. */
+ fgets(line,80,stdin);
+ sscanf(line,"%c",&tmpchar);
+ sfatal=FALSE_;
+ if (tmpchar=='T')sfatal=TRUE_;
+ fgets(line,80,stdin);
+ sscanf(line,"%c",&tmpchar);
+ tsterr=FALSE_;
+ if (tmpchar=='T')tsterr=TRUE_;
+ fgets(line,80,stdin);
+ sscanf(line,"%d",&layout);
+ fgets(line,80,stdin);
+ sscanf(line,"%f",&thresh);
+
+
+/* Read and check the parameter values for the tests. */
+
+/* Values of N */
+ fgets(line,80,stdin);
+ 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; }*/
--- /dev/null
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#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<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conjf(Cf(&x[i]))._Val[0] * Cf(&y[i])._Val[0];
+ zdotc._Val[1] += conjf(Cf(&x[i]))._Val[1] * Cf(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conjf(Cf(&x[i*incx]))._Val[0] * Cf(&y[i*incy])._Val[0];
+ zdotc._Val[1] += conjf(Cf(&x[i*incx]))._Val[1] * Cf(&y[i*incy])._Val[1];
+ }
+ }
+ pCf(z) = zdotc;
+}
+#else
+ _Complex float zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+ }
+ }
+ pCf(z) = zdotc;
+}
+#endif
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Dcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conj(Cd(&x[i]))._Val[0] * Cd(&y[i])._Val[0];
+ zdotc._Val[1] += conj(Cd(&x[i]))._Val[1] * Cd(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conj(Cd(&x[i*incx]))._Val[0] * Cd(&y[i*incy])._Val[0];
+ zdotc._Val[1] += conj(Cd(&x[i*incx]))._Val[1] * Cd(&y[i*incy])._Val[1];
+ }
+ }
+ pCd(z) = zdotc;
+}
+#else
+ _Complex double zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+ }
+ }
+ pCd(z) = zdotc;
+}
+#endif
+static inline void cdotu_(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<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cf(&x[i])._Val[0] * Cf(&y[i])._Val[0];
+ zdotc._Val[1] += Cf(&x[i])._Val[1] * Cf(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cf(&x[i*incx])._Val[0] * Cf(&y[i*incy])._Val[0];
+ zdotc._Val[1] += Cf(&x[i*incx])._Val[1] * Cf(&y[i*incy])._Val[1];
+ }
+ }
+ pCf(z) = zdotc;
+}
+#else
+ _Complex float zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cf(&x[i]) * Cf(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+ }
+ }
+ pCf(z) = zdotc;
+}
+#endif
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Dcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cd(&x[i])._Val[0] * Cd(&y[i])._Val[0];
+ zdotc._Val[1] += Cd(&x[i])._Val[1] * Cd(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cd(&x[i*incx])._Val[0] * Cd(&y[i*incy])._Val[0];
+ zdotc._Val[1] += Cd(&x[i*incx])._Val[1] * Cd(&y[i*incy])._Val[1];
+ }
+ }
+ pCd(z) = zdotc;
+}
+#else
+ _Complex double zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cd(&x[i]) * Cd(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+ }
+ }
+ pCd(z) = zdotc;
+}
+#endif
+
+/* Common Block Declarations */
+
+struct {
+ integer icase, n, incx, incy, mode;
+ logical pass;
+} combla_;
+
+#define combla_1 combla_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b34 = 1.;
+
+/* Main program */ int main()
+{
+ /* Initialized data */
+
+ static doublereal sfac = 9.765625e-4;
+
+ /* Local variables */
+ extern /* Subroutine */ int check0_(), check1_(), check2_(), check3_();
+ static integer ic;
+ extern /* Subroutine */ int header_();
+
+/* Test program for the DOUBLE PRECISION Level 1 CBLAS. */
+/* Based upon the original CBLAS test routine together with: */
+/* F06EAF Example Program Text */
+/* .. Parameters .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. External Subroutines .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+ printf("Real CBLAS Test Program Results\n");
+ for (ic = 1; ic <= 11; ++ic) {
+ combla_1.icase = ic;
+ header_();
+
+/* .. Initialize PASS, INCX, INCY, and MODE for a new case. .. */
+/* .. the value 9999 for INCX, INCY or MODE will appear in the .. */
+/* .. detailed output, if any, for cases that do not involve .. */
+/* .. these parameters .. */
+
+ combla_1.pass = TRUE_;
+ combla_1.incx = 9999;
+ combla_1.incy = 9999;
+ combla_1.mode = 9999;
+ if (combla_1.icase == 3) {
+ check0_(&sfac);
+ } else if (combla_1.icase == 7 || combla_1.icase == 8 ||
+ combla_1.icase == 9 || combla_1.icase == 10) {
+ check1_(&sfac);
+ } else if (combla_1.icase == 1 || combla_1.icase == 2 ||
+ combla_1.icase == 5 || combla_1.icase == 6) {
+ check2_(&sfac);
+ } else if (combla_1.icase == 4 || combla_1.icase == 11) {
+ check3_(&sfac);
+ }
+/* -- Print */
+ if (combla_1.pass) {
+ printf(" ----- PASS -----\n");
+ }
+/* L20: */
+ }
+ exit(0);
+
+} /* MAIN__ */
+
+/* Subroutine */ int header_()
+{
+ /* Initialized data */
+
+ static char l[15][13] = {"CBLAS_DDOT " , "CBLAS_DAXPY " , "CBLAS_DROTG " ,
+ "CBLAS_DROT " , "CBLAS_DCOPY " , "CBLAS_DSWAP " , "CBLAS_DNRM2 " , "CBLAS_DASUM ",
+ "CBLAS_DSCAL " , "CBLAS_IDAMAX" , "CBLAS_DROTM "};
+
+/* .. 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 check0_(sfac)
+doublereal *sfac;
+{
+ /* Initialized data */
+
+ static doublereal ds1[8] = { .8,.6,.8,-.6,.8,0.,1.,0. };
+ static doublereal datrue[8] = { .5,.5,.5,-.5,-.5,0.,1.,1. };
+ static doublereal dbtrue[8] = { 0.,.6,0.,-.6,0.,0.,1.,0. };
+ static doublereal da1[8] = { .3,.4,-.3,-.4,-.3,0.,0.,1. };
+ static doublereal db1[8] = { .4,.3,.4,.3,-.4,0.,1.,0. };
+ static doublereal dc1[8] = { .6,.8,-.6,.8,.6,1.,0.,1. };
+
+ /* Local variables */
+ static integer k;
+ extern /* Subroutine */ int drotgtest_(), stest1_();
+ static doublereal sa, sb, sc, ss;
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Subroutines .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+
+/* Compute true values which cannot be prestored */
+/* in decimal notation */
+
+ dbtrue[0] = 1.6666666666666667;
+ dbtrue[2] = -1.6666666666666667;
+ dbtrue[4] = 1.6666666666666667;
+
+ for (k = 1; k <= 8; ++k) {
+/* .. Set N=K for identification in output if any .. */
+ combla_1.n = k;
+ if (combla_1.icase == 3) {
+/* .. DROTGTEST .. */
+ if (k > 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_ */
+
--- /dev/null
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#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<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conjf(Cf(&x[i]))._Val[0] * Cf(&y[i])._Val[0];
+ zdotc._Val[1] += conjf(Cf(&x[i]))._Val[1] * Cf(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conjf(Cf(&x[i*incx]))._Val[0] * Cf(&y[i*incy])._Val[0];
+ zdotc._Val[1] += conjf(Cf(&x[i*incx]))._Val[1] * Cf(&y[i*incy])._Val[1];
+ }
+ }
+ pCf(z) = zdotc;
+}
+#else
+ _Complex float zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+ }
+ }
+ pCf(z) = zdotc;
+}
+#endif
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Dcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conj(Cd(&x[i]))._Val[0] * Cd(&y[i])._Val[0];
+ zdotc._Val[1] += conj(Cd(&x[i]))._Val[1] * Cd(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conj(Cd(&x[i*incx]))._Val[0] * Cd(&y[i*incy])._Val[0];
+ zdotc._Val[1] += conj(Cd(&x[i*incx]))._Val[1] * Cd(&y[i*incy])._Val[1];
+ }
+ }
+ pCd(z) = zdotc;
+}
+#else
+ _Complex double zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+ }
+ }
+ pCd(z) = zdotc;
+}
+#endif
+static inline void cdotu_(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<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cf(&x[i])._Val[0] * Cf(&y[i])._Val[0];
+ zdotc._Val[1] += Cf(&x[i])._Val[1] * Cf(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cf(&x[i*incx])._Val[0] * Cf(&y[i*incy])._Val[0];
+ zdotc._Val[1] += Cf(&x[i*incx])._Val[1] * Cf(&y[i*incy])._Val[1];
+ }
+ }
+ pCf(z) = zdotc;
+}
+#else
+ _Complex float zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cf(&x[i]) * Cf(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+ }
+ }
+ pCf(z) = zdotc;
+}
+#endif
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Dcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cd(&x[i])._Val[0] * Cd(&y[i])._Val[0];
+ zdotc._Val[1] += Cd(&x[i])._Val[1] * Cd(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cd(&x[i*incx])._Val[0] * Cd(&y[i*incy])._Val[0];
+ zdotc._Val[1] += Cd(&x[i*incx])._Val[1] * Cd(&y[i*incy])._Val[1];
+ }
+ }
+ pCd(z) = zdotc;
+}
+#else
+ _Complex double zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cd(&x[i]) * Cd(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+ }
+ }
+ pCd(z) = zdotc;
+}
+#endif
+/* -- translated by f2c (version 20000121).
+ You must link the resulting object file with the libraries:
+ -lf2c -lm (in that order)
+*/
+
+
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, noutc;
+ logical ok;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[12];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__65 = 65;
+static integer c__2 = 2;
+static doublereal c_b123 = 1.;
+static doublereal c_b135 = 0.;
+static integer c__6 = 6;
+static logical c_true = TRUE_;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static logical c_false = FALSE_;
+
+/* Main program */ int main()
+{
+ /* Initialized data */
+
+ static char snames[16][13] = { "cblas_dgemv ", "cblas_dgbmv ", "cblas_dsymv ",
+ "cblas_dsbmv ", "cblas_dspmv ", "cblas_dtrmv ", "cblas_dtbmv ", "cblas_dtpmv ",
+ "cblas_dtrsv ", "cblas_dtbsv ", "cblas_dtpsv ", "cblas_dger ", "cblas_dsyr ",
+ "cblas_dspr ", "cblas_dsyr2 ", "cblas_dspr2 "};
+
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublereal d__1;
+
+ /* Local variables */
+ static integer nalf, idim[9];
+ static logical same;
+ static integer ninc, nbet, ntra;
+ static logical rewi;
+ extern /* Subroutine */ int dchk1_(), dchk2_(), dchk3_(), dchk4_(),
+ dchk5_(), dchk6_();
+ static doublereal a[4225] /* was [65][65] */, g[65];
+ static integer i__, j;
+ extern doublereal ddiff_();
+ static integer n;
+ static logical fatal;
+ static doublereal x[65], y[65], z__[130];
+ static logical trace;
+ static integer nidim;
+ extern /* Subroutine */ int dmvch_();
+ static char snaps[32], trans[1];
+ static integer isnum;
+ static logical ltest[16];
+ static doublereal aa[4225];
+ static integer kb[7];
+ static doublereal as[4225];
+ static logical sfatal;
+ static doublereal xs[130], ys[130];
+ static logical corder;
+ static doublereal xx[130], yt[65], yy[130];
+ static char snamet[12];
+ static doublereal thresh;
+ static logical rorder;
+ extern /* Subroutine */ int cd2chke_();
+ static integer layout;
+ static logical ltestt, tsterr;
+ static doublereal alf[7];
+ extern logical lde_();
+ static integer inc[7], nkb;
+ static doublereal bet[7],eps,err;
+ char tmpchar;
+
+
+
+/* Test program for the DOUBLE PRECISION Level 2 Blas. */
+
+/* The program must be driven by a short data file. The first 17 records */
+/* of the file are read using list-directed input, the last 16 records */
+/* are read using the format ( A12, L2 ). An annotated example of a data */
+/* file can be obtained by deleting the first 3 characters from the */
+/* following 33 lines: */
+/* 'DBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE */
+/* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) */
+/* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. */
+/* F LOGICAL FLAG, T TO STOP ON FAILURES. */
+/* T LOGICAL FLAG, T TO TEST ERROR EXITS. */
+/* 2 0 TO TEST COLUMN-MAJOR, 1 TO TEST ROW-MAJOR, 2 TO TEST BOTH */
+/* 16.0 THRESHOLD VALUE OF TEST RATIO */
+/* 6 NUMBER OF VALUES OF N */
+/* 0 1 2 3 5 9 VALUES OF N */
+/* 4 NUMBER OF VALUES OF K */
+/* 0 1 2 4 VALUES OF K */
+/* 4 NUMBER OF VALUES OF INCX AND INCY */
+/* 1 2 -1 -2 VALUES OF INCX AND INCY */
+/* 3 NUMBER OF VALUES OF ALPHA */
+/* 0.0 1.0 0.7 VALUES OF ALPHA */
+/* 3 NUMBER OF VALUES OF BETA */
+/* 0.0 1.0 0.9 VALUES OF BETA */
+/* cblas_dgemv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_dgbmv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_dsymv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_dsbmv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_dspmv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_dtrmv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_dtbmv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_dtpmv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_dtrsv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_dtbsv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_dtpsv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_dger T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_dsyr T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_dspr T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_dsyr2 T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_dspr2 T PUT F FOR NO TEST. SAME COLUMNS. */
+
+/* See: */
+
+/* Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J.. */
+/* An extended set of Fortran Basic Linear Algebra Subprograms. */
+
+/* Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics */
+/* and Computer Science Division, Argonne National Laboratory, */
+/* 9700 South Cass Avenue, Argonne, Illinois 60439, US. */
+
+/* Or */
+
+/* NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms */
+/* Group Ltd., NAG Central Office, 256 Banbury Road, Oxford */
+/* OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st */
+/* Street, Suite 100, Downers Grove, Illinois 60515-1263, USA. */
+
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+
+ infoc_1.noutc = 6;
+
+/* Read name and unit number for snapshot output file and open file. */
+
+ char line[80];
+
+ fgets(line,80,stdin);
+ sscanf(line,"'%s'",snaps);
+ fgets(line,80,stdin);
+ sscanf(line,"%d",&ntra);
+ trace = ntra >= 0;
+
+ if (trace) {
+/* o__1.oerr = 0;
+ o__1.ounit = ntra;
+ o__1.ofnmlen = 32;
+ o__1.ofnm = snaps;
+ o__1.orl = 0;
+ o__1.osta = 0;
+ o__1.oacc = 0;
+ o__1.ofm = 0;
+ o__1.oblnk = 0;
+ f_open(&o__1);*/
+ }
+/* Read the flag that directs rewinding of the snapshot file. */
+ fgets(line,80,stdin);
+ sscanf(line,"%d",&rewi);
+ rewi = rewi && trace;
+/* Read the flag that directs stopping on any failure. */
+ fgets(line,80,stdin);
+ sscanf(line,"%c",&tmpchar);
+/* 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_ */
+
--- /dev/null
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#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<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conjf(Cf(&x[i]))._Val[0] * Cf(&y[i])._Val[0];
+ zdotc._Val[1] += conjf(Cf(&x[i]))._Val[1] * Cf(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conjf(Cf(&x[i*incx]))._Val[0] * Cf(&y[i*incy])._Val[0];
+ zdotc._Val[1] += conjf(Cf(&x[i*incx]))._Val[1] * Cf(&y[i*incy])._Val[1];
+ }
+ }
+ pCf(z) = zdotc;
+}
+#else
+ _Complex float zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+ }
+ }
+ pCf(z) = zdotc;
+}
+#endif
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Dcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conj(Cd(&x[i]))._Val[0] * Cd(&y[i])._Val[0];
+ zdotc._Val[1] += conj(Cd(&x[i]))._Val[1] * Cd(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conj(Cd(&x[i*incx]))._Val[0] * Cd(&y[i*incy])._Val[0];
+ zdotc._Val[1] += conj(Cd(&x[i*incx]))._Val[1] * Cd(&y[i*incy])._Val[1];
+ }
+ }
+ pCd(z) = zdotc;
+}
+#else
+ _Complex double zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+ }
+ }
+ pCd(z) = zdotc;
+}
+#endif
+static inline void cdotu_(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<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cf(&x[i])._Val[0] * Cf(&y[i])._Val[0];
+ zdotc._Val[1] += Cf(&x[i])._Val[1] * Cf(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cf(&x[i*incx])._Val[0] * Cf(&y[i*incy])._Val[0];
+ zdotc._Val[1] += Cf(&x[i*incx])._Val[1] * Cf(&y[i*incy])._Val[1];
+ }
+ }
+ pCf(z) = zdotc;
+}
+#else
+ _Complex float zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cf(&x[i]) * Cf(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+ }
+ }
+ pCf(z) = zdotc;
+}
+#endif
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Dcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cd(&x[i])._Val[0] * Cd(&y[i])._Val[0];
+ zdotc._Val[1] += Cd(&x[i])._Val[1] * Cd(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cd(&x[i*incx])._Val[0] * Cd(&y[i*incy])._Val[0];
+ zdotc._Val[1] += Cd(&x[i*incx])._Val[1] * Cd(&y[i*incy])._Val[1];
+ }
+ }
+ pCd(z) = zdotc;
+}
+#else
+ _Complex double zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cd(&x[i]) * Cd(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+ }
+ }
+ pCd(z) = zdotc;
+}
+#endif
+/* -- translated by f2c (version 20000121).
+ You must link the resulting object file with the libraries:
+ -lf2c -lm (in that order)
+*/
+
+
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, noutc;
+ logical ok;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[12];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__65 = 65;
+static doublereal c_b90 = 1.;
+static doublereal c_b104 = 0.;
+static integer c__6 = 6;
+static logical c_true = TRUE_;
+static integer c__0 = 0;
+static logical c_false = FALSE_;
+
+/* Main program MAIN__() */ int main()
+{
+ /* Initialized data */
+
+ static char snames[6][13] = {"cblas_dgemm ", "cblas_dsymm ", "cblas_dtrmm ", "cblas_dtrsm ", "cblas_dsyrk ", "cblas_dsyr2k"};
+
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublereal d__1;
+
+ /* Builtin functions */
+ integer s_rsle(), do_lio(), e_rsle(), f_open(), s_wsfe(), do_fio(),
+ e_wsfe(), s_wsle(), e_wsle(), s_rsfe(), e_rsfe();
+ integer f_clos();
+
+ /* Local variables */
+ static integer nalf, idim[9];
+ static logical same;
+ static integer nbet, ntra;
+ static logical rewi;
+ extern /* Subroutine */ int dchk1_(), dchk2_(), dchk3_(), dchk4_(),
+ dchk5_();
+ static doublereal c__[4225] /* was [65][65] */, g[65];
+ static integer i__, j;
+ extern doublereal ddiff_();
+ static integer n;
+ static logical fatal;
+ static doublereal w[130];
+ extern /* Subroutine */ int dmmch_();
+ static logical trace;
+ static integer nidim;
+ static char snaps[32];
+ static integer isnum;
+ static logical ltest[6];
+ static doublereal aa[4225], ab[8450] /* was [65][130] */, bb[4225],
+ cc[4225], as[4225], bs[4225], cs[4225], ct[65];
+ static logical sfatal, corder;
+ static char snamet[12], transa[1], transb[1];
+ static doublereal thresh;
+ static logical rorder;
+ extern /* Subroutine */ int cd3chke_();
+ static integer layout;
+ static logical ltestt, tsterr;
+ static doublereal alf[7];
+ extern logical lde_();
+ static doublereal bet[7], eps, err;
+ char tmpchar;
+
+/* Test program for the DOUBLE PRECISION Level 3 Blas. */
+
+/* The program must be driven by a short data file. The first 13 records */
+/* of the file are read using list-directed input, the last 6 records */
+/* are read using the format ( A12, L2 ). An annotated example of a data */
+/* file can be obtained by deleting the first 3 characters from the */
+/* following 19 lines: */
+/* 'DBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE */
+/* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) */
+/* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. */
+/* F LOGICAL FLAG, T TO STOP ON FAILURES. */
+/* T LOGICAL FLAG, T TO TEST ERROR EXITS. */
+/* 2 0 TO TEST COLUMN-MAJOR, 1 TO TEST ROW-MAJOR, 2 TO TEST BOTH */
+/* 16.0 THRESHOLD VALUE OF TEST RATIO */
+/* 6 NUMBER OF VALUES OF N */
+/* 0 1 2 3 5 9 VALUES OF N */
+/* 3 NUMBER OF VALUES OF ALPHA */
+/* 0.0 1.0 0.7 VALUES OF ALPHA */
+/* 3 NUMBER OF VALUES OF BETA */
+/* 0.0 1.0 1.3 VALUES OF BETA */
+/* cblas_dgemm T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_dsymm T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_dtrmm T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_dtrsm T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_dsyrk T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_dsyr2k T PUT F FOR NO TEST. SAME COLUMNS. */
+
+/* See: */
+
+/* Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. */
+/* A Set of Level 3 Basic Linear Algebra Subprograms. */
+
+/* Technical Memorandum No.88 (Revision 1), Mathematics and */
+/* Computer Science Division, Argonne National Laboratory, 9700 */
+/* South Cass Avenue, Argonne, Illinois 60439, US. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+
+/* Read name and unit number for summary output file and open file. */
+
+ infoc_1.noutc = 6;
+/* Read name and unit number for snapshot output file and open file. */
+
+ char line[80];
+
+ fgets(line,80,stdin);
+ sscanf(line,"'%s'",snaps);
+ fgets(line,80,stdin);
+ sscanf(line,"%d",&ntra);
+ trace = ntra >= 0;
+ if (trace) {
+/* o__1.oerr = 0;
+ o__1.ounit = ntra;
+ o__1.ofnmlen = 32;
+ o__1.ofnm = snaps;
+ o__1.orl = 0;
+ o__1.osta = "NEW";
+ o__1.oacc = 0;
+ o__1.ofm = 0;
+ o__1.oblnk = 0;
+ f_open(&o__1);*/
+ }
+/* Read the flag that directs rewinding of the snapshot file. */
+ fgets(line,80,stdin);
+ sscanf(line,"%d",&rewi);
+ rewi = rewi && trace;
+/* Read the flag that directs stopping on any failure. */
+ fgets(line,80,stdin);
+ sscanf(line,"%c",&tmpchar);
+/* Read the flag that indicates whether error exits are to be tested. */
+ sfatal=FALSE_;
+ if (tmpchar=='T')sfatal=TRUE_;
+ fgets(line,80,stdin);
+ sscanf(line,"%c",&tmpchar);
+/* Read the flag that indicates whether error exits are to be tested. */
+ tsterr=FALSE_;
+ if (tmpchar=='T')tsterr=TRUE_;
+/* Read the flag that indicates whether row-major data layout to be tested. */
+ fgets(line,80,stdin);
+ sscanf(line,"%d",&layout);
+/* Read the threshold value of the test ratio */
+ fgets(line,80,stdin);
+ sscanf(line,"%lf",&thresh);
+/* Read and check the parameter values for the tests. */
+
+/* Values of N */
+ fgets(line,80,stdin);
+ 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__ (); }*/
--- /dev/null
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#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<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conjf(Cf(&x[i]))._Val[0] * Cf(&y[i])._Val[0];
+ zdotc._Val[1] += conjf(Cf(&x[i]))._Val[1] * Cf(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conjf(Cf(&x[i*incx]))._Val[0] * Cf(&y[i*incy])._Val[0];
+ zdotc._Val[1] += conjf(Cf(&x[i*incx]))._Val[1] * Cf(&y[i*incy])._Val[1];
+ }
+ }
+ pCf(z) = zdotc;
+}
+#else
+ _Complex float zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+ }
+ }
+ pCf(z) = zdotc;
+}
+#endif
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Dcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conj(Cd(&x[i]))._Val[0] * Cd(&y[i])._Val[0];
+ zdotc._Val[1] += conj(Cd(&x[i]))._Val[1] * Cd(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conj(Cd(&x[i*incx]))._Val[0] * Cd(&y[i*incy])._Val[0];
+ zdotc._Val[1] += conj(Cd(&x[i*incx]))._Val[1] * Cd(&y[i*incy])._Val[1];
+ }
+ }
+ pCd(z) = zdotc;
+}
+#else
+ _Complex double zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+ }
+ }
+ pCd(z) = zdotc;
+}
+#endif
+static inline void cdotu_(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<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cf(&x[i])._Val[0] * Cf(&y[i])._Val[0];
+ zdotc._Val[1] += Cf(&x[i])._Val[1] * Cf(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cf(&x[i*incx])._Val[0] * Cf(&y[i*incy])._Val[0];
+ zdotc._Val[1] += Cf(&x[i*incx])._Val[1] * Cf(&y[i*incy])._Val[1];
+ }
+ }
+ pCf(z) = zdotc;
+}
+#else
+ _Complex float zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cf(&x[i]) * Cf(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+ }
+ }
+ pCf(z) = zdotc;
+}
+#endif
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Dcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cd(&x[i])._Val[0] * Cd(&y[i])._Val[0];
+ zdotc._Val[1] += Cd(&x[i])._Val[1] * Cd(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cd(&x[i*incx])._Val[0] * Cd(&y[i*incy])._Val[0];
+ zdotc._Val[1] += Cd(&x[i*incx])._Val[1] * Cd(&y[i*incy])._Val[1];
+ }
+ }
+ pCd(z) = zdotc;
+}
+#else
+ _Complex double zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cd(&x[i]) * Cd(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+ }
+ }
+ pCd(z) = zdotc;
+}
+#endif
+
+
+
+/* Common Block Declarations */
+
+struct {
+ integer icase, n, incx, incy, mode;
+ logical pass;
+} combla_;
+
+#define combla_1 combla_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b34 = (float)1.;
+
+/* Main program */ int main ()
+{
+ /* Initialized data */
+
+ static real sfac = (float)9.765625e-4;
+
+ /* Local variables */
+ extern /* Subroutine */ int check0_(), check1_(), check2_(), check3_();
+ static integer ic;
+ extern /* Subroutine */ int header_();
+
+/* Test program for the REAL Level 1 CBLAS. */
+/* Based upon the original CBLAS test routine together with: */
+/* F06EAF Example Program Text */
+/* .. Parameters .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. External Subroutines .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+ printf("Real CBLAS Test Program Results\n");
+ for (ic = 1; ic <= 11; ++ic) {
+ combla_1.icase = ic;
+ header_();
+
+/* .. Initialize PASS, INCX, INCY, and MODE for a new case. .. */
+/* .. the value 9999 for INCX, INCY or MODE will appear in the .. */
+/* .. detailed output, if any, for cases that do not involve .. */
+/* .. these parameters .. */
+
+ combla_1.pass = TRUE_;
+ combla_1.incx = 9999;
+ combla_1.incy = 9999;
+ combla_1.mode = 9999;
+ if (combla_1.icase == 3) {
+ check0_(&sfac);
+ } else if (combla_1.icase == 7 || combla_1.icase == 8 ||
+ combla_1.icase == 9 || combla_1.icase == 10) {
+ check1_(&sfac);
+ } else if (combla_1.icase == 1 || combla_1.icase == 2 ||
+ combla_1.icase == 5 || combla_1.icase == 6) {
+ check2_(&sfac);
+ } else if (combla_1.icase == 4 || combla_1.icase == 11) {
+ check3_(&sfac);
+ }
+/* -- Print */
+ if (combla_1.pass) {
+ printf(" ----- PASS -----\n");
+ }
+/* L20: */
+ }
+ exit(0);
+} /* MAIN__ */
+
+/* Subroutine */ int header_()
+{
+ /* Initialized data */
+
+ static char l[15][13] = {"CBLAS_SDOT " , "CBLAS_SAXPY " , "CBLAS_SROTG " ,
+ "CBLAS_SROT " , "CBLAS_SCOPY " , "CBLAS_SSWAP " , "CBLAS_SNRM2 " , "CBLAS_SASUM ",
+ "CBLAS_SSCAL " , "CBLAS_ISAMAX", "CBLAS_SROTM "};
+
+ /* Fortran I/O blocks */
+
+
+/* .. Parameters .. */
+/* .. Scalars in Common .. */
+/* .. Local Arrays .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+ printf("\nTest of subprogram number %3d %15s",combla_1.icase,l[combla_1.icase-1]);
+
+ return 0;
+
+} /* header_ */
+
+/* Subroutine */ int check0_(sfac)
+real *sfac;
+{
+ /* Initialized data */
+
+ static real ds1[8] = { (float).8,(float).6,(float).8,(float)-.6,(float).8,
+ (float)0.,(float)1.,(float)0. };
+ static real datrue[8] = { (float).5,(float).5,(float).5,(float)-.5,(float)
+ -.5,(float)0.,(float)1.,(float)1. };
+ static real dbtrue[8] = { (float)0.,(float).6,(float)0.,(float)-.6,(float)
+ 0.,(float)0.,(float)1.,(float)0. };
+ static real da1[8] = { (float).3,(float).4,(float)-.3,(float)-.4,(float)
+ -.3,(float)0.,(float)0.,(float)1. };
+ static real db1[8] = { (float).4,(float).3,(float).4,(float).3,(float)-.4,
+ (float)0.,(float)1.,(float)0. };
+ static real dc1[8] = { (float).6,(float).8,(float)-.6,(float).8,(float).6,
+ (float)1.,(float)0.,(float)1. };
+
+ /* Local variables */
+ static integer k;
+ extern /* Subroutine */ int srotgtest_(), stest1_();
+ static real sa, sb, sc, ss;
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Subroutines .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+
+/* Compute true values which cannot be prestored */
+/* in decimal notation */
+
+ dbtrue[0] = (float)1.6666666666666667;
+ dbtrue[2] = (float)-1.6666666666666667;
+ dbtrue[4] = (float)1.6666666666666667;
+
+ for (k = 1; k <= 8; ++k) {
+/* .. Set N=K for identification in output if any .. */
+ combla_1.n = k;
+ if (combla_1.icase == 3) {
+/* .. SROTGTEST .. */
+ if (k > 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_ */
+
--- /dev/null
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#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<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conjf(Cf(&x[i]))._Val[0] * Cf(&y[i])._Val[0];
+ zdotc._Val[1] += conjf(Cf(&x[i]))._Val[1] * Cf(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conjf(Cf(&x[i*incx]))._Val[0] * Cf(&y[i*incy])._Val[0];
+ zdotc._Val[1] += conjf(Cf(&x[i*incx]))._Val[1] * Cf(&y[i*incy])._Val[1];
+ }
+ }
+ pCf(z) = zdotc;
+}
+#else
+ _Complex float zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+ }
+ }
+ pCf(z) = zdotc;
+}
+#endif
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Dcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conj(Cd(&x[i]))._Val[0] * Cd(&y[i])._Val[0];
+ zdotc._Val[1] += conj(Cd(&x[i]))._Val[1] * Cd(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conj(Cd(&x[i*incx]))._Val[0] * Cd(&y[i*incy])._Val[0];
+ zdotc._Val[1] += conj(Cd(&x[i*incx]))._Val[1] * Cd(&y[i*incy])._Val[1];
+ }
+ }
+ pCd(z) = zdotc;
+}
+#else
+ _Complex double zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+ }
+ }
+ pCd(z) = zdotc;
+}
+#endif
+static inline void cdotu_(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<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cf(&x[i])._Val[0] * Cf(&y[i])._Val[0];
+ zdotc._Val[1] += Cf(&x[i])._Val[1] * Cf(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cf(&x[i*incx])._Val[0] * Cf(&y[i*incy])._Val[0];
+ zdotc._Val[1] += Cf(&x[i*incx])._Val[1] * Cf(&y[i*incy])._Val[1];
+ }
+ }
+ pCf(z) = zdotc;
+}
+#else
+ _Complex float zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cf(&x[i]) * Cf(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+ }
+ }
+ pCf(z) = zdotc;
+}
+#endif
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Dcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cd(&x[i])._Val[0] * Cd(&y[i])._Val[0];
+ zdotc._Val[1] += Cd(&x[i])._Val[1] * Cd(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cd(&x[i*incx])._Val[0] * Cd(&y[i*incy])._Val[0];
+ zdotc._Val[1] += Cd(&x[i*incx])._Val[1] * Cd(&y[i*incy])._Val[1];
+ }
+ }
+ pCd(z) = zdotc;
+}
+#else
+ _Complex double zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cd(&x[i]) * Cd(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+ }
+ }
+ pCd(z) = zdotc;
+}
+#endif
+/* -- translated by f2c (version 20000121).
+ You must link the resulting object file with the libraries:
+ -lf2c -lm (in that order)
+*/
+
+
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, noutc;
+ logical ok;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[12];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__65 = 65;
+static integer c__2 = 2;
+static real c_b123 = (float)1.;
+static real c_b135 = (float)0.;
+static integer c__6 = 6;
+static logical c_true = TRUE_;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static logical c_false = FALSE_;
+
+/* Main program */ int main()
+{
+ /* Initialized data */
+
+ static char snames[16][13] = { "cblas_sgemv ", "cblas_sgbmv ", "cblas_ssymv ",
+ "cblas_ssbmv ", "cblas_sspmv ", "cblas_strmv ", "cblas_stbmv ", "cblas_stpmv ",
+ "cblas_strsv ", "cblas_stbsv ", "cblas_stpsv ", "cblas_sger ", "cblas_ssyr ",
+ "cblas_sspr ", "cblas_ssyr2 ", "cblas_sspr2 "};
+
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ real r__1;
+
+ /* Local variables */
+ static integer nalf, idim[9];
+ static logical same;
+ static integer ninc, nbet, ntra;
+ static logical rewi;
+ extern /* Subroutine */ int schk1_(), schk2_(), schk3_(), schk4_(),
+ schk5_(), schk6_();
+ static real a[4225] /* was [65][65] */, g[65];
+ static integer i__, j, n;
+ static logical fatal;
+ static real x[65], y[65], z__[130];
+ extern doublereal sdiff_();
+ static logical trace;
+ static integer nidim;
+ extern /* Subroutine */ int smvch_();
+ static char snaps[32], trans[1];
+ static integer isnum;
+ static logical ltest[16];
+ static real aa[4225];
+ static integer kb[7];
+ static real as[4225];
+ static logical sfatal;
+ static real xs[130], ys[130];
+ static logical corder;
+ static real xx[130], yt[65], yy[130];
+ static char snamet[12];
+ static real thresh;
+ static logical rorder;
+ static integer layout;
+ static logical ltestt;
+ extern /* Subroutine */ int cs2chke_();
+ static logical tsterr;
+ static real alf[7];
+ static integer inc[7], nkb;
+ static real bet[7];
+ extern logical lse_();
+ static real eps, err;
+ char tmpchar;
+
+/* Test program for the REAL Level 2 Blas. */
+
+/* The program must be driven by a short data file. The first 17 records */
+/* of the file are read using list-directed input, the last 16 records */
+/* are read using the format ( A12, L2 ). An annotated example of a data */
+/* file can be obtained by deleting the first 3 characters from the */
+/* following 33 lines: */
+/* 'SBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE */
+/* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) */
+/* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. */
+/* F LOGICAL FLAG, T TO STOP ON FAILURES. */
+/* T LOGICAL FLAG, T TO TEST ERROR EXITS. */
+/* 2 0 TO TEST COLUMN-MAJOR, 1 TO TEST ROW-MAJOR, 2 TO TEST BOTH */
+/* 16.0 THRESHOLD VALUE OF TEST RATIO */
+/* 6 NUMBER OF VALUES OF N */
+/* 0 1 2 3 5 9 VALUES OF N */
+/* 4 NUMBER OF VALUES OF K */
+/* 0 1 2 4 VALUES OF K */
+/* 4 NUMBER OF VALUES OF INCX AND INCY */
+/* 1 2 -1 -2 VALUES OF INCX AND INCY */
+/* 3 NUMBER OF VALUES OF ALPHA */
+/* 0.0 1.0 0.7 VALUES OF ALPHA */
+/* 3 NUMBER OF VALUES OF BETA */
+/* 0.0 1.0 0.9 VALUES OF BETA */
+/* cblas_sgemv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_sgbmv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_ssymv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_ssbmv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_sspmv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_strmv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_stbmv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_stpmv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_strsv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_stbsv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_stpsv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_sger T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_ssyr T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_sspr T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_ssyr2 T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_sspr2 T PUT F FOR NO TEST. SAME COLUMNS. */
+
+/* See: */
+
+/* Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J.. */
+/* An extended set of Fortran Basic Linear Algebra Subprograms. */
+
+/* Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics */
+/* and Computer Science Division, Argonne National Laboratory, */
+/* 9700 South Cass Avenue, Argonne, Illinois 60439, US. */
+
+/* Or */
+
+/* NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms */
+/* Group Ltd., NAG Central Office, 256 Banbury Road, Oxford */
+/* OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st */
+/* Street, Suite 100, Downers Grove, Illinois 60515-1263, USA. */
+
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+
+ infoc_1.noutc = 6;
+
+/* Read name and unit number for snapshot output file and open file. */
+
+ char line[80];
+
+ fgets(line,80,stdin);
+ sscanf(line,"'%s'",snaps);
+ fgets(line,80,stdin);
+ sscanf(line,"%d",&ntra);
+ trace = ntra >= 0;
+
+ if (trace) {
+/* o__1.oerr = 0;
+ o__1.ounit = ntra;
+ o__1.ofnmlen = 32;
+ o__1.ofnm = snaps;
+ o__1.orl = 0;
+ o__1.osta = 0;
+ o__1.oacc = 0;
+ o__1.ofm = 0;
+ o__1.oblnk = 0;
+ f_open(&o__1);*/
+ }
+/* Read the flag that directs rewinding of the snapshot file. */
+ fgets(line,80,stdin);
+ sscanf(line,"%d",&rewi);
+ rewi = rewi && trace;
+/* Read the flag that directs stopping on any failure. */
+ fgets(line,80,stdin);
+ sscanf(line,"%c",&tmpchar);
+/* 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_ */
+
--- /dev/null
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#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<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conjf(Cf(&x[i]))._Val[0] * Cf(&y[i])._Val[0];
+ zdotc._Val[1] += conjf(Cf(&x[i]))._Val[1] * Cf(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conjf(Cf(&x[i*incx]))._Val[0] * Cf(&y[i*incy])._Val[0];
+ zdotc._Val[1] += conjf(Cf(&x[i*incx]))._Val[1] * Cf(&y[i*incy])._Val[1];
+ }
+ }
+ pCf(z) = zdotc;
+}
+#else
+ _Complex float zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+ }
+ }
+ pCf(z) = zdotc;
+}
+#endif
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Dcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conj(Cd(&x[i]))._Val[0] * Cd(&y[i])._Val[0];
+ zdotc._Val[1] += conj(Cd(&x[i]))._Val[1] * Cd(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conj(Cd(&x[i*incx]))._Val[0] * Cd(&y[i*incy])._Val[0];
+ zdotc._Val[1] += conj(Cd(&x[i*incx]))._Val[1] * Cd(&y[i*incy])._Val[1];
+ }
+ }
+ pCd(z) = zdotc;
+}
+#else
+ _Complex double zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+ }
+ }
+ pCd(z) = zdotc;
+}
+#endif
+static inline void cdotu_(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<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cf(&x[i])._Val[0] * Cf(&y[i])._Val[0];
+ zdotc._Val[1] += Cf(&x[i])._Val[1] * Cf(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cf(&x[i*incx])._Val[0] * Cf(&y[i*incy])._Val[0];
+ zdotc._Val[1] += Cf(&x[i*incx])._Val[1] * Cf(&y[i*incy])._Val[1];
+ }
+ }
+ pCf(z) = zdotc;
+}
+#else
+ _Complex float zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cf(&x[i]) * Cf(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+ }
+ }
+ pCf(z) = zdotc;
+}
+#endif
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Dcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cd(&x[i])._Val[0] * Cd(&y[i])._Val[0];
+ zdotc._Val[1] += Cd(&x[i])._Val[1] * Cd(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cd(&x[i*incx])._Val[0] * Cd(&y[i*incy])._Val[0];
+ zdotc._Val[1] += Cd(&x[i*incx])._Val[1] * Cd(&y[i*incy])._Val[1];
+ }
+ }
+ pCd(z) = zdotc;
+}
+#else
+ _Complex double zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cd(&x[i]) * Cd(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+ }
+ }
+ pCd(z) = zdotc;
+}
+#endif
+/* -- translated by f2c (version 20000121).
+ You must link the resulting object file with the libraries:
+ -lf2c -lm (in that order)
+*/
+
+
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, noutc;
+ logical ok;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[12];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__65 = 65;
+static real c_b89 = (float)1.;
+static real c_b103 = (float)0.;
+static integer c__6 = 6;
+static logical c_true = TRUE_;
+static integer c__0 = 0;
+static logical c_false = FALSE_;
+
+/* Main program MAIN__() */ int main()
+{
+ /* Initialized data */
+
+ static char snames[6][13] = {"cblas_sgemm ", "cblas_ssymm ", "cblas_strmm ", "cblas_strsm ", "cblas_ssyrk ", "cblas_ssyr2k"};
+
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ real r__1;
+ /* Builtin functions */
+ integer s_rsle(), do_lio(), e_rsle(), f_open(), s_wsfe(), do_fio(),
+ e_wsfe(), s_wsle(), e_wsle(), s_rsfe(), e_rsfe();
+ integer f_clos();
+
+ /* Local variables */
+ static integer nalf, idim[9];
+ static logical same;
+ static integer nbet, ntra;
+ static logical rewi;
+ extern /* Subroutine */ int schk1_(), schk2_(), schk3_(), schk4_(),
+ schk5_();
+ static real c__[4225] /* was [65][65] */, g[65];
+ static integer i__, j, n;
+ static logical fatal;
+ static real w[130];
+ extern doublereal sdiff_();
+ static logical trace;
+ static integer nidim;
+ extern /* Subroutine */ int smmch_();
+ static char snaps[32];
+ static integer isnum;
+ static logical ltest[6];
+ static real aa[4225], ab[8450] /* was [65][130] */, bb[4225], cc[
+ 4225], as[4225], bs[4225], cs[4225], ct[65];
+ static logical sfatal, corder;
+ static char snamet[12], transa[1], transb[1];
+ static real thresh;
+ static logical rorder;
+ static integer layout;
+ static logical ltestt, tsterr;
+ extern /* Subroutine */ int cs3chke_();
+ static real alf[7], bet[7];
+ extern logical lse_();
+ static real eps, err;
+ char tmpchar;
+
+/* Test program for the REAL Level 3 Blas. */
+
+/* The program must be driven by a short data file. The first 13 records */
+/* of the file are read using list-directed input, the last 6 records */
+/* are read using the format ( A12, L2 ). An annotated example of a data */
+/* file can be obtained by deleting the first 3 characters from the */
+/* following 19 lines: */
+/* 'SBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE */
+/* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) */
+/* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. */
+/* F LOGICAL FLAG, T TO STOP ON FAILURES. */
+/* T LOGICAL FLAG, T TO TEST ERROR EXITS. */
+/* 2 0 TO TEST COLUMN-MAJOR, 1 TO TEST ROW-MAJOR, 2 TO TEST BOTH */
+/* 16.0 THRESHOLD VALUE OF TEST RATIO */
+/* 6 NUMBER OF VALUES OF N */
+/* 0 1 2 3 5 9 VALUES OF N */
+/* 3 NUMBER OF VALUES OF ALPHA */
+/* 0.0 1.0 0.7 VALUES OF ALPHA */
+/* 3 NUMBER OF VALUES OF BETA */
+/* 0.0 1.0 1.3 VALUES OF BETA */
+/* cblas_sgemm T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_ssymm T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_strmm T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_strsm T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_ssyrk T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_ssyr2k T PUT F FOR NO TEST. SAME COLUMNS. */
+
+/* See: */
+
+/* Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. */
+/* A Set of Level 3 Basic Linear Algebra Subprograms. */
+
+/* Technical Memorandum No.88 (Revision 1), Mathematics and */
+/* Computer Science Division, Argonne National Laboratory, 9700 */
+/* South Cass Avenue, Argonne, Illinois 60439, US. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+
+ infoc_1.noutc = 6;
+/* Read name and unit number for summary output file and open file. */
+
+ char line[80];
+
+ fgets(line,80,stdin);
+ sscanf(line,"'%s'",snaps);
+ fgets(line,80,stdin);
+ sscanf(line,"%d",&ntra);
+ trace = ntra >= 0;
+ if (trace) {
+/* OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' ) */
+/* o__1.ounit = ntra;
+ o__1.ofnmlen = 32;
+ o__1.ofnm = snaps;
+ o__1.orl = 0;
+ o__1.osta = 0;
+ o__1.oacc = 0;
+ o__1.ofm = 0;
+ o__1.oblnk = 0;
+ f_open(&o__1);*/
+ }
+/* Read the flag that directs rewinding of the snapshot file. */
+ fgets(line,80,stdin);
+ sscanf(line,"%d",&rewi);
+ rewi = rewi && trace;
+/* Read the flag that directs stopping on any failure. */
+ fgets(line,80,stdin);
+ sscanf(line,"%c",&tmpchar);
+/* Read the flag that indicates whether error exits are to be tested. */
+ sfatal=FALSE_;
+ if (tmpchar=='T')sfatal=TRUE_;
+ fgets(line,80,stdin);
+ sscanf(line,"%c",&tmpchar);
+/* Read the flag that indicates whether error exits are to be tested. */
+ tsterr=FALSE_;
+ if (tmpchar=='T')tsterr=TRUE_;
+/* Read the flag that indicates whether row-major data layout to be tested. */
+ fgets(line,80,stdin);
+ sscanf(line,"%d",&layout);
+/* Read the threshold value of the test ratio */
+ fgets(line,80,stdin);
+ sscanf(line,"%f",&thresh);
+
+/* Read and check the parameter values for the tests. */
+
+/* Values of N */
+ fgets(line,80,stdin);
+ 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__ (); }*/
--- /dev/null
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#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<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conjf(Cf(&x[i]))._Val[0] * Cf(&y[i])._Val[0];
+ zdotc._Val[1] += conjf(Cf(&x[i]))._Val[1] * Cf(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conjf(Cf(&x[i*incx]))._Val[0] * Cf(&y[i*incy])._Val[0];
+ zdotc._Val[1] += conjf(Cf(&x[i*incx]))._Val[1] * Cf(&y[i*incy])._Val[1];
+ }
+ }
+ pCf(z) = zdotc;
+}
+#else
+ _Complex float zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+ }
+ }
+ pCf(z) = zdotc;
+}
+#endif
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Dcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conj(Cd(&x[i]))._Val[0] * Cd(&y[i])._Val[0];
+ zdotc._Val[1] += conj(Cd(&x[i]))._Val[1] * Cd(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conj(Cd(&x[i*incx]))._Val[0] * Cd(&y[i*incy])._Val[0];
+ zdotc._Val[1] += conj(Cd(&x[i*incx]))._Val[1] * Cd(&y[i*incy])._Val[1];
+ }
+ }
+ pCd(z) = zdotc;
+}
+#else
+ _Complex double zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+ }
+ }
+ pCd(z) = zdotc;
+}
+#endif
+static inline void cdotu_(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<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cf(&x[i])._Val[0] * Cf(&y[i])._Val[0];
+ zdotc._Val[1] += Cf(&x[i])._Val[1] * Cf(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cf(&x[i*incx])._Val[0] * Cf(&y[i*incy])._Val[0];
+ zdotc._Val[1] += Cf(&x[i*incx])._Val[1] * Cf(&y[i*incy])._Val[1];
+ }
+ }
+ pCf(z) = zdotc;
+}
+#else
+ _Complex float zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cf(&x[i]) * Cf(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+ }
+ }
+ pCf(z) = zdotc;
+}
+#endif
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Dcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cd(&x[i])._Val[0] * Cd(&y[i])._Val[0];
+ zdotc._Val[1] += Cd(&x[i])._Val[1] * Cd(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cd(&x[i*incx])._Val[0] * Cd(&y[i*incy])._Val[0];
+ zdotc._Val[1] += Cd(&x[i*incx])._Val[1] * Cd(&y[i*incy])._Val[1];
+ }
+ }
+ pCd(z) = zdotc;
+}
+#else
+ _Complex double zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cd(&x[i]) * Cd(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+ }
+ }
+ pCd(z) = zdotc;
+}
+#endif
+
+/* Common Block Declarations */
+
+struct {
+ integer icase, n, incx, incy, mode;
+ logical pass;
+} combla_;
+
+#define combla_1 combla_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__5 = 5;
+static doublereal c_b43 = 1.;
+
+/* Main program */ int main()
+{
+ /* Initialized data */
+
+ static doublereal sfac = 9.765625e-4;
+
+ /* Local variables */
+ extern /* Subroutine */ int check1_(), check2_();
+ static integer ic;
+ extern /* Subroutine */ int header_();
+
+/* Test program for the COMPLEX*16 Level 1 CBLAS. */
+/* Based upon the original CBLAS test routine together with: */
+/* F06GAF Example Program Text */
+/* .. Parameters .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. External Subroutines .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+ printf("Complex CBLAS Test Program Results\n");
+ for (ic = 1; ic <= 10; ++ic) {
+ combla_1.icase = ic;
+ header_();
+
+/* Initialize PASS, INCX, INCY, and MODE for a new case. */
+/* The value 9999 for INCX, INCY or MODE will appear in the */
+/* detailed output, if any, for cases that do not involve */
+/* these parameters. */
+
+ combla_1.pass = TRUE_;
+ combla_1.incx = 9999;
+ combla_1.incy = 9999;
+ combla_1.mode = 9999;
+ if (combla_1.icase <= 5) {
+ check2_(&sfac);
+ } else if (combla_1.icase >= 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_ */
+
--- /dev/null
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#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<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conjf(Cf(&x[i]))._Val[0] * Cf(&y[i])._Val[0];
+ zdotc._Val[1] += conjf(Cf(&x[i]))._Val[1] * Cf(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conjf(Cf(&x[i*incx]))._Val[0] * Cf(&y[i*incy])._Val[0];
+ zdotc._Val[1] += conjf(Cf(&x[i*incx]))._Val[1] * Cf(&y[i*incy])._Val[1];
+ }
+ }
+ pCf(z) = zdotc;
+}
+#else
+ _Complex float zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+ }
+ }
+ pCf(z) = zdotc;
+}
+#endif
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Dcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conj(Cd(&x[i]))._Val[0] * Cd(&y[i])._Val[0];
+ zdotc._Val[1] += conj(Cd(&x[i]))._Val[1] * Cd(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conj(Cd(&x[i*incx]))._Val[0] * Cd(&y[i*incy])._Val[0];
+ zdotc._Val[1] += conj(Cd(&x[i*incx]))._Val[1] * Cd(&y[i*incy])._Val[1];
+ }
+ }
+ pCd(z) = zdotc;
+}
+#else
+ _Complex double zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+ }
+ }
+ pCd(z) = zdotc;
+}
+#endif
+static inline void cdotu_(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<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cf(&x[i])._Val[0] * Cf(&y[i])._Val[0];
+ zdotc._Val[1] += Cf(&x[i])._Val[1] * Cf(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cf(&x[i*incx])._Val[0] * Cf(&y[i*incy])._Val[0];
+ zdotc._Val[1] += Cf(&x[i*incx])._Val[1] * Cf(&y[i*incy])._Val[1];
+ }
+ }
+ pCf(z) = zdotc;
+}
+#else
+ _Complex float zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cf(&x[i]) * Cf(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+ }
+ }
+ pCf(z) = zdotc;
+}
+#endif
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Dcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cd(&x[i])._Val[0] * Cd(&y[i])._Val[0];
+ zdotc._Val[1] += Cd(&x[i])._Val[1] * Cd(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cd(&x[i*incx])._Val[0] * Cd(&y[i*incy])._Val[0];
+ zdotc._Val[1] += Cd(&x[i*incx])._Val[1] * Cd(&y[i*incy])._Val[1];
+ }
+ }
+ pCd(z) = zdotc;
+}
+#else
+ _Complex double zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cd(&x[i]) * Cd(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+ }
+ }
+ pCd(z) = zdotc;
+}
+#endif
+/* -- translated by f2c (version 20000121).
+ You must link the resulting object file with the libraries:
+ -lf2c -lm (in that order)
+*/
+
+
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, noutc;
+ logical ok;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[12];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+static integer c__65 = 65;
+static integer c__2 = 2;
+static doublereal c_b125 = 1.;
+static integer c__6 = 6;
+static logical c_true = TRUE_;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static logical c_false = FALSE_;
+
+/* Main program */ int main()
+{
+ /* Initialized data */
+
+ static char snames[17][13] = { "cblas_zgemv " , "cblas_zgbmv " , "cblas_zhemv ",
+ "cblas_zhbmv ", "cblas_zhpmv ", "cblas_ztrmv " , "cblas_ztbmv " , "cblas_ztpmv ",
+ "cblas_ztrsv ", "cblas_ztbsv ", "cblas_ztpsv " , "cblas_zgerc " , "cblas_zgeru ",
+ "cblas_zher ", "cblas_zhpr ", "cblas_zher2 " , "cblas_zhpr2 " };
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1;
+
+ /* Local variables */
+ static integer nalf, idim[9];
+ static logical same;
+ static integer ninc, nbet, ntra;
+ static logical rewi;
+ extern /* Subroutine */ int zchk1_(), zchk2_(), zchk3_(), zchk4_(),
+ zchk5_(), zchk6_();
+ static doublecomplex a[4225] /* was [65][65] */;
+ static doublereal g[65];
+ static integer i__, j;
+ extern doublereal ddiff_();
+ static integer n;
+ static logical fatal;
+ static doublecomplex x[65], y[65], z__[130];
+ static logical trace;
+ static integer nidim;
+ static char snaps[32], trans[1];
+ extern /* Subroutine */ int zmvch_();
+ static integer isnum;
+ static logical ltest[17];
+ static doublecomplex aa[4225];
+ static integer kb[7];
+ static doublecomplex as[4225];
+ static logical sfatal;
+ static doublecomplex xs[130], ys[130];
+ static logical corder;
+ static doublecomplex xx[130], yt[65], yy[130];
+ static char snamet[12];
+ static doublereal thresh;
+ static logical rorder;
+ static integer layout;
+ static logical ltestt, tsterr;
+ extern /* Subroutine */ int cz2chke_();
+ static doublecomplex alf[7];
+ static integer inc[7], nkb;
+ static doublecomplex bet[7];
+ static doublereal eps, err;
+ extern logical lze_();
+ char tmpchar;
+
+/* Test program for the DOUBLE PRECISION COMPLEX Level 2 Blas. */
+
+/* The program must be driven by a short data file. The first 17 records */
+/* of the file are read using list-directed input, the last 17 records */
+/* are read using the format ( A12, L2 ). An annotated example of a data */
+/* file can be obtained by deleting the first 3 characters from the */
+/* following 34 lines: */
+/* 'CBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE */
+/* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) */
+/* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. */
+/* F LOGICAL FLAG, T TO STOP ON FAILURES. */
+/* T LOGICAL FLAG, T TO TEST ERROR EXITS. */
+/* 2 0 TO TEST COLUMN-MAJOR, 1 TO TEST ROW-MAJOR, 2 TO TEST BOTH */
+/* 16.0 THRESHOLD VALUE OF TEST RATIO */
+/* 6 NUMBER OF VALUES OF N */
+/* 0 1 2 3 5 9 VALUES OF N */
+/* 4 NUMBER OF VALUES OF K */
+/* 0 1 2 4 VALUES OF K */
+/* 4 NUMBER OF VALUES OF INCX AND INCY */
+/* 1 2 -1 -2 VALUES OF INCX AND INCY */
+/* 3 NUMBER OF VALUES OF ALPHA */
+/* (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA */
+/* 3 NUMBER OF VALUES OF BETA */
+/* (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA */
+/* cblas_zgemv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_zgbmv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_zhemv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_zhbmv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_zhpmv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_ztrmv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_ztbmv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_ztpmv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_ztrsv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_ztbsv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_ztpsv T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_zgerc T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_zgeru T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_zher T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_zhpr T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_zher2 T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_zhpr2 T PUT F FOR NO TEST. SAME COLUMNS. */
+
+/* See: */
+
+/* Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J.. */
+/* An extended set of Fortran Basic Linear Algebra Subprograms. */
+
+/* Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics */
+/* and Computer Science Division, Argonne National Laboratory, */
+/* 9700 South Cass Avenue, Argonne, Illinois 60439, US. */
+
+/* Or */
+
+/* NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms */
+/* Group Ltd., NAG Central Office, 256 Banbury Road, Oxford */
+/* OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st */
+/* Street, Suite 100, Downers Grove, Illinois 60515-1263, USA. */
+
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+
+ infoc_1.noutc = 6;
+
+/* Read name and unit number for summary output file and open file. */
+
+ char line[80];
+
+ fgets(line,80,stdin);
+ sscanf(line,"'%s'",snaps);
+ fgets(line,80,stdin);
+ sscanf(line,"%d",&ntra);
+ trace = ntra >= 0;
+ if (trace) {
+/* o__1.oerr = 0;
+ o__1.ounit = ntra;
+ o__1.ofnmlen = 32;
+ o__1.ofnm = snaps;
+ o__1.orl = 0;
+ o__1.osta = 0;
+ o__1.oacc = 0;
+ o__1.ofm = 0;
+ o__1.oblnk = 0;
+ f_open(&o__1);*/
+ }
+/* Read the flag that directs rewinding of the snapshot file. */
+ fgets(line,80,stdin);
+ sscanf(line,"%d",&rewi);
+ rewi = rewi && trace;
+/* Read the flag that directs stopping on any failure. */
+ fgets(line,80,stdin);
+ sscanf(line,"%c",&tmpchar);
+/* 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_ */
+
--- /dev/null
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#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<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conjf(Cf(&x[i]))._Val[0] * Cf(&y[i])._Val[0];
+ zdotc._Val[1] += conjf(Cf(&x[i]))._Val[1] * Cf(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conjf(Cf(&x[i*incx]))._Val[0] * Cf(&y[i*incy])._Val[0];
+ zdotc._Val[1] += conjf(Cf(&x[i*incx]))._Val[1] * Cf(&y[i*incy])._Val[1];
+ }
+ }
+ pCf(z) = zdotc;
+}
+#else
+ _Complex float zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
+ }
+ }
+ pCf(z) = zdotc;
+}
+#endif
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Dcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conj(Cd(&x[i]))._Val[0] * Cd(&y[i])._Val[0];
+ zdotc._Val[1] += conj(Cd(&x[i]))._Val[1] * Cd(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += conj(Cd(&x[i*incx]))._Val[0] * Cd(&y[i*incy])._Val[0];
+ zdotc._Val[1] += conj(Cd(&x[i*incx]))._Val[1] * Cd(&y[i*incy])._Val[1];
+ }
+ }
+ pCd(z) = zdotc;
+}
+#else
+ _Complex double zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
+ }
+ }
+ pCd(z) = zdotc;
+}
+#endif
+static inline void cdotu_(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<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cf(&x[i])._Val[0] * Cf(&y[i])._Val[0];
+ zdotc._Val[1] += Cf(&x[i])._Val[1] * Cf(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cf(&x[i*incx])._Val[0] * Cf(&y[i*incy])._Val[0];
+ zdotc._Val[1] += Cf(&x[i*incx])._Val[1] * Cf(&y[i*incy])._Val[1];
+ }
+ }
+ pCf(z) = zdotc;
+}
+#else
+ _Complex float zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cf(&x[i]) * Cf(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
+ }
+ }
+ pCf(z) = zdotc;
+}
+#endif
+static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Dcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cd(&x[i])._Val[0] * Cd(&y[i])._Val[0];
+ zdotc._Val[1] += Cd(&x[i])._Val[1] * Cd(&y[i])._Val[1];
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc._Val[0] += Cd(&x[i*incx])._Val[0] * Cd(&y[i*incy])._Val[0];
+ zdotc._Val[1] += Cd(&x[i*incx])._Val[1] * Cd(&y[i*incy])._Val[1];
+ }
+ }
+ pCd(z) = zdotc;
+}
+#else
+ _Complex double zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cd(&x[i]) * Cd(&y[i]);
+ }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
+ }
+ }
+ pCd(z) = zdotc;
+}
+#endif
+
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, noutc;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[12];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+static integer c__65 = 65;
+static doublereal c_b92 = 1.;
+static integer c__6 = 6;
+static logical c_true = TRUE_;
+static integer c__0 = 0;
+static logical c_false = FALSE_;
+
+/* Main program MAIN__() */ int main()
+{
+ /* Initialized data */
+
+ static char snames[9][13] = { "cblas_zgemm ", "cblas_zhemm ", "cblas_zsymm ", "cblas_ztrmm ",
+ "cblas_ztrsm ", "cblas_zherk ", "cblas_zsyrk ", "cblas_zher2k", "cblas_zsyr2k"};
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1;
+
+ /* Builtin functions */
+ integer s_rsle(), do_lio(), e_rsle(), f_open(), s_wsfe(), do_fio(),
+ e_wsfe(), s_wsle(), e_wsle(), s_rsfe(), e_rsfe();
+
+ /* Local variables */
+ static integer nalf, idim[9];
+ static logical same;
+ static integer nbet, ntra;
+ static logical rewi;
+ extern /* Subroutine */ int zchk1_(), zchk2_(), zchk3_(), zchk4_(),
+ zchk5_();
+ static doublecomplex c__[4225] /* was [65][65] */;
+ static doublereal g[65];
+ static integer i__, j;
+ extern doublereal ddiff_();
+ static integer n;
+ static logical fatal;
+ static doublecomplex w[130];
+ static logical trace;
+ static integer nidim;
+ extern /* Subroutine */ int zmmch_();
+ static char snaps[32];
+ static integer isnum;
+ static logical ltest[9];
+ static doublecomplex aa[4225], ab[8450] /* was [65][130] */, bb[4225],
+ cc[4225], as[4225], bs[4225], cs[4225], ct[65];
+ static logical sfatal, corder;
+ static char snamet[12], transa[1], transb[1];
+ static doublereal thresh;
+ static logical rorder;
+ static integer layout;
+ static logical ltestt, tsterr;
+ extern /* Subroutine */ int cz3chke_();
+ static doublecomplex alf[7], bet[7];
+ static doublereal eps, err;
+ extern logical lze_();
+ char tmpchar;
+
+/* Test program for the COMPLEX*16 Level 3 Blas. */
+
+/* The program must be driven by a short data file. The first 13 records */
+/* of the file are read using list-directed input, the last 9 records */
+/* are read using the format ( A12,L2 ). An annotated example of a data */
+/* file can be obtained by deleting the first 3 characters from the */
+/* following 22 lines: */
+/* 'CBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE */
+/* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) */
+/* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. */
+/* F LOGICAL FLAG, T TO STOP ON FAILURES. */
+/* T LOGICAL FLAG, T TO TEST ERROR EXITS. */
+/* 2 0 TO TEST COLUMN-MAJOR, 1 TO TEST ROW-MAJOR, 2 TO TEST BOTH */
+/* 16.0 THRESHOLD VALUE OF TEST RATIO */
+/* 6 NUMBER OF VALUES OF N */
+/* 0 1 2 3 5 9 VALUES OF N */
+/* 3 NUMBER OF VALUES OF ALPHA */
+/* (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA */
+/* 3 NUMBER OF VALUES OF BETA */
+/* (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA */
+/* ZGEMM T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZHEMM T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZSYMM T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZTRMM T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZTRSM T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZHERK T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZSYRK T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZHER2K T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZSYR2K T PUT F FOR NO TEST. SAME COLUMNS. */
+
+/* See: */
+
+/* Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. */
+/* A Set of Level 3 Basic Linear Algebra Subprograms. */
+
+/* Technical Memorandum No.88 (Revision 1), Mathematics and */
+/* Computer Science Division, Argonne National Laboratory, 9700 */
+/* South Cass Avenue, Argonne, Illinois 60439, US. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+
+ infoc_1.noutc = 6;
+
+/* Read name and unit number for snapshot output file and open file. */
+
+ char line[80];
+
+ fgets(line,80,stdin);
+ sscanf(line,"'%s'",snaps);
+ fgets(line,80,stdin);
+ sscanf(line,"%d",&ntra);
+ trace = ntra >= 0;
+ if (trace) {
+/* o__1.oerr = 0;
+ o__1.ounit = ntra;
+ o__1.ofnmlen = 32;
+ o__1.ofnm = snaps;
+ o__1.orl = 0;
+ o__1.osta = "NEW";
+ o__1.oacc = 0;
+ o__1.ofm = 0;
+ o__1.oblnk = 0;
+ f_open(&o__1);*/
+ }
+/* Read the flag that directs rewinding of the snapshot file. */
+ fgets(line,80,stdin);
+ sscanf(line,"%d",&rewi);
+ rewi = rewi && trace;
+/* Read the flag that directs stopping on any failure. */
+ fgets(line,80,stdin);
+ sscanf(line,"%c",&tmpchar);
+ sfatal=FALSE_;
+ if (tmpchar=='T')sfatal=TRUE_;
+/* Read the flag that indicates whether error exits are to be tested. */
+ fgets(line,80,stdin);
+ sscanf(line,"%c",&tmpchar);
+ tsterr=FALSE_;
+ if (tmpchar=='T')tsterr=TRUE_;
+/* Read the flag that indicates whether row-major data layout to be tested. */
+ fgets(line,80,stdin);
+ sscanf(line,"%d",&layout);
+/* Read the threshold value of the test ratio */
+ fgets(line,80,stdin);
+ sscanf(line,"%lf",&thresh);
+
+/* Read and check the parameter values for the tests. */
+
+/* Values of N */
+ fgets(line,80,stdin);
+ 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__ (); }*/
projects / platform / upstream / openblas.git / commitdiff